diff options
Diffstat (limited to '')
13 files changed, 0 insertions, 1871 deletions
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<Maybe>] - [text] - text/format - [number] - (coll [list "list/" Functor<List> Fold<List>])) - (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 [<name> <function>] - [(def: #export <name> - (-> (List Expression) Expression) - (composite-literal (format <function> "(") ")" 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 [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (self-contained - (format (:representation subject) - " " <op> " " - (:representation param))))] - - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [%% "%%"] - [** "**"] - [or "||"] - [and "&&"] - ) - - (def: #export @@ - (All [k] (-> (Var k) Expression)) - (|>> ..name self-contained)) - - (def: #export global - (-> Text Expression) - (|>> var @@)) - - (template [<name> <func>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (..apply (.list subject param) (..global <func>)))] - - [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 [<name> <op>] - [(def: #export <name> - (-> Expression Expression) - (|>> :representation (format <op>) 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 [<name> <keyword>] - [(def: #export (<name> message) - (-> Expression Expression) - (..apply (.list message) (..global <keyword>)))] - - [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>] - 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 [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [No-Active-Module-Buffer] - [Cannot-Execute] - - [No-Anchor] - ) - -(host.import: java/lang/Object) - -(host.import: java/lang/String - (getBytes [String] #try [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<Error> - [_ (ScriptEngine::eval [(r.expression code)] interpreter)] - (wrap []))) - #interpreter (function (_ code) - (do e.Monad<Error> - [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 [<name> <field> <outputT>] - [(def: (<name> code) - (-> Expression (Meta <outputT>)) - (function (_ compiler) - (let [runner (|> compiler (get@ #.host) (:coerce Host) (get@ <field>))] - (case (runner code) - (#e.Error error) - ((lang.throw Cannot-Execute error) compiler) - - (#e.Success output) - (#e.Success [compiler output])))))] - - [load! #loader 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<Meta> - [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<Meta> - [module macro.current-module-name - module-buffer module-buffer - program-buffer program-buffer - #let [module-code (StringBuilder::toString [] module-buffer) - _ (Appendable::append [(:coerce CharSequence (format module-code "\n"))] - program-buffer)]] - (wrap (ioC.write target - (format (lang.normalize-name module) "/" 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<List> Fold<List>] - (set ["set" unordered #+ Set]))) - [macro #+ "meta/" Monad<Meta>] - (macro [code])) - (luxc [lang] - (lang [".L" variable #+ Register Variable] - ["ls" synthesis #+ Synthesis Path] - (host [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<Meta> - [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<Meta> - [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<Meta> - [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 [<tag> <format>] - [_ (<tag> value)] - (meta/wrap (r.when (r.not (r.= (|> value <format>) cursor-top)) - fail-pm!))) - ([#.Bit r.bool] - [#.Frac r.float] - [#.Text r.string]) - - (^template [<tag> <format>] - [_ (<tag> value)] - (meta/wrap (r.when (r.not (runtimeT.int//= (|> value <format>) cursor-top)) - fail-pm!))) - ([#.Nat (<| runtimeT.int (:coerce Int))] - [#.Int runtimeT.int] - [#.Rev (<| runtimeT.int (:coerce Int))]) - - (^template [<pm> <getter>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor! (<getter> cursor-top (r.int (:coerce Int idx)))))) - (["lux case tuple left" runtimeT.product//left] - ["lux case tuple right" runtimeT.product//right]) - - (^template [<pm> <flag>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap ($_ r.then - (r.set! $temp (runtimeT.sum//get cursor-top (r.int (:coerce Int idx)) <flag>)) - (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<Meta> - [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<Meta> - [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<Meta> - [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<Meta> - [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 [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Invalid-Function-Syntax] - [Unrecognized-Synthesis] - ) - -(def: #export (translate synthesis) - (-> ls.Synthesis (Meta Expression)) - (case synthesis - (^code []) - (:: macro.Monad<Meta> wrap runtimeT.unit) - - (^template [<tag> <generator>] - [_ (<tag> value)] - (<generator> 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<Meta> - ## [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<List> Fold<List>])) - [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<Meta>} - [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<Meta> - [_ (//.save function-definition)] - (wrap (r.global function-name))) - - _ - (do macro.Monad<Meta> - [_ (//.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<Meta>} - [[function-name bodyO] (//.with-sub-context - (do @ - [function-name //.context] - (//.with-anchor [function-name +1] - (translate bodyS)))) - closureO+ (monad.map @ referenceT.translate-variable env) - #let [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<List>])) - [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<Meta>} - [loop-name (|> (macro.gensym "loop") - (:: @ map (|>> %code lang.normalize-name))) - initsO+ (monad.map @ translate initsS+) - bodyO (//.with-anchor [loop-name offset] - (translate bodyS)) - #let [$loop-name (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<Meta>} - [[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<Meta>]) - (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/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 [<register> <translation> <prefix>] - [(def: #export (<register> register) - (-> Register SVar) - (r.var (format <prefix> (%i (.int register))))) - - (def: #export (<translation> register) - (-> Register (Meta Expression)) - (:: macro.Monad<Meta> wrap (@@ (<register> 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<Meta> 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<Parser>] - [monad #+ do]) - (data [bit] - [number (#+ hex) ("int/" Interval<Int>)] - text/format - (coll [list "list/" Monad<List>])) - [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 [<name> <value>] - [(runtime: <name> - (..int <value>))] - - [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 [<name> <op>] - [(runtime: (<name> mask input) - (int//new (<op> (int64-high (@@ mask)) - (int64-high (@@ input))) - (<op> (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 [<name> <top-cmp>] - [(def: (<name> top value) - (-> Expression Expression Expression) - (|> (|> value (r.>= (r.int 0))) - (r.and (|> value (<top-cmp> 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<Meta> - [_ //.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<Meta>} - [current-module macro.current-module-name - #let [def-name [current-module name]]] - (case (macro.get-identifier-ann (name-of #.alias) metaV) - (#.Some real-def) - (do @ - [[realT realA realV] (macro.find-def real-def) - _ (moduleL.define def-name [realT metaV realV])] - (wrap [])) - - _ - (do @ - [#let [def-name (referenceT.global def-name)] - _ (//.save (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<Meta> wrap runtimeT.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do {@ macro.Monad<Meta>} - [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<Meta> - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) diff --git a/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux index 85ccd90dc..85ccd90dc 100644 --- a/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux diff --git a/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux index 3bd33955f..3bd33955f 100644 --- a/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux |