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