diff options
Diffstat (limited to 'new-luxc/source')
19 files changed, 2328 insertions, 23 deletions
diff --git a/new-luxc/source/luxc/lang/host/js.lux b/new-luxc/source/luxc/lang/host/js.lux index 7ef948abb..41dc0965e 100644 --- a/new-luxc/source/luxc/lang/host/js.lux +++ b/new-luxc/source/luxc/lang/host/js.lux @@ -77,12 +77,12 @@ (def: #export (object fields) (-> (List [Text Expression]) Expression) - (format "{" + (format "({" (|> fields (list/map (.function [[key val]] (format key ": " val))) (text.join-with ", ")) - "}")) + "})")) (do-template [<name> <op>] [(def: #export (<name> param subject) diff --git a/new-luxc/source/luxc/lang/host/lua.lux b/new-luxc/source/luxc/lang/host/lua.lux new file mode 100644 index 000000000..943b0377e --- /dev/null +++ b/new-luxc/source/luxc/lang/host/lua.lux @@ -0,0 +1,188 @@ +(.module: + [lux #- not or and function] + (lux (data [text] + text/format + (coll [list "list/" Functor<List> Fold<List>])))) + +(type: #export Lua Text) + +(type: #export Expression Lua) + +(type: #export Statement Lua) + +(def: #export nil + Expression + "nil") + +(def: #export bool + (-> Bool Expression) + %b) + +(def: #export int + (-> Int Expression) + %i) + +(def: #export float + (-> Frac Expression) + %f) + +(def: #export (string value) + (-> Text Expression) + (%t value)) + +(def: #export (array elements) + (-> (List Expression) Expression) + (format "{" (text.join-with "," elements) "}")) + +(def: #export (nth idx array) + (-> Expression Expression Expression) + (format "(" array ")[" idx "]")) + +(def: #export (length array) + (-> Expression Expression) + (format "#(" array ")")) + +(def: #export (apply func args) + (-> Expression (List Expression) Expression) + (format func "(" (text.join-with "," args) ")")) + +(def: #export (method field table args) + (-> Text Expression (List Expression) Expression) + (format table ":" field "(" (text.join-with "," args) ")")) + +(def: #export (local! name value) + (-> Text (Maybe Expression) Statement) + (case value + #.None + (format "local " name ";") + + (#.Some value) + (format "local " name " = " value ";"))) + +(def: #export (global! name value) + (-> Text (Maybe Expression) Statement) + (case value + #.None + (format name ";") + + (#.Some value) + (format name " = " value ";"))) + +(def: #export (set! name value) + (-> Text Expression Statement) + (format name " = " value ";")) + +(def: #export (if! test then! else!) + (-> Expression Statement Statement Statement) + (format "if " test + " then " then! + " else " else! + " end;")) + +(def: #export (when! test then!) + (-> Expression Statement Statement) + (format "if " test + " then " then! + " end;")) + +(def: #export (cond! clauses else!) + (-> (List [Expression Statement]) Statement Statement) + (list/fold (.function [[test then!] next!] + (if! test then! next!)) + else! + (list.reverse clauses))) + +(def: #export (block! statements) + (-> (List Statement) Statement) + (text.join-with " " statements)) + +(def: #export (while! test body) + (-> Expression Statement Statement) + (format "while " test " do " body " end;")) + +(def: #export (for-in! vars source body) + (-> (List Text) Expression Statement Statement) + (format "for " (text.join-with "," vars) " in " source + " do " body " end;")) + +(def: #export (for-step! var from to step body) + (-> Text Expression Expression Expression Statement + Statement) + (format "for " var " = " from ", " to ", " step + " do " body " end;")) + +(def: #export (error message) + (-> Expression Expression) + (apply "error" (list message))) + +(def: #export (return! value) + (-> Expression Statement) + (format "return " value ";")) + +(def: #export (function args body) + (-> (List Text) Statement Expression) + (format "(" + (format "function " (format "(" (text.join-with ", " args) ")") + " " + body + " end") + ")")) + +(def: #export (function! name args body) + (-> Text (List Text) Statement Expression) + (format "function " name (format "(" (text.join-with ", " args) ")") + " " + body + " end;")) + +(def: #export (table fields) + (-> (List [Text Expression]) Expression) + (format "{" + (|> fields + (list/map (.function [[key val]] + (format key " = " val))) + (text.join-with ", ")) + "}")) + +(do-template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (format "(" subject " " <op> " " param ")"))] + + [= "=="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [// "//"] + [% "%"] + ) + +(do-template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (format "(" param " " <op> " " subject ")"))] + + [or "or"] + [and "and"] + [bit-or "|"] + [bit-and "&"] + [bit-xor "~"] + ) + +(do-template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (format "(" subject " " <op> " " param ")"))] + + [bit-shl "<<"] + [bit-shr ">>"] + ) + +(def: #export (not subject) + (-> Expression Expression) + (format "(not " subject ")")) diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux index 063c01e25..c0cf2d0dd 100644 --- a/new-luxc/source/luxc/lang/translation/js.lux +++ b/new-luxc/source/luxc/lang/translation/js.lux @@ -332,7 +332,7 @@ _ (Appendable::append [(:! CharSequence (format module-code "\n"))] program-buffer)]] (wrap (ioC.write target - (format module "/" module-js-name) + (format (module-name module) "/" module-js-name) (|> module-code (String::getBytes ["UTF-8"]) e.assume))))) diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux index 14329e0dd..8b45557cd 100644 --- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux @@ -354,14 +354,9 @@ Trinary (format subjectJS ".replace(" paramJS "," extraJS ")")) -(do-template [<name> <method>] - [(def: (<name> [textJS partJS startJS]) - Trinary - (format <method> "(" textJS "," partJS "," startJS ")"))] - - [text//index runtimeT.text//index] - [text//last-index runtimeT.text//last-index] - ) +(def: (text//index [textJS partJS startJS]) + Trinary + (format runtimeT.text//index "(" textJS "," partJS "," startJS ")")) ## [[Math]] (do-template [<name> <method>] diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux index 21aa8f983..2104dbf81 100644 --- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux @@ -752,17 +752,6 @@ "}")) "})")) -(runtime: text//last-index "lastIndex" - (format "(function " @ "(text,part,start) {" - "var idx = text.lastIndexOf(part," int//to-number "(start));" - (format (format "if(idx === -1) {" - "return " none ";" - "}") - (format "else {" - (format "return " (some (format int//from-number "(idx)")) ";") - "}")) - "})")) - (runtime: text//clip "clip" (format "(function " @ "(text,from,to) {" (format "if(from.L > text.length || to.L > text.length) {" @@ -802,7 +791,6 @@ (def: runtime//text Runtime (format __text//index - __text//last-index __text//clip __text//replace-all __text//char diff --git a/new-luxc/source/luxc/lang/translation/lua.lux b/new-luxc/source/luxc/lang/translation/lua.lux new file mode 100644 index 000000000..115471cbe --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua.lux @@ -0,0 +1,228 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + pipe + [monad #+ do]) + (data [bit] + [maybe] + ["e" error #+ Error] + [text "text/" Eq<Text>] + text/format + (coll [array])) + [macro] + [io #+ IO Process io] + [host #+ class: interface: object] + (world [file #+ File])) + (luxc [lang] + (lang [".L" variable #+ Register] + (host [lua #+ Lua Expression Statement])) + [".C" io])) + +(host.import java/lang/Object) + +(host.import java/lang/String + (getBytes [String] #try (Array byte))) + +(host.import java/lang/CharSequence) + +(host.import java/lang/Appendable + (append [CharSequence] Appendable)) + +(host.import java/lang/StringBuilder + (new []) + (toString [] String)) + +(host.import net/sandius/rembulan/StateContext) + +(host.import net/sandius/rembulan/impl/StateContexts + (#static newDefaultInstance [] StateContext)) + +(host.import net/sandius/rembulan/env/RuntimeEnvironment) + +(host.import net/sandius/rembulan/env/RuntimeEnvironments + (#static system [] RuntimeEnvironment)) + +(host.import net/sandius/rembulan/Table) + +(host.import net/sandius/rembulan/lib/StandardLibrary + (#static in [RuntimeEnvironment] StandardLibrary) + (installInto [StateContext] Table)) + +(host.import net/sandius/rembulan/Variable + (new [Object])) + +(host.import net/sandius/rembulan/runtime/LuaFunction) + +(host.import net/sandius/rembulan/load/ChunkLoader + (loadTextChunk [Variable String String] LuaFunction)) + +(host.import net/sandius/rembulan/compiler/CompilerChunkLoader + (#static of [String] CompilerChunkLoader)) + +(host.import net/sandius/rembulan/exec/DirectCallExecutor + (#static newExecutor [] DirectCallExecutor) + (call [StateContext Object (Array Object)] (Array Object))) + +(type: #export Anchor [Text Register]) + +(type: #export Host + {#context [Text Nat] + #anchor (Maybe Anchor) + #interpreter (-> Text (Error Top)) + #module-buffer (Maybe StringBuilder) + #program-buffer StringBuilder}) + +(def: #export init + (IO Host) + (io {#context ["" +0] + #anchor #.None + #interpreter (let [runtime-env (RuntimeEnvironments::system []) + std-lib (StandardLibrary::in [runtime-env]) + state-context (StateContexts::newDefaultInstance []) + table (StandardLibrary::installInto [state-context] std-lib) + variable (Variable::new [table]) + loader (CompilerChunkLoader::of ["_lux_definition"]) + executor (DirectCallExecutor::newExecutor [])] + (function [code] + (let [lua-function (ChunkLoader::loadTextChunk [variable "lux compilation" code] + loader)] + ("lux try" (io (DirectCallExecutor::call [state-context (:! Object lua-function) (array.new +0)] + executor)))))) + #module-buffer #.None + #program-buffer (StringBuilder::new [])})) + +(def: #export lua-module-name Text "module.lua") + +(def: #export init-module-buffer + (Meta Unit) + (function [compiler] + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #module-buffer (#.Some (StringBuilder::new []))) + (:! Void)) + compiler) + []]))) + +(exception: #export No-Active-Module-Buffer) +(exception: #export Cannot-Execute) + +(def: #export (with-sub-context expr) + (All [a] (-> (Meta a) (Meta [Text a]))) + (function [compiler] + (let [old (:! Host (get@ #.host compiler)) + [old-name old-sub] (get@ #context old) + new-name (format old-name "___" (%i (nat-to-int old-sub)))] + (case (expr (set@ #.host + (:! Void (set@ #context [new-name +0] old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #context [old-name (n/inc old-sub)]) + (:! Void)) + compiler') + [new-name output]]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export context + (Meta Text) + (function [compiler] + (#e.Success [compiler + (|> (get@ #.host compiler) + (:! Host) + (get@ #context) + (let> [name sub] + name))]))) + +(def: #export (with-anchor anchor expr) + (All [a] (-> Anchor (Meta a) (Meta a))) + (function [compiler] + (let [old (:! Host (get@ #.host compiler))] + (case (expr (set@ #.host + (:! Void (set@ #anchor (#.Some anchor) old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #anchor (get@ #anchor old)) + (:! Void)) + compiler') + output]) + + (#e.Error error) + (#e.Error error))))) + +(exception: #export No-Anchor) + +(def: #export anchor + (Meta Anchor) + (function [compiler] + (case (|> compiler (get@ #.host) (:! Host) (get@ #anchor)) + (#.Some anchor) + (#e.Success [compiler anchor]) + + #.None + ((lang.throw No-Anchor "") compiler)))) + +(def: #export module-buffer + (Meta StringBuilder) + (function [compiler] + (case (|> compiler (get@ #.host) (:! Host) (get@ #module-buffer)) + #.None + ((lang.fail (No-Active-Module-Buffer "")) compiler) + + (#.Some module-buffer) + (#e.Success [compiler module-buffer])))) + +(def: #export program-buffer + (Meta StringBuilder) + (function [compiler] + (#e.Success [compiler (|> compiler (get@ #.host) (:! Host) (get@ #program-buffer))]))) + +(def: (execute code) + (-> Expression (Meta Unit)) + (function [compiler] + (let [interpreter (|> compiler (get@ #.host) (:! Host) (get@ #interpreter))] + (case (interpreter code) + (#e.Error error) + ((lang.fail (Cannot-Execute error)) compiler) + + (#e.Success _) + (#e.Success [compiler []]))))) + +(exception: #export Unknown-Member) + +(def: #export variant-tag-field "_lux_tag") +(def: #export variant-flag-field "_lux_flag") +(def: #export variant-value-field "_lux_value") + +(def: #export unit Text "\u0000") + +(def: #export (definition-name [module name]) + (-> Ident Text) + (lang.normalize-name (format module "$" name))) + +(def: #export (save code) + (-> Lua (Meta Unit)) + (do macro.Monad<Meta> + [module-buffer module-buffer + #let [_ (Appendable::append [(:! CharSequence code)] + module-buffer)]] + (execute code))) + +(def: #export (save-module! target) + (-> File (Meta (Process Unit))) + (do macro.Monad<Meta> + [module macro.current-module-name + module-buffer module-buffer + program-buffer program-buffer + #let [module-code (StringBuilder::toString [] module-buffer) + _ (Appendable::append [(:! CharSequence (format module-code "\n"))] + program-buffer)]] + (wrap (ioC.write target + (format (lang.normalize-name module) "/" lua-module-name) + (|> module-code + (String::getBytes ["UTF-8"]) + e.assume))))) diff --git a/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux new file mode 100644 index 000000000..bce4d7bff --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux @@ -0,0 +1,174 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format + (coll [list "list/" Fold<List>])) + [macro #+ "meta/" Monad<Meta>]) + (luxc [lang] + (lang ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" runtime] + [".T" primitive] + [".T" reference])) + +(def: (expression-block body) + (-> Statement Expression) + (lua.apply (lua.function (list) + body) + (list))) + +(def: #export (translate-let translate register valueS bodyS) + (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (expression-block + (lua.block! (list (lua.local! (referenceT.variable register) (#.Some valueO)) + (lua.return! bodyO))))))) + +(def: #export (translate-record-get translate valueS path) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bool]) + (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS)] + (wrap (list/fold (function [[idx tail?] source] + (let [method (if tail? + runtimeT.product//right + runtimeT.product//left)] + (method source (lua.int (:! Int idx))))) + valueO + path)))) + +(def: #export (translate-if testO thenO elseO) + (-> Expression Expression Expression Expression) + (expression-block + (lua.if! testO + (lua.return! thenO) + (lua.return! elseO)))) + +(def: savepoint + Expression + "pm_cursor_savepoint") + +(def: cursor + Expression + "pm_cursor") + +(def: (push-cursor! value) + (-> Expression Expression) + (lua.apply "table.insert" (list cursor value))) + +(def: save-cursor! + Statement + (lua.apply "table.insert" (list savepoint (runtimeT.array//copy cursor)))) + +(def: restore-cursor! + Statement + (lua.set! cursor (lua.apply "table.remove" (list savepoint)))) + +(def: cursor-top + Expression + (lua.nth (lua.length cursor) cursor)) + +(def: pop-cursor! + Statement + (lua.apply "table.remove" (list cursor))) + +(def: pm-error + Expression + (lua.string "PM-ERROR")) + +(exception: #export Unrecognized-Path) + +(def: (translate-pattern-matching' translate path) + (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) + (case path + (^code ("lux case exec" (~ bodyS))) + (do macro.Monad<Meta> + [bodyO (translate bodyS)] + (wrap (lua.return! bodyO))) + + (^code ("lux case pop")) + (meta/wrap pop-cursor!) + + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (meta/wrap (lua.local! (referenceT.variable register) (#.Some cursor-top))) + + (^template [<tag> <format>] + [_ (<tag> value)] + (meta/wrap (lua.when! (lua.not (lua.= (|> value <format>) cursor-top)) + (lua.return! pm-error)))) + ([#.Nat (<| lua.int (:! Int))] + [#.Int lua.int] + [#.Deg (<| lua.int (:! Int))] + [#.Bool lua.bool] + [#.Frac lua.float] + [#.Text lua.string]) + + (^template [<pm> <getter>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! (<getter> cursor-top (lua.int (:! Int idx)))))) + (["lux case tuple left" runtimeT.product//left] + ["lux case tuple right" runtimeT.product//right]) + + (^template [<pm> <flag>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (lua.block! (list (lua.set! "temp" (runtimeT.sum//get cursor-top (lua.int (:! Int idx)) <flag>)) + (lua.if! (lua.not (lua.= lua.nil "temp")) + (push-cursor! "temp") + (lua.return! pm-error)))))) + (["lux case variant left" lua.nil] + ["lux case variant right" (lua.string "")]) + + (^code ("lux case seq" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (lua.block! (list leftO rightO)))) + + (^code ("lux case alt" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (lua.block! (list (format "local alt_success, alt_value = " (lua.apply "pcall" (list (lua.function (list) + (lua.block! (list save-cursor! + leftO))))) ";") + (lua.if! "alt_success" + (lua.return! "alt_value") + (lua.if! (lua.= pm-error "alt_value") + (lua.block! (list restore-cursor! + rightO)) + (lua.error "alt_value"))))))) + + _ + (lang.throw Unrecognized-Path (%code path)) + )) + +(def: (translate-pattern-matching translate path) + (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) + (do macro.Monad<Meta> + [pattern-matching (translate-pattern-matching' translate path)] + (wrap (lua.block! (list (format "local success, value = pcall(function () " pattern-matching " end);") + (lua.if! "success" + (lua.return! "value") + (lua.if! (lua.= pm-error "value") + (lua.error (lua.string "Invalid expression for pattern-matching.")) + (lua.error "value")))))))) + +(def: (initialize-pattern-matching stack-init) + (-> Expression Statement) + (lua.block! (list (lua.local! "temp" #.None) + (lua.local! cursor (#.Some (lua.array (list stack-init)))) + (lua.local! savepoint (#.Some (lua.array (list))))))) + +(def: #export (translate-case translate valueS path) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + pattern-matching (translate-pattern-matching translate path)] + (wrap (expression-block + (lua.block! (list (initialize-pattern-matching valueO) + pattern-matching)))))) diff --git a/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux new file mode 100644 index 000000000..331ec857d --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux @@ -0,0 +1,121 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:]) + (data [bit] + [maybe] + ["e" error #+ Error] + text/format + (coll [array])) + [host]) + (luxc [lang] + (lang (host [js #+ JS Expression Statement]))) + [//]) + +(host.import java/lang/Object + (toString [] String) + (getClass [] (Class Object))) + +(host.import java/lang/Long + (intValue [] Integer)) + +(host.import net/sandius/rembulan/ByteString + (decode [] String)) + +(host.import net/sandius/rembulan/Table + (rawget #as get-idx [long] #? Object) + (rawget #as get-key [Object] #? Object) + (rawlen [] long)) + +(host.import net/sandius/rembulan/impl/DefaultTable) + +(def: (variant lux-object host-object) + (-> (-> Object (Error Top)) DefaultTable (Maybe Top)) + (case [(Table::get-key [//.variant-tag-field] host-object) + (Table::get-key [//.variant-flag-field] host-object) + (Table::get-key [//.variant-value-field] host-object)] + (^multi [(#.Some tag) ?flag (#.Some value)] + [(lux-object value) + (#.Some value)]) + (#.Some [(Long::intValue [] (:! Long tag)) + (: Top (case ?flag (#.Some _) "" #.None (host.null))) + value]) + + _ + #.None)) + +(def: (array lux-object host-object) + (-> (-> Object (Error Top)) DefaultTable (Maybe (Array Object))) + (let [init-num-keys (:! Nat (Table::rawlen [] host-object))] + (loop [num-keys init-num-keys + idx +0 + output (: (Array Object) + (array.new init-num-keys))] + (if (n/< num-keys idx) + (case (Table::get-idx (:! Long (n/inc idx)) host-object) + (#.Some member) + (case (lux-object member) + (#e.Success parsed-member) + (recur num-keys (n/inc idx) (array.write idx (:! Object parsed-member) output)) + + (#e.Error error) + #.None) + + #.None + (recur num-keys (n/inc idx) output)) + (#.Some output))))) + +(exception: #export Unknown-Kind-Of-Host-Object) +(exception: #export Null-Has-No-Lux-Representation) + +(def: (lux-object host-object) + (-> Object (Error Top)) + (`` (cond (host.null? host-object) + (ex.throw Null-Has-No-Lux-Representation "") + + (or (host.instance? java/lang/Boolean host-object) + (host.instance? java/lang/Long host-object) + (host.instance? java/lang/Double host-object) + (host.instance? java/lang/String host-object)) + (ex.return host-object) + + (host.instance? ByteString host-object) + (ex.return (ByteString::decode [] (:! ByteString host-object))) + + (host.instance? DefaultTable host-object) + (let [host-object (:! DefaultTable host-object)] + (case (variant lux-object host-object) + (#.Some value) + (ex.return value) + + #.None + (case (array lux-object host-object) + (#.Some value) + (ex.return value) + + #.None + (ex.throw Unknown-Kind-Of-Host-Object (format "SECOND " (Object::toString [] (:! Object host-object))))))) + + ## else + (ex.throw Unknown-Kind-Of-Host-Object (format "FIRST " (Object::toString [] (:! Object host-object)))) + ))) + +(exception: #export Cannot-Evaluate) + +(def: #export (eval code) + (-> Expression (Meta Top)) + (function [compiler] + (let [interpreter (|> compiler (get@ #.host) (:! //.Host) (get@ #//.interpreter))] + (case (interpreter (format "return " code ";")) + (#e.Error error) + ((lang.throw Cannot-Evaluate error) compiler) + + (#e.Success output) + (case (lux-object (|> output + (:! (Array Object)) + (array.read +0) + maybe.assume)) + (#e.Success parsed-output) + (#e.Success [compiler parsed-output]) + + (#e.Error error) + ((lang.throw Cannot-Evaluate error) compiler)))))) diff --git a/new-luxc/source/luxc/lang/translation/lua/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/expression.jvm.lux new file mode 100644 index 000000000..d3d336420 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/expression.jvm.lux @@ -0,0 +1,83 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + text/format) + [macro] + (macro ["s" syntax])) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + [".L" extension] + ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" runtime] + [".T" primitive] + [".T" structure] + [".T" reference] + [".T" function] + [".T" loop] + [".T" case] + [".T" procedure])) + +(exception: #export Invalid-Function-Syntax) +(exception: #export Unrecognized-Synthesis) + +(def: #export (translate synthesis) + (-> ls.Synthesis (Meta Expression)) + (case synthesis + (^code []) + (:: macro.Monad<Meta> wrap runtimeT.unit) + + (^code [(~ singleton)]) + (translate singleton) + + (^template [<tag> <generator>] + [_ (<tag> value)] + (<generator> value)) + ([#.Bool primitiveT.translate-bool] + [#.Nat primitiveT.translate-nat] + [#.Int primitiveT.translate-int] + [#.Deg primitiveT.translate-deg] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) + + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (structureT.translate-variant translate tag last? valueS) + + (^code [(~+ members)]) + (structureT.translate-tuple translate members) + + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (referenceT.translate-variable var) + + [_ (#.Symbol definition)] + (referenceT.translate-definition definition) + + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (caseT.translate-let translate register inputS exprS) + + (^code ("lux case" (~ inputS) (~ pathPS))) + (caseT.translate-case translate inputS pathPS) + + (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) + (case (s.run environment (p.some s.int)) + (#e.Success environment) + (functionT.translate-function translate environment arity bodyS) + + _ + (&.throw Invalid-Function-Syntax (%code synthesis))) + + (^code ("lux call" (~ functionS) (~+ argsS))) + (functionT.translate-apply translate functionS argsS) + + (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) + (procedureT.translate-procedure translate procedure argsS) + ## (do macro.Monad<Meta> + ## [translation (extensionL.find-translation procedure)] + ## (translation argsS)) + + _ + (&.throw Unrecognized-Synthesis (%code synthesis)))) diff --git a/new-luxc/source/luxc/lang/translation/lua/function.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/function.jvm.lux new file mode 100644 index 000000000..1750cd3eb --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/function.jvm.lux @@ -0,0 +1,82 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [product] + [text] + text/format + (coll [list "list/" Functor<List>])) + [macro]) + (luxc ["&" lang] + (lang ["ls" synthesis] + [".L" variable #+ Variable] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" reference] + [".T" loop] + [".T" runtime])) + +(def: #export (translate-apply translate functionS argsS+) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) + (do macro.Monad<Meta> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (lua.apply functionO argsO+)))) + +(def: (input-declaration register) + (lua.local! (referenceT.variable (n/inc register)) + (#.Some (lua.nth (|> register n/inc nat-to-int %i) "curried")))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Statement (Meta Expression)) + (let [closure-name (format function-name "___CLOSURE")] + (case inits + #.Nil + (do macro.Monad<Meta> + [_ (//.save function-definition)] + (wrap function-name)) + + _ + (do macro.Monad<Meta> + [_ (//.save (lua.function! closure-name + (|> (list.enumerate inits) + (list/map (|>> product.left referenceT.closure))) + (lua.block! (list function-definition + (lua.return! function-name)))))] + (wrap (lua.apply closure-name inits)))))) + +(def: #export (translate-function translate env arity bodyS) + (-> (-> ls.Synthesis (Meta Expression)) + (List Variable) ls.Arity ls.Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [[function-name bodyO] (//.with-sub-context + (do @ + [function-name //.context] + (//.with-anchor [function-name +1] + (translate bodyS)))) + closureO+ (monad.map @ referenceT.translate-variable env) + #let [args-initsO+ (|> (list.n/range +0 (n/dec arity)) + (list/map input-declaration)) + selfO (lua.local! (referenceT.variable +0) (#.Some function-name)) + arityO (|> arity nat-to-int %i) + pack (|>> (list) (lua.apply "table.pack"))]] + (with-closure function-name closureO+ + (lua.function! function-name (list "...") + (lua.block! (list (lua.local! "curried" (#.Some (pack "..."))) + (lua.local! "num_args" (#.Some (lua.length "curried"))) + (lua.if! (lua.= arityO "num_args") + (lua.block! (list selfO + (lua.block! args-initsO+) + (lua.while! (lua.bool true) + (lua.return! bodyO)))) + (let [unpack (|>> (list) (lua.apply "table.unpack")) + recur (|>> (list) (lua.apply function-name))] + (lua.if! (lua.> arityO "num_args") + (let [slice (function [from to] + (runtimeT.array//sub "curried" from to)) + arity-args (unpack (slice (lua.int 1) arityO)) + output-func-args (unpack (slice (lua.+ (lua.int 1) arityO) "num_args"))] + (lua.return! (lua.apply (recur arity-args) + (list output-func-args)))) + (lua.return! (lua.function (list "...") + (lua.return! (recur (unpack (runtimeT.array//concat "curried" (pack "...")))))))))))))))) diff --git a/new-luxc/source/luxc/lang/translation/lua/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/loop.jvm.lux new file mode 100644 index 000000000..d00f6910d --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/loop.jvm.lux @@ -0,0 +1,35 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List>])) + [macro]) + (luxc [lang] + (lang ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" reference])) + +(def: #export (translate-loop translate offset initsS+ bodyS) + (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [loop-name (:: @ map (|>> %code lang.normalize-name) + (macro.gensym "loop")) + initsO+ (monad.map @ translate initsS+) + bodyO (//.with-anchor [loop-name offset] + (translate bodyS)) + #let [registersO+ (|> (list.n/range +0 (n/dec (list.size initsS+))) + (list/map (|>> (n/+ offset) referenceT.variable)))] + _ (//.save (lua.function! loop-name registersO+ + (lua.return! bodyO)))] + (wrap (lua.apply loop-name initsO+)))) + +(def: #export (translate-recur translate argsS+) + (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis) + (Meta Expression)) + (do macro.Monad<Meta> + [[loop-name offset] //.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (lua.apply loop-name argsO+)))) diff --git a/new-luxc/source/luxc/lang/translation/lua/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/primitive.jvm.lux new file mode 100644 index 000000000..c322e5005 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/primitive.jvm.lux @@ -0,0 +1,42 @@ +(.module: + lux + (lux (control pipe) + (data [number] + text/format) + [macro "meta/" Monad<Meta>]) + (luxc (lang (host [lua #+ Lua Expression Statement])))) + +(def: #export translate-bool + (-> Bool (Meta Expression)) + (|>> %b meta/wrap)) + +(def: #export translate-int + (-> Int (Meta Expression)) + (|>> %i meta/wrap)) + +(def: #export translate-nat + (-> Nat (Meta Expression)) + (|>> (:! Int) %i meta/wrap)) + +(def: #export translate-deg + (-> Deg (Meta Expression)) + (|>> (:! Int) %i meta/wrap)) + +(def: #export translate-frac + (-> Frac (Meta Expression)) + (|>> (cond> [(f/= number.positive-infinity)] + [(new> "math.huge")] + + [(f/= number.negative-infinity)] + [(new> "(-1 * math.huge)")] + + [(f/= number.not-a-number)] + [(new> "(0/0)")] + + ## else + [%f]) + meta/wrap)) + +(def: #export translate-text + (-> Text (Meta Expression)) + (|>> %t meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/lua/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/procedure.jvm.lux new file mode 100644 index 000000000..e25050ede --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/procedure.jvm.lux @@ -0,0 +1,28 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll [dict]))) + (luxc ["&" lang] + (lang ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [//] + (/ ["/." common] + ["/." host])) + +(exception: #export Unknown-Procedure) + +(def: procedures + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) + +(def: #export (translate-procedure translate name args) + (-> (-> ls.Synthesis (Meta Expression)) Text (List ls.Synthesis) + (Meta Expression)) + (<| (maybe.default (&.throw Unknown-Procedure (%t name))) + (do maybe.Monad<Maybe> + [proc (dict.get name procedures)] + (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux new file mode 100644 index 000000000..2b277dec4 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux @@ -0,0 +1,640 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [///] + (/// [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])) + +## [Types] +(type: #export Translator + (-> ls.Synthesis (Meta Expression))) + +(type: #export Proc + (-> Translator (List ls.Synthesis) (Meta Expression))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector [size s.nat] elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Expression)) +(type: #export Unary (-> (Vector +1 Expression) Expression)) +(type: #export Binary (-> (Vector +2 Expression) Expression)) +(type: #export Trinary (-> (Vector +3 Expression) Expression)) +(type: #export Variadic (-> (List Expression) Expression)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function [[key val]] [(format prefix " " key) val])) + (dict.from-list text.Hash<Text>))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s.local-symbol] [arity s.nat]) + (with-gensyms [g!proc g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) + (-> Text ..Proc)) + (function [(~ g!name)] + (function [(~ g!translate) (~ g!inputs)] + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do macro.Monad<Meta> + [(~+ (|> g!input+ + (list/map (function [g!input] + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) + + (~' _) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function [proc-name] + (function [translate inputsS] + (do macro.Monad<Meta> + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftO rightO]) + Binary + (lua.= leftO rightO)) + +(def: (lux//if [testO thenO elseO]) + Trinary + (caseT.translate-if testO thenO elseO)) + +(def: (lux//try riskyO) + Unary + (runtimeT.lux//try riskyO)) + +(def: (lux//noop valueO) + Unary + valueO) + +(exception: #export Wrong-Syntax) +(def: #export (wrong-syntax procedure args) + (-> Text (List ls.Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code.tuple args)))) + +(def: lux//loop + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) + (#e.Success [offset initsS+ bodyS]) + (loopT.translate-loop translate offset initsS+ bodyS) + + (#e.Error error) + (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + ))) + +(def: lux//recur + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (loopT.translate-recur translate inputsS)))) + +## [[Bits]] +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and lua.bit-and] + [bit//or lua.bit-or] + [bit//xor lua.bit-xor] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//shift-left lua.bit-shl] + [bit//shift-right lua.bit-shr] + [bit//unsigned-shift-right runtimeT.bit//shift-right] + ) + +(def: bit//count + Unary + runtimeT.bit//count) + +## [[Arrays]] +(def: (array//new sizeO) + Unary + (runtimeT.array//new sizeO)) + +(def: (array//get [arrayO idxO]) + Binary + (runtimeT.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) + Trinary + (runtimeT.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) + Binary + (runtimeT.array//remove arrayO idxO)) + +(def: array//size + Unary + lua.length) + +## [[Numbers]] +(host.import java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double) + (#static NaN Double) + (#static POSITIVE_INFINITY Double) + (#static NEGATIVE_INFINITY Double)) + +(do-template [<name> <const> <encode>] + [(def: (<name> _) + Nullary + (<encode> <const>))] + + [nat//min 0 lua.int] + [nat//max -1 lua.int] + + [frac//smallest Double::MIN_VALUE lua.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) lua.float] + [frac//max Double::MAX_VALUE lua.float] + + [deg//min 0 lua.int] + [deg//max -1 lua.int] + ) + +(do-template [<name> <expression>] + [(def: (<name> _) + Nullary + <expression>)] + + [int//min "math.mininteger"] + [int//max "math.maxinteger"] + ) + +(do-template [<name> <expression>] + [(def: (<name> _) + Nullary + <expression>)] + + [frac//not-a-number (lua./ (lua.int 0) (lua.int 0))] + [frac//positive-infinity "math.huge"] + [frac//negative-infinity (lua.* (lua.int -1) "math.huge")] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [int//add lua.+] + [int//sub lua.-] + [int//mul lua.*] + [int//div lua.//] + [int//rem lua.%] + + [nat//add lua.+] + [nat//sub lua.-] + [nat//mul lua.*] + [nat//div runtimeT.nat///] + [nat//rem runtimeT.nat//%] + + [deg//add lua.+] + [deg//sub lua.-] + [deg//mul runtimeT.deg//*] + [deg//div runtimeT.deg///] + [deg//rem lua.-] + [deg//scale lua.*] + [deg//reciprocal lua.//] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//add lua.+] + [frac//sub lua.-] + [frac//mul lua.*] + [frac//div lua./] + [frac//rem lua.%] + [frac//= lua.=] + [frac//< lua.<] + + [text//= lua.=] + [text//< lua.<] + ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [nat//= lua.=] + [nat//< runtimeT.nat//<] + [int//= lua.=] + [int//< lua.<] + [deg//= lua.=] + [deg//< runtimeT.nat//<] + ) + +(do-template [<name>] + [(def: (<name> inputO) + Unary + inputO)] + + [nat//to-int] + [int//to-nat] + ) + +(def: frac//encode + Unary + (|>> (list) (lua.apply "tostring"))) + +(def: (frac//decode inputO) + Unary + (lux//try (lua.function (list) + (lua.return! (lua.apply "tonumber" (list inputO)))))) + +(do-template [<name> <divisor>] + [(def: (<name> inputO) + Unary + (lua./ <divisor> inputO))] + + [int//to-frac (lua.float 1.0)] + [deg//to-frac (lua.bit-shl (lua.int 32) (lua.int 1))] + ) + +(do-template [<name> <transform>] + [(def: (<name> inputO) + Unary + (|> inputO <transform>))] + + [frac//to-int (<| (lua.apply "math.floor") (list))] + [frac//to-deg runtimeT.deg//from-frac] + [text//hash runtimeT.text//hash] + ) + +(def: nat//char + Unary + (|>> (list) (lua.apply "string.char"))) + +## [[Text]] +(do-template [<name> <op>] + [(def: <name> + Unary + (|>> (list) (lua.apply <op>)))] + + [text//size "string.len"] + [text//upper "string.upper"] + [text//lower "string.lower"] + ) + +(def: (text//trim inputO) + Unary + (lua.apply "string.match" (list inputO "^%s*(.-)%s*$"))) + +(def: (text//concat [subjectO paramO]) + Binary + (format "(" subjectO " .. " paramO ")")) + +(def: (text//contains? [subjectO paramO]) + Binary + (|> (lua.apply "string.find" (list subjectO paramO (lua.int 1) (lua.bool true))) + (lua.= lua.nil) + lua.not)) + +(def: (text//char [subjectO paramO]) + Binary + (runtimeT.text//char subjectO paramO)) + +(do-template [<name> <runtime>] + [(def: (<name> [subjectO paramO extraO]) + Trinary + (<runtime> subjectO paramO extraO))] + + [text//clip runtimeT.text//clip] + [text//replace-all runtimeT.text//replace-all] + [text//replace-once runtimeT.text//replace-once] + ) + +(def: (text//index [textO partO startO]) + Trinary + (runtimeT.text//index textO partO startO)) + +## [[Math]] +(do-template [<name> <method>] + [(def: (<name> inputO) + Unary + (lua.apply <method> (list inputO)))] + + [math//cos "math.cos"] + [math//sin "math.sin"] + [math//tan "math.tan"] + [math//acos "math.acos"] + [math//asin "math.asin"] + [math//atan "math.atan"] + [math//exp "math.exp"] + [math//log "math.log"] + [math//ceil "math.ceil"] + [math//floor "math.floor"] + ) + +(def: (math//pow [inputO paramO]) + Binary + (lua.apply "math.pow" (list inputO paramO))) + +## [[IO]] +(def: (io//log messageO) + Unary + (lua.or (lua.apply "print" (list messageO)) + runtimeT.unit)) + +(def: io//error + Unary + lua.error) + +(def: io//exit + Unary + (|>> (list) (lua.apply "os.exit"))) + +(def: (io//current-time []) + Nullary + (|> (lua.apply "os.time" (list)) + (lua.* (lua.int 1_000)))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> [runtimeT.atom//field] (list) lua.table)) + +(def: atom//read + Unary + (lua.nth (lua.string runtimeT.atom//field))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (runtimeT.atom//compare-and-swap atomO oldO newO)) + +## [[Box]] +(def: box//new + Unary + (|>> (list) lua.array)) + +(def: box//read + Unary + (lua.nth (lua.int 1))) + +(def: (box//write [valueO boxO]) + Binary + (runtimeT.box//write valueO boxO)) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (lua.int 1)) + +(def: process//future + Unary + runtimeT.process//future) + +(def: (process//schedule [milli-secondsO procedureO]) + Binary + (runtimeT.process//schedule milli-secondsO procedureO)) + +## [Bundles] +(def: lux-procs + Bundle + (|> (dict.new text.Hash<Text>) + (install "noop" (unary lux//noop)) + (install "is" (binary lux//is)) + (install "try" (unary lux//try)) + (install "if" (trinary lux//if)) + (install "loop" lux//loop) + (install "recur" lux//recur) + )) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "count" (unary bit//count)) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "shift-left" (binary bit//shift-left)) + (install "unsigned-shift-right" (binary bit//unsigned-shift-right)) + (install "shift-right" (binary bit//shift-right)) + ))) + +(def: nat-procs + Bundle + (<| (prefix "nat") + (|> (dict.new text.Hash<Text>) + (install "+" (binary nat//add)) + (install "-" (binary nat//sub)) + (install "*" (binary nat//mul)) + (install "/" (binary nat//div)) + (install "%" (binary nat//rem)) + (install "=" (binary nat//=)) + (install "<" (binary nat//<)) + (install "min" (nullary nat//min)) + (install "max" (nullary nat//max)) + (install "to-int" (unary nat//to-int)) + (install "char" (unary nat//char))))) + +(def: int-procs + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash<Text>) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "min" (nullary int//min)) + (install "max" (nullary int//max)) + (install "to-nat" (unary int//to-nat)) + (install "to-frac" (unary int//to-frac))))) + +(def: deg-procs + Bundle + (<| (prefix "deg") + (|> (dict.new text.Hash<Text>) + (install "+" (binary deg//add)) + (install "-" (binary deg//sub)) + (install "*" (binary deg//mul)) + (install "/" (binary deg//div)) + (install "%" (binary deg//rem)) + (install "=" (binary deg//=)) + (install "<" (binary deg//<)) + (install "scale" (binary deg//scale)) + (install "reciprocal" (binary deg//reciprocal)) + (install "min" (nullary deg//min)) + (install "max" (nullary deg//max)) + (install "to-frac" (unary deg//to-frac))))) + +(def: frac-procs + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash<Text>) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (install "=" (binary frac//=)) + (install "<" (binary frac//<)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (install "to-deg" (unary frac//to-deg)) + (install "to-int" (unary frac//to-int)) + (install "encode" (unary frac//encode)) + (install "decode" (unary frac//decode))))) + +(def: text-procs + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash<Text>) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary text//size)) + (install "hash" (unary text//hash)) + (install "replace-once" (trinary text//replace-once)) + (install "replace-all" (trinary text//replace-all)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + (install "upper" (unary text//upper)) + (install "lower" (unary text//lower)) + ))) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash<Text>) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary array//size)) + ))) + +(def: math-procs + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash<Text>) + (install "cos" (unary math//cos)) + (install "sin" (unary math//sin)) + (install "tan" (unary math//tan)) + (install "acos" (unary math//acos)) + (install "asin" (unary math//asin)) + (install "atan" (unary math//atan)) + (install "exp" (unary math//exp)) + (install "log" (unary math//log)) + (install "ceil" (unary math//ceil)) + (install "floor" (unary math//floor)) + (install "pow" (binary math//pow)) + ))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary io//log)) + (install "error" (unary io//error)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary io//current-time))))) + +(def: atom-procs + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash<Text>) + (install "new" (unary box//new)) + (install "read" (unary box//read)) + (install "write" (binary box//write))))) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash<Text>) + (install "concurrency-level" (nullary process//concurrency-level)) + (install "future" (unary process//future)) + (install "schedule" (binary process//schedule)) + ))) + +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> lux-procs + (dict.merge bit-procs) + (dict.merge nat-procs) + (dict.merge int-procs) + (dict.merge deg-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge array-procs) + (dict.merge math-procs) + (dict.merge io-procs) + (dict.merge atom-procs) + (dict.merge box-procs) + (dict.merge process-procs) + ))) diff --git a/new-luxc/source/luxc/lang/translation/lua/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/procedure/host.jvm.lux new file mode 100644 index 000000000..85af96ec9 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/procedure/host.jvm.lux @@ -0,0 +1,87 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro "macro/" Monad<Meta>]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [///] + (/// [".T" runtime]) + (// ["@" common])) + +(do-template [<name> <lua>] + [(def: (<name> _) @.Nullary <lua>)] + + [lua//nil "nil"] + [lua//table "{}"] + ) + +(def: (lua//global proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text name)])) + (do macro.Monad<Meta> + [] + (wrap name)) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (lua//call proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& functionS argsS+)) + (do macro.Monad<Meta> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (lua.apply functionO argsO+))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: lua-procs + @.Bundle + (|> (dict.new text.Hash<Text>) + (@.install "nil" (@.nullary lua//nil)) + (@.install "table" (@.nullary lua//table)) + (@.install "global" lua//global) + (@.install "call" lua//call))) + +(def: (table//call proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& tableS [_ (#.Text field)] argsS+)) + (do macro.Monad<Meta> + [tableO (translate tableS) + argsO+ (monad.map @ translate argsS+)] + (wrap (lua.method field tableO argsO+))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (table//get [fieldO tableO]) + @.Binary + (runtimeT.lua//get tableO fieldO)) + +(def: (table//set [fieldO valueO tableO]) + @.Trinary + (runtimeT.lua//set tableO fieldO valueO)) + +(def: table-procs + @.Bundle + (<| (@.prefix "table") + (|> (dict.new text.Hash<Text>) + (@.install "call" table//call) + (@.install "get" (@.binary table//get)) + (@.install "set" (@.trinary table//set))))) + +(def: #export procedures + @.Bundle + (<| (@.prefix "lua") + (|> lua-procs + (dict.merge table-procs)))) diff --git a/new-luxc/source/luxc/lang/translation/lua/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/reference.jvm.lux new file mode 100644 index 000000000..0760e700a --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/reference.jvm.lux @@ -0,0 +1,36 @@ +(.module: + lux + (lux [macro] + (data [text] + text/format)) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" runtime])) + +(do-template [<register> <translation> <prefix>] + [(def: #export (<register> register) + (-> Register Expression) + (format <prefix> (%i (nat-to-int register)))) + + (def: #export (<translation> register) + (-> Register (Meta Expression)) + (:: macro.Monad<Meta> wrap (<register> register)))] + + [closure translate-captured "c"] + [variable translate-local "v"]) + +(def: #export (translate-variable var) + (-> Variable (Meta Expression)) + (if (variableL.captured? var) + (translate-captured (variableL.captured-register var)) + (translate-local (int-to-nat var)))) + +(def: #export global + (-> Ident Expression) + //.definition-name) + +(def: #export (translate-definition name) + (-> Ident (Meta Expression)) + (:: macro.Monad<Meta> wrap (global name))) diff --git a/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux new file mode 100644 index 000000000..b5e2147e0 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux @@ -0,0 +1,499 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data text/format + (coll [list "list/" Monad<List>])) + [macro] + (macro [code] + ["s" syntax #+ syntax:]) + [io #+ Process]) + [//] + (luxc [lang] + (lang (host [lua #+ Lua Expression Statement])))) + +(def: prefix Text "LuxRuntime") + +(def: #export unit Expression (%t //.unit)) + +(def: (flag value) + (-> Bool Lua) + (if value + (%t "") + "null")) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (lua.table (list [//.variant-tag-field tag] + [//.variant-flag-field last?] + [//.variant-value-field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bool Expression Expression) + (variant' (%i (nat-to-int tag)) (flag last?) value)) + +(def: none + Expression + (variant +0 false unit)) + +(def: some + (-> Expression Expression) + (variant +1 true)) + +(def: left + (-> Expression Expression) + (variant +0 false)) + +(def: right + (-> Expression Expression) + (variant +1 true)) + +(type: Runtime Lua) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-symbol (p/wrap (list))) + (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: [[name args] declaration] + definition) + (let [implementation (code.local-symbol (format "@@" name)) + runtime (code.text (format "__" prefix "__" (lang.normalize-name name))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> lang.normalize-name code.text) args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` lua.Lua))) + lua.Lua))] + (wrap (list (` (def: #export (~ declaration) + (~ type) + (lua.apply (~ runtime) (list (~+ argsC+))))) + (` (def: (~ implementation) + Lua + (~ (case argsC+ + #.Nil + (` (lua.global! (~ runtime) (#.Some (~ definition)))) + + _ + (` (let [(~' @) (~ runtime) + (~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function [[left right]] (list left right))) + list/join))] + (lua.function! (~ runtime) (list (~+ argsLC+)) + (~ definition)))))))))))) + +(runtime: (array//copy array) + (lua.block! (list (lua.local! "temp" (#.Some (lua.array (list)))) + (lua.for-step! "idx" (lua.int 1) (lua.length array) (lua.int 1) + (lua.apply "table.insert" (list "temp" (lua.nth "idx" array)))) + (lua.return! "temp")))) + +(runtime: (array//sub array from to) + (lua.block! (list (lua.local! "temp" (#.Some (lua.array (list)))) + (lua.for-step! "idx" from to (lua.int 1) + (lua.apply "table.insert" (list "temp" (lua.nth "idx" array)))) + (lua.return! "temp")))) + +(runtime: (array//concat left right) + (let [copy! (function [input output] + (lua.for-step! "idx" (lua.int 1) (format input ".n") (lua.int 1) + (lua.apply "table.insert" (list output (lua.nth "idx" input)))))] + (lua.block! (list (lua.local! "temp" (#.Some (lua.array (list)))) + (copy! left "temp") + (copy! right "temp") + (lua.return! "temp"))))) + +(runtime: (lux//try op) + (lua.block! (list (format "local success, value = " (lua.apply "pcall" (list (lua.function (list) (lua.return! (lua.apply op (list unit)))))) ";") + (lua.if! "success" + (lua.return! (right "value")) + (lua.return! (left "value")))))) + +(runtime: (lux//program-args program-args) + (lua.block! (list (lua.local! "inputs" (#.Some none)) + (lua.for-step! "idx" (lua.int 1) (lua.length program-args) (lua.int 1) + (lua.set! "inputs" (some (lua.array (list (lua.nth "idx" program-args) + "inputs"))))) + (lua.return! "inputs")))) + +(def: runtime//lux + Runtime + (format @@lux//try + @@lux//program-args)) + +(runtime: (product//left product index) + (lua.block! (list (lua.local! "index_min_length" (#.Some (lua.+ (lua.int 1) index))) + (lua.if! (lua.>= "index_min_length" (lua.length product)) + ## No need for recursion + (lua.return! (lua.nth "index_min_length" product)) + ## Needs recursion + (lua.return! (product//left (lua.nth (lua.length product) + product) + (lua.- (lua.length product) + "index_min_length"))))))) + +(runtime: (product//right product index) + (lua.block! (list (lua.local! "index_min_length" (#.Some (lua.+ (lua.int 1) index))) + (lua.cond! (list [(lua.= "index_min_length" (lua.length product)) + ## Last element. + (lua.return! (lua.nth "index_min_length" product))] + [(lua.< "index_min_length" (lua.length product)) + ## Needs recursion + (lua.return! (product//right (lua.nth (lua.length product) + product) + (lua.- (lua.length product) + "index_min_length")))]) + ## Must slice + (lua.return! (array//sub product "index_min_length" (lua.length product))))))) + +(runtime: (sum//get sum wantedTag wantsLast) + (let [no-match! (lua.return! lua.nil) + sum-tag (format "sum." //.variant-tag-field) + sum-flag (format "sum." //.variant-flag-field) + sum-value (format "sum." //.variant-value-field) + is-last? (lua.= (lua.string "") sum-flag) + test-recursion! (lua.if! is-last? + ## Must recurse. + (lua.return! (sum//get sum-value (lua.- sum-tag wantedTag) wantsLast)) + no-match!)] + (lua.cond! (list [(lua.= sum-tag wantedTag) + (lua.if! (lua.= wantsLast sum-flag) + (lua.return! sum-value) + test-recursion!)] + + [(lua.> sum-tag wantedTag) + test-recursion!] + + [(lua.and (lua.< sum-tag wantedTag) + (lua.= (lua.string "") wantsLast)) + (lua.return! (variant' (lua.- wantedTag sum-tag) sum-flag sum-value))]) + + no-match!))) + +(def: runtime//adt + Runtime + (format @@product//left + @@product//right + @@sum//get)) + +(runtime: (bit//shift-right param subject) + (let [mask (|> (lua.int 1) + (lua.bit-shl (lua.- param (lua.int 64))) + (lua.- (lua.int 1)))] + (lua.return! (|> subject + (lua.bit-shr param) + (lua.bit-and mask))))) + +(runtime: (bit//count subject) + (lua.block! (list (lua.local! "count" (#.Some (lua.int 0))) + (lua.while! (lua.> (lua.int 0) subject) + (lua.block! (list (lua.set! "count" (lua.+ (lua.% (lua.int 2) subject) + "count")) + (lua.set! subject (lua.// (lua.int 2) subject))))) + (lua.return! "count")))) + +(def: runtime//bit + Runtime + (format @@bit//count + @@bit//shift-right)) + +(runtime: (nat//< param subject) + (lua.return! (lua.apply "math.ult" (list subject param)))) + +(runtime: (nat/// param subject) + (lua.if! (lua.< (lua.int 0) param) + (lua.if! (nat//< param subject) + (lua.return! (lua.int 0)) + (lua.return! (lua.int 1))) + (lua.block! (list (lua.local! "quotient" (#.Some (|> subject + (lua.bit-shr (lua.int 1)) + (lua.// param) + (lua.bit-shl (lua.int 1))))) + (lua.local! "remainder" (#.Some (lua.- (lua.* param "quotient") + subject))) + (lua.if! (lua.not (nat//< param "remainder")) + (lua.return! (lua.+ (lua.int 1) "quotient")) + (lua.return! "quotient")))))) + +(runtime: (nat//% param subject) + (let [flat (|> subject + (nat/// param) + (lua.* param))] + (lua.return! (lua.- flat subject)))) + +(def: runtime//nat + Runtime + (format @@nat//< + @@nat/// + @@nat//%)) + +(runtime: deg//low-mask + (|> (lua.int 1) + (lua.bit-shl (lua.int 32)) + (lua.- (lua.int 1)))) + +(runtime: (deg//* param subject) + (lua.block! (list (lua.local! "sL" (#.Some (lua.bit-and deg//low-mask subject))) + (lua.local! "sH" (#.Some (bit//shift-right (lua.int 32) subject))) + (lua.local! "pL" (#.Some (lua.bit-and deg//low-mask param))) + (lua.local! "pH" (#.Some (bit//shift-right (lua.int 32) param))) + (lua.local! "bottom" (#.Some (bit//shift-right (lua.int 32) + (lua.* "pL" "sL")))) + (lua.local! "middle" (#.Some (lua.+ (lua.* "pL" "sH") + (lua.* "pH" "sL")))) + (lua.local! "top" (#.Some (lua.* "pH" "sH"))) + (lua.return! (|> "bottom" + (lua.+ "middle") + (bit//shift-right (lua.int 32)) + (lua.+ "top")))))) + +(runtime: (deg//leading-zeroes input) + (lua.block! (list (lua.local! "zeroes" (#.Some (lua.int 64))) + (lua.while! (lua.not (lua.= (lua.int 0) input)) + (lua.block! (list (lua.set! "zeroes" (lua.- (lua.int 1) "zeroes")) + (lua.set! input (bit//shift-right (lua.int 1) input))))) + (lua.return! "zeroes")))) + +(runtime: (deg/// param subject) + (lua.if! (lua.= param subject) + (lua.return! (lua.int -1)) + (lua.block! (list (lua.local! "min_shift" (#.Some (lua.apply "math.min" (list (deg//leading-zeroes param) + (deg//leading-zeroes subject))))) + (lua.return! (|> (lua.bit-shl "min_shift" subject) + (lua.// (|> (lua.bit-shl "min_shift" param) + (lua.bit-and deg//low-mask))) + (lua.bit-shl (lua.int 32)))))))) + +(runtime: (deg//from-frac input) + (let [->int (|>> (list) (lua.apply "math.floor"))] + (lua.block! (list (lua.local! "two32" (#.Some (lua.apply "math.pow" (list (lua.float 2.0) (lua.float 32.0))))) + (lua.local! "shifted" (#.Some (|> input + (lua.% (lua.float 1.0)) + (lua.* "two32")))) + (lua.local! "low" (#.Some (|> "shifted" + (lua.% (lua.float 1.0)) + (lua.* "two32") + ->int))) + (lua.local! "high" (#.Some (|> "shifted" ->int))) + (lua.return! (lua.+ (lua.bit-shl (lua.int 32) "high") + "low")))))) + +(def: runtime//deg + Runtime + (format @@deg//low-mask + @@deg//* + @@deg//leading-zeroes + @@deg/// + @@deg//from-frac)) + +(runtime: (text//index subject param start) + (lua.block! (list (lua.local! "idx" (#.Some (lua.apply "string.find" (list subject param start (lua.bool true))))) + (lua.if! (lua.= lua.nil "idx") + (lua.return! none) + (lua.return! (some "idx")))))) + +(runtime: (text//clip text from to) + (lua.block! (list (lua.local! "size" (#.Some (lua.apply "string.len" (list text)))) + (lua.if! (lua.or (lua.> "size" from) + (lua.> "size" to)) + (lua.return! none) + (lua.return! (some (lua.apply "string.sub" (list text from to)))))))) + +(runtime: (text//replace-once text to-find replacement) + (let [find-index (lua.apply "string.find" (list text to-find (lua.int 1) (lua.bool true)))] + (lua.block! (list (lua.local! "findSize" (#.Some (lua.apply "string.len" (list to-find)))) + (lua.local! "parts" (#.Some (lua.array (list)))) + (lua.local! "idx" (#.Some find-index)) + (lua.when! (lua.not (lua.= lua.nil "idx")) + (let [find-pre (lua.apply "string.sub" (list text (lua.int 1) "idx")) + find-post (lua.apply "string.sub" (list text "idx" (lua.+ "idx" "findSize")))] + (lua.block! (list (lua.apply "table.insert" (list "parts" find-pre)) + (lua.apply "table.insert" (list "parts" replacement)) + (lua.set! text find-post))))) + (lua.apply "table.insert" (list "parts" text)) + (lua.return! (lua.apply "table.concat" (list "parts"))))))) + +(runtime: (text//replace-all text to-find replacement) + (let [find-index (lua.apply "string.find" (list text to-find (lua.int 1) (lua.bool true)))] + (lua.block! (list (lua.local! "findSize" (#.Some (lua.apply "string.len" (list to-find)))) + (lua.local! "parts" (#.Some (lua.array (list)))) + (lua.local! "idx" (#.Some find-index)) + (lua.while! (lua.not (lua.= lua.nil "idx")) + (let [find-pre (lua.apply "string.sub" (list text (lua.int 1) (lua.- (lua.int 1) "idx"))) + find-post (lua.apply "string.sub" (list text (lua.+ "findSize" "idx")))] + (lua.block! (list (lua.apply "table.insert" (list "parts" find-pre)) + (lua.apply "table.insert" (list "parts" replacement)) + (lua.set! text find-post) + (lua.set! "idx" find-index))))) + (lua.apply "table.insert" (list "parts" text)) + (lua.return! (lua.apply "table.concat" (list "parts"))))))) + +(runtime: (text//char text idx) + (lua.block! (list (lua.local! "char" (#.Some (lua.apply "string.byte" (list text idx)))) + (lua.if! (lua.= lua.nil "char") + (lua.return! none) + (lua.return! (some "char")))))) + +(runtime: (text//hash input) + (lua.block! (list (lua.local! "hash" (#.Some (lua.int 0))) + (lua.for-step! "idx" (lua.int 1) (lua.apply "string.len" (list input)) (lua.int 1) + (lua.set! "hash" (|> "hash" + (lua.bit-shl (lua.int 5)) + (lua.- "hash") + (lua.+ (lua.apply "string.byte" (list input "idx")))))) + (lua.return! "hash")))) + +(def: runtime//text + Runtime + (format @@text//index + @@text//clip + @@text//replace-once + @@text//replace-all + @@text//char + @@text//hash)) + +(def: (check-index-out-of-bounds array idx body!) + (-> Expression Expression Statement Statement) + (lua.if! (lua.<= (lua.length array) + idx) + body! + (lua.error (lua.string "Array index out of bounds!")))) + +(runtime: (array//new size) + (lua.block! (list (lua.local! "output" (#.Some (lua.array (list)))) + (lua.for-step! "idx" (lua.int 1) size (lua.int 1) + (lua.apply "table.insert" (list "output" unit))) + (lua.return! "output")))) + +(runtime: (array//get array idx) + (<| (check-index-out-of-bounds array idx) + (lua.block! (list (lua.local! "temp" (#.Some (lua.nth idx array))) + (lua.if! (lua.or (lua.= lua.nil "temp") + (lua.= unit "temp")) + (lua.return! none) + (lua.return! (some "temp"))))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (lua.block! (list (lua.set! (lua.nth idx array) value) + (lua.return! array))))) + +(runtime: (array//remove array idx) + (array//put array idx unit)) + +(def: runtime//array + Runtime + (format @@array//sub + @@array//concat + @@array//copy + @@array//get + @@array//put + @@array//remove + )) + +(def: #export atom//field Text "_lux_atom") + +(runtime: (atom//compare-and-swap atom old new) + (let [atom//field (lua.string atom//field)] + (lua.if! (lua.= old (lua.nth atom//field atom)) + (lua.block! (list (lua.set! (lua.nth atom//field atom) new) + (lua.return! (lua.bool true)))) + (lua.return! (lua.bool false))))) + +(def: runtime//atom + Runtime + (format @@atom//compare-and-swap)) + +(runtime: (box//write value box) + (lua.block! (list (lua.set! (lua.nth (lua.int 0) box) + value) + (lua.return! unit)))) + +(def: runtime//box + Runtime + (format @@box//write)) + +(def: process//incoming + Text + (lang.normalize-name "process//incoming")) + +(runtime: (process//loop _) + (let [migrate-incoming! (lua.block! (list (lua.for-step! "idx" (lua.int 1) (lua.length process//incoming) (lua.int 1) + (lua.apply "table.insert" (list "queue" (lua.nth "idx" process//incoming)))) + (lua.set! process//incoming (lua.array (list))))) + consume-queue! (lua.block! (list (lua.local! "survivors" (#.Some (lua.array (list)))) + (lua.local! "active_processes" (#.Some (lua.length "queue"))) + (lua.for-step! "idx" (lua.int 1) "active_processes" (lua.int 1) + (lua.block! (list (lua.local! "process" (#.Some (lua.nth "idx" "queue"))) + (lua.when! (lua.apply "coroutine.resume" (list "process")) + (lua.apply "table.insert" (list "survivors" "process")))))) + (lua.set! "queue" "survivors")))] + (lua.block! (list (lua.local! "queue" (#.Some (lua.array (list)))) + migrate-incoming! + consume-queue! + (lua.when! (lua.> (lua.int 0) + (lua.length "queue")) + (process//loop unit)))))) + +(runtime: (process//future procedure) + (lua.block! (list (lua.apply "table.insert" (list process//incoming + (lua.function (list) + (lua.return! (lua.apply procedure (list unit)))))) + (lua.return! unit)))) + +(runtime: (process//schedule milli-seconds procedure) + (let [now (lua.apply "os.time" (list))] + (lua.block! (list (lua.local! "start" (#.Some now)) + (lua.local! "seconds" (#.Some (lua.// (lua.int 1_000) + milli-seconds))) + (lua.apply "table.insert" (list process//incoming + (lua.function (list) + (lua.block! (list (lua.while! (lua.< "seconds" (lua.- "start" now)) + (lua.apply "coroutine.yield" (list))) + (lua.return! (lua.apply procedure (list unit)))))))) + (lua.return! unit))))) + +(def: runtime//process + Runtime + (format (lua.global! process//incoming (#.Some (lua.array (list)))) + @@process//loop + @@process//future + @@process//schedule)) + +(runtime: (lua//get object field) + (lua.block! (list (lua.local! "value" (#.Some (lua.nth field object))) + (lua.if! (lua.= lua.nil "value") + (lua.return! none) + (lua.return! (some "value")))))) + +(runtime: (lua//set object field value) + (lua.block! (list (lua.set! (lua.nth field object) value) + (lua.return! object)))) + +(def: runtime//lua + Runtime + (format @@lua//get + @@lua//set)) + +(def: runtime + Runtime + (format runtime//lux + runtime//adt + runtime//bit + runtime//nat + runtime//deg + runtime//text + runtime//array + runtime//atom + runtime//box + runtime//process + runtime//lua)) + +(def: #export artifact Text (format prefix ".lua")) + +(def: #export translate + (Meta (Process Unit)) + (do macro.Monad<Meta> + [_ //.init-module-buffer + _ (//.save runtime)] + (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/lua/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/statement.jvm.lux new file mode 100644 index 000000000..eb181d160 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/statement.jvm.lux @@ -0,0 +1,48 @@ +(.module: + lux + (lux (control [monad #+ do]) + [macro] + (data text/format)) + (luxc (lang [".L" module] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" runtime] + [".T" reference] + [".T" eval])) + +(def: #export (translate-def name expressionT expressionO metaV) + (-> Text Type Expression Code (Meta Unit)) + (do macro.Monad<Meta> + [current-module macro.current-module-name + #let [def-ident [current-module name]]] + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) + (do @ + [[realT realA realV] (macro.find-def real-def) + _ (moduleL.define def-ident [realT metaV realV])] + (wrap [])) + + _ + (do @ + [#let [def-name (referenceT.global def-ident)] + _ (//.save (lua.global! def-name (#.Some expressionO))) + expressionV (evalT.eval def-name) + _ (moduleL.define def-ident [expressionT metaV expressionV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil + (wrap []) + + tags + (moduleL.declare-tags tags (macro.export? metaV) (:! Type expressionV))) + (wrap [])) + #let [_ (log! (format "DEF " (%ident def-ident)))]] + (wrap [])) + ))) + +(def: #export (translate-program programO) + (-> Expression (Meta Statement)) + (macro.fail "translate-program NOT IMPLEMENTED YET") + ## (hostT.save (format "var " (referenceT.variable +0) " = " runtimeT.lux//program-args "();" + ## "(" programO ")(null);")) + ) diff --git a/new-luxc/source/luxc/lang/translation/lua/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/structure.jvm.lux new file mode 100644 index 000000000..c629b0cae --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/structure.jvm.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format) + [macro]) + (luxc ["&" lang] + (lang [synthesis #+ Synthesis] + (host [js #+ JS Expression Statement]))) + [//] + (// [".T" runtime])) + +(def: #export (translate-tuple translate elemsS+) + (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression)) + (case elemsS+ + #.Nil + (:: macro.Monad<Meta> wrap runtimeT.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do macro.Monad<Meta> + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (format "{" (text.join-with "," elemsT+) "}"))))) + +(def: #export (translate-variant translate tag tail? valueS) + (-> (-> Synthesis (Meta Expression)) Nat Bool Synthesis (Meta Expression)) + (do macro.Monad<Meta> + [valueT (translate valueS)] + (wrap (runtimeT.variant tag tail? valueT)))) |