diff options
Diffstat (limited to '')
15 files changed, 2648 insertions, 6 deletions
diff --git a/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux index 137e5d4ab..12a0fe6a5 100644 --- a/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux @@ -424,13 +424,13 @@ (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.set! "queue" "survivors"))) + loop-body! (lua.block! (list migrate-incoming! + consume-queue!))] (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)))))) + loop-body! + (lua.while! (|> (lua.length "queue") (lua.> (lua.int 0))) + loop-body!))))) (runtime: (process//future procedure) (lua.block! (list (lua.apply "table.insert" (list process//incoming diff --git a/new-luxc/source/luxc/lang/translation/r.lux b/new-luxc/source/luxc/lang/translation/r.lux new file mode 100644 index 000000000..aba64bc87 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r.lux @@ -0,0 +1,223 @@ +(.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 [r #+ Expression Statement])) + [".C" io])) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [No-Active-Module-Buffer] + [Cannot-Execute] + + [No-Anchor] + ) + +(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 javax/script/ScriptEngine + (eval [String] #try #? Object)) + +(host.import javax/script/ScriptEngineFactory + (getScriptEngine [] ScriptEngine)) + +(host.import org/renjin/script/RenjinScriptEngineFactory + (new [])) + +(type: #export Anchor [Text Register]) + +(type: #export Host + {#context [Text Nat] + #anchor (Maybe Anchor) + #loader (-> Statement (Error Unit)) + #interpreter (-> Expression (Error Object)) + #module-buffer (Maybe StringBuilder) + #program-buffer StringBuilder}) + +(def: #export init + (IO Host) + (io (let [interpreter (|> (RenjinScriptEngineFactory::new []) + (ScriptEngineFactory::getScriptEngine []))] + {#context ["" +0] + #anchor #.None + #loader (function (_ code) + (do e.Monad<Error> + [_ (ScriptEngine::eval [(r.statement code)] interpreter)] + (wrap []))) + #interpreter (function (_ code) + (do e.Monad<Error> + [output (ScriptEngine::eval [(r.expression code)] interpreter)] + (wrap (maybe.default (:! Object []) + output)))) + #module-buffer #.None + #program-buffer (StringBuilder::new [])}))) + +(def: #export r-module-name Text "module.r") + +(def: #export init-module-buffer + (Meta Unit) + (function (_ compiler) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #module-buffer (#.Some (StringBuilder::new []))) + (:! Void)) + compiler) + []]))) + +(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 "f___" (%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))))) + +(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.throw 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))]))) + +(do-template [<name> <field> <inputT> <outputT> <unwrap>] + [(def: (<name> code) + (-> <inputT> (Meta <outputT>)) + (function (_ compiler) + (let [runner (|> compiler (get@ #.host) (:! Host) (get@ <field>))] + (case (runner code) + (#e.Error error) + (exec ## (log! (<unwrap> code)) + ((lang.throw Cannot-Execute error) compiler)) + + (#e.Success output) + (#e.Success [compiler output])))))] + + [load! #loader Statement Unit r.statement] + [interpret #interpreter Expression Object r.expression] + ) + +(def: #export variant-tag-field "luxVT") +(def: #export variant-flag-field "luxVF") +(def: #export variant-value-field "luxVV") + +(def: #export int-high-field "luxIH") +(def: #export int-low-field "luxIL") + +(def: #export unit Text "") + +(def: #export (definition-name [module name]) + (-> Ident Text) + (lang.normalize-name (format module "$" name))) + +(do-template [<name> <eval> <un-wrap> <inputT> <outputT>] + [(def: #export (<name> code) + (-> <inputT> (Meta <outputT>)) + (do macro.Monad<Meta> + [module-buffer module-buffer + #let [_ (Appendable::append [(:! CharSequence (<un-wrap> code))] + module-buffer)]] + (<eval> code)))] + + [save load! r.statement Statement Unit] + [run interpret r.expression Expression Object] + ) + +(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) "/" r-module-name) + (|> module-code + (String::getBytes ["UTF-8"]) + e.assume))))) diff --git a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux new file mode 100644 index 000000000..2a635030c --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux @@ -0,0 +1,188 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>] + [set #+ Set])) + [macro #+ "meta/" Monad<Meta>] + (macro [code])) + (luxc [lang] + (lang [".L" variable #+ Register Variable] + ["ls" synthesis #+ Synthesis Path] + (host [r #+ Expression Statement SVar @@]))) + [//] + (// [".T" runtime] + [".T" primitive] + [".T" reference])) + +(def: #export (translate-let translate register valueS bodyS) + (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + bodyO (translate bodyS) + #let [$register (referenceT.variable register)]] + (wrap (r.block ($_ r.then! + (r.set! $register valueO) + (r.do! bodyO)))))) + +(def: #export (translate-record-get translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) 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 (r.int (:! Int idx))))) + valueO + pathP)))) + +(def: #export (translate-if testO thenO elseO) + (-> Expression Expression Expression Expression) + (r.if testO thenO elseO)) + +(def: $savepoint (r.var "lux_pm_cursor_savepoint")) +(def: $cursor (r.var "lux_pm_cursor")) + +(def: top r.length) +(def: next (|>> r.length (r.+ (r.int 1)))) +(def: (push! value var) + (-> Expression SVar Statement) + (r.set-nth! (next (@@ var)) value var)) +(def: (pop! var) + (-> SVar Statement) + (r.set-nth! (top (@@ var)) r.null var)) + +(def: (push-cursor! value) + (-> Expression Statement) + (push! value $cursor)) + +(def: save-cursor! + Statement + (push! (r.slice (r.float 1.0) (r.length (@@ $cursor)) (@@ $cursor)) + $savepoint)) + +(def: restore-cursor! + Statement + (r.set! $cursor (r.nth (top (@@ $savepoint)) (@@ $savepoint)))) + +(def: cursor-top + Expression + (top (@@ $cursor))) + +(def: pop-cursor! + Statement + (pop! $cursor)) + +(def: pm-error (r.string "PM-ERROR")) + +(def: fail-pm! (r.stop! pm-error)) + +(def: $temp (r.var "lux_pm_temp")) + +(exception: #export (Unrecognized-Path {message Text}) + message) + +(def: $alt_error (r.var "alt_error")) + +(def: (pm-catch handler!) + (-> Statement Expression) + (r.function (list $alt_error) + (r.if! (|> (@@ $alt_error) (r.= pm-error)) + handler! + (r.stop! (@@ $alt_error))))) + +(def: (translate-pattern-matching' translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Statement)) + (case pathP + (^code ("lux case exec" (~ bodyS))) + (do macro.Monad<Meta> + [bodyO (translate bodyS)] + (wrap (r.do! bodyO))) + + (^code ("lux case pop")) + (meta/wrap pop-cursor!) + + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (meta/wrap (r.set! (referenceT.variable register) cursor-top)) + + (^template [<tag> <format>] + [_ (<tag> value)] + (meta/wrap (r.when! (r.not (r.= (|> value <format>) cursor-top)) + fail-pm!))) + ([#.Nat (<| runtimeT.int (:! Int))] + [#.Int runtimeT.int] + [#.Deg (<| runtimeT.int (:! Int))] + [#.Bool r.bool] + [#.Frac r.float] + [#.Text r.string]) + + (^template [<pm> <getter>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! (<getter> cursor-top (r.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 ($_ r.then! + (r.set! $temp (runtimeT.sum//get cursor-top (r.int (:! Int idx)) <flag>)) + (r.if! (r.not (r.= r.null (@@ $temp))) + (push-cursor! (@@ $temp)) + fail-pm!)))) + (["lux case variant left" r.null] + ["lux case variant right" (r.string "")]) + + (^code ("lux case seq" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap ($_ r.then! + 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 (r.do! (r.try ($_ r.then! + save-cursor! + leftO) + #.None + (#.Some (pm-catch ($_ r.then! + restore-cursor! + rightO))) + #.None)))) + + _ + (lang.throw Unrecognized-Path (%code pathP)) + )) + +(def: (translate-pattern-matching translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Statement)) + (do macro.Monad<Meta> + [pattern-matching! (translate-pattern-matching' translate pathP)] + (wrap (r.do! (r.try pattern-matching! + #.None + (#.Some (pm-catch (r.stop! (r.string "Invalid expression for pattern-matching.")))) + #.None))))) + +(def: (initialize-pattern-matching! stack-init) + (-> Expression Statement) + ($_ r.then! + (r.set! $cursor (r.list (list stack-init))) + (r.set! $savepoint (r.list (list))))) + +(def: #export (translate-case translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + pattern-matching! (translate-pattern-matching translate pathP)] + (wrap (r.block ($_ r.then! + (initialize-pattern-matching! valueO) + pattern-matching!))))) diff --git a/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux new file mode 100644 index 000000000..27d05fdaa --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux @@ -0,0 +1,162 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + [monad #+ do]) + (data [bit] + [maybe] + ["e" error #+ Error] + text/format + (coll [array])) + [host]) + (luxc [lang] + (lang (host [r #+ Expression Statement]))) + [//]) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Unknown-Kind-Of-Host-Object] + [Null-Has-No-Lux-Representation] + [Cannot-Evaluate] + ) + +(host.import java/lang/Object + (toString [] String) + (getClass [] (Class Object))) + +(host.import java/lang/Long + (intValue [] Integer)) + +(host.import org/renjin/sexp/SEXP) + +(host.import org/renjin/sexp/StringArrayVector + (getElementAsString [int] String)) + +(host.import org/renjin/sexp/LogicalArrayVector + (getElementAsRawLogical [int] int)) + +(host.import org/renjin/sexp/IntArrayVector + (getElementAsInt [int] int)) + +(host.import org/renjin/sexp/DoubleArrayVector + (getElementAsDouble [int] double)) + +(host.import org/renjin/sexp/ListVector + (length [] int) + (getElementAsSEXP [int] #try SEXP) + (getElementAsSEXP #as get-field-sexp [String] #try SEXP)) + +(host.import org/renjin/sexp/Null) + +(def: (parse-tuple lux-object host-object) + (-> (-> Object (Error Top)) ListVector (Error Top)) + (let [size (:! Nat (ListVector::length [] host-object))] + (loop [idx +0 + output (:! (Array Top) (array.new size))] + (if (n/< size idx) + (case (ListVector::getElementAsSEXP [(:! Int idx)] host-object) + (#e.Error error) + (#e.Error error) + + (#e.Success value) + (case (lux-object (:! Object value)) + (#e.Error error) + (#e.Error error) + + (#e.Success lux-value) + (recur (n/inc idx) (array.write idx (:! Top lux-value) output)))) + (#e.Success output))))) + +(def: (parse-variant lux-object host-object) + (-> (-> Object (Error Top)) ListVector (Error Top)) + (do e.Monad<Error> + [tag (ListVector::get-field-sexp [//.variant-tag-field] host-object) + flag (ListVector::get-field-sexp [//.variant-flag-field] host-object) + value (ListVector::get-field-sexp [//.variant-value-field] host-object) + value (lux-object (:! Object value))] + (wrap [(|> tag + (:! IntArrayVector) + (IntArrayVector::getElementAsInt [0]) + (Long::intValue [])) + (: Top + (if (host.instance? Null flag) + host.null + //.unit)) + value]))) + +(def: (parse-int host-object) + (-> ListVector (Error Int)) + (do e.Monad<Error> + [high (ListVector::get-field-sexp [//.int-high-field] host-object) + low (ListVector::get-field-sexp [//.int-low-field] host-object) + #let [high (:! Nat (IntArrayVector::getElementAsInt [0] (:! IntArrayVector high))) + low (:! Nat (IntArrayVector::getElementAsInt [0] (:! IntArrayVector low)))]] + (wrap (|> high (bit.shift-left +32) (n/+ low) nat-to-int)))) + +(def: (lux-object host-object) + (-> Object (Error Top)) + (cond (host.instance? StringArrayVector host-object) + (#e.Success (StringArrayVector::getElementAsString [0] (:! StringArrayVector host-object))) + + (host.instance? LogicalArrayVector host-object) + (#e.Success (i/= 1 (LogicalArrayVector::getElementAsRawLogical [0] (:! LogicalArrayVector host-object)))) + + (host.instance? IntArrayVector host-object) + (#e.Success (IntArrayVector::getElementAsInt [0] (:! IntArrayVector host-object))) + + (host.instance? DoubleArrayVector host-object) + (#e.Success (DoubleArrayVector::getElementAsDouble [0] (:! DoubleArrayVector host-object))) + + (host.instance? ListVector host-object) + (case (parse-int (:! ListVector host-object)) + (#e.Error error) + (case (parse-variant lux-object (:! ListVector host-object)) + (#e.Error error) + (parse-tuple lux-object (:! ListVector host-object)) + + output + output) + + output + output) + + ## else + (let [object-class (:! Text (Object::toString [] (Object::getClass [] (:! Object host-object)))) + text-representation (:! Text (Object::toString [] (:! Object host-object)))] + (ex.throw Unknown-Kind-Of-Host-Object (format object-class " --- " text-representation)))) + ## (case (python-type host-object) + ## "tuple" + ## (tuple lux-object host-object) + + ## "dict" + ## (variant lux-object host-object) + + ## "NoneType" + ## (#e.Success []) + + ## type + ## (ex.throw Unknown-Kind-Of-Host-Object (format type " " (Object::toString [] host-object)))) + ) + +(def: #export (eval code) + (-> Expression (Meta Top)) + (function (_ compiler) + (let [interpreter (|> compiler (get@ #.host) (:! //.Host) (get@ #//.interpreter))] + (case (interpreter code) + (#e.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (r.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler)) + + (#e.Success output) + (case (lux-object output) + (#e.Success parsed-output) + (#e.Success [compiler parsed-output]) + + (#e.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (r.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler))))))) diff --git a/new-luxc/source/luxc/lang/translation/r/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/r/expression.jvm.lux new file mode 100644 index 000000000..67ea089a2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/expression.jvm.lux @@ -0,0 +1,88 @@ +(.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 [r #+ Expression Statement]))) + [//] + (// [".T" runtime] + [".T" primitive] + [".T" structure] + [".T" reference] + [".T" function] + [".T" case] + [".T" procedure]) + ) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Invalid-Function-Syntax] + [Unrecognized-Synthesis] + ) + +(def: #export (translate synthesis) + (-> ls.Synthesis (Meta Expression)) + (case synthesis + (^code []) + (:: macro.Monad<Meta> wrap runtimeT.unit) + + (^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 [(~ singleton)]) + (translate singleton) + + (^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/r/function.jvm.lux b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux new file mode 100644 index 000000000..c42327839 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux @@ -0,0 +1,101 @@ +(.module: + lux + (lux (control [monad #+ do] + pipe) + (data [product] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>])) + [macro]) + (luxc ["&" lang] + (lang ["ls" synthesis] + [".L" variable #+ Variable] + (host [r #+ Expression Statement @@]))) + [//] + (// [".T" reference])) + +(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 (r.apply argsO+ functionO)))) + +(def: $curried (r.var "curried")) + +(def: (input-declaration register) + (r.set! (referenceT.variable (n/inc register)) + (|> (@@ $curried) (r.nth (|> register n/inc nat-to-int r.int))))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Statement (Meta Expression)) + (let [$closure (r.var (format function-name "___CLOSURE"))] + (case inits + #.Nil + (do macro.Monad<Meta> + [_ (//.save function-definition)] + (wrap (r.global function-name))) + + _ + (do macro.Monad<Meta> + [_ (//.save (r.set! $closure + (r.function (|> (list.enumerate inits) + (list/map (|>> product.left referenceT.closure))) + ($_ r.then! + function-definition + (r.do! (r.global function-name))))))] + (wrap (r.apply inits (@@ $closure))))))) + +(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-inits! (|> (list.n/range +0 (n/dec arity)) + (list/map input-declaration) + (case> #.Nil + r.no-op! + + (#.Cons head tail) + (list/fold r.then! head tail))) + arityO (|> arity nat-to-int r.int) + $num_args (r.var "num_args") + $function (r.var function-name) + apply-poly (function (_ args func) + (r.apply (list func args) (r.global "do.call")))]] + (with-closure function-name closureO+ + (r.set! $function + (r.function (list r.var-args) + ($_ r.then! + ## (r.set! $curried (r.apply (list (@@ r.var-args)) (r.global "list"))) + (r.set! $curried (@@ r.var-args)) + (r.set! $num_args (r.length (@@ $curried))) + (r.do! + (r.cond (list [(|> (@@ $num_args) (r.= arityO)) + (r.block + ($_ r.then! + (r.set! (referenceT.variable +0) (@@ $function)) + args-inits! + (r.do! bodyO)))] + [(|> (@@ $num_args) (r.> arityO)) + (let [arity-args (r.slice (r.int 1) arityO (@@ $curried)) + output-func-args (r.slice arityO (@@ $num_args) (@@ $curried))] + (|> (@@ $function) + (apply-poly arity-args) + (apply-poly output-func-args)))]) + ## (|> (@@ $num_args) (r.< arityO)) + (let [$missing (r.var "missing")] + (r.function (list r.var-args) + ($_ r.then! + ## (r.set! $missing (r.apply (list (@@ r.var-args)) (r.global "list"))) + (r.set! $missing (@@ r.var-args)) + (r.do! (|> (@@ $function) + (apply-poly (r.apply (list (@@ $curried) (@@ $missing)) + (r.global "append")))))))))))))) + )) diff --git a/new-luxc/source/luxc/lang/translation/r/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/r/loop.jvm.lux new file mode 100644 index 000000000..d0caebd80 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/loop.jvm.lux @@ -0,0 +1,37 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List>])) + [macro]) + (luxc [lang] + (lang ["ls" synthesis] + (host [r #+ 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 (|> (macro.gensym "loop") + (:: @ map (|>> %code lang.normalize-name))) + initsO+ (monad.map @ translate initsS+) + bodyO (//.with-anchor [loop-name offset] + (translate bodyS)) + #let [$loop-name (r.var loop-name) + @loop-name (@@ $loop-name)] + _ (//.save (r.set! $loop-name + (r.function (|> (list.n/range +0 (n/dec (list.size initsS+))) + (list/map (|>> (n/+ offset) referenceT.variable))) + (r.do! bodyO))))] + (wrap (r.apply initsO+ @loop-name)))) + +(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 (r.apply argsO+ (r.global loop-name))))) diff --git a/new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux new file mode 100644 index 000000000..2afe41421 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux @@ -0,0 +1,30 @@ +(.module: + lux + (lux [macro "meta/" Monad<Meta>]) + (luxc (lang (host [r #+ Expression Statement]))) + [//] + (// [".T" runtime])) + +(def: #export translate-bool + (-> Bool (Meta Expression)) + (|>> r.bool meta/wrap)) + +(def: #export translate-int + (-> Int (Meta Expression)) + (|>> runtimeT.int meta/wrap)) + +(def: #export translate-nat + (-> Nat (Meta Expression)) + (|>> (:! Int) runtimeT.int meta/wrap)) + +(def: #export translate-deg + (-> Deg (Meta Expression)) + (|>> (:! Int) runtimeT.int meta/wrap)) + +(def: #export translate-frac + (-> Frac (Meta Expression)) + (|>> r.float meta/wrap)) + +(def: #export translate-text + (-> Text (Meta Expression)) + (|>> r.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/r/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure.jvm.lux new file mode 100644 index 000000000..699c0c000 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/procedure.jvm.lux @@ -0,0 +1,29 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll [dict]))) + (luxc ["&" lang] + (lang ["ls" synthesis] + (host [python #+ Expression Statement]))) + [//] + (/ ["/." common] + ["/." host])) + +(exception: #export (Unknown-Procedure {message Text}) + message) + +(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/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux new file mode 100644 index 000000000..849093126 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux @@ -0,0 +1,554 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number] + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [r #+ 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!_ 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!_) (~ g!name)) + (function ((~ g!_) (~ 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 + (r.apply (list leftO rightO) + (r.global "identical"))) + +(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 {message Text}) + message) + +(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)))) + +(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) + )) + +## [[Bits]] +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and runtimeT.bit//and] + [bit//or runtimeT.bit//or] + [bit//xor runtimeT.bit//xor] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//shift-left runtimeT.bit//shift-left] + [bit//signed-shift-right runtimeT.bit//signed-shift-right] + [bit//shift-right runtimeT.bit//shift-right] + ) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "count" (unary runtimeT.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//shift-right)) + (install "shift-right" (binary bit//signed-shift-right)) + ))) + +## [[Arrays]] +(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//put arrayO idxO r.null)) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash<Text>) + (install "new" (unary runtimeT.array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary r.length)) + ))) + +## [[Numbers]] +(host.import java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [<name> <const> <encode>] + [(def: (<name> _) + Nullary + (<encode> <const>))] + + [frac//smallest Double::MIN_VALUE r.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) r.float] + [frac//max Double::MAX_VALUE r.float] + ) + +(do-template [<name> <expression>] + [(def: (<name> _) + Nullary + <expression>)] + + [nat//min runtimeT.int//zero] + [nat//max runtimeT.int//-one] + + [int//min runtimeT.int//min] + [int//max runtimeT.int//max] + + [deg//min runtimeT.int//zero] + [deg//max runtimeT.int//-one] + ) + +(do-template [<name> <frac>] + [(def: (<name> _) + Nullary + (r.float <frac>))] + + [frac//not-a-number number.not-a-number] + [frac//positive-infinity number.positive-infinity] + [frac//negative-infinity number.negative-infinity] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [int//add runtimeT.int//+] + [int//sub runtimeT.int//-] + [int//mul runtimeT.int//*] + [int//div runtimeT.int///] + [int//rem runtimeT.int//%] + + [nat//add runtimeT.int//+] + [nat//sub runtimeT.int//-] + [nat//mul runtimeT.int//*] + [nat//div runtimeT.nat///] + [nat//rem runtimeT.nat//%] + + [deg//add runtimeT.int//+] + [deg//sub runtimeT.int//-] + [deg//rem runtimeT.int//-] + [deg//scale runtimeT.int//*] + [deg//mul runtimeT.deg//*] + [deg//div runtimeT.deg///] + [deg//reciprocal runtimeT.int///] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//add r.+] + [frac//sub r.-] + [frac//mul r.*] + [frac//div r./] + [frac//rem r.%%] + [frac//= r.=] + [frac//< r.<] + + [text//= r.=] + [text//< r.<] + ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [nat//= runtimeT.int//=] + [nat//< runtimeT.nat//<] + + [int//= runtimeT.int//=] + [int//< runtimeT.int//<] + + [deg//= runtimeT.int//=] + [deg//< runtimeT.nat//<] + ) + +(def: (apply1 func) + (-> Expression (-> Expression Expression)) + (function (_ value) + (r.apply (list value) func))) + +(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 id)) + (install "char" (unary (apply1 (r.global "intToUtf8"))))))) + +(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 id)) + (install "to-frac" (unary runtimeT.int//to-float))))) + +(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 runtimeT.deg//to-frac))))) + +(def: (frac//encode value) + (-> Expression Expression) + (r.apply (list (r.string "%f") value) (r.global "sprintf"))) + +(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 runtimeT.deg//from-frac)) + (install "to-int" (unary (apply1 (r.global "as.integer")))) + (install "encode" (unary frac//encode)) + (install "decode" (unary runtimeT.frac//decode))))) + +## [[Text]] +(def: (text//concat [subjectO paramO]) + Binary + (r.apply (list subjectO paramO) (r.global "paste0"))) + +(def: (text//char [subjectO paramO]) + Binary + (runtimeT.text//char subjectO paramO)) + +(def: (text//replace-all [textO patternO replacementO]) + Trinary + (r.apply (list patternO replacementO textO) (r.global "gsub"))) + +(def: (text//replace-once [textO patternO replacementO]) + Trinary + (r.apply (list patternO replacementO textO) (r.global "sub"))) + +(def: (text//clip [subjectO paramO extraO]) + Trinary + (runtimeT.text//clip subjectO paramO extraO)) + +(def: (text//index [textO partO startO]) + Trinary + (runtimeT.text//index textO partO startO)) + +(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 (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float))) + (install "hash" (unary runtimeT.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 (apply1 (r.global "toupper")))) + (install "lower" (unary (apply1 (r.global "tolower")))) + ))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + (|> subject (r.** param))) + +(def: (math-func name) + (-> Text (-> Expression Expression)) + (function (_ input) + (r.apply (list input) (r.global name)))) + +(def: math-procs + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash<Text>) + (install "cos" (unary (math-func "cos"))) + (install "sin" (unary (math-func "sin"))) + (install "tan" (unary (math-func "tan"))) + (install "acos" (unary (math-func "acos"))) + (install "asin" (unary (math-func "asin"))) + (install "atan" (unary (math-func "atan"))) + (install "exp" (unary (math-func "exp"))) + (install "log" (unary (math-func "log"))) + (install "ceil" (unary (math-func "ceiling"))) + (install "floor" (unary (math-func "floor"))) + (install "pow" (binary math//pow)) + ))) + +## [[IO]] +(def: (io//exit input) + (-> Expression Expression) + (r.apply-kw (list) + (list ["status" (runtimeT.int//to-float input)]) + (r.global "quit"))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary (apply1 (r.global "print")))) + (install "error" (unary (apply1 (r.global "stop")))) + (install "exit" (unary io//exit)) + (install "current-time" (nullary (function (_ _) + (runtimeT.io//current-time! runtimeT.unit))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> [runtimeT.atom//field] (list) r.named-list)) + +(def: atom//read + Unary + (r.nth (r.string runtimeT.atom//field))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (runtimeT.atom//compare-and-swap atomO oldO newO)) + +(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))))) + +## [[Box]] +(def: box//new + Unary + (|>> (list) r.list)) + +(def: box//read + Unary + (r.nth (r.int 1))) + +(def: (box//write [valueO boxO]) + Binary + (runtimeT.box//write valueO boxO)) + +(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))))) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (r.int 1)) + +(def: (process//schedule [milli-secondsO procedureO]) + Binary + (runtimeT.process//schedule milli-secondsO procedureO)) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash<Text>) + (install "concurrency-level" (nullary process//concurrency-level)) + (install "future" (unary runtimeT.process//future)) + (install "schedule" (binary process//schedule)) + ))) + +## [Bundles] +(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/r/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/host.jvm.lux new file mode 100644 index 000000000..c1b43da2f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/procedure/host.jvm.lux @@ -0,0 +1,89 @@ +(.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 [ruby #+ Ruby 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") + (dict.new text.Hash<Text>) + ## (|> lua-procs + ## (dict.merge table-procs)) + )) diff --git a/new-luxc/source/luxc/lang/translation/r/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/r/reference.jvm.lux new file mode 100644 index 000000000..0a1bcae1f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/reference.jvm.lux @@ -0,0 +1,42 @@ +(.module: + lux + (lux [macro] + (data [text] + text/format)) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + (host [r #+ Expression Statement SVar @@]))) + [//] + (// [".T" runtime])) + +(do-template [<register> <translation> <prefix>] + [(def: #export (<register> register) + (-> Register SVar) + (r.var (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 (local var) + (-> Variable SVar) + (if (variableL.captured? var) + (closure (variableL.captured-register var)) + (variable (int-to-nat var)))) + +(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 SVar) + (|>> //.definition-name r.var)) + +(def: #export (translate-definition name) + (-> Ident (Meta Expression)) + (:: macro.Monad<Meta> wrap (@@ (global name)))) diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux new file mode 100644 index 000000000..9b6d0c862 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux @@ -0,0 +1,1023 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data [bit] + [number #+ hex] + text/format + (coll [list "list/" Monad<List>])) + [macro] + (macro [code] + ["s" syntax #+ syntax:]) + [io #+ Process]) + [//] + (luxc [lang] + (lang (host [r #+ SVar Expression Statement @@])))) + +(def: prefix Text "LuxRuntime") + +(def: #export unit Expression (r.string //.unit)) + +(def: high (|>> int-to-nat (bit.shift-right +32) nat-to-int)) +(def: low (|>> int-to-nat (bit.and (hex "+FFFFFFFF")) nat-to-int)) + +(def: #export (int value) + (-> Int Expression) + (r.named-list (list [//.int-high-field (r.int (high value))] + [//.int-low-field (r.int (low value))]))) + +(def: (flag value) + (-> Bool Expression) + (if value + (r.string "") + r.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (r.named-list (list [//.variant-tag-field tag] + [//.variant-flag-field last?] + [//.variant-value-field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bool Expression Expression) + (variant' (r.int (nat-to-int tag)) + (flag last?) + value)) + +(def: #export none + Expression + (variant +0 false unit)) + +(def: #export some + (-> Expression Expression) + (variant +1 true)) + +(def: #export left + (-> Expression Expression) + (variant +0 false)) + +(def: #export right + (-> Expression Expression) + (variant +1 true)) + +(type: Runtime Statement) + +(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 (format prefix "__" (lang.normalize-name name)) + $runtime (` (r.var (~ (code.text runtime)))) + @runtime (` (@@ (~ $runtime))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> lang.normalize-name code.text (~) (r.var) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` r.Expression))) + r.Expression))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (r.apply (list (~+ argsC+)) (~ @runtime)))) + (` (def: (~ implementation) + r.Statement + (~ (case argsC+ + #.Nil + (` (r.set! (~ $runtime) (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (r.set! (~ $runtime) + (r.function (list (~+ argsLC+)) + (~ definition))))))))))))) + +(syntax: #export (with-vars [vars (s.tuple (p.many s.local-symbol))] + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-symbol var) + (` (r.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) + list/join))] + (~ body)))))) + +(def: high-shift (r.bit-shl (r.int 32))) + +(def: f2^32 (|> (r.int 1) high-shift)) +(def: f2^63 (|> (r.int 1) (r.bit-shl (r.int 63)))) + +(def: (as-integer value) + (-> Expression Expression) + (r.apply (list value) (r.global "as.integer"))) + +(runtime: (int//unsigned-low input) + (with-vars [low] + ($_ r.then! + (r.set! low (|> (@@ input) (r.nth (r.string //.int-low-field)))) + (r.do! + (r.if (|> (@@ low) (r.>= (r.int 0))) + (@@ low) + (|> (@@ low) (r.+ f2^32))))))) + +(runtime: (int//to-float input) + (let [high (|> (@@ input) + (r.nth (r.string //.int-high-field)) + high-shift) + low (|> (@@ input) + int//unsigned-low)] + (r.do! (|> high (r.+ low))))) + +(runtime: (int//new high low) + (r.do! + (r.named-list (list [//.int-high-field (as-integer (@@ high))] + [//.int-low-field (as-integer (@@ low))])))) + +(do-template [<name> <high> <low>] + [(runtime: <name> + (int//new (r.int <high>) (r.int <low>)))] + + [int//zero 0 0] + [int//one 0 1] + [int//min (hex "80000000") 0] + [int//max (hex "7FFFFFFF") (hex "FFFFFFFF")] + ) + +(def: int64-high (r.nth (r.string //.int-high-field))) +(def: int64-low (r.nth (r.string //.int-low-field))) + +(runtime: (bit//not input) + (r.do! (int//new (|> (@@ input) int64-high r.bit-not) + (|> (@@ input) int64-low r.bit-not)))) + +(runtime: (int//+ param subject) + (with-vars [sH sL pH pL + x00 x16 x32 x48] + ($_ r.then! + (r.set! sH (|> (@@ subject) int64-high)) + (r.set! sL (|> (@@ subject) int64-low)) + (r.set! pH (|> (@@ param) int64-high)) + (r.set! pL (|> (@@ param) int64-low)) + (let [bits16 (r.code "0xFFFF") + move-top-16 (r.bit-shl (r.int 16)) + top-16 (r.bit-ushr (r.int 16)) + bottom-16 (r.bit-and bits16) + split-16 (function (_ source) + [(|> source top-16) + (|> source bottom-16)]) + split-int (function (_ high low) + [(split-16 high) + (split-16 low)]) + + [[s48 s32] [s16 s00]] (split-int (@@ sH) (@@ sL)) + [[p48 p32] [p16 p00]] (split-int (@@ pH) (@@ pL)) + new-half (function (_ top bottom) + (|> top bottom-16 move-top-16 + (r.bit-or (bottom-16 bottom))))] + ($_ r.then! + (r.set! x00 (|> s00 (r.+ p00))) + (r.set! x16 (|> (@@ x00) top-16 (r.+ s16) (r.+ p16))) + (r.set! x32 (|> (@@ x16) top-16 (r.+ s32) (r.+ p32))) + (r.set! x48 (|> (@@ x32) top-16 (r.+ s48) (r.+ p48))) + (r.do! (int//new (new-half (@@ x48) (@@ x32)) + (new-half (@@ x16) (@@ x00))))))))) + +(runtime: (int//= reference sample) + (let [comparison (: (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (field (@@ sample)) (r.= (field (@@ reference))))))] + (r.do! (|> (comparison int64-high) + (r.and (comparison int64-low)))))) + +(runtime: (int//negate input) + (r.do! + (r.if (|> (@@ input) (int//= int//min)) + int//min + (|> (@@ input) bit//not (int//+ int//one))))) + +(runtime: int//-one + (int//negate int//one)) + +(runtime: (int//- param subject) + (r.do! (int//+ (int//negate (@@ param)) (@@ subject)))) + +(runtime: (int//< reference sample) + (with-vars [r-? s-?] + ($_ r.then! + (r.set! s-? (|> (@@ sample) int64-high (r.< (r.int 0)))) + (r.set! r-? (|> (@@ reference) int64-high (r.< (r.int 0)))) + (r.do! (|> (|> (@@ s-?) (r.and (r.not (@@ r-?)))) + (r.or (|> (r.not (@@ s-?)) (r.and (@@ r-?)) r.not)) + (r.or (|> (@@ sample) + (int//- (@@ reference)) + int64-high + (r.< (r.int 0))))))))) + +(runtime: (int//from-float input) + (r.do! + (r.cond (list [(r.apply (list (@@ input)) (r.global "is.nan")) + int//zero] + [(|> (@@ input) (r.<= (r.negate f2^63))) + int//min] + [(|> (@@ input) (r.+ (r.float 1.0)) (r.>= f2^63)) + int//max] + [(|> (@@ input) (r.< (r.float 0.0))) + (|> (@@ input) r.negate int//from-float int//negate)]) + (int//new (|> (@@ input) (r./ f2^32)) + (|> (@@ input) (r.%% f2^32)))))) + +(runtime: (int//* param subject) + (with-vars [sH sL pH pL + x00 x16 x32 x48] + ($_ r.then! + (r.set! sH (|> (@@ subject) int64-high)) + (r.set! pH (|> (@@ param) int64-high)) + (let [negative-subject? (|> (@@ sH) (r.< (r.int 0))) + negative-param? (|> (@@ pH) (r.< (r.int 0)))] + (r.cond! (list [negative-subject? + (r.if! negative-param? + (r.do! (int//* (int//negate (@@ param)) + (int//negate (@@ subject)))) + (r.do! (int//negate (int//* (@@ param) + (int//negate (@@ subject))))))] + + [negative-param? + (r.do! (int//negate (int//* (int//negate (@@ param)) + (@@ subject))))]) + ($_ r.then! + (r.set! sL (|> (@@ subject) int64-low)) + (r.set! pL (|> (@@ param) int64-low)) + (let [bits16 (r.code "0xFFFF") + move-top-16 (r.bit-shl (r.int 16)) + top-16 (r.bit-ushr (r.int 16)) + bottom-16 (r.bit-and bits16) + split-16 (function (_ source) + [(|> source top-16) + (|> source bottom-16)]) + split-int (function (_ high low) + [(split-16 high) + (split-16 low)]) + new-half (function (_ top bottom) + (|> top bottom-16 move-top-16 + (r.bit-or (bottom-16 bottom)))) + + [[_s48 _s32] [_s16 _s00]] (split-int (@@ sH) (@@ sL)) + [[_p48 _p32] [_p16 _p00]] (split-int (@@ pH) (@@ pL)) + x16-top (|> (@@ x16) top-16) + x32-top (|> (@@ x32) top-16)] + (with-vars [s48 s32 s16 s00 + p48 p32 p16 p00] + ($_ r.then! + (r.set! s48 _s48) (r.set! s32 _s32) (r.set! s16 _s16) (r.set! s00 _s00) + (r.set! p48 _p48) (r.set! p32 _p32) (r.set! p16 _p16) (r.set! p00 _p00) + (r.set! x00 (|> (@@ s00) (r.* (@@ p00)))) + (r.set! x16 (|> (@@ x00) top-16 (r.+ (|> (@@ s16) (r.* (@@ p00)))))) + (r.set! x32 x16-top) + (r.set! x16 (|> (@@ x16) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p16)))))) + (r.set! x32 (|> (@@ x32) (r.+ x16-top) (r.+ (|> (@@ s32) (r.* (@@ p00)))))) + (r.set! x48 x32-top) + (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s16) (r.* (@@ p16)))))) + (r.set! x48 (|> (@@ x48) (r.+ x32-top))) + (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p32)))))) + (r.set! x48 (|> (@@ x48) (r.+ x32-top) + (r.+ (|> (@@ s48) (r.* (@@ p00)))) + (r.+ (|> (@@ s32) (r.* (@@ p16)))) + (r.+ (|> (@@ s16) (r.* (@@ p32)))) + (r.+ (|> (@@ s00) (r.* (@@ p48)))))) + (r.do! (int//new (new-half (@@ x48) (@@ x32)) + (new-half (@@ x16) (@@ x00)))))) + ))))))) + +(def: (limit-shift! shift) + (-> SVar Statement) + (r.set! shift (|> (@@ shift) (r.bit-and (r.int 63))))) + +(def: (no-shift-clause shift input) + (-> SVar SVar [Expression Statement]) + [(|> (@@ shift) (r.= (r.int 0))) + (r.do! (@@ input))]) + +(runtime: (bit//shift-left shift input) + ($_ r.then! + (limit-shift! shift) + (r.cond! (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (let [mid (|> (int64-low (@@ input)) (r.bit-ushr (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) + (r.bit-shl (@@ shift)) + (r.bit-or mid)) + low (|> (int64-low (@@ input)) + (r.bit-shl (@@ shift)))] + (r.do! (int//new high low)))]) + (let [high (|> (int64-high (@@ input)) + (r.bit-shl (|> (@@ shift) (r.- (r.int 32)))))] + (r.do! (int//new high (r.int 0))))))) + +(runtime: (bit//signed-shift-right-32 shift input) + (let [top-bit (|> (@@ input) (r.bit-and (r.int (hex "80000000"))))] + (r.do! (|> (@@ input) + (r.bit-ushr (@@ shift)) + (r.bit-or top-bit))))) + +(runtime: (bit//signed-shift-right shift input) + ($_ r.then! + (limit-shift! shift) + (r.cond! (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) + (bit//signed-shift-right-32 (@@ shift))) + low (|> (int64-low (@@ input)) + (r.bit-ushr (@@ shift)) + (r.bit-or mid))] + (r.do! (int//new high low)))]) + (let [low (|> (int64-high (@@ input)) + (bit//signed-shift-right-32 (|> (@@ shift) (r.- (r.int 32))))) + high (r.if (|> (int64-high (@@ input)) (r.>= (r.int 0))) + (r.int 0) + (r.int -1))] + (r.do! (int//new high low)))))) + +(runtime: (int/// param subject) + (let [negative? (|>> (int//< int//zero)) + valid-division-check [(|> (@@ param) (int//= int//zero)) + (r.stop! (r.string "Cannot divide by zero!"))] + short-circuit-check [(|> (@@ subject) (int//= int//zero)) + (r.do! int//zero)]] + (r.cond! (list valid-division-check + short-circuit-check + + [(|> (@@ subject) (int//= int//min)) + (r.cond! (list [(|> (|> (@@ param) (int//= int//one)) + (r.or (|> (@@ param) (int//= int//-one)))) + (r.do! int//min)] + [(|> (@@ param) (int//= int//min)) + (r.do! int//one)]) + (with-vars [approximation] + ($_ r.then! + (r.set! approximation + (|> (@@ subject) + (bit//signed-shift-right (r.int 1)) + (int/// (@@ param)) + (bit//shift-left (r.int 1)))) + (r.if! (|> (@@ approximation) (int//= int//zero)) + (r.do! (r.if (negative? (@@ param)) + int//one + int//-one)) + (let [remainder (int//- (int//* (@@ param) (@@ approximation)) + (@@ subject))] + (r.do! (|> remainder + (int/// (@@ param)) + (int//+ (@@ approximation)))))))))] + [(|> (@@ param) (int//= int//min)) + (r.do! int//zero)] + + [(negative? (@@ subject)) + (r.do! (r.if (negative? (@@ param)) + (|> (int//negate (@@ subject)) + (int/// (int//negate (@@ param)))) + (|> (int//negate (@@ subject)) + (int/// (@@ param)) + int//negate)))] + + [(negative? (@@ param)) + (r.do! (|> (@@ param) + int//negate + (int/// (@@ subject)) + int//negate))]) + (with-vars [result remainder approximate approximate-result log2 approximate-remainder] + ($_ r.then! + (r.set! result int//zero) + (r.set! remainder (@@ subject)) + (r.while! (|> (|> (@@ remainder) (int//< (@@ param))) + (r.or (|> (@@ remainder) (int//= (@@ param))))) + (let [calc-rough-estimate (r.apply (list (|> (int//to-float (@@ remainder)) (r./ (int//to-float (@@ param))))) + (r.global "floor")) + calc-approximate-result (int//from-float (@@ approximate)) + calc-approximate-remainder (|> (@@ approximate-result) (int//* (@@ param))) + delta (r.if (|> (r.float 48.0) (r.<= (@@ log2))) + (r.float 1.0) + (r.** (|> (@@ log2) (r.- (r.float 48.0))) + (r.float 2.0)))] + ($_ r.then! + (r.set! approximate (r.apply (list (r.float 1.0) calc-rough-estimate) + (r.global "max"))) + (r.set! log2 (let [log (function (_ input) + (r.apply (list input) (r.global "log")))] + (r.apply (list (|> (log (r.int 2)) + (r./ (log (@@ approximate))))) + (r.global "ceil")))) + (r.set! approximate-result calc-approximate-result) + (r.set! approximate-remainder calc-approximate-remainder) + (r.while! (|> (negative? (@@ approximate-remainder)) + (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder))))) + ($_ r.then! + (r.set! approximate (|> delta (r.- (@@ approximate)))) + (r.set! approximate-result calc-approximate-result) + (r.set! approximate-remainder calc-approximate-remainder))) + (r.set! result (|> (r.if (|> (@@ approximate-result) (int//= int//zero)) + int//one + (@@ approximate-result)) + (int//+ (@@ result)))) + (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder))))))) + (r.do! (@@ result)))) + ))) + +(runtime: (int//% param subject) + (let [flat (|> (@@ subject) (int/// (@@ param)) (int//* (@@ param)))] + (r.do! (|> (@@ subject) (int//- flat))))) + +(def: runtime//int + Runtime + ($_ r.then! + @@int//unsigned-low + @@int//to-float + @@int//new + @@int//zero + @@int//one + @@int//min + @@int//max + @@int//= + @@int//< + @@int//+ + @@int//- + @@int//* + @@int/// + @@int//% + @@int//negate + @@int//from-float)) + +(runtime: (lux//try op) + (with-vars [error value] + (r.do! (r.try ($_ r.then! + (r.set! value (r.apply (list ..unit) (@@ op))) + (r.do! (..right (@@ value)))) + #.None + (#.Some (r.function (list error) + (r.do! (..left (@@ error))))) + #.None)))) + +(runtime: (lux//program-args program-args) + (with-vars [inputs value] + ($_ r.then! + (r.set! inputs ..none) + (<| (r.for-in! value (@@ program-args)) + (r.set! inputs (..some (r.list (list (@@ value) (@@ inputs)))))) + (r.do! (@@ inputs))))) + +(def: runtime//lux + Runtime + ($_ r.then! + @@lux//try + @@lux//program-args)) + +(def: current-time-float + Expression + (let [raw-time (r.apply (list) (r.global "Sys.time"))] + (r.apply (list raw-time) (r.global "as.numeric")))) + +(runtime: (io//current-time! _) + (r.do! (|> current-time-float + (r.* (r.float 1_000.0)) + int//from-float))) + +(def: runtime//io + Runtime + ($_ r.then! + @@io//current-time!)) + +(def: minimum-index-length + (-> SVar Expression) + (|>> @@ (r.+ (r.int 1)))) + +(def: (product-element product index) + (-> Expression Expression Expression) + (|> product (r.nth (|> index (r.+ (r.int 1)))))) + +(def: (product-tail product) + (-> SVar Expression) + (|> (@@ product) (r.nth (r.length (@@ product))))) + +(def: (updated-index min-length product) + (-> Expression Expression Expression) + (|> min-length (r.- (r.length product)))) + +(runtime: (product//left product index) + (let [$index_min_length (r.var "index_min_length")] + ($_ r.then! + (r.set! $index_min_length (minimum-index-length index)) + (r.do! (r.if (|> (r.length (@@ product)) (r.> (@@ $index_min_length))) + ## No need for recursion + (product-element (@@ product) (@@ index)) + ## Needs recursion + (product//left (product-tail product) + (updated-index (@@ $index_min_length) (@@ product)))))))) + +(runtime: (product//right product index) + (let [$index_min_length (r.var "index_min_length")] + ($_ r.then! + (r.set! $index_min_length (minimum-index-length index)) + (r.do! (r.cond (list [## Last element. + (|> (r.length (@@ product)) (r.= (@@ $index_min_length))) + (product-element (@@ product) (@@ index))] + [## Needs recursion + (|> (r.length (@@ product)) (r.< (@@ $index_min_length))) + (product//right (product-tail product) + (updated-index (@@ $index_min_length) (@@ product)))]) + ## Must slice + (|> (@@ product) (r.slice-from (@@ index)))))))) + +(runtime: (sum//get sum wanted_tag wants_last) + (let [no-match r.null + sum-tag (|> (@@ sum) (r.nth (r.string //.variant-tag-field))) + sum-flag (|> (@@ sum) (r.nth (r.string //.variant-flag-field))) + sum-value (|> (@@ sum) (r.nth (r.string //.variant-value-field))) + is-last? (|> sum-flag (r.= (r.string ""))) + test-recursion (r.if is-last? + ## Must recurse. + (sum//get sum-value + (|> (@@ wanted_tag) (r.- sum-tag)) + (@@ wants_last)) + no-match)] + (r.do! (r.cond (list [(r.= sum-tag (@@ wanted_tag)) + (r.if (r.= (@@ wants_last) sum-flag) + sum-value + test-recursion)] + + [(|> (@@ wanted_tag) (r.> sum-tag)) + test-recursion] + + [(|> (|> (@@ wants_last) (r.= (r.string ""))) + (r.and (|> (@@ wanted_tag) (r.< sum-tag)))) + (variant' (|> sum-tag (r.- (@@ wanted_tag))) sum-flag sum-value)]) + + no-match)))) + +(def: runtime//adt + Runtime + ($_ r.then! + @@product//left + @@product//right + @@sum//get + )) + +(do-template [<name> <op>] + [(runtime: (<name> mask input) + (r.do! (int//new (<op> (int64-high (@@ mask)) + (int64-high (@@ input))) + (<op> (int64-low (@@ mask)) + (int64-low (@@ input))))))] + + [bit//and r.bit-and] + [bit//or r.bit-or] + [bit//xor r.bit-xor] + ) + +(runtime: (bit//count-32 input) + (with-vars [count] + ($_ r.then! + (r.set! count (r.int 0)) + (let [last-input-bit (|> (@@ input) (r.bit-and (r.int 1))) + update-count! (r.set! count (|> (@@ count) (r.+ last-input-bit))) + consume-input! (r.set! input (|> (@@ input) (r.bit-ushr (r.int 1)))) + input-remaining? (|> (@@ input) (r.= (r.int 0)))] + (r.while! input-remaining? + ($_ r.then! + update-count! + consume-input!))) + (r.do! (@@ count))))) + +(runtime: (bit//count input) + (r.do! (int//from-float (r.+ (int64-high (@@ input)) + (int64-low (@@ input)))))) + +(runtime: (bit//shift-right shift input) + ($_ r.then! + (limit-shift! shift) + (r.cond! (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) (r.bit-ushr (@@ shift))) + low (|> (int64-low (@@ input)) + (r.bit-ushr (@@ shift)) + (r.bit-or mid))] + (r.do! (int//new high low)))] + [(|> (@@ shift) (r.= (r.int 32))) + (let [high (int64-high (@@ input))] + (r.do! (int//new (r.int 0) high)))]) + (let [low (|> (int64-high (@@ input)) (r.bit-ushr (|> (@@ shift) (r.- (r.int 32)))))] + (r.do! (int//new (r.int 0) low)))))) + +(def: runtime//bit + Runtime + ($_ r.then! + @@bit//and + @@bit//or + @@bit//xor + @@bit//not + @@bit//count-32 + @@bit//count + @@bit//shift-left + @@bit//signed-shift-right-32 + @@bit//signed-shift-right + @@bit//shift-right + )) + +(runtime: (nat//< param subject) + (with-vars [pH sH] + ($_ r.then! + (r.set! pH (..int64-high (@@ param))) + (r.set! sH (..int64-high (@@ subject))) + (let [lesser-high? (|> (@@ sH) (r.< (@@ pH))) + equal-high? (|> (@@ sH) (r.= (@@ pH))) + lesser-low? (|> (..int64-low (@@ subject)) (r.< (..int64-low (@@ param))))] + (r.do! (|> lesser-high? + (r.or (|> equal-high? + (r.and lesser-low?))))))))) + +(runtime: (nat/// parameter subject) + (let [negative? (int//< int//zero) + valid-division-check [(|> (@@ parameter) (int//= int//zero)) + (r.stop! (r.string "Cannot divide by zero!"))] + short-circuit-check [(|> (@@ subject) (nat//< (@@ parameter))) + (r.do! int//zero)]] + (r.cond! (list valid-division-check + short-circuit-check + + [(|> (@@ parameter) + (nat//< (|> (@@ subject) (bit//shift-right (r.int 1))))) + (r.do! int//one)]) + (with-vars [result remainder approximate log2 approximate-result approximate-remainder delta] + ($_ r.then! + (r.set! result int//zero) + (r.set! remainder (@@ subject)) + (r.while! (|> (|> (@@ remainder) (nat//< (@@ parameter))) + (r.or (|> (@@ remainder) (int//= (@@ parameter))))) + (let [rough-estimate (r.apply (list (|> (int//to-float (@@ parameter)) (r./ (int//to-float (@@ remainder))))) + (r.global "floor")) + calculate-approximate-result (int//from-float (@@ approximate)) + calculate-approximate-remainder (int//* (@@ parameter) (@@ approximate-result)) + delta (r.if (|> (r.float 48.0) (r.<= (@@ log2))) + (r.float 1.0) + (r.** (|> (r.float 48.0) (r.- (@@ log2))) + (r.float 2.0))) + update-approximates! ($_ r.then! + (r.set! approximate-result calculate-approximate-result) + (r.set! approximate-remainder calculate-approximate-remainder))] + ($_ r.then! + (r.set! approximate (r.apply (list (r.float 1.0) rough-estimate) + (r.global "max"))) + (r.set! log2 (let [log (function (_ input) + (r.apply (list input) (r.global "log")))] + (r.apply (list (|> (log (r.int 2)) + (r./ (log (@@ approximate))))) + (r.global "ceil")))) + update-approximates! + (r.while! (|> (negative? (@@ approximate-remainder)) + (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder))))) + ($_ r.then! + (r.set! approximate (|> delta (r.- (@@ approximate)))) + update-approximates!)) + ($_ r.then! + (r.set! result (|> (@@ result) + (int//+ (r.if (|> (@@ approximate-result) (int//= int//zero)) + int//one + (@@ approximate-result))))) + (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder)))))))) + (r.do! (@@ result)))) + ))) + +(runtime: (nat//% param subject) + (let [flat (|> (@@ subject) + (nat/// (@@ param)) + (int//* (@@ param)))] + (r.do! (|> (@@ subject) (int//- flat))))) + +(def: runtime//nat + Runtime + ($_ r.then! + @@nat//< + @@nat/// + @@nat//%)) + +(runtime: (deg//* param subject) + (with-vars [sL sH pL pH bottom middle top] + ($_ r.then! + (r.set! sL (int//from-float (int64-low (@@ subject)))) + (r.set! sH (int//from-float (int64-high (@@ subject)))) + (r.set! pL (int//from-float (int64-low (@@ param)))) + (r.set! pH (int//from-float (int64-high (@@ param)))) + (let [bottom (bit//shift-right (r.int 32) + (r.* (@@ pL) (@@ sL))) + middle (r.+ (r.* (@@ pL) (@@ sH)) + (r.* (@@ pH) (@@ sL))) + top (r.* (@@ pH) (@@ sH))] + (r.do! (|> bottom + (r.+ middle) + (bit//shift-right (r.int 32)) + (r.+ top))))))) + +(runtime: (deg//leading-zeroes input) + (with-vars [zeroes remaining] + ($_ r.then! + (r.set! zeroes (r.int 64)) + (r.set! remaining (@@ input)) + (r.while! (|> (@@ remaining) (int//= int//zero) r.not) + ($_ r.then! + (r.set! zeroes (|> (@@ zeroes) (r.- (r.int 1)))) + (r.set! remaining (|> (@@ remaining) (bit//shift-right (r.int 1)))))) + (r.do! (@@ zeroes))))) + +(runtime: (deg/// param subject) + (with-vars [min-shift] + (r.if! (|> (@@ subject) (int//= (@@ param))) + (r.do! int//-one) + ($_ r.then! + (r.set! min-shift + (r.apply (list (deg//leading-zeroes (@@ param)) + (deg//leading-zeroes (@@ subject))) + (r.global "min"))) + (let [subject' (|> (@@ subject) (bit//shift-left (@@ min-shift))) + param' (|> (@@ param) (bit//shift-left (@@ min-shift)) int64-low int//from-float)] + (r.do! (|> subject' + (int/// param') + (bit//shift-left (r.int 32))))))))) + +(runtime: (deg//from-frac input) + (with-vars [two32 shifted] + ($_ r.then! + (r.set! two32 (|> (r.float 2.0) (r.** (r.float 32.0)))) + (r.set! shifted (|> (@@ input) (r.%% (r.float 1.0)) (r.* (@@ two32)))) + (let [low (|> (@@ shifted) (r.%% (r.float 1.0)) (r.* (@@ two32)) as-integer) + high (|> (@@ shifted) as-integer)] + (r.do! (int//new high low)))))) + +(runtime: (deg//to-frac input) + (with-vars [two32] + ($_ r.then! + (r.set! two32 f2^32) + (let [high (|> (int64-high (@@ input)) (r./ (@@ two32))) + low (|> (int64-low (@@ input)) (r./ (@@ two32)) (r./ (@@ two32)))] + (r.do! (|> low (r.+ high))))))) + +(def: runtime//deg + Runtime + ($_ r.then! + @@deg//* + @@deg//leading-zeroes + @@deg/// + @@deg//from-frac + @@deg//to-frac)) + +(runtime: (frac//decode input) + (with-vars [output] + ($_ r.then! + (r.set! output (r.apply (list (@@ input)) (r.global "as.numeric"))) + (r.do! (r.if (|> (@@ output) (r.= r.n/a)) + ..none + (..some (@@ output))))))) + +(def: runtime//frac + Runtime + ($_ r.then! + @@frac//decode)) + +(def: inc (-> Expression Expression) (|>> (r.+ (r.int 1)))) + +(do-template [<name> <top-cmp>] + [(def: (<name> top value) + (-> Expression Expression Expression) + (|> (|> value (r.>= (r.int 0))) + (r.and (|> value (<top-cmp> top)))))] + + [within? r.<] + [up-to? r.<=] + ) + +(def: (text-clip start end text) + (-> Expression Expression Expression Expression) + (r.apply (list text start end) + (r.global "substr"))) + +(def: (text-length text) + (-> Expression Expression) + (r.apply (list text) (r.global "nchar"))) + +(runtime: (text//index subject param start) + (with-vars [idx startF subjectL] + ($_ r.then! + (r.set! startF (int//to-float (@@ start))) + (r.set! subjectL (text-length (@@ subject))) + (r.do! + (r.if (|> (@@ startF) (within? (@@ subjectL))) + (r.block + ($_ r.then! + (r.set! idx (|> (r.apply-kw (list (@@ param) (r.if (|> (@@ startF) (r.= (r.int 0))) + (@@ subject) + (text-clip (inc (@@ startF)) + (inc (@@ subjectL)) + (@@ subject)))) + (list ["fixed" (r.bool true)]) + (r.global "regexpr")) + (r.nth (r.int 1)))) + (r.do! + (r.if (|> (@@ idx) (r.= (r.int -1))) + ..none + (..some (int//from-float (|> (@@ idx) (r.+ (@@ startF))))))))) + ..none))))) + +(runtime: (text//clip text from to) + (with-vars [length] + ($_ r.then! + (r.set! length (r.length (@@ text))) + (r.do! + (r.if ($_ r.and + (|> (@@ to) (within? (@@ length))) + (|> (@@ from) (up-to? (@@ to)))) + (..some (text-clip (inc (@@ from)) (inc (@@ to)) (@@ text))) + ..none))))) + +(def: (char-at idx text) + (-> Expression Expression Expression) + (r.apply (list (text-clip idx idx text)) + (r.global "utf8ToInt"))) + +(runtime: (text//char text idx) + (r.if! (|> (@@ idx) (within? (r.length (@@ text)))) + ($_ r.then! + (r.set! idx (inc (@@ idx))) + (r.do! (..some (int//from-float (char-at (@@ idx) (@@ text)))))) + (r.do! ..none))) + +(runtime: (text//hash input) + (let [bits-32 (r.code "0xFFFFFFFF")] + (with-vars [idx hash] + ($_ r.then! + (r.set! hash (r.int 0)) + (r.for-in! idx (r.range (r.int 1) (text-length (@@ input))) + (r.set! hash (|> (@@ hash) + (r.bit-shl (r.int 5)) + (r.- (@@ hash)) + (r.+ (char-at (@@ idx) (@@ input))) + (r.bit-and bits-32)))) + (r.do! (int//from-float (@@ hash))))))) + +(def: runtime//text + Runtime + ($_ r.then! + @@text//index + @@text//clip + @@text//char + @@text//hash)) + +(def: (check-index-out-of-bounds array idx body!) + (-> Expression Expression Statement Statement) + (r.if! (|> idx (r.<= (r.length array))) + body! + (r.stop! (r.string "Array index out of bounds!")))) + +(runtime: (array//new size) + (with-vars [output] + ($_ r.then! + (r.set! output (r.list (list))) + (r.set-nth! (|> (@@ size) (r.+ (r.int 1))) + r.null + output) + (r.do! (@@ output))))) + +(runtime: (array//get array idx) + (with-vars [temp] + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + ($_ r.then! + (r.set! temp (|> (@@ array) (r.nth (@@ idx)))) + (r.if! (|> (@@ temp) (r.= r.null)) + (r.do! ..none) + (r.do! (..some (@@ temp)))))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + ($_ r.then! + (r.set-nth! (@@ idx) (@@ value) array) + (r.do! (@@ array))))) + +(def: runtime//array + Runtime + ($_ r.then! + @@array//new + @@array//get + @@array//put)) + +(def: #export atom//field Text "lux_atom") + +(runtime: (atom//compare-and-swap atom old new) + (let [atom//field (r.string atom//field)] + (r.do! + (r.if (|> (@@ atom) (r.nth atom//field) (r.= (@@ old))) + (r.block + ($_ r.then! + (r.set-nth! atom//field (@@ new) atom) + (r.do! (r.bool true)))) + (r.bool false))))) + +(def: runtime//atom + Runtime + ($_ r.then! + @@atom//compare-and-swap)) + +(runtime: (box//write value box) + ($_ r.then! + (r.set-nth! (r.int 1) (@@ value) box) + (r.do! ..unit))) + +(def: runtime//box + Runtime + ($_ r.then! + @@box//write)) + +(def: process//incoming + SVar + (r.var (lang.normalize-name "process//incoming"))) + +(def: (list-append! value rlist) + (-> Expression SVar Statement) + (r.set-nth! (r.length (@@ rlist)) value rlist)) + +(runtime: (process//loop _) + (let [empty (r.list (list))] + (with-vars [queue process] + (let [migrate-incoming! ($_ r.then! + (r.set! queue empty) + (<| (r.for-in! process (@@ process//incoming)) + (list-append! (@@ process) queue)) + (r.set! process//incoming empty)) + consume-queue! (<| (r.for-in! process (@@ queue)) + (r.do! (r.apply (list ..unit) (@@ process))))] + ($_ r.then! + migrate-incoming! + consume-queue! + (r.when! (|> (r.length (@@ queue)) (r.> (r.int 0))) + (r.do! (process//loop ..unit)))))))) + +(runtime: (process//future procedure) + ($_ r.then! + (list-append! (@@ procedure) process//incoming) + (r.do! ..unit))) + +(runtime: (process//schedule milli-seconds procedure) + (let [to-seconds (|>> (r./ (r.float 1_000.0))) + to-millis (|>> (r.* (r.float 1_000.0)))] + (with-vars [start now seconds _arg elapsed-time] + ($_ r.then! + (r.set! start current-time-float) + (r.set! seconds (to-seconds (@@ milli-seconds))) + (list-append! (r.function (list _arg) + ($_ r.then! + (r.set! now current-time-float) + (r.set! elapsed-time (|> (@@ now) (r.- (@@ start)))) + (r.if! (|> (@@ elapsed-time) (r.>= (@@ seconds))) + (r.do! (@@ procedure)) + (r.do! (process//schedule (to-millis (@@ elapsed-time)) + (@@ procedure)))))) + process//incoming) + (r.do! ..unit))))) + +(def: runtime//process + Runtime + ($_ r.then! + (r.set! process//incoming (r.list (list))) + @@process//loop + @@process//future + @@process//schedule + )) + +(def: runtime + Runtime + ($_ r.then! + runtime//int + runtime//lux + runtime//adt + runtime//bit + runtime//nat + runtime//deg + runtime//frac + runtime//text + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + )) + +(def: #export artifact Text (format prefix ".r")) + +(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/r/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/r/statement.jvm.lux new file mode 100644 index 000000000..317abcf73 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/statement.jvm.lux @@ -0,0 +1,45 @@ +(.module: + lux + (lux (control [monad #+ do]) + [macro] + (data text/format)) + (luxc (lang [".L" module] + (host [r #+ 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 (r.set! def-name 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")) diff --git a/new-luxc/source/luxc/lang/translation/r/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/r/structure.jvm.lux new file mode 100644 index 000000000..16d144f93 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/structure.jvm.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format) + [macro]) + (luxc ["&" lang] + (lang [synthesis #+ Synthesis] + (host [r #+ 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 (r.list 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)))) |