diff options
14 files changed, 318 insertions, 179 deletions
diff --git a/new-luxc/source/luxc/lang/host/js.lux b/new-luxc/source/luxc/lang/host/js.lux new file mode 100644 index 000000000..b4c5acd58 --- /dev/null +++ b/new-luxc/source/luxc/lang/host/js.lux @@ -0,0 +1,106 @@ +(.module: + [lux #- or and function] + (lux (data [text] + text/format + (coll [list "list/" Functor<List> Fold<List>])))) + +(type: #export JS Text) + +(type: #export Expression JS) + +(type: #export Statement JS) + +(def: #export (number value) + (-> Frac Expression) + (%f value)) + +(def: #export (string value) + (-> Text Expression) + (%t value)) + +(def: #export (apply func args) + (-> Expression (List Expression) Expression) + (format func "(" (text.join-with "," args) ")")) + +(def: #export (var! name value) + (-> Text (Maybe Expression) Statement) + (case value + #.None + (format "var " name ";") + + (#.Some value) + (format "var " name " = " value ";"))) + +(def: #export (set! name value) + (-> Text Expression Statement) + (format name " = " value ";")) + +(def: #export (if! test then! else!) + (-> Expression Statement Statement Statement) + (format "if(" test ") " + then! + " else " + else!)) + +(def: #export (cond! clauses else!) + (-> (List [Expression Statement]) Statement Statement) + (list/fold (.function [[test then!] next!] + (if! test then! next!)) + else! + clauses)) + +(def: #export (block! statements) + (-> (List Statement) Statement) + (format "{" (text.join-with "" statements) "}")) + +(def: #export (while! test body) + (-> Expression (List Statement) Statement) + (format "while(" test ") " (block! body))) + +(def: #export (throw! message) + (-> Expression Statement) + (format "throw Error(" message ");")) + +(def: #export (return! value) + (-> Expression Statement) + (format "return " value ";")) + +(def: #export (function name args body) + (-> Text (List Text) (List Statement) Expression) + (let [args (format "(" (text.join-with ", " args) ")") + function (format "function " name args " " (block! body))] + (format "(" function ")"))) + +(def: #export (? test then else) + (-> Expression Expression Expression Expression) + (format "(" test " ? " then " : " else ")")) + +(def: #export (object fields) + (-> (List [Text Expression]) Expression) + (format "{" + (|> fields + (list/map (.function [[key val]] + (format key ": " val))) + (text.join-with ", ")) + "}")) + +(do-template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (format "(" subject " " <op> " " param ")"))] + + [= "="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [% "%"] + [or "||"] + [and "&&"] + [bit-or "|"] + [bit-and "&"] + ) diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux index a28d9c3db..063c01e25 100644 --- a/new-luxc/source/luxc/lang/translation/js.lux +++ b/new-luxc/source/luxc/lang/translation/js.lux @@ -14,15 +14,10 @@ [host #+ class: interface: object] (world [file #+ File])) (luxc [lang] - (lang [".L" variable #+ Register]) + (lang [".L" variable #+ Register] + (host [js #+ JS Expression Statement])) [".C" io])) -(type: #export JS Text) - -(type: #export Expression JS) - -(type: #export Statement JS) - (host.import java/lang/Object (toString [] String)) diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux index cbb0e6c77..7c624c102 100644 --- a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux @@ -6,15 +6,16 @@ (coll [list "list/" Fold<List>])) [macro #+ "meta/" Monad<Meta>]) (luxc [lang] - (lang ["ls" synthesis])) + (lang ["ls" synthesis] + (host [js #+ JS Expression Statement]))) [//] (// [".T" runtime] [".T" primitive] [".T" reference])) (def: #export (translate-let translate register valueS bodyS) - (-> (-> ls.Synthesis (Meta //.Expression)) Nat ls.Synthesis ls.Synthesis - (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis + (Meta Expression)) (do macro.Monad<Meta> [valueJS (translate valueS) bodyJS (translate bodyS)] @@ -24,8 +25,8 @@ "})()")))) (def: #export (translate-record-get translate valueS path) - (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis (List [Nat Bool]) - (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bool]) + (Meta Expression)) (do macro.Monad<Meta> [valueJS (translate valueS)] (wrap (list/fold (function [[idx tail?] source] @@ -35,50 +36,50 @@ path)))) (def: #export (translate-if testJS thenJS elseJS) - (-> //.Expression //.Expression //.Expression - //.Expression) + (-> Expression Expression Expression + Expression) (format "(" testJS " ? " thenJS " : " elseJS ")")) (def: savepoint - //.Expression + Expression "pm_cursor_savepoint") (def: cursor - //.Expression + Expression "pm_cursor") (def: (push-cursor value) - (-> //.Expression //.Expression) + (-> Expression Expression) (format cursor ".push(" value ");")) (def: save-cursor - //.Statement + Statement (format savepoint ".push(" cursor ".slice());")) (def: restore-cursor - //.Statement + Statement (format cursor " = " savepoint ".pop();")) (def: peek-cursor - //.Expression + Expression (format cursor "[" cursor ".length - 1]")) (def: pop-cursor - //.Statement + Statement (format cursor ".pop();")) (def: pm-error - //.Expression + Expression (%t "PM-ERROR")) (def: fail-pattern-matching - //.Statement + Statement (format "throw " pm-error ";")) (exception: #export Unrecognized-Path) (def: (translate-pattern-matching' translate path) - (-> (-> ls.Synthesis (Meta //.Expression)) Code (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) (case path (^code ("lux case exec" (~ bodyS))) (do macro.Monad<Meta> @@ -154,7 +155,7 @@ )) (def: report-pattern-matching-error - //.Statement + Statement (format "if(ex === " pm-error ") {" "throw \"Invalid expression for pattern-matching.\";" "}" @@ -163,7 +164,7 @@ "}")) (def: (translate-pattern-matching translate path) - (-> (-> ls.Synthesis (Meta //.Expression)) Code (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) (do macro.Monad<Meta> [pmJS (translate-pattern-matching' translate path)] (wrap (format "try {" pmJS "}" @@ -172,13 +173,13 @@ "}")))) (def: (initialize-pattern-matching stack-init) - (-> //.Expression //.Statement) + (-> Expression Statement) (format "var temp;" "var " cursor " = [" stack-init "];" "var " savepoint " = [];")) (def: #export (translate-case translate valueS path) - (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis Code (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression)) (do macro.Monad<Meta> [valueJS (translate valueS) pmJS (translate-pattern-matching translate path)] diff --git a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux index 50cfe833c..d4546ca4c 100644 --- a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux @@ -7,7 +7,8 @@ text/format (coll [array])) [host]) - (luxc [lang]) + (luxc [lang] + (lang (host [js #+ JS Expression Statement]))) [//]) (host.import java/lang/Object @@ -154,7 +155,7 @@ (exception: #export Cannot-Evaluate) (def: #export (eval code) - (-> //.Expression (Meta Top)) + (-> Expression (Meta Top)) (function [compiler] (case (|> compiler (get@ #.host) diff --git a/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux index 1bde82766..9fbaca3d2 100644 --- a/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux @@ -10,7 +10,8 @@ (luxc ["&" lang] (lang [".L" variable #+ Variable Register] [".L" extension] - ["ls" synthesis])) + ["ls" synthesis] + (host [js #+ JS Expression Statement]))) [//] (// [".T" runtime] [".T" primitive] @@ -25,7 +26,7 @@ (exception: #export Unrecognized-Synthesis) (def: #export (translate synthesis) - (-> ls.Synthesis (Meta //.Expression)) + (-> ls.Synthesis (Meta Expression)) (case synthesis (^code []) (:: macro.Monad<Meta> wrap runtimeT.unit) diff --git a/new-luxc/source/luxc/lang/translation/js/function.jvm.lux b/new-luxc/source/luxc/lang/translation/js/function.jvm.lux index b0865a16e..b3c6761cd 100644 --- a/new-luxc/source/luxc/lang/translation/js/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/function.jvm.lux @@ -7,13 +7,14 @@ [macro]) (luxc ["&" lang] (lang ["ls" synthesis] - [".L" variable #+ Variable])) + [".L" variable #+ Variable] + (host [js #+ JS Expression Statement]))) [//] (// [".T" reference] [".T" loop])) (def: #export (translate-apply translate functionS argsS+) - (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis (List ls.Synthesis) (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) (do macro.Monad<Meta> [functionJS (translate functionS) argsJS+ (monad.map @ translate argsS+)] @@ -23,7 +24,7 @@ (format "var " (referenceT.variable (n/inc register)) " = arguments[" (|> register nat-to-int %i) "];")) (def: (with-closure inits function) - (-> (List //.Expression) //.Expression //.Expression) + (-> (List Expression) Expression Expression) (let [closure (case inits #.Nil (list) @@ -36,9 +37,9 @@ ";})(" (text.join-with "," inits) ")"))) (def: #export (translate-function translate env arity bodyS) - (-> (-> ls.Synthesis (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) (List Variable) ls.Arity ls.Synthesis - (Meta //.Expression)) + (Meta Expression)) (do macro.Monad<Meta> [[function-name bodyJS] (//.with-sub-context (do @ diff --git a/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux index 9315508e8..657982556 100644 --- a/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux @@ -6,13 +6,14 @@ (coll [list "list/" Functor<List>])) [macro]) (luxc [lang] - (lang ["ls" synthesis])) + (lang ["ls" synthesis] + (host [js #+ JS Expression Statement]))) [//] (// [".T" reference])) (def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls.Synthesis (Meta //.Expression)) Nat (List ls.Synthesis) ls.Synthesis - (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis + (Meta Expression)) (do macro.Monad<Meta> [loop-name (:: @ map (|>> %code lang.normalize-name) (macro.gensym "loop")) @@ -26,8 +27,8 @@ "})(" (text.join-with "," initsJS+) ")")))) (def: #export (translate-recur translate argsS+) - (-> (-> ls.Synthesis (Meta //.Expression)) (List ls.Synthesis) - (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis) + (Meta Expression)) (do macro.Monad<Meta> [[loop-name offset] //.anchor argsJS+ (monad.map @ translate argsS+)] diff --git a/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux index 860cc7fae..2e1bf8389 100644 --- a/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux @@ -6,16 +6,17 @@ text/format) [macro "meta/" Monad<Meta>]) [//] - (// [".T" runtime])) + (// [".T" runtime]) + (luxc (lang (host [js #+ JS Expression Statement])))) (def: #export translate-bool - (-> Bool (Meta //.Expression)) + (-> Bool (Meta Expression)) (|>> %b meta/wrap)) (def: low-mask Nat (n/dec (bit.shift-left +32 +1))) (def: #export (translate-nat value) - (-> Nat (Meta //.Expression)) + (-> Nat (Meta Expression)) (let [high (|> value (bit.shift-right +32) nat-to-int %i) @@ -25,7 +26,7 @@ (meta/wrap (format runtimeT.int//new "(" high "," low ")")))) (def: #export translate-int - (-> Int (Meta //.Expression)) + (-> Int (Meta Expression)) (|>> int-to-nat translate-nat)) (def: deg-to-nat @@ -33,11 +34,11 @@ (|>> (:! Nat))) (def: #export translate-deg - (-> Deg (Meta //.Expression)) + (-> Deg (Meta Expression)) (|>> deg-to-nat translate-nat)) (def: #export translate-frac - (-> Frac (Meta //.Expression)) + (-> Frac (Meta Expression)) (|>> (cond> [(f/= number.positive-infinity)] [(new> "Infinity")] @@ -52,5 +53,5 @@ meta/wrap)) (def: #export translate-text - (-> Text (Meta //.Expression)) + (-> Text (Meta Expression)) (|>> %t meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux index 66c7fe6f5..afedc42e0 100644 --- a/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux @@ -6,7 +6,8 @@ text/format (coll [dict]))) (luxc ["&" lang] - (lang ["ls" synthesis])) + (lang ["ls" synthesis] + (host [js #+ JS Expression Statement]))) [//] (/ ["/." common] ["/." host])) @@ -19,8 +20,8 @@ (dict.merge /host.procedures))) (def: #export (translate-procedure translate name args) - (-> (-> ls.Synthesis (Meta //.Expression)) Text (List ls.Synthesis) - (Meta //.Expression)) + (-> (-> ls.Synthesis (Meta Expression)) Text (List ls.Synthesis) + (Meta Expression)) (<| (maybe.default (&.throw Unknown-Procedure (%t name))) (do maybe.Monad<Maybe> [proc (dict.get name procedures)] diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux index efef6084c..49bf7fe27 100644 --- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux @@ -14,7 +14,8 @@ [host]) (luxc ["&" lang] (lang ["la" analysis] - ["ls" synthesis])) + ["ls" synthesis] + (host [js #+ JS Expression Statement]))) [///] (/// [".T" runtime] [".T" case] @@ -23,10 +24,10 @@ ## [Types] (type: #export Translator - (-> ls.Synthesis (Meta ///.Expression))) + (-> ls.Synthesis (Meta Expression))) (type: #export Proc - (-> Translator (List ls.Synthesis) (Meta ///.Expression))) + (-> Translator (List ls.Synthesis) (Meta Expression))) (type: #export Bundle (Dict Text Proc)) @@ -34,11 +35,11 @@ (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)) +(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) @@ -64,7 +65,7 @@ (do @ [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) ///.Expression) ///.Expression) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) (-> Text ..Proc)) (function [(~ g!name)] (function [(~ g!translate) (~ g!inputs)] @@ -94,11 +95,11 @@ (wrap (proc inputsI)))))) (def: (self-contained content) - (-> ///.Expression ///.Expression) + (-> Expression Expression) (format "(" content ")")) (def: (void action) - (-> ///.Expression ///.Expression) + (-> Expression Expression) (format "(" action "," runtimeT.unit ")")) ## [Procedures] diff --git a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux index d9e508193..0c5cc3a44 100644 --- a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux @@ -4,32 +4,33 @@ (data [text] text/format)) (luxc ["&" lang] - (lang [".L" variable #+ Variable Register])) + (lang [".L" variable #+ Variable Register] + (host [js #+ JS Expression Statement]))) [//] (// [".T" runtime])) (do-template [<register> <translation> <prefix>] [(def: #export (<register> register) - (-> Register //.Expression) + (-> Register Expression) (format <prefix> (%i (nat-to-int register)))) (def: #export (<translation> register) - (-> Register (Meta //.Expression)) + (-> Register (Meta Expression)) (:: macro.Monad<Meta> wrap (<register> register)))] [closure translate-captured "c"] [variable translate-local "v"]) (def: #export (translate-variable var) - (-> Variable (Meta //.Expression)) + (-> Variable (Meta Expression)) (if (variableL.captured? var) (translate-captured (variableL.captured-register var)) (translate-local (int-to-nat var)))) (def: #export global - (-> Ident //.Expression) + (-> Ident Expression) //.definition-name) (def: #export (translate-definition name) - (-> Ident (Meta //.Expression)) + (-> Ident (Meta Expression)) (:: macro.Monad<Meta> wrap (global name))) diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux index 70f648be1..f002ccd1f 100644 --- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux @@ -6,54 +6,53 @@ (macro [code] ["s" syntax #+ syntax:]) [io #+ Process]) - [//]) + [//] + (luxc (lang (host [js #+ JS Expression Statement])))) (def: prefix Text "LuxRuntime") -(def: #export unit //.Expression (%t //.unit)) +(def: #export unit Expression (%t //.unit)) (def: (flag value) - (-> Bool //.JS) + (-> Bool JS) (if value (%t "") "null")) -(def: (variant-js tag last? value) - (-> //.Expression //.Expression //.Expression //.Expression) - (format "{" - //.variant-tag-field ": " tag "," - //.variant-flag-field ": " last? "," - //.variant-value-field ": " value - "}")) +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (js.object (list [//.variant-tag-field tag] + [//.variant-flag-field last?] + [//.variant-value-field value]))) (def: #export (variant tag last? value) - (-> Nat Bool //.Expression //.Expression) - (variant-js (%i (nat-to-int tag)) (flag last?) value)) + (-> Nat Bool Expression Expression) + (variant' (%i (nat-to-int tag)) (flag last?) value)) (def: none - //.Expression + Expression (variant +0 false unit)) (def: some - (-> //.Expression //.Expression) + (-> Expression Expression) (variant +1 true)) (def: left - (-> //.Expression //.Expression) + (-> Expression Expression) (variant +0 false)) (def: right - (-> //.Expression //.Expression) + (-> Expression Expression) (variant +1 true)) -(type: Runtime //.JS) +(type: Runtime JS) (def: (runtime-name name) (-> Text Text) (format prefix "$" name)) (def: (feature name definition) - (-> Text (-> Text //.Expression) //.Statement) + (-> Text (-> Text Expression) Statement) (format "var " name " = " (definition name) ";\n")) (syntax: (runtime-implementation-name [runtime-name s.local-symbol]) @@ -68,16 +67,16 @@ <js-definition>))))) (def: #export (int value) - (-> Int //.Expression) + (-> Int Expression) (format "({" //.int-high-field " : " (|> value int-to-nat //.high nat-to-int %i) ", " //.int-low-field " : " (|> value int-to-nat //.low nat-to-int %i) "})")) -(def: #export (frac value) - (-> Frac //.Expression) - (%f value)) +(def: #export frac + (-> Frac Expression) + js.number) (runtime: lux//try "runTry" (format "(function " @ "(op) {" @@ -157,7 +156,7 @@ "}" (format "else if(wantedTag > " sum-tag ") {" test-recursion "}") (format "else if(wantedTag < " sum-tag " && wantsLast === '') {" - (let [updated-sum (variant-js (format "(" sum-tag " - wantedTag)") sum-flag sum-value)] + (let [updated-sum (variant' (format "(" sum-tag " - wantedTag)") sum-flag sum-value)] (format "return " updated-sum ";")) "}") "else { " no-match " }" @@ -266,6 +265,9 @@ "}") "})")) +(runtime: int//-one "NEG_ONE" + (js.apply int//negate (list int//one))) + (runtime: int//from-number "fromNumberI64" (format "(function " @ "(num) {" (format "if(isNaN(num)) {" @@ -449,90 +451,115 @@ "return (" int//- "(l,r).H < 0);" "})")) +(def: (<I param subject) + (-> Expression Expression Expression) + (js.apply int//< (list subject param))) + +(def: (<=I param subject) + (-> Expression Expression Expression) + (js.or (js.apply int//< (list subject param)) + (js.apply int//= (list subject param)))) + +(def: (>I param subject) + (-> Expression Expression Expression) + (js.apply int//< (list param subject))) + +(def: (>=I param subject) + (-> Expression Expression Expression) + (js.or (js.apply int//< (list param subject)) + (js.apply int//= (list subject param)))) + +(def: (=I reference sample) + (-> Expression Expression Expression) + (js.apply int//= (list sample reference))) + (runtime: int/// "divI64" - (format "(function " @ "(l,r) {" - (format "if((r.H === 0) && (r.L === 0)) {" - ## Special case: R = 0 - "throw new Error('Cannot divide by zero!');" - "}" - "else if((l.H === 0) && (l.L === 0)) {" - ## Special case: L = 0 - "return l;" - "}") - (format "if(" int//= "(l," int//min ")) {" - ## Special case: L = MIN - (format "if(" int//= "(r," int//one ") || " int//= "(r, " int//negate "(" int//one "))) {" - ## Special case: L = MIN, R = 1|-1 - "return " int//min ";" - "}" - ## Special case: L = R = MIN - "else if(" int//= "(r," int//min ")) {" - "return " int//one ";" - "}" - ## Special case: L = MIN - "else {" - "var halfL = " bit//signed-shift-right "(l,1);" - "var approx = " bit//shift-left "(" @ "(halfL,r),1);" - (format "if((approx.H === 0) && (approx.L === 0)) {" - (format "if(r.H < 0) {" - "return " int//one ";" - "}" - "else {" - "return " int//negate "(" int//one ");" - "}") - "}" - "else {" - "var rem = " int//- "(l," int//* "(r,approx));" - "return " int//+ "(approx," @ "(rem,r));" - "}") - "}") - "}" - "else if(" int//= "(r," int//min ")) {" - ## Special case: R = MIN - "return " int//new "(0,0);" - "}") - ## Special case: negatives - (format "if(l.H < 0) {" - (format "if(r.H < 0) {" - ## Both are negative - "return " @ "( " int//negate "(l), " int//negate "(r));" - "}" - "else {" - ## Only L is negative - "return " int//negate "(" @ "( " int//negate "(l),r));" - "}") - "}" - "else if(r.H < 0) {" - ## R is negative - "return " int//negate "(" @ "(l, " int//negate "(r)));" - "}") - ## Common case - (format "var res = " int//zero ";" - "var rem = l;" - (format "while(" int//< "(r,rem) || " int//= "(r,rem)) {" - "var approx = Math.max(1, Math.floor(" int//to-number "(rem) / " int//to-number "(r)));" - "var log2 = Math.ceil(Math.log(approx) / Math.LN2);" - "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);" - "var approxRes = " int//from-number "(approx);" - "var approxRem = " int//* "(approxRes,r);" - (format "while((approxRem.H < 0) || " int//< "(rem,approxRem)) {" - "approx -= delta;" - "approxRes = " int//from-number "(approx);" - "approxRem = " int//* "(approxRes,r);" - "}") - (format "if((approxRes.H === 0) && (approxRes.L === 0)) {" - "approxRes = " int//one ";" - "}") - "res = " int//+ "(res,approxRes);" - "rem = " int//- "(rem,approxRem);" - "}") - "return res;") - "})")) + (let [negate (|>> (list) (js.apply int//negate)) + negative? (function [value] + (js.apply int//< (list value int//zero))) + valid-division-check [(=I int//zero "parameter") + (js.throw! (js.string "Cannot divide by zero!"))] + short-circuit-check [(=I int//zero "subject") + (js.return! int//zero)] + recur (function [subject parameter] + (js.apply @ (list subject parameter)))] + (js.function @ (list "subject" "parameter") + (list (js.cond! (list valid-division-check + short-circuit-check + + [(=I int//min "subject") + (js.cond! (list [(js.or (=I int//one "parameter") + (=I int//-one "parameter")) + (js.return! int//min)] + [(=I int//min "parameter") + (js.return! int//one)]) + (js.block! (list (js.var! "approximation" + (#.Some (js.apply bit//shift-left + (list (recur (js.apply bit//signed-shift-right + (list "subject" (js.number 1.0))) + "parameter") + (js.number 1.0))))) + (js.if! (=I int//zero "approximation") + (js.return! (js.? (negative? "parameter") + int//one + int//-one)) + (let [remainder (js.apply int//- (list "subject" + (js.apply int//* (list "parameter" + "approximation")))) + result (js.apply int//+ (list "approximation" + (recur remainder + "parameter")))] + (js.return! result))))))] + [(=I int//min "parameter") + (js.return! int//zero)] + + [(negative? "subject") + (js.return! (js.? (negative? "parameter") + (recur (negate "subject") + (negate "parameter")) + (negate (recur (negate "subject") + "parameter"))))] + + [(negative? "parameter") + (js.return! (negate (recur "subject" (negate "parameter"))))]) + (js.block! (list (js.var! "result" (#.Some int//zero)) + (js.var! "remainder" (#.Some "subject")) + (js.while! (>=I "parameter" "remainder") + (let [rough-estimate (js.apply "Math.floor" (list (js./ (js.apply int//to-number (list "parameter")) + (js.apply int//to-number (list "remainder"))))) + log2 (js./ "Math.LN2" + (js.apply "Math.log" (list "approximate"))) + approx-result (js.apply int//from-number (list "approximate")) + approx-remainder (js.apply int//* (list "approximate_result" "parameter"))] + (list (js.var! "approximate" (#.Some (js.apply "Math.max" (list (js.number 1.0) + rough-estimate)))) + (js.var! "log2" (#.Some (js.apply "Math.ceil" (list log2)))) + (js.var! "delta" (#.Some (js.? (js.<= (js.number 48.0) "log2") + (js.number 1.0) + (js.apply "Math.pow" (list (js.number 2.0) + (js.- (js.number 48.0) + "log2")))))) + (js.var! "approximate_result" (#.Some approx-result)) + (js.var! "approximate_remainder" (#.Some approx-remainder)) + (js.while! (js.or (negative? "approximate_remainder") + (>I "remainder" + "approximate_remainder")) + (list (js.set! "approximate" (js.- "delta" "approximate")) + (js.set! "approximate_result" approx-result) + (js.set! "approximate_remainder" approx-remainder))) + (js.block! (list (js.set! "result" (js.apply int//+ (list "result" + (js.? (=I int//zero "approximate_result") + int//one + "approximate_result")))) + (js.set! "remainder" (js.apply int//- (list "remainder" "approximate_remainder")))))))) + (js.return! "result"))) + ))))) (runtime: int//% "remI64" - (format "(function " @ "(l,r) {" - "return " int//- "(l," int//* "(" int/// "(l,r),r));" - "})")) + (js.function @ (list "subject" "parameter") + (list (let [flat (js.apply int//* (list (js.apply int/// (list "subject" "parameter")) + "parameter"))] + (js.return! (js.apply int//- (list "subject" flat))))))) (def: runtime//int Runtime diff --git a/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux index a2c0c6510..7bcd8e112 100644 --- a/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux @@ -3,14 +3,15 @@ (lux (control [monad #+ do]) [macro] (data text/format)) - (luxc (lang [".L" module])) + (luxc (lang [".L" module] + (host [js #+ JS Expression Statement]))) [//] (// [".T" runtime] [".T" reference] [".T" eval])) (def: #export (translate-def name expressionT expressionJS metaV) - (-> Text Type //.Expression Code (Meta Unit)) + (-> Text Type Expression Code (Meta Unit)) (do macro.Monad<Meta> [current-module macro.current-module-name #let [def-ident [current-module name]]] @@ -39,7 +40,7 @@ ))) (def: #export (translate-program programJS) - (-> //.Expression (Meta //.Statement)) + (-> Expression (Meta Statement)) (macro.fail "translate-program NOT IMPLEMENTED YET") ## (hostT.save (format "var " (referenceT.variable +0) " = " runtimeT.lux//program-args "();" ## "(" programJS ")(null);")) diff --git a/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux index 54f578bee..df7215dba 100644 --- a/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux @@ -5,12 +5,13 @@ text/format) [macro]) (luxc ["&" lang] - (lang [synthesis #+ Synthesis])) + (lang [synthesis #+ Synthesis] + (host [js #+ JS Expression Statement]))) [//] (// [".T" runtime])) (def: #export (translate-tuple translate elemsS+) - (-> (-> Synthesis (Meta //.Expression)) (List Synthesis) (Meta //.Expression)) + (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression)) (case elemsS+ #.Nil (:: macro.Monad<Meta> wrap runtimeT.unit) @@ -24,7 +25,7 @@ (wrap (format "[" (text.join-with "," elemsT+) "]"))))) (def: #export (translate-variant translate tag tail? valueS) - (-> (-> Synthesis (Meta //.Expression)) Nat Bool Synthesis (Meta //.Expression)) + (-> (-> Synthesis (Meta Expression)) Nat Bool Synthesis (Meta Expression)) (do macro.Monad<Meta> [valueT (translate valueS)] (wrap (runtimeT.variant tag tail? valueT)))) |