diff options
4 files changed, 459 insertions, 28 deletions
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 849ff67d0..ce79bda35 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 @@ -152,6 +152,14 @@ [bit//and runtimeT.bit//and] [bit//or runtimeT.bit//or] [bit//xor runtimeT.bit//xor] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectJS paramJS]) + Binary + (let [simple-param (format runtimeT.int//to-number "(" paramJS ")")] + (format <op> "(" subjectJS "," simple-param ")")))] + [bit//shift-left runtimeT.bit//shift-left] [bit//shift-right runtimeT.bit//signed-shift-right] [bit//unsigned-shift-right runtimeT.bit//shift-right] @@ -199,21 +207,21 @@ Nullary (<encode> <const>))] - [nat//min 0 runtimeT.int-constant] - [nat//max -1 runtimeT.int-constant] + [nat//min 0 runtimeT.int] + [nat//max -1 runtimeT.int] - [int//min Long::MIN_VALUE runtimeT.int-constant] - [int//max Long::MAX_VALUE runtimeT.int-constant] + [int//min Long::MIN_VALUE runtimeT.int] + [int//max Long::MAX_VALUE runtimeT.int] - [frac//smallest Double::MIN_VALUE runtimeT.frac-constant] - [frac//min (f/* -1.0 Double::MAX_VALUE) runtimeT.frac-constant] - [frac//max Double::MAX_VALUE runtimeT.frac-constant] - [frac//not-a-number Double::NaN runtimeT.frac-constant] - [frac//positive-infinity Double::POSITIVE_INFINITY runtimeT.frac-constant] - [frac//negative-infinity Double::NEGATIVE_INFINITY runtimeT.frac-constant] - - [deg//min 0 runtimeT.int-constant] - [deg//max -1 runtimeT.int-constant] + [frac//smallest Double::MIN_VALUE runtimeT.frac] + [frac//min (f/* -1.0 Double::MAX_VALUE) runtimeT.frac] + [frac//max Double::MAX_VALUE runtimeT.frac] + [frac//not-a-number Double::NaN runtimeT.frac] + [frac//positive-infinity Double::POSITIVE_INFINITY runtimeT.frac] + [frac//negative-infinity Double::NEGATIVE_INFINITY runtimeT.frac] + + [deg//min 0 runtimeT.int] + [deg//max -1 runtimeT.int] ) (do-template [<name> <op>] @@ -287,7 +295,9 @@ (def: (frac//decode inputJS) Unary - (format "parseFloat(" inputJS ")")) + (let [decoding (format "parseFloat(" inputJS ")") + thunk (format "(function () {" decoding "}")] + (lux//try decoding))) (do-template [<name> <transform>] [(def: (<name> inputJS) 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 aceac4089..0ff5e46b9 100644 --- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux @@ -59,15 +59,15 @@ (function [(~' @)] <js-definition>))))) -(def: #export (int-constant value) +(def: #export (int value) (-> Int //.Expression) - (format "{" + (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-constant value) +(def: #export (frac value) (-> Frac //.Expression) (%f value)) @@ -180,7 +180,7 @@ (runtime: int//to-number "toNumberI64" (format "(function " @ "(i64) {" - "return (i64.H * " int//2^32 ") + " @ "(i64);" + "return (i64.H * " int//2^32 ") + " int//unsigned-low "(i64);" "})")) (runtime: int//zero "ZERO" @@ -272,13 +272,28 @@ "}") "})")) +(runtime: bit//count32 "countI32" + (let [last-input-bit "input & 1" + update-count! (format "count += " last-input-bit ";") + consume-input! "input = input >>> 1;" + input-remaining? "input !== 0"] + (format "(function " @ "(input) {" + "var count = 0;" + "while(" input-remaining? ") {" + update-count! + consume-input! + "}" + "return count;" + "})"))) + (runtime: bit//count "countI64" - (format "(function " @ "(input) {" - "var hs = (input.H).toString(2);" - "var ls = (input.L).toString(2);" - "var num1s = hs.concat(ls).replace(/0/g,'').length;" - "return " int//from-number "(num1s);" - "})")) + (let [high (format bit//count32 "(input.H)") + low (format bit//count32 "(input.L)") + whole (format "(" high " + " low ")") + cast (format int//from-number "(" whole ")")] + (format "(function " @ "(input) {" + "return " cast ";" + "})"))) (runtime: bit//shift-left "shlI64" (format "(function " @ "(input,shift) {" @@ -347,6 +362,7 @@ __bit//or __bit//xor __bit//not + __bit//count32 __bit//count __bit//shift-left __bit//signed-shift-right @@ -443,7 +459,7 @@ ## Special case: L = MIN "else {" "var halfL = " bit//signed-shift-right "(l,1);" - "var approx = " bit//shift-left "(" @ "(halfL,r)," int//one ");" + "var approx = " bit//shift-left "(" @ "(halfL,r),1);" (format "if((approx.H === 0) && (approx.L === 0)) {" (format "if(r.H < 0) {" "return " int//one ";" diff --git a/new-luxc/test/test/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/test/test/luxc/lang/translation/js/procedure/common.jvm.lux new file mode 100644 index 000000000..1c52d9e7b --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/js/procedure/common.jvm.lux @@ -0,0 +1,405 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + [bit] + ["e" error] + [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] + [number "nat/" Interval<Nat> "int/" Number<Int> Interval<Int> "frac/" Number<Frac> Interval<Frac> "deg/" Interval<Deg>] + (coll ["a" array] + [list])) + ["r" math/random] + [macro] + (macro [code]) + [host] + test) + (luxc [lang] + (lang ["ls" synthesis] + (translation (js [".T" expression] + [".T" eval] + [".T" runtime])))) + (test/luxc common)) + +(context: "Bit procedures" + (<| (times +100) + (do @ + [param r.nat + subject r.nat] + (with-expansions [<binary> (do-template [<name> <reference> <param-expr>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.nat subject)) + (~ (code.nat param)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (n/= (<reference> param subject) (:! Nat valueT)) + + (#e.Error error) + false) + (let [param <param-expr>])))] + + ["lux bit and" bit.and param] + ["lux bit or" bit.or param] + ["lux bit xor" bit.xor param] + ["lux bit shift-left" bit.shift-left (n/% +64 param)] + ["lux bit unsigned-shift-right" bit.shift-right (n/% +64 param)] + )] + ($_ seq + (test "lux bit count" + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` ("lux bit count" (~ (code.nat subject)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (n/= (bit.count subject) (:! Nat valueT)) + + (#e.Error error) + false))) + + <binary> + (test "lux bit shift-right" + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` ("lux bit shift-right" + (~ (code.int (nat-to-int subject))) + (~ (code.nat param)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (i/= (bit.signed-shift-right param (nat-to-int subject)) + (:! Int valueT)) + + (#e.Error error) + false) + (let [param (n/% +64 param)]))) + ))))) + +(context: "Nat procedures" + (<| (times +100) + (do @ + [param (|> r.nat (r.filter (|>> (n/= +0) not))) + subject r.nat] + (`` ($_ seq + (~~ (do-template [<name> <reference>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name>)))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (n/= <reference> (:! Nat valueT)) + + (#e.Error error) + false)))] + + ["lux nat min" nat/bottom] + ["lux nat max" nat/top] + )) + (~~ (do-template [<name> <type> <prepare> <comp> <subject-expr>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.nat subject)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<prepare> subject) (:! <type> valueT)) + + (#e.Error error) + false) + (let [subject <subject-expr>])))] + + ["lux nat to-int" Int nat-to-int i/= subject] + ["lux nat char" Text text.from-code text/= (n/% (bit.shift-left +32 +1) subject)] + )) + (~~ (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.nat subject)) (~ (code.nat param)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["lux nat +" n/+ Nat n/=] + ["lux nat -" n/- Nat n/=] + ["lux nat *" n/* Nat n/=] + ["lux nat /" n// Nat n/=] + ["lux nat %" n/% Nat n/=] + ["lux nat =" n/= Bool bool/=] + ["lux nat <" n/< Bool bool/=] + )) + ))))) + +(context: "Int procedures" + (<| (times +100) + (do @ + [param (|> r.int (r.filter (|>> (i/= 0) not))) + subject r.int] + (with-expansions [<nullary> (do-template [<name> <reference>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name>)))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (i/= <reference> (:! Int valueT)) + + (#e.Error error) + false)))] + + ["lux int min" int/bottom] + ["lux int max" int/top] + ) + <unary> (do-template [<name> <type> <prepare> <comp>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.int subject)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<prepare> subject) (:! <type> valueT)) + + (#e.Error error) + false)))] + + ["lux int to-nat" Nat int-to-nat n/=] + ["lux int to-frac" Frac int-to-frac f/=] + ) + <binary> (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.int subject)) (~ (code.int param)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["lux int +" i/+ Int i/=] + ["lux int -" i/- Int i/=] + ["lux int *" i/* Int i/=] + ["lux int /" i// Int i/=] + ["lux int %" i/% Int i/=] + ["lux int =" i/= Bool bool/=] + ["lux int <" i/< Bool bool/=] + )] + ($_ seq + <nullary> + <unary> + <binary> + ))))) + +(context: "Frac procedures [Part 1]" + (<| (times +100) + (do @ + [param (|> r.frac (r.filter (|>> (f/= 0.0) not))) + subject r.frac] + (with-expansions [<binary> (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.frac subject)) (~ (code.frac param)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["lux frac +" f/+ Frac f/=] + ["lux frac -" f/- Frac f/=] + ["lux frac *" f/* Frac f/=] + ["lux frac /" f// Frac f/=] + ["lux frac %" f/% Frac f/=] + ["lux frac =" f/= Bool bool/=] + ["lux frac <" f/< Bool bool/=] + )] + ($_ seq + <binary> + ))))) + +(context: "Frac procedures [Part 2]" + (<| (times +100) + (do @ + [param (|> r.frac (r.filter (|>> (f/= 0.0) not))) + subject r.frac] + (with-expansions [<nullary> (do-template [<name> <test>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name>)))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<test> (:! Frac valueT)) + + _ + false)))] + + ["lux frac min" (f/= frac/bottom)] + ["lux frac max" (f/= frac/top)] + ["lux frac not-a-number" number.not-a-number?] + ["lux frac positive-infinity" (f/= number.positive-infinity)] + ["lux frac negative-infinity" (f/= number.negative-infinity)] + ["lux frac smallest" (f/= ("lux frac smallest"))] + ) + <unary> (do-template [<forward> <backward> <test>] + [(test <forward> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<backward> (<forward> (~ (code.frac subject))))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (|> valueT (:! Frac) (f/- subject) frac/abs <test>) + + (#e.Error error) + false)))] + + ["lux frac to-int" "lux int to-frac" (f/< 1.0)] + ["lux frac to-deg" "lux deg to-frac" (f/<= 0.000000001)])] + ($_ seq + <nullary> + <unary> + (test "frac encode|decode" + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` ("lux frac decode" ("lux frac encode" (~ (code.frac subject))))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (^multi (#e.Success valueT) + [(:! (Maybe Frac) valueT) (#.Some value)]) + (f/= subject value) + + _ + false))) + ))))) + +(def: deg-threshold + {#.doc "1/(2^30)"} + Deg + .000000001) + +(def: (above-threshold value) + (-> Deg Deg) + (if (d/< deg-threshold value) + (d/+ deg-threshold value) + value)) + +(def: (deg-difference reference sample) + (-> Deg Deg Deg) + (if (d/> reference sample) + (d/- reference sample) + (d/- sample reference))) + +(context: "Deg procedures" + (<| (times +100) + (do @ + [param (|> r.deg (:: @ map above-threshold)) + special r.nat + subject (|> r.deg (:: @ map above-threshold))] + (`` ($_ seq + (~~ (do-template [<name> <reference>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name>)))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (d/= <reference> (:! Deg valueT)) + + _ + false)))] + + ["lux deg min" deg/bottom] + ["lux deg max" deg/top] + )) + (~~ (do-template [<forward> <backward> <type>] + [(test <forward> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<backward> (<forward> (~ (code.deg subject))))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueV) + (d/<= deg-threshold (deg-difference subject (:! <type> valueV))) + + _ + false)))] + + ["lux deg to-frac" "lux frac to-deg" Deg] + )) + (~~ (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.deg subject)) (~ (code.deg param)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["lux deg +" d/+ Deg d/=] + ["lux deg -" d/- Deg d/=] + ["lux deg *" d/* Deg d/=] + ["lux deg /" d// Deg d/=] + ["lux deg %" d/% Deg d/=] + ["lux deg =" d/= Bool bool/=] + ["lux deg <" d/< Bool bool/=] + )) + (~~ (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleJS (expressionT.translate (` (<name> (~ (code.deg subject)) (~ (code.nat special)))))] + (evalT.eval sampleJS)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<comp> (<reference> special subject) (:! <outputT> valueT)) + + _ + false)))] + + ["lux deg scale" d/scale Deg d/=] + ["lux deg reciprocal" d/reciprocal Deg d/=] + )) + ))))) diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/test/test/luxc/lang/translation/jvm/procedure/common.jvm.lux index 8e4fd362f..d81058e17 100644 --- a/new-luxc/test/test/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/test/test/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -50,7 +50,7 @@ ["lux bit unsigned-shift-right" bit.shift-right] )] ($_ seq - (test "bit count" + (test "lux bit count" (|> (do macro.Monad<Meta> [sampleI (expressionT.translate (` ("lux bit count" (~ (code.nat subject)))))] (@eval.eval sampleI)) @@ -63,7 +63,7 @@ false))) <binary> - (test "bit shift-right" + (test "lux bit shift-right" (|> (do macro.Monad<Meta> [sampleI (expressionT.translate (` ("lux bit shift-right" (~ (code.int (nat-to-int subject))) |