aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux38
-rw-r--r--new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux40
-rw-r--r--new-luxc/test/test/luxc/lang/translation/js/procedure/common.jvm.lux405
-rw-r--r--new-luxc/test/test/luxc/lang/translation/jvm/procedure/common.jvm.lux4
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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 14:11:09 +0000