diff options
Diffstat (limited to 'new-luxc/source')
20 files changed, 2259 insertions, 15 deletions
diff --git a/new-luxc/source/luxc/lang/host/scheme.lux b/new-luxc/source/luxc/lang/host/scheme.lux new file mode 100644 index 000000000..db91b94ce --- /dev/null +++ b/new-luxc/source/luxc/lang/host/scheme.lux @@ -0,0 +1,260 @@ +(.module: + [lux #- not or and list if function cond when let] + (lux (control pipe) + (data [maybe "maybe/" Functor<Maybe>] + [text] + text/format + [number] + (coll [list "list/" Functor<List> Fold<List>])) + (type abstract))) + +(abstract: #export Single {} Unit) +(abstract: #export Poly {} Unit) + +(abstract: #export (Var kind) + {} + + Text + + (def: name (All [k] (-> (Var k) Text)) (|>> @representation)) + + (def: #export var (-> Text (Var Single)) (|>> @abstraction)) + + (def: #export (poly vars) + (-> (List (Var Single)) (Var Poly)) + (@abstraction + (format "(" (|> vars (list/map ..name) (text.join-with " ")) ")"))) + + (def: #export (poly+ vars rest) + (-> (List (Var Single)) (Var Single) (Var Poly)) + (@abstraction + (format "(" (|> vars (list/map ..name) (text.join-with " ")) + " . " (..name rest) + ")"))) + ) + +(type: #export SVar (Var Single)) +(type: #export PVar (Var Poly)) +(type: #export *Var (Ex [k] (Var k))) + +(abstract: #export Expression + {} + + Text + + (def: #export expression (-> Expression Text) (|>> @representation)) + + (def: #export code (-> Text Expression) (|>> @abstraction)) + + (def: #export nil + Expression + (@abstraction "'()")) + + (def: #export bool + (-> Bool Expression) + (|>> (case> true "#t" + false "#f") + @abstraction)) + + (def: #export int + (-> Int Expression) + (|>> %i @abstraction)) + + (def: #export float + (-> Frac Expression) + (|>> (cond> [(f/= number.positive-infinity)] + [(new> "+inf.0")] + + [(f/= number.negative-infinity)] + [(new> "-inf.0")] + + [number.not-a-number?] + [(new> "+nan.0")] + + ## else + [%f]) + @abstraction)) + + (def: #export positive-infinity Expression (..float number.positive-infinity)) + (def: #export negative-infinity Expression (..float number.negative-infinity)) + (def: #export not-a-number Expression (..float number.not-a-number)) + + (def: #export string + (-> Text Expression) + (|>> %t @abstraction)) + + (def: #export symbol + (-> Text Expression) + (|>> (format "'") @abstraction)) + + (def: #export (form elements) + (-> (List Expression) Expression) + (@abstraction + (format "(" (|> elements (list/map expression) (text.join-with " ")) ")"))) + + (def: #export @@ + (All [k] (-> (Var k) Expression)) + (|>> ..name @abstraction)) + + (def: #export global + (-> Text Expression) + (|>> var @@)) + + (def: #export (apply func args) + (-> Expression (List Expression) Expression) + (form (#.Cons func args))) + + (do-template [<name> <function>] + [(def: #export <name> + (-> (List Expression) Expression) + (apply (..global <function>)))] + + [vector "vector"] + [list "list"] + ) + + (def: #export (apply1 func) + (-> Expression (-> Expression Expression)) + (|>> (.list) (..apply func))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply1 (..global <scheme-name>)))] + + [length "length"] + [values "values"] + [null? "null?"] + [car "car"] + [cdr "cdr"] + [raise "raise"] + [error-object-message "error-object-message"] + [make-vector "make-vector"] + [not "not"] + [string-hash "string-hash"] + ) + + (def: #export (apply2 func) + (-> Expression (-> Expression Expression Expression)) + (.function (_ _0 _1) + (..apply func (.list _0 _1)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply2 (..global <scheme-name>)))] + + [append "append"] + [cons "cons"] + [vector-ref "vector-ref"] + [list-tail "list-tail"] + ) + + (def: #export (apply3 func) + (-> Expression (-> Expression Expression Expression Expression)) + (.function (_ _0 _1 _2) + (..apply func (.list _0 _1 _2)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply3 (..global <scheme-name>)))] + + [vector-set! "vector-set!"] + ) + + (def: #export (vector-copy! _0 _1 _2 _3 _4) + (-> Expression Expression Expression Expression Expression + Expression) + (..apply (..global "vector-copy!") + (.list _0 _1 _2 _3 _4))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> + (-> (List Expression) Expression) + (|>> (.list& (..global <scheme-name>)) ..form))] + + [or "or"] + [and "and"] + ) + + (do-template [<lux-name> <scheme-name>] + [(def: #export (<lux-name> param subject) + (-> Expression Expression Expression) + (..form (.list (..global <scheme-name>) subject param)))] + + [= "="] + [eq? "eq?"] + [eqv? "eqv?"] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [string=? "string=?"] + [string<? "string<?"] + [+ "+"] + [- "-"] + [/ "/"] + [* "*"] + [expt "expt"] + [remainder "remainder"] + [quotient "quotient"] + [mod "mod"] + [arithmetic-shift "arithmetic-shift"] + [bit-and "bitwise-and"] + [bit-or "bitwise-ior"] + [bit-xor "bitwise-xor"] + ) + + (do-template [<lux-name> <scheme-name> <var>] + [(def: #export (<lux-name> bindings body) + (-> (List [<var> Expression]) Expression Expression) + (..form (.list (..global <scheme-name>) + (|> bindings + (list/map (.function (_ [fname fvalue]) + (..form (.list (@@ fname) fvalue)))) + ..form) + body)))] + + [let "let" SVar] + [let* "let*" SVar] + [letrec "letrec" SVar] + [let-values "let-values" PVar] + ) + + (def: #export (if test then else) + (-> Expression Expression Expression Expression) + (..form (.list (..global "if") test then else))) + + (def: #export (when test then) + (-> Expression Expression Expression) + (..form (.list (..global "when") test then))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Expression) + (list/fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses))) + + (def: #export (lambda input body) + (-> *Var Expression Expression) + (..form (.list (..global "lambda") (@@ input) body))) + + (def: #export (define name inputs body) + (-> SVar (List SVar) Expression Expression) + (..form (.list (..global "define") + (case inputs + #.Nil + (@@ name) + + _ + (@@ (..poly (#.Cons name inputs)))) + body))) + + (def: #export begin + (-> (List Expression) Expression) + (|>> (#.Cons (..global "begin")) ..form)) + + (def: #export (set! name value) + (-> SVar Expression Expression) + (..form (.list (..global "set!") (@@ name) value))) + + (def: #export (with-exception-handler handler body) + (-> Expression Expression Expression) + (..form (.list (..global "with-exception-handler") handler body))) + ) diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux index 45b6ec10e..82a8bb5c9 100644 --- a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux @@ -118,11 +118,11 @@ (^template [<pm> <flag>] (^code (<pm> (~ [_ (#.Nat idx)]))) (meta/wrap (format "temp = " runtimeT.sum//get "(" peek-cursor "," (|> idx nat-to-int %i) "," <flag> ");" - "if(temp !== null) {" - (push-cursor "temp") + "if(temp == null) {" + fail-pattern-matching "}" "else {" - fail-pattern-matching + (push-cursor "temp") "}"))) (["lux case variant left" "null"] ["lux case variant right" "\"\""]) diff --git a/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux index 1853338b4..ed084b44d 100644 --- a/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux @@ -118,9 +118,9 @@ (^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)))))) + (lua.if! (lua.= lua.nil "temp") + (lua.return! pm-error) + (push-cursor! "temp")))))) (["lux case variant left" lua.nil] ["lux case variant right" (lua.string "")]) diff --git a/new-luxc/source/luxc/lang/translation/python/case.jvm.lux b/new-luxc/source/luxc/lang/translation/python/case.jvm.lux index 2668ae9f2..6e5935297 100644 --- a/new-luxc/source/luxc/lang/translation/python/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/python/case.jvm.lux @@ -132,9 +132,9 @@ (^code (<pm> (~ [_ (#.Nat idx)]))) (meta/wrap ($_ python.then! (python.set! (list $temp) (runtimeT.sum//get cursor-top (python.int (:! Int idx)) <flag>)) - (python.if! (python.not (python.= python.none (@@ $temp))) - (push-cursor! (@@ $temp)) - fail-pm!)))) + (python.if! (python.= python.none (@@ $temp)) + fail-pm! + (push-cursor! (@@ $temp)))))) (["lux case variant left" python.none] ["lux case variant right" (python.string "")]) diff --git a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux index 6ceae3842..8a61f0263 100644 --- a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux @@ -138,9 +138,9 @@ (^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!)))) + (r.if (r.= r.null (@@ $temp)) + fail-pm! + (push-cursor! (@@ $temp)))))) (["lux case variant left" r.null] ["lux case variant right" (r.string "")]) diff --git a/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux index 7f951a9dc..d76b2a757 100644 --- a/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux @@ -123,9 +123,9 @@ (^template [<pm> <flag>] (^code (<pm> (~ [_ (#.Nat idx)]))) (meta/wrap (ruby.block! (list (ruby.set! (list "temp") (runtimeT.sum//get cursor-top (ruby.int (:! Int idx)) <flag>)) - (ruby.if! (ruby.not (ruby.= ruby.nil "temp")) - (push-cursor! "temp") - (ruby.raise pm-error)))))) + (ruby.if! (ruby.= ruby.nil "temp") + (ruby.raise pm-error) + (push-cursor! "temp")))))) (["lux case variant left" ruby.nil] ["lux case variant right" (ruby.string "")]) diff --git a/new-luxc/source/luxc/lang/translation/scheme.lux b/new-luxc/source/luxc/lang/translation/scheme.lux new file mode 100644 index 000000000..c32890a84 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme.lux @@ -0,0 +1,214 @@ +(.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 [scheme #+ Expression])) + [".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 gnu/mapping/Environment) + +(host.import gnu/expr/Language + (eval [String] #try #? Object)) + +(host.import kawa/standard/Scheme + (#static getR7rsInstance [] Scheme)) + +(type: #export Anchor [Text Register]) + +(type: #export Host + {#context [Text Nat] + #anchor (Maybe Anchor) + #loader (-> Expression (Error Unit)) + #interpreter (-> Expression (Error Object)) + #module-buffer (Maybe StringBuilder) + #program-buffer StringBuilder}) + +(def: #export init + (IO Host) + (io (let [interpreter (Scheme::getR7rsInstance [])] + {#context ["" +0] + #anchor #.None + #loader (function (_ code) + (do e.Monad<Error> + [_ (Language::eval [(scheme.expression code)] interpreter)] + (wrap []))) + #interpreter (function (_ code) + (do e.Monad<Error> + [output (Language::eval [(scheme.expression code)] interpreter)] + (wrap (maybe.default (:! Object []) + output)))) + #module-buffer #.None + #program-buffer (StringBuilder::new [])}))) + +(def: #export file-extension ".scm") + +(def: #export r-module-name Text (format "module" file-extension)) + +(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> <outputT>] + [(def: (<name> code) + (-> Expression (Meta <outputT>)) + (function (_ compiler) + (let [runner (|> compiler (get@ #.host) (:! Host) (get@ <field>))] + (case (runner code) + (#e.Error error) + ((lang.throw Cannot-Execute error) compiler) + + (#e.Success output) + (#e.Success [compiler output])))))] + + [load! #loader Unit] + [interpret #interpreter Object] + ) + +(def: #export variant-tag "lux-variant") + +(def: #export unit Text "") + +(def: #export (definition-name [module name]) + (-> Ident Text) + (lang.normalize-name (format module "$" name))) + +(def: #export (save code) + (-> Expression (Meta Unit)) + (do macro.Monad<Meta> + [module-buffer module-buffer + #let [_ (Appendable::append [(:! CharSequence (scheme.expression code))] + module-buffer)]] + (load! code))) + +(def: #export run interpret) + +(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/scheme/case.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..0d67848c7 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux @@ -0,0 +1,179 @@ +(.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 ["_" scheme #+ Expression 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 (_.let (list [$register valueO]) + 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 (_.int (:! Int idx))))) + valueO + pathP)))) + +(def: #export (translate-if testO thenO elseO) + (-> Expression Expression Expression Expression) + (_.if testO thenO elseO)) + +(def: $savepoint (_.var "lux_pm_cursor_savepoint")) +(def: $cursor (_.var "lux_pm_cursor")) + +(def: top _.length) +(def: (push! value var) + (-> Expression SVar Expression) + (_.set! var (_.cons value (@@ var)))) +(def: (pop! var) + (-> SVar Expression) + (_.set! var (@@ var))) + +(def: (push-cursor! value) + (-> Expression Expression) + (push! value $cursor)) + +(def: save-cursor! + Expression + (push! (@@ $cursor) $savepoint)) + +(def: restore-cursor! + Expression + (_.set! $cursor (_.car (@@ $savepoint)))) + +(def: cursor-top + Expression + (_.car (@@ $cursor))) + +(def: pop-cursor! + Expression + (pop! $cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise pm-error)) + +(def: $temp (_.var "lux_pm_temp")) + +(exception: #export (Unrecognized-Path {message Text}) + message) + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Expression) + (_.lambda (_.poly (list $alt_error)) + (_.if (|> (@@ $alt_error) (_.eqv? pm-error)) + handler + (_.raise (@@ $alt_error))))) + +(def: (translate-pattern-matching' translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) + (case pathP + (^code ("lux case exec" (~ bodyS))) + (do macro.Monad<Meta> + [bodyO (translate bodyS)] + (wrap bodyO)) + + (^code ("lux case pop")) + (meta/wrap pop-cursor!) + + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (meta/wrap (_.define (referenceT.variable register) (list) cursor-top)) + + (^template [<tag> <format> <=>] + [_ (<tag> value)] + (meta/wrap (_.when (|> value <format> (<=> cursor-top) _.not) + fail-pm!))) + ([#.Bool _.bool _.eqv?] + [#.Nat (<| _.int (:! Int)) _.=] + [#.Int _.int _.=] + [#.Deg (<| _.int (:! Int)) _.=] + [#.Frac _.float _.=] + [#.Text _.string _.eqv?]) + + (^template [<pm> <getter>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! (<getter> cursor-top (_.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 (_.begin (list (_.set! $temp (runtimeT.sum//get cursor-top (_.int (:! Int idx)) <flag>)) + (_.if (_.null? (@@ $temp)) + fail-pm! + (push-cursor! (@@ $temp))))))) + (["lux case variant left" _.nil] + ["lux case variant right" (_.string "")]) + + (^code ("lux case seq" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (_.begin (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 (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda (_.poly (list)) + (_.begin (list save-cursor! + leftO)))))) + + _ + (lang.throw Unrecognized-Path (%code pathP)) + )) + +(def: (translate-pattern-matching translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) + (do macro.Monad<Meta> + [pattern-matching! (translate-pattern-matching' translate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise (_.string "Invalid expression for pattern-matching."))) + (_.lambda (_.poly (list)) + pattern-matching!))))) + +(def: (initialize-pattern-matching! stack-init) + (-> Expression Expression) + (_.begin (list (_.set! $cursor (_.list (list stack-init))) + (_.set! $savepoint (_.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 (_.begin (list (initialize-pattern-matching! valueO) + pattern-matching!))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux new file mode 100644 index 000000000..a45af1f00 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux @@ -0,0 +1,154 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + [monad #+ do]) + (data [bit] + [maybe] + ["e" error #+ Error] + [text "text/" Eq<Text>] + text/format + (coll [array])) + [host]) + (luxc [lang] + (lang (host [scheme #+ Expression]))) + [//]) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Unknown-Kind-Of-Host-Object] + [Null-Has-No-Lux-Representation] + [Cannot-Evaluate] + [invalid-variant] + ) + +(host.import java/lang/Object + (toString [] String) + (getClass [] (Class Object))) + +(host.import java/lang/Long + (intValue [] Integer)) + +(host.import java/lang/Boolean) +(host.import java/lang/String) + +(host.import gnu/math/IntNum + (longValue [] long)) + +(host.import gnu/math/DFloNum + (doubleValue [] double)) + +(host.import (gnu/lists/FVector E) + (getBufferLength [] int) + (get [int] E)) + +(host.import gnu/lists/EmptyList) + +(host.import gnu/lists/FString + (toString [] String)) + +(host.import gnu/lists/Pair + (getCar [] Object) + (getCdr [] Object) + (get [int] Object)) + +(host.import gnu/mapping/Symbol + (getName [] String)) + +(host.import gnu/mapping/SimpleSymbol) + +(def: (parse-tuple lux-object host-object) + (-> (-> Object (Error Top)) (FVector Object) (Error Top)) + (let [size (:! Nat (FVector::getBufferLength [] host-object))] + (loop [idx +0 + output (:! (Array Top) (array.new size))] + (if (n/< size idx) + (case (lux-object (FVector::get [(:! Int idx)] host-object)) + (#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: (variant tag flag value) + (-> Nat Bool Top Top) + [(Long::intValue [] (:! Long tag)) + (: Top + (if flag + //.unit + (host.null))) + value]) + +(def: (to-text value) + (-> Top Text) + (let [value-text (:! Text (Object::toString [] (:! Object value))) + class-text (:! Text (Object::toString [] (Object::getClass [] (:! Object value))))] + (format value-text " : " class-text))) + +(def: (parse-variant lux-object host-object) + (-> (-> Object (Error Top)) Pair (Error Top)) + (let [variant-tag (Pair::getCar [] host-object)] + (if (and (host.instance? gnu/mapping/SimpleSymbol variant-tag) + (text/= //.variant-tag (Symbol::getName [] (:! Symbol variant-tag)))) + (do e.Monad<Error> + [#let [host-object (:! Pair (Pair::getCdr [] host-object))] + tag (lux-object (Pair::getCar [] host-object)) + #let [host-object (:! Pair (Pair::getCdr [] host-object))] + #let [flag (host.instance? java/lang/String + (Pair::getCar [] host-object))] + value (lux-object (Pair::getCdr [] host-object))] + (wrap (..variant (:! Nat tag) flag value))) + (ex.throw invalid-variant (:! Text (Object::toString [] (:! Object host-object))))))) + +(def: (lux-object host-object) + (-> Object (Error Top)) + (cond (or (host.instance? java/lang/Boolean host-object) + (host.instance? java/lang/String host-object)) + (#e.Success host-object) + + (host.instance? gnu/math/IntNum host-object) + (#e.Success (IntNum::longValue [] (:! IntNum host-object))) + + (host.instance? gnu/math/DFloNum host-object) + (#e.Success (DFloNum::doubleValue [] (:! DFloNum host-object))) + + (host.instance? gnu/lists/FString host-object) + (#e.Success (FString::toString [] (:! FString host-object))) + + (host.instance? gnu/lists/FVector host-object) + (parse-tuple lux-object (:! (FVector Object) host-object)) + + (host.instance? gnu/lists/EmptyList host-object) + (#e.Success //.unit) + + (host.instance? gnu/lists/Pair host-object) + (parse-variant lux-object (:! Pair host-object)) + + ## 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))))) + +(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" + "<< " (scheme.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" + "<< " (scheme.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler))))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..d906ae825 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux @@ -0,0 +1,87 @@ +(.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 ["_" scheme #+ Expression]))) + [//] + (// [".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 call" (~ functionS) (~+ argsS))) + (functionT.translate-apply translate functionS argsS) + + (^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 let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (caseT.translate-let translate register inputS exprS) + + (^code ("lux case" (~ inputS) (~ pathPS))) + (caseT.translate-case translate inputS pathPS) + + (^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/scheme/function.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..0d03b31a3 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/function.jvm.lux @@ -0,0 +1,87 @@ +(.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 ["_" scheme #+ Expression @@]))) + [//] + (// [".T" reference] + [".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 (_.apply functionO argsO+)))) + +(def: $curried (_.var "curried")) +(def: $missing (_.var "missing")) + +(def: input-declaration + (|>> n/inc referenceT.variable)) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Expression (Meta Expression)) + (let [$closure (_.var (format function-name "___CLOSURE"))] + (do macro.Monad<Meta> + [] + (case inits + #.Nil + (wrap function-definition) + + _ + (wrap (_.letrec (list [$closure + (_.lambda (|> (list.enumerate inits) + (list/map (|>> product.left referenceT.closure)) + _.poly) + function-definition)]) + (_.apply (@@ $closure) 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 [arityO (|> arity nat-to-int _.int) + $num_args (_.var "num_args") + $function (_.var function-name) + apply-poly (function (_ args func) + (_.apply (_.global "apply") (list func args)))]] + (with-closure function-name closureO+ + (_.letrec (list [$function (_.lambda $curried + (_.let (list [$num_args (_.length (@@ $curried))]) + (<| (_.if (|> (@@ $num_args) (_.= arityO)) + (_.let (list [(referenceT.variable +0) (@@ $function)]) + (_.let-values (list [(|> (list.n/range +0 (n/dec arity)) + (list/map input-declaration) + _.poly) + (_.apply (_.global "apply") (list (_.global "values") (@@ $curried)))]) + bodyO))) + (_.if (|> (@@ $num_args) (_.> arityO)) + (let [arity-args (runtimeT.list-slice (_.int 0) arityO (@@ $curried)) + output-func-args (runtimeT.list-slice arityO + (|> (@@ $num_args) (_.- arityO)) + (@@ $curried))] + (|> (@@ $function) + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> (@@ $num_args) (_.< arityO)) + (_.lambda $missing + (|> (@@ $function) + (apply-poly (_.append (@@ $curried) (@@ $missing))))))))]) + (@@ $function))) + )) diff --git a/new-luxc/source/luxc/lang/translation/scheme/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..ecaf12c7c --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/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 @@]))) + [//] + (// [".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))) + 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/scheme/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..c7043eeb7 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/primitive.jvm.lux @@ -0,0 +1,30 @@ +(.module: + lux + (lux [macro "meta/" Monad<Meta>]) + (luxc (lang (host [scheme #+ Expression]))) + [//] + (// [".T" runtime])) + +(def: #export translate-bool + (-> Bool (Meta Expression)) + (|>> scheme.bool meta/wrap)) + +(def: #export translate-int + (-> Int (Meta Expression)) + (|>> scheme.int meta/wrap)) + +(def: #export translate-nat + (-> Nat (Meta Expression)) + (|>> (:! Int) scheme.int meta/wrap)) + +(def: #export translate-deg + (-> Deg (Meta Expression)) + (|>> (:! Int) scheme.int meta/wrap)) + +(def: #export translate-frac + (-> Frac (Meta Expression)) + (|>> scheme.float meta/wrap)) + +(def: #export translate-text + (-> Text (Meta Expression)) + (|>> scheme.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/scheme/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure.jvm.lux new file mode 100644 index 000000000..0876e9b19 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/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 ["_" scheme #+ Expression]))) + [//] + (/ ["/." 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/scheme/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux new file mode 100644 index 000000000..f6a468f76 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux @@ -0,0 +1,535 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number #+ hex] + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host ["_" scheme #+ Expression]))) + [///] + (/// [".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 + (_.eq? 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 {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 _.bit-and] + [bit//or _.bit-or] + [bit//xor _.bit-xor] + ) + +(def: (bit//shift-left [subjectO paramO]) + Binary + (_.arithmetic-shift (_.remainder (_.int 64) paramO) subjectO)) + +(def: (bit//signed-shift-right [subjectO paramO]) + Binary + (_.arithmetic-shift (|> paramO (_.remainder (_.int 64)) (_.* (_.int -1))) + subjectO)) + +(def: (bit//shift-right [subjectO paramO]) + Binary + (runtimeT.bit//shift-right (_.remainder (_.int 64) paramO) subjectO)) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "count" (unary (_.apply1 (_.global "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//new size0) + Unary + ((_.apply2 (_.global "make-vector")) size0 _.nil)) + +(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 _.nil)) + +(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 (_.apply1 (_.global "vector-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 _.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] + [frac//max Double::MAX_VALUE _.float] + ) + +(do-template [<name> <expression>] + [(def: (<name> _) + Nullary + (_.int <expression>))] + + [nat//min 0] + [nat//max -1] + + [int//min ("lux int min")] + [int//max ("lux int max")] + + [deg//min 0] + [deg//max -1] + ) + +(do-template [<name> <frac>] + [(def: (<name> _) + Nullary + (_.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 _.+] + [int//sub _.-] + [int//mul _.*] + [int//div _.quotient] + [int//rem _.remainder] + + [nat//add _.+] + [nat//sub _.-] + [nat//mul _.*] + [nat//div runtimeT.nat///] + [nat//rem runtimeT.nat//%] + + [deg//add _.+] + [deg//sub _.-] + [deg//rem _.-] + [deg//scale _.*] + [deg//mul _.*] + [deg//div _.quotient] + [deg//reciprocal _.quotient] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//add _.+] + [frac//sub _.-] + [frac//mul _.*] + [frac//div _./] + [frac//rem _.mod] + [frac//= _.=] + [frac//< _.<] + + [text//= _.string=?] + [text//< _.string<?] + ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [nat//= _.=] + [nat//< runtimeT.nat//<] + + [int//= _.=] + [int//< _.<] + + [deg//= _.=] + [deg//< runtimeT.nat//<] + ) + +(def: deg//to-frac + Unary + (let [f2^32 (_.arithmetic-shift (_.int 32) (_.int 1))] + (|>> (_.arithmetic-shift (_.int -32)) + (_.bit-and (_.int (hex "7FFFFFFFFFFFFFFF"))) + (_./ f2^32) + (_./ (_.float 1.0))))) + +(def: nat//char (|>> (_.apply1 (_.global "integer->char")) + (_.apply1 (_.global "string")))) + +(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 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 id)) + (install "to-frac" (unary (|>> (_./ (_.float 1.0)))))))) + +(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 runtimeT.frac//to-deg)) + (install "to-int" (unary (_.apply1 (_.global "exact")))) + (install "encode" (unary (_.apply1 (_.global "number->string")))) + (install "decode" (unary runtimeT.frac//decode))))) + +## [[Text]] +(def: (text//concat [subjectO paramO]) + Binary + (_.apply (_.global "string-append") (list subjectO paramO))) + +(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 (_.global "string-length")))) + (install "hash" (unary (_.apply1 (_.global "string-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 (_.global "string-upcase")))) + (install "lower" (unary (_.apply1 (_.global "string-downcase")))) + ))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + ((_.apply2 (_.global "expt")) subject param)) + +(def: math-func + (-> Text (-> Expression Expression)) + (|>> _.global _.apply1)) + +(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//log input) + Unary + (_.begin (list (_.apply (_.global "display") (list input)) + (_.apply (_.global "newline") (list))))) + +(def: (void code) + (-> Expression Expression) + (_.begin (list code runtimeT.unit))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary (|>> io//log ..void))) + (install "error" (unary _.raise)) + (install "exit" (unary (_.apply1 (_.global "exit")))) + (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time runtimeT.unit))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> (list) _.vector)) + +(def: (atom//read atom) + Unary + (_.vector-ref atom (_.int 0))) + +(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//write [valueO boxO]) + Binary + (runtimeT.box//write valueO boxO)) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "write" (binary box//write))))) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (_.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/scheme/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure/host.jvm.lux new file mode 100644 index 000000000..c1b43da2f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/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/scheme/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..3ee8e472a --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/reference.jvm.lux @@ -0,0 +1,42 @@ +(.module: + lux + (lux [macro] + (data [text] + text/format)) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + (host ["_" scheme #+ Expression SVar @@]))) + [//] + (// [".T" runtime])) + +(do-template [<register> <translation> <prefix>] + [(def: #export (<register> register) + (-> Register SVar) + (_.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 _.var)) + +(def: #export (translate-definition name) + (-> Ident (Meta Expression)) + (:: macro.Monad<Meta> wrap (@@ (global name)))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..585c80c86 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux @@ -0,0 +1,425 @@ +(.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 ["_" scheme #+ SVar Expression @@])))) + +(def: prefix Text "LuxRuntime") + +(def: #export unit Expression (_.string //.unit)) + +(def: (flag value) + (-> Bool Expression) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (<| (_.cons (_.symbol //.variant-tag)) + (_.cons tag) + (_.cons last?) + value)) + +(def: #export (variant tag last? value) + (-> Nat Bool Expression Expression) + (variant' (_.int (:! 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 Expression) + +(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 (` (_.var (~ (code.text runtime)))) + @runtime (` (@@ (~ $runtime))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Expression))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Expression + (~ (case argsC+ + #.Nil + (` (_.define (~ $runtime) (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ $runtime) (list (~+ argsLC+)) + (~ definition)))))))))))) + +(runtime: (list-slice offset length list) + (<| (_.if (_.null? (@@ list)) + (@@ list)) + (_.if (|> (@@ offset) (_.> (_.int 0))) + (list-slice (|> (@@ offset) (_.- (_.int 1))) + (@@ length) + (_.cdr (@@ list)))) + (_.if (|> (@@ length) (_.> (_.int 0))) + (_.cons (_.car (@@ list)) + (list-slice (@@ offset) + (|> (@@ length) (_.- (_.int 1))) + (_.cdr (@@ list))))) + _.nil)) + +(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) + (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) + list/join))] + (~ body)))))) + +(def: as-integer + (-> Expression Expression) + (_.apply1 (_.global "exact"))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda (_.poly (list error)) + (..left (@@ error))) + (_.lambda (_.poly (list)) + (..right (_.apply (@@ op) (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [loop input output] + (_.letrec (list [loop (_.lambda (_.poly (list input output)) + (_.if (_.eqv? _.nil (@@ input)) + (@@ output) + (_.apply (@@ loop) + (list (_.cdr (@@ input)) + (..some (_.vector (list (_.car (@@ input)) (@@ output))))))))]) + (_.apply (@@ loop) (list (_.apply (_.global "reverse") (list (@@ program-args))) + ..none))))) + +(def: runtime//lux + Runtime + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Expression) + (|>> (_.+ (_.int 1)))) + +(def: product-element + (-> Expression Expression Expression) + _.vector-ref) + +(def: (product-tail product) + (-> Expression Expression) + (_.vector-ref product (|> (_.length product) (_.- (_.int 1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Expression) + (|> min-length (_.- (_.length product)))) + +(runtime: (product//left product index) + (let [$index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define $index_min_length (list) + (minimum-index-length (@@ index))) + (_.if (|> (_.length (@@ product)) (_.> (@@ $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 (_.var "index_min_length") + $product_length (_.var "product_length") + $slice (_.var "slice")] + (_.begin + (list + (_.define $index_min_length (list) (minimum-index-length (@@ index))) + (_.define $product_length (list) (_.length (@@ product))) + (<| (_.if ## Last element. + (|> (@@ $product_length) (_.= (@@ $index_min_length))) + (product-element (@@ product) (@@ index))) + (_.if ## Needs recursion + (|> (@@ $product_length) (_.< (@@ $index_min_length))) + (product//right (product-tail (@@ product)) + (updated-index (@@ $index_min_length) (@@ product)))) + ## Must slice + (_.begin + (list (_.define $slice (list) + (_.make-vector (|> (@@ $product_length) + (_.- (@@ index))))) + (_.vector-copy! (@@ $slice) (_.int 0) + (@@ product) (@@ index) (@@ $product_length)) + (@@ $slice)))))))) + +(runtime: (sum//get sum wanted_tag wants_last) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> (@@ sum-flag) (_.eqv? (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get (@@ sum-value) + (|> (@@ wanted_tag) (_.- (@@ sum-tag))) + (@@ wants_last)) + no-match)] + (<| (_.let-values (list [(_.poly (list variant-tag sum-tag sum-flag sum-value)) + (_.apply (_.global "apply") (list (_.global "values") (@@ sum)))])) + (_.if (|> (@@ wanted_tag) (_.= (@@ sum-tag))) + (_.if (|> (@@ sum-flag) (_.eqv? (@@ wants_last))) + (@@ sum-value) + test-recursion)) + (_.if (|> (@@ wanted_tag) (_.> (@@ sum-tag))) + test-recursion) + (_.if (_.and (list (|> (@@ wants_last) (_.eqv? (_.string ""))) + (|> (@@ wanted_tag) (_.< (@@ sum-tag))))) + (variant' (|> (@@ sum-tag) (_.- (@@ wanted_tag))) (@@ sum-flag) (@@ sum-value))) + no-match)))) + +(def: runtime//adt + Runtime + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//shift-right shift input) + (_.if (_.= (_.int 0) (@@ shift)) + (@@ input) + (|> (@@ input) + (_.arithmetic-shift (_.* (_.int -1) (@@ shift))) + (_.bit-and (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Runtime + (_.begin (list @@bit//shift-right))) + +(def: int-high (bit//shift-right (_.int 32))) +(def: int-low (_.bit-and (_.int (hex "FFFFFFFF")))) + +(runtime: (nat//< param subject) + (with-vars [pH sH] + (_.let (list [pH (int-high (@@ param))] + [sH (int-high (@@ subject))]) + (_.or (list (_.< (@@ pH) (@@ sH)) + (_.and (list (_.= (@@ pH) (@@ sH)) + (_.< (int-low (@@ param)) (int-low (@@ subject)))))))))) + +(runtime: (nat/// param subject) + (_.if (_.< (_.int 0) (@@ param)) + (_.if (nat//< (@@ param) (@@ subject)) + (_.int 0) + (_.int 1)) + (with-vars [quotient] + (_.let (list [quotient (|> (@@ subject) + (bit//shift-right (_.int 1)) + (_.quotient (@@ param)) + (_.arithmetic-shift (_.int 1)))]) + (let [remainder (_.- (_.* (@@ param) (@@ quotient)) + (@@ subject))] + (_.if (_.not (nat//< (@@ param) remainder)) + (_.+ (_.int 1) (@@ quotient)) + (@@ quotient))))))) + +(runtime: (nat//% param subject) + (let [flat (|> (@@ subject) + (nat/// (@@ param)) + (_.* (@@ param)))] + (|> (@@ subject) (_.- flat)))) + +(def: runtime//nat + Runtime + (_.begin + (list @@nat//< + @@nat/// + @@nat//%))) + +(runtime: (frac//to-deg input) + (with-vars [two32 shifted] + (_.let* (list [two32 (|> (_.float 2.0) (_.expt (_.float 32.0)))] + [shifted (|> (@@ input) (_.mod (_.float 1.0)) (_.* (@@ two32)))]) + (let [low (|> (@@ shifted) (_.mod (_.float 1.0)) (_.* (@@ two32)) as-integer) + high (|> (@@ shifted) as-integer)] + (|> high + (_.arithmetic-shift (_.int 32)) + (_.+ low)))))) + +(runtime: (frac//decode input) + (with-vars [output] + (_.let (list [output ((_.apply1 (_.global "string->number")) (@@ input))]) + (_.if (_.and (list (_.not (_.= (@@ output) (@@ output))) + (_.not (_.eqv? (_.string "+nan.0") (@@ input))))) + ..none + (..some (@@ output)))))) + +(def: runtime//frac + Runtime + (_.begin + (list @@frac//to-deg + @@frac//decode))) + +## (def: runtime//text +## Runtime +## (_.begin (list @@text//index +## @@text//clip +## @@text//char))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Expression) + (_.if (|> idx (_.<= (_.length array))) + body + (_.raise (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [temp] + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + (_.let (list [temp (_.vector-ref (@@ array) (@@ idx))]) + (_.if (|> (@@ temp) (_.eqv? _.nil)) + ..none + (..some (@@ temp))))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + (_.begin + (list (_.vector-set! (@@ array) (@@ idx) (@@ value)) + (@@ array))))) + +(def: runtime//array + Runtime + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (atom//compare-and-swap atom old new) + (with-vars [temp] + (_.let (list [temp (_.vector-ref (@@ atom) (_.int 0))]) + (_.if (_.eq? (@@ old) (@@ temp)) + (_.begin + (list (_.vector-set! (@@ atom) (_.int 0) (@@ new)) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Runtime + @@atom//compare-and-swap) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set! (@@ box) (_.int 0) (@@ value)) + ..unit))) + +(def: runtime//box + Runtime + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply (_.global "current-second") (list)) + (_.* (_.int 1_000)) + as-integer)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: process//incoming + SVar + (_.var (lang.normalize-name "process//incoming"))) + +(runtime: (process//loop _) + (_.when (_.not (_.null? (@@ process//incoming))) + (with-vars [queue process] + (_.let (list [queue (@@ process//incoming)]) + (_.begin (list (_.set! process//incoming (_.list (list))) + (_.apply (_.global "map") + (list (_.lambda (_.poly (list process)) + (_.apply (@@ process) (list ..unit))) + (@@ queue))) + (process//loop ..unit))))))) + +(runtime: (process//future procedure) + (_.begin (list (_.set! process//incoming (_.cons (@@ procedure) (@@ process//incoming))) + ..unit))) + +(runtime: (process//schedule milli-seconds procedure) + (with-vars [start process now _ignored] + (_.let (list [start (io//current-time ..unit)]) + (_.letrec (list [process (_.lambda _ignored + (_.let (list [now (io//current-time ..unit)]) + (_.if (|> (@@ now) (_.- (@@ start)) (_.>= (@@ milli-seconds))) + (_.apply (@@ procedure) (list ..unit)) + (process//future (@@ process)))))]) + (process//future (@@ process)))))) + +(def: runtime//process + Runtime + (_.begin (list (_.define process//incoming (list) (_.list (list))) + @@process//loop + @@process//future + @@process//schedule))) + +(def: runtime + Runtime + (_.begin (list @@list-slice + runtime//lux + runtime//bit + runtime//adt + runtime//nat + runtime//frac + ## runtime//text + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + ))) + +(def: #export artifact Text (format prefix //.file-extension)) + +(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/scheme/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux new file mode 100644 index 000000000..c9611cd2b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux @@ -0,0 +1,45 @@ +(.module: + lux + (lux (control [monad #+ do]) + [macro] + (data text/format)) + (luxc (lang [".L" module] + (host ["_" scheme #+ Expression @@]))) + [//] + (// [".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 (_.define def-name (list) 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 Expression)) + (macro.fail "translate-program NOT IMPLEMENTED YET")) diff --git a/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..01ddcbf6f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format) + [macro]) + (luxc ["&" lang] + (lang [synthesis #+ Synthesis] + (host [scheme #+ Expression]))) + [//] + (// [".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 (scheme.vector 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)))) |