From 4b7d81c1e0449adc031ece6299fe4d0a09f66347 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 May 2018 00:40:01 -0400 Subject: - WIP: - Initial PHP back-end implementation [missing procedures]. --- .../source/luxc/lang/translation/php/case.jvm.lux | 257 ++++++++++++ .../source/luxc/lang/translation/php/eval.jvm.lux | 14 +- .../luxc/lang/translation/php/expression.jvm.lux | 16 +- .../luxc/lang/translation/php/function.jvm.lux | 88 ++-- .../source/luxc/lang/translation/php/loop.jvm.lux | 36 ++ .../luxc/lang/translation/php/primitive.jvm.lux | 10 +- .../luxc/lang/translation/php/procedure.jvm.lux | 30 ++ .../lang/translation/php/procedure/common.jvm.lux | 460 +++++++++++++++++++++ .../lang/translation/php/procedure/host.jvm.lux | 89 ++++ .../luxc/lang/translation/php/reference.jvm.lux | 10 +- .../luxc/lang/translation/php/runtime.jvm.lux | 279 ++++++------- .../luxc/lang/translation/php/structure.jvm.lux | 4 +- 12 files changed, 1079 insertions(+), 214 deletions(-) create mode 100644 new-luxc/source/luxc/lang/translation/php/case.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/php/loop.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/php/procedure.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/php/procedure/host.jvm.lux (limited to 'new-luxc/source/luxc/lang/translation/php') diff --git a/new-luxc/source/luxc/lang/translation/php/case.jvm.lux b/new-luxc/source/luxc/lang/translation/php/case.jvm.lux new file mode 100644 index 000000000..0868811e7 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/case.jvm.lux @@ -0,0 +1,257 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor Fold] + [set #+ Set])) + [macro #+ "meta/" Monad] + (macro [code])) + (luxc [lang] + (lang [".L" variable #+ Register Variable] + ["ls" synthesis #+ Synthesis Path] + (host ["_" php #+ Expression Statement Except Var]))) + [//] + (// [".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 + [valueO (translate valueS) + bodyO (translate bodyS) + #let [@register (referenceT.variable register)]] + (wrap (|> bodyO + (list (_.set!' @register valueO)) + _.array/* + (_.nth (_.int 1)))))) + +(def: #export (translate-record-get translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bool]) + (Meta Expression)) + (do macro.Monad + [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) + (_.? testO thenO elseO)) + +(def: @savepoint (_.var "pm_cursor_savepoint")) +(def: @cursor (_.var "pm_cursor")) + +(def: (push-cursor! value) + (-> Expression Statement) + (_.do! (_.array-push/2 @cursor value))) + +(def: save-cursor! + Statement + (_.do! (_.array-push/2 @savepoint (_.array-slice/2 @cursor (_.int 0))))) + +(def: restore-cursor! + Statement + (_.set! @cursor (_.array-pop/1 @savepoint))) + +(def: cursor-top + Expression + (_.nth (|> @cursor _.count/1 (_.- (_.int 1))) + @cursor)) + +(def: pop-cursor! + Statement + (_.do! (_.array-pop/1 @cursor))) + +(def: pm-error (_.string "PM-ERROR")) + +(def: php-exception (_.global "Exception")) + +(def: (new-Exception error) + (-> Expression Expression) + (_.new php-exception (list error))) + +(def: fail-pm! (_.throw! (new-Exception pm-error))) + +(def: @temp (_.var "temp")) + +(exception: #export (Unrecognized-Path {message Text}) + message) + +(def: @alt-error (_.var "alt_error")) + +(def: (pm-catch! handler!) + (-> Statement Except) + {#_.class php-exception + #_.exception @alt-error + #_.handler (_.if! (|> @alt-error (_.send "getMessage" (list)) (_.= pm-error)) + handler! + (_.throw! @alt-error))}) + +(def: (translate-pattern-matching' translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Statement)) + (case pathP + (^code ("lux case exec" (~ bodyS))) + (do macro.Monad + [bodyO (translate bodyS)] + (wrap (_.return! bodyO))) + + (^code ("lux case pop")) + (meta/wrap pop-cursor!) + + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (meta/wrap (_.set! (referenceT.variable register) cursor-top)) + + (^template [ ] + [_ ( value)] + (meta/wrap (_.when! (_.not (_.= (|> value ) cursor-top)) + fail-pm!))) + ([#.Nat (<| _.int (:! Int))] + [#.Int _.int] + [#.Deg (<| _.int (:! Int))] + [#.Bool _.bool] + [#.Frac _.float] + [#.Text _.string]) + + (^template [ ] + (^code ( (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! ( cursor-top (_.int (:! Int idx)))))) + (["lux case tuple left" runtimeT.product//left] + ["lux case tuple right" runtimeT.product//right]) + + (^template [ ] + (^code ( (~ [_ (#.Nat idx)]))) + (meta/wrap (|> (_.set! @temp (runtimeT.sum//get cursor-top (_.int (:! Int idx)) )) + (_.then! (_.if! (_.is-null/1 @temp) + fail-pm! + (push-cursor! @temp)))))) + (["lux case variant left" _.null] + ["lux case variant right" (_.string "")]) + + (^code ("lux case seq" (~ leftP) (~ rightP))) + (do macro.Monad + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (|> leftO + (_.then! rightO)))) + + (^code ("lux case alt" (~ leftP) (~ rightP))) + (do macro.Monad + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (_.try! (|> save-cursor! + (_.then! leftO)) + (list (pm-catch! + (|> restore-cursor! + (_.then! rightO))))))) + + _ + (lang.throw Unrecognized-Path (%code pathP)) + )) + +(def: (translate-pattern-matching translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Statement)) + (do macro.Monad + [pattern-matching (translate-pattern-matching' translate pathP)] + (wrap (_.try! pattern-matching + (list (pm-catch! + (_.throw! (new-Exception (_.string "Invalid expression for pattern-matching."))))))))) + +(def: (initialize-pattern-matching! stack-init) + (-> Expression Statement) + (|> (_.set! @cursor (_.array/* (list stack-init))) + (_.then! (_.set! @savepoint (_.array/* (list)))))) + +(def: empty (Set Variable) (set.new number.Hash)) + +(type: Storage + {#bindings (Set Variable) + #dependencies (Set Variable)}) + +(def: (path-variables pathP) + (-> Path Storage) + (loop [pathP pathP + outer-variables {#bindings empty + #dependencies empty}] + ## TODO: Remove (let [outer recur]) once loops can have names. + (let [outer recur] + (case pathP + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (update@ #bindings (set.add (nat-to-int register)) + outer-variables) + + (^or (^code ("lux case seq" (~ leftP) (~ rightP))) + (^code ("lux case alt" (~ leftP) (~ rightP)))) + (list/fold outer outer-variables (list leftP rightP)) + + (^code ("lux case exec" (~ bodyS))) + (loop [bodyS bodyS + inner-variables outer-variables] + ## TODO: Remove (let [inner recur]) once loops can have names. + (let [inner recur] + (case bodyS + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (inner valueS inner-variables) + + (^code [(~+ members)]) + (list/fold inner inner-variables members) + + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (if (set.member? (get@ #bindings inner-variables) var) + inner-variables + (update@ #dependencies (set.add var) inner-variables)) + + (^code ("lux call" (~ functionS) (~+ argsS))) + (list/fold inner inner-variables (#.Cons functionS argsS)) + + (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) + (|> environment + (list/map (|>> (list) code.form)) + (list/fold inner inner-variables)) + + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (list/fold inner (update@ #bindings (set.add (nat-to-int register)) + inner-variables) + (list inputS exprS)) + + (^code ("lux case" (~ inputS) (~ pathPS))) + (|> inner-variables (inner inputS) (outer pathPS)) + + (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) + (list/fold inner inner-variables argsS) + + _ + inner-variables))) + + _ + outer-variables)))) + +(def: generated-name + (-> Text (Meta Text)) + (|>> macro.gensym + (:: macro.Monad map (|>> %code lang.normalize-name)))) + +(def: #export (translate-case translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) + (do macro.Monad + [valueO (translate valueS) + @case (:: @ map _.global (generated-name "case")) + @value (:: @ map _.var (generated-name "value")) + #let [@dependencies+ (|> (path-variables pathP) + (get@ #dependencies) + set.to-list + (list/map referenceT.local))] + pattern-matching! (translate-pattern-matching translate pathP) + _ (//.save (_.function! @case (|> (list& @value @dependencies+) + (list/map _.parameter)) + (|> (initialize-pattern-matching! @value) + (_.then! pattern-matching!))))] + (wrap (_.apply (list& valueO @dependencies+) @case)))) diff --git a/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux index ba9220f57..c6ff1a880 100644 --- a/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux @@ -128,20 +128,12 @@ (let [interpreter (|> compiler (get@ #.host) (:! //.Host) (get@ #//.interpreter))] (case (interpreter code) (#e.Error error) - (exec (log! (format "eval #e.Error\n" - "<< " (_.expression code) "\n" - error)) - ((lang.throw Cannot-Evaluate error) compiler)) + ((lang.throw Cannot-Evaluate error) compiler) (#e.Success output) (case (lux-object output) (#e.Success parsed-output) - (exec ## (log! (format "eval #e.Success\n" - ## "<< " (_.expression code))) - (#e.Success [compiler parsed-output])) + (#e.Success [compiler parsed-output]) (#e.Error error) - (exec (log! (format "eval #e.Error\n" - "<< " (_.expression code) "\n" - error)) - ((lang.throw Cannot-Evaluate error) compiler))))))) + ((lang.throw Cannot-Evaluate error) compiler)))))) diff --git a/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux index abcc22187..43497c93e 100644 --- a/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux @@ -18,8 +18,8 @@ [".T" structure] [".T" reference] [".T" function] - ## [".T" case] - ## [".T" procedure] + [".T" case] + [".T" procedure] )) (do-template [] @@ -55,11 +55,11 @@ [_ (#.Symbol definition)] (referenceT.translate-definition definition) - ## (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) - ## (caseT.translate-let translate register inputS exprS) + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (caseT.translate-let translate register inputS exprS) - ## (^code ("lux case" (~ inputS) (~ pathPS))) - ## (caseT.translate-case translate inputS pathPS) + (^code ("lux case" (~ inputS) (~ pathPS))) + (caseT.translate-case translate inputS pathPS) (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) (case (s.run environment (p.some s.int)) @@ -72,8 +72,8 @@ (^code ("lux call" (~ functionS) (~+ argsS))) (functionT.translate-apply translate functionS argsS) - ## (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) - ## (procedureT.translate-procedure translate procedure argsS) + (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) + (procedureT.translate-procedure translate procedure argsS) ## (do macro.Monad ## [translation (extensionL.find-translation procedure)] ## (translation argsS)) diff --git a/new-luxc/source/luxc/lang/translation/php/function.jvm.lux b/new-luxc/source/luxc/lang/translation/php/function.jvm.lux index 7d0baa4d5..9a283439f 100644 --- a/new-luxc/source/luxc/lang/translation/php/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/function.jvm.lux @@ -10,12 +10,12 @@ (luxc ["&" lang] (lang ["ls" synthesis #+ Synthesis Arity] [".L" variable #+ Register Variable] - (host ["_" php #+ Expression GExpression CExpression Statement]))) + (host ["_" php #+ Expression Var Computation Statement]))) [//] (// [".T" reference])) (def: #export (translate-apply translate functionS argsS+) - (-> //.Translator Synthesis (List Synthesis) (Meta CExpression)) + (-> //.Translator Synthesis (List Synthesis) (Meta Computation)) (do macro.Monad [functionO (translate functionS) argsO+ (monad.map @ translate argsS+)] @@ -29,53 +29,61 @@ (_.nth (|> register nat-to-int _.int) @curried))) -(def: (with-closure @function inits function-definition!) - (-> GExpression (List Expression) Statement (Meta Expression)) - (case inits - #.Nil - (do macro.Monad - [_ (//.save function-definition!)] - (wrap @function)) +(def: (with-closure function-name inits function-definition!) + (-> Text (List Expression) (-> (List Var) Statement) (Meta Expression)) + (let [@function (_.var function-name)] + (case inits + #.Nil + (do macro.Monad + [_ (//.save (function-definition! (list)))] + (wrap @function)) - _ - (do macro.Monad - [] - (wrap (_.apply inits - (_.function (|> (list.enumerate inits) - (list/map (|>> product.left referenceT.closure))) - (|> function-definition! - (_.then! (_.return! @function))))))))) + _ + (do macro.Monad + [#let [closure-name (format function-name "___CLOSURE") + @closure (_.global (format function-name "___CLOSURE")) + captured (|> (list.enumerate inits) (list/map (|>> product.left referenceT.closure)))] + _ (//.save (_.function! @closure (list/map _.parameter captured) + (|> (function-definition! captured) + (_.then! (_.return! @function)))))] + (wrap (_.apply inits @closure)))))) (def: #export (translate-function translate env arity bodyS) (-> //.Translator (List Variable) Arity Synthesis (Meta Expression)) (do macro.Monad - [[function-name bodyO] (//.with-sub-context - (do @ - [function-name //.context] - (//.with-anchor [function-name +1] - (translate bodyS)))) + [[base-function-name bodyO] (//.with-sub-context + (do @ + [function-name //.context] + (//.with-anchor [function-name +1] + (translate bodyS)))) + current-module-name macro.current-module-name + #let [function-name (format current-module-name "___" base-function-name)] closureO+ (monad.map @ referenceT.translate-variable env) - #let [@function (_.global function-name) + #let [@function (_.var function-name) self-init! (_.set! (referenceT.variable +0) @function) args-inits! (|> (list.n/range +0 (n/dec arity)) (list/map input-declaration!) (list/fold _.then! self-init!)) arityO (|> arity nat-to-int _.int) @num_args (_.var "num_args")]] - (with-closure @function closureO+ - (_.function! @function (list) - (|> (_.set! @num_args _.func-num-args/0) - (_.then! (_.set! @curried _.func-get-args/0)) - (_.then! (_.if! (|> @num_args (_.= arityO)) - (|> args-inits! - (_.then! (_.return! bodyO))) - (_.if! (|> @num_args (_.> arityO)) - (let [arity-args (_.array-slice/3 @curried (_.int 0) arityO) - output-func-args (_.array-slice/2 @curried arityO)] - (_.return! (_.call-user-func-array/2 (_.call-user-func-array/2 @function arity-args) - output-func-args))) - (let [@missing (_.var "missing")] - (_.return! (_.function (list) - (|> (_.set! @missing _.func-get-args/0) - (_.then! (_.return! (_.call-user-func-array/2 @function - (_.array-merge/+ @curried (list @missing))))))))))))))))) + (with-closure function-name closureO+ + (function (_ captured) + (_.set! @function + (_.function (list) (|> captured + (list/map _.reference) + (list& (_.reference @function))) + (|> (_.set! @num_args _.func-num-args/0) + (_.then! (_.set! @curried _.func-get-args/0)) + (_.then! (_.if! (|> @num_args (_.= arityO)) + (|> args-inits! + (_.then! (_.return! bodyO))) + (_.if! (|> @num_args (_.> arityO)) + (let [arity-args (_.array-slice/3 @curried (_.int 0) arityO) + output-func-args (_.array-slice/2 @curried arityO)] + (_.return! (_.call-user-func-array/2 (_.call-user-func-array/2 @function arity-args) + output-func-args))) + (let [@missing (_.var "missing")] + (_.return! (_.function (list) (list (_.reference @function) (_.reference @curried)) + (|> (_.set! @missing _.func-get-args/0) + (_.then! (_.return! (_.call-user-func-array/2 @function + (_.array-merge/+ @curried (list @missing))))))))))))))))))) diff --git a/new-luxc/source/luxc/lang/translation/php/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/php/loop.jvm.lux new file mode 100644 index 000000000..8a5b40261 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/loop.jvm.lux @@ -0,0 +1,36 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor])) + [macro]) + (luxc [lang] + (lang ["ls" synthesis] + (host ["_" php #+ Expression Statement]))) + [//] + (// [".T" reference])) + +## (def: #export (translate-loop translate offset initsS+ bodyS) +## (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis +## (Meta Expression)) +## (do macro.Monad +## [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 (python.var loop-name) +## @loop-name (@@ $loop-name)] +## _ (//.save (python.def! $loop-name (|> (list.n/range +0 (n/dec (list.size initsS+))) +## (list/map (|>> (n/+ offset) referenceT.variable))) +## (python.return! bodyO)))] +## (wrap (python.apply initsO+ @loop-name)))) + +## (def: #export (translate-recur translate argsS+) +## (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis) +## (Meta Expression)) +## (do macro.Monad +## [[loop-name offset] //.anchor +## argsO+ (monad.map @ translate argsS+)] +## (wrap (python.apply argsO+ (python.global loop-name))))) diff --git a/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux index 61570143b..6fcd675ce 100644 --- a/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux @@ -1,20 +1,20 @@ (.module: lux (lux [macro "meta/" Monad]) - (luxc (lang (host ["_" php #+ CExpression])))) + (luxc (lang (host ["_" php #+ Computation])))) (def: #export translate-bool - (-> Bool (Meta CExpression)) + (-> Bool (Meta Computation)) (|>> _.bool meta/wrap)) (def: #export translate-int - (-> Int (Meta CExpression)) + (-> Int (Meta Computation)) (|>> _.int meta/wrap)) (def: #export translate-frac - (-> Frac (Meta CExpression)) + (-> Frac (Meta Computation)) (|>> _.float meta/wrap)) (def: #export translate-text - (-> Text (Meta CExpression)) + (-> Text (Meta Computation)) (|>> _.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/php/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/php/procedure.jvm.lux new file mode 100644 index 000000000..9748167ca --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/procedure.jvm.lux @@ -0,0 +1,30 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [dict]))) + (luxc ["&" lang] + (lang ["ls" synthesis] + (host ["_" php #+ Expression Statement]))) + [//] + (/ ["/." common] + ["/." host])) + +(exception: #export (Unknown-Procedure {message Text}) + message) + +(def: procedures + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) + +(def: #export (translate-procedure translate name args) + (-> (-> ls.Synthesis (Meta Expression)) Text (List ls.Synthesis) + (Meta Expression)) + (<| (maybe.default (&.throw Unknown-Procedure (%t name))) + (do maybe.Monad + [proc (dict.get name procedures)] + (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux new file mode 100644 index 000000000..384a88056 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux @@ -0,0 +1,460 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number] + (coll [list "list/" Functor] + [dict #+ Dict])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host ["_" php #+ Expression Statement]))) + [///] + (/// [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])) + +## [Types] +(type: #export Translator + (-> ls.Synthesis (Meta Expression))) + +(type: #export Proc + (-> Translator (List ls.Synthesis) (Meta Expression))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector [size s.nat] elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Expression)) +(type: #export Unary (-> (Vector +1 Expression) Expression)) +(type: #export Binary (-> (Vector +2 Expression) Expression)) +(type: #export Trinary (-> (Vector +3 Expression) Expression)) +(type: #export Variadic (-> (List Expression) Expression)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s.local-symbol] [arity s.nat]) + (with-gensyms [g!_ g!proc g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) + (-> Text ..Proc)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do macro.Monad + [(~+ (|> 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 + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [Procedures] +## ## [[Lux]] +## (def: (lux//is [leftO rightO]) +## Binary +## (_.is 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) +## (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 [ ] +## [(def: ( [subjectO paramO]) +## Binary +## ( paramO subjectO))] + +## [bit//and _.bit-and] +## [bit//or _.bit-or] +## [bit//xor _.bit-xor] +## ) + +## (def: (bit//shift-left [subjectO paramO]) +## Binary +## (|> (_.bit-shl paramO subjectO) +## runtimeT.bit//64)) + +## (do-template [ ] +## [(def: ( [subjectO paramO]) +## Binary +## ( paramO subjectO))] + +## [bit//shift-right _.bit-shr] +## [bit//unsigned-shift-right runtimeT.bit//shift-right] +## ) + +## (def: bit-procs +## Bundle +## (<| (prefix "bit") +## (|> (dict.new text.Hash) +## (install "count" (unary runtimeT.bit//count)) +## (install "and" (binary bit//and)) +## (install "or" (binary bit//or)) +## (install "xor" (binary bit//xor)) +## (install "shift-left" (binary bit//shift-left)) +## (install "unsigned-shift-right" (binary bit//unsigned-shift-right)) +## (install "shift-right" (binary bit//shift-right)) +## ))) + +## ## [[Arrays]] +## (def: (array//new sizeO) +## Unary +## (|> _.none +## list _.list +## (_.* sizeO))) + +## (def: (array//get [arrayO idxO]) +## Binary +## (runtimeT.array//get arrayO idxO)) + +## (def: (array//put [arrayO idxO elemO]) +## Trinary +## (runtimeT.array//put arrayO idxO elemO)) + +## (def: (array//remove [arrayO idxO]) +## Binary +## (runtimeT.array//put arrayO idxO _.none)) + +## (def: array-procs +## Bundle +## (<| (prefix "array") +## (|> (dict.new text.Hash) +## (install "new" (unary array//new)) +## (install "get" (binary array//get)) +## (install "put" (trinary array//put)) +## (install "remove" (binary array//remove)) +## (install "size" (unary _.length)) +## ))) + +## ## [[Numbers]] +## (host.import java/lang/Double +## (#static MIN_VALUE Double) +## (#static MAX_VALUE Double)) + +## (do-template [ ] +## [(def: ( _) +## Nullary +## ( ))] + +## [frac//smallest Double::MIN_VALUE _.float] +## [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] +## [frac//max Double::MAX_VALUE _.float] +## ) + +(do-template [ ] + [(def: ( _) + Nullary + )] + + [int//min (|> (_.int -2) (_.** (_.int 63)))] + [int//max (|> (_.int 2) (_.** (_.int 63)) (_.- (_.int 1)))] + ) + +## (do-template [