diff options
Diffstat (limited to 'new-luxc/source/luxc/lang')
15 files changed, 1256 insertions, 365 deletions
diff --git a/new-luxc/source/luxc/lang/host/php.lux b/new-luxc/source/luxc/lang/host/php.lux index 1fb1ca1e0..6d21da21f 100644 --- a/new-luxc/source/luxc/lang/host/php.lux +++ b/new-luxc/source/luxc/lang/host/php.lux @@ -1,5 +1,5 @@ (.module: - [lux #- not or and function] + [lux #- Code' Code not or and function] (lux (control pipe) (data [text] text/format @@ -7,87 +7,127 @@ (coll [list "list/" Functor<List> Fold<List>])) (type abstract))) -(def: nest - (-> Text Text) - (|>> (format "\n") - (text.replace-all "\n" "\n "))) +(abstract: Global' {} Unit) +(abstract: Var' {} Unit) +(abstract: Computation' {} Unit) +(abstract: (Expression' k) {} Unit) +(abstract: Statement' {} Unit) -(def: (block content) - (-> Text Text) - (format "{" (nest content) "\n" "}")) - -(abstract: #export Global {} Unit) -(abstract: #export Var {} Unit) -(abstract: #export Computation {} Unit) - -(abstract: #export (Expression' k) +(abstract: (Code' k) {} Text - (type: #export Expression (Ex [k] (Expression' k))) - (type: #export GExpression (Expression' Global)) - (type: #export VExpression (Expression' Var)) - (type: #export CExpression (Expression' Computation)) - - (def: (self-contained content) - (-> Text CExpression) - (@abstraction (format "(" content ")"))) + (type: #export Code (Ex [k] (Code' k))) + (type: #export Expression (Code' (Ex [k] (Expression' k)))) + (type: #export Global (Code' (Expression' Global'))) + (type: #export Var (Code' (Expression' Var'))) + (type: #export Argument + {#reference? Bool + #var Var}) + (type: #export Computation (Code' (Expression' Computation'))) + (type: #export Statement (Code' Statement')) + + (def: #export code (-> Code Text) (|>> @representation)) + + (def: nest + (-> Text Text) + (|>> (format "\n") + (text.replace-all "\n" "\n "))) + + (def: block + (-> Text Text) + (|>> nest (text.enclose ["{" "\n}"]))) + + (def: computation + (-> Text Computation) + (|>> (text.enclose ["(" ")"]) @abstraction)) + + (def: (statement code) + (-> Text Statement) + (@abstraction (format code ";"))) + + (def: parameters + (-> (List Argument) Text) + (|>> (list/map (.function (_ [reference? var]) + (if reference? + (format "&" (@representation var)) + (@representation var)))) + (text.join-with ", ") + (text.enclose ["(" ")"]))) + + (do-template [<name> <reference?>] + [(def: #export <name> + (-> Var Argument) + (|>> [<reference?>]))] - (def: #export expression (-> Expression Text) (|>> @representation)) + [parameter false] + [reference true] + ) (def: arguments (-> (List Expression) Text) - (|>> (list/map ..expression) (text.join-with ", "))) - - (def: #export code (-> Text CExpression) (|>> @abstraction)) + (|>> (list/map ..code) (text.join-with ", ") (text.enclose ["(" ")"]))) (def: #export var - (-> Text VExpression) + (-> Text Var) (|>> (format "$") @abstraction)) (def: #export global - (-> Text GExpression) + (-> Text Global) (|>> @abstraction)) (def: #export null - CExpression + Computation (@abstraction "NULL")) (def: #export bool - (-> Bool CExpression) + (-> Bool Computation) (|>> %b @abstraction)) (def: #export int - (-> Int CExpression) + (-> Int Computation) (|>> %i @abstraction)) (def: #export float - (-> Frac CExpression) + (-> Frac Computation) (|>> (cond> [(f/= number.positive-infinity)] - [(new> "INF" self-contained)] + [(new> "INF" computation)] [(f/= number.negative-infinity)] - [(new> "-INF" self-contained)] + [(new> "-INF" computation)] [(f/= number.not-a-number)] - [(new> "NAN" self-contained)] + [(new> "NAN" computation)] ## else [%f @abstraction]))) (def: #export string - (-> Text CExpression) + (-> Text Computation) (|>> %t @abstraction)) (def: #export (apply args func) - (-> (List Expression) Expression CExpression) - (self-contained - (format (@representation func) "(" (..arguments args) ")"))) + (-> (List Expression) Expression Computation) + (@abstraction + (format (@representation func) (..arguments args)))) + + (def: #export (function arguments uses body) + (-> (List Argument) (List Argument) Statement Computation) + (let [uses (case uses + #.Nil + "" + + _ + (format "use " (..parameters uses)))] + (computation + (format "function " (..parameters arguments) + " " uses " " + (block (@representation body)))))) (do-template [<name> <function>] [(def: #export <name> - CExpression + Computation (..apply (list) (..global <function>)))] [func-num-args/0 "func_num_args"] @@ -96,7 +136,7 @@ (do-template [<name> <function>] [(def: #export (<name> values) - (-> (List Expression) CExpression) + (-> (List Expression) Computation) (..apply values (..global <function>)))] [array/* "array"] @@ -104,15 +144,15 @@ (do-template [<name> <function>] [(def: #export (<name> required optionals) - (-> Expression (List Expression) CExpression) + (-> Expression (List Expression) Computation) (..apply (list& required optionals) (..global <function>)))] [array-merge/+ "array_merge"] ) (def: #export (array/** kvs) - (-> (List [Expression Expression]) CExpression) - (self-contained + (-> (List [Expression Expression]) Computation) + (computation (format "array(" (|> kvs (list/map (.function (_ [key value]) @@ -122,73 +162,63 @@ (do-template [<name> <function>] [(def: #export (<name> input0) - (-> Expression CExpression) + (-> Expression Computation) (..apply (list input0) (..global <function>)))] - [count/1 "count"]) + [is-null/1 "is_null"] + [empty/1 "empty"] + [count/1 "count"] + [array-pop/1 "array_pop"] + [floatval/1 "floatval"] + ) (do-template [<name> <function>] [(def: #export (<name> input0 input1) - (-> Expression Expression CExpression) + (-> Expression Expression Computation) (..apply (list input0 input1) (..global <function>)))] [call-user-func-array/2 "call_user_func_array"] - [array-slice/2 "array_slice"]) + [array-slice/2 "array_slice"] + [array-push/2 "array_push"] + ) (do-template [<name> <function>] [(def: #export (<name> input0 input1 input2) - (-> Expression Expression Expression CExpression) + (-> Expression Expression Expression Computation) (..apply (list input0 input1 input2) (..global <function>)))] [array-slice/3 "array_slice"]) - ## (def: (composite-literal left-delimiter right-delimiter entry-serializer) - ## (All [a] (-> Text Text (-> a Text) - ## (-> (List a) CExpression))) - ## (function (_ entries) - ## (@abstraction (format "(" left-delimiter - ## (|> entries (list/map entry-serializer) (text.join-with ",")) - ## right-delimiter ")")))) - - ## (def: #export (slice from to list) - ## (-> CExpression CExpression CExpression CExpression) - ## (@abstraction (format "(" (@representation list) - ## "[" (@representation from) ":" (@representation to) "]" - ## ")"))) - - ## (def: #export (slice-from from list) - ## (-> CExpression CExpression CExpression) - ## (@abstraction (format "(" (@representation list) - ## "[" (@representation from) ":]" - ## ")"))) - - ## (def: #export (field name object) - ## (-> Text CExpression CExpression) - ## (@abstraction (format "(" (@representation object) "." name ")"))) - - ## (def: #export (send args method object) - ## (-> (List CExpression) Text CExpression CExpression) - ## (|> object (field method) (apply args))) + (def: #export (new constructor inputs) + (-> Global (List Expression) Computation) + (computation + (format "new " (@representation constructor) (arguments inputs)))) + + (def: #export (send method inputs object) + (-> Text (List Expression) Expression Computation) + (computation + (format (@representation object) "->" method (arguments inputs)))) (def: #export (nth idx array) - (-> Expression Expression CExpression) - (self-contained + (-> Expression Expression Computation) + (computation (format (@representation array) "[" (@representation idx) "]"))) (def: #export (? test then else) - (-> Expression Expression Expression CExpression) - (self-contained + (-> Expression Expression Expression Computation) + (computation (format (@representation test) " ? " (@representation then) " : " (@representation else)))) (do-template [<name> <op>] [(def: #export (<name> param subject) - (-> Expression Expression CExpression) - (@abstraction (format "(" (@representation subject) - " " <op> " " - (@representation param) ")")))] + (-> Expression Expression Computation) + (computation + (format (@representation subject) " " <op> " " (@representation param))))] + [or "||"] + [and "&&"] ## [is "is"] [= "=="] [< "<"] @@ -208,42 +238,36 @@ ## [bit-shr ">>"] ) - ## (do-template [<name> <op>] - ## [(def: #export (<name> param subject) - ## (-> CExpression CExpression CExpression) - ## (@abstraction (format "(" (@representation param) - ## " " <op> " " - ## (@representation subject) ")")))] + (def: #export not + (-> Computation Computation) + (|>> @representation (format "!") @abstraction)) - ## [or "or"] - ## [and "and"] - ## ) + (do-template [<name> <type> <constructor>] + [(def: #export (<name> var value) + (-> Var Expression <type>) + (<constructor> (format (@representation var) " = " (@representation value))))] - ## (def: #export (not subject) - ## (-> CExpression CExpression) - ## (@abstraction (format "(not " (@representation subject) ")"))) - ) - -(abstract: #export Statement - {} + [set! Statement ..statement] + [set!' Computation ..computation] + ) - Text - - (def: #export statement (-> Statement Text) (|>> @representation)) + (def: #export (set-nth! idx value array) + (-> Expression Expression Expression Statement) + (..statement + (format (@representation array) "[" (@representation idx) "] = " (@representation value)))) - (def: #export (set! var value) - (-> VExpression Expression Statement) - (@abstraction - (format (..expression var) " = " (..expression value) ";"))) + (def: #export global! + (-> Var Statement) + (|>> @representation (format "global ") ..statement)) - ## (def: #export (set-nth! idx value array) - ## (-> CExpression CExpression CExpression Statement) - ## (@abstraction (format (expression array) "[" (expression idx) "] = " (expression value)))) + (def: #export (set-global! name value) + (-> Text Expression Statement) + (|> (..var "GLOBALS") (..set-nth! (..string name) value))) (def: #export (if! test then! else!) (-> Expression Statement Statement Statement) (@abstraction - (format "if (" (..expression test) ")" + (format "if (" (@representation test) ")" (block (@representation then!)) " else " (block (@representation else!))))) @@ -251,7 +275,7 @@ (def: #export (when! test then!) (-> Expression Statement Statement) (@abstraction - (format "if (" (..expression test) ") " + (format "if (" (@representation test) ") " (block (@representation then!))))) (def: #export (then! post! pre!) @@ -262,53 +286,58 @@ (@representation post!)))) ## (def: #export (while! test body!) - ## (-> CExpression Statement Statement) + ## (-> Computation Statement Statement) ## (@abstraction ## (format "while " (expression test) ":" ## (nest body!)))) ## (def: #export (for-in! variable inputs body!) - ## (-> SVariable CExpression Statement Statement) + ## (-> SVariable Computation Statement Statement) ## (@abstraction ## (format "for " (..name variable) " in " (expression inputs) ":" ## (nest body!)))) - ## (type: #export Except - ## {#classes (List Text) - ## #exception SVariable - ## #handler Statement}) + (type: #export Except + {#class Global + #exception Var + #handler Statement}) + + (def: (catch! except) + (-> Except Text) + (let [declaration (format "(" (@representation (get@ #class except)) + " " (@representation (get@ #exception except)) ")")] + (format "catch" declaration " " + (block (@representation (get@ #handler except)))))) - ## (def: #export (try! body! excepts) - ## (-> Statement (List Except) Statement) - ## (@abstraction - ## (format "try:" - ## (nest body!) - ## (|> excepts - ## (list/map (function (_ [classes exception catch!]) - ## (format "\n" "except (" (text.join-with "," classes) - ## ") as " (..name exception) ":" - ## (nest catch!)))) - ## (text.join-with ""))))) + (def: #export (try! body! excepts) + (-> Statement (List Except) Statement) + (@abstraction + (format "try " (block (@representation body!)) "\n" + (|> excepts (list/map catch!) (text.join-with "\n"))))) (do-template [<name> <keyword>] [(def: #export (<name> message) (-> Expression Statement) - (@abstraction - (format <keyword> " " (..expression message) ";")))] + (statement (format <keyword> " " (@representation message))))] - ## [raise! "raise"] + [throw! "throw"] [return! "return"] [echo! "echo"] ) + + (def: #export do! + (-> Expression Statement) + (|>> @representation statement)) + + (def: #export (define! name value) + (-> Global Expression Statement) + (do! (..apply (list (|> name @representation ..string) + value) + (..global "define")))) (def: #export (function! name args body) - (-> GExpression (List VExpression) Statement Statement) + (-> Global (List Argument) Statement Statement) (@abstraction - (format "function " (..expression name) "(" (..arguments args) ") " - (block (@representation body))))) + (format "function " (@representation name) (..parameters args) + " " (block (@representation body))))) ) - -(def: #export (function arguments body) - (-> (List VExpression) Statement CExpression) - (self-contained - (format "function " "(" (..arguments arguments) ") " (block (..statement body))))) 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)))) diff --git a/new-luxc/source/luxc/lang/translation/python/case.jvm.lux b/new-luxc/source/luxc/lang/translation/python/case.jvm.lux index 6e5935297..6769103d9 100644 --- a/new-luxc/source/luxc/lang/translation/python/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/python/case.jvm.lux @@ -79,7 +79,7 @@ (def: (new-Exception error) (-> Expression Expression) - (python.apply (list pm-error) (python.global "Exception"))) + (python.apply (list error) (python.global "Exception"))) (def: fail-pm! (python.raise! (new-Exception pm-error))) |