diff options
37 files changed, 1860 insertions, 1817 deletions
diff --git a/new-luxc/source/luxc/lang/host/scheme.lux b/new-luxc/source/luxc/lang/host/scheme.lux deleted file mode 100644 index 7c8c67ab0..000000000 --- a/new-luxc/source/luxc/lang/host/scheme.lux +++ /dev/null @@ -1,260 +0,0 @@ -(.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 {} Any) -(abstract: #export Poly {} Any) - -(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/scheme/case.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux deleted file mode 100644 index 91ad5140d..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux +++ /dev/null @@ -1,179 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [number] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>] - (set ["set" unordered #+ 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/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux deleted file mode 100644 index d906ae825..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.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 deleted file mode 100644 index 87821f2a0..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/function.jvm.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.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 - (|>> 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 .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 (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 deleted file mode 100644 index c64973d8f..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/loop.jvm.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.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 (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 deleted file mode 100644 index c7043eeb7..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.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 deleted file mode 100644 index 8247baa0c..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure.jvm.lux +++ /dev/null @@ -1,29 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - text/format - (coll (dictionary ["dict" unordered #+ 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 deleted file mode 100644 index a7e9f0814..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux +++ /dev/null @@ -1,461 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number #+ hex] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ 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 .int %i) "\n" - " Actual: " (|> actual .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//left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift (_.remainder (_.int 64) paramO) subjectO)) - -(def: (bit//arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift (|> paramO (_.remainder (_.int 64)) (_.* (_.int -1))) - subjectO)) - -(def: (bit//logical-right-shift [subjectO paramO]) - Binary - (runtimeT.bit//logical-right-shift (_.remainder (_.int 64) paramO) subjectO)) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -## [[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>))] - - [int//min ("lux int min")] - [int//max ("lux int max")] - ) - -(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] - ) - -(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))] - - [int//= _.=] - [int//< _.<] - ) - -(def: int//char (|>> (_.apply1 (_.global "integer->char")) - (_.apply1 (_.global "string")))) - -(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-frac" (unary (|>> (_./ (_.float 1.0))))) - (install "char" (unary int//char))))) - -(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-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)) - ))) - -## [[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//parallelism-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 "parallelism-level" (nullary process//parallelism-level)) - (install "schedule" (binary process//schedule)) - ))) - -## [Bundles] -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-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 deleted file mode 100644 index af82491b6..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure/host.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ 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 deleted file mode 100644 index 1552f52af..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/reference.jvm.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.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 (.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 (.nat var)))) - -(def: #export (translate-variable var) - (-> Variable (Meta Expression)) - (if (variableL.captured? var) - (translate-captured (variableL.captured-register var)) - (translate-local (.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 deleted file mode 100644 index c3f149eeb..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,375 +0,0 @@ -(.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//logical-right-shift 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//logical-right-shift))) - -(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//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//schedule milli-seconds procedure) - (let [process//future (function (_ process) - (_.set! process//incoming (_.cons process (@@ process//incoming))))] - (_.begin - (list - (_.if (_.= (_.int 0) (@@ milli-seconds)) - (process//future (@@ 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)))))) - ..unit)))) - -(def: runtime//process - Runtime - (_.begin (list (_.define process//incoming (list) (_.list (list))) - @@process//loop - @@process//schedule))) - -(def: runtime - Runtime - (_.begin (list @@list-slice - runtime//lux - runtime//bit - runtime//adt - 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 Any)) - (do macro.Monad<Meta> - [_ //.init-module-buffer - _ (//.save runtime)] - (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux deleted file mode 100644 index 01ddcbf6f..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.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)))) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 72c6dbb86..640bff8a2 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -91,10 +91,10 @@ (def: succ <succ>) (def: pred <pred>))] - [Nat Order<Nat> inc dec] - [Int Order<Int> inc dec] + [Nat Order<Nat> inc dec] + [Int Order<Int> inc dec] [Frac Order<Frac> (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))] - [Deg Order<Deg> inc dec] + [Deg Order<Deg> inc dec] ) (do-template [<type> <enum> <top> <bottom>] diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux index 2259b615b..322b9f655 100644 --- a/stdlib/source/lux/lang.lux +++ b/stdlib/source/lux/lang.lux @@ -16,6 +16,10 @@ (type: #export Eval (-> Type Code (Meta Any))) +(type: #export Version Text) + +(def: #export version Version "0.6.0") + (def: #export (fail message) (All [a] (-> Text (Meta a))) (do macro.Monad<Meta> diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 0996ad1f4..6efa934d8 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -77,7 +77,11 @@ (type: #export (Tuple a) (List a)) -(type: #export Application [Analysis (List Analysis)]) +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)]) (def: (last? size tag) (-> Nat Tag Bool) @@ -131,7 +135,7 @@ ) (def: #export (apply [func args]) - (-> Application Analysis) + (-> (Application Analysis) Analysis) (list/fold (function (_ arg func) (#Apply arg func)) func args)) (type: #export Analyser @@ -180,7 +184,7 @@ ) (def: #export (application analysis) - (-> Analysis Application) + (-> Analysis (Application Analysis)) (case analysis (#Apply head func) (let [[func' tail] (application func)] diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux index d9eb90fc9..7edac52c3 100644 --- a/stdlib/source/lux/lang/extension.lux +++ b/stdlib/source/lux/lang/extension.lux @@ -4,16 +4,16 @@ ["ex" exception #+ exception:]) (data ["e" error] [text] - (coll (dictionary ["dict" unordered #+ Dict]))) - [macro]) + (coll (dictionary ["dict" unordered #+ Dict])))) [// #+ Eval] [//compiler #+ Operation Compiler] [//analysis #+ Analyser] - [//synthesis #+ Synthesizer]) + [//synthesis #+ Synthesizer] + [//translation #+ Translator]) (do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] + [(exception: #export (<name> {extension Text}) + extension)] [unknown-analysis] [unknown-synthesis] @@ -27,7 +27,10 @@ ) (type: #export Analysis - (-> Analyser Eval (List Code) (Meta //analysis.Analysis))) + (-> Analyser Eval + (Compiler .Lux + (List Code) + //analysis.Analysis))) (type: #export Synthesis (-> Synthesizer @@ -35,8 +38,11 @@ (List //analysis.Analysis) //synthesis.Synthesis))) -(type: #export Translation - (-> (List Code) (Meta Code))) +(type: #export (Translation anchor code) + (-> (Translator anchor code) + (Compiler (//translation.State anchor code) + (List //synthesis.Synthesis) + code))) (type: #export Statement (-> (List Code) (Meta Any))) @@ -72,14 +78,14 @@ (do-template [<name> <type> <category> <exception>] [(def: #export (<name> name) (-> Text (Meta <type>)) - (do macro.Monad<Meta> + (do //compiler.Monad<Operation> [extensions ..get] (case (dict.get name (get@ <category> extensions)) (#.Some extension) (wrap extension) #.None - (//.throw <exception> name))))] + (//compiler.throw <exception> name))))] [find-analysis Analysis #analysis unknown-analysis] [find-synthesis Synthesis #synthesis unknown-synthesis] @@ -91,25 +97,30 @@ (All [e] (Extension e)) (dict.new text.Hash<Text>)) -(do-template [<all> <type> <category>] +(do-template [<params> <all> <state> <type> <category>] [(def: #export <all> - (Meta (Extension <type>)) + (All <params> (Operation <state> (Extension <type>))) (|> ..get - (:: macro.Monad<Meta> map (get@ <category>))))] - - [all-analyses Analysis #analysis] - [all-syntheses Synthesis #synthesis] - [all-translations Translation #translation] - [all-statements Statement #statement] + (:: //compiler.Monad<Operation> map (get@ <category>))))] + + [[] all-analyses .Lux + Analysis #analysis] + [[] all-syntheses //synthesis.State + Synthesis #synthesis] + [[anchor code] all-translations (//translation.State anchor code) + Translation #translation] + [[] all-statements Any + Statement #statement] ) (do-template [<name> <type> <category> <exception>] [(def: #export (<name> name extension) (-> Text <type> (Meta Any)) - (do macro.Monad<Meta> + (do //compiler.Monad<Operation> [extensions ..get - _ (//.assert <exception> name - (not (dict.contains? name (get@ <category> extensions)))) + _ (if (not (dict.contains? name (get@ <category> extensions))) + (wrap []) + (//compiler.throw <exception> name)) _ (..set (update@ <category> (dict.put name extension) extensions))] (wrap [])))] diff --git a/new-luxc/source/luxc/lang/extension/synthesis.lux b/stdlib/source/lux/lang/extension/synthesis.lux index c48f3e3a5..c48f3e3a5 100644 --- a/new-luxc/source/luxc/lang/extension/synthesis.lux +++ b/stdlib/source/lux/lang/extension/synthesis.lux diff --git a/new-luxc/source/luxc/lang/extension/translation.lux b/stdlib/source/lux/lang/extension/translation.lux index bc95ed1f4..bc95ed1f4 100644 --- a/new-luxc/source/luxc/lang/extension/translation.lux +++ b/stdlib/source/lux/lang/extension/translation.lux diff --git a/stdlib/source/lux/lang/host/scheme.lux b/stdlib/source/lux/lang/host/scheme.lux new file mode 100644 index 000000000..f6e7b1834 --- /dev/null +++ b/stdlib/source/lux/lang/host/scheme.lux @@ -0,0 +1,302 @@ +(.module: + [lux #- Code' Code int or and if function cond when let] + (lux (control pipe) + (data [text] + text/format + [number] + (coll [list "list/" Functor<List> Fold<List>])) + (type abstract))) + +(abstract: Global' {} Any) +(abstract: Var' {} Any) +(abstract: Computation' {} Any) +(abstract: (Expression' k) {} Any) + +(abstract: (Code' k) + {} + + Text + + (type: #export Code (Ex [k] (Code' k))) + (type: #export Expression (Code' (Ex [k] (Expression' k)))) + (type: #export Global (Code' (Expression' Global'))) + (type: #export Computation (Code' (Expression' Computation'))) + (type: #export Var (Code' (Expression' Var'))) + + (type: #export Arguments + {#mandatory (List Var) + #rest (Maybe Var)}) + + (def: #export code (-> Code Text) (|>> @representation)) + + (def: #export var (-> Text Var) (|>> @abstraction)) + + (def: (arguments [vars rest]) + (-> Arguments Code) + (case rest + (#.Some rest) + (case vars + #.Nil + rest + + _ + (|> (format " . " (@representation rest)) + (format (|> vars + (list/map ..code) + (text.join-with " "))) + (text.enclose ["(" ")"]) + @abstraction)) + + #.None + (|> vars + (list/map ..code) + (text.join-with " ") + (text.enclose ["(" ")"]) + @abstraction))) + + (def: #export nil + Computation + (@abstraction "'()")) + + (def: #export bool + (-> Bool Computation) + (|>> (case> true "#t" + false "#f") + @abstraction)) + + (def: #export int + (-> Int Computation) + (|>> %i @abstraction)) + + (def: #export float + (-> Frac Computation) + (|>> (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 Computation (..float number.positive-infinity)) + (def: #export negative-infinity Computation (..float number.negative-infinity)) + (def: #export not-a-number Computation (..float number.not-a-number)) + + (def: #export string + (-> Text Computation) + (|>> %t @abstraction)) + + (def: #export symbol + (-> Text Computation) + (|>> (format "'") @abstraction)) + + (def: #export global + (-> Text Global) + (|>> @abstraction)) + + (def: form + (-> (List Code) Text) + (|>> (list/map ..code) + (text.join-with " ") + (text.enclose ["(" ")"]))) + + (def: #export (apply/* func args) + (-> Expression (List Expression) Computation) + (@abstraction (..form (#.Cons func args)))) + + (do-template [<name> <function>] + [(def: #export <name> + (-> (List Expression) Computation) + (apply/* (..global <function>)))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def: #export (apply/0 func) + (-> Expression Computation) + (..apply/* func (list))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/0 (..global <scheme-name>)))] + + [newline/0 "newline"] + ) + + (def: #export (apply/1 func) + (-> Expression (-> Expression Computation)) + (|>> (list) (..apply/* func))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/1 (..global <scheme-name>)))] + + [exact/1 "exact"] + [integer->char/1 "integer->char"] + [number->string/1 "number->string"] + [string/1 "string"] + [length/1 "length"] + [values/1 "values"] + [null?/1 "null?"] + [car/1 "car"] + [cdr/1 "cdr"] + [raise/1 "raise"] + [error-object-message/1 "error-object-message"] + [make-vector/1 "make-vector"] + [vector-length/1 "vector-length"] + [not/1 "not"] + [string-length/1 "string-length"] + [string-hash/1 "string-hash"] + [reverse/1 "reverse"] + [display/1 "display"] + [exit/1 "exit"] + ) + + (def: #export (apply/2 func) + (-> Expression (-> Expression Expression Computation)) + (.function (_ _0 _1) + (..apply/* func (list _0 _1)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/2 (..global <scheme-name>)))] + + [append/2 "append"] + [cons/2 "cons"] + [make-vector/2 "make-vector"] + [vector-ref/2 "vector-ref"] + [list-tail/2 "list-tail"] + [map/2 "map"] + [string-ref/2 "string-ref"] + [string-append/2 "string-append"] + ) + + (do-template [<lux-name> <scheme-name>] + [(def: #export (<lux-name> param subject) + (-> Expression Expression Computation) + (..apply/2 (..global <scheme-name>) subject param))] + + [=/2 "="] + [eq?/2 "eq?"] + [eqv?/2 "eqv?"] + [</2 "<"] + [<=/2 "<="] + [>/2 ">"] + [>=/2 ">="] + [string=?/2 "string=?"] + [string<?/2 "string<?"] + [+/2 "+"] + [-/2 "-"] + [//2 "/"] + [*/2 "*"] + [expt/2 "expt"] + [remainder/2 "remainder"] + [quotient/2 "quotient"] + [mod/2 "mod"] + [arithmetic-shift/2 "arithmetic-shift"] + [bit-and/2 "bitwise-and"] + [bit-or/2 "bitwise-ior"] + [bit-xor/2 "bitwise-xor"] + ) + + (def: #export (apply/3 func) + (-> Expression (-> Expression Expression Expression Computation)) + (.function (_ _0 _1 _2) + (..apply/* func (list _0 _1 _2)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/3 (..global <scheme-name>)))] + + [substring/3 "substring"] + [vector-set!/3 "vector-set!"] + ) + + (def: #export (vector-copy!/5 _0 _1 _2 _3 _4) + (-> Expression Expression Expression Expression Expression + Computation) + (..apply/* (..global "vector-copy!") + (list _0 _1 _2 _3 _4))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> + (-> (List Expression) Computation) + (|>> (list& (..global <scheme-name>)) ..form @abstraction))] + + [or "or"] + [and "and"] + ) + + (do-template [<lux-name> <scheme-name> <var> <pre>] + [(def: #export (<lux-name> bindings body) + (-> (List [<var> Expression]) Expression Computation) + (@abstraction + (..form (list (..global <scheme-name>) + (|> bindings + (list/map (.function (_ [binding/name binding/value]) + (@abstraction + (..form (list (<pre> binding/name) + binding/value))))) + ..form + @abstraction) + body))))] + + [let "let" Var .id] + [let* "let*" Var .id] + [letrec "letrec" Var .id] + [let-values "let-values" Arguments ..arguments] + [let*-values "let*-values" Arguments ..arguments] + [letrec-values "letrec-values" Arguments ..arguments] + ) + + (def: #export (if test then else) + (-> Expression Expression Expression Computation) + (@abstraction + (..form (list (..global "if") test then else)))) + + (def: #export (when test then) + (-> Expression Expression Computation) + (@abstraction + (..form (list (..global "when") test then)))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Computation) + (|> (list/fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses)) + @representation + @abstraction)) + + (def: #export (lambda arguments body) + (-> Arguments Expression Computation) + (@abstraction + (..form (list (..global "lambda") + (..arguments arguments) + body)))) + + (def: #export (define name arguments body) + (-> Var Arguments Expression Computation) + (@abstraction + (..form (list (..global "define") + (|> arguments + (update@ #mandatory (|>> (#.Cons name))) + ..arguments) + body)))) + + (def: #export begin + (-> (List Expression) Computation) + (|>> (#.Cons (..global "begin")) ..form @abstraction)) + + (def: #export (set! name value) + (-> Var Expression Computation) + (@abstraction + (..form (list (..global "set!") name value)))) + + (def: #export (with-exception-handler handler body) + (-> Expression Expression Computation) + (@abstraction + (..form (list (..global "with-exception-handler") handler body)))) + ) diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux index 9c909942e..40a7fc69c 100644 --- a/stdlib/source/lux/lang/init.lux +++ b/stdlib/source/lux/lang/init.lux @@ -1,10 +1,11 @@ (.module: lux + [//] (// ["//." target] [".L" extension] (extension [".E" analysis] - ## [".E" synthesis] - ## [".E" translation] + [".E" synthesis] + [".E" translation] ## [".E" statement] ))) @@ -26,10 +27,6 @@ #.var-counter +0 #.var-bindings (list)}) -(type: #export Version Text) - -(def: #export version Version "0.6.0") - (`` (def: #export info Info {#.target (for {(~~ (static //target.common-lisp)) //target.common-lisp @@ -41,7 +38,7 @@ (~~ (static //target.r)) //target.r (~~ (static //target.ruby)) //target.ruby (~~ (static //target.scheme)) //target.scheme}) - #.version ..version + #.version //.version #.mode #.Build})) (def: #export (compiler host) @@ -57,8 +54,8 @@ #.seed +0 #.scope-type-vars (list) #.extensions {#extensionL.analysis analysisE.defaults - #extensionL.synthesis (:!! []) ## synthesisE.defaults - #extensionL.translation (:!! []) ## translationE.defaults + #extensionL.synthesis synthesisE.defaults + #extensionL.translation translationE.defaults #extensionL.statement (:!! []) ## statementE.defaults } #.host host}) diff --git a/new-luxc/source/luxc/lang.lux b/stdlib/source/lux/lang/name.lux index f02af30c5..1053eb76f 100644 --- a/new-luxc/source/luxc/lang.lux +++ b/stdlib/source/lux/lang/name.lux @@ -4,7 +4,7 @@ [text] text/format))) -(def: (normalize-char char) +(def: (sanitize char) (-> Nat Text) (case char (^ (char "*")) "_ASTER_" @@ -30,15 +30,18 @@ (^ (char ">")) "_GT_" (^ (char "~")) "_TILDE_" (^ (char "|")) "_PIPE_" - _ - (text.from-code char))) + _ (text.from-code char))) -(def: underflow Nat (dec +0)) - -(def: #export (normalize-name name) +(def: #export (normalize name) (-> Text Text) - (loop [idx (dec (text.size name)) - output ""] - (if (n/= underflow idx) - output - (recur (dec idx) (format (|> (text.nth idx name) maybe.assume normalize-char) output))))) + (let [name/size (text.size name)] + (loop [idx +0 + output ""] + (if (n/< name/size idx) + (recur (inc idx) + (|> (text.nth idx name) maybe.assume sanitize (format output))) + output)))) + +(def: #export (definition [module name]) + (-> Ident Text) + (format (normalize module) "___" (normalize name))) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux index cc43ea0b3..1bf06cdd0 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/synthesis.lux @@ -5,11 +5,9 @@ (coll (dictionary ["dict" unordered #+ Dict])))) [// #+ Extension] [//reference #+ Register Variable Reference] - [//analysis #+ Environment Analysis] + [//analysis #+ Environment Arity Analysis] [//compiler #+ Operation Compiler]) -(type: #export Arity Nat) - (type: #export Resolver (Dict Variable Variable)) (type: #export State @@ -66,8 +64,7 @@ (type: #export (Branch s) (#Case s (Path' s)) (#Let s Register s) - (#If s s s) - (#Exec s)) + (#If s s s)) (type: #export (Scope s) {#start Register @@ -111,6 +108,29 @@ [path/text #..Text] ) +(do-template [<name> <kind>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + content))] + + [path/side #..Side] + [path/member #..Member] + ) + +(do-template [<name> <kind> <side>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + <side> + content))] + + [side/left #..Side #.Left] + [side/right #..Side #.Right] + [member/left #..Member #.Left] + [member/right #..Member #.Right] + ) + (do-template [<name> <tag>] [(template: #export (<name> content) (<tag> content))] @@ -186,25 +206,34 @@ (do-template [<name> <tag>] [(template: #export (<name> content) - (<| #..Reference + (<| #..Structure <tag> content))] + [variant #..Variant] + [tuple #..Tuple] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + [variable/local //reference.local] [variable/foreign //reference.foreign] ) (do-template [<name> <family> <tag>] [(template: #export (<name> content) - (<| #..Control - <family> - <tag> - content))] + (.<| #..Control + <family> + <tag> + content))] [branch/case #..Branch #..Case] [branch/let #..Branch #..Let] [branch/if #..Branch #..If] - [branch/exec #..Branch #..Exec] [loop/scope #..Loop #..Scope] [loop/recur #..Loop #..Recur] diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux index 85065393d..b7f224168 100644 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ b/stdlib/source/lux/lang/synthesis/case.lux @@ -126,45 +126,52 @@ (-> //.Synthesizer Analysis Match (Operation //.State Synthesis)) (do ///compiler.Monad<Operation> [inputS (synthesize^ inputA)] - (case [headB tailB+] - [[(#///analysis.Bind inputR) headB/bodyA] - #.Nil] - (case headB/bodyA - (^ (#///analysis.Reference (///reference.local outputR))) - (wrap (if (n/= inputR outputR) - inputS - (//.branch/exec inputS))) - - _ - (do @ - [arity //.scope-arity - headB/bodyS (//.with-new-local - (synthesize^ headB/bodyA))] - (wrap (//.branch/let [inputS - (if (//function.nested? arity) - (n/+ (dec arity) inputR) - inputR) - headB/bodyS])))) - - (^or (^ [[(///analysis.pattern/bool true) thenA] - (list [(///analysis.pattern/bool false) elseA])]) - (^ [[(///analysis.pattern/bool false) elseA] - (list [(///analysis.pattern/bool true) thenA])])) - (do @ - [thenS (synthesize^ thenA) - elseS (synthesize^ elseA)] - (wrap (//.branch/if [inputS thenS elseS]))) - - _ - (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) - list.reverse - (case> (#.Cons [lastP lastA] prevsPA) - [[lastP lastA] prevsPA] - - _ - (undefined)))] - (do @ - [lastSP (path synthesize^ lastP lastA) - prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] - (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))) - ))) + (with-expansions [<unnecesary-let> + (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR))) + (n/= inputR outputR)) + (wrap inputS)) + + <let> + (as-is [[(#///analysis.Bind inputR) headB/bodyA] + #.Nil] + (case headB/bodyA + <unnecesary-let> + + _ + (do @ + [arity //.scope-arity + headB/bodyS (//.with-new-local + (synthesize^ headB/bodyA))] + (wrap (//.branch/let [inputS + (if (//function.nested? arity) + (n/+ (dec arity) inputR) + inputR) + headB/bodyS]))))) + + <if> + (as-is (^or (^ [[(///analysis.pattern/bool true) thenA] + (list [(///analysis.pattern/bool false) elseA])]) + (^ [[(///analysis.pattern/bool false) elseA] + (list [(///analysis.pattern/bool true) thenA])])) + (do @ + [thenS (synthesize^ thenA) + elseS (synthesize^ elseA)] + (wrap (//.branch/if [inputS thenS elseS])))) + + <case> + (as-is _ + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do @ + [lastSP (path synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] + (case [headB tailB+] + <let> + <if> + <case>)))) diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux index cc40bea4d..35b9e047e 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/synthesis/function.lux @@ -10,8 +10,8 @@ (dictionary ["dict" unordered #+ Dict])))) [///reference #+ Variable] [///compiler #+ Operation] - [///analysis #+ Environment Analysis] - [// #+ Arity Synthesis Synthesizer] + [///analysis #+ Environment Arity Analysis] + [// #+ Synthesis Synthesizer] [//loop]) (def: #export nested? diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux index 6aab72213..eb57eb7ad 100644 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ b/stdlib/source/lux/lang/synthesis/loop.lux @@ -60,9 +60,6 @@ _ proper))) - (#//.Exec bodyS) - (proper? bodyS) - (#//.Let inputS register bodyS) (and (proper? inputS) (proper? bodyS)) @@ -131,9 +128,6 @@ (path-recursion recur) (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) - (#//.Exec bodyS) - (maybe/map (|>> //.branch/exec) (recur bodyS)) - (#//.Let inputS register bodyS) (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) (recur bodyS)) diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/translation.lux new file mode 100644 index 000000000..c117bc019 --- /dev/null +++ b/stdlib/source/lux/lang/translation.lux @@ -0,0 +1,164 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + [monad #+ do]) + (data [maybe "maybe/" Functor<Maybe>] + [error #+ Error] + [text] + text/format + (coll [sequence #+ Sequence] + (dictionary ["dict" unordered #+ Dict]))) + (world [file #+ File])) + [//name] + [//reference #+ Register] + [//compiler #+ Operation Compiler] + [//synthesis #+ Synthesis]) + +(do-template [<name>] + [(exception: #export (<name>) + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {message Text}) + message) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(sig: #export (Host code) + (: (-> code (Error Any)) + execute!) + (: (-> code (Error Any)) + evaluate!)) + +(type: #export (Buffer code) (Sequence [Ident code])) + +(type: #export (Artifacts code) (Dict File (Buffer code))) + +(type: #export (State anchor code) + {#context Context + #anchor (Maybe anchor) + #host (Host code) + #buffer (Maybe (Buffer code)) + #artifacts (Artifacts code)}) + +(type: #export (Translator anchor code) + (Compiler (State anchor code) Synthesis code)) + +(def: #export (init host) + (All [anchor code] (-> (Host code) (..State anchor code))) + {#context {#scope-name "" + #inner-functions +0} + #anchor #.None + #host host + #buffer #.None + #artifacts (dict.new text.Hash<Text>)}) + +(def: #export (with-context expr) + (All [anchor code output] + (-> (Operation (..State anchor code) output) + (Operation (..State anchor code) [Text output]))) + (function (_ state) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c___" (%i (.int old-inner)))] + (case (expr (set@ #context [new-scope +0] state)) + (#error.Success [state' output]) + (#error.Success [(set@ #context [old-scope (inc old-inner)] state') + [new-scope output]]) + + (#error.Error error) + (#error.Error error))))) + +(def: #export context + (All [anchor code] (Operation (..State anchor code) Text)) + (function (_ state) + (#error.Success [state + (|> state + (get@ #context) + (get@ #scope-name))]))) + +(do-template [<tag> + <with-declaration> <with-type> <with-value> + <get> <get-type> <exception>] + [(def: #export <with-declaration> + (All [anchor code output] <with-type>) + (function (_ body) + (function (_ state) + (case (body (set@ <tag> (#.Some <with-value>) state)) + (#error.Success [state' output]) + (#error.Success [(set@ <tag> (get@ <tag> state) state') + output]) + + (#error.Error error) + (#error.Error error))))) + + (def: #export <get> + (All [anchor code] (Operation (..State anchor code) <get-type>)) + (function (_ state) + (case (get@ <tag> state) + (#.Some output) + (#error.Success [state output]) + + #.None + (ex.throw <exception> []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation (..State anchor code) output) + (Operation (..State anchor code) output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation (..State anchor code) output) + (Operation (..State anchor code) output)) + sequence.empty + buffer (Buffer code) no-active-buffer] + ) + +(def: #export artifacts + (All [anchor code] + (Operation (..State anchor code) (Artifacts code))) + (function (_ state) + (#error.Success [state (get@ #artifacts state)]))) + +(do-template [<name>] + [(def: #export (<name> code) + (All [anchor code] + (-> code (Operation (..State anchor code) Any))) + (function (_ state) + (case (:: (get@ #host state) <name> code) + (#error.Error error) + (ex.throw cannot-interpret error) + + (#error.Success output) + (#error.Success [state output]))))] + + [execute!] + [evaluate!] + ) + +(def: #export (save! name code) + (All [anchor code] + (-> Ident code (Operation (..State anchor code) Any))) + (do //compiler.Monad<Operation> + [_ (execute! code)] + (function (_ state) + (#error.Success [(update@ #buffer + (maybe/map (sequence.add [name code])) + state) + []])))) + +(def: #export (save-buffer! target) + (All [anchor code] + (-> File (Operation (..State anchor code) Any))) + (do //compiler.Monad<Operation> + [buffer ..buffer] + (function (_ state) + (#error.Success [(update@ #artifacts (dict.put target buffer) state) + []])))) diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..e5d12a005 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux @@ -0,0 +1,170 @@ +(.module: + [lux #- case let if] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>] + (set ["set" unordered #+ Set])))) + (//// [reference #+ Register] + (host ["_" scheme #+ Expression Computation Var]) + [compiler #+ "operation/" Monad<Operation>] + [synthesis #+ Synthesis Path]) + [//runtime #+ Operation Translator] + [//reference]) + +(def: #export (let translate [valueS register bodyS]) + (-> Translator [Synthesis Register Synthesis] + (Operation Computation)) + (do compiler.Monad<Operation> + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (_.let (list [(//reference.local' register) valueO]) + bodyO)))) + +(def: #export (record-get translate valueS pathP) + (-> Translator Synthesis (List [Nat Bool]) + (Operation Expression)) + (do compiler.Monad<Operation> + [valueO (translate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.int (:! Int idx))))) + valueO + pathP)))) + +(def: #export (if translate [testS thenS elseS]) + (-> Translator [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do compiler.Monad<Operation> + [testO (translate testS) + thenO (translate thenS) + elseO (translate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) + +(def: @cursor (_.var "lux_pm_cursor")) + +(def: top _.length/1) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(def: @temp (_.var "lux_pm_temp")) + +(exception: #export (unrecognized-path) + "") + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list $alt_error) #.None] + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) + +(def: (pattern-matching' translate pathP) + (-> Translator Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (translate bodyS) + + #synthesis.Pop + (operation/wrap pop-cursor!) + + (#synthesis.Bind register) + (operation/wrap (_.define (//reference.local' register) [(list) #.None] + cursor-top)) + + (^template [<tag> <format> <=>] + (^ (<tag> value)) + (operation/wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bool _.bool _.eqv?/2] + [synthesis.path/i64 _.int _.=/2] + [synthesis.path/f64 _.float _.=/2] + [synthesis.path/text _.string _.eqv?/2]) + + (^template [<pm> <flag> <prep>] + (^ (<pm> idx)) + (operation/wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.nil (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [<pm> <getter> <prep>] + (^ (<pm> idx)) + (operation/wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!))) + ([synthesis.member/left //runtime.product//left (<|)] + [synthesis.member/right //runtime.product//right inc]) + + (^template [<tag> <computation>] + (^ (<tag> [leftP rightP])) + (do compiler.Monad<Operation> + [leftO (pattern-matching' translate leftP) + rightO (pattern-matching' translate rightP)] + (wrap <computation>))) + ([synthesis.path/seq (_.begin (list leftO + rightO))] + [synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (compiler.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Translator Path (Operation Computation)) + (do compiler.Monad<Operation> + [pattern-matching! (pattern-matching' translate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case translate [valueS pathP]) + (-> Translator [Synthesis Path] (Operation Computation)) + (do compiler.Monad<Operation> + [valueO (translate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..96bb17126 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux @@ -0,0 +1,53 @@ +(.module: + lux + (lux (control [monad #+ do])) + (//// [compiler] + [synthesis] + [extension]) + [//runtime #+ Translator] + [//primitive] + [//structure] + [//reference] + [//function] + [//case]) + +(def: #export (translate synthesis) + Translator + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (<generator> value)) + ([synthesis.bool //primitive.bool] + [synthesis.i64 //primitive.i64] + [synthesis.f64 //primitive.f64] + [synthesis.text //primitive.text]) + + (^ (synthesis.variant variantS)) + (//structure.variant translate variantS) + + (^ (synthesis.tuple members)) + (//structure.tuple translate members) + + (#synthesis.Reference reference) + (//reference.reference reference) + + (^ (synthesis.function/apply application)) + (//function.apply translate application) + + (^ (synthesis.function/abstraction abstraction)) + (//function.function translate abstraction) + + (^ (synthesis.branch/case case)) + (//case.case translate case) + + (^ (synthesis.branch/let let)) + (//case.let translate let) + + (^ (synthesis.branch/if if)) + (//case.if translate if) + + (#synthesis.Extension [extension argsS]) + (do compiler.Monad<Operation> + [extension (extension.find-translation extension)] + (extension argsS)) + )) diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..6475caf68 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux @@ -0,0 +1,32 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll (dictionary ["dict" unordered #+ Dict])))) + (//// [reference #+ Register Variable] + (host ["_" scheme #+ Computation]) + [compiler "operation/" Monad<Operation>] + [synthesis #+ Synthesis]) + [//runtime #+ Operation Translator] + [/common] + ## [/host] + ) + +(exception: #export (unknown-extension {message Text}) + message) + +(def: extensions + /common.Bundle + (|> /common.extensions + ## (dict.merge /host.extensions) + )) + +(def: #export (extension translate name args) + (-> Translator Text (List Synthesis) + (Operation Computation)) + (<| (maybe.default (compiler.throw unknown-extension (%t name))) + (do maybe.Monad<Maybe> + [ext (dict.get name extensions)] + (wrap (ext translate args))))) diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..140045aaf --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,389 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + [text] + text/format + [number #+ hex] + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered #+ Dict]))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (///// (host ["_" scheme #+ Expression Computation]) + [compiler] + [synthesis #+ Synthesis]) + [///runtime #+ Operation Translator]) + +## [Types] +(type: #export Extension + (-> Translator (List Synthesis) (Operation Computation))) + +(type: #export Bundle + (Dict Text Extension)) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Computation)) +(type: #export Unary (-> (Vector +1 Expression) Computation)) +(type: #export Binary (-> (Vector +2 Expression) Computation)) +(type: #export Trinary (-> (Vector +3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Extension) + (-> 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>))) + +(exception: #export (wrong-arity {extension Text} {expected Nat} {actual Nat}) + (ex.report ["Extension" (%t extension)] + ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)])) + +(syntax: (arity: {name s.local-symbol} {arity s.nat}) + (with-gensyms [g!_ g!extension 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!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + (-> Text ..Extension)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do compiler.Monad<Operation> + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (compiler.throw wrong-arity [(~ g!name) +1 (list.size (~ g!inputs))]))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic extension) + (-> Variadic (-> Text Extension)) + (function (_ extension-name) + (function (_ translate inputsS) + (do compiler.Monad<Operation> + [inputsI (monad.map @ translate inputsS)] + (wrap (extension inputsI)))))) + +## [Extensions] +## [[Lux]] +(def: extensions/lux + Bundle + (|> (dict.new text.Hash<Text>) + (install "is?" (binary (product.uncurry _.eq?/2))) + (install "try" (unary ///runtime.lux//try)))) + +## [[Bits]] +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and _.bit-and/2] + [bit//or _.bit-or/2] + [bit//xor _.bit-xor/2] + ) + +(def: (bit//left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int 64) paramO) + subjectO)) + +(def: (bit//arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int 64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit//logical-right-shift [subjectO paramO]) + Binary + (///runtime.bit//logical-right-shift (_.remainder/2 (_.int 64) paramO) subjectO)) + +(def: extensions/bit + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "left-shift" (binary bit//left-shift)) + (install "logical-right-shift" (binary bit//logical-right-shift)) + (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + ))) + +## [[Arrays]] +(def: (array//new size0) + Unary + (_.make-vector/2 size0 _.nil)) + +(def: (array//get [arrayO idxO]) + Binary + (///runtime.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) + Trinary + (///runtime.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) + Binary + (///runtime.array//put arrayO idxO _.nil)) + +(def: extensions/array + 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 _.vector-length/1)) + ))) + +## [[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> <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//+ _.+/2] + [int//- _.-/2] + [int//* _.*/2] + [int/// _.quotient/2] + [int//% _.remainder/2] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//+ _.+/2] + [frac//- _.-/2] + [frac//* _.*/2] + [frac/// _.//2] + [frac//% _.mod/2] + [frac//= _.=/2] + [frac//< _.</2] + + [text//= _.string=?/2] + [text//< _.string<?/2] + ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [int//= _.=/2] + [int//< _.</2] + ) + +(def: int//char (|>> _.integer->char/1 _.string/1)) + +(def: extensions/int + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash<Text>) + (install "+" (binary int//+)) + (install "-" (binary int//-)) + (install "*" (binary int//*)) + (install "/" (binary int///)) + (install "%" (binary int//%)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary (|>> (_.//2 (_.float 1.0))))) + (install "char" (unary int//char))))) + +(def: extensions/frac + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash<Text>) + (install "+" (binary frac//+)) + (install "-" (binary frac//-)) + (install "*" (binary frac//*)) + (install "/" (binary frac///)) + (install "%" (binary frac//%)) + (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-int" (unary _.exact/1)) + (install "encode" (unary _.number->string/1)) + (install "decode" (unary ///runtime.frac//decode))))) + +## [[Text]] +(def: (text//char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text//clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: extensions/text + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash<Text>) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary (product.uncurry _.string-append/2))) + (install "size" (unary _.string-length/1)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip))))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + (_.expt/2 param subject)) + +(def: math-func + (-> Text Unary) + (|>> _.global _.apply/1)) + +(def: extensions/math + 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 (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: extensions/io + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary (|>> io//log ..void))) + (install "error" (unary _.raise/1)) + (install "exit" (unary _.exit/1)) + (install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string synthesis.unit)))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> (list) _.vector/*)) + +(def: (atom//read atom) + Unary + (_.vector-ref/2 atom (_.int 0))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (///runtime.atom//compare-and-swap atomO oldO newO)) + +(def: extensions/atom + 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 + (///runtime.box//write valueO boxO)) + +(def: extensions/box + 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//parallelism-level []) + Nullary + (_.int 1)) + +(def: extensions/process + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash<Text>) + (install "parallelism-level" (nullary process//parallelism-level)) + (install "schedule" (binary (product.uncurry ///runtime.process//schedule))) + ))) + +## [Bundles] +(def: #export extensions + Bundle + (<| (prefix "lux") + (|> extensions/lux + (dict.merge extensions/bit) + (dict.merge extensions/int) + (dict.merge extensions/frac) + (dict.merge extensions/text) + (dict.merge extensions/array) + (dict.merge extensions/math) + (dict.merge extensions/io) + (dict.merge extensions/atom) + (dict.merge extensions/box) + (dict.merge extensions/process) + ))) diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..11c64076c --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux @@ -0,0 +1,85 @@ +(.module: + [lux #- function] + (lux (control [monad #+ do] + pipe) + (data [product] + text/format + (coll [list "list/" Functor<List>]))) + (//// [reference #+ Register Variable] + [name] + [compiler "operation/" Monad<Operation>] + [analysis #+ Variant Tuple Environment Arity Abstraction Application Analysis] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression Computation Var])) + [///] + [//runtime #+ Operation Translator] + [//primitive] + [//reference]) + +(def: #export (apply translate [functionS argsS+]) + (-> Translator (Application Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (let [@closure (_.var (format function-name "___CLOSURE"))] + (operation/wrap + (case inits + #.Nil + function-definition + + _ + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left //reference.foreign'))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc //reference.local')) + +(def: #export (function translate [environment arity bodyS]) + (-> Translator (Abstraction Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (monad.map @ //reference.variable environment) + #let [arityO (|> arity .int _.int) + @num-args (_.var "num_args") + @function (_.var function-name) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args))]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(//reference.local' +0) @function])) + (_.let-values (list [[(|> (list.n/range +0 (dec arity)) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (//runtime.slice (_.int 0) arityO @curried) + output-func-args (//runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_.</2 arityO)) + (_.lambda [(list) (#.Some @missing)] + (|> @function + (apply-poly (_.append/2 @curried @missing)))))))]) + @function)) + )) diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..6f305336e --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux @@ -0,0 +1,39 @@ +(.module: + [lux #- loop] + (lux (control [monad #+ do]) + (data [product] + [text] + text/format + (coll [list "list/" Functor<List>])) + [macro]) + [////] + (//// [name] + (host ["_" scheme #+ Computation Var]) + [compiler "operation/" Monad<Operation>] + [synthesis #+ Synthesis]) + [///] + [//runtime #+ Operation Translator] + [//reference]) + +(def: @loop (_.var "loop")) + +(def: #export (loop translate offset initsS+ bodyS) + (-> Translator Nat (List Synthesis) Synthesis + (Operation Computation)) + (do compiler.Monad<Operation> + [initsO+ (monad.map @ translate initsS+) + bodyO (///.with-anchor @loop + (translate bodyS))] + (wrap (_.letrec (list [@loop (_.lambda [(|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ offset) //reference.local'))) + #.None] + bodyO)]) + (_.apply/* @loop initsO+))))) + +(def: #export (recur translate argsS+) + (-> Translator (List Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [@loop ///.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* @loop argsO+)))) diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..ac775fa82 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux @@ -0,0 +1,22 @@ +(.module: + [lux #- i64] + [/// #+ State] + (//// [compiler #+ "operation/" Monad<Operation>] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation]) + +(def: #export bool + (-> Bool (Operation Expression)) + (|>> _.bool operation/wrap)) + +(def: #export i64 + (-> (I64 Any) (Operation Expression)) + (|>> .int _.int operation/wrap)) + +(def: #export f64 + (-> Frac (Operation Expression)) + (|>> _.float operation/wrap)) + +(def: #export text + (-> Text (Operation Expression)) + (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..453d4edb6 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux @@ -0,0 +1,54 @@ +(.module: + lux + (lux (control pipe) + (data text/format)) + (//// [reference #+ Register Variable Reference] + [name] + [compiler "operation/" Monad<Operation>] + [analysis #+ Variant Tuple] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression Var])) + [//runtime #+ Operation Translator] + [//primitive]) + +(do-template [<name> <prefix>] + [(def: #export <name> + (-> Register Var) + (|>> .int %i (format <prefix>) _.var))] + + [local' "l"] + [foreign' "f"] + ) + +(def: #export variable' + (-> Variable Var) + (|>> (case> (#reference.Local register) + (local' register) + + (#reference.Foreign register) + (foreign' register)))) + +(def: #export variable + (-> Variable (Operation Var)) + (|>> ..variable' + operation/wrap)) + +(def: #export constant' + (-> Ident Var) + (|>> name.definition _.var)) + +(def: #export constant + (-> Ident (Operation Var)) + (|>> constant' operation/wrap)) + +(def: #export reference' + (-> Reference Expression) + (|>> (case> (#reference.Constant value) + (..constant' value) + + (#reference.Variable value) + (..variable' value)))) + +(def: #export reference + (-> Reference (Operation Expression)) + (|>> reference' operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..b30aff3a2 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux @@ -0,0 +1,362 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data [number #+ hex] + text/format + (coll [list "list/" Monad<List>])) + [function] + (macro [code] + ["s" syntax #+ syntax:])) + [/// #+ State] + (//// [name] + [compiler] + [analysis #+ Variant] + [synthesis] + (host ["_" scheme #+ Expression Computation Var]))) + +(type: #export Operation + (compiler.Operation (State Var Expression))) + +(type: #export Translator + (///.Translator Var Expression)) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bool Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [+0 false ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [+0 false] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(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 "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int 0))) + (slice (|> offset (_.-/2 (_.int 1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int 0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int 1))) + (_.cdr/1 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__" (name.normalize var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int 1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int 1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## 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") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_.</2 @index_min_length))] + (_.begin + (list + (_.define @index_min_length [(list) #.None] (minimum-index-length index)) + (_.define @product_length [(list) #.None] (_.length/1 product)) + (<| (_.if last-element? + (product-element index product)) + (_.if needs-recursion? + (product//right (product-tail product) + (updated-index @index_min_length product))) + ## Must slice + (_.begin + (list (_.define @slice [(list) #.None] + (_.make-vector/1 (|> @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int 0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_.</2 sum-tag)))) + (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int 0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.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/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (atom//compare-and-swap atom old new) + (with-vars [@temp] + (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))]) + (_.if (_.eq?/2 old @temp) + (_.begin + (list (_.vector-set!/3 atom (_.int 0) new) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Computation + @@atom//compare-and-swap) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int 0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int 1_000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: process//incoming + Var + (_.var (name.normalize "process//incoming"))) + +(runtime: (process//loop _) + (_.when (_.not/1 (_.null?/1 process//incoming)) + (with-vars [queue process] + (_.let (list [queue process//incoming]) + (_.begin (list (_.set! process//incoming (_.list/* (list))) + (_.map/2 (_.lambda [(list process) #.None] + (_.apply/1 process ..unit)) + queue) + (process//loop ..unit))))))) + +(runtime: (process//schedule milli-seconds procedure) + (let [process//future (function (_ process) + (_.set! process//incoming (_.cons/2 process process//incoming)))] + (_.begin + (list + (_.if (_.=/2 (_.int 0) milli-seconds) + (process//future procedure) + (with-vars [@start @process @now @ignored] + (_.let (list [@start (io//current-time ..unit)]) + (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)] + (_.let (list [@now (io//current-time ..unit)]) + (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds)) + (_.apply/1 procedure ..unit) + (process//future @process))))]) + (process//future @process))))) + ..unit)))) + +(def: runtime//process + Computation + (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list))) + @@process//loop + @@process//schedule))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + ))) + +(def: #export translate + (Operation Any) + (///.with-buffer + (do compiler.Monad<Operation> + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..a11434594 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux @@ -0,0 +1,29 @@ +(.module: + lux + (lux (control [monad #+ do])) + (//// [compiler] + [analysis #+ Variant Tuple] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation Translator] + [//primitive]) + +(def: #export (tuple translate elemsS+) + (-> Translator (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (//primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do compiler.Monad<Operation> + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Translator (Variant Synthesis) (Operation Expression)) + (do compiler.Monad<Operation> + [valueT (translate valueS)] + (wrap (//runtime.variant [lefts right? valueT])))) diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux index 38a8dd8a2..c7b16de27 100644 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/synthesis/function.lux @@ -13,8 +13,8 @@ (set ["set" unordered]))) (lang ["///." reference #+ Variable "variable/" Equality<Variable>] ["///." compiler] - [".L" analysis #+ Analysis] - ["//" synthesis #+ Arity Synthesis] + [".L" analysis #+ Arity Analysis] + ["//" synthesis #+ Synthesis] (synthesis [".S" expression]) [".L" extension]) ["r" math/random] |