diff options
Diffstat (limited to '')
10 files changed, 1136 insertions, 29 deletions
diff --git a/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux index 8be5667e9..cc267e7d5 100644 --- a/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux @@ -75,35 +75,35 @@ (def: (lux-object host-object) (-> Object (Error Top)) - (`` (cond (host.null? host-object) - (ex.throw Null-Has-No-Lux-Representation "") - - (or (host.instance? java/lang/Boolean host-object) - (host.instance? java/lang/Long host-object) - (host.instance? java/lang/Double host-object) - (host.instance? java/lang/String host-object)) - (ex.return host-object) - - (host.instance? ByteString host-object) - (ex.return (ByteString::decode [] (:! ByteString host-object))) - - (host.instance? DefaultTable host-object) - (let [host-object (:! DefaultTable host-object)] - (case (variant lux-object host-object) - (#.Some value) - (ex.return value) - - #.None - (case (array lux-object host-object) - (#.Some value) - (ex.return value) - - #.None - (ex.throw Unknown-Kind-Of-Host-Object (format "SECOND " (Object::toString [] (:! Object host-object))))))) - - ## else - (ex.throw Unknown-Kind-Of-Host-Object (format "FIRST " (Object::toString [] (:! Object host-object)))) - ))) + (cond (host.null? host-object) + (ex.throw Null-Has-No-Lux-Representation "") + + (or (host.instance? java/lang/Boolean host-object) + (host.instance? java/lang/Long host-object) + (host.instance? java/lang/Double host-object) + (host.instance? java/lang/String host-object)) + (ex.return host-object) + + (host.instance? ByteString host-object) + (ex.return (ByteString::decode [] (:! ByteString host-object))) + + (host.instance? DefaultTable host-object) + (let [host-object (:! DefaultTable host-object)] + (case (variant lux-object host-object) + (#.Some value) + (ex.return value) + + #.None + (case (array lux-object host-object) + (#.Some value) + (ex.return value) + + #.None + (ex.throw Unknown-Kind-Of-Host-Object (format "SECOND " (Object::toString [] (:! Object host-object))))))) + + ## else + (ex.throw Unknown-Kind-Of-Host-Object (format "FIRST " (Object::toString [] (:! Object host-object)))) + )) (def: #export (eval code) (-> Expression (Meta Top)) diff --git a/new-luxc/source/luxc/lang/translation/php.lux b/new-luxc/source/luxc/lang/translation/php.lux new file mode 100644 index 000000000..4cfcaaa0f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php.lux @@ -0,0 +1,214 @@ +(.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])) + +(do-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 javax/script/ScriptEngineManager + (new []) + (getEngineByName [String] ScriptEngine)) + +(type: #export Anchor [Text Register]) + +(type: #export Host + {#context [Text Nat] + #anchor (Maybe Anchor) + #loader (-> Statement (Error Unit)) + #interpreter (-> Expression (Error Object)) + #module-buffer (Maybe StringBuilder) + #program-buffer StringBuilder}) + +(def: #export init + (IO Host) + (io (let [interpreter (|> (ScriptEngineManager::new []) + (ScriptEngineManager::getEngineByName ["jphp"]))] + {#context ["" +0] + #anchor #.None + #loader (function (_ code) + (do e.Monad<Error> + [_ (ScriptEngine::eval [(format "<?php " (_.statement code))] interpreter)] + (wrap []))) + #interpreter (function (_ code) + (ScriptEngine::eval [(format "<?php " (_.statement (_.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 Unit) + (function (_ compiler) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #module-buffer (#.Some (StringBuilder::new []))) + (:! Void)) + compiler) + []]))) + +(def: #export (with-sub-context expr) + (All [a] (-> (Meta a) (Meta [Text a]))) + (function (_ compiler) + (let [old (:! Host (get@ #.host compiler)) + [old-name old-sub] (get@ #context old) + new-name (format old-name "___" (%i (nat-to-int old-sub)))] + (case (expr (set@ #.host + (:! Void (set@ #context [new-name +0] old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #context [old-name (n/inc old-sub)]) + (:! Void)) + compiler') + [new-name output]]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export context + (Meta Text) + (function (_ compiler) + (#e.Success [compiler + (|> (get@ #.host compiler) + (:! Host) + (get@ #context) + (let> [name sub] + name))]))) + +(def: #export (with-anchor anchor expr) + (All [a] (-> Anchor (Meta a) (Meta a))) + (function (_ compiler) + (let [old (:! Host (get@ #.host compiler))] + (case (expr (set@ #.host + (:! Void (set@ #anchor (#.Some anchor) old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #anchor (get@ #anchor old)) + (:! Void)) + compiler') + output]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export anchor + (Meta Anchor) + (function (_ compiler) + (case (|> compiler (get@ #.host) (:! 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) (:! 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) (:! Host) (get@ #program-buffer))]))) + +(do-template [<name> <field> <inputT> <outputT>] + [(def: (<name> code) + (-> <inputT> (Meta <outputT>)) + (function (_ compiler) + (let [runner (|> compiler (get@ #.host) (:! Host) (get@ <field>))] + (case (runner code) + (#e.Error error) + (exec (log! (:! Text code)) + ((lang.throw Cannot-Execute error) compiler)) + + (#e.Success output) + (#e.Success [compiler output])))))] + + [load! #loader Statement Unit] + [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]) + (-> Ident Text) + (lang.normalize-name (format module "$" name))) + +(def: #export (save code) + (-> Statement (Meta Unit)) + (do macro.Monad<Meta> + [module-buffer module-buffer + #let [_ (Appendable::append [(:! CharSequence (_.statement code))] + module-buffer)]] + (load! code))) + +(def: #export (save-module! target) + (-> File (Meta (Process Unit))) + (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 [(:! 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/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux new file mode 100644 index 000000000..ba9220f57 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux @@ -0,0 +1,147 @@ +(.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]))) + [//]) + +(do-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 (:! Text (Object::toString [] (Object::getClass [] (:! Object host-object)))) + text-representation (:! Text (Object::toString [] (:! 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 Top)) ArrayMemory (Error Top)) + (let [size (ArrayMemory::size [] host-object)] + (loop [idx 0 + output (: (Array Top) (array.new (:! Nat size)))] + (if (i/< size idx) + (let [value (|> host-object + (ArrayMemory::get [(LongMemory::new [idx])]) + (:! ReferenceMemory) (ReferenceMemory::getValue []))] + (if (host.instance? php/runtime/memory/NullMemory value) + (recur (i/inc idx) + (array.write (:! Nat idx) (host.null) output)) + (do e.Monad<Error> + [lux-value (lux-object value)] + (recur (i/inc idx) + (array.write (:! Nat idx) lux-value output))))) + (ex.return output))))) + +(def: (variant lux-object host-object) + (-> (-> Object (Error Top)) ArrayMemory (Error Top)) + (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 (: Top + [(Long::intValue [] (:! Long variant-tag)) + (: Top + (if (|> host-object + (ArrayMemory::get [(StringMemory::new [//.variant-flag-field])]) + (:! ReferenceMemory) + (ReferenceMemory::getValue []) + (host.instance? php/runtime/memory/NullMemory)) + (host.null) + "")) + variant-value])))) + +(def: (lux-object host-object) + (-> Object (Error Top)) + (cond (host.instance? php/runtime/memory/FalseMemory host-object) + (ex.return false) + + (host.instance? php/runtime/memory/TrueMemory host-object) + (ex.return true) + + (host.instance? php/runtime/memory/LongMemory host-object) + (ex.return (LongMemory::toLong [] (:! LongMemory host-object))) + + (host.instance? php/runtime/memory/DoubleMemory host-object) + (ex.return (DoubleMemory::toDouble [] (:! DoubleMemory host-object))) + + (host.instance? php/runtime/memory/StringMemory host-object) + (ex.return (StringMemory::toString [] (:! StringMemory host-object))) + + (host.instance? php/runtime/memory/ReferenceMemory host-object) + (lux-object (ReferenceMemory::getValue [] (:! ReferenceMemory host-object))) + + (host.instance? php/runtime/memory/ArrayMemory host-object) + (if (ArrayMemory::isMap [] (:! ArrayMemory host-object)) + (variant lux-object (:! ArrayMemory host-object)) + (tuple lux-object (:! ArrayMemory host-object))) + + ## else + (ex.throw Unknown-Kind-Of-Host-Object host-object))) + +(def: #export (eval code) + (-> Expression (Meta Top)) + (function (_ compiler) + (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)) + + (#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.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (_.expression code) "\n" + 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 new file mode 100644 index 000000000..abcc22187 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux @@ -0,0 +1,82 @@ +(.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] + )) + +(do-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>)) + ([#.Bool primitiveT.translate-bool] + [#.Nat (<| primitiveT.translate-int (:! Int))] + [#.Int primitiveT.translate-int] + [#.Deg (<| primitiveT.translate-int (:! Int))] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) + + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (structureT.translate-variant translate tag last? valueS) + + (^code [(~+ members)]) + (structureT.translate-tuple translate members) + + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (referenceT.translate-variable var) + + [_ (#.Symbol 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 new file mode 100644 index 000000000..7d0baa4d5 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/function.jvm.lux @@ -0,0 +1,81 @@ +(.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 GExpression CExpression Statement]))) + [//] + (// [".T" reference])) + +(def: #export (translate-apply translate functionS argsS+) + (-> //.Translator Synthesis (List Synthesis) (Meta CExpression)) + (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 (n/inc register)) + (_.nth (|> register nat-to-int _.int) + @curried))) + +(def: (with-closure @function inits function-definition!) + (-> GExpression (List Expression) Statement (Meta Expression)) + (case inits + #.Nil + (do macro.Monad<Meta> + [_ (//.save function-definition!)] + (wrap @function)) + + _ + (do macro.Monad<Meta> + [] + (wrap (_.apply inits + (_.function (|> (list.enumerate inits) + (list/map (|>> product.left referenceT.closure))) + (|> function-definition! + (_.then! (_.return! @function))))))))) + +(def: #export (translate-function translate env arity bodyS) + (-> //.Translator (List Variable) Arity Synthesis (Meta Expression)) + (do macro.Monad<Meta> + [[function-name bodyO] (//.with-sub-context + (do @ + [function-name //.context] + (//.with-anchor [function-name +1] + (translate bodyS)))) + closureO+ (monad.map @ referenceT.translate-variable env) + #let [@function (_.global 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))))))))))))))))) diff --git a/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux new file mode 100644 index 000000000..61570143b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux @@ -0,0 +1,20 @@ +(.module: + lux + (lux [macro "meta/" Monad<Meta>]) + (luxc (lang (host ["_" php #+ CExpression])))) + +(def: #export translate-bool + (-> Bool (Meta CExpression)) + (|>> _.bool meta/wrap)) + +(def: #export translate-int + (-> Int (Meta CExpression)) + (|>> _.int meta/wrap)) + +(def: #export translate-frac + (-> Frac (Meta CExpression)) + (|>> _.float meta/wrap)) + +(def: #export translate-text + (-> Text (Meta CExpression)) + (|>> _.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux new file mode 100644 index 000000000..280710afc --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux @@ -0,0 +1,37 @@ +(.module: + lux + (lux [macro] + (data [text] + text/format)) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + (host ["_" php #+ VExpression]))) + [//] + (// [".T" runtime])) + +(do-template [<register> <prefix>] + [(def: #export <register> + (-> Register VExpression) + (|>> (:! Int) %i (format <prefix>) _.var))] + + [closure "c"] + [variable "v"]) + +(def: #export (local var) + (-> Variable VExpression) + (if (variableL.captured? var) + (closure (variableL.captured-register var)) + (variable (:! Nat var)))) + +(def: #export global + (-> Ident VExpression) + (|>> //.definition-name _.var)) + +(do-template [<name> <input> <converter>] + [(def: #export <name> + (-> <input> (Meta VExpression)) + (|>> <converter> (:: macro.Monad<Meta> wrap)))] + + [translate-variable Variable local] + [translate-definition Ident 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 new file mode 100644 index 000000000..d2f5cd2a2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux @@ -0,0 +1,447 @@ +(.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 CExpression Statement])))) + +(def: prefix Text "LuxRuntime") + +(def: #export unit CExpression (_.string //.unit)) + +(def: (flag value) + (-> Bool CExpression) + (if value + (_.string "") + _.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression CExpression) + (_.array/** (list [(_.string //.variant-tag-field) tag] + [(_.string //.variant-flag-field) last?] + [(_.string //.variant-value-field) value]))) + +(def: #export (variant tag last? value) + (-> Nat Bool Expression CExpression) + (variant' (_.int (nat-to-int tag)) + (flag last?) + value)) + +(def: #export none + CExpression + (variant +0 false unit)) + +(def: #export some + (-> Expression CExpression) + (variant +1 true)) + +(def: #export left + (-> Expression CExpression) + (variant +0 false)) + +(def: #export right + (-> Expression CExpression) + (variant +1 true)) + +(type: Runtime Statement) + +## (def: declaration +## (s.Syntax [Text (List Text)]) +## (p.either (p.seq s.local-symbol (p/wrap (list))) +## (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +## (syntax: (runtime: [[name args] declaration] +## definition) +## (let [implementation (code.local-symbol (format "@@" name)) +## runtime (format "__" prefix "__" (lang.normalize-name name)) +## $runtime (` (_.var (~ (code.text runtime)))) +## @runtime (` (@@ (~ $runtime))) +## argsC+ (list/map code.local-symbol args) +## argsLC+ (list/map (|>> lang.normalize-name code.text (~) (_.var) (`)) +## args) +## declaration (` ((~ (code.local-symbol name)) +## (~+ argsC+))) +## type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) +## _.CExpression))] +## (wrap (list (` (def: (~' #export) (~ declaration) +## (~ type) +## (_.apply (list (~+ argsC+)) (~ @runtime)))) +## (` (def: (~ implementation) +## _.Statement +## (~ (case argsC+ +## #.Nil +## (` (_.set! (list (~ $runtime)) (~ definition))) + +## _ +## (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) +## (list/map (function (_ [left right]) +## (list left (` (@@ (~ right)))))) +## list/join))] +## (_.def! (~ $runtime) +## (list (~+ argsLC+)) +## (~ definition)))))))))))) + +## (syntax: (with-vars [vars (s.tuple (p.many s.local-symbol))] +## body) +## (wrap (list (` (let [(~+ (|> vars +## (list/map (function (_ var) +## (list (code.local-symbol var) +## (` (_.var (~ (code.text (lang.normalize-name var)))))))) +## list/join))] +## (~ body)))))) + +## (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 CExpression) +## (_.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")] +## ($_ _.then! +## (_.set! (list $index_min_length) (_.+ (_.int 1) index)) +## (_.if! (_.> (@@ $index_min_length) (_.length product)) +## ## No need for recursion +## (_.return! (_.nth index product)) +## ## Needs recursion +## (_.return! (product//left (_.nth (_.- (_.int 1) +## (_.length product)) +## product) +## (_.- (_.length product) +## (@@ $index_min_length)))))))) + +## (runtime: (product//right product index) +## (let [$index_min_length (_.var "index_min_length")] +## ($_ _.then! +## (_.set! (list $index_min_length) (_.+ (_.int 1) index)) +## (_.cond! (list [(_.= (@@ $index_min_length) (_.length product)) +## ## Last element. +## (_.return! (_.nth index product))] +## [(_.< (@@ $index_min_length) (_.length product)) +## ## Needs recursion +## (_.return! (product//right (_.nth (_.- (_.int 1) +## (_.length product)) +## product) +## (_.- (_.length product) +## (@@ $index_min_length))))]) +## ## Must slice +## (_.return! (_.slice-from index product)))))) + +## (runtime: (sum//get sum wantedTag wantsLast) +## (let [no-match! (_.return! _.none) +## sum-tag (_.nth (_.string //.variant-tag-field) sum) +## sum-flag (_.nth (_.string //.variant-flag-field) sum) +## sum-value (_.nth (_.string //.variant-value-field) sum) +## is-last? (_.= (_.string "") sum-flag) +## test-recursion! (_.if! is-last? +## ## Must recurse. +## (_.return! (sum//get sum-value (_.- sum-tag wantedTag) wantsLast)) +## no-match!)] +## (_.cond! (list [(_.= sum-tag wantedTag) +## (_.if! (_.= wantsLast sum-flag) +## (_.return! sum-value) +## test-recursion!)] + +## [(_.> sum-tag wantedTag) +## test-recursion!] + +## [(_.and (_.< sum-tag wantedTag) +## (_.= (_.string "") wantsLast)) +## (_.return! (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) + +## no-match!))) + +## (def: runtime//adt +## Runtime +## ($_ _.then! +## @@product//left +## @@product//right +## @@sum//get)) + +## (def: full-32-bits (_.code "0xFFFFFFFF")) + +## (runtime: (bit//32 input) +## (with-vars [capped] +## (_.cond! (list [(|> input (_.> full-32-bits)) +## (_.return! (|> input (_.bit-and full-32-bits) bit//32))] +## [(|> input (_.> (_.code "0x7FFFFFFF"))) +## ($_ _.then! +## (_.set! (list capped) +## (_.apply (list (|> (_.code "0x100000000") +## (_.- input))) +## (_.global "int"))) +## (_.if! (|> (@@ capped) (_.<= (_.int 2147483647))) +## (_.return! (|> (@@ capped) (_.* (_.int -1)))) +## (_.return! (_.int -2147483648))))]) +## (_.return! input)))) + +## (def: full-64-bits (_.code "0xFFFFFFFFFFFFFFFF")) + +## (runtime: (bit//64 input) +## (with-vars [capped] +## (_.cond! (list [(|> input (_.> full-64-bits)) +## (_.return! (|> input (_.bit-and full-64-bits) bit//64))] +## [(|> input (_.> (_.code "0x7FFFFFFFFFFFFFFF"))) +## ($_ _.then! +## (_.set! (list capped) +## (_.apply (list (|> (_.code "0x10000000000000000") +## (_.- input))) +## (_.global "int"))) +## (_.if! (|> (@@ capped) (_.<= (_.code "9223372036854775807L"))) +## (_.return! (|> (@@ capped) (_.* (_.int -1)))) +## (_.return! (_.code "-9223372036854775808L"))))]) +## (_.return! input)))) + +## (runtime: (bit//shift-right 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//32 +## @@bit//64 +## @@bit//shift-right)) + +## (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)))) + +## (do-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) (_.length @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? (_.length 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 (_.<= (_.length 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! (_.= _.none (@@ 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: #export atom//field Text "_lux_atom") + +## (runtime: (atom//compare-and-swap atom old new) +## (let [atom//field (_.string atom//field)] +## (_.if! (_.= old (_.nth atom//field atom)) +## ($_ _.then! +## (_.set-nth! atom//field new atom) +## (_.return! (_.bool true))) +## (_.return! (_.bool false))))) + +## (def: runtime//atom +## Runtime +## ($_ _.then! +## @@atom//compare-and-swap)) + +## (runtime: (box//write value box) +## ($_ _.then! +## (_.set-nth! (_.int 0) value box) +## (_.return! ..unit))) + +## (def: runtime//box +## Runtime +## ($_ _.then! +## @@box//write)) + +## (runtime: (process//future procedure) +## ($_ _.then! +## (_.import! "threading") +## (let [params (_.dict (list [(_.string "target") procedure]))] +## (_.do! (|> (_.global "threading") +## (_.send-keyword (list) params "Thread") +## (_.send (list) "start")))) +## (_.return! ..unit))) + +## (runtime: (process//schedule milli-seconds procedure) +## ($_ _.then! +## (_.import! "threading") +## (let [seconds (|> milli-seconds (_./ (_.float 1_000.0)))] +## (_.do! (|> (_.global "threading") +## (_.send (list seconds procedure) "Timer") +## (_.send (list) "start")))) +## (_.return! ..unit))) + +## (def: runtime//process +## Runtime +## ($_ _.then! +## @@process//future +## @@process//schedule)) + +## (do-template [<name> <method>] +## [(runtime: (<name> input) +## ($_ _.then! +## (_.import! "math") +## (_.return! (|> (_.global "math") (_.send (list input) <method>)))))] + +## [math//cos "cos"] +## [math//sin "sin"] +## [math//tan "tan"] +## [math//acos "acos"] +## [math//asin "asin"] +## [math//atan "atan"] +## [math//exp "exp"] +## [math//log "log"] +## [math//ceil "ceil"] +## [math//floor "floor"] +## ) + +## (def: runtime//math +## Runtime +## ($_ _.then! +## @@math//cos +## @@math//sin +## @@math//tan +## @@math//acos +## @@math//asin +## @@math//atan +## @@math//exp +## @@math//log +## @@math//ceil +## @@math//floor)) + +(def: runtime + Runtime + (_.echo! (_.string "Hello, world!")) + ## ($_ _.then! + ## runtime//lux + ## runtime//adt + ## runtime//bit + ## runtime//text + ## runtime//array + ## runtime//atom + ## runtime//box + ## runtime//io + ## runtime//process + ## runtime//math + ## ) + ) + +(def: #export artifact Text (format prefix //.extension)) + +(def: #export translate + (Meta (Process Unit)) + (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 new file mode 100644 index 000000000..592e579cf --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux @@ -0,0 +1,48 @@ +(.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 Unit)) + (do macro.Monad<Meta> + [current-module macro.current-module-name + #let [def-ident [current-module name]]] + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) + (do @ + [[realT realA realV] (macro.find-def real-def) + _ (moduleL.define def-ident [realT metaV realV])] + (wrap [])) + + _ + (do @ + [#let [def-name (referenceT.global def-ident)] + _ (//.save (_.set! def-name expressionO)) + expressionV (evalT.eval def-name) + _ (moduleL.define def-ident [expressionT metaV expressionV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil + (wrap []) + + tags + (moduleL.declare-tags tags (macro.export? metaV) (:! Type expressionV))) + (wrap [])) + #let [_ (log! (format "DEF " (%ident def-ident)))]] + (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 new file mode 100644 index 000000000..6e44f3973 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format) + [macro]) + (luxc ["&" lang] + (lang [synthesis #+ Synthesis] + (host ["_" php #+ Expression CExpression]))) + [//] + (// [".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 Bool Synthesis (Meta CExpression)) + (do macro.Monad<Meta> + [valueT (translate valueS)] + (wrap (runtimeT.variant tag tail? valueT)))) |