diff options
Diffstat (limited to '')
13 files changed, 1086 insertions, 224 deletions
diff --git a/new-luxc/source/luxc/lang/translation/php.lux b/new-luxc/source/luxc/lang/translation/php.lux index 4cfcaaa0f..eeaa95309 100644 --- a/new-luxc/source/luxc/lang/translation/php.lux +++ b/new-luxc/source/luxc/lang/translation/php.lux @@ -46,9 +46,8 @@ (host.import javax/script/ScriptEngine (eval [String] #try Object)) -(host.import javax/script/ScriptEngineManager - (new []) - (getEngineByName [String] ScriptEngine)) +(host.import org/develnext/jphp/scripting/JPHPScriptEngine + (new [])) (type: #export Anchor [Text Register]) @@ -62,16 +61,15 @@ (def: #export init (IO Host) - (io (let [interpreter (|> (ScriptEngineManager::new []) - (ScriptEngineManager::getEngineByName ["jphp"]))] + (io (let [interpreter (JPHPScriptEngine::new [])] {#context ["" +0] #anchor #.None #loader (function (_ code) (do e.Monad<Error> - [_ (ScriptEngine::eval [(format "<?php " (_.statement code))] interpreter)] + [_ (ScriptEngine::eval [(format "<?php " (_.code code))] interpreter)] (wrap []))) #interpreter (function (_ code) - (ScriptEngine::eval [(format "<?php " (_.statement (_.return! code)))] interpreter)) + (ScriptEngine::eval [(format "<?php " (_.code (_.return! code)))] interpreter)) #module-buffer #.None #program-buffer (StringBuilder::new [])}))) @@ -168,8 +166,7 @@ (let [runner (|> compiler (get@ #.host) (:! Host) (get@ <field>))] (case (runner code) (#e.Error error) - (exec (log! (:! Text code)) - ((lang.throw Cannot-Execute error) compiler)) + ((lang.throw Cannot-Execute error) compiler) (#e.Success output) (#e.Success [compiler output])))))] @@ -192,7 +189,7 @@ (-> Statement (Meta Unit)) (do macro.Monad<Meta> [module-buffer module-buffer - #let [_ (Appendable::append [(:! CharSequence (_.statement code))] + #let [_ (Appendable::append [(:! CharSequence (_.code code))] module-buffer)]] (load! code))) 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<List> Fold<List>] + [set #+ Set])) + [macro #+ "meta/" Monad<Meta>] + (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<Meta> + [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<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) + (_.? 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<Meta> + [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 [<tag> <format>] + [_ (<tag> value)] + (meta/wrap (_.when! (_.not (_.= (|> value <format>) cursor-top)) + fail-pm!))) + ([#.Nat (<| _.int (:! Int))] + [#.Int _.int] + [#.Deg (<| _.int (:! Int))] + [#.Bool _.bool] + [#.Frac _.float] + [#.Text _.string]) + + (^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 (|> (_.set! @temp (runtimeT.sum//get cursor-top (_.int (:! Int idx)) <flag>)) + (_.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<Meta> + [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<Meta> + [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<Meta> + [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<Int>)) + +(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<Meta> map (|>> %code lang.normalize-name)))) + +(def: #export (translate-case translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) + (do macro.Monad<Meta> + [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 [<name>] @@ -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<Meta> ## [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<Meta> [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<Meta> - [_ (//.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<Meta> + [_ (//.save (function-definition! (list)))] + (wrap @function)) - _ - (do macro.Monad<Meta> - [] - (wrap (_.apply inits - (_.function (|> (list.enumerate inits) - (list/map (|>> product.left referenceT.closure))) - (|> function-definition! - (_.then! (_.return! @function))))))))) + _ + (do macro.Monad<Meta> + [#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<Meta> - [[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<List>])) + [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<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 (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<Meta> +## [[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<Meta>]) - (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<Maybe> + [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<List>] + [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<Text>))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s.local-symbol] [arity s.nat]) + (with-gensyms [g!_ g!proc g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) + (-> Text ..Proc)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do macro.Monad<Meta> + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) + + (~' _) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function (_ proc-name) + (function (_ translate inputsS) + (do macro.Monad<Meta> + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [Procedures] +## ## [[Lux]] +## (def: (lux//is [leftO rightO]) +## Binary +## (_.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<Text>) +## (install "noop" (unary lux//noop)) +## (install "is" (binary lux//is)) +## (install "try" (unary lux//try)) +## (install "if" (trinary lux//if)) +## (install "loop" lux//loop) +## (install "recur" lux//recur) +## )) + +## ## [[Bits]] +## (do-template [<name> <op>] +## [(def: (<name> [subjectO paramO]) +## Binary +## (<op> paramO subjectO))] + +## [bit//and _.bit-and] +## [bit//or _.bit-or] +## [bit//xor _.bit-xor] +## ) + +## (def: (bit//shift-left [subjectO paramO]) +## Binary +## (|> (_.bit-shl paramO subjectO) +## runtimeT.bit//64)) + +## (do-template [<name> <op>] +## [(def: (<name> [subjectO paramO]) +## Binary +## (<op> 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<Text>) +## (install "count" (unary runtimeT.bit//count)) +## (install "and" (binary bit//and)) +## (install "or" (binary bit//or)) +## (install "xor" (binary bit//xor)) +## (install "shift-left" (binary bit//shift-left)) +## (install "unsigned-shift-right" (binary bit//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<Text>) +## (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 [<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 + <expression>)] + + [int//min (|> (_.int -2) (_.** (_.int 63)))] + [int//max (|> (_.int 2) (_.** (_.int 63)) (_.- (_.int 1)))] + ) + +## (do-template [<name> <label>] +## [(def: (<name> _) +## Nullary +## (_.apply (list (_.string <label>)) (_.global "float")))] + +## [frac//not-a-number "nan"] +## [frac//positive-infinity "inf"] +## [frac//negative-infinity "-inf"] +## ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO + (<op> paramO)))] + + [int//+ _.+] + [int//- _.-] + [int//* _.*] + [int/// _./] + [int//% _.%] + ) + +## (do-template [<name> <op>] +## [(def: (<name> [subjectO paramO]) +## Binary +## (<op> paramO subjectO))] + +## [frac//+ _.+] +## [frac//- _.-] +## [frac//* _.*] +## [frac/// _./] +## [frac//% _.%] +## [frac//= _.=] +## [frac//< _.<] + +## [text//= _.=] +## [text//< _.<] +## ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [int//= _.=] + [int//< _.<] + ) + +(def: int-procs + 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 "min" (nullary int//min)) + (install "max" (nullary int//max)) + (install "to-frac" (unary _.floatval/1))))) + +## (def: frac-procs +## 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 (apply1 (_.global "int")))) +## (install "encode" (unary (apply1 (_.global "repr")))) +## (install "decode" (unary runtimeT.frac//decode))))) + +## ## [[Text]] +## (def: (text//concat [subjectO paramO]) +## Binary +## (|> subjectO (_.+ paramO))) + +## (def: (text//char [subjectO paramO]) +## Binary +## (runtimeT.text//char subjectO paramO)) + +## (def: (text//replace-all [subjectO paramO extraO]) +## Trinary +## (_.send (list paramO extraO) "replace" subjectO)) + +## (def: (text//replace-once [subjectO paramO extraO]) +## Trinary +## (_.send (list paramO extraO (_.int 1)) "replace" subjectO)) + +## (def: (text//clip [subjectO paramO extraO]) +## Trinary +## (runtimeT.text//clip subjectO paramO extraO)) + +## (def: (text//index [textO partO startO]) +## Trinary +## (runtimeT.text//index textO partO startO)) + +## (def: text-procs +## Bundle +## (<| (prefix "text") +## (|> (dict.new text.Hash<Text>) +## (install "=" (binary text//=)) +## (install "<" (binary text//<)) +## (install "concat" (binary text//concat)) +## (install "index" (trinary text//index)) +## (install "size" (unary (apply1 (_.global "len")))) +## (install "hash" (unary (apply1 (_.global "hash")))) +## (install "replace-once" (trinary text//replace-once)) +## (install "replace-all" (trinary text//replace-all)) +## (install "char" (binary text//char)) +## (install "clip" (trinary text//clip)) +## (install "upper" (unary (send0 "upper"))) +## (install "lower" (unary (send0 "lower"))) +## ))) + +## ## [[Math]] +## (def: (math//pow [subject param]) +## Binary +## (|> subject (_.** param))) + +## (def: math-procs +## Bundle +## (<| (prefix "math") +## (|> (dict.new text.Hash<Text>) +## (install "cos" (unary runtimeT.math//cos)) +## (install "sin" (unary runtimeT.math//sin)) +## (install "tan" (unary runtimeT.math//tan)) +## (install "acos" (unary runtimeT.math//acos)) +## (install "asin" (unary runtimeT.math//asin)) +## (install "atan" (unary runtimeT.math//atan)) +## (install "exp" (unary runtimeT.math//exp)) +## (install "log" (unary runtimeT.math//log)) +## (install "ceil" (unary runtimeT.math//ceil)) +## (install "floor" (unary runtimeT.math//floor)) +## (install "pow" (binary math//pow)) +## ))) + +## ## [[IO]] +## (def: io-procs +## Bundle +## (<| (prefix "io") +## (|> (dict.new text.Hash<Text>) +## (install "log" (unary runtimeT.io//log!)) +## (install "error" (unary runtimeT.io//throw!)) +## (install "exit" (unary runtimeT.io//exit!)) +## (install "current-time" (nullary (function (_ _) +## (runtimeT.io//current-time! runtimeT.unit))))))) + +## ## [[Atoms]] +## (def: atom//new +## Unary +## (|>> [(_.string runtimeT.atom//field)] (list) _.dict)) + +## (def: atom//read +## Unary +## (_.nth (_.string runtimeT.atom//field))) + +## (def: (atom//compare-and-swap [atomO oldO newO]) +## Trinary +## (runtimeT.atom//compare-and-swap atomO oldO newO)) + +## (def: atom-procs +## Bundle +## (<| (prefix "atom") +## (|> (dict.new text.Hash<Text>) +## (install "new" (unary atom//new)) +## (install "read" (unary atom//read)) +## (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +## ## [[Processes]] +## (def: (process//concurrency-level []) +## Nullary +## (_.int 1)) + +## (def: (process//schedule [milli-secondsO procedureO]) +## Binary +## (runtimeT.process//schedule milli-secondsO procedureO)) + +## (def: process-procs +## Bundle +## (<| (prefix "process") +## (|> (dict.new text.Hash<Text>) +## (install "concurrency-level" (nullary process//concurrency-level)) +## (install "future" (unary runtimeT.process//future)) +## (install "schedule" (binary process//schedule)) +## ))) + +## [Bundles] +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> (dict.new text.Hash<Text>) + ## 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 process-procs) + ))) diff --git a/new-luxc/source/luxc/lang/translation/php/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/php/procedure/host.jvm.lux new file mode 100644 index 000000000..c1b43da2f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/procedure/host.jvm.lux @@ -0,0 +1,89 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro "macro/" Monad<Meta>]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [ruby #+ Ruby Expression Statement]))) + [///] + (/// [".T" runtime]) + (// ["@" common])) + +## (do-template [<name> <lua>] +## [(def: (<name> _) @.Nullary <lua>)] + +## [lua//nil "nil"] +## [lua//table "{}"] +## ) + +## (def: (lua//global proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list [_ (#.Text name)])) +## (do macro.Monad<Meta> +## [] +## (wrap name)) + +## _ +## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +## (def: (lua//call proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list& functionS argsS+)) +## (do macro.Monad<Meta> +## [functionO (translate functionS) +## argsO+ (monad.map @ translate argsS+)] +## (wrap (lua.apply functionO argsO+))) + +## _ +## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +## (def: lua-procs +## @.Bundle +## (|> (dict.new text.Hash<Text>) +## (@.install "nil" (@.nullary lua//nil)) +## (@.install "table" (@.nullary lua//table)) +## (@.install "global" lua//global) +## (@.install "call" lua//call))) + +## (def: (table//call proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list& tableS [_ (#.Text field)] argsS+)) +## (do macro.Monad<Meta> +## [tableO (translate tableS) +## argsO+ (monad.map @ translate argsS+)] +## (wrap (lua.method field tableO argsO+))) + +## _ +## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +## (def: (table//get [fieldO tableO]) +## @.Binary +## (runtimeT.lua//get tableO fieldO)) + +## (def: (table//set [fieldO valueO tableO]) +## @.Trinary +## (runtimeT.lua//set tableO fieldO valueO)) + +## (def: table-procs +## @.Bundle +## (<| (@.prefix "table") +## (|> (dict.new text.Hash<Text>) +## (@.install "call" table//call) +## (@.install "get" (@.binary table//get)) +## (@.install "set" (@.trinary table//set))))) + +(def: #export procedures + @.Bundle + (<| (@.prefix "lua") + (dict.new text.Hash<Text>) + ## (|> lua-procs + ## (dict.merge table-procs)) + )) diff --git a/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux index 280710afc..9146684e4 100644 --- a/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux @@ -5,31 +5,31 @@ text/format)) (luxc ["&" lang] (lang [".L" variable #+ Variable Register] - (host ["_" php #+ VExpression]))) + (host ["_" php #+ Var]))) [//] (// [".T" runtime])) (do-template [<register> <prefix>] [(def: #export <register> - (-> Register VExpression) + (-> Register Var) (|>> (:! Int) %i (format <prefix>) _.var))] [closure "c"] [variable "v"]) (def: #export (local var) - (-> Variable VExpression) + (-> Variable Var) (if (variableL.captured? var) (closure (variableL.captured-register var)) (variable (:! Nat var)))) (def: #export global - (-> Ident VExpression) + (-> Ident Var) (|>> //.definition-name _.var)) (do-template [<name> <input> <converter>] [(def: #export <name> - (-> <input> (Meta VExpression)) + (-> <input> (Meta Var)) (|>> <converter> (:: macro.Monad<Meta> wrap)))] [translate-variable Variable local] diff --git a/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux index d2f5cd2a2..fe02cf2fc 100644 --- a/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux @@ -10,92 +10,91 @@ [io #+ Process]) [//] (luxc [lang] - (lang (host ["_" php #+ Expression CExpression Statement])))) + (lang (host ["_" php #+ Expression Computation Statement])))) (def: prefix Text "LuxRuntime") -(def: #export unit CExpression (_.string //.unit)) +(def: #export unit Computation (_.string //.unit)) (def: (flag value) - (-> Bool CExpression) + (-> Bool Computation) (if value (_.string "") _.null)) (def: (variant' tag last? value) - (-> Expression Expression Expression CExpression) + (-> Expression Expression Expression Computation) (_.array/** (list [(_.string //.variant-tag-field) tag] [(_.string //.variant-flag-field) last?] [(_.string //.variant-value-field) value]))) (def: #export (variant tag last? value) - (-> Nat Bool Expression CExpression) + (-> Nat Bool Expression Computation) (variant' (_.int (nat-to-int tag)) (flag last?) value)) (def: #export none - CExpression + Computation (variant +0 false unit)) (def: #export some - (-> Expression CExpression) + (-> Expression Computation) (variant +1 true)) (def: #export left - (-> Expression CExpression) + (-> Expression Computation) (variant +0 false)) (def: #export right - (-> Expression CExpression) + (-> Expression Computation) (variant +1 true)) (type: Runtime Statement) -## (def: declaration -## (s.Syntax [Text (List Text)]) -## (p.either (p.seq s.local-symbol (p/wrap (list))) -## (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) - -## (syntax: (runtime: [[name args] declaration] -## definition) -## (let [implementation (code.local-symbol (format "@@" name)) -## runtime (format "__" prefix "__" (lang.normalize-name name)) -## $runtime (` (_.var (~ (code.text runtime)))) -## @runtime (` (@@ (~ $runtime))) -## argsC+ (list/map code.local-symbol args) -## argsLC+ (list/map (|>> lang.normalize-name code.text (~) (_.var) (`)) -## args) -## declaration (` ((~ (code.local-symbol name)) -## (~+ argsC+))) -## type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) -## _.CExpression))] -## (wrap (list (` (def: (~' #export) (~ declaration) -## (~ type) -## (_.apply (list (~+ argsC+)) (~ @runtime)))) -## (` (def: (~ implementation) -## _.Statement -## (~ (case argsC+ -## #.Nil -## (` (_.set! (list (~ $runtime)) (~ definition))) - -## _ -## (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) -## (list/map (function (_ [left right]) -## (list left (` (@@ (~ right)))))) -## list/join))] -## (_.def! (~ $runtime) -## (list (~+ argsLC+)) -## (~ definition)))))))))))) - -## (syntax: (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 (lang.normalize-name var)))))))) -## list/join))] -## (~ body)))))) +(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 (` (_.global (~ (code.text runtime)))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> lang.normalize-name code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (_.apply (list (~+ argsC+)) (~ @runtime)))) + (` (def: (~ implementation) + _.Statement + (~ (case argsC+ + #.Nil + (` (_.define! (~ @runtime) (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.function! (~ @runtime) + ((~! list/map) _.parameter (list (~+ argsLC+))) + (~ definition)))))))))))) + +(syntax: (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 (lang.normalize-name var)))))))) + list/join))] + (~ body)))))) ## (runtime: (lux//try op) ## (let [$error (_.var "error") @@ -128,7 +127,7 @@ ## (_.return! ..unit))) ## (def: (exception message) -## (-> Expression CExpression) +## (-> Expression Computation) ## (_.apply (list message) (_.global "Exception"))) ## (runtime: (io//throw! message) @@ -158,67 +157,64 @@ ## @@io//exit! ## @@io//current-time!)) -## (runtime: (product//left product index) -## (let [$index_min_length (_.var "index_min_length")] -## ($_ _.then! -## (_.set! (list $index_min_length) (_.+ (_.int 1) index)) -## (_.if! (_.> (@@ $index_min_length) (_.length product)) -## ## No need for recursion -## (_.return! (_.nth index product)) -## ## Needs recursion -## (_.return! (product//left (_.nth (_.- (_.int 1) -## (_.length product)) -## product) -## (_.- (_.length product) -## (@@ $index_min_length)))))))) - -## (runtime: (product//right product index) -## (let [$index_min_length (_.var "index_min_length")] -## ($_ _.then! -## (_.set! (list $index_min_length) (_.+ (_.int 1) index)) -## (_.cond! (list [(_.= (@@ $index_min_length) (_.length product)) -## ## Last element. -## (_.return! (_.nth index product))] -## [(_.< (@@ $index_min_length) (_.length product)) -## ## Needs recursion -## (_.return! (product//right (_.nth (_.- (_.int 1) -## (_.length product)) -## product) -## (_.- (_.length product) -## (@@ $index_min_length))))]) -## ## Must slice -## (_.return! (_.slice-from index product)))))) - -## (runtime: (sum//get sum wantedTag wantsLast) -## (let [no-match! (_.return! _.none) -## sum-tag (_.nth (_.string //.variant-tag-field) sum) -## sum-flag (_.nth (_.string //.variant-flag-field) sum) -## sum-value (_.nth (_.string //.variant-value-field) sum) -## is-last? (_.= (_.string "") sum-flag) -## test-recursion! (_.if! is-last? -## ## Must recurse. -## (_.return! (sum//get sum-value (_.- sum-tag wantedTag) wantsLast)) -## no-match!)] -## (_.cond! (list [(_.= sum-tag wantedTag) -## (_.if! (_.= wantsLast sum-flag) -## (_.return! sum-value) -## test-recursion!)] - -## [(_.> sum-tag wantedTag) -## test-recursion!] - -## [(_.and (_.< sum-tag wantedTag) -## (_.= (_.string "") wantsLast)) -## (_.return! (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) - -## no-match!))) - -## (def: runtime//adt -## Runtime -## ($_ _.then! -## @@product//left -## @@product//right -## @@sum//get)) +(runtime: (product//left product index) + (let [$index_min_length (_.var "index_min_length")] + (|> (_.set! $index_min_length (_.+ (_.int 1) index)) + (_.then! (_.if! (_.> $index_min_length (_.count/1 product)) + ## No need for recursion + (_.return! (_.nth index product)) + ## Needs recursion + (_.return! (product//left (_.nth (_.- (_.int 1) + (_.count/1 product)) + product) + (_.- (_.count/1 product) + $index_min_length)))))))) + +(runtime: (product//right product index) + (let [$index_min_length (_.var "index_min_length")] + (|> (_.set! $index_min_length (_.+ (_.int 1) index)) + (_.then! (<| (_.if! (_.= $index_min_length (_.count/1 product)) + ## Last element. + (_.return! (_.nth index product))) + (_.if! (_.< $index_min_length (_.count/1 product)) + ## Needs recursion + (_.return! (product//right (_.nth (_.- (_.int 1) + (_.count/1 product)) + product) + (_.- (_.count/1 product) + $index_min_length)))) + ## Must slice + (_.return! (_.array-slice/2 product index))))))) + +(runtime: (sum//get sum wantedTag wantsLast) + (let [no-match! (_.return! _.null) + sum-tag (_.nth (_.string //.variant-tag-field) sum) + sum-flag (_.nth (_.string //.variant-flag-field) sum) + sum-value (_.nth (_.string //.variant-value-field) sum) + is-last? (_.= (_.string "") sum-flag) + test-recursion! (_.if! is-last? + ## Must recurse. + (_.return! (sum//get sum-value (_.- sum-tag wantedTag) wantsLast)) + no-match!)] + (<| (_.if! (_.= sum-tag wantedTag) + (_.if! (|> (_.and (_.is-null/1 wantsLast) (_.is-null/1 sum-flag)) + (_.or (|> (_.and (_.not (_.is-null/1 wantsLast)) + (_.not (_.is-null/1 sum-flag))) + (_.and (_.= wantsLast sum-flag))))) + (_.return! sum-value) + test-recursion!)) + (_.if! (_.> sum-tag wantedTag) + test-recursion!) + (_.if! (|> (_.< sum-tag wantedTag) + (_.and (_.not (_.is-null/1 wantsLast)))) + (_.return! (variant' (_.- wantedTag sum-tag) sum-flag sum-value))) + no-match!))) + +(def: runtime//adt + Runtime + (|> @@product//left + (_.then! @@product//right) + (_.then! @@sum//get))) ## (def: full-32-bits (_.code "0xFFFFFFFF")) @@ -292,7 +288,7 @@ ## (runtime: (text//clip @text @from @to) ## (with-vars [length] ## ($_ _.then! -## (_.set! (list length) (_.length @text)) +## (_.set! (list length) (_.count/1 @text)) ## (_.if! ($_ _.and ## (|> @to (within? (@@ length))) ## (|> @from (up-to? @to))) @@ -300,7 +296,7 @@ ## (_.return! ..none))))) ## (runtime: (text//char text idx) -## (_.if! (|> idx (within? (_.length text))) +## (_.if! (|> idx (within? (_.count/1 text))) ## (_.return! (..some (_.apply (list (|> text (_.slice idx (inc idx)))) ## (_.global "ord")))) ## (_.return! ..none))) @@ -314,7 +310,7 @@ ## (def: (check-index-out-of-bounds array idx body!) ## (-> Expression Expression Statement Statement) -## (_.if! (|> idx (_.<= (_.length array))) +## (_.if! (|> idx (_.<= (_.count/1 array))) ## body! ## (_.raise! (exception (_.string "Array index out of bounds!"))))) @@ -323,7 +319,7 @@ ## (<| (check-index-out-of-bounds array idx) ## ($_ _.then! ## (_.set! (list temp) (_.nth idx array)) -## (_.if! (_.= _.none (@@ temp)) +## (_.if! (_.= _.null (@@ temp)) ## (_.return! ..none) ## (_.return! (..some (@@ temp)))))))) @@ -354,16 +350,6 @@ ## ($_ _.then! ## @@atom//compare-and-swap)) -## (runtime: (box//write value box) -## ($_ _.then! -## (_.set-nth! (_.int 0) value box) -## (_.return! ..unit))) - -## (def: runtime//box -## Runtime -## ($_ _.then! -## @@box//write)) - ## (runtime: (process//future procedure) ## ($_ _.then! ## (_.import! "threading") @@ -420,22 +406,29 @@ ## @@math//ceil ## @@math//floor)) +(def: check-necessary-conditions! + Statement + (let [condition (_.= (_.int 8) + (_.global "PHP_INT_SIZE")) + error-message (_.string (format "Cannot run program!" "\n" + "Lux/PHP programs require 64-bit PHP builds!")) + ->Exception (|>> (list) (_.new (_.global "Exception")))] + (_.when! (_.not condition) + (_.throw! (->Exception error-message))))) + (def: runtime Runtime - (_.echo! (_.string "Hello, world!")) - ## ($_ _.then! - ## runtime//lux - ## runtime//adt - ## runtime//bit - ## runtime//text - ## runtime//array - ## runtime//atom - ## runtime//box - ## runtime//io - ## runtime//process - ## runtime//math - ## ) - ) + (|> check-necessary-conditions! + ## runtime//lux + (_.then! runtime//adt) + ## runtime//bit + ## runtime//text + ## runtime//array + ## runtime//atom + ## runtime//io + ## runtime//process + ## runtime//math + )) (def: #export artifact Text (format prefix //.extension)) diff --git a/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux index 6e44f3973..a92340e92 100644 --- a/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux @@ -6,7 +6,7 @@ [macro]) (luxc ["&" lang] (lang [synthesis #+ Synthesis] - (host ["_" php #+ Expression CExpression]))) + (host ["_" php #+ Expression Computation]))) [//] (// [".T" runtime])) @@ -25,7 +25,7 @@ (wrap (_.array/* elemsT+))))) (def: #export (translate-variant translate tag tail? valueS) - (-> //.Translator Nat Bool Synthesis (Meta CExpression)) + (-> //.Translator Nat Bool Synthesis (Meta Computation)) (do macro.Monad<Meta> [valueT (translate valueS)] (wrap (runtimeT.variant tag tail? valueT)))) |