diff options
43 files changed, 1975 insertions, 2108 deletions
diff --git a/.gitignore b/.gitignore index 8e75a4c6f..e83967470 100644 --- a/.gitignore +++ b/.gitignore @@ -40,3 +40,8 @@ pom.xml.asc /lux-ruby/source/lux /lux-ruby/source/program +/lux-php/target +/lux-php/source/lux.lux +/lux-php/source/lux +/lux-php/source/program + @@ -75,6 +75,16 @@ cd ~/lux/lux-python/ && lein clean # Try cd ~/lux/lux-ruby/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +# PHP compiler + # Test + cd ~/lux/lux-php/ && lein_2_7_1 lux auto test + cd ~/lux/lux-php/ && lein clean && lein_2_7_1 lux auto test + # Build + cd ~/lux/lux-php/ && lein_2_7_1 lux auto build + cd ~/lux/lux-php/ && lein clean && lein_2_7_1 lux auto build + # Try + cd ~/lux/lux-php/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux + # Run compiler test suite cd ~/lux/new-luxc/ && lein_2_7_1 lux auto test cd ~/lux/new-luxc/ && lein clean && lein_2_7_1 lux auto test diff --git a/lux-lua/project.clj b/lux-lua/project.clj index 62abfb470..a97f77bd9 100644 --- a/lux-lua/project.clj +++ b/lux-lua/project.clj @@ -3,7 +3,7 @@ (def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") (def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") -(defproject com.github.luxlang/lux-python #=(identity version) +(defproject com.github.luxlang/lux-lua #=(identity version) :description "A Lua compiler for Lux." :url ~repo :license {:name "Lux License v0.1" diff --git a/lux-php/project.clj b/lux-php/project.clj new file mode 100644 index 000000000..8dfe91d27 --- /dev/null +++ b/lux-php/project.clj @@ -0,0 +1,33 @@ +(def version "0.6.0-SNAPSHOT") +(def repo "https://github.com/LuxLang/lux") +(def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") +(def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") + +(defproject com.github.luxlang/lux-php #=(identity version) + :description "A Ruby compiler for Lux." + :url ~repo + :license {:name "Lux License v0.1" + :url ~(str repo "/blob/master/license.txt")} + :scm {:name "git" + :url ~(str repo ".git")} + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + + :repositories [["releases" ~sonatype-releases] + ["snapshots" ~sonatype-snapshots] + ["jitpack" "https://jitpack.io"]] + :deploy-repositories [["releases" {:url ~sonatype-releases :creds :gpg}] + ["snapshots" {:url ~sonatype-snapshots :creds :gpg}]] + + :plugins [[com.github.luxlang/lein-luxc ~version]] + :dependencies [[com.github.luxlang/luxc-jvm ~version] + [com.github.luxlang/stdlib ~version] + ;; PHP 5 + [org.develnext.jphp/jphp-core "0.9.2"] + [org.develnext.jphp/jphp-scripting "0.9.2"]] + + :manifest {"lux" ~version} + :source-paths ["source"] + :lux {:program "program"} + ) diff --git a/lux-php/source/program.lux b/lux-php/source/program.lux new file mode 100644 index 000000000..f3f445bd9 --- /dev/null +++ b/lux-php/source/program.lux @@ -0,0 +1,460 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + pipe + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + ["p" parser + [cli (#+ program:)]]] + [data + ["." maybe] + ["." error (#+ Error)] + [number + ["." i64]] + ["." text ("#@." hash) + format] + [collection + ["." array (#+ Array)] + ["." list ("#@." functor)]]] + [macro + ["." template]] + [world + ["." file]] + ["." host (#+ import: interface: do-to object) + ["_" php]] + [tool + [compiler + ["." name] + ["." synthesis] + [phase + [macro (#+ Expander)] + ["." generation + ["." php + ["." runtime] + ["." extension]]]] + [default + ["." platform (#+ Platform)]]]] + ["." debug]] + [program + ["/" compositor + ["/." cli]]]) + +(import: #long java/lang/String) + +(import: #long (java/lang/Class a)) + +(import: #long java/lang/Object + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/Integer) + +(import: #long java/lang/Long + (intValue [] java/lang/Integer)) + +(import: #long php/runtime/Memory) + +(import: #long php/runtime/Memory$Type + (#enum ARRAY)) + +(import: #long php/runtime/memory/NullMemory) + +(import: #long php/runtime/memory/FalseMemory) +(import: #long php/runtime/memory/TrueMemory) + +(import: #long php/runtime/memory/LongMemory + (new [long]) + (toLong [] long)) + +(import: #long php/runtime/memory/DoubleMemory + (toDouble [] double)) + +(import: #long php/runtime/memory/StringMemory + (new [java/lang/String]) + (toString [] java/lang/String)) + +(import: #long php/runtime/memory/ReferenceMemory + (getValue [] php/runtime/Memory)) + +(import: #long php/runtime/memory/ArrayMemory + (new [(Array java/lang/Object)]) + (size [] int) + (isMap [] boolean) + (get [php/runtime/Memory] php/runtime/Memory)) + +(import: #long php/runtime/lang/IObject) + +(import: #long php/runtime/memory/ObjectMemory + (value php/runtime/lang/IObject)) + +(import: #long php/runtime/env/Environment + (#static current [] php/runtime/env/Environment)) + +(import: #long php/runtime/env/TraceInfo + (new [java/lang/String int int])) + +(import: #long php/runtime/reflection/FunctionEntity) + +(import: #long php/runtime/invoke/InvokeHelper + (#static callAny [php/runtime/Memory (Array php/runtime/Memory) php/runtime/env/Environment php/runtime/env/TraceInfo] + #try php/runtime/Memory)) + +(import: #long php/runtime/lang/Closure + (call [php/runtime/env/Environment (Array php/runtime/Memory)] #try php/runtime/Memory)) + +(template [<name>] + [(interface: <name> + (getValue [] java/lang/Object)) + + (`` (import: (~~ (template.identifier ["program/" <name>])) + (getValue [] java/lang/Object)))] + + [StructureValue] + ) + +(type: Reader + (-> java/lang/Object (Error Any))) + +(exception: (unknown-kind-of-object {object java/lang/Object}) + (exception.report + ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] + ["Object" (java/lang/Object::toString object)])) + +(def: (lux-structure value) + (-> (Array java/lang/Object) + ## php/runtime/memory/ArrayMemory + php/runtime/Memory) + (`` (object [] php/runtime/Memory ## php/runtime/memory/ArrayMemory + [program/StructureValue] + [{php/runtime/Memory$Type php/runtime/Memory$Type::ARRAY}] + ## Methods + (program/StructureValue + (getValue) + java/lang/Object + (:assume value)) + + ## (php/runtime/memory/ArrayMemory + ## (size) + ## int + ## (exec + ## (log! "{lux-structure#size}") + ## (:assume (array.size value)))) + + ## (php/runtime/memory/ArrayMemory + ## (get {key php/runtime/Memory}) + ## php/runtime/Memory + ## (exec + ## (log! (format "{lux-structure#get}" text.new-line + ## (exception.construct unknown-kind-of-object key))) + ## (error! "OOPS!"))) + + ## (php/runtime/memory/ArrayMemory + ## (getOrCreate {key php/runtime/Memory}) + ## php/runtime/memory/ReferenceMemory + ## (exec + ## (log! (format "{lux-structure#getOrCreate}" text.new-line + ## (exception.construct unknown-kind-of-object key))) + ## (error! "OOPS!"))) + + ## (php/runtime/memory/ArrayMemory + ## (getOrCreateAsShortcut {key php/runtime/Memory}) + ## php/runtime/memory/ReferenceMemory + ## (exec + ## (log! (format "{lux-structure#getOrCreateAsShortcut}" text.new-line + ## (exception.construct unknown-kind-of-object key))) + ## (error! "OOPS!"))) + + ## (php/runtime/memory/ArrayMemory + ## (getByScalarOrCreateAsShortcut {key java/lang/Object}) + ## php/runtime/memory/ReferenceMemory + ## (exec + ## (log! (format "{lux-structure#getByScalarOrCreateAsShortcut}" text.new-line + ## (exception.construct unknown-kind-of-object key))) + ## (error! "OOPS!"))) + + ## (php/runtime/memory/ArrayMemory + ## (getByScalarOrCreate {key java/lang/Object}) + ## php/runtime/memory/ReferenceMemory + ## (exec + ## (log! (format "{lux-structure#getByScalarOrCreate}" text.new-line + ## (exception.construct unknown-kind-of-object key))) + ## (error! "OOPS!"))) + + ## (php/runtime/memory/ArrayMemory + ## (getByScalar {key java/lang/Object}) + ## php/runtime/memory/ReferenceMemory + ## (exec + ## (log! (format "{lux-structure#getByScalar}" text.new-line + ## (exception.construct unknown-kind-of-object key))) + ## (error! "OOPS!"))) + + (php/runtime/Memory + (refOfIndex {trace php/runtime/env/TraceInfo} + {index php/runtime/Memory}) + php/runtime/Memory + (exec + (log! (format "{lux-structure#refOfIndex}" text.new-line + (exception.construct unknown-kind-of-object index))) + (error! "OOPS!"))) + + (php/runtime/Memory + (refOfIndexAsShortcut {trace php/runtime/env/TraceInfo} + {index php/runtime/Memory}) + php/runtime/Memory + (exec + (log! (format "{lux-structure#refOfIndexAsShortcut}" text.new-line + (exception.construct unknown-kind-of-object index))) + (error! "OOPS!"))) + + (php/runtime/Memory + (refOfIndex {trace php/runtime/env/TraceInfo} + {index long}) + php/runtime/Memory + (exec + (log! (format "{lux-structure#refOfIndex long}" text.new-line + (exception.construct unknown-kind-of-object index))) + (error! "OOPS!"))) + + (php/runtime/Memory + (refOfIndex {trace php/runtime/env/TraceInfo} + {index java/lang/String}) + php/runtime/Memory + (exec + (log! (format "{lux-structure#refOfIndex java/lang/String}" text.new-line + (exception.construct unknown-kind-of-object index))) + (error! "OOPS!"))) + + (~~ (template [<name>] + [(php/runtime/Memory (<name>) php/runtime/Memory (undefined))] + + [inc] [dec] [negative] [toNumeric] + )) + + (~~ (template [<name>] + [(php/runtime/Memory (<name> {other php/runtime/Memory}) php/runtime/Memory (undefined))] + + [plus] [minus] [mul] [pow] [div] + [identical] [equal] [notEqual] + [smaller] [smallerEq] [greater] [greaterEq] + )) + + (php/runtime/Memory (toLong) long (undefined)) + (php/runtime/Memory (toDouble) double (undefined)) + (php/runtime/Memory (toBoolean) boolean (undefined)) + (php/runtime/Memory (toString) java/lang/String (undefined)) + (php/runtime/Memory (getBinaryBytes {input java/nio/charset/Charset}) ByteArray (undefined)) + ))) + +(def: (read-tuple read host-object) + (-> Reader php/runtime/memory/ArrayMemory (Error Any)) + (let [size (:coerce Nat (php/runtime/memory/ArrayMemory::size host-object))] + (loop [idx 0 + output (:coerce (Array Any) (array.new size))] + (if (n/< size idx) + (let [value (|> host-object + (php/runtime/memory/ArrayMemory::get (php/runtime/memory/LongMemory::new (.int idx))) + (:coerce php/runtime/memory/ReferenceMemory) + php/runtime/memory/ReferenceMemory::getValue)] + (case (host.check php/runtime/memory/NullMemory value) + (#.Some _) + (recur (inc idx) output) + + #.None + (case (read value) + (#error.Failure error) + (#error.Failure error) + + (#error.Success lux-value) + (recur (inc idx) (array.write idx lux-value output))))) + (#error.Success output))))) + +(def: (read-variant read host-object) + (-> Reader php/runtime/memory/ArrayMemory (Error Any)) + (case [(|> host-object + (php/runtime/memory/ArrayMemory::get (php/runtime/memory/StringMemory::new runtime.variant-tag-field)) + read) + (|> host-object + (php/runtime/memory/ArrayMemory::get (php/runtime/memory/StringMemory::new runtime.variant-value-field)) + read)] + [(#error.Success tag) (#error.Success value)] + (#error.Success [(java/lang/Long::intValue (:coerce java/lang/Long tag)) + (: Any + (case (|> host-object + (php/runtime/memory/ArrayMemory::get (php/runtime/memory/StringMemory::new runtime.variant-flag-field)) + (:coerce php/runtime/memory/ReferenceMemory) + php/runtime/memory/ReferenceMemory::getValue + (host.check php/runtime/memory/NullMemory)) + (#.Some _) + (host.null) + + #.None + synthesis.unit)) + value]) + + _ + (exception.throw ..unknown-kind-of-object host-object))) + +(exception: #export nulll-has-no-lux-representation) + +(def: (read host-object) + Reader + (`` (<| (~~ (template [<class> <constant>] + [(case (host.check <class> host-object) + (#.Some _) + (#error.Success <constant>) + + #.None)] + + [php/runtime/memory/FalseMemory false] + [php/runtime/memory/TrueMemory true] + )) + (~~ (template [<class> <post>] + [(case (host.check <class> host-object) + (#.Some value) + (`` (|> value (~~ (template.splice <post>)))) + + #.None)] + + [php/runtime/memory/LongMemory [php/runtime/memory/LongMemory::toLong #error.Success]] + [php/runtime/memory/DoubleMemory [php/runtime/memory/DoubleMemory::toDouble #error.Success]] + [php/runtime/memory/StringMemory [php/runtime/memory/StringMemory::toString #error.Success]] + [php/runtime/memory/ReferenceMemory [php/runtime/memory/ReferenceMemory::getValue read]] + [php/runtime/memory/ObjectMemory [#error.Success]] + )) + (case (host.check php/runtime/memory/ArrayMemory host-object) + (#.Some value) + (if (php/runtime/memory/ArrayMemory::isMap value) + (read-variant read value) + (read-tuple read value)) + + #.None) + (exception.throw ..unknown-kind-of-object host-object) + ))) + +(exception: (cannot-apply-a-non-function {object java/lang/Object}) + (exception.report + ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] + ["Non-function" (java/lang/Object::toString object)])) + +(import: #long javax/script/ScriptEngine + (eval [String] #try Object)) + +(import: #long org/develnext/jphp/scripting/JPHPScriptEngine + (new [])) + +(def: (ensure-macro macro) + ## (-> Macro (Maybe php/runtime/lang/Closure)) + ## (do maybe.monad + ## [object-memory (|> macro + ## (:coerce java/lang/Object) + ## (host.check php/runtime/memory/ObjectMemory))] + ## (|> object-memory + ## php/runtime/memory/ObjectMemory::value + ## (host.check php/runtime/lang/Closure))) + (-> Macro (Maybe php/runtime/memory/ObjectMemory)) + (|> macro + (:coerce java/lang/Object) + (host.check php/runtime/memory/ObjectMemory))) + +(def: (call-macro inputs lux macro) + (-> (List Code) Lux + php/runtime/memory/ObjectMemory + ## php/runtime/lang/Closure + (Error (Error [Lux (List Code)]))) + (<| :assume + (do error.monad + [#let [_ (log! (format "{call-macro 0} " (exception.construct ..unknown-kind-of-object (:coerce java/lang/Object (php/runtime/memory/ObjectMemory::value macro)))))] + output (php/runtime/lang/Closure::call (php/runtime/env/Environment::current) + (|> (host.array php/runtime/Memory 3) + (host.array-write 0 macro) + (host.array-write 1 + ## (php/runtime/memory/ArrayMemory::new (:coerce (Array java/lang/Object) inputs)) + (lux-structure (:coerce (Array java/lang/Object) inputs)) + ) + (host.array-write 2 + ## (php/runtime/memory/ArrayMemory::new (:coerce (Array java/lang/Object) lux)) + (lux-structure (:coerce (Array java/lang/Object) lux)) + )) + (:coerce php/runtime/lang/Closure + (php/runtime/memory/ObjectMemory::value macro))) + ## output (php/runtime/invoke/InvokeHelper::callAny macro + ## (|> (host.array php/runtime/Memory 2) + ## ## (host.array-write 0 macro) + ## ## (host.array-write 1 macro) + ## (host.array-write 0 ## (php/runtime/memory/ArrayMemory::new (:coerce (Array java/lang/Object) inputs)) + ## (lux-structure (:coerce (Array java/lang/Object) inputs)) + ## ) + ## (host.array-write 1 ## (php/runtime/memory/ArrayMemory::new (:coerce (Array java/lang/Object) lux)) + ## (lux-structure (:coerce (Array java/lang/Object) lux)) + ## )) + ## (php/runtime/env/Environment::current) + ## (php/runtime/env/TraceInfo::new "" +0 +0)) + #let [_ (log! (format "{call-macro 1} " (debug.inspect output))) + _ (log! (format "{call-macro 2} " (exception.construct ..unknown-kind-of-object (:coerce java/lang/Object output))))]] + (..read (:coerce java/lang/Object output))))) + +(def: (expander macro inputs lux) + Expander + (case (ensure-macro macro) + (#.Some macro) + (call-macro inputs lux macro) + + #.None + (exception.throw cannot-apply-a-non-function (:coerce java/lang/Object macro))) + ) + +(def: separator "___") + +(type: Host + (generation.Host (_.Expression Any) _.Statement)) + +(def: host + (IO Host) + (io (let [interpreter (org/develnext/jphp/scripting/JPHPScriptEngine::new) + run! (: (-> Text (_.Code Any) (Error Any)) + (function (_ dummy-name code) + (do error.monad + [output (javax/script/ScriptEngine::eval (format "<?php " (_.code code)) interpreter)] + (..read output))))] + (: Host + (structure + (def: (evaluate! dummy-name code) + (run! dummy-name (_.return code))) + + (def: execute! run!) + + (def: (define! [module name] input) + (let [global (format (text.replace-all .module-separator ..separator module) + ..separator (name.normalize name) + "___" (%n (text@hash name))) + @global (_.global global)] + (do error.monad + [#let [definition (_.; (_.set @global input))] + _ (run! global definition) + value (run! global (_.return @global))] + (wrap [global value definition]))))))))) + +(def: platform + (IO (Platform IO _.Var (_.Expression Any) _.Statement)) + (do io.monad + [host ..host] + (wrap {#platform.&monad io.monad + #platform.&file-system file.system + #platform.host host + #platform.phase php.generate + #platform.runtime runtime.generate}))) + +(def: (program program) + (-> (_.Expression Any) _.Statement) + (_.; (_.apply/2 [(runtime.lux//program-args _.command-line-arguments) + _.null] + program))) + +(program: [{service /cli.service}] + (/.compiler ..expander + ..platform + extension.bundle + ..program + service)) diff --git a/lux-ruby/project.clj b/lux-ruby/project.clj index 70f2e949c..5da89c1a4 100644 --- a/lux-ruby/project.clj +++ b/lux-ruby/project.clj @@ -3,7 +3,7 @@ (def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") (def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") -(defproject com.github.luxlang/lux-python #=(identity version) +(defproject com.github.luxlang/lux-ruby #=(identity version) :description "A Ruby compiler for Lux." :url ~repo :license {:name "Lux License v0.1" diff --git a/new-luxc/project.clj b/new-luxc/project.clj index 91b6efdb5..1b858000d 100644 --- a/new-luxc/project.clj +++ b/new-luxc/project.clj @@ -27,9 +27,6 @@ ;; [kawa-scheme/kawa-core "2.4"] ;; ;; Common Lisp ;; [org.abcl/abcl "1.5.0"] - ;; ;; PHP 5 - ;; [org.develnext.jphp/jphp-core "0.9.2"] - ;; [org.develnext.jphp/jphp-scripting "0.9.2"] ] :manifest {"lux" ~version} 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)))) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 661858e40..0936b51dd 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -4,8 +4,9 @@ [abstract [monad (#+ do)]] [control - [cli (#+ program:)] - ["." io (#+ IO)]] + ["." io (#+ IO)] + [parser + [cli (#+ program:)]]] [data ["." error (#+ Error)] [collection diff --git a/stdlib/source/lux/host/php.lux b/stdlib/source/lux/host/php.lux new file mode 100644 index 000000000..286d8d397 --- /dev/null +++ b/stdlib/source/lux/host/php.lux @@ -0,0 +1,444 @@ +(.module: + [lux (#- Code static int if cond or and not comment for) + [control + [pipe (#+ case> cond> new>)]] + [data + [number + ["." frac]] + ["." text + format] + [collection + ["." list ("#@." functor fold)]]] + [macro + ["." template]] + [type + abstract]]) + +(def: input-separator ", ") +(def: statement-suffix ";") + +(def: nest + (-> Text Text) + (|>> (format text.new-line) + (text.replace-all text.new-line (format text.new-line text.tab)))) + +(def: block + (-> Text Text) + (|>> ..nest (text.enclose ["{" (format text.new-line "}")]))) + +(def: group + (-> Text Text) + (text.enclose ["(" ")"])) + +(abstract: #export (Code brand) + {} + + Text + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export (<brand> brand) {} Any)) + (`` (type: #export (<type> brand) + (<super> (<brand> brand)))))] + + [Expression Code] + [Computation Expression] + [Location Computation] + ) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export <brand> {} Any)) + (`` (type: #export <type> (<super> <brand>))))] + + [Literal Computation] + [Var Location] + [Constant Location] + [Global Location] + [Access Location] + [Statement Code] + ) + + (type: #export Argument + {#reference? Bit + #var Var}) + + (def: #export ; + (-> (Expression Any) Statement) + (|>> :representation + (text.suffix ..statement-suffix) + :abstraction)) + + (def: #export var + (-> Text Var) + (|>> (format "$") :abstraction)) + + (def: #export constant + (-> Text Constant) + (|>> :abstraction)) + + (def: #export null + Literal + (:abstraction "NULL")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "false" + #1 "true") + :abstraction)) + + (def: #export int + (-> Int Literal) + (|>> %i :abstraction)) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f/= frac.positive-infinity)] + [(new> "+INF" [])] + + [(f/= frac.negative-infinity)] + [(new> "-INF" [])] + + [(f/= frac.not-a-number)] + [(new> "NAN" [])] + + ## else + [%f]) + :abstraction)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace-all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical-tab "\v"] + [text.null "\0"] + [text.back-space "\b"] + [text.form-feed "\f"] + [text.new-line "\n"] + [text.carriage-return "\r"] + [text.double-quote (format "\" text.double-quote)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose [text.double-quote text.double-quote]) + :abstraction)) + + (def: arguments + (-> (List (Expression Any)) Text) + (|>> (list@map ..code) (text.join-with ..input-separator) ..group)) + + (def: #export (apply/* args func) + (-> (List (Expression Any)) (Expression Any) (Computation Any)) + (:abstraction + (format (:representation func) (..arguments args)))) + + (def: parameters + (-> (List Argument) Text) + (|>> (list@map (function (_ [reference? var]) + (.if reference? + (format "&" (:representation var)) + (:representation var)))) + (text.join-with ..input-separator) + ..group)) + + (template [<name> <reference?>] + [(def: #export <name> + (-> Var Argument) + (|>> [<reference?>]))] + + [parameter #0] + [reference #1] + ) + + (def: #export (closure uses arguments body!) + (-> (List Argument) (List Argument) Statement Literal) + (let [uses (case uses + #.Nil + "" + + _ + (format "use " (..parameters uses)))] + (|> (format "function " (..parameters arguments) + " " uses " " + (..block (:representation body!))) + ..group + :abstraction))) + + (template [<apply> <input-var>+ <input-type>+ <function>+] + [(`` (def: #export (<apply> [(~~ (template.splice <input-var>+))] function) + (-> [(~~ (template.splice <input-type>+))] (Expression Any) (Computation Any)) + (..apply/* (list (~~ (template.splice <input-var>+))) function))) + + (`` (template [<lux-name> <php-name>] + [(def: #export (<lux-name> args) + (-> [(~~ (template.splice <input-type>+))] (Computation Any)) + (<apply> args (..constant <php-name>)))] + + (~~ (template.splice <function>+))))] + + [apply/0 [] [] + [[func-num-args/0 "func_num_args"] + [func-get-args/0 "func_get_args"] + [time/0 "time"]]] + [apply/1 [in0] [(Expression Any)] + [[is-null/1 "is_null"] + [empty/1 "empty"] + [count/1 "count"] + [strlen/1 "strlen"] + [array-pop/1 "array_pop"] + [array-reverse/1 "array_reverse"] + [intval/1 "intval"] + [floatval/1 "floatval"] + [strval/1 "strval"] + [ord/1 "ord"] + [chr/1 "chr"] + [print/1 "print"] + [exit/1 "exit"]]] + [apply/2 [in0 in1] [(Expression Any) (Expression Any)] + [[call-user-func-array/2 "call_user_func_array"] + [array-slice/2 "array_slice"] + [array-push/2 "array_push"]]] + [apply/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] + [[array-slice/3 "array_slice"] + [array-splice/3 "array_splice"] + [strpos/3 "strpos"] + [substr/3 "substr"]]] + ) + + (def: #export (array/* values) + (-> (List (Expression Any)) Literal) + (|> values + (list@map ..code) + (text.join-with ..input-separator) + ..group + (format "array") + :abstraction)) + + (def: #export (array-merge/+ required optionals) + (-> (Expression Any) (List (Expression Any)) (Computation Any)) + (..apply/* (list& required optionals) (..constant "array_merge"))) + + (def: #export (array/** kvs) + (-> (List [(Expression Any) (Expression Any)]) Literal) + (|> kvs + (list@map (function (_ [key value]) + (format (:representation key) " => " (:representation value)))) + (text.join-with ..input-separator) + ..group + (format "array") + :abstraction)) + + (def: #export (new constructor inputs) + (-> Constant (List (Expression Any)) (Computation Any)) + (|> (format "new " (:representation constructor) (arguments inputs)) + :abstraction)) + + (def: #export (do method inputs object) + (-> Text (List (Expression Any)) (Expression Any) (Computation Any)) + (|> (format (:representation object) "->" method (arguments inputs)) + :abstraction)) + + (def: #export (nth idx array) + (-> (Expression Any) (Expression Any) Access) + (|> (format (:representation array) "[" (:representation idx) "]") + :abstraction)) + + (def: #export (global name) + (-> Text Global) + (|> (..var "GLOBALS") (..nth (..string name)) :transmutation)) + + (def: #export (? test then else) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (|> (format (:representation test) " ? " + (:representation then) " : " + (:representation else)) + ..group + :abstraction)) + + (template [<name> <op>] + [(def: #export (<name> parameter subject) + (-> (Expression Any) (Expression Any) (Computation Any)) + (|> (format (:representation subject) " " <op> " " (:representation parameter)) + ..group + :abstraction))] + + [or "||"] + [and "&&"] + [= "==="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [% "%"] + [bit-or "|"] + [bit-and "&"] + [bit-xor "^"] + [bit-shl "<<"] + [bit-shr ">>"] + [concat "."] + ) + + (def: #export not + (-> (Computation Any) (Computation Any)) + (|>> :representation (format "!") :abstraction)) + + (def: #export (set var value) + (-> (Location Any) (Expression Any) (Computation Any)) + (|> (format (:representation var) " = " (:representation value)) + ..group + :abstraction)) + + (def: #export (set? var) + (-> Var (Computation Any)) + (..apply/1 [var] (..constant "isset"))) + + (template [<name> <modifier>] + [(def: #export <name> + (-> Var Statement) + (|>> :representation (format <modifier> " ") (text.suffix ..statement-suffix) :abstraction))] + + [define-global "global"] + ) + + (template [<name> <modifier> <location>] + [(def: #export (<name> location value) + (-> <location> (Expression Any) Statement) + (:abstraction (format <modifier> " " (:representation location) + " = " (:representation value) + ..statement-suffix)))] + + [define-static "static" Var] + [define-constant "const" Constant] + ) + + (def: #export (if test then! else!) + (-> (Expression Any) Statement Statement Statement) + (:abstraction + (format "if " (..group (:representation test)) " " + (..block (:representation then!)) + " else " + (..block (:representation else!))))) + + (def: #export (when test then!) + (-> (Expression Any) Statement Statement) + (:abstraction + (format "if " (..group (:representation test)) " " + (..block (:representation then!))))) + + (def: #export (then pre! post!) + (-> Statement Statement Statement) + (:abstraction + (format (:representation pre!) + text.new-line + (:representation post!)))) + + (def: #export (while test body!) + (-> (Expression Any) Statement Statement) + (:abstraction + (format "while " (..group (:representation test)) " " + (..block (:representation body!))))) + + (def: #export (do-while test body!) + (-> (Expression Any) Statement Statement) + (:abstraction + (format "do " (..block (:representation body!)) + " while " (..group (:representation test)) + ..statement-suffix))) + + (def: #export (for-each array value body!) + (-> (Expression Any) Var Statement Statement) + (:abstraction + (format "foreach(" (:representation array) + " as " (:representation value) + ") " (..block (:representation body!))))) + + (type: #export Except + {#class Constant + #exception Var + #handler Statement}) + + (def: (catch except) + (-> Except Text) + (let [declaration (format (:representation (get@ #class except)) + " " (:representation (get@ #exception except)))] + (format "catch" (..group declaration) " " + (..block (:representation (get@ #handler except)))))) + + (def: #export (try body! excepts) + (-> Statement (List Except) Statement) + (:abstraction + (format "try " (..block (:representation body!)) + text.new-line + (|> excepts + (list@map catch) + (text.join-with text.new-line))))) + + (template [<name> <keyword>] + [(def: #export <name> + (-> (Expression Any) Statement) + (|>> :representation (format <keyword> " ") (text.suffix ..statement-suffix) :abstraction))] + + [throw "throw"] + [return "return"] + [echo "echo"] + ) + + (def: #export (define name value) + (-> Constant (Expression Any) (Expression Any)) + (..apply/2 [(|> name :representation ..string) + value] + (..constant "define"))) + + (def: #export (define-function name uses arguments body!) + (-> Constant (List Argument) (List Argument) Statement Statement) + (let [uses (case uses + #.Nil + "" + + _ + (format " use " (..parameters uses)))] + (:abstraction + (format "function " (:representation name) " " (..parameters arguments) + uses " " + (..block (:representation body!)))))) + + (template [<name> <keyword>] + [(def: #export <name> + Statement + (|> <keyword> + (text.suffix ..statement-suffix) + :abstraction))] + + [break "break"] + [continue "continue"] + ) + ) + +(def: #export (cond clauses else!) + (-> (List [(Expression Any) Statement]) Statement Statement) + (list@fold (function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) + +(def: #export command-line-arguments + Var + (..var "argv")) diff --git a/stdlib/source/lux/host/ruby.lux b/stdlib/source/lux/host/ruby.lux index e52fb6f37..037cdca5b 100644 --- a/stdlib/source/lux/host/ruby.lux +++ b/stdlib/source/lux/host/ruby.lux @@ -1,9 +1,7 @@ (.module: [lux (#- Code static int if cond function or and not comment) [control - [pipe (#+ case> cond> new>)] - [parser - ["s" code]]] + [pipe (#+ case> cond> new>)]] [data [number ["." frac]] @@ -12,9 +10,7 @@ [collection ["." list ("#@." functor fold)]]] [macro - ["." template] - ["." code] - [syntax (#+ syntax:)]] + ["." template]] [type abstract]]) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux index 61243a9bc..6c2ba872f 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -80,7 +80,7 @@ (do ///.monad [codeT (generate codeS) [target-name value statement] (///generation.define! name codeT) - _ (///generation.save! name statement)] + _ (///generation.save! false name statement)] (wrap [code//type codeT target-name value])))) (def: (definition name ?type codeC) @@ -296,7 +296,7 @@ (///generation.Operation anchor expression statement Any))) (do ///.monad [programG (generate programS)] - (///generation.save! ["" ""] (program programG)))) + (///generation.save! false ["" ""] (program programG)))) (def: (def::program program) (All [anchor expression statement] diff --git a/stdlib/source/lux/tool/compiler/phase/generation.lux b/stdlib/source/lux/tool/compiler/phase/generation.lux index edf260e19..4482daa3b 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation.lux @@ -221,12 +221,14 @@ (#error.Failure error) (exception.throw cannot-interpret error)))) -(def: #export (save! name code) +(def: #export (save! execute? name code) (All [anchor expression statement] - (-> Name statement (Operation anchor expression statement Any))) + (-> Bit Name statement (Operation anchor expression statement Any))) (do //.monad [label (..gensym "save") - _ (execute! label code) + _ (if execute? + (execute! label code) + (wrap [])) ?buffer (extension.read (get@ #buffer))] (case ?buffer (#.Some buffer) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php.lux b/stdlib/source/lux/tool/compiler/phase/generation/php.lux new file mode 100644 index 000000000..480c473bf --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php.lux @@ -0,0 +1,60 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]]] + [/ + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference ("#@." system)] + ["." case] + ["." loop] + ["." function] + ["." /// + ["." extension] + [// + ["." synthesis]]]]) + +(def: #export (generate synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (:: ///.monad wrap (<generator> value))) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant generate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple generate members) + + (#synthesis.Reference value) + (reference@reference value) + + (^ (synthesis.branch/case case)) + (case.case generate case) + + (^ (synthesis.branch/let let)) + (case.let generate let) + + (^ (synthesis.branch/if if)) + (case.if generate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope generate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur generate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function generate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply generate application) + + (#synthesis.Extension extension) + (extension.apply generate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/case.lux new file mode 100644 index 000000000..1167ae5a6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/case.lux @@ -0,0 +1,250 @@ +(.module: + [lux (#- case let if) + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#@." functor fold)] + ["." set]]] + [host + ["_" php (#+ Var Expression Statement)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." reference] + ["#." primitive] + ["#/" // + ["#." reference] + ["#/" // ("#@." monad) + [synthesis + ["." case]] + ["#/" // #_ + ["." reference (#+ Register)] + ["#." synthesis (#+ Synthesis Path)]]]]]) + +(def: #export register + (///reference.local _.var)) + +(def: #export capture + (///reference.foreign _.var)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation (Expression Any))) + (do ////.monad + [valueG (generate valueS) + bodyG (generate bodyS)] + (wrap (|> bodyG + (list (_.set (..register register) valueG)) + _.array/* + (_.nth (_.int +1)))))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List (Either Nat Nat)) + (Operation (Expression Any))) + (do ////.monad + [valueG (generate valueS)] + (wrap (list@fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + (<side> lefts) + (<accessor> (_.int (.int lefts)))) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueG + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation (Expression Any))) + (do ////.monad + [testG (generate testS) + thenG (generate thenS) + elseG (generate elseS)] + (wrap (_.? testG thenG elseG)))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push! value) + (-> (Expression Any) Statement) + (_.; (_.array-push/2 [@cursor value]))) + +(def: peek-and-pop + (Expression Any) + (_.array-pop/1 @cursor)) + +(def: pop! + Statement + (_.; ..peek-and-pop)) + +(def: peek + (Expression Any) + (_.nth (|> @cursor _.count/1 (_.- (_.int +1))) + @cursor)) + +(def: save! + Statement + (.let [cursor (_.array-slice/2 [@cursor (_.int +0)])] + (_.; (_.array-push/2 [@savepoint cursor])))) + +(def: restore! + Statement + (_.; (_.set @cursor (_.array-pop/1 @savepoint)))) + +(def: fail! _.break) + +(exception: #export unrecognized-path) + +(def: (multi-pop! pops) + (-> Nat Statement) + (_.; (_.array-splice/3 [@cursor + (_.int +0) + (_.int (i/* -1 (.int pops)))]))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat Statement) + ($_ _.then + (_.; (_.set @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))) + (.if simple? + (_.when (_.is-null/1 @temp) + fail!) + (_.if (_.is-null/1 @temp) + fail! + (..push! @temp)))))] + + [left-choice _.null (<|)] + [right-choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> Statement Statement Statement) + ($_ _.then + (_.do-while (_.bool false) + ($_ _.then + ..save! + pre!)) + ($_ _.then + ..restore! + post!))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation Statement)) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (:: ////.monad map _.return (generate bodyS)) + + #/////synthesis.Pop + (////@wrap ..pop!) + + (#/////synthesis.Bind register) + (////@wrap (_.; (_.set (..register register) ..peek))) + + (^template [<tag> <format>] + (^ (<tag> value)) + (////@wrap (_.when (|> value <format> (_.= ..peek) _.not) + fail!))) + ([/////synthesis.path/bit //primitive.bit] + [/////synthesis.path/i64 //primitive.i64] + [/////synthesis.path/f64 //primitive.f64] + [/////synthesis.path/text //primitive.text]) + + (^template [<complex> <simple> <choice>] + (^ (<complex> idx)) + (////@wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + (pattern-matching' generate) + (:: ////.monad map (_.then (<choice> true idx))))) + ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice] + [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) + + (^ (/////synthesis.member/left 0)) + (////@wrap (|> ..peek (_.nth (_.int +0)) ..push!)) + + (^template [<pm> <getter>] + (^ (<pm> lefts)) + (////@wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind-top register thenP)) + (do ////.monad + [then! (pattern-matching' generate thenP)] + (////@wrap ($_ _.then + (_.; (_.set (..register register) ..peek-and-pop)) + then!))) + + ## (^ (/////synthesis.!multi-pop nextP)) + ## (.let [[extra-pops nextP'] (case.count-pops nextP)] + ## (do ////.monad + ## [next! (pattern-matching' generate nextP')] + ## (////@wrap ($_ _.then + ## (..multi-pop! (n/+ 2 extra-pops)) + ## next!)))) + + (^template [<tag> <combinator>] + (^ (<tag> preP postP)) + (do ////.monad + [pre! (pattern-matching' generate preP) + post! (pattern-matching' generate postP)] + (wrap (<combinator> pre! post!)))) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation Statement)) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap ($_ _.then + (_.do-while (_.bool false) + pattern-matching!) + (_.throw (_.new (_.constant "Exception") (list (_.string case.pattern-matching-error)))))))) + +(def: (gensym prefix) + (-> Text (Operation Text)) + (:: ////.monad map (|>> %n (format prefix)) ///.next)) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation (Expression Any))) + (do ////.monad + [initG (generate valueS) + pattern-matching! (pattern-matching generate pathP) + @case (..gensym "case") + #let [@caseG (_.global @case) + @caseL (_.var @case)] + @init (:: @ map _.var (..gensym "init")) + #let [@dependencies+ (|> (case.storage pathP) + (get@ #case.dependencies) + set.to-list + (list@map (function (_ variable) + [#0 (.case variable + (#reference.Local register) + (..register register) + + (#reference.Foreign register) + (..capture register))])))] + _ (///.save! true ["" @case] + ($_ _.then + (<| _.; + (_.set @caseL) + (_.closure (list (_.reference @caseL)) (list& [#0 @init] + @dependencies+)) + ($_ _.then + (_.; (_.set @cursor (_.array/* (list @init)))) + (_.; (_.set @savepoint (_.array/* (list)))) + pattern-matching!)) + (_.; (_.set @caseG @caseL))))] + (wrap (_.apply/* (list& initG (list@map product.right @dependencies+)) + @caseG)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/extension.lux new file mode 100644 index 000000000..3bc0a0887 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/extension.lux @@ -0,0 +1,13 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/extension/common.lux new file mode 100644 index 000000000..9938bb2c1 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/extension/common.lux @@ -0,0 +1,126 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + ["." text] + [collection + ["." dictionary]]] + [host (#+ import:) + ["_" php (#+ Expression)]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.bit-and))) + (bundle.install "or" (binary (product.uncurry _.bit-or))) + (bundle.install "xor" (binary (product.uncurry _.bit-xor))) + (bundle.install "left-shift" (binary (product.uncurry _.bit-shl))) + (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift))) + (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + ))) + +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "frac" (unary _.floatval/1)) + (bundle.install "char" (unary _.chr/1))))) + +(import: #long java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(template [<name> <const>] + [(def: (<name> _) + (Nullary (Expression Any)) + (_.float <const>))] + + [frac//smallest (java/lang/Double::MIN_VALUE)] + [frac//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] + [frac//max (java/lang/Double::MAX_VALUE)] + ) + +(def: frac-procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "smallest" (nullary frac//smallest)) + (bundle.install "min" (nullary frac//min)) + (bundle.install "max" (nullary frac//max)) + (bundle.install "int" (unary _.intval/1)) + (bundle.install "encode" (unary _.strval/1)) + (bundle.install "decode" (unary (|>> _.floatval/1 ///runtime.some))) + ))) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "concat" (binary (product.uncurry _.concat))) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.strlen/1)) + (bundle.install "char" (binary (function (text//char [text idx]) + (|> text (_.nth idx) _.ord/1)))) + (bundle.install "clip" (trinary (function (text//clip [from to text]) + (_.substr/3 [text from (_.- from to)])))) + ))) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> (_.concat (_.string text.new-line)) _.print/1))) + (bundle.install "error" (unary ///runtime.io//throw!)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (|>> _.time/0 (_.* (_.int +1,000)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge int-procs) + (dictionary.merge frac-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/function.lux new file mode 100644 index 000000000..b2b446ed0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/function.lux @@ -0,0 +1,104 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#@." functor fold)]]] + [host + ["_" php (#+ Argument Expression Statement)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." reference] + ["#." case] + ["#/" // + ["#." reference] + ["#/" // + ["." // #_ + [reference (#+ Register Variable)] + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)]]]]]) + +(def: #export (apply generate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation (Expression Any))) + (do ////.monad + [functionG (generate functionS) + argsG+ (monad.map @ generate argsS+)] + (wrap (_.apply/* argsG+ functionG)))) + +(def: #export capture + (///reference.foreign _.var)) + +(def: input + (|>> inc //case.register)) + +(def: #export (function generate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation (Expression Any))) + (do ////.monad + [[function-name bodyG] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (generate bodyS)))) + closureG+ (: (Operation (List Argument)) + (monad.map @ (|>> (:: //reference.system variable) + (:: @ map _.reference)) + environment)) + #let [@curried (_.var "curried") + arityG (|> arity .int _.int) + @num-args (_.var "num_args") + @selfG (_.global function-name) + @selfL (_.var function-name) + initialize-self! (_.; (_.set (//case.register 0) @selfL)) + initialize! (list@fold (.function (_ post pre!) + ($_ _.then + pre! + (_.; (_.set (..input post) (_.nth (|> post .int _.int) @curried))))) + initialize-self! + (list.indices arity))] + _ (///.save! true ["" function-name] + ($_ _.then + (<| _.; + (_.set @selfL) + (_.closure (list& (_.reference @selfL) closureG+) (list)) + ($_ _.then + (_.echo (_.string "'ello, world! ")) + (_.; (_.set @num-args (_.func-num-args/0 []))) + (_.echo @num-args) (_.echo (_.string " ~ ")) (_.echo arityG) + (_.echo (_.string text.new-line)) + (_.; (_.set @curried (_.func-get-args/0 []))) + (_.cond (list [(|> @num-args (_.= arityG)) + ($_ _.then + initialize! + (_.return bodyG))] + [(|> @num-args (_.> arityG)) + (let [arity-inputs (_.array-slice/3 [@curried (_.int +0) arityG]) + extra-inputs (_.array-slice/2 [@curried arityG]) + next (_.call-user-func-array/2 [@selfL arity-inputs]) + done (_.call-user-func-array/2 [next extra-inputs])] + ($_ _.then + (_.echo (_.string "STAGED ")) (_.echo (_.count/1 arity-inputs)) + (_.echo (_.string " + ")) (_.echo (_.count/1 extra-inputs)) + (_.echo (_.string text.new-line)) + (_.echo (_.string "@selfL ")) (_.echo @selfL) (_.echo (_.string text.new-line)) + (_.echo (_.string " next ")) (_.echo next) (_.echo (_.string text.new-line)) + (_.echo (_.string " done ")) (_.echo done) (_.echo (_.string text.new-line)) + (_.return done)))]) + ## (|> @num-args (_.< arityG)) + (let [@missing (_.var "missing")] + (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) + ($_ _.then + (_.; (_.set @missing (_.func-get-args/0 []))) + (_.echo (_.string "NEXT ")) (_.echo (_.count/1 @curried)) + (_.echo (_.string " ")) (_.echo (_.count/1 @missing)) + (_.echo (_.string " ")) (_.echo (_.count/1 (_.array-merge/+ @curried (list @missing)))) + (_.echo (_.string text.new-line)) + (_.return (_.call-user-func-array/2 [@selfL (_.array-merge/+ @curried (list @missing))]))))))) + )) + (_.; (_.set @selfG @selfL))))] + (wrap @selfG))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/loop.lux new file mode 100644 index 000000000..3404953fe --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/loop.lux @@ -0,0 +1,47 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor)]]] + [host + ["_" php (#+ Expression)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." case] + ["#/" // + ["#/" // + [// + [synthesis (#+ Scope Synthesis)]]]]]) + +(def: #export (scope generate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation (Expression Any))) + (do ////.monad + [@loop (:: @ map (|>> %n (format "loop")) ///.next) + #let [@loopG (_.global @loop) + @loopL (_.var @loop)] + initsO+ (monad.map @ generate initsS+) + bodyO (///.with-anchor @loopL + (generate bodyS)) + _ (///.save! true ["" @loop] + ($_ _.then + (<| _.; + (_.set @loopL) + (_.closure (list (_.reference @loopL)) + (|> initsS+ + list.enumerate + (list@map (|>> product.left (n/+ start) //case.register [#0]))) + (_.return bodyO))) + (_.; (_.set @loopG @loopL))))] + (wrap (_.apply/* initsO+ @loopG)))) + +(def: #export (recur generate argsS+) + (-> Phase (List Synthesis) (Operation (Expression Any))) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/primitive.lux new file mode 100644 index 000000000..48a32389b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/primitive.lux @@ -0,0 +1,27 @@ +(.module: + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [data + [number + ["." frac]]] + [host + ["_" php (#+ Literal)]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + (-> Bit Literal) + _.bool) + +(def: #export i64 + (-> (I64 Any) Literal) + (|>> .int _.int)) + +(def: #export f64 + (-> Frac Literal) + _.float) + +(def: #export text + (-> Text Literal) + _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/reference.lux new file mode 100644 index 000000000..8f5313421 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/reference.lux @@ -0,0 +1,11 @@ +(.module: + [lux #* + [host + ["_" php (#+ Expression)]]] + [// + [// + ["." reference]]]) + +(def: #export system + (reference.system (: (-> Text (Expression Any)) _.global) + (: (-> Text (Expression Any)) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux new file mode 100644 index 000000000..e29b7622a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux @@ -0,0 +1,305 @@ +(.module: + [lux (#- inc) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["p" parser + ["s" code]]] + [data + [number (#+ hex) + ["." i64]] + ["." text + format] + [collection + ["." list ("#@." functor)]]] + ["." macro + ["." code] + [syntax (#+ syntax:)]] + [host + ["_" php (#+ Expression Var Global Computation Literal Statement)]]] + ["." /// + ["//." // + [// + ["/////." name] + ["." synthesis]]]] + ) + +(template [<name> <base>] + [(type: #export <name> + (<base> Var (Expression Any) Statement))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: #export unit (_.string synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + (_.string "") + _.null)) + +(def: #export variant-tag-field "_lux_tag") +(def: #export variant-flag-field "_lux_flag") +(def: #export variant-value-field "_lux_value") + +(def: (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) Literal) + (_.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 Any) Literal) + (variant' (_.int (.int tag)) + (..flag last?) + value)) + +(def: #export none + Literal + (..variant 0 #0 ..unit)) + +(def: #export some + (-> (Expression Any) Literal) + (..variant 1 #1)) + +(def: #export left + (-> (Expression Any) Literal) + (..variant 0 #0)) + +(def: #export right + (-> (Expression Any) Literal) + (..variant 1 #1)) + +(def: (runtime-name raw) + (-> Text [Global Var]) + (let [refined (|> raw + /////name.normalize + (format ..prefix "_"))] + [(_.global refined) (_.var refined)])) + +(def: (feature name definition) + (-> [Global Var] (-> [Global Var] Statement) Statement) + (definition name)) + +(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list@map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (/////name.normalize var)))))))) + list.concat))] + (~ body)))))) + +(syntax: (runtime: {declaration (p.or s.local-identifier + (s.form (p.and s.local-identifier + (p.some s.local-identifier))))} + code) + (macro.with-gensyms [g!_ g!G g!L] + (case declaration + (#.Left name) + (let [code-nameC (code.local-identifier (format "@" name)) + runtime-nameC (` (runtime-name (~ (code.text name))))] + (wrap (list (` (def: #export (~ (code.local-identifier name)) _.Global (~ runtime-nameC))) + (` (def: (~ code-nameC) + _.Statement + (..feature (~ runtime-nameC) + (function ((~ g!_) [(~ g!G) (~ g!L)]) + (_.; (_.set (~ g!G) (~ code)))))))))) + + (#.Right [name inputs]) + (let [code-nameC (code.local-identifier (format "@" name)) + runtime-nameC (` (runtime-name (~ (code.text name)))) + inputsC (list@map code.local-identifier inputs) + inputs-typesC (list@map (function.constant (` (_.Expression Any))) + inputs)] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~+ inputsC)) + (-> (~+ inputs-typesC) (_.Computation Any)) + (.let [[(~ g!G) (~ g!L)] (~ runtime-nameC)] + (_.apply/* (list (~+ inputsC)) (~ g!G))))) + (` (def: (~ code-nameC) + _.Statement + (..feature (~ runtime-nameC) + (function ((~ g!_) [(~ g!G) (~ g!L)]) + (..with-vars [(~+ inputsC)] + ($_ _.then + (<| _.; + (_.set (~ g!L)) + (_.closure (list (_.reference (~ g!L))) + (list (~+ (|> inputsC + (list@map (function (_ inputC) + (` [#0 (~ inputC)])))))) + (~ code))) + (_.; (_.set (~ g!G) (~ g!L))) + )))))))))))) + +(runtime: (lux//try op) + (with-vars [value] + (_.try ($_ _.then + (_.; (_.set value (_.apply/1 [..unit] op))) + (_.return (..right value))) + (list (with-vars [error] + {#_.class (_.constant "Exception") + #_.exception error + #_.handler (_.return (..left (_.do "getMessage" (list) error)))}))))) + +(runtime: (lux//program-args inputs) + (with-vars [head tail] + ($_ _.then + (_.; (_.set tail ..none)) + (<| (_.for-each (_.array-reverse/1 inputs) head) + (_.; (_.set tail (..some (_.array/* (list head tail)))))) + (_.return tail)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program-args)) + +(runtime: (io//throw! message) + ($_ _.then + (_.throw (_.new (_.constant "Exception") (list message))) + (_.return ..unit))) + +(def: runtime//io + Statement + ($_ _.then + @io//throw!)) + +(def: tuple-size + _.count/1) + +(def: last-index + (|>> ..tuple-size (_.- (_.int +1)))) + +(with-expansions [<recur> (as-is ($_ _.then + (_.; (_.set lefts (_.- last-index-right lefts))) + (_.; (_.set tuple (_.nth last-index-right tuple)))))] + (runtime: (tuple//left lefts tuple) + (with-vars [last-index-right] + (<| (_.while (_.bool true)) + ($_ _.then + (_.; (_.set last-index-right (..last-index tuple))) + (_.if (_.> lefts last-index-right) + ## No need for recursion + (_.return (_.nth lefts tuple)) + ## Needs recursion + <recur>))))) + + (runtime: (tuple//right lefts tuple) + (with-vars [last-index-right right-index] + (<| (_.while (_.bool true)) + ($_ _.then + (_.; (_.set last-index-right (..last-index tuple))) + (_.; (_.set right-index (_.+ (_.int +1) lefts))) + (_.cond (list [(_.= right-index last-index-right) + (_.return (_.nth right-index tuple))] + [(_.> right-index last-index-right) + ## Needs recursion. + <recur>]) + (_.return (_.array-slice/2 [tuple right-index]))) + ))))) + +(runtime: (sum//get sum wantsLast wantedTag) + (let [no-match! (_.return _.null) + sum-tag (_.nth (_.string ..variant-tag-field) sum) + ## sum-tag (_.nth (_.int +0) sum) + sum-flag (_.nth (_.string ..variant-flag-field) sum) + ## sum-flag (_.nth (_.int +1) sum) + sum-value (_.nth (_.string ..variant-value-field) sum) + ## sum-value (_.nth (_.int +2) sum) + is-last? (_.= (_.string "") sum-flag) + test-recursion! (_.if is-last? + ## Must recurse. + (_.return (sum//get sum-value (_.- sum-tag wantedTag) wantsLast)) + no-match!)] + ($_ _.then + (_.echo (_.string "sum//get ")) (_.echo (_.count/1 sum)) + (_.echo (_.string " ")) (_.echo (_.apply/1 [sum] (_.constant "gettype"))) + (_.echo (_.string " ")) (_.echo sum-tag) + (_.echo (_.string " ")) (_.echo wantedTag) + (_.echo (_.string text.new-line)) + (_.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 + Statement + ($_ _.then + @tuple//left + @tuple//right + @sum//get)) + +(runtime: (i64//logic-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//i64 + Statement + ($_ _.then + @i64//logic-right-shift + )) + +(runtime: (text//index subject param start) + (with-vars [idx] + ($_ _.then + (_.; (_.set idx (_.strpos/3 [subject param start]))) + (_.if (_.= (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))))) + +(def: runtime//text + Statement + ($_ _.then + @text//index + )) + +(def: check-necessary-conditions! + Statement + (let [condition (_.= (_.int +8) + (_.constant "PHP_INT_SIZE")) + error-message (_.string (format "Cannot run program!" text.new-line + "Lux/PHP programs require 64-bit PHP builds!"))] + (_.when (_.not condition) + (_.throw (_.new (_.constant "Exception") (list error-message)))))) + +(def: runtime + Statement + ($_ _.then + check-necessary-conditions! + runtime//lux + runtime//adt + runtime//i64 + runtime//text + runtime//io + )) + +(def: #export artifact ..prefix) + +(def: #export generate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! true ["" ..prefix] ..runtime)] + (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/structure.lux new file mode 100644 index 000000000..7bc675d7e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/structure.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [host + ["_" php (#+ Expression)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." primitive] + ["#//" /// + ["#/" // #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)]]]]) + +(def: #export (tuple generate elemsS+) + (-> Phase (Tuple Synthesis) (Operation (Expression Any))) + (case elemsS+ + #.Nil + (:: ////.monad wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate singletonS) + + _ + (|> elemsS+ + (monad.map ////.monad generate) + (:: ////.monad map _.array/*)))) + +(def: #export (variant generate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation (Expression Any))) + (:: ////.monad map + (//runtime.variant (if right? + (inc lefts) + lefts) + right?) + (generate valueS))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/extension/common.lux index adec09fa3..1113ec3b6 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/python/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/extension/common.lux @@ -41,6 +41,17 @@ (bundle.install "-" (binary (product.uncurry _.-))) ))) +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "frac" (unary _.float/1)) + (bundle.install "char" (unary _.chr/1))))) + (import: #long java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE Double)) @@ -55,17 +66,6 @@ [frac//max (java/lang/Double::MAX_VALUE)] ) -(def: int-procs - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (bundle.install "frac" (unary _.float/1)) - (bundle.install "char" (unary _.chr/1))))) - (def: frac-procs Bundle (<| (bundle.prefix "frac") @@ -84,10 +84,6 @@ (bundle.install "encode" (unary _.repr/1)) (bundle.install "decode" (unary ///runtime.frac//decode))))) -(def: (text//char [subjectO paramO]) - (Binary (Expression Any)) - (///runtime.text//char subjectO paramO)) - (def: (text//clip [paramO extraO subjectO]) (Trinary (Expression Any)) (///runtime.text//clip subjectO paramO extraO)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux index 81bdc8702..8858e9d4f 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux @@ -274,34 +274,6 @@ @text//clip @text//char)) -(runtime: (array//get array idx) - (with-vars [temp] - ($_ _.then - (_.set (list temp) (_.nth idx array)) - (_.if (_.= _.nil temp) - (_.return ..none) - (_.return (..some temp)))))) - -(runtime: (array//put array idx value) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array))) - -(def: runtime//array - (Statement Any) - ($_ _.then - @array//get - @array//put)) - -(runtime: (box//write value box) - ($_ _.then - (_.set (list (_.nth (_.int +0) box)) value) - (_.return ..unit))) - -(def: runtime//box - (Statement Any) - @box//write) - (def: runtime (Statement Any) ($_ _.then @@ -310,8 +282,6 @@ runtime//i64 runtime//f64 runtime//text - runtime//array - runtime//box )) (def: #export artifact ..prefix) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index a92aea013..5dd2fd1ba 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -4,8 +4,9 @@ [abstract [monad (#+ do)]] [control - [cli (#+ program:)] ["." io (#+ IO io)] + [parser + [cli (#+ program:)]] [security ["!" capability]]] [data diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index f62a071ae..5c5051a2c 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -40,6 +40,7 @@ [python (#+)] [lua (#+)] [ruby (#+)] + [php (#+)] [scheme (#+)]] [tool [compiler @@ -53,6 +54,8 @@ <host-modules>] [ruby (#+) <host-modules>] + [php (#+) + <host-modules>] [scheme (#+) <host-modules>]]]]] ## [control |