diff options
Diffstat (limited to 'new-luxc/source/luxc')
17 files changed, 14 insertions, 2044 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index da9dcb974..01ec36624 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -3,13 +3,14 @@ [abstract monad] [control - ["p" parser]] + ["p" parser + ["s" code]]] [data [collection ["." list ("#/." functor)]]] [macro ["." code] - ["s" syntax (#+ syntax:)]] + [syntax (#+ syntax:)]] [host (#+ import:)] [world [binary (#+ Binary)]] diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index d8360d4d7..7329dec1a 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -4,18 +4,19 @@ [monad (#+ do)]] [control ["." function] - ["p" parser]] + ["p" parser + ["s" code]]] [data ["." maybe] ["." error] [text format] [collection - ["." list ("#/." functor)]]] + ["." list ("#@." functor)]]] ["." host (#+ import: do-to)] [macro ["." code] - ["s" syntax (#+ syntax:)]] + [syntax (#+ syntax:)]] [tool [compiler [phase (#+ Operation)]]]] @@ -28,7 +29,7 @@ (syntax: (declare {codes (p.many s.local-identifier)}) (|> codes - (list/map (function (_ code) (` ((~' #static) (~ (code.local-identifier code)) (~' int))))) + (list@map (function (_ code) (` ((~' #static) (~ (code.local-identifier code)) (~' int))))) wrap)) (`` (import: org/objectweb/asm/Opcodes diff --git a/new-luxc/source/luxc/lang/host/php.lux b/new-luxc/source/luxc/lang/host/php.lux deleted file mode 100644 index 878bbaa18..000000000 --- a/new-luxc/source/luxc/lang/host/php.lux +++ /dev/null @@ -1,345 +0,0 @@ -(.module: - [lux #- Code' Code not or and function] - (lux (control pipe) - (data [text] - text/format - [number] - (coll [list "list/" Functor<List> Fold<List>])) - (type abstract))) - -(abstract: Global' {} Any) -(abstract: Var' {} Any) -(abstract: Computation' {} Any) -(abstract: (Expression' k) {} Any) -(abstract: Statement' {} Any) - -(abstract: (Code' k) - {} - - Text - - (type: #export Code (Ex [k] (Code' k))) - (type: #export Expression (Code' (Ex [k] (Expression' k)))) - (type: #export Global (Code' (Expression' Global'))) - (type: #export Var (Code' (Expression' Var'))) - (type: #export Argument - {#reference? Bit - #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 ["(" ")"]))) - - (template [<name> <reference?>] - [(def: #export <name> - (-> Var Argument) - (|>> [<reference?>]))] - - [parameter #0] - [reference #1] - ) - - (def: arguments - (-> (List Expression) Text) - (|>> (list/map ..code) (text.join-with ", ") (text.enclose ["(" ")"]))) - - (def: #export var - (-> Text Var) - (|>> (format "$") :abstraction)) - - (def: #export global - (-> Text Global) - (|>> :abstraction)) - - (def: #export null - Computation - (:abstraction "NULL")) - - (def: #export bool - (-> Bit Computation) - (|>> (case> #0 "false" - #1 "true") - :abstraction)) - - (def: #export int - (-> Int Computation) - (|>> %i :abstraction)) - - (def: #export float - (-> Frac Computation) - (|>> (cond> [(f/= number.positive-infinity)] - [(new> "INF" computation)] - - [(f/= number.negative-infinity)] - [(new> "-INF" computation)] - - [(f/= number.not-a-number)] - [(new> "NAN" computation)] - - ## else - [%f :abstraction]))) - - (def: #export string - (-> Text Computation) - (|>> %t :abstraction)) - - (def: #export (apply args func) - (-> (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)))))) - - (template [<name> <function>] - [(def: #export <name> - Computation - (..apply (list) (..global <function>)))] - - [func-num-args/0 "func_num_args"] - [func-get-args/0 "func_get_args"] - ) - - (template [<name> <function>] - [(def: #export (<name> values) - (-> (List Expression) Computation) - (..apply values (..global <function>)))] - - [array/* "array"] - ) - - (template [<name> <function>] - [(def: #export (<name> required optionals) - (-> Expression (List Expression) Computation) - (..apply (list& required optionals) (..global <function>)))] - - [array-merge/+ "array_merge"] - ) - - (def: #export (array/** kvs) - (-> (List [Expression Expression]) Computation) - (computation - (format "array(" - (|> kvs - (list/map (.function (_ [key value]) - (format (:representation key) " => " (:representation value)))) - (text.join-with ", ")) - ")"))) - - (template [<name> <function>] - [(def: #export (<name> input0) - (-> Expression Computation) - (..apply (list input0) (..global <function>)))] - - [is-null/1 "is_null"] - [empty/1 "empty"] - [count/1 "count"] - [array-pop/1 "array_pop"] - [floatval/1 "floatval"] - ) - - (template [<name> <function>] - [(def: #export (<name> input0 input1) - (-> Expression Expression Computation) - (..apply (list input0 input1) (..global <function>)))] - - [call-user-func-array/2 "call_user_func_array"] - [array-slice/2 "array_slice"] - [array-push/2 "array_push"] - ) - - (template [<name> <function>] - [(def: #export (<name> input0 input1 input2) - (-> Expression Expression Expression Computation) - (..apply (list input0 input1 input2) (..global <function>)))] - - [array-slice/3 "array_slice"]) - - (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 Computation) - (computation - (format (:representation array) "[" (:representation idx) "]"))) - - (def: #export (? test then else) - (-> Expression Expression Expression Computation) - (computation - (format (:representation test) " ? " - (:representation then) " : " - (:representation else)))) - - (template [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Computation) - (computation - (format (:representation subject) " " <op> " " (:representation param))))] - - [or "||"] - [and "&&"] - ## [is "is"] - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [% "%"] - [** "**"] - ## [bit-or "|"] - ## [bit-and "&"] - ## [bit-xor "^"] - ## [bit-shl "<<"] - ## [bit-shr ">>"] - ) - - (def: #export not - (-> Computation Computation) - (|>> :representation (format "!") :abstraction)) - - (template [<name> <type> <constructor>] - [(def: #export (<name> var value) - (-> Var Expression <type>) - (<constructor> (format (:representation var) " = " (:representation value))))] - - [set! Statement ..statement] - [set!' Computation ..computation] - ) - - (def: #export (set-nth! idx value array) - (-> Expression Expression Expression Statement) - (..statement - (format (:representation array) "[" (:representation idx) "] = " (:representation value)))) - - (def: #export global! - (-> Var Statement) - (|>> :representation (format "global ") ..statement)) - - (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 (" (:representation test) ")" - (block (:representation then!)) - " else " - (block (:representation else!))))) - - (def: #export (when! test then!) - (-> Expression Statement Statement) - (:abstraction - (format "if (" (:representation test) ") " - (block (:representation then!))))) - - (def: #export (then! post! pre!) - (-> Statement Statement Statement) - (:abstraction - (format (:representation pre!) - "\n" - (:representation post!)))) - - ## (def: #export (while! test body!) - ## (-> Computation Statement Statement) - ## (:abstraction - ## (format "while " (expression test) ":" - ## (nest body!)))) - - ## (def: #export (for-in! variable inputs body!) - ## (-> SVariable Computation Statement Statement) - ## (:abstraction - ## (format "for " (..name variable) " in " (expression inputs) ":" - ## (nest body!)))) - - (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 " (block (:representation body!)) "\n" - (|> excepts (list/map catch!) (text.join-with "\n"))))) - - (template [<name> <keyword>] - [(def: #export (<name> message) - (-> Expression Statement) - (statement (format <keyword> " " (:representation message))))] - - [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) - (-> Global (List Argument) Statement Statement) - (:abstraction - (format "function " (:representation name) (..parameters args) - " " (block (:representation body))))) - ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index d5a7bd3f5..c4bc66923 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -3,14 +3,14 @@ [abstract ["." monad (#+ do)]] [control - ["p" parser ("#@." monad)] - ["ex" exception (#+ exception:)]] + ["ex" exception (#+ exception:)] + ["p" parser ("#@." monad) + ["l" text]]] [data ["." product] ["." error] ["." text - format - ["l" lexer]] + format] [collection ["." list ("#@." functor)] ["." dictionary (#+ Dictionary)]]] @@ -602,7 +602,7 @@ (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) (def: base-type - (l.Lexer $.Type) + (l.Parser $.Type) ($_ p.either (p.after (l.this "boolean") (p@wrap _t.boolean)) (p.after (l.this "byte") (p@wrap _t.byte)) @@ -618,7 +618,7 @@ )) (def: java-type - (l.Lexer $.Type) + (l.Parser $.Type) (do p.monad [raw base-type nesting (p.some (l.this "[]"))] diff --git a/new-luxc/source/luxc/lang/translation/php.lux b/new-luxc/source/luxc/lang/translation/php.lux deleted file mode 100644 index 0a694d3e6..000000000 --- a/new-luxc/source/luxc/lang/translation/php.lux +++ /dev/null @@ -1,211 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - pipe - [monad #+ do]) - (data [bit] - [maybe] - ["e" error #+ Error] - [text "text/" Eq<Text>] - text/format - (coll [array])) - [macro] - [io #+ IO Process io] - [host #+ class: interface: object] - (world [file #+ File])) - (luxc [lang] - (lang [".L" variable #+ Register] - ["ls" synthesis #+ Synthesis] - (host ["_" php #+ Expression Statement])) - [".C" io])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [No-Active-Module-Buffer] - [Cannot-Execute] - - [No-Anchor] - ) - -(host.import: java/lang/Object) - -(host.import: java/lang/String - (getBytes [String] #try (Array byte))) - -(host.import: java/lang/CharSequence) - -(host.import: java/lang/Appendable - (append [CharSequence] Appendable)) - -(host.import: java/lang/StringBuilder - (new []) - (toString [] String)) - -(host.import: javax/script/ScriptEngine - (eval [String] #try Object)) - -(host.import: org/develnext/jphp/scripting/JPHPScriptEngine - (new [])) - -(type: #export Anchor [Text Register]) - -(type: #export Host - {#context [Text Nat] - #anchor (Maybe Anchor) - #loader (-> Statement (Error Any)) - #interpreter (-> Expression (Error Object)) - #module-buffer (Maybe StringBuilder) - #program-buffer StringBuilder}) - -(def: #export init - (IO Host) - (io (let [interpreter (JPHPScriptEngine::new [])] - {#context ["" +0] - #anchor #.None - #loader (function (_ code) - (do e.Monad<Error> - [_ (ScriptEngine::eval [(format "<?php " (_.code code))] interpreter)] - (wrap []))) - #interpreter (function (_ code) - (ScriptEngine::eval [(format "<?php " (_.code (_.return! code)))] interpreter)) - #module-buffer #.None - #program-buffer (StringBuilder::new [])}))) - -(def: #export extension Text ".php") -(def: #export module-name Text (format "module" extension)) - -(def: #export init-module-buffer - (Meta Any) - (function (_ compiler) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #module-buffer (#.Some (StringBuilder::new []))) - (:coerce Nothing)) - compiler) - []]))) - -(def: #export (with-sub-context expr) - (All [a] (-> (Meta a) (Meta [Text a]))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler)) - [old-name old-sub] (get@ #context old) - new-name (format old-name "___" (%i (.int old-sub)))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #context [new-name +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #context [old-name (inc old-sub)]) - (:coerce Nothing)) - compiler') - [new-name output]]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export context - (Meta Text) - (function (_ compiler) - (#e.Success [compiler - (|> (get@ #.host compiler) - (:coerce Host) - (get@ #context) - (let> [name sub] - name))]))) - -(def: #export (with-anchor anchor expr) - (All [a] (-> Anchor (Meta a) (Meta a))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #anchor (#.Some anchor) old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #anchor (get@ #anchor old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export anchor - (Meta Anchor) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #anchor)) - (#.Some anchor) - (#e.Success [compiler anchor]) - - #.None - ((lang.throw No-Anchor "") compiler)))) - -(def: #export module-buffer - (Meta StringBuilder) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #module-buffer)) - #.None - ((lang.throw No-Active-Module-Buffer "") compiler) - - (#.Some module-buffer) - (#e.Success [compiler module-buffer])))) - -(def: #export program-buffer - (Meta StringBuilder) - (function (_ compiler) - (#e.Success [compiler (|> compiler (get@ #.host) (:coerce Host) (get@ #program-buffer))]))) - -(template [<name> <field> <inputT> <outputT>] - [(def: (<name> code) - (-> <inputT> (Meta <outputT>)) - (function (_ compiler) - (let [runner (|> compiler (get@ #.host) (:coerce Host) (get@ <field>))] - (case (runner code) - (#e.Error error) - ((lang.throw Cannot-Execute error) compiler) - - (#e.Success output) - (#e.Success [compiler output])))))] - - [load! #loader Statement Any] - [interpret #interpreter Expression Object] - ) - -(def: #export variant-tag-field "_lux_tag") -(def: #export variant-flag-field "_lux_flag") -(def: #export variant-value-field "_lux_value") - -(def: #export unit Text "") - -(def: #export (definition-name [module name]) - (-> Name Text) - (lang.normalize-name (format module "$" name))) - -(def: #export (save code) - (-> Statement (Meta Any)) - (do macro.Monad<Meta> - [module-buffer module-buffer - #let [_ (Appendable::append [(:coerce CharSequence (_.code code))] - module-buffer)]] - (load! code))) - -(def: #export (save-module! target) - (-> File (Meta (Process Any))) - (do macro.Monad<Meta> - [module macro.current-module-name - module-buffer module-buffer - program-buffer program-buffer - #let [module-code (StringBuilder::toString [] module-buffer) - _ (Appendable::append [(:coerce CharSequence (format module-code "\n"))] - program-buffer)]] - (wrap (ioC.write target - (format (lang.normalize-name module) "/" ..module-name) - (|> module-code - (String::getBytes ["UTF-8"]) - e.assume))))) - -(type: #export Translator (-> Synthesis (Meta Expression))) diff --git a/new-luxc/source/luxc/lang/translation/php/case.jvm.lux b/new-luxc/source/luxc/lang/translation/php/case.jvm.lux deleted file mode 100644 index c438425ff..000000000 --- a/new-luxc/source/luxc/lang/translation/php/case.jvm.lux +++ /dev/null @@ -1,255 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [number] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>] - (set ["set" unordered #+ Set]))) - [macro #+ "meta/" Monad<Meta>] - (macro [code])) - (luxc [lang] - (lang [".L" variable #+ Register Variable] - ["ls" synthesis #+ Synthesis Path] - (host ["_" 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 Bit]) - (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 (:coerce 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!))) - ([#.Int _.int] - [#.Bit _.bool] - [#.Frac _.float] - [#.Text _.string]) - - (^template [<pm> <getter>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor! (<getter> cursor-top (_.int (:coerce 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 (:coerce 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 (.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)]) (~ [_ (#.Bit 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 (.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 deleted file mode 100644 index 4c4a6c641..000000000 --- a/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux +++ /dev/null @@ -1,139 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [bit] - [maybe] - ["e" error #+ Error] - text/format - (coll [array])) - [host]) - (luxc [lang] - (lang (host ["_" php #+ Expression Statement]))) - [//]) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Not-A-Variant] - [Null-Has-No-Lux-Representation] - [Cannot-Evaluate] - ) - -(host.import: java/lang/Object - (toString [] String) - (getClass [] (Class Object))) - -(host.import: java/lang/Long - (intValue [] Integer)) - -(exception: #export (Unknown-Kind-Of-Host-Object {host-object Object}) - (let [object-class (:coerce Text (Object::toString [] (Object::getClass [] (:coerce Object host-object)))) - text-representation (:coerce Text (Object::toString [] (:coerce Object host-object)))] - (format object-class " --- " text-representation))) - -(host.import: php/runtime/Memory) - -(host.import: php/runtime/memory/NullMemory) - -(host.import: php/runtime/memory/FalseMemory) -(host.import: php/runtime/memory/TrueMemory) - -(host.import: php/runtime/memory/LongMemory - (new [long]) - (toLong [] long)) - -(host.import: php/runtime/memory/DoubleMemory - (toDouble [] double)) - -(host.import: php/runtime/memory/StringMemory - (new [String]) - (toString [] String)) - -(host.import: php/runtime/memory/ReferenceMemory - (getValue [] Memory)) - -(host.import: php/runtime/memory/ArrayMemory - (size [] int) - (isMap [] boolean) - (get [Memory] Memory)) - -(def: (tuple lux-object host-object) - (-> (-> Object (Error Any)) ArrayMemory (Error Any)) - (let [size (ArrayMemory::size [] host-object)] - (loop [idx 0 - output (: (Array Any) (array.new (:coerce Nat size)))] - (if (i/< size idx) - (let [value (|> host-object - (ArrayMemory::get [(LongMemory::new [idx])]) - (:coerce ReferenceMemory) (ReferenceMemory::getValue []))] - (if (host.instance? php/runtime/memory/NullMemory value) - (recur (inc idx) - (array.write (:coerce Nat idx) (host.null) output)) - (do e.Monad<Error> - [lux-value (lux-object value)] - (recur (inc idx) - (array.write (:coerce Nat idx) lux-value output))))) - (ex.return output))))) - -(def: (variant lux-object host-object) - (-> (-> Object (Error Any)) ArrayMemory (Error Any)) - (do e.Monad<Error> - [variant-tag (lux-object (ArrayMemory::get [(StringMemory::new [//.variant-tag-field])] host-object)) - variant-value (lux-object (ArrayMemory::get [(StringMemory::new [//.variant-value-field])] host-object))] - (wrap (: Any - [(Long::intValue [] (:coerce Long variant-tag)) - (: Any - (if (|> host-object - (ArrayMemory::get [(StringMemory::new [//.variant-flag-field])]) - (:coerce ReferenceMemory) - (ReferenceMemory::getValue []) - (host.instance? php/runtime/memory/NullMemory)) - (host.null) - "")) - variant-value])))) - -(def: (lux-object host-object) - (-> Object (Error Any)) - (cond (host.instance? php/runtime/memory/FalseMemory host-object) - (ex.return #0) - - (host.instance? php/runtime/memory/TrueMemory host-object) - (ex.return #1) - - (host.instance? php/runtime/memory/LongMemory host-object) - (ex.return (LongMemory::toLong [] (:coerce LongMemory host-object))) - - (host.instance? php/runtime/memory/DoubleMemory host-object) - (ex.return (DoubleMemory::toDouble [] (:coerce DoubleMemory host-object))) - - (host.instance? php/runtime/memory/StringMemory host-object) - (ex.return (StringMemory::toString [] (:coerce StringMemory host-object))) - - (host.instance? php/runtime/memory/ReferenceMemory host-object) - (lux-object (ReferenceMemory::getValue [] (:coerce ReferenceMemory host-object))) - - (host.instance? php/runtime/memory/ArrayMemory host-object) - (if (ArrayMemory::isMap [] (:coerce ArrayMemory host-object)) - (variant lux-object (:coerce ArrayMemory host-object)) - (tuple lux-object (:coerce ArrayMemory host-object))) - - ## else - (ex.throw Unknown-Kind-Of-Host-Object host-object))) - -(def: #export (eval code) - (-> Expression (Meta Any)) - (function (_ compiler) - (let [interpreter (|> compiler (get@ #.host) (:coerce //.Host) (get@ #//.interpreter))] - (case (interpreter code) - (#e.Error error) - ((lang.throw Cannot-Evaluate error) compiler) - - (#e.Success output) - (case (lux-object output) - (#e.Success parsed-output) - (#e.Success [compiler parsed-output]) - - (#e.Error error) - ((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 deleted file mode 100644 index c49003c64..000000000 --- a/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux +++ /dev/null @@ -1,80 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - text/format) - [macro] - (macro ["s" syntax])) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - [".L" extension] - ["ls" synthesis #+ Synthesis] - (host ["_" php #+ Expression Statement]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" structure] - [".T" reference] - [".T" function] - [".T" case] - [".T" procedure] - )) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Invalid-Function-Syntax] - [Unrecognized-Synthesis] - ) - -(def: #export (translate synthesis) - //.Translator - (case synthesis - (^template [<tag> <generator>] - [_ (<tag> value)] - (|> value <generator>)) - ([#.Bit primitiveT.translate-bit] - [#.Int primitiveT.translate-int] - [#.Frac primitiveT.translate-frac] - [#.Text primitiveT.translate-text]) - - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) - - (^code [(~+ members)]) - (structureT.translate-tuple translate members) - - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (referenceT.translate-variable var) - - [_ (#.Identifier definition)] - (referenceT.translate-definition definition) - - (^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 function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) - (case (s.run environment (p.some s.int)) - (#e.Success environment) - (functionT.translate-function translate environment arity bodyS) - - _ - (&.throw Invalid-Function-Syntax (%code synthesis))) - - (^code ("lux call" (~ functionS) (~+ argsS))) - (functionT.translate-apply translate functionS argsS) - - (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) - (procedureT.translate-procedure translate procedure argsS) - ## (do macro.Monad<Meta> - ## [translation (extensionL.find-translation procedure)] - ## (translation argsS)) - - _ - (&.throw Unrecognized-Synthesis (%code synthesis)))) diff --git a/new-luxc/source/luxc/lang/translation/php/function.jvm.lux b/new-luxc/source/luxc/lang/translation/php/function.jvm.lux deleted file mode 100644 index 27a265566..000000000 --- a/new-luxc/source/luxc/lang/translation/php/function.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [product] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>])) - [macro]) - (luxc ["&" lang] - (lang ["ls" synthesis #+ Synthesis Arity] - [".L" variable #+ Register Variable] - (host ["_" php #+ Expression Var Computation Statement]))) - [//] - (// [".T" reference])) - -(def: #export (translate-apply translate functionS argsS+) - (-> //.Translator Synthesis (List Synthesis) (Meta Computation)) - (do macro.Monad<Meta> - [functionO (translate functionS) - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply argsO+ functionO)))) - -(def: @curried (_.var "curried")) - -(def: (input-declaration! register) - (-> Register Statement) - (_.set! (referenceT.variable (inc register)) - (_.nth (|> register .int _.int) - @curried))) - -(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> - [#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> - [[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 (_.var function-name) - self-init! (_.set! (referenceT.variable +0) @function) - args-inits! (|> (list.n/range +0 (dec arity)) - (list/map input-declaration!) - (list/fold _.then! self-init!)) - arityO (|> arity .int _.int) - @num_args (_.var "num_args")]] - (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 deleted file mode 100644 index ddc4f67ab..000000000 --- a/new-luxc/source/luxc/lang/translation/php/loop.jvm.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.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 (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 deleted file mode 100644 index 061833c70..000000000 --- a/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - lux - (lux [macro "meta/" Monad<Meta>]) - (luxc (lang (host ["_" php #+ Computation])))) - -(def: #export translate-bit - (-> Bit (Meta Computation)) - (|>> _.bool meta/wrap)) - -(def: #export translate-int - (-> Int (Meta Computation)) - (|>> _.int meta/wrap)) - -(def: #export translate-frac - (-> Frac (Meta Computation)) - (|>> _.float meta/wrap)) - -(def: #export translate-text - (-> Text (Meta Computation)) - (|>> _.string meta/wrap)) 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 deleted file mode 100644 index 7a44accf2..000000000 --- a/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux +++ /dev/null @@ -1,322 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host ["_" 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 .int %i) "\n" - " Actual: " (|> actual .int %i))) - -(syntax: (arity: {name s.local-identifier} {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-identifier 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)) - -## (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 "is" (binary lux//is)) -## (install "try" (unary lux//try)) -## (install "if" (trinary lux//if)) -## (install "loop" lux//loop) -## (install "recur" lux//recur) -## )) - -## ## [[Bits]] -## (template [<name> <op>] -## [(def: (<name> [subjectO paramO]) -## Binary -## (<op> paramO subjectO))] - -## [bit//and _.bit-and] -## [bit//or _.bit-or] -## [bit//xor _.bit-xor] -## ) - -## (def: (bit//left-shift [subjectO paramO]) -## Binary -## (|> (_.bit-shl paramO subjectO) -## runtimeT.bit//64)) - -## (template [<name> <op>] -## [(def: (<name> [subjectO paramO]) -## Binary -## (<op> paramO subjectO))] - -## [bit//arithmetic-right-shift _.bit-shr] -## [bit//logical-right-shift runtimeT.bit//logical-right-shift] -## ) - -## (def: bit-procs -## Bundle -## (<| (prefix "bit") -## (|> (dict.new text.Hash<Text>) -## (install "and" (binary bit//and)) -## (install "or" (binary bit//or)) -## (install "xor" (binary bit//xor)) -## (install "left-shift" (binary bit//left-shift)) -## (install "logical-right-shift" (binary bit//logical-right-shift)) -## (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) -## ))) - -## ## [[Numbers]] -## (host.import: java/lang/Double -## (#static MIN_VALUE Double) -## (#static MAX_VALUE Double)) - -## (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] -## ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO - (<op> paramO)))] - - [int//+ _.+] - [int//- _.-] - [int//* _.*] - [int/// _./] - [int//% _.%] - ) - -## (template [<name> <op>] -## [(def: (<name> [subjectO paramO]) -## Binary -## (<op> paramO subjectO))] - -## [frac//+ _.+] -## [frac//- _.-] -## [frac//* _.*] -## [frac/// _./] -## [frac//% _.%] -## [frac//= _.=] -## [frac//< _.<] - -## [text//= _.=] -## [text//< _.<] -## ) - -(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 "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 "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//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 "char" (binary text//char)) -## (install "clip" (trinary text//clip)) -## ))) - -## ## [[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))))))) - -## [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 io-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 deleted file mode 100644 index 2793b40e8..000000000 --- a/new-luxc/source/luxc/lang/translation/php/procedure/host.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -## (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 deleted file mode 100644 index 2415963d1..000000000 --- a/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - lux - (lux [macro] - (data [text] - text/format)) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host ["_" php #+ Var]))) - [//] - (// [".T" runtime])) - -(template [<register> <prefix>] - [(def: #export <register> - (-> Register Var) - (|>> (:coerce Int) %i (format <prefix>) _.var))] - - [closure "c"] - [variable "v"]) - -(def: #export (local var) - (-> Variable Var) - (if (variableL.captured? var) - (closure (variableL.captured-register var)) - (variable (:coerce Nat var)))) - -(def: #export global - (-> Name Var) - (|>> //.definition-name _.var)) - -(template [<name> <input> <converter>] - [(def: #export <name> - (-> <input> (Meta Var)) - (|>> <converter> (:: macro.Monad<Meta> wrap)))] - - [translate-variable Variable local] - [translate-definition Name global] - ) diff --git a/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux deleted file mode 100644 index 7c4d9f444..000000000 --- a/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux +++ /dev/null @@ -1,330 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad<Parser>] - [monad #+ do]) - (data text/format - (coll [list "list/" Monad<List>])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [io #+ Process]) - [//] - (luxc [lang] - (lang (host ["_" php #+ Expression Computation Statement])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Computation (_.string //.unit)) - -(def: (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.null)) - -(def: (variant' tag last? value) - (-> 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 Bit Expression Computation) - (variant' (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Computation - (variant +0 #0 unit)) - -(def: #export some - (-> Expression Computation) - (variant +1 #1)) - -(def: #export left - (-> Expression Computation) - (variant +0 #0)) - -(def: #export right - (-> Expression Computation) - (variant +1 #1)) - -(type: Runtime Statement) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.seq s.local-identifier (p/wrap (list))) - (s.form (p.seq s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format "__" prefix "__" (lang.normalize-name name)) - @runtime (` (_.global (~ (code.text runtime)))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> lang.normalize-name code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier 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-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (lang.normalize-name var)))))))) - list/join))] - (~ body)))))) - -## (runtime: (lux//try op) -## (let [$error (_.var "error") -## $value (_.var "value")] -## (_.try! ($_ _.then! -## (_.set! (list $value) (_.apply (list unit) op)) -## (_.return! (right (@@ $value)))) -## (list [(list "Exception") $error -## (_.return! (left (_.apply (list (@@ $error)) (_.global "str"))))])))) - -## (runtime: (lux//program-args program-args) -## (let [$inputs (_.var "inputs") -## $value (_.var "value")] -## ($_ _.then! -## (_.set! (list $inputs) none) -## (<| (_.for-in! $value program-args) -## (_.set! (list $inputs) -## (some (_.tuple (list (@@ $value) (@@ $inputs)))))) -## (_.return! (@@ $inputs))))) - -## (def: runtime//lux -## Runtime -## ($_ _.then! -## @@lux//try -## @@lux//program-args)) - -## (runtime: (io//log! message) -## ($_ _.then! -## (_.print! message) -## (_.return! ..unit))) - -## (def: (exception message) -## (-> Expression Computation) -## (_.apply (list message) (_.global "Exception"))) - -## (runtime: (io//throw! message) -## ($_ _.then! -## (_.raise! (exception message)) -## (_.return! ..unit))) - -## (runtime: (io//exit! code) -## ($_ _.then! -## (_.import! "sys") -## (_.do! (|> (_.global "sys") (_.send (list code) "exit"))) -## (_.return! ..unit))) - -## (runtime: (io//current-time! _) -## ($_ _.then! -## (_.import! "time") -## (_.return! (let [time (|> (_.global "time") -## (_.send (list) "time") -## (_.* (_.int 1,000)))] -## (_.apply (list time) (_.global "int")))))) - -## (def: runtime//io -## Runtime -## ($_ _.then! -## @@io//log! -## @@io//throw! -## @@io//exit! -## @@io//current-time!)) - -(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))) - -## (runtime: (bit//logical-right-shift param subject) -## (let [mask (|> (_.int 1) -## (_.bit-shl (_.- param (_.int 64))) -## (_.- (_.int 1)))] -## (_.return! (|> subject -## (_.bit-shr param) -## (_.bit-and mask))))) - -## (def: runtime//bit -## Runtime -## ($_ _.then! -## @@bit//logical-right-shift)) - -## (runtime: (text//index subject param start) -## (with-vars [idx] -## ($_ _.then! -## (_.set! (list idx) (_.send (list param start) "find" subject)) -## (_.if! (_.= (_.int -1) (@@ idx)) -## (_.return! ..none) -## (_.return! (..some (@@ idx))))))) - -## (def: inc (|>> (_.+ (_.int 1)))) - -## (template [<name> <top-cmp>] -## [(def: (<name> top value) -## (-> Expression Expression Expression) -## (_.and (|> value (_.>= (_.int 0))) -## (|> value (<top-cmp> top))))] - -## [within? _.<] -## [up-to? _.<=] -## ) - -## (runtime: (text//clip @text @from @to) -## (with-vars [length] -## ($_ _.then! -## (_.set! (list length) (_.count/1 @text)) -## (_.if! ($_ _.and -## (|> @to (within? (@@ length))) -## (|> @from (up-to? @to))) -## (_.return! (..some (|> @text (_.slice @from (inc @to))))) -## (_.return! ..none))))) - -## (runtime: (text//char text idx) -## (_.if! (|> idx (within? (_.count/1 text))) -## (_.return! (..some (_.apply (list (|> text (_.slice idx (inc idx)))) -## (_.global "ord")))) -## (_.return! ..none))) - -## (def: runtime//text -## Runtime -## ($_ _.then! -## @@text//index -## @@text//clip -## @@text//char)) - -## (def: (check-index-out-of-bounds array idx body!) -## (-> Expression Expression Statement Statement) -## (_.if! (|> idx (_.<= (_.count/1 array))) -## body! -## (_.raise! (exception (_.string "Array index out of bounds!"))))) - -## (runtime: (array//get array idx) -## (with-vars [temp] -## (<| (check-index-out-of-bounds array idx) -## ($_ _.then! -## (_.set! (list temp) (_.nth idx array)) -## (_.if! (_.= _.null (@@ temp)) -## (_.return! ..none) -## (_.return! (..some (@@ temp)))))))) - -## (runtime: (array//put array idx value) -## (<| (check-index-out-of-bounds array idx) -## ($_ _.then! -## (_.set-nth! idx value array) -## (_.return! array)))) - -## (def: runtime//array -## Runtime -## ($_ _.then! -## @@array//get -## @@array//put)) - -(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 - (|> check-necessary-conditions! - ## runtime//lux - (_.then! runtime//adt) - ## runtime//bit - ## runtime//text - ## runtime//array - ## runtime//io - )) - -(def: #export artifact Text (format prefix //.extension)) - -(def: #export translate - (Meta (Process Any)) - (do macro.Monad<Meta> - [_ //.init-module-buffer - _ (//.save runtime)] - (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux deleted file mode 100644 index 7c2482af6..000000000 --- a/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - [macro] - (data text/format)) - (luxc (lang [".L" module] - (host ["_" php #+ Expression Statement]))) - [//] - (// [".T" runtime] - [".T" reference] - [".T" eval])) - -(def: #export (translate-def name expressionT expressionO metaV) - (-> Text Type Expression Code (Meta Any)) - (do macro.Monad<Meta> - [current-module macro.current-module-name - #let [def-name [current-module name]]] - (case (macro.get-identifier-ann (name-of #.alias) metaV) - (#.Some real-def) - (do @ - [[realT realA realV] (macro.find-def real-def) - _ (moduleL.define def-name [realT metaV realV])] - (wrap [])) - - _ - (do @ - [#let [def-name (referenceT.global def-name)] - _ (//.save (_.set! def-name expressionO)) - expressionV (evalT.eval def-name) - _ (moduleL.define def-name [expressionT metaV expressionV]) - _ (if (macro.type? metaV) - (case (macro.declared-tags metaV) - #.Nil - (wrap []) - - tags - (moduleL.declare-tags tags (macro.export? metaV) (:coerce Type expressionV))) - (wrap [])) - #let [_ (log! (format "DEF " (%name def-name)))]] - (wrap [])) - ))) - -(def: #export (translate-program programO) - (-> Expression (Meta Statement)) - (macro.fail "translate-program NOT IMPLEMENTED YET") - ## (hostT.save (format "var " (referenceT.variable +0) " = " runtimeT.lux//program-args "();" - ## "(" programO ")(null);")) - ) diff --git a/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux deleted file mode 100644 index 229b0e31d..000000000 --- a/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format) - [macro]) - (luxc ["&" lang] - (lang [synthesis #+ Synthesis] - (host ["_" php #+ Expression Computation]))) - [//] - (// [".T" runtime])) - -(def: #export (translate-tuple translate elemsS+) - (-> //.Translator (List Synthesis) (Meta Expression)) - (case elemsS+ - #.Nil - (:: macro.Monad<Meta> wrap runtimeT.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do macro.Monad<Meta> - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (_.array/* elemsT+))))) - -(def: #export (translate-variant translate tag tail? valueS) - (-> //.Translator Nat Bit Synthesis (Meta Computation)) - (do macro.Monad<Meta> - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) |