aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation
diff options
context:
space:
mode:
authorEduardo Julian2018-04-27 19:46:44 -0400
committerEduardo Julian2018-04-27 19:46:44 -0400
commitf8d6348b3fec0c55768ebcd8dba446949b8a4ef7 (patch)
tree26aa0a2cc6309cfc6cba5b23d6a68f68934e40a4 /new-luxc/source/luxc/lang/translation
parentfac2fa47c11db08596c890290bae09bf57a27089 (diff)
- WIP: - Initial PHP back-end implementation.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux58
-rw-r--r--new-luxc/source/luxc/lang/translation/php.lux214
-rw-r--r--new-luxc/source/luxc/lang/translation/php/eval.jvm.lux147
-rw-r--r--new-luxc/source/luxc/lang/translation/php/expression.jvm.lux82
-rw-r--r--new-luxc/source/luxc/lang/translation/php/function.jvm.lux81
-rw-r--r--new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux20
-rw-r--r--new-luxc/source/luxc/lang/translation/php/reference.jvm.lux37
-rw-r--r--new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux447
-rw-r--r--new-luxc/source/luxc/lang/translation/php/statement.jvm.lux48
-rw-r--r--new-luxc/source/luxc/lang/translation/php/structure.jvm.lux31
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))))