From 26c22f6a8dccb41c41ff9f64ac1b7b2d5340baef Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Jun 2021 00:51:05 -0400 Subject: Updates for R compiler. --- commands.md | 2 +- compilers.md | 35 - lux-r/commands.md | 35 + lux-r/project.clj | 3 +- lux-r/source/luxc/lang/host/r.lux | 299 -------- lux-r/source/luxc/lang/translation/r.lux | 216 ------ lux-r/source/luxc/lang/translation/r/case.jvm.lux | 195 ----- .../luxc/lang/translation/r/expression.jvm.lux | 88 --- .../luxc/lang/translation/r/function.jvm.lux | 94 --- lux-r/source/luxc/lang/translation/r/loop.jvm.lux | 37 - .../luxc/lang/translation/r/primitive.jvm.lux | 22 - .../lang/translation/r/procedure/common.jvm.lux | 339 -------- .../luxc/lang/translation/r/procedure/host.jvm.lux | 89 --- .../luxc/lang/translation/r/reference.jvm.lux | 42 - .../source/luxc/lang/translation/r/runtime.jvm.lux | 802 ------------------- .../luxc/lang/translation/r/statement.jvm.lux | 45 -- .../luxc/lang/translation/r/structure.jvm.lux | 31 - lux-r/source/program.lux | 501 ++++++++---- stdlib/source/lux/target/r.lux | 378 +++++++++ .../language/lux/phase/extension/analysis/r.lux | 34 + .../language/lux/phase/extension/generation/r.lux | 17 + .../lux/phase/extension/generation/r/common.lux | 179 +++++ .../lux/phase/extension/generation/r/host.lux | 39 + .../compiler/language/lux/phase/generation/r.lux | 58 ++ .../language/lux/phase/generation/r/case.lux | 239 ++++++ .../language/lux/phase/generation/r/function.lux | 116 +++ .../language/lux/phase/generation/r/loop.lux | 64 ++ .../language/lux/phase/generation/r/primitive.lux | 17 + .../lux/phase/generation/r/procedure/common.lux | 339 ++++++++ .../lux/phase/generation/r/procedure/host.lux | 89 +++ .../language/lux/phase/generation/r/reference.lux | 12 + .../language/lux/phase/generation/r/runtime.lux | 848 +++++++++++++++++++++ .../language/lux/phase/generation/r/structure.lux | 39 + .../language/lux/phase/generation/scheme.lux | 2 - .../lux/phase/generation/scheme/function.lux | 3 +- .../language/lux/phase/generation/scheme/loop.lux | 2 +- .../lux/phase/generation/scheme/runtime.lux | 5 +- .../source/lux/tool/compiler/meta/io/context.lux | 5 +- .../lux/tool/compiler/meta/packager/script.lux | 7 +- 39 files changed, 2861 insertions(+), 2506 deletions(-) create mode 100644 lux-r/commands.md delete mode 100644 lux-r/source/luxc/lang/host/r.lux delete mode 100644 lux-r/source/luxc/lang/translation/r.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/case.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/expression.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/function.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/loop.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/primitive.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/reference.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/runtime.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/statement.jvm.lux delete mode 100644 lux-r/source/luxc/lang/translation/r/structure.jvm.lux create mode 100644 stdlib/source/lux/target/r.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux diff --git a/commands.md b/commands.md index 148ad9040..961d0220b 100644 --- a/commands.md +++ b/commands.md @@ -44,7 +44,7 @@ cd ~/lux/lux-bootstrapper/ && lein clean && lein install ## Run JBE ``` -cd ~/lux/jbe/ && ./jbe.sh +cd ~/lux/jbe/bin/ && java ee.ioc.cs.jbe.browser.BrowserApplication ``` --- diff --git a/compilers.md b/compilers.md index 5494eafd4..4277a07f7 100644 --- a/compilers.md +++ b/compilers.md @@ -1,38 +1,3 @@ -# R compiler - -## Test - -``` -cd ~/lux/lux-r/ && lein lux auto test -cd ~/lux/lux-r/ && lein clean && lein lux auto test -``` - -## Build - -``` -cd ~/lux/lux-r/ && lein lux auto build -cd ~/lux/lux-r/ && lein clean && lein lux auto build -``` - -## REPL - -``` -cd ~/lux/lux-r/ && java -jar target/program.jar repl --source ~/lux/stdlib/source --target ~/lux/stdlib/target -``` - -## Try - -``` -cd ~/lux/lux-r/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux -cd ~/lux/stdlib/ && lein clean && cd ~/lux/lux-r/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux -cd ~/lux/stdlib/ && lein clean && cd ~/lux/lux-r/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --library ~/lux/stdlib/target/library.tar --target ~/lux/stdlib/target --module test/lux -cd ~/lux/lux-r/ && java -jar target/program.jar export --source ~/lux/stdlib/source --target ~/lux/stdlib/target - -cd ~/lux/stdlib/target/ && java -jar program.jar -``` - ---- - # Compiler trial ## Build diff --git a/lux-r/commands.md b/lux-r/commands.md new file mode 100644 index 000000000..dd982fab6 --- /dev/null +++ b/lux-r/commands.md @@ -0,0 +1,35 @@ +# R compiler + +## Test + +``` +cd ~/lux/lux-r/ && lein lux auto test +cd ~/lux/lux-r/ && lein clean && lein lux auto test +``` + +## Build + +``` +## Develop +cd ~/lux/lux-r/ \ +&& lein clean \ +&& lein lux auto build +``` + +## REPL + +``` +cd ~/lux/lux-r/ && java -jar target/program.jar repl --source ~/lux/stdlib/source --target ~/lux/stdlib/target +``` + +## Try + +``` +cd ~/lux/lux-r/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +cd ~/lux/stdlib/ && lein clean && cd ~/lux/lux-r/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +cd ~/lux/stdlib/ && lein clean && cd ~/lux/lux-r/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --library ~/lux/stdlib/target/library.tar --target ~/lux/stdlib/target --module test/lux +cd ~/lux/lux-r/ && java -jar target/program.jar export --source ~/lux/stdlib/source --target ~/lux/stdlib/target + +cd ~/lux/stdlib/target/ && java -jar program.jar +``` + diff --git a/lux-r/project.clj b/lux-r/project.clj index 96e02e021..ce41ff448 100644 --- a/lux-r/project.clj +++ b/lux-r/project.clj @@ -24,8 +24,7 @@ :dependencies [[com.github.luxlang/luxc-jvm ~version] [com.github.luxlang/stdlib ~version] - ;; JVM Bytecode - [org.ow2.asm/asm-all "5.0.3"]] + [org.renjin/renjin-script-engine "3.5-beta43"]] :manifest {"lux" ~version} :source-paths ["source"] diff --git a/lux-r/source/luxc/lang/host/r.lux b/lux-r/source/luxc/lang/host/r.lux deleted file mode 100644 index 6e4c7fb5b..000000000 --- a/lux-r/source/luxc/lang/host/r.lux +++ /dev/null @@ -1,299 +0,0 @@ -(.module: - [lux #- not or and list if function cond when] - (lux (control pipe) - (data [maybe "maybe/" Functor] - [text] - text/format - [number] - (coll [list "list/" Functor Fold])) - (type abstract))) - -(abstract: #export Single {} Any) -(abstract: #export Poly {} Any) - -(abstract: #export (Var kind) - {} - - Text - - (def: name (All [k] (-> (Var k) Text)) (|>> :representation)) - - (def: #export var (-> Text (Var Single)) (|>> :abstraction)) - (def: #export var-args (Var Poly) (:abstraction "...")) - ) - -(type: #export SVar (Var Single)) -(type: #export PVar (Var Poly)) - -(abstract: #export Expression - {} - - Text - - (def: #export expression (-> Expression Text) (|>> :representation)) - - (def: #export code (-> Text Expression) (|>> :abstraction)) - - (def: (self-contained code) - (-> Text Expression) - (:abstraction - (format "(" code ")"))) - - (def: nest - (-> Text Text) - (|>> (format "\n") - (text.replace-all "\n" "\n "))) - - (def: (_block expression) - (-> Text Text) - (format "{" (nest expression) "\n" "}")) - - (def: #export (block expression) - (-> Expression Expression) - (:abstraction - (format "{" (:representation expression) "}"))) - - (def: #export null - Expression - (|> "NULL" self-contained)) - - (def: #export n/a - Expression - (|> "NA" self-contained)) - - (def: #export not-available Expression n/a) - (def: #export not-applicable Expression n/a) - (def: #export no-answer Expression n/a) - - (def: #export bool - (-> Bit Expression) - (|>> (case> #0 "FALSE" - #1 "TRUE") - self-contained)) - - (def: #export (int value) - (-> Int Expression) - (self-contained - (format "as.integer(" (%i value) ")"))) - - (def: #export float - (-> Frac Expression) - (|>> (cond> [(f/= number.positive-infinity)] - [(new> "1.0/0.0")] - - [(f/= number.negative-infinity)] - [(new> "-1.0/0.0")] - - [(f/= number.not-a-number)] - [(new> "0.0/0.0")] - - ## else - [%f]) - self-contained)) - - (def: #export string - (-> Text Expression) - (|>> %t self-contained)) - - (def: (composite-literal left-delimiter right-delimiter entry-serializer) - (All [a] (-> Text Text (-> a Text) - (-> (List a) Expression))) - (.function (_ entries) - (self-contained - (format left-delimiter - (|> entries (list/map entry-serializer) (text.join-with ",")) - right-delimiter)))) - - (def: #export named-list - (-> (List [Text Expression]) Expression) - (composite-literal "list(" ")" (.function (_ [key value]) - (format key "=" (:representation value))))) - - (template [ ] - [(def: #export - (-> (List Expression) Expression) - (composite-literal (format "(") ")" expression))] - - [vector "c"] - [list "list"] - ) - - (def: #export (slice from to list) - (-> Expression Expression Expression Expression) - (self-contained - (format (:representation list) - "[" (:representation from) ":" (:representation to) "]"))) - - (def: #export (slice-from from list) - (-> Expression Expression Expression) - (self-contained - (format (:representation list) - "[-1" ":-" (:representation from) "]"))) - - (def: #export (apply args func) - (-> (List Expression) Expression Expression) - (self-contained - (format (:representation func) "(" (text.join-with "," (list/map expression args)) ")"))) - - (def: #export (apply-kw args kw-args func) - (-> (List Expression) (List [Text Expression]) Expression Expression) - (self-contained - (format (:representation func) - (format "(" - (text.join-with "," (list/map expression args)) "," - (text.join-with "," (list/map (.function (_ [key val]) - (format key "=" (expression val))) - kw-args)) - ")")))) - - (def: #export (nth idx list) - (-> Expression Expression Expression) - (self-contained - (format (:representation list) "[[" (:representation idx) "]]"))) - - (def: #export (if test then else) - (-> Expression Expression Expression Expression) - (self-contained - (format "if(" (:representation test) ")" - " " (.._block (:representation then)) - " else " (.._block (:representation else))))) - - (def: #export (when test then) - (-> Expression Expression Expression) - (self-contained - (format "if(" (:representation test) ") {" - (.._block (:representation then)) - "\n" "}"))) - - (def: #export (cond clauses else) - (-> (List [Expression Expression]) Expression Expression) - (list/fold (.function (_ [test then] next) - (if test then next)) - else - (list.reverse clauses))) - - (template [ ] - [(def: #export ( param subject) - (-> Expression Expression Expression) - (self-contained - (format (:representation subject) - " " " " - (:representation param))))] - - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [%% "%%"] - [** "**"] - [or "||"] - [and "&&"] - ) - - (def: #export @@ - (All [k] (-> (Var k) Expression)) - (|>> ..name self-contained)) - - (def: #export global - (-> Text Expression) - (|>> var @@)) - - (template [ ] - [(def: #export ( param subject) - (-> Expression Expression Expression) - (..apply (.list subject param) (..global )))] - - [bit-or "bitwOr"] - [bit-and "bitwAnd"] - [bit-xor "bitwXor"] - [bit-shl "bitwShiftL"] - [bit-ushr "bitwShiftR"] - ) - - (def: #export (bit-not subject) - (-> Expression Expression) - (..apply (.list subject) (..global "bitwNot"))) - - (template [ ] - [(def: #export - (-> Expression Expression) - (|>> :representation (format ) self-contained))] - - [not "!"] - [negate "-"] - ) - - (def: #export (length list) - (-> Expression Expression) - (..apply (.list list) (..global "length"))) - - (def: #export (range from to) - (-> Expression Expression Expression) - (self-contained - (format (:representation from) ":" (:representation to)))) - - (def: #export (function inputs body) - (-> (List (Ex [k] (Var k))) Expression Expression) - (let [args (|> inputs (list/map ..name) (text.join-with ", "))] - (self-contained - (format "function(" args ") " - (.._block (:representation body)))))) - - (def: #export (try body warning error finally) - (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression) - (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text) - (.function (_ parameter value preparation) - (|> value - (maybe/map (|>> :representation preparation (format ", " parameter " = "))) - (maybe.default ""))))] - (self-contained - (format "tryCatch(" - (.._block (:representation body)) - (optional "warning" warning id) - (optional "error" error id) - (optional "finally" finally .._block) - ")")))) - - (def: #export (while test body) - (-> Expression Expression Expression) - (self-contained - (format "while (" (:representation test) ") " - (.._block (:representation body))))) - - (def: #export (for-in var inputs body) - (-> SVar Expression Expression Expression) - (self-contained - (format "for (" (..name var) " in " (..expression inputs) ")" - (.._block (:representation body))))) - - (template [ ] - [(def: #export ( message) - (-> Expression Expression) - (..apply (.list message) (..global )))] - - [stop "stop"] - [print "print"] - ) - - (def: #export (set! var value) - (-> (Var Single) Expression Expression) - (self-contained - (format (..name var) " <- " (:representation value)))) - - (def: #export (set-nth! idx value list) - (-> Expression Expression SVar Expression) - (self-contained - (format (..name list) "[[" (:representation idx) "]] <- " (:representation value)))) - - (def: #export (then pre post) - (-> Expression Expression Expression) - (:abstraction - (format (:representation pre) - "\n" - (:representation post)))) - ) diff --git a/lux-r/source/luxc/lang/translation/r.lux b/lux-r/source/luxc/lang/translation/r.lux deleted file mode 100644 index a4a3db1f5..000000000 --- a/lux-r/source/luxc/lang/translation/r.lux +++ /dev/null @@ -1,216 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - pipe - [monad #+ do]) - (data [bit] - [maybe] - ["e" error #+ Error] - [text "text/" Eq] - text/format - (coll [array])) - [macro] - [io #+ IO Process io] - [host #+ class: interface: object] - (world [file #+ File])) - (luxc [lang] - (lang [".L" variable #+ Register] - (host [r #+ Expression])) - [".C" io])) - -(template [] - [(exception: #export ( {message Text}) - message)] - - [No-Active-Module-Buffer] - [Cannot-Execute] - - [No-Anchor] - ) - -(host.import: java/lang/Object) - -(host.import: java/lang/String - (getBytes [String] #try [byte])) - -(host.import: java/lang/CharSequence) - -(host.import: java/lang/Appendable - (append [CharSequence] Appendable)) - -(host.import: java/lang/StringBuilder - (new []) - (toString [] String)) - -(host.import: javax/script/ScriptEngine - (eval [String] #try #? Object)) - -(host.import: javax/script/ScriptEngineFactory - (getScriptEngine [] ScriptEngine)) - -(type: #export Anchor [Text Register]) - -(type: #export Host - {#context [Text Nat] - #anchor (Maybe Anchor) - #loader (-> Expression (Error Any)) - #interpreter (-> Expression (Error Object)) - #module-buffer (Maybe StringBuilder) - #program-buffer StringBuilder}) - -(def: #export init - (IO Host) - (io (let [interpreter (|> (undefined) - (ScriptEngineFactory::getScriptEngine []))] - {#context ["" +0] - #anchor #.None - #loader (function (_ code) - (do e.Monad - [_ (ScriptEngine::eval [(r.expression code)] interpreter)] - (wrap []))) - #interpreter (function (_ code) - (do e.Monad - [output (ScriptEngine::eval [(r.expression code)] interpreter)] - (wrap (maybe.default (:coerce Object []) - output)))) - #module-buffer #.None - #program-buffer (StringBuilder::new [])}))) - -(def: #export r-module-name Text "module.r") - -(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 "f___" (%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 [ ] - [(def: ( code) - (-> Expression (Meta )) - (function (_ compiler) - (let [runner (|> compiler (get@ #.host) (:coerce Host) (get@ ))] - (case (runner code) - (#e.Error error) - ((lang.throw Cannot-Execute error) compiler) - - (#e.Success output) - (#e.Success [compiler output])))))] - - [load! #loader Any] - [interpret #interpreter Object] - ) - -(def: #export variant-tag-field "luxVT") -(def: #export variant-flag-field "luxVF") -(def: #export variant-value-field "luxVV") - -(def: #export int-high-field "luxIH") -(def: #export int-low-field "luxIL") - -(def: #export unit Text "") - -(def: #export (definition-name [module name]) - (-> Name Text) - (lang.normalize-name (format module "$" name))) - -(def: #export (save code) - (-> Expression (Meta Any)) - (do macro.Monad - [module-buffer module-buffer - #let [_ (Appendable::append [(:coerce CharSequence (r.expression code))] - module-buffer)]] - (load! code))) - -(def: #export run interpret) - -(def: #export (save-module! target) - (-> File (Meta (Process Any))) - (do macro.Monad - [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) "/" r-module-name) - (|> module-code - (String::getBytes ["UTF-8"]) - e.assume))))) diff --git a/lux-r/source/luxc/lang/translation/r/case.jvm.lux b/lux-r/source/luxc/lang/translation/r/case.jvm.lux deleted file mode 100644 index 42460b620..000000000 --- a/lux-r/source/luxc/lang/translation/r/case.jvm.lux +++ /dev/null @@ -1,195 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [number] - [text] - text/format - (coll [list "list/" Functor Fold] - (set ["set" unordered #+ Set]))) - [macro #+ "meta/" Monad] - (macro [code])) - (luxc [lang] - (lang [".L" variable #+ Register Variable] - ["ls" synthesis #+ Synthesis Path] - (host [r #+ Expression SVar @@]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" reference])) - -(def: #export (translate-let translate register valueS bodyS) - (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis - (Meta Expression)) - (do macro.Monad - [valueO (translate valueS) - bodyO (translate bodyS) - #let [$register (referenceT.variable register)]] - (wrap (r.block - ($_ r.then - (r.set! $register valueO) - bodyO))))) - -(def: #export (translate-record-get translate valueS pathP) - (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bit]) - (Meta Expression)) - (do macro.Monad - [valueO (translate valueS)] - (wrap (list/fold (function (_ [idx tail?] source) - (let [method (if tail? - runtimeT.product//right - runtimeT.product//left)] - (method source (r.int (:coerce Int idx))))) - valueO - pathP)))) - -(def: #export (translate-if testO thenO elseO) - (-> Expression Expression Expression Expression) - (r.if testO thenO elseO)) - -(def: $savepoint (r.var "lux_pm_cursor_savepoint")) -(def: $cursor (r.var "lux_pm_cursor")) - -(def: top r.length) -(def: next (|>> r.length (r.+ (r.int 1)))) -(def: (push! value var) - (-> Expression SVar Expression) - (r.set-nth! (next (@@ var)) value var)) -(def: (pop! var) - (-> SVar Expression) - (r.set-nth! (top (@@ var)) r.null var)) - -(def: (push-cursor! value) - (-> Expression Expression) - (push! value $cursor)) - -(def: save-cursor! - Expression - (push! (r.slice (r.float 1.0) (r.length (@@ $cursor)) (@@ $cursor)) - $savepoint)) - -(def: restore-cursor! - Expression - (r.set! $cursor (r.nth (top (@@ $savepoint)) (@@ $savepoint)))) - -(def: cursor-top - Expression - (|> (@@ $cursor) (r.nth (top (@@ $cursor))))) - -(def: pop-cursor! - Expression - (pop! $cursor)) - -(def: pm-error (r.string "PM-ERROR")) - -(def: fail-pm! (r.stop pm-error)) - -(def: $temp (r.var "lux_pm_temp")) - -(exception: #export (Unrecognized-Path {message Text}) - message) - -(def: $alt_error (r.var "alt_error")) - -(def: (pm-catch handler) - (-> Expression Expression) - (r.function (list $alt_error) - (r.if (|> (@@ $alt_error) (r.= pm-error)) - handler - (r.stop (@@ $alt_error))))) - -(def: (translate-pattern-matching' translate pathP) - (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) - (case pathP - (^code ("lux case exec" (~ bodyS))) - (do macro.Monad - [bodyO (translate bodyS)] - (wrap bodyO)) - - (^code ("lux case pop")) - (meta/wrap pop-cursor!) - - (^code ("lux case bind" (~ [_ (#.Nat register)]))) - (meta/wrap (r.set! (referenceT.variable register) cursor-top)) - - (^template [ ] - [_ ( value)] - (meta/wrap (r.when (r.not (r.= (|> value ) cursor-top)) - fail-pm!))) - ([#.Bit r.bool] - [#.Frac r.float] - [#.Text r.string]) - - (^template [ ] - [_ ( value)] - (meta/wrap (r.when (r.not (runtimeT.int//= (|> value ) cursor-top)) - fail-pm!))) - ([#.Nat (<| runtimeT.int (:coerce Int))] - [#.Int runtimeT.int] - [#.Rev (<| runtimeT.int (:coerce Int))]) - - (^template [ ] - (^code ( (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor! ( cursor-top (r.int (:coerce Int idx)))))) - (["lux case tuple left" runtimeT.product//left] - ["lux case tuple right" runtimeT.product//right]) - - (^template [ ] - (^code ( (~ [_ (#.Nat idx)]))) - (meta/wrap ($_ r.then - (r.set! $temp (runtimeT.sum//get cursor-top (r.int (:coerce Int idx)) )) - (r.if (r.= r.null (@@ $temp)) - fail-pm! - (push-cursor! (@@ $temp)))))) - (["lux case variant left" r.null] - ["lux case variant right" (r.string "")]) - - (^code ("lux case seq" (~ leftP) (~ rightP))) - (do macro.Monad - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap ($_ r.then - leftO - rightO))) - - (^code ("lux case alt" (~ leftP) (~ rightP))) - (do macro.Monad - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap (r.try ($_ r.then - save-cursor! - leftO) - #.None - (#.Some (pm-catch ($_ r.then - restore-cursor! - rightO))) - #.None))) - - _ - (lang.throw Unrecognized-Path (%code pathP)) - )) - -(def: (translate-pattern-matching translate pathP) - (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) - (do macro.Monad - [pattern-matching! (translate-pattern-matching' translate pathP)] - (wrap (r.try pattern-matching! - #.None - (#.Some (pm-catch (r.stop (r.string "Invalid expression for pattern-matching.")))) - #.None)))) - -(def: (initialize-pattern-matching! stack-init) - (-> Expression Expression) - ($_ r.then - (r.set! $cursor (r.list (list stack-init))) - (r.set! $savepoint (r.list (list))))) - -(def: #export (translate-case translate valueS pathP) - (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) - (do macro.Monad - [valueO (translate valueS) - pattern-matching! (translate-pattern-matching translate pathP)] - (wrap (r.block - ($_ r.then - (initialize-pattern-matching! valueO) - pattern-matching!))))) diff --git a/lux-r/source/luxc/lang/translation/r/expression.jvm.lux b/lux-r/source/luxc/lang/translation/r/expression.jvm.lux deleted file mode 100644 index 3c41fbe63..000000000 --- a/lux-r/source/luxc/lang/translation/r/expression.jvm.lux +++ /dev/null @@ -1,88 +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] - (host [r #+ Expression]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" structure] - [".T" reference] - [".T" function] - [".T" case] - [".T" procedure]) - ) - -(template [] - [(exception: #export ( {message Text}) - message)] - - [Invalid-Function-Syntax] - [Unrecognized-Synthesis] - ) - -(def: #export (translate synthesis) - (-> ls.Synthesis (Meta Expression)) - (case synthesis - (^code []) - (:: macro.Monad wrap runtimeT.unit) - - (^template [ ] - [_ ( value)] - ( value)) - ([#.Bit primitiveT.translate-bit] - [#.Nat primitiveT.translate-nat] - [#.Int primitiveT.translate-int] - [#.Rev primitiveT.translate-rev] - [#.Frac primitiveT.translate-frac] - [#.Text primitiveT.translate-text]) - - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) - - (^code [(~ singleton)]) - (translate singleton) - - (^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 - ## [translation (extensionL.find-translation procedure)] - ## (translation argsS)) - - _ - (&.throw Unrecognized-Synthesis (%code synthesis)))) diff --git a/lux-r/source/luxc/lang/translation/r/function.jvm.lux b/lux-r/source/luxc/lang/translation/r/function.jvm.lux deleted file mode 100644 index f39a5e1a2..000000000 --- a/lux-r/source/luxc/lang/translation/r/function.jvm.lux +++ /dev/null @@ -1,94 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [product] - [text] - text/format - (coll [list "list/" Functor Fold])) - [macro]) - (luxc ["&" lang] - (lang ["ls" synthesis] - [".L" variable #+ Variable] - (host [r #+ Expression @@]))) - [//] - (// [".T" reference])) - -(def: #export (translate-apply translate functionS argsS+) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) - (do {@ macro.Monad} - [functionO (translate functionS) - argsO+ (monad.map @ translate argsS+)] - (wrap (r.apply argsO+ functionO)))) - -(def: $curried (r.var "curried")) - -(def: (input-declaration register) - (r.set! (referenceT.variable (inc register)) - (|> (@@ $curried) (r.nth (|> register inc .int r.int))))) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Expression (Meta Expression)) - (let [$closure (r.var (format function-name "___CLOSURE"))] - (case inits - #.Nil - (do macro.Monad - [_ (//.save function-definition)] - (wrap (r.global function-name))) - - _ - (do macro.Monad - [_ (//.save (r.set! $closure - (r.function (|> (list.enumerate inits) - (list/map (|>> product.left referenceT.closure))) - ($_ r.then - function-definition - (r.global function-name)))))] - (wrap (r.apply inits (@@ $closure))))))) - -(def: #export (translate-function translate env arity bodyS) - (-> (-> ls.Synthesis (Meta Expression)) - (List Variable) ls.Arity ls.Synthesis - (Meta Expression)) - (do {@ macro.Monad} - [[function-name bodyO] (//.with-sub-context - (do @ - [function-name //.context] - (//.with-anchor [function-name +1] - (translate bodyS)))) - closureO+ (monad.map @ referenceT.translate-variable env) - #let [arityO (|> arity .int r.int) - $num_args (r.var "num_args") - $function (r.var function-name) - var-args (r.code (format "list" (r.expression (@@ r.var-args)))) - apply-poly (function (_ args func) - (r.apply (list func args) (r.global "do.call")))]] - (with-closure function-name closureO+ - (r.set! $function - (r.function (list r.var-args) - ($_ r.then - (r.set! $curried var-args) - (r.set! $num_args (r.length (@@ $curried))) - (r.cond (list [(|> (@@ $num_args) (r.= arityO)) - ($_ r.then - (r.set! (referenceT.variable +0) (@@ $function)) - (|> (list.n/range +0 (dec arity)) - (list/map input-declaration) - (list/fold r.then bodyO)))] - [(|> (@@ $num_args) (r.> arityO)) - (let [arity-args (r.slice (r.int 1) arityO (@@ $curried)) - output-func-args (r.slice (|> arityO (r.+ (r.int 1))) - (@@ $num_args) - (@@ $curried))] - (|> (@@ $function) - (apply-poly arity-args) - (apply-poly output-func-args)))]) - ## (|> (@@ $num_args) (r.< arityO)) - (let [$missing (r.var "missing")] - (r.function (list r.var-args) - ($_ r.then - (r.set! $missing var-args) - (|> (@@ $function) - (apply-poly (r.apply (list (@@ $curried) (@@ $missing)) - (r.global "append")))))))))))) - )) diff --git a/lux-r/source/luxc/lang/translation/r/loop.jvm.lux b/lux-r/source/luxc/lang/translation/r/loop.jvm.lux deleted file mode 100644 index f1197e5ce..000000000 --- a/lux-r/source/luxc/lang/translation/r/loop.jvm.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor])) - [macro]) - (luxc [lang] - (lang ["ls" synthesis] - (host [r #+ Expression @@]))) - [//] - (// [".T" reference])) - -(def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis - (Meta Expression)) - (do {@ macro.Monad} - [loop-name (|> (macro.gensym "loop") - (:: @ map (|>> %code lang.normalize-name))) - initsO+ (monad.map @ translate initsS+) - bodyO (//.with-anchor [loop-name offset] - (translate bodyS)) - #let [$loop-name (r.var loop-name) - @loop-name (@@ $loop-name)] - _ (//.save (r.set! $loop-name - (r.function (|> (list.n/range +0 (dec (list.size initsS+))) - (list/map (|>> (n/+ offset) referenceT.variable))) - bodyO)))] - (wrap (r.apply initsO+ @loop-name)))) - -(def: #export (translate-recur translate argsS+) - (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis) - (Meta Expression)) - (do {@ macro.Monad} - [[loop-name offset] //.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (r.apply argsO+ (r.global loop-name))))) diff --git a/lux-r/source/luxc/lang/translation/r/primitive.jvm.lux b/lux-r/source/luxc/lang/translation/r/primitive.jvm.lux deleted file mode 100644 index 8bc7da848..000000000 --- a/lux-r/source/luxc/lang/translation/r/primitive.jvm.lux +++ /dev/null @@ -1,22 +0,0 @@ -(.module: - lux - (lux [macro "meta/" Monad]) - (luxc (lang (host [r #+ Expression]))) - [//] - (// [".T" runtime])) - -(def: #export translate-bit - (-> Bit (Meta Expression)) - (|>> r.bool meta/wrap)) - -(def: #export translate-int - (-> Int (Meta Expression)) - (|>> runtimeT.int meta/wrap)) - -(def: #export translate-frac - (-> Frac (Meta Expression)) - (|>> r.float meta/wrap)) - -(def: #export translate-text - (-> Text (Meta Expression)) - (|>> r.string meta/wrap)) diff --git a/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux b/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux deleted file mode 100644 index 85ccd90dc..000000000 --- a/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux +++ /dev/null @@ -1,339 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number] - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [r #+ Expression]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .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 {@ macro.monad} - [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 - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do {@ macro.Monad} - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftO rightO]) - Binary - (r.apply (list leftO rightO) - (r.global "identical"))) - -(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) - (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 [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [bit//and runtimeT.bit//and] - [bit//or runtimeT.bit//or] - [bit//xor runtimeT.bit//xor] - ) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - ( (runtimeT.int64-low paramO) subjectO))] - - [bit//left-shift runtimeT.bit//left-shift] - [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift] - [bit//logical-right-shift runtimeT.bit//logical-right-shift] - ) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash) - (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 [ ] - [(def: ( _) - Nullary - ( ))] - - [frac//smallest Double::MIN_VALUE r.float] - [frac//min (f/* -1.0 Double::MAX_VALUE) r.float] - [frac//max Double::MAX_VALUE r.float] - ) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - (|> subjectO ( paramO)))] - - [int//add runtimeT.int//+] - [int//sub runtimeT.int//-] - [int//mul runtimeT.int//*] - [int//div runtimeT.int///] - [int//rem runtimeT.int//%] - ) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [frac//add r.+] - [frac//sub r.-] - [frac//mul r.*] - [frac//div r./] - [frac//rem r.%%] - [frac//= r.=] - [frac//< r.<] - - [text//= r.=] - [text//< r.<] - ) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [int//= runtimeT.int//=] - [int//< runtimeT.int//<] - ) - -(def: (apply1 func) - (-> Expression (-> Expression Expression)) - (function (_ value) - (r.apply (list value) func))) - -(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8")))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "to-frac" (unary runtimeT.int//to-float)) - (install "char" (unary int//char))))) - -(def: (frac//encode value) - (-> Expression Expression) - (r.apply (list (r.string "%f") value) (r.global "sprintf"))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (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 (r.global "as.integer")))) - (install "encode" (unary frac//encode)) - (install "decode" (unary runtimeT.frac//decode))))) - -## [[Text]] -(def: (text//concat [subjectO paramO]) - Binary - (r.apply (list subjectO paramO) (r.global "paste0"))) - -(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) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary text//concat)) - (install "index" (trinary text//index)) - (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float))) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - ))) - -## [[IO]] -(def: (io//exit input) - Unary - (r.apply-kw (list) - (list ["status" (runtimeT.int//to-float input)]) - (r.global "quit"))) - -(def: (void code) - (-> Expression Expression) - (r.block (r.then code runtimeT.unit))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash) - (install "log" (unary (|>> r.print ..void))) - (install "error" (unary r.stop)) - (install "exit" (unary io//exit)) - (install "current-time" (nullary (function (_ _) - (runtimeT.io//current-time! runtimeT.unit))))))) - -## [Bundles] -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> 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/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux b/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux deleted file mode 100644 index 3bd33955f..000000000 --- a/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -## (template [ ] -## [(def: ( _) @.Nullary )] - -## [lua//nil "nil"] -## [lua//table "{}"] -## ) - -## (def: (lua//global proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list [_ (#.Text name)])) -## (do macro.Monad -## [] -## (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} -## [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) -## (@.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} -## [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) -## (@.install "call" table//call) -## (@.install "get" (@.binary table//get)) -## (@.install "set" (@.trinary table//set))))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "lua") - (dict.new text.Hash) - ## (|> lua-procs - ## (dict.merge table-procs)) - )) diff --git a/lux-r/source/luxc/lang/translation/r/reference.jvm.lux b/lux-r/source/luxc/lang/translation/r/reference.jvm.lux deleted file mode 100644 index 7de1c74ee..000000000 --- a/lux-r/source/luxc/lang/translation/r/reference.jvm.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - lux - (lux [macro] - (data [text] - text/format)) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host [r #+ Expression SVar @@]))) - [//] - (// [".T" runtime])) - -(template [ ] - [(def: #export ( register) - (-> Register SVar) - (r.var (format (%i (.int register))))) - - (def: #export ( register) - (-> Register (Meta Expression)) - (:: macro.Monad wrap (@@ ( register))))] - - [closure translate-captured "c"] - [variable translate-local "v"]) - -(def: #export (local var) - (-> Variable SVar) - (if (variableL.captured? var) - (closure (variableL.captured-register var)) - (variable (.nat var)))) - -(def: #export (translate-variable var) - (-> Variable (Meta Expression)) - (if (variableL.captured? var) - (translate-captured (variableL.captured-register var)) - (translate-local (.nat var)))) - -(def: #export global - (-> Name SVar) - (|>> //.definition-name r.var)) - -(def: #export (translate-definition name) - (-> Name (Meta Expression)) - (:: macro.Monad wrap (@@ (global name)))) diff --git a/lux-r/source/luxc/lang/translation/r/runtime.jvm.lux b/lux-r/source/luxc/lang/translation/r/runtime.jvm.lux deleted file mode 100644 index d641041d2..000000000 --- a/lux-r/source/luxc/lang/translation/r/runtime.jvm.lux +++ /dev/null @@ -1,802 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad] - [monad #+ do]) - (data [bit] - [number (#+ hex) ("int/" Interval)] - text/format - (coll [list "list/" Monad])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [io #+ Process]) - [//] - (luxc [lang] - (lang (host [r #+ SVar Expression @@])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Expression (r.string //.unit)) - -(def: full-32 (hex "+FFFFFFFF")) -(def: half-32 (hex "+7FFFFFFF")) -(def: post-32 (hex "+100000000")) - -(def: (cap-32 input) - (-> Nat Int) - (cond (n/> full-32 input) - (|> input (bit.and full-32) cap-32) - - (n/> half-32 input) - (|> post-32 (n/- input) .int (i/* -1)) - - ## else - (.int input))) - -(def: high-32 (bit.logical-right-shift +32)) -(def: low-32 (|>> (bit.and (hex "+FFFFFFFF")))) - -(def: #export (int value) - (-> Int Expression) - (let [value (.nat value) - high (|> value ..high-32 cap-32) - low (|> value ..low-32 cap-32)] - (r.named-list (list [//.int-high-field (r.int high)] - [//.int-low-field (r.int low)])))) - -(def: (flag value) - (-> Bit Expression) - (if value - (r.string "") - r.null)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Expression) - (r.named-list (list [//.variant-tag-field tag] - [//.variant-flag-field last?] - [//.variant-value-field value]))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Expression) - (variant' (r.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Expression - (variant +0 #0 unit)) - -(def: #export some - (-> Expression Expression) - (variant +1 #1)) - -(def: #export left - (-> Expression Expression) - (variant +0 #0)) - -(def: #export right - (-> Expression Expression) - (variant +1 #1)) - -(type: Runtime Expression) - -(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 (` (r.var (~ (code.text runtime)))) - @runtime (` (@@ (~ $runtime))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (r.var) (`)) - args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` r.Expression))) - r.Expression))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (r.apply (list (~+ argsC+)) (~ @runtime))))))) - (` (def: (~ implementation) - r.Expression - (~ (case argsC+ - #.Nil - (` (r.set! (~ $runtime) (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (r.set! (~ $runtime) - (r.function (list (~+ argsLC+)) - (~ definition))))))))))))) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (r.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) - list/join))] - (~ body)))))) - -(def: high-shift (r.bit-shl (r.int 32))) - -(runtime: f2^32 (|> (r.int 2) (r.** (r.int 32)))) -(runtime: f2^63 (|> (r.int 2) (r.** (r.int 63)))) - -(def: (as-double value) - (-> Expression Expression) - (r.apply (list value) (r.global "as.double"))) - -(def: (as-integer value) - (-> Expression Expression) - (r.apply (list value) (r.global "as.integer"))) - -(runtime: (int//unsigned-low input) - (with-vars [low] - ($_ r.then - (r.set! low (|> (@@ input) (r.nth (r.string //.int-low-field)))) - (r.if (|> (@@ low) (r.>= (r.int 0))) - (@@ low) - (|> (@@ low) (r.+ f2^32)))))) - -(runtime: (int//to-float input) - (let [high (|> (@@ input) - (r.nth (r.string //.int-high-field)) - high-shift) - low (|> (@@ input) - int//unsigned-low)] - (|> high (r.+ low) as-double))) - -(runtime: (int//new high low) - (r.named-list (list [//.int-high-field (as-integer (@@ high))] - [//.int-low-field (as-integer (@@ low))]))) - -(template [ ] - [(runtime: - (..int ))] - - [int//zero 0] - [int//one 1] - [int//min int/bottom] - [int//max int/top] - ) - -(def: #export int64-high (r.nth (r.string //.int-high-field))) -(def: #export int64-low (r.nth (r.string //.int-low-field))) - -(runtime: (bit//not input) - (int//new (|> (@@ input) int64-high r.bit-not) - (|> (@@ input) int64-low r.bit-not))) - -(runtime: (int//+ param subject) - (with-vars [sH sL pH pL - x00 x16 x32 x48] - ($_ r.then - (r.set! sH (|> (@@ subject) int64-high)) - (r.set! sL (|> (@@ subject) int64-low)) - (r.set! pH (|> (@@ param) int64-high)) - (r.set! pL (|> (@@ param) int64-low)) - (let [bits16 (r.code "0xFFFF") - move-top-16 (r.bit-shl (r.int 16)) - top-16 (r.bit-ushr (r.int 16)) - bottom-16 (r.bit-and bits16) - split-16 (function (_ source) - [(|> source top-16) - (|> source bottom-16)]) - split-int (function (_ high low) - [(split-16 high) - (split-16 low)]) - - [[s48 s32] [s16 s00]] (split-int (@@ sH) (@@ sL)) - [[p48 p32] [p16 p00]] (split-int (@@ pH) (@@ pL)) - new-half (function (_ top bottom) - (|> top bottom-16 move-top-16 - (r.bit-or (bottom-16 bottom))))] - ($_ r.then - (r.set! x00 (|> s00 (r.+ p00))) - (r.set! x16 (|> (@@ x00) top-16 (r.+ s16) (r.+ p16))) - (r.set! x32 (|> (@@ x16) top-16 (r.+ s32) (r.+ p32))) - (r.set! x48 (|> (@@ x32) top-16 (r.+ s48) (r.+ p48))) - (int//new (new-half (@@ x48) (@@ x32)) - (new-half (@@ x16) (@@ x00)))))))) - -(runtime: (int//= reference sample) - (let [n/a? (function (_ value) - (r.apply (list value) (r.global "is.na"))) - isTRUE? (function (_ value) - (r.apply (list value) (r.global "isTRUE"))) - comparison (: (-> (-> Expression Expression) Expression) - (function (_ field) - (|> (|> (field (@@ sample)) (r.= (field (@@ reference)))) - (r.or (|> (n/a? (field (@@ sample))) - (r.and (n/a? (field (@@ reference)))))))))] - (|> (comparison int64-high) - (r.and (comparison int64-low)) - isTRUE?))) - -(runtime: (int//negate input) - (r.if (|> (@@ input) (int//= int//min)) - int//min - (|> (@@ input) bit//not (int//+ int//one)))) - -(runtime: int//-one - (int//negate int//one)) - -(runtime: (int//- param subject) - (int//+ (int//negate (@@ param)) (@@ subject))) - -(runtime: (int//< reference sample) - (with-vars [r-? s-?] - ($_ r.then - (r.set! s-? (|> (@@ sample) int64-high (r.< (r.int 0)))) - (r.set! r-? (|> (@@ reference) int64-high (r.< (r.int 0)))) - (|> (|> (@@ s-?) (r.and (r.not (@@ r-?)))) - (r.or (|> (r.not (@@ s-?)) (r.and (@@ r-?)) r.not)) - (r.or (|> (@@ sample) - (int//- (@@ reference)) - int64-high - (r.< (r.int 0)))))))) - -(runtime: (int//from-float input) - (r.cond (list [(r.apply (list (@@ input)) (r.global "is.nan")) - int//zero] - [(|> (@@ input) (r.<= (r.negate f2^63))) - int//min] - [(|> (@@ input) (r.+ (r.float 1.0)) (r.>= f2^63)) - int//max] - [(|> (@@ input) (r.< (r.float 0.0))) - (|> (@@ input) r.negate int//from-float int//negate)]) - (int//new (|> (@@ input) (r./ f2^32)) - (|> (@@ input) (r.%% f2^32))))) - -(runtime: (int//* param subject) - (with-vars [sH sL pH pL - x00 x16 x32 x48] - ($_ r.then - (r.set! sH (|> (@@ subject) int64-high)) - (r.set! pH (|> (@@ param) int64-high)) - (let [negative-subject? (|> (@@ sH) (r.< (r.int 0))) - negative-param? (|> (@@ pH) (r.< (r.int 0)))] - (r.cond (list [negative-subject? - (r.if negative-param? - (int//* (int//negate (@@ param)) - (int//negate (@@ subject))) - (int//negate (int//* (@@ param) - (int//negate (@@ subject)))))] - - [negative-param? - (int//negate (int//* (int//negate (@@ param)) - (@@ subject)))]) - ($_ r.then - (r.set! sL (|> (@@ subject) int64-low)) - (r.set! pL (|> (@@ param) int64-low)) - (let [bits16 (r.code "0xFFFF") - move-top-16 (r.bit-shl (r.int 16)) - top-16 (r.bit-ushr (r.int 16)) - bottom-16 (r.bit-and bits16) - split-16 (function (_ source) - [(|> source top-16) - (|> source bottom-16)]) - split-int (function (_ high low) - [(split-16 high) - (split-16 low)]) - new-half (function (_ top bottom) - (|> top bottom-16 move-top-16 - (r.bit-or (bottom-16 bottom)))) - x16-top (|> (@@ x16) top-16) - x32-top (|> (@@ x32) top-16)] - (with-vars [s48 s32 s16 s00 - p48 p32 p16 p00] - (let [[[_s48 _s32] [_s16 _s00]] (split-int (@@ sH) (@@ sL)) - [[_p48 _p32] [_p16 _p00]] (split-int (@@ pH) (@@ pL)) - set-subject-chunks! ($_ r.then (r.set! s48 _s48) (r.set! s32 _s32) (r.set! s16 _s16) (r.set! s00 _s00)) - set-param-chunks! ($_ r.then (r.set! p48 _p48) (r.set! p32 _p32) (r.set! p16 _p16) (r.set! p00 _p00))] - ($_ r.then - set-subject-chunks! - set-param-chunks! - (r.set! x00 (|> (@@ s00) (r.* (@@ p00)))) - (r.set! x16 (|> (@@ x00) top-16 (r.+ (|> (@@ s16) (r.* (@@ p00)))))) - (r.set! x32 x16-top) - (r.set! x16 (|> (@@ x16) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p16)))))) - (r.set! x32 (|> (@@ x32) (r.+ x16-top) (r.+ (|> (@@ s32) (r.* (@@ p00)))))) - (r.set! x48 x32-top) - (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s16) (r.* (@@ p16)))))) - (r.set! x48 (|> (@@ x48) (r.+ x32-top))) - (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p32)))))) - (r.set! x48 (|> (@@ x48) (r.+ x32-top) - (r.+ (|> (@@ s48) (r.* (@@ p00)))) - (r.+ (|> (@@ s32) (r.* (@@ p16)))) - (r.+ (|> (@@ s16) (r.* (@@ p32)))) - (r.+ (|> (@@ s00) (r.* (@@ p48)))))) - (int//new (new-half (@@ x48) (@@ x32)) - (new-half (@@ x16) (@@ x00)))))) - ))))))) - -(def: (limit-shift! shift) - (-> SVar Expression) - (r.set! shift (|> (@@ shift) (r.bit-and (r.int 63))))) - -(def: (no-shift-clause shift input) - (-> SVar SVar [Expression Expression]) - [(|> (@@ shift) (r.= (r.int 0))) - (@@ input)]) - -(runtime: (bit//left-shift shift input) - ($_ r.then - (limit-shift! shift) - (r.cond (list (no-shift-clause shift input) - [(|> (@@ shift) (r.< (r.int 32))) - (let [mid (|> (int64-low (@@ input)) (r.bit-ushr (|> (r.int 32) (r.- (@@ shift))))) - high (|> (int64-high (@@ input)) - (r.bit-shl (@@ shift)) - (r.bit-or mid)) - low (|> (int64-low (@@ input)) - (r.bit-shl (@@ shift)))] - (int//new high low))]) - (let [high (|> (int64-high (@@ input)) - (r.bit-shl (|> (@@ shift) (r.- (r.int 32)))))] - (int//new high (r.int 0)))))) - -(runtime: (bit//arithmetic-right-shift-32 shift input) - (let [top-bit (|> (@@ input) (r.bit-and (r.int (hex "80000000"))))] - (|> (@@ input) - (r.bit-ushr (@@ shift)) - (r.bit-or top-bit)))) - -(runtime: (bit//arithmetic-right-shift shift input) - ($_ r.then - (limit-shift! shift) - (r.cond (list (no-shift-clause shift input) - [(|> (@@ shift) (r.< (r.int 32))) - (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift))))) - high (|> (int64-high (@@ input)) - (bit//arithmetic-right-shift-32 (@@ shift))) - low (|> (int64-low (@@ input)) - (r.bit-ushr (@@ shift)) - (r.bit-or mid))] - (int//new high low))]) - (let [low (|> (int64-high (@@ input)) - (bit//arithmetic-right-shift-32 (|> (@@ shift) (r.- (r.int 32))))) - high (r.if (|> (int64-high (@@ input)) (r.>= (r.int 0))) - (r.int 0) - (r.int -1))] - (int//new high low))))) - -(runtime: (int/// param subject) - (let [negative? (|>> (int//< int//zero)) - valid-division-check [(|> (@@ param) (int//= int//zero)) - (r.stop (r.string "Cannot divide by zero!"))] - short-circuit-check [(|> (@@ subject) (int//= int//zero)) - int//zero]] - (r.cond (list valid-division-check - short-circuit-check - - [(|> (@@ subject) (int//= int//min)) - (r.cond (list [(|> (|> (@@ param) (int//= int//one)) - (r.or (|> (@@ param) (int//= int//-one)))) - int//min] - [(|> (@@ param) (int//= int//min)) - int//one]) - (with-vars [approximation] - ($_ r.then - (r.set! approximation - (|> (@@ subject) - (bit//arithmetic-right-shift (r.int 1)) - (int/// (@@ param)) - (bit//left-shift (r.int 1)))) - (r.if (|> (@@ approximation) (int//= int//zero)) - (r.if (negative? (@@ param)) - int//one - int//-one) - (let [remainder (int//- (int//* (@@ param) (@@ approximation)) - (@@ subject))] - (|> remainder - (int/// (@@ param)) - (int//+ (@@ approximation))))))))] - [(|> (@@ param) (int//= int//min)) - int//zero] - - [(negative? (@@ subject)) - (r.if (negative? (@@ param)) - (|> (int//negate (@@ subject)) - (int/// (int//negate (@@ param)))) - (|> (int//negate (@@ subject)) - (int/// (@@ param)) - int//negate))] - - [(negative? (@@ param)) - (|> (@@ param) - int//negate - (int/// (@@ subject)) - int//negate)]) - (with-vars [result remainder approximate approximate-result log2 approximate-remainder] - ($_ r.then - (r.set! result int//zero) - (r.set! remainder (@@ subject)) - (r.while (|> (|> (@@ remainder) (int//< (@@ param))) - (r.or (|> (@@ remainder) (int//= (@@ param))))) - (let [calc-rough-estimate (r.apply (list (|> (int//to-float (@@ remainder)) (r./ (int//to-float (@@ param))))) - (r.global "floor")) - calc-approximate-result (int//from-float (@@ approximate)) - calc-approximate-remainder (|> (@@ approximate-result) (int//* (@@ param))) - delta (r.if (|> (r.float 48.0) (r.<= (@@ log2))) - (r.float 1.0) - (r.** (|> (@@ log2) (r.- (r.float 48.0))) - (r.float 2.0)))] - ($_ r.then - (r.set! approximate (r.apply (list (r.float 1.0) calc-rough-estimate) - (r.global "max"))) - (r.set! log2 (let [log (function (_ input) - (r.apply (list input) (r.global "log")))] - (r.apply (list (|> (log (r.int 2)) - (r./ (log (@@ approximate))))) - (r.global "ceil")))) - (r.set! approximate-result calc-approximate-result) - (r.set! approximate-remainder calc-approximate-remainder) - (r.while (|> (negative? (@@ approximate-remainder)) - (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder))))) - ($_ r.then - (r.set! approximate (|> delta (r.- (@@ approximate)))) - (r.set! approximate-result calc-approximate-result) - (r.set! approximate-remainder calc-approximate-remainder))) - (r.set! result (|> (r.if (|> (@@ approximate-result) (int//= int//zero)) - int//one - (@@ approximate-result)) - (int//+ (@@ result)))) - (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder))))))) - (@@ result))) - ))) - -(runtime: (int//% param subject) - (let [flat (|> (@@ subject) (int/// (@@ param)) (int//* (@@ param)))] - (|> (@@ subject) (int//- flat)))) - -(def: runtime//int - Runtime - ($_ r.then - @@int//zero - @@int//one - @@int//min - @@int//max - @@int//= - @@int//< - @@int//+ - @@int//- - @@int//negate - @@int//-one - @@int//unsigned-low - @@int//to-float - @@int//* - @@int/// - @@int//%)) - -(runtime: (lux//try op) - (with-vars [error value] - (r.try ($_ r.then - (r.set! value (r.apply (list ..unit) (@@ op))) - (..right (@@ value))) - #.None - (#.Some (r.function (list error) - (..left (r.nth (r.string "message") - (@@ error))))) - #.None))) - -(runtime: (lux//program-args program-args) - (with-vars [inputs value] - ($_ r.then - (r.set! inputs ..none) - (<| (r.for-in value (@@ program-args)) - (r.set! inputs (..some (r.list (list (@@ value) (@@ inputs)))))) - (@@ inputs)))) - -(def: runtime//lux - Runtime - ($_ r.then - @@lux//try - @@lux//program-args)) - -(def: current-time-float - Expression - (let [raw-time (r.apply (list) (r.global "Sys.time"))] - (r.apply (list raw-time) (r.global "as.numeric")))) - -(runtime: (io//current-time! _) - (|> current-time-float - (r.* (r.float 1,000.0)) - int//from-float)) - -(def: runtime//io - Runtime - ($_ r.then - @@io//current-time!)) - -(def: minimum-index-length - (-> SVar Expression) - (|>> @@ (r.+ (r.int 1)))) - -(def: (product-element product index) - (-> Expression Expression Expression) - (|> product (r.nth (|> index (r.+ (r.int 1)))))) - -(def: (product-tail product) - (-> SVar Expression) - (|> (@@ product) (r.nth (r.length (@@ product))))) - -(def: (updated-index min-length product) - (-> Expression Expression Expression) - (|> min-length (r.- (r.length product)))) - -(runtime: (product//left product index) - (let [$index_min_length (r.var "index_min_length")] - ($_ r.then - (r.set! $index_min_length (minimum-index-length index)) - (r.if (|> (r.length (@@ product)) (r.> (@@ $index_min_length))) - ## No need for recursion - (product-element (@@ product) (@@ index)) - ## Needs recursion - (product//left (product-tail product) - (updated-index (@@ $index_min_length) (@@ product))))))) - -(runtime: (product//right product index) - (let [$index_min_length (r.var "index_min_length")] - ($_ r.then - (r.set! $index_min_length (minimum-index-length index)) - (r.cond (list [## Last element. - (|> (r.length (@@ product)) (r.= (@@ $index_min_length))) - (product-element (@@ product) (@@ index))] - [## Needs recursion - (|> (r.length (@@ product)) (r.< (@@ $index_min_length))) - (product//right (product-tail product) - (updated-index (@@ $index_min_length) (@@ product)))]) - ## Must slice - (|> (@@ product) (r.slice-from (@@ index))))))) - -(runtime: (sum//get sum wanted_tag wants_last) - (let [no-match r.null - sum-tag (|> (@@ sum) (r.nth (r.string //.variant-tag-field))) - sum-flag (|> (@@ sum) (r.nth (r.string //.variant-flag-field))) - sum-value (|> (@@ sum) (r.nth (r.string //.variant-value-field))) - is-last? (|> sum-flag (r.= (r.string ""))) - test-recursion (r.if is-last? - ## Must recurse. - (sum//get sum-value - (|> (@@ wanted_tag) (r.- sum-tag)) - (@@ wants_last)) - no-match)] - (r.cond (list [(r.= sum-tag (@@ wanted_tag)) - (r.if (r.= (@@ wants_last) sum-flag) - sum-value - test-recursion)] - - [(|> (@@ wanted_tag) (r.> sum-tag)) - test-recursion] - - [(|> (|> (@@ wants_last) (r.= (r.string ""))) - (r.and (|> (@@ wanted_tag) (r.< sum-tag)))) - (variant' (|> sum-tag (r.- (@@ wanted_tag))) sum-flag sum-value)]) - - no-match))) - -(def: runtime//adt - Runtime - ($_ r.then - @@product//left - @@product//right - @@sum//get - )) - -(template [ ] - [(runtime: ( mask input) - (int//new ( (int64-high (@@ mask)) - (int64-high (@@ input))) - ( (int64-low (@@ mask)) - (int64-low (@@ input)))))] - - [bit//and r.bit-and] - [bit//or r.bit-or] - [bit//xor r.bit-xor] - ) - -(runtime: (bit//logical-right-shift shift input) - ($_ r.then - (limit-shift! shift) - (r.cond (list (no-shift-clause shift input) - [(|> (@@ shift) (r.< (r.int 32))) - (with-vars [$mid] - (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift))))) - high (|> (int64-high (@@ input)) (r.bit-ushr (@@ shift))) - low (|> (int64-low (@@ input)) - (r.bit-ushr (@@ shift)) - (r.bit-or (r.if (r.apply (list (@@ $mid)) (r.global "is.na")) - (r.int 0) - (@@ $mid))))] - ($_ r.then - (r.set! $mid mid) - (int//new high low))))] - [(|> (@@ shift) (r.= (r.int 32))) - (let [high (int64-high (@@ input))] - (int//new (r.int 0) high))]) - (let [low (|> (int64-high (@@ input)) (r.bit-ushr (|> (@@ shift) (r.- (r.int 32)))))] - (int//new (r.int 0) low))))) - -(def: runtime//bit - Runtime - ($_ r.then - @@bit//and - @@bit//or - @@bit//xor - @@bit//not - @@bit//left-shift - @@bit//arithmetic-right-shift-32 - @@bit//arithmetic-right-shift - @@bit//logical-right-shift - )) - -(runtime: (frac//decode input) - (with-vars [output] - ($_ r.then - (r.set! output (r.apply (list (@@ input)) (r.global "as.numeric"))) - (r.if (|> (@@ output) (r.= r.n/a)) - ..none - (..some (@@ output)))))) - -(def: runtime//frac - Runtime - ($_ r.then - @@frac//decode)) - -(def: inc (-> Expression Expression) (|>> (r.+ (r.int 1)))) - -(template [ ] - [(def: ( top value) - (-> Expression Expression Expression) - (|> (|> value (r.>= (r.int 0))) - (r.and (|> value ( top)))))] - - [within? r.<] - [up-to? r.<=] - ) - -(def: (text-clip start end text) - (-> Expression Expression Expression Expression) - (r.apply (list text start end) - (r.global "substr"))) - -(def: (text-length text) - (-> Expression Expression) - (r.apply (list text) (r.global "nchar"))) - -(runtime: (text//index subject param start) - (with-vars [idx startF subjectL] - ($_ r.then - (r.set! startF (int//to-float (@@ start))) - (r.set! subjectL (text-length (@@ subject))) - (r.if (|> (@@ startF) (within? (@@ subjectL))) - ($_ r.then - (r.set! idx (|> (r.apply-kw (list (@@ param) (r.if (|> (@@ startF) (r.= (r.int 0))) - (@@ subject) - (text-clip (inc (@@ startF)) - (inc (@@ subjectL)) - (@@ subject)))) - (list ["fixed" (r.bool #1)]) - (r.global "regexpr")) - (r.nth (r.int 1)))) - (r.if (|> (@@ idx) (r.= (r.int -1))) - ..none - (..some (int//from-float (|> (@@ idx) (r.+ (@@ startF))))))) - ..none)))) - -(runtime: (text//clip text from to) - (with-vars [length] - ($_ r.then - (r.set! length (r.length (@@ text))) - (r.if ($_ r.and - (|> (@@ to) (within? (@@ length))) - (|> (@@ from) (up-to? (@@ to)))) - (..some (text-clip (inc (@@ from)) (inc (@@ to)) (@@ text))) - ..none)))) - -(def: (char-at idx text) - (-> Expression Expression Expression) - (r.apply (list (text-clip idx idx text)) - (r.global "utf8ToInt"))) - -(runtime: (text//char text idx) - (r.if (|> (@@ idx) (within? (r.length (@@ text)))) - ($_ r.then - (r.set! idx (inc (@@ idx))) - (..some (int//from-float (char-at (@@ idx) (@@ text))))) - ..none)) - -(def: runtime//text - Runtime - ($_ r.then - @@text//index - @@text//clip - @@text//char)) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Expression) - (r.if (|> idx (r.<= (r.length array))) - body - (r.stop (r.string "Array index out of bounds!")))) - -(runtime: (array//new size) - (with-vars [output] - ($_ r.then - (r.set! output (r.list (list))) - (r.set-nth! (|> (@@ size) (r.+ (r.int 1))) - r.null - output) - (@@ output)))) - -(runtime: (array//get array idx) - (with-vars [temp] - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - ($_ r.then - (r.set! temp (|> (@@ array) (r.nth (@@ idx)))) - (r.if (|> (@@ temp) (r.= r.null)) - ..none - (..some (@@ temp))))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - ($_ r.then - (r.set-nth! (@@ idx) (@@ value) array) - (@@ array)))) - -(def: runtime//array - Runtime - ($_ r.then - @@array//new - @@array//get - @@array//put)) - -(runtime: (box//write value box) - ($_ r.then - (r.set-nth! (r.int 1) (@@ value) box) - ..unit)) - -(def: runtime//box - Runtime - ($_ r.then - @@box//write)) - -(def: runtime - Runtime - ($_ r.then - runtime//lux - @@f2^32 - @@f2^63 - @@int//new - @@int//from-float - runtime//bit - runtime//int - runtime//adt - runtime//frac - runtime//text - runtime//array - runtime//box - runtime//io - )) - -(def: #export artifact Text (format prefix ".r")) - -(def: #export translate - (Meta (Process Any)) - (do macro.Monad - [_ //.init-module-buffer - _ (//.save runtime)] - (//.save-module! artifact))) diff --git a/lux-r/source/luxc/lang/translation/r/statement.jvm.lux b/lux-r/source/luxc/lang/translation/r/statement.jvm.lux deleted file mode 100644 index 1798cb56d..000000000 --- a/lux-r/source/luxc/lang/translation/r/statement.jvm.lux +++ /dev/null @@ -1,45 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - [macro] - (data text/format)) - (luxc (lang [".L" module] - (host [r #+ Expression @@]))) - [//] - (// [".T" runtime] - [".T" reference] - [".T" eval])) - -(def: #export (translate-def name expressionT expressionO metaV) - (-> Text Type Expression Code (Meta Any)) - (do {@ macro.Monad} - [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 (r.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 Expression)) - (macro.fail "translate-program NOT IMPLEMENTED YET")) diff --git a/lux-r/source/luxc/lang/translation/r/structure.jvm.lux b/lux-r/source/luxc/lang/translation/r/structure.jvm.lux deleted file mode 100644 index cea8fcd59..000000000 --- a/lux-r/source/luxc/lang/translation/r/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 [r #+ Expression]))) - [//] - (// [".T" runtime])) - -(def: #export (translate-tuple translate elemsS+) - (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression)) - (case elemsS+ - #.Nil - (:: macro.Monad wrap runtimeT.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do {@ macro.Monad} - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (r.list elemsT+))))) - -(def: #export (translate-variant translate tag tail? valueS) - (-> (-> Synthesis (Meta Expression)) Nat Bit Synthesis (Meta Expression)) - (do macro.Monad - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) diff --git a/lux-r/source/program.lux b/lux-r/source/program.lux index e2cf047e9..183797d4f 100644 --- a/lux-r/source/program.lux +++ b/lux-r/source/program.lux @@ -1,180 +1,367 @@ (.module: - [lux (#- Definition) - ["@" target] - ["." host (#+ import:)] + [lux #* + [program (#+ program:)] + ["." ffi] + ["." debug] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control - ["." io (#+ IO)] + [pipe (#+ exec> case> new>)] ["." try (#+ Try)] - [parser - [cli (#+ program:)]] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] [concurrency ["." promise (#+ Promise)]]] [data - ["." product] - [text - ["%" format (#+ format)]] + ["." maybe] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] [collection - [array (#+ Array)] - ["." dictionary]]] - [world - ["." file]] - [target - [jvm - [bytecode (#+ Bytecode)]]] + ["." array (#+ Array)]]] + [macro + ["." template]] + [math + [number (#+ hex) + ["n" nat] + ["." i64]]] + ["." world #_ + ["." file] + ["#/." program]] + ["@" target + ["_" r]] [tool [compiler - [default - ["." platform (#+ Platform)]] + [phase (#+ Operation Phase)] + [reference + [variable (#+ Register)]] [language [lux + [program (#+ Program)] + [generation (#+ Context Host)] + ["." synthesis] [analysis - ["." macro (#+ Expander)]] + [macro (#+ Expander)]] [phase - [extension (#+ Phase Bundle Operation Handler Extender) + ["." extension (#+ Extender Handler) + ["#/." bundle] ["." analysis #_ - ["#" jvm]] + ["#" r]] ["." generation #_ - ["#" jvm]] - ## ["." directive #_ - ## ["#" jvm]] - ] + ["#" r]]] [generation - ["." jvm #_ - ## ["." runtime (#+ Anchor Definition)] - ["." packager] - ## ["#/." host] - ]]]]]]]] + ["." reference] + ["." r + ["." runtime]]]]]] + [default + ["." platform (#+ Platform)]] + [meta + ["." packager #_ + ["#" script]]]]]] [program ["/" compositor - ["/." cli] - ["/." static]]] - [luxc - [lang - [host - ["_" jvm]] - ["." directive #_ - ["#" jvm]] - [translation - ["." jvm - ["." runtime] - ["." expression] - ["#/." program] - ["translation" extension]]]]]) - -(import: #long java/lang/reflect/Method - (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)) - -(import: #long (java/lang/Class c) - (getMethod [java/lang/String [(java/lang/Class java/lang/Object)]] #try java/lang/reflect/Method)) - -(import: #long java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(def: _object-class - (java/lang/Class java/lang/Object) - (host.class-for java/lang/Object)) - -(def: _apply2-args - (Array (java/lang/Class java/lang/Object)) - (|> (host.array (java/lang/Class java/lang/Object) 2) - (host.array-write 0 _object-class) - (host.array-write 1 _object-class))) - -(def: _apply4-args - (Array (java/lang/Class java/lang/Object)) - (|> (host.array (java/lang/Class java/lang/Object) 4) - (host.array-write 0 _object-class) - (host.array-write 1 _object-class) - (host.array-write 2 _object-class) - (host.array-write 3 _object-class))) - -(def: #export (expander macro inputs lux) + ["#." cli] + ["#." static]]]) + +(ffi.import: java/lang/String) + +(ffi.import: (java/lang/Class a) + ["#::." + (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))]) + +(ffi.import: java/lang/Object + ["#::." + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))]) + +(ffi.import: java/lang/Long + ["#::." + (intValue [] java/lang/Integer)]) + +(ffi.import: java/lang/Integer + ["#::." + (longValue [] long)]) + +(ffi.import: java/lang/Number + ["#::." + (intValue [] java/lang/Integer) + (longValue [] long) + (doubleValue [] double)]) + +(ffi.import: javax/script/ScriptEngine + ["#::." + (eval [java/lang/String] #try java/lang/Object)]) + +(ffi.import: org/renjin/script/RenjinScriptEngine) + +(ffi.import: org/renjin/script/RenjinScriptEngineFactory + ["#::." + (new []) + (getScriptEngine [] org/renjin/script/RenjinScriptEngine)]) + +(template [] + [(exception: ( {object java/lang/Object}) + (exception.report + ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] + ["Object" (java/lang/Object::toString object)]))] + + [unknown_kind_of_object] + [cannot_apply_a_non_function] + ) + +## (def: host_bit +## (-> Bit org/armedbear/lisp/LispObject) +## (|>> (case> #0 (org/armedbear/lisp/Nil::NIL) +## #1 (org/armedbear/lisp/Symbol::T)))) + +## (def: (host_value value) +## (-> Any org/armedbear/lisp/LispObject) +## (let [to_sub (: (-> Any org/armedbear/lisp/LispObject) +## (function (_ sub_value) +## (let [sub_value (:coerce java/lang/Object sub_value)] +## (`` (<| (~~ (template [ ] +## [(case (ffi.check sub_value) +## (#.Some sub_value) +## (`` (|> sub_value (~~ (template.splice )))) +## #.None)] + +## [[java/lang/Object] [host_value]] +## [java/lang/Boolean [..host_bit]] +## [java/lang/Integer [java/lang/Integer::longValue org/armedbear/lisp/Fixnum::getInstance]] +## [java/lang/Long [org/armedbear/lisp/Bignum::getInstance]] +## [java/lang/Double [org/armedbear/lisp/DoubleFloat::new]] +## [java/lang/String [org/armedbear/lisp/SimpleString::new]] +## )) +## ## else +## (:coerce org/armedbear/lisp/LispObject sub_value))))))] +## (`` (ffi.object [] org/armedbear/lisp/LispObject [program/LuxADT] +## [] +## ## Methods +## (program/LuxADT +## [] (getValue self) java/lang/Object +## (:coerce java/lang/Object value)) + +## (org/armedbear/lisp/LispObject +## [] (length self) +## int +## (|> value +## (:coerce (Array java/lang/Object)) +## array.size +## (:coerce java/lang/Long) +## java/lang/Number::intValue)) + +## (~~ (template [] +## [(org/armedbear/lisp/LispObject +## [] ( self {idx int}) +## org/armedbear/lisp/LispObject +## (case (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)) +## (:coerce (Array java/lang/Object) value)) +## (#.Some sub) +## (to_sub sub) + +## #.None +## (org/armedbear/lisp/Nil::NIL)))] + +## [NTH] [SVREF] [elt] +## )) +## )))) + +(type: (Reader a) + (-> a (Try Any))) + +## (def: (read_variant read host_object) +## (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/Cons)) +## (do try.monad +## [tag (read (org/armedbear/lisp/LispObject::NTH +0 host_object)) +## value (read (org/armedbear/lisp/LispObject::NTH +2 host_object))] +## (wrap [(java/lang/Long::intValue (:coerce java/lang/Long tag)) +## (case (ffi.check org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host_object)) +## (#.Some _) +## (: Any (ffi.null)) + +## _ +## (: Any synthesis.unit)) +## value]))) + +## (def: (read_tuple read host_object) +## (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/SimpleVector)) +## (let [size (.nat (org/armedbear/lisp/LispObject::length host_object))] +## (loop [idx 0 +## output (:coerce (Array Any) (array.new size))] +## (if (n.< size idx) +## ## TODO: Start using "SVREF" instead of "elt" ASAP +## (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host_object)) +## (#try.Failure error) +## (#try.Failure error) + +## (#try.Success member) +## (recur (inc idx) (array.write! idx (:coerce Any member) output))) +## (#try.Success output))))) + +(def: (read host_object) + (Reader java/lang/Object) + (`` (<| ## (~~ (template [ ] + ## [(case (ffi.check host_object) + ## (#.Some host_object) + ## (`` (|> host_object (~~ (template.splice )))) + + ## #.None)] + + ## [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue #try.Success]] + ## [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue #try.Success]] + ## [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #try.Success]] + ## [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue #try.Success]] + ## [org/armedbear/lisp/Cons [(read_variant read)]] + ## [org/armedbear/lisp/SimpleVector [(read_tuple read)]] + ## [org/armedbear/lisp/Nil [(new> (#try.Success false) [])]] + ## [org/armedbear/lisp/Closure [#try.Success]] + ## [program/LuxADT [program/LuxADT::getValue #try.Success]])) + ## (case (ffi.check org/armedbear/lisp/Symbol host_object) + ## (#.Some host_object) + ## (if (is? (org/armedbear/lisp/Symbol::T) host_object) + ## (#try.Success true) + ## (exception.throw ..unknown_kind_of_object [host_object])) + + ## #.None) + ## else + (exception.throw ..unknown_kind_of_object [host_object]) + ))) + +## (def: ensure_macro +## (-> Macro (Maybe org/armedbear/lisp/Closure)) +## (|>> (:coerce java/lang/Object) (ffi.check org/armedbear/lisp/Closure))) + +## (def: (call_macro inputs lux macro) +## (-> (List Code) Lux org/armedbear/lisp/Closure (Try (Try [Lux (List Code)]))) +## (do try.monad +## [raw_output (org/armedbear/lisp/LispObject::execute (..host_value inputs) (..host_value lux) macro)] +## (:coerce (Try (Try [Lux (List Code)])) +## (..read raw_output)))) + +(def: (expander macro inputs lux) Expander - (do try.monad - [apply-method (|> macro - (:coerce java/lang/Object) - (java/lang/Object::getClass) - (java/lang/Class::getMethod "apply" _apply2-args))] - (:coerce (Try (Try [Lux (List Code)])) - (java/lang/reflect/Method::invoke - (:coerce java/lang/Object macro) - (|> (host.array java/lang/Object 2) - (host.array-write 0 (:coerce java/lang/Object inputs)) - (host.array-write 1 (:coerce java/lang/Object lux))) - apply-method)))) - -(def: #export platform - ## (IO (Platform Anchor (Bytecode Any) Definition)) - (IO (Platform _.Anchor _.Inst _.Definition)) + ## (case (ensure_macro macro) + ## (#.Some macro) + ## (call_macro inputs lux macro) + + ## #.None + ## (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))) + (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))) + +(def: host + (IO (Host _.Expression _.Expression)) + (io (let [interpreter (|> (org/renjin/script/RenjinScriptEngineFactory::new) + org/renjin/script/RenjinScriptEngineFactory::getScriptEngine) + run! (: (-> (_.Code Any) (Try Any)) + (function (_ code) + (do try.monad + [host_value (javax/script/ScriptEngine::eval (_.code code) interpreter)] + (read host_value))))] + (: (Host _.Expression _.Expression) + (structure + (def: (evaluate! context code) + (run! code)) + + (def: (execute! input) + (javax/script/ScriptEngine::eval (_.code input) interpreter)) + + (def: (define! context input) + (let [global (reference.artifact context) + $global (_.var global)] + (do try.monad + [#let [definition (_.set! $global input)] + _ (javax/script/ScriptEngine::eval (_.code definition) interpreter) + value (run! $global)] + (wrap [global value definition])))) + + (def: (ingest context content) + (|> content (\ utf8.codec decode) try.assume (:coerce _.Expression))) + + (def: (re_learn context content) + (run! content)) + + (def: (re_load context content) + (do try.monad + [_ (run! content)] + (run! (_.var (reference.artifact context))))) + ))))) + +(def: platform + (IO (Platform _.SVar _.Expression _.Expression)) (do io.monad - [## host jvm/host.host - host jvm.host] - (wrap {#platform.&file-system (file.async file.system) + [host ..host] + (wrap {#platform.&file_system (file.async file.default) #platform.host host - ## #platform.phase jvm.generate - #platform.phase expression.translate - ## #platform.runtime runtime.generate - #platform.runtime runtime.translate - #platform.write product.right}))) - -(def: extender - Extender - ## TODO: Stop relying on coercions ASAP. - (<| (:coerce Extender) - (function (@self handler)) - (:coerce Handler) - (function (@self name phase)) - (:coerce Phase) - (function (@self parameters)) - (:coerce Operation) - (function (@self state)) - (:coerce Try) - try.assume - (:coerce Try) - (do try.monad - [method (|> handler - (:coerce java/lang/Object) - (java/lang/Object::getClass) - (java/lang/Class::getMethod "apply" _apply4-args))] - (java/lang/reflect/Method::invoke - (:coerce java/lang/Object handler) - (|> (host.array java/lang/Object 4) - (host.array-write 0 (:coerce java/lang/Object name)) - (host.array-write 1 (:coerce java/lang/Object phase)) - (host.array-write 2 (:coerce java/lang/Object parameters)) - (host.array-write 3 (:coerce java/lang/Object state))) - method)))) - -(def: (target service) - (-> /cli.Service /cli.Target) - (case service - (^or (#/cli.Compilation [sources libraries target module]) - (#/cli.Interpretation [sources libraries target module]) - (#/cli.Export [sources target])) - target)) - -(def: (declare-success! _) + #platform.phase r.generate + #platform.runtime runtime.generate + #platform.write (|>> _.code (\ utf8.codec encode))}))) + +(def: (program context program) + (Program _.Expression _.Expression) + (_.apply/2 program [(runtime.lux::program_args (_.commandArgs/0 [])) _.null])) + +(for {@.old + (def: extender + Extender + ## TODO: Stop relying on coercions ASAP. + (<| (:coerce Extender) + (function (@self handler)) + (:coerce Handler) + (function (@self name phase)) + (:coerce Phase) + (function (@self archive parameters)) + (:coerce Operation) + (function (@self state)) + (:coerce Try) + try.assume + (:coerce Try) + (exec + ("lux io log" "TODO: Extender") + (#try.Failure "TODO: Extender")))) + + @.r + (def: (extender handler) + Extender + (:assume handler))}) + +(def: (declare_success! _) (-> Any (Promise Any)) - (promise.future (io.exit +0))) - -(program: [{service /cli.service}] - (let [jar-path (format (..target service) (:: file.system separator) "program.jar")] - (exec (do promise.monad - [_ (/.compiler {#/static.host @.jvm - #/static.host-module-extension ".jvm" - #/static.target (..target service) - #/static.artifact-extension ".class"} - ..expander - analysis.bundle - ..platform - ## generation.bundle - translation.bundle - (directive.bundle ..extender) - jvm/program.program - ..extender - service - [(packager.package jvm/program.class) jar-path])] - (..declare-success! [])) - (io.io [])))) + (promise.future (\ world/program.default exit +0))) + +(def: (scope body) + (-> _.Expression _.Expression) + (let [$program (_.var "lux_program")] + ($_ _.then + (_.set! $program (_.function (list) body)) + (_.apply/0 $program []) + ))) + +(`` (program: [{service /cli.service}] + (let [extension ".r"] + (do io.monad + [platform ..platform] + (exec (do promise.monad + [_ (/.compiler {#/static.host @.r + #/static.host_module_extension extension + #/static.target (/cli.target service) + #/static.artifact_extension extension} + ..expander + analysis.bundle + (io.io platform) + generation.bundle + extension/bundle.empty + ..program + [_.SVar _.Expression _.Expression] + ..extender + service + [(packager.package (_.manual "") + _.code + _.then + ..scope) + (format (/cli.target service) + (\ file.default separator) + "program" + extension)])] + (..declare_success! [])) + (io.io [])))))) diff --git a/stdlib/source/lux/target/r.lux b/stdlib/source/lux/target/r.lux new file mode 100644 index 000000000..c60456ad2 --- /dev/null +++ b/stdlib/source/lux/target/r.lux @@ -0,0 +1,378 @@ +(.module: + [lux (#- Code or and list if function cond not int) + [control + [pipe (#+ case> cond> new>)] + ["." function] + [parser + ["<.>" code]]] + [data + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["f" frac]]] + [type + abstract]]) + +(abstract: #export (Code kind) + Text + + {} + + (template [ +] + [(with_expansions [ (template.identifier [ "'"])] + (abstract: #export ( kind) Any) + (`` (type: #export (|> Any (~~ (template.splice +))))))] + + [Expression [Code]] + ) + + (template [ +] + [(with_expansions [ (template.identifier [ "'"])] + (abstract: #export ( kind) Any) + (`` (type: #export ( ) (|> (~~ (template.splice +))))))] + + [Var [Expression' Code]] + ) + + (template [ ] + [(abstract: #export Any) + (type: #export (Var ))] + + [SVar Single] + [PVar Poly] + ) + + (def: #export var + (-> Text SVar) + (|>> :abstraction)) + + (def: #export var_args + PVar + (:abstraction "...")) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (def: (self_contained code) + (-> Text Expression) + (:abstraction + (format "(" code ")"))) + + (def: nest + (-> Text Text) + (let [nested_new_line (format text.new_line text.tab)] + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line)))) + + (def: (_block expression) + (-> Text Text) + (format "{" (nest expression) text.new_line "}")) + + (def: #export (block expression) + (-> Expression Expression) + (:abstraction + (format "{" (:representation expression) "}"))) + + (template [ ] + [(def: #export + Expression + (..self_contained ))] + + [null "NULL"] + [n/a "NA"] + ) + + (template [] + [(def: #export Expression n/a)] + + [not_available] + [not_applicable] + [no_answer] + ) + + (def: #export bool + (-> Bit Expression) + (|>> (case> #0 "FALSE" + #1 "TRUE") + ..self_contained)) + + (def: #export (int value) + (-> Int Expression) + (..self_contained (format "as.integer(" (%.int value) ")"))) + + (def: #export float + (-> Frac Expression) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "1.0/0.0" [])] + + [(f.= f.negative_infinity)] + [(new> "-1.0/0.0" [])] + + [(f.= f.not_a_number)] + [(new> "0.0/0.0" [])] + + ## else + [%.frac]) + ..self_contained)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [ ] + [(text.replace_all )] + + ["\" "\\"] + ["|" "\|"] + [text.alarm "\a"] + [text.back_space "\b"] + [text.tab "\t"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Expression) + (|>> %.text ..sanitize ..self_contained)) + + (def: (composite_literal left_delimiter right_delimiter entry_serializer) + (All [a] (-> Text Text (-> a Text) + (-> (List a) Expression))) + (.function (_ entries) + (..self_contained + (format left_delimiter + (|> entries (list\map entry_serializer) (text.join_with ",")) + right_delimiter)))) + + (def: #export named_list + (-> (List [Text Expression]) Expression) + (composite_literal "list(" ")" (.function (_ [key value]) + (format key "=" (:representation value))))) + + (template [ ] + [(def: #export + (-> (List Expression) Expression) + (composite_literal (format "(") ")" ..code))] + + [vector "c"] + [list "list"] + ) + + (def: #export (slice from to list) + (-> Expression Expression Expression Expression) + (..self_contained + (format (:representation list) + "[" (:representation from) ":" (:representation to) "]"))) + + (def: #export (slice_from from list) + (-> Expression Expression Expression) + (..self_contained + (format (:representation list) + "[-1" ":-" (:representation from) "]"))) + + (def: #export (apply args func) + (-> (List Expression) Expression Expression) + (..self_contained + (format (:representation func) "(" (text.join_with "," (list\map ..code args)) ")"))) + + (def: #export (apply_kw args kw_args func) + (-> (List Expression) (List [Text Expression]) Expression Expression) + (..self_contained + (format (:representation func) + (format "(" + (text.join_with "," (list\map ..code args)) "," + (text.join_with "," (list\map (.function (_ [key val]) + (format key "=" (:representation val))) + kw_args)) + ")")))) + + (syntax: (arity_inputs {arity .nat}) + (wrap (case arity + 0 (.list) + _ (|> arity + list.indices + (list\map (|>> %.nat code.local_identifier)))))) + + (syntax: (arity_types {arity .nat}) + (wrap (list.repeat arity (` ..Expression)))) + + (template [ +] + [(with_expansions [ (template.identifier ["apply/" ]) + (arity_inputs ) + (arity_types ) + (template.splice +)] + (def: #export ( function []) + (-> Expression [] Expression) + (..apply (.list ) function)) + + (template [] + [(`` (def: #export (~~ (template.identifier [ "/" ])) + (-> [] Expression) + ( (..var ))))] + + ))] + + [0 + [["commandArgs"]]] + [1 + []] + [2 + []] + ) + + (def: #export (nth idx list) + (-> Expression Expression Expression) + (..self_contained + (format (:representation list) "[[" (:representation idx) "]]"))) + + (def: #export (if test then else) + (-> Expression Expression Expression Expression) + (..self_contained + (format "if(" (:representation test) ")" + " " (.._block (:representation then)) + " else " (.._block (:representation else))))) + + (def: #export (when test then) + (-> Expression Expression Expression) + (..self_contained + (format "if(" (:representation test) ") {" + (.._block (:representation then)) + text.new_line "}"))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Expression) + (list\fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses))) + + (template [ ] + [(def: #export ( param subject) + (-> Expression Expression Expression) + (..self_contained + (format (:representation subject) + " " " " + (:representation param))))] + + [= "=="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [%% "%%"] + [** "**"] + [or "||"] + [and "&&"] + ) + + (template [ ] + [(def: #export ( param subject) + (-> Expression Expression Expression) + (..apply (.list subject param) (..var )))] + + [bit_or "bitwOr"] + [bit_and "bitwAnd"] + [bit_xor "bitwXor"] + [bit_shl "bitwShiftL"] + [bit_ushr "bitwShiftR"] + ) + + (def: #export (bit_not subject) + (-> Expression Expression) + (..apply (.list subject) (..var "bitwNot"))) + + (template [ ] + [(def: #export + (-> Expression Expression) + (|>> :representation (format ) ..self_contained))] + + [not "!"] + [negate "-"] + ) + + (def: #export (length list) + (-> Expression Expression) + (..apply (.list list) (..var "length"))) + + (def: #export (range from to) + (-> Expression Expression Expression) + (..self_contained + (format (:representation from) ":" (:representation to)))) + + (def: #export (function inputs body) + (-> (List (Ex [k] (Var k))) Expression Expression) + (let [args (|> inputs (list\map ..code) (text.join_with ", "))] + (..self_contained + (format "function(" args ") " + (.._block (:representation body)))))) + + (def: #export (try body warning error finally) + (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression) + (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text) + (.function (_ parameter value preparation) + (|> value + (maybe\map (|>> :representation preparation (format ", " parameter " = "))) + (maybe.default ""))))] + (..self_contained + (format "tryCatch(" + (.._block (:representation body)) + (optional "warning" warning function.identity) + (optional "error" error function.identity) + (optional "finally" finally .._block) + ")")))) + + (def: #export (while test body) + (-> Expression Expression Expression) + (..self_contained + (format "while (" (:representation test) ") " + (.._block (:representation body))))) + + (def: #export (for_in var inputs body) + (-> SVar Expression Expression Expression) + (..self_contained + (format "for (" (:representation var) " in " (:representation inputs) ")" + (.._block (:representation body))))) + + (template [ ] + [(def: #export ( message) + (-> Expression Expression) + (..apply (.list message) (..var )))] + + [stop "stop"] + [print "print"] + ) + + (def: #export (set! var value) + (-> SVar Expression Expression) + (..self_contained + (format (:representation var) " <- " (:representation value)))) + + (def: #export (set_nth! idx value list) + (-> Expression Expression SVar Expression) + (..self_contained + (format (:representation list) "[[" (:representation idx) "]] <- " (:representation value)))) + + (def: #export (then pre post) + (-> Expression Expression Expression) + (:abstraction + (format (:representation pre) + text.new_line + (:representation post)))) + ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux new file mode 100644 index 000000000..12f578ed2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" r]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "r") + (|> bundle.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux new file mode 100644 index 000000000..cd0f6b7cc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [r + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux new file mode 100644 index 000000000..cb82c6cb4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux @@ -0,0 +1,179 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" r (#+ Expression)]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" r #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +## (template: (!unary function) +## (|>> list _.apply/* (|> (_.constant function)))) + +## ## ## TODO: Get rid of this ASAP +## ## (def: lux::syntax_char_case! +## ## (..custom [($_ <>.and +## ## .any +## ## .any +## ## (<>.some (.tuple ($_ <>.and +## ## (.tuple (<>.many .i64)) +## ## .any)))) +## ## (function (_ extension_name phase archive [input else conditionals]) +## ## (do {! /////.monad} +## ## [@input (\ ! map _.var (generation.gensym "input")) +## ## inputG (phase archive input) +## ## elseG (phase archive else) +## ## conditionalsG (: (Operation (List [Expression Expression])) +## ## (monad.map ! (function (_ [chars branch]) +## ## (do ! +## ## [branchG (phase archive branch)] +## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) +## ## branchG]))) +## ## conditionals))] +## ## (wrap (_.let (list [@input inputG]) +## ## (list (list\fold (function (_ [test then] else) +## ## (_.if test then else)) +## ## elseG +## ## conditionalsG))))))])) + +## (def: lux_procs +## Bundle +## (|> /.empty +## ## (/.install "syntax char case!" lux::syntax_char_case!) +## (/.install "is" (binary _.eq/2)) +## ## (/.install "try" (unary //runtime.lux//try)) +## )) + +## ## (def: (capped operation parameter subject) +## ## (-> (-> Expression Expression Expression) +## ## (-> Expression Expression Expression)) +## ## (//runtime.i64//64 (operation parameter subject))) + +## (def: i64_procs +## Bundle +## (<| (/.prefix "i64") +## (|> /.empty +## (/.install "and" (binary _.logand/2)) +## (/.install "or" (binary _.logior/2)) +## (/.install "xor" (binary _.logxor/2)) +## (/.install "left-shift" (binary _.ash/2)) +## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) +## (/.install "=" (binary _.=/2)) +## (/.install "<" (binary _.> _.code-char/1 _.string/1))) +## ))) + +## (def: f64_procs +## Bundle +## (<| (/.prefix "f64") +## (|> /.empty +## ## (/.install "=" (binary (product.uncurry _.=/2))) +## ## (/.install "<" (binary (product.uncurry _. /.empty +## (/.install "=" (binary _.string=/2)) +## ## (/.install "<" (binary (product.uncurry _.string /.empty +## (/.install "log" (unary ..io//log!)) +## (/.install "error" (unary _.error/1)) +## ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + ## (dictionary.merge lux_procs) + ## (dictionary.merge i64_procs) + ## (dictionary.merge f64_procs) + ## (dictionary.merge text_procs) + ## (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux new file mode 100644 index 000000000..2d9148dda --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" r (#+ Var Expression)]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" r #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (/.prefix "r") + (|> /.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux new file mode 100644 index 000000000..b4b3e6423 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux @@ -0,0 +1,58 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [target + ["_" r]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [ ] + [(^ ( value)) + (//////phase\wrap ( value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [ ] + [(^ ( value)) + ( generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux new file mode 100644 index 000000000..fe4e4a7c2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux @@ -0,0 +1,239 @@ +(.module: + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [macro + ["." template]] + [math + [number + ["i" int]]] + [target + ["_" r (#+ Expression SVar)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register SVar) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + (wrap (_.block + ($_ _.then + (_.set! (..register register) valueO) + bodyO))))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [ ] + [( lefts) + ( (_.int (.int lefts)))]) + ([#.Left //runtime.tuple::left] + [#.Right //runtime.tuple::right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: $savepoint (_.var "lux_pm_cursor_savepoint")) +(def: $cursor (_.var "lux_pm_cursor")) +(def: $temp (_.var "lux_pm_temp")) +(def: $alt_error (_.var "alt_error")) + +(def: top + _.length) + +(def: next + (|>> _.length (_.+ (_.int +1)))) + +(def: (push! value var) + (-> Expression SVar Expression) + (_.set_nth! (next var) value var)) + +(def: (pop! var) + (-> SVar Expression) + (_.set_nth! (top var) _.null var)) + +(def: (push_cursor! value) + (-> Expression Expression) + (push! value $cursor)) + +(def: save_cursor! + Expression + (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor) + $savepoint)) + +(def: restore_cursor! + Expression + (_.set! $cursor (_.nth (top $savepoint) $savepoint))) + +(def: peek + Expression + (|> $cursor (_.nth (top $cursor)))) + +(def: pop_cursor! + Expression + (pop! $cursor)) + +(def: error + (_.string (template.with_locals [error] + (template.text [error])))) + +(def: fail! + (_.stop ..error)) + +(def: (catch handler) + (-> Expression Expression) + (_.function (list $alt_error) + (_.if (|> $alt_error (_.= ..error)) + handler + (_.stop $alt_error)))) + +(def: (pattern_matching' expression archive) + (Generator Path) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop_cursor!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set! (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [ <=>] + [( cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match ) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([#/////synthesis.I64_Fork //primitive.i64 //runtime.i64::=] + [#/////synthesis.F64_Fork //primitive.f64 _.=] + [#/////synthesis.Text_Fork //primitive.text _.=]) + + (^template [ ] + [(^ ( idx)) + (///////phase\wrap ($_ _.then + (_.set! $temp (|> idx .int _.int (//runtime.sum::get ..peek (//runtime.flag )))) + (_.if (_.= _.null $temp) + ..fail! + (..push_cursor! $temp))))]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true inc]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (_.nth (_.int +1) ..peek)) + + (^template [ ] + [(^ ( lefts)) + (///////phase\wrap (|> ..peek ( (_.int (.int lefts))) ..push_cursor!))]) + ([/////synthesis.member/left //runtime.tuple::left] + [/////synthesis.member/right //runtime.tuple::right]) + + (^ (/////synthesis.path/seq leftP rightP)) + (do ///////phase.monad + [leftO (recur leftP) + rightO (recur rightP)] + (wrap ($_ _.then + leftO + rightO))) + + (^ (/////synthesis.path/alt leftP rightP)) + (do {! ///////phase.monad} + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (_.try ($_ _.then + ..save_cursor! + leftO) + #.None + (#.Some (..catch ($_ _.then + ..restore_cursor! + rightO))) + #.None))) + ))) + +(def: (pattern_matching expression archive pathP) + (Generator Path) + (do ///////phase.monad + [pattern_matching! (pattern_matching' expression archive pathP)] + (wrap (_.try pattern_matching! + #.None + (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching.")))) + #.None)))) + +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do {! ///////phase.monad} + [valueO (expression archive valueS)] + (<| (\ ! map (|>> ($_ _.then + (_.set! $cursor (_.list (list valueO))) + (_.set! $savepoint (_.list (list)))) + _.block)) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux new file mode 100644 index 000000000..c89ffaf0a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux @@ -0,0 +1,116 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" r (#+ Expression SVar)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]] + [meta + [archive + ["." artifact]]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply argsO+ functionO)))) + +(def: (with_closure function_id $function inits function_definition) + (-> artifact.ID SVar (List Expression) Expression (Operation Expression)) + (case inits + #.Nil + (do ///////phase.monad + [_ (/////generation.execute! function_definition) + _ (/////generation.save! (%.nat function_id) + function_definition)] + (wrap $function)) + + _ + (do ///////phase.monad + [#let [closure_definition (_.set! $function + (_.function (|> inits + list.size + list.indices + (list\map //case.capture)) + ($_ _.then + function_definition + $function)))] + _ (/////generation.execute! closure_definition) + _ (/////generation.save! (%.nat function_id) closure_definition)] + (wrap (_.apply inits $function))))) + +(def: $curried (_.var "curried")) +(def: $missing (_.var "missing")) + +(def: (input_declaration register) + (-> Register Expression) + (_.set! (|> register inc //case.register) + (|> $curried (_.nth (|> register inc .int _.int))))) + +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive + (do ! + [$self (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor $self + (expression archive bodyS)))) + closureO+ (monad.map ! (expression archive) environment) + #let [arityO (|> arity .int _.int) + $num_args (_.var "num_args") + $self (_.var (///reference.artifact [function_module function_artifact])) + apply_poly (.function (_ args func) + (_.apply (list func args) (_.var "do.call")))]] + (with_closure function_artifact $self closureO+ + (_.set! $self (_.function (list _.var_args) + ($_ _.then + (_.set! $curried (_.list (list _.var_args))) + (_.set! $num_args (_.length $curried)) + (_.cond (list [(|> $num_args (_.= arityO)) + ($_ _.then + (_.set! (//case.register 0) $self) + (|> arity + list.indices + (list\map input_declaration) + (list\fold _.then bodyO)))] + [(|> $num_args (_.> arityO)) + (let [arity_args (_.slice (_.int +1) arityO $curried) + output_func_args (_.slice (|> arityO (_.+ (_.int +1))) + $num_args + $curried)] + (|> $self + (apply_poly arity_args) + (apply_poly output_func_args)))]) + ## (|> $num_args (_.< arityO)) + (let [$missing (_.var "missing")] + (_.function (list _.var_args) + ($_ _.then + (_.set! $missing (_.list (list _.var_args))) + (|> $self + (apply_poly (_.apply (list $curried $missing) + (_.var "append")))))))))))) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux new file mode 100644 index 000000000..c8f8bd1d5 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux @@ -0,0 +1,64 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat]]] + [target + ["_" r]]] + ["." // #_ + [runtime (#+ Operation Phase Generator)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export (scope expression archive [offset initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [$scope (\ ! map _.var (/////generation.gensym "loop_scope")) + initsO+ (monad.map ! (expression archive) initsS+) + bodyO (/////generation.with_anchor $scope + (expression archive bodyS))] + (wrap (_.block + ($_ _.then + (_.set! $scope + (_.function (|> initsS+ + list.size + list.indices + (list\map (|>> (n.+ offset) //case.register))) + bodyO)) + (_.apply initsO+ $scope))))))) + +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [$scope /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply argsO+ $scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux new file mode 100644 index 000000000..efbd569f4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux @@ -0,0 +1,17 @@ +(.module: + [lux (#- i64) + [target + ["_" r (#+ Expression)]]] + ["." // #_ + ["#." runtime]]) + +(template [ ] + [(def: #export + (-> Expression) + )] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int //runtime.i64)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux new file mode 100644 index 000000000..85ccd90dc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux @@ -0,0 +1,339 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number] + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict]))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [r #+ Expression]))) + [///] + (/// [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])) + +## [Types] +(type: #export Translator + (-> ls.Synthesis (Meta Expression))) + +(type: #export Proc + (-> Translator (List ls.Synthesis) (Meta Expression))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Expression)) +(type: #export Unary (-> (Vector +1 Expression) Expression)) +(type: #export Binary (-> (Vector +2 Expression) Expression)) +(type: #export Trinary (-> (Vector +3 Expression) Expression)) +(type: #export Variadic (-> (List Expression) Expression)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected .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 {@ macro.monad} + [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 + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) + + (~' _) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function (_ proc-name) + (function (_ translate inputsS) + (do {@ macro.Monad} + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftO rightO]) + Binary + (r.apply (list leftO rightO) + (r.global "identical"))) + +(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) + (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 [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [bit//and runtimeT.bit//and] + [bit//or runtimeT.bit//or] + [bit//xor runtimeT.bit//xor] + ) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + ( (runtimeT.int64-low paramO) subjectO))] + + [bit//left-shift runtimeT.bit//left-shift] + [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift] + [bit//logical-right-shift runtimeT.bit//logical-right-shift] + ) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash) + (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 [ ] + [(def: ( _) + Nullary + ( ))] + + [frac//smallest Double::MIN_VALUE r.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) r.float] + [frac//max Double::MAX_VALUE r.float] + ) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + (|> subjectO ( paramO)))] + + [int//add runtimeT.int//+] + [int//sub runtimeT.int//-] + [int//mul runtimeT.int//*] + [int//div runtimeT.int///] + [int//rem runtimeT.int//%] + ) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [frac//add r.+] + [frac//sub r.-] + [frac//mul r.*] + [frac//div r./] + [frac//rem r.%%] + [frac//= r.=] + [frac//< r.<] + + [text//= r.=] + [text//< r.<] + ) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [int//= runtimeT.int//=] + [int//< runtimeT.int//<] + ) + +(def: (apply1 func) + (-> Expression (-> Expression Expression)) + (function (_ value) + (r.apply (list value) func))) + +(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8")))) + +(def: int-procs + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary runtimeT.int//to-float)) + (install "char" (unary int//char))))) + +(def: (frac//encode value) + (-> Expression Expression) + (r.apply (list (r.string "%f") value) (r.global "sprintf"))) + +(def: frac-procs + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (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 (r.global "as.integer")))) + (install "encode" (unary frac//encode)) + (install "decode" (unary runtimeT.frac//decode))))) + +## [[Text]] +(def: (text//concat [subjectO paramO]) + Binary + (r.apply (list subjectO paramO) (r.global "paste0"))) + +(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) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float))) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + ))) + +## [[IO]] +(def: (io//exit input) + Unary + (r.apply-kw (list) + (list ["status" (runtimeT.int//to-float input)]) + (r.global "quit"))) + +(def: (void code) + (-> Expression Expression) + (r.block (r.then code runtimeT.unit))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash) + (install "log" (unary (|>> r.print ..void))) + (install "error" (unary r.stop)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary (function (_ _) + (runtimeT.io//current-time! runtimeT.unit))))))) + +## [Bundles] +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> 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/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux new file mode 100644 index 000000000..3bd33955f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux @@ -0,0 +1,89 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict]))) + [macro "macro/" Monad]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [ruby #+ Ruby Expression Statement]))) + [///] + (/// [".T" runtime]) + (// ["@" common])) + +## (template [ ] +## [(def: ( _) @.Nullary )] + +## [lua//nil "nil"] +## [lua//table "{}"] +## ) + +## (def: (lua//global proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list [_ (#.Text name)])) +## (do macro.Monad +## [] +## (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} +## [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) +## (@.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} +## [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) +## (@.install "call" table//call) +## (@.install "get" (@.binary table//get)) +## (@.install "set" (@.trinary table//set))))) + +(def: #export procedures + @.Bundle + (<| (@.prefix "lua") + (dict.new text.Hash) + ## (|> lua-procs + ## (dict.merge table-procs)) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux new file mode 100644 index 000000000..c3f2e8289 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux @@ -0,0 +1,12 @@ +(.module: + [lux #* + [target + ["_" r (#+ Expression)]]] + [/// + [reference (#+ System)]]) + +(structure: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux new file mode 100644 index 000000000..1b7119378 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux @@ -0,0 +1,848 @@ +(.module: + [lux (#- Location inc i64) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["n" nat] + ["i" int ("#\." interval)] + ["." i64]]] + ["@" target + ["_" r (#+ SVar Expression)]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) + +(template [ ] + [(type: #export + ( _.SVar _.Expression _.Expression))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(def: #export unit + Expression + (_.string /////synthesis.unit)) + +(def: full_32 (hex "FFFFFFFF")) +(def: half_32 (hex "7FFFFFFF")) +(def: post_32 (hex "100000000")) + +(def: (cap_32 input) + (-> Nat Int) + (cond (n.> full_32 input) + (|> input (i64.and full_32) cap_32) + + (n.> half_32 input) + (|> post_32 (n.- input) .int (i.* -1)) + + ## else + (.int input))) + +(def: high_32 + (-> Nat Nat) + (i64.right_shift 32)) + +(def: low_32 + (-> Nat Nat) + (|>> (i64.and (hex "FFFFFFFF")))) + +(def: #export i64_high_field "luxIH") +(def: #export i64_low_field "luxIL") + +(def: #export (i64 value) + (-> Int Expression) + (let [value (.nat value) + high (|> value ..high_32 ..cap_32) + low (|> value ..low_32 ..cap_32)] + (_.named_list (list [..i64_high_field (_.int high)] + [..i64_low_field (_.int low)])))) + +(def: #export variant_tag_field "luxVT") +(def: #export variant_flag_field "luxVF") +(def: #export variant_value_field "luxVV") + +(def: #export (flag value) + (-> Bit Expression) + (if value + (_.string "") + _.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (_.named_list (list [..variant_tag_field tag] + [..variant_flag_field last?] + [..variant_value_field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Expression) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Expression + (variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Expression) + (variant 1 #1)) + +(def: #export left + (-> Expression Expression) + (variant 0 #0)) + +(def: #export right + (-> Expression Expression) + (variant 1 #1)) + +(syntax: #export (with_vars {vars (.tuple (<>.some .local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or .local_identifier + (.form (<>.and .local_identifier + (<>.some .local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + _.SVar + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Expression + (_.set! (~ runtime_name) (~ code))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) _.Expression) + (_.apply (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Expression + (..with_vars [(~+ inputsC)] + (_.set! (~ runtime_name) + (_.function (list (~+ inputsC)) + (~ code)))))))))))))) + +(def: high_shift (_.bit_shl (_.int +32))) + +(runtime: f2^32 (|> (_.int +2) (_.** (_.int +32)))) +(runtime: f2^63 (|> (_.int +2) (_.** (_.int +63)))) + +(def: (as_double value) + (-> Expression Expression) + (_.apply (list value) (_.var "as.double"))) + +(def: (as_integer value) + (-> Expression Expression) + (_.apply (list value) (_.var "as.integer"))) + +(runtime: (i64::unsigned_low input) + (with_vars [low] + ($_ _.then + (_.set! low (|> input (_.nth (_.string ..i64_low_field)))) + (_.if (|> low (_.>= (_.int +0))) + low + (|> low (_.+ f2^32)))))) + +(runtime: (i64::to_float input) + (let [high (|> input + (_.nth (_.string ..i64_high_field)) + high_shift) + low (|> input + i64::unsigned_low)] + (|> high (_.+ low) as_double))) + +(runtime: (i64::new high low) + (_.named_list (list [..i64_high_field (as_integer high)] + [..i64_low_field (as_integer low)]))) + +(template [ ] + [(runtime: + (..i64 ))] + + [i64::zero +0] + [i64::one +1] + [i64::min i\bottom] + [i64::max i\top] + ) + +(def: #export i64_high (_.nth (_.string ..i64_high_field))) +(def: #export i64_low (_.nth (_.string ..i64_low_field))) + +(runtime: (i64::not input) + (i64::new (|> input i64_high _.bit_not) + (|> input i64_low _.bit_not))) + +(runtime: (i64::+ param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + ($_ _.then + (_.set! sH (|> subject i64_high)) + (_.set! sL (|> subject i64_low)) + (_.set! pH (|> param i64_high)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + + [[s48 s32] [s16 s00]] (split_int sH sL) + [[p48 p32] [p16 p00]] (split_int pH pL) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom))))] + ($_ _.then + (_.set! x00 (|> s00 (_.+ p00))) + (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16))) + (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32))) + (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))))) + +(runtime: (i64::= reference sample) + (let [n/a? (function (_ value) + (_.apply (list value) (_.var "is.na"))) + isTRUE? (function (_ value) + (_.apply (list value) (_.var "isTRUE"))) + comparison (: (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (|> (field sample) (_.= (field reference))) + (_.or (|> (n/a? (field sample)) + (_.and (n/a? (field reference))))))))] + (|> (comparison i64_high) + (_.and (comparison i64_low)) + isTRUE?))) + +(runtime: (i64::negate input) + (_.if (|> input (i64::= i64::min)) + i64::min + (|> input i64::not (i64::+ i64::one)))) + +(runtime: i64::-one + (i64::negate i64::one)) + +(runtime: (i64::- param subject) + (i64::+ (i64::negate param) subject)) + +(runtime: (i64::< reference sample) + (with_vars [r_? s_?] + ($_ _.then + (_.set! s_? (|> sample i64_high (_.< (_.int +0)))) + (_.set! r_? (|> reference i64_high (_.< (_.int +0)))) + (|> (|> s_? (_.and (_.not r_?))) + (_.or (|> (_.not s_?) (_.and r_?) _.not)) + (_.or (|> sample + (i64::- reference) + i64_high + (_.< (_.int +0)))))))) + +(runtime: (i64::from_float input) + (_.cond (list [(_.apply (list input) (_.var "is.nan")) + i64::zero] + [(|> input (_.<= (_.negate f2^63))) + i64::min] + [(|> input (_.+ (_.float +1.0)) (_.>= f2^63)) + i64::max] + [(|> input (_.< (_.float +0.0))) + (|> input _.negate i64::from_float i64::negate)]) + (i64::new (|> input (_./ f2^32)) + (|> input (_.%% f2^32))))) + +(runtime: (i64::* param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + ($_ _.then + (_.set! sH (|> subject i64_high)) + (_.set! pH (|> param i64_high)) + (let [negative_subject? (|> sH (_.< (_.int +0))) + negative_param? (|> pH (_.< (_.int +0)))] + (_.cond (list [negative_subject? + (_.if negative_param? + (i64::* (i64::negate param) + (i64::negate subject)) + (i64::negate (i64::* param + (i64::negate subject))))] + + [negative_param? + (i64::negate (i64::* (i64::negate param) + subject))]) + ($_ _.then + (_.set! sL (|> subject i64_low)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom)))) + x16_top (|> x16 top_16) + x32_top (|> x32 top_16)] + (with_vars [s48 s32 s16 s00 + p48 p32 p16 p00] + (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL) + [[_p48 _p32] [_p16 _p00]] (split_int pH pL) + set_subject_chunks! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00)) + set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))] + ($_ _.then + set_subject_chunks! + set_param_chunks! + (_.set! x00 (|> s00 (_.* p00))) + (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00))))) + (_.set! x32 x16_top) + (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16))))) + (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00))))) + (_.set! x48 x32_top) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16))))) + (_.set! x48 (|> x48 (_.+ x32_top))) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32))))) + (_.set! x48 (|> x48 (_.+ x32_top) + (_.+ (|> s48 (_.* p00))) + (_.+ (|> s32 (_.* p16))) + (_.+ (|> s16 (_.* p32))) + (_.+ (|> s00 (_.* p48))))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))) + ))))))) + +(def: (limit_shift! shift) + (-> SVar Expression) + (_.set! shift (|> shift (_.bit_and (_.int +63))))) + +(def: (no_shift_clause shift input) + (-> SVar SVar [Expression Expression]) + [(|> shift (_.= (_.int +0))) + input]) + +(runtime: (i64::left_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (_.bit_shl shift) + (_.bit_or mid)) + low (|> (i64_low input) + (_.bit_shl shift))] + (i64::new high low))]) + (let [high (|> (i64_high input) + (_.bit_shl (|> shift (_.- (_.int +32)))))] + (i64::new high (_.int +0)))))) + +(runtime: (i64::arithmetic_right_shift_32 shift input) + (let [top_bit (|> input (_.bit_and (_.int (hex "+80000000"))))] + (|> input + (_.bit_ushr shift) + (_.bit_or top_bit)))) + +(runtime: (i64::arithmetic_right_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (i64::arithmetic_right_shift_32 shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or mid))] + (i64::new high low))]) + (let [low (|> (i64_high input) + (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32))))) + high (_.if (|> (i64_high input) (_.>= (_.int +0))) + (_.int +0) + (_.int -1))] + (i64::new high low))))) + +(runtime: (i64::/ param subject) + (let [negative? (|>> (i64::< i64::zero)) + valid_division_check [(|> param (i64::= i64::zero)) + (_.stop (_.string "Cannot divide by zero!"))] + short_circuit_check [(|> subject (i64::= i64::zero)) + i64::zero]] + (_.cond (list valid_division_check + short_circuit_check + + [(|> subject (i64::= i64::min)) + (_.cond (list [(|> (|> param (i64::= i64::one)) + (_.or (|> param (i64::= i64::-one)))) + i64::min] + [(|> param (i64::= i64::min)) + i64::one]) + (with_vars [approximation] + ($_ _.then + (_.set! approximation + (|> subject + (i64::arithmetic_right_shift (_.int +1)) + (i64::/ param) + (i64::left_shift (_.int +1)))) + (_.if (|> approximation (i64::= i64::zero)) + (_.if (negative? param) + i64::one + i64::-one) + (let [remainder (i64::- (i64::* param approximation) + subject)] + (|> remainder + (i64::/ param) + (i64::+ approximation)))))))] + [(|> param (i64::= i64::min)) + i64::zero] + + [(negative? subject) + (_.if (negative? param) + (|> (i64::negate subject) + (i64::/ (i64::negate param))) + (|> (i64::negate subject) + (i64::/ param) + i64::negate))] + + [(negative? param) + (|> param + i64::negate + (i64::/ subject) + i64::negate)]) + (with_vars [result remainder approximate approximate_result log2 approximate_remainder] + ($_ _.then + (_.set! result i64::zero) + (_.set! remainder subject) + (_.while (|> (|> remainder (i64::< param)) + (_.or (|> remainder (i64::= param)))) + (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param)))) + (_.var "floor")) + calc_approximate_result (i64::from_float approximate) + calc_approximate_remainder (|> approximate_result (i64::* param)) + delta (_.if (|> (_.float +48.0) (_.<= log2)) + (_.float +1.0) + (_.** (|> log2 (_.- (_.float +48.0))) + (_.float +2.0)))] + ($_ _.then + (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate) + (_.var "max"))) + (_.set! log2 (let [log (function (_ input) + (_.apply (list input) (_.var "log")))] + (_.apply (list (|> (log (_.int +2)) + (_./ (log approximate)))) + (_.var "ceil")))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder) + (_.while (|> (negative? approximate_remainder) + (_.or (|> approximate_remainder (i64::< remainder)))) + ($_ _.then + (_.set! approximate (|> delta (_.- approximate))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder))) + (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero)) + i64::one + approximate_result) + (i64::+ result))) + (_.set! remainder (|> remainder (i64::- approximate_remainder)))))) + result)) + ))) + +(runtime: (i64::% param subject) + (let [flat (|> subject (i64::/ param) (i64::* param))] + (|> subject (i64::- flat)))) + +(runtime: (lux::try op) + (with_vars [error value] + (_.try ($_ _.then + (_.set! value (_.apply (list ..unit) op)) + (..right value)) + #.None + (#.Some (_.function (list error) + (..left (_.nth (_.string "message") + error)))) + #.None))) + +(runtime: (lux::program_args program_args) + (with_vars [inputs value] + ($_ _.then + (_.set! inputs ..none) + (<| (_.for_in value program_args) + (_.set! inputs (..some (_.list (list value inputs))))) + inputs))) + +(def: runtime::lux + Expression + ($_ _.then + @lux::try + @lux::program_args + )) + +(def: current_time_float + Expression + (let [raw_time (_.apply (list) (_.var "Sys.time"))] + (_.apply (list raw_time) (_.var "as.numeric")))) + +(runtime: (io::current_time! _) + (|> current_time_float + (_.* (_.float +1,000.0)) + i64::from_float)) + +(def: runtime::io + Expression + ($_ _.then + @io::current_time! + )) + +(def: minimum_index_length + (-> SVar Expression) + (|>> (_.+ (_.int +1)))) + +(def: (product_element product index) + (-> Expression Expression Expression) + (|> product (_.nth (|> index (_.+ (_.int +1)))))) + +(def: (product_tail product) + (-> SVar Expression) + (|> product (_.nth (_.length product)))) + +(def: (updated_index min_length product) + (-> Expression Expression Expression) + (|> min_length (_.- (_.length product)))) + +(runtime: (tuple::left index product) + (let [$index_min_length (_.var "index_min_length")] + ($_ _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.if (|> (_.length product) (_.> $index_min_length)) + ## No need for recursion + (product_element product index) + ## Needs recursion + (tuple::left (updated_index $index_min_length product) + (product_tail product)))))) + +(runtime: (tuple::right index product) + (let [$index_min_length (_.var "index_min_length")] + ($_ _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.cond (list [## Last element. + (|> (_.length product) (_.= $index_min_length)) + (product_element product index)] + [## Needs recursion + (|> (_.length product) (_.< $index_min_length)) + (tuple::right (updated_index $index_min_length product) + (product_tail product))]) + ## Must slice + (|> product (_.slice_from index)))))) + +(runtime: (sum::get sum wants_last? wanted_tag) + (let [no_match _.null + sum_tag (|> sum (_.nth (_.string ..variant_tag_field))) + sum_flag (|> sum (_.nth (_.string ..variant_flag_field))) + sum_value (|> sum (_.nth (_.string ..variant_value_field))) + is_last? (|> sum_flag (_.= (_.string ""))) + test_recursion (_.if is_last? + ## Must recurse. + (|> wanted_tag + (_.- sum_tag) + (sum::get sum_value wants_last?)) + no_match)] + (_.cond (list [(_.= sum_tag wanted_tag) + (_.if (_.= wants_last? sum_flag) + sum_value + test_recursion)] + + [(|> wanted_tag (_.> sum_tag)) + test_recursion] + + [(|> (|> wants_last? (_.= (_.string ""))) + (_.and (|> wanted_tag (_.< sum_tag)))) + (variant' (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)]) + + no_match))) + +(def: runtime::adt + Expression + ($_ _.then + @tuple::left + @tuple::right + @sum::get + )) + +(template [ ] + [(runtime: ( mask input) + (i64::new ( (i64_high mask) + (i64_high input)) + ( (i64_low mask) + (i64_low input))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(runtime: (i64::right_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (with_vars [$mid] + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) (_.bit_ushr shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na")) + (_.int +0) + $mid)))] + ($_ _.then + (_.set! $mid mid) + (i64::new high low))))] + [(|> shift (_.= (_.int +32))) + (let [high (i64_high input)] + (i64::new (_.int +0) high))]) + (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))] + (i64::new (_.int +0) low))))) + +(def: runtime::i64 + Expression + ($_ _.then + @i64::zero + @i64::one + @i64::min + @i64::max + @i64::= + @i64::< + @i64::+ + @i64::- + @i64::negate + @i64::-one + @i64::unsigned_low + @i64::to_float + @i64::* + @i64::/ + @i64::% + + @i64::and + @i64::or + @i64::xor + @i64::not + @i64::left_shift + @i64::arithmetic_right_shift_32 + @i64::arithmetic_right_shift + @i64::right_shift + )) + +(runtime: (frac::decode input) + (with_vars [output] + ($_ _.then + (_.set! output (_.apply (list input) (_.var "as.numeric"))) + (_.if (|> output (_.= _.n/a)) + ..none + (..some output))))) + +(def: runtime::frac + Expression + ($_ _.then + @frac::decode + )) + +(def: inc + (-> Expression Expression) + (|>> (_.+ (_.int +1)))) + +(template [ ] + [(def: ( top value) + (-> Expression Expression Expression) + (|> (|> value (_.>= (_.int +0))) + (_.and (|> value ( top)))))] + + [within? _.<] + [up_to? _.<=] + ) + +(def: (text_clip start end text) + (-> Expression Expression Expression Expression) + (_.apply (list text start end) + (_.var "substr"))) + +(def: (text_length text) + (-> Expression Expression) + (_.apply (list text) (_.var "nchar"))) + +(runtime: (text::index subject param start) + (with_vars [idx startF subjectL] + ($_ _.then + (_.set! startF (i64::to_float start)) + (_.set! subjectL (text_length subject)) + (_.if (|> startF (within? subjectL)) + ($_ _.then + (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0))) + subject + (text_clip (inc startF) + (inc subjectL) + subject))) + (list ["fixed" (_.bool #1)]) + (_.var "regexpr")) + (_.nth (_.int +1)))) + (_.if (|> idx (_.= (_.int -1))) + ..none + (..some (i64::from_float (|> idx (_.+ startF)))))) + ..none)))) + +(runtime: (text::clip text from to) + (with_vars [length] + ($_ _.then + (_.set! length (_.length text)) + (_.if ($_ _.and + (|> to (within? length)) + (|> from (up_to? to))) + (..some (text_clip (inc from) (inc to) text)) + ..none)))) + +(def: (char_at idx text) + (-> Expression Expression Expression) + (_.apply (list (text_clip idx idx text)) + (_.var "utf8ToInt"))) + +(runtime: (text::char text idx) + (_.if (|> idx (within? (_.length text))) + ($_ _.then + (_.set! idx (inc idx)) + (..some (i64::from_float (char_at idx text)))) + ..none)) + +(def: runtime::text + Expression + ($_ _.then + @text::index + @text::clip + @text::char + )) + +(def: (check_index_out_of_bounds array idx body) + (-> Expression Expression Expression Expression) + (_.if (|> idx (_.<= (_.length array))) + body + (_.stop (_.string "Array index out of bounds!")))) + +(runtime: (array::new size) + (with_vars [output] + ($_ _.then + (_.set! output (_.list (list))) + (_.set_nth! (|> size (_.+ (_.int +1))) + _.null + output) + output))) + +(runtime: (array::get array idx) + (with_vars [temp] + (<| (check_index_out_of_bounds array idx) + ($_ _.then + (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx)))) + (_.if (|> temp (_.= _.null)) + ..none + (..some temp)))))) + +(runtime: (array::put array idx value) + (<| (check_index_out_of_bounds array idx) + ($_ _.then + (_.set_nth! (_.+ (_.int +1) idx) value array) + array))) + +(def: runtime::array + Expression + ($_ _.then + @array::new + @array::get + @array::put + )) + +(def: runtime + Expression + ($_ _.then + runtime::lux + @f2^32 + @f2^63 + @i64::new + @i64::from_float + runtime::i64 + runtime::adt + runtime::frac + runtime::text + runtime::array + runtime::io + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux new file mode 100644 index 000000000..5f4703836 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [data + [collection + ["." list]]] + [target + ["_" r (#+ Expression)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.list)))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> (//runtime.variant tag right?)) + (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux index be476cf74..1a36df4e0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux @@ -2,8 +2,6 @@ [lux #* [abstract [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] [target ["_" scheme]]] ["." / #_ diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux index 380352c5b..65c674ded 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux @@ -89,8 +89,7 @@ output_func_args (//runtime.slice arityO (|> @num_args (_.-/2 arityO)) @curried)] - (_.begin (list ## (_.display/1 (_.string (format "!!! PRE [slice]" text.new_line))) - (|> @self + (_.begin (list (|> @self (apply_poly arity_args) (apply_poly output_func_args)))))) ## (|> @num_args (_. ..runtime _.code - (\ encoding.utf8 encode))])]))) + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index 6c44c026a..3bb388f5e 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -15,7 +15,8 @@ [binary (#+ Binary)] ["." text ("#\." hash) ["%" format (#+ format)] - ["." encoding]] + [encoding + ["." utf8]]] [collection ["." dictionary (#+ Dictionary)]]] [world @@ -127,7 +128,7 @@ (Promise (Try Input))) (do (try.with promise.monad) [[path binary] (..find_any_source_file system import contexts partial_host_extension module)] - (case (\ encoding.utf8 decode binary) + (case (\ utf8.codec decode binary) (#try.Success code) (wrap {#////.module module #////.file path diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux index e8685ce2b..c23688a9e 100644 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ b/stdlib/source/lux/tool/compiler/meta/packager/script.lux @@ -12,7 +12,8 @@ ["." product] [text ["%" format (#+ format)] - ["." encoding]] + [encoding + ["." utf8]]] [collection ["." row] ["." list ("#\." functor)]]] @@ -49,7 +50,7 @@ (monad.fold try.monad (function (_ content so_far) (|> content - (\ encoding.utf8 decode) + (\ utf8.codec decode) (\ try.monad map (function (_ content) (sequence so_far @@ -75,4 +76,4 @@ (list\map (function (_ [module [module_id [descriptor document output]]]) [module_id output])) (monad.fold ! (..write_module sequence) header) - (\ ! map (|>> scope to_code (\ encoding.utf8 encode))))))) + (\ ! map (|>> scope to_code (\ utf8.codec encode))))))) -- cgit v1.2.3