aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
authorEduardo Julian2018-04-15 02:24:27 -0400
committerEduardo Julian2018-04-15 02:24:27 -0400
commit6eb9cf17f161522d4eddf6783284952f8a84f099 (patch)
tree9158749544826d8d0940117ca5884fdd2f90c327 /new-luxc
parent0bba53ceb52502510e0f6ba4c53a951933532a61 (diff)
- Fixes for R back-end.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/host/r.lux27
-rw-r--r--new-luxc/source/luxc/lang/translation/r/case.jvm.lux29
-rw-r--r--new-luxc/source/luxc/lang/translation/r/eval.jvm.lux13
-rw-r--r--new-luxc/source/luxc/lang/translation/r/function.jvm.lux9
-rw-r--r--new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux16
-rw-r--r--new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux146
-rw-r--r--new-luxc/test/test/luxc/lang/translation/case.lux15
-rw-r--r--new-luxc/test/test/luxc/lang/translation/common.lux81
-rw-r--r--new-luxc/test/test/luxc/lang/translation/function.lux10
-rw-r--r--new-luxc/test/test/luxc/lang/translation/structure.lux21
10 files changed, 238 insertions, 129 deletions
diff --git a/new-luxc/source/luxc/lang/host/r.lux b/new-luxc/source/luxc/lang/host/r.lux
index 5394b756f..6af15d058 100644
--- a/new-luxc/source/luxc/lang/host/r.lux
+++ b/new-luxc/source/luxc/lang/host/r.lux
@@ -44,10 +44,15 @@
(|>> (format "\n")
(text.replace-all "\n" "\n ")))
- (def: (block expression)
+ (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))
@@ -135,7 +140,7 @@
(self-contained
(format (@representation func)
(format "("
- (text.join-with "," (list/map expression args))
+ (text.join-with "," (list/map expression args)) ","
(text.join-with "," (list/map (.function (_ [key val])
(format key "=" (expression val)))
kw-args))
@@ -150,14 +155,14 @@
(-> Expression Expression Expression Expression)
(self-contained
(format "if(" (@representation test) ")"
- " " (block (@representation then))
- " else " (block (@representation else)))))
+ " " (.._block (@representation then))
+ " else " (.._block (@representation else)))))
(def: #export (when test then)
(-> Expression Expression Expression)
(self-contained
(format "if(" (@representation test) ") {"
- (block (@representation then))
+ (.._block (@representation then))
"\n" "}")))
(def: #export (cond clauses else)
@@ -237,7 +242,7 @@
(let [args (|> inputs (list/map ..name) (text.join-with ", "))]
(self-contained
(format "function(" args ") "
- (..block (@representation body))))))
+ (.._block (@representation body))))))
(def: #export (try body warning error finally)
(-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression)
@@ -248,23 +253,23 @@
(maybe.default ""))))]
(self-contained
(format "tryCatch("
- (..block (@representation body))
+ (.._block (@representation body))
(optional "warning" warning id)
(optional "error" error id)
- (optional "finally" finally ..block)
+ (optional "finally" finally .._block)
")"))))
(def: #export (while test body)
(-> Expression Expression Expression)
(self-contained
(format "while (" (@representation test) ") "
- (..block (@representation body)))))
+ (.._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)))))
+ (.._block (@representation body)))))
(do-template [<name> <keyword>]
[(def: #export (<name> message)
@@ -283,7 +288,7 @@
(def: #export (set-nth! idx value list)
(-> Expression Expression SVar Expression)
(self-contained
- (format (..name list) "[" (@representation idx) "] <- " (@representation value))))
+ (format (..name list) "[[" (@representation idx) "]] <- " (@representation value))))
(def: #export (then pre post)
(-> Expression Expression Expression)
diff --git a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
index 67de862e8..6ceae3842 100644
--- a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
@@ -25,9 +25,10 @@
[valueO (translate valueS)
bodyO (translate bodyS)
#let [$register (referenceT.variable register)]]
- (wrap ($_ r.then
- (r.set! $register valueO)
- bodyO))))
+ (wrap (r.block
+ ($_ r.then
+ (r.set! $register valueO)
+ bodyO)))))
(def: #export (translate-record-get translate valueS pathP)
(-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bool])
@@ -73,7 +74,7 @@
(def: cursor-top
Expression
- (top (@@ $cursor)))
+ (|> (@@ $cursor) (r.nth (top (@@ $cursor)))))
(def: pop-cursor!
Expression
@@ -115,13 +116,18 @@
[_ (<tag> value)]
(meta/wrap (r.when (r.not (r.= (|> value <format>) cursor-top))
fail-pm!)))
- ([#.Nat (<| runtimeT.int (:! Int))]
- [#.Int runtimeT.int]
- [#.Deg (<| runtimeT.int (:! Int))]
- [#.Bool r.bool]
+ ([#.Bool 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 (:! Int))]
+ [#.Int runtimeT.int]
+ [#.Deg (<| runtimeT.int (:! Int))])
+
(^template [<pm> <getter>]
(^code (<pm> (~ [_ (#.Nat idx)])))
(meta/wrap (push-cursor! (<getter> cursor-top (r.int (:! Int idx))))))
@@ -183,6 +189,7 @@
(do macro.Monad<Meta>
[valueO (translate valueS)
pattern-matching! (translate-pattern-matching translate pathP)]
- (wrap ($_ r.then
- (initialize-pattern-matching! valueO)
- pattern-matching!))))
+ (wrap (r.block
+ ($_ r.then
+ (initialize-pattern-matching! valueO)
+ pattern-matching!)))))
diff --git a/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux
index c026750a7..5685ae05e 100644
--- a/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux
@@ -81,7 +81,7 @@
(Long::intValue []))
(: Top
(if (host.instance? Null flag)
- host.null
+ (host.null)
//.unit))
value])))
@@ -90,9 +90,14 @@
(do e.Monad<Error>
[high (ListVector::get-field-sexp [//.int-high-field] host-object)
low (ListVector::get-field-sexp [//.int-low-field] host-object)
- #let [high (:! Nat (IntArrayVector::getElementAsInt [0] (:! IntArrayVector high)))
- low (:! Nat (IntArrayVector::getElementAsInt [0] (:! IntArrayVector low)))]]
- (wrap (|> high (bit.shift-left +32) (n/+ low) nat-to-int))))
+ #let [get-int-32 (|>> (IntArrayVector::getElementAsInt [0]) (:! Nat))
+ high (get-int-32 (:! IntArrayVector high))
+ low (get-int-32 (:! IntArrayVector low))]]
+ (wrap (:! Int
+ (n/+ (|> high (bit.shift-left +32))
+ (if (i/< 0 (:! Int low))
+ (|> low (bit.shift-left +32) (bit.shift-right +32))
+ low))))))
(def: (lux-object host-object)
(-> Object (Error Top))
diff --git a/new-luxc/source/luxc/lang/translation/r/function.jvm.lux b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
index 3d4407bd0..565a44909 100644
--- a/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
@@ -60,13 +60,14 @@
#let [arityO (|> arity nat-to-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 (@@ r.var-args))
+ (r.set! $curried var-args)
(r.set! $num_args (r.length (@@ $curried)))
(r.cond (list [(|> (@@ $num_args) (r.= arityO))
($_ r.then
@@ -76,7 +77,9 @@
(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 (@@ $num_args) (@@ $curried))]
+ output-func-args (r.slice (|> arityO (r.+ (r.int 1)))
+ (@@ $num_args)
+ (@@ $curried))]
(|> (@@ $function)
(apply-poly arity-args)
(apply-poly output-func-args)))])
@@ -84,7 +87,7 @@
(let [$missing (r.var "missing")]
(r.function (list r.var-args)
($_ r.then
- (r.set! $missing (@@ r.var-args))
+ (r.set! $missing var-args)
(|> (@@ $function)
(apply-poly (r.apply (list (@@ $curried) (@@ $missing))
(r.global "append"))))))))))))
diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
index 1bcd560e9..bc2289f6a 100644
--- a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
@@ -165,7 +165,7 @@
(do-template [<name> <op>]
[(def: (<name> [subjectO paramO])
Binary
- (<op> paramO subjectO))]
+ (<op> (runtimeT.int64-low paramO) subjectO))]
[bit//shift-left runtimeT.bit//shift-left]
[bit//signed-shift-right runtimeT.bit//signed-shift-right]
@@ -312,6 +312,8 @@
(function (_ value)
(r.apply (list value) func)))
+(def: nat//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8"))))
+
(def: nat-procs
Bundle
(<| (prefix "nat")
@@ -326,7 +328,7 @@
(install "min" (nullary nat//min))
(install "max" (nullary nat//max))
(install "to-int" (unary id))
- (install "char" (unary (apply1 (r.global "intToUtf8")))))))
+ (install "char" (unary nat//char)))))
(def: int-procs
Bundle
@@ -459,17 +461,21 @@
## [[IO]]
(def: (io//exit input)
- (-> Expression Expression)
+ Unary
(r.apply-kw (list)
(list ["status" (runtimeT.int//to-float input)])
(r.global "quit")))
+(def: (void code)
+ (-> Expression Expression)
+ (r.block (r.then code runtimeT.unit)))
+
(def: io-procs
Bundle
(<| (prefix "io")
(|> (dict.new text.Hash<Text>)
- (install "log" (unary (apply1 (r.global "print"))))
- (install "error" (unary (apply1 (r.global "stop"))))
+ (install "log" (unary (|>> r.print ..void)))
+ (install "error" (unary r.stop))
(install "exit" (unary io//exit))
(install "current-time" (nullary (function (_ _)
(runtimeT.io//current-time! runtimeT.unit)))))))
diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
index b75da1804..30eaf2a77 100644
--- a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
@@ -18,13 +18,31 @@
(def: #export unit Expression (r.string //.unit))
-(def: high (|>> int-to-nat (bit.shift-right +32) nat-to-int))
-(def: low (|>> int-to-nat (bit.and (hex "+FFFFFFFF")) nat-to-int))
+(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) nat-to-int (i/* -1))
+
+ ## else
+ (nat-to-int input)))
+
+(def: high-32 (bit.shift-right +32))
+(def: low-32 (|>> (bit.and (hex "+FFFFFFFF"))))
(def: #export (int value)
(-> Int Expression)
- (r.named-list (list [//.int-high-field (r.int (high value))]
- [//.int-low-field (r.int (low value))])))
+ (let [value (int-to-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)
(-> Bool Expression)
@@ -74,7 +92,7 @@
$runtime (` (r.var (~ (code.text runtime))))
@runtime (` (@@ (~ $runtime)))
argsC+ (list/map code.local-symbol args)
- argsLC+ (list/map (|>> lang.normalize-name code.text (~) (r.var) (`))
+ argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (r.var) (`))
args)
declaration (` ((~ (code.local-symbol name))
(~+ argsC+)))
@@ -82,7 +100,12 @@
r.Expression))]
(wrap (list (` (def: (~' #export) (~ declaration)
(~ type)
- (r.apply (list (~+ argsC+)) (~ @runtime))))
+ (~ (case argsC+
+ #.Nil
+ @runtime
+
+ _
+ (` (r.apply (list (~+ argsC+)) (~ @runtime)))))))
(` (def: (~ implementation)
r.Expression
(~ (case argsC+
@@ -109,8 +132,12 @@
(def: high-shift (r.bit-shl (r.int 32)))
-(def: f2^32 (|> (r.int 1) high-shift))
-(def: f2^63 (|> (r.int 1) (r.bit-shl (r.int 63))))
+(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)
@@ -130,24 +157,24 @@
high-shift)
low (|> (@@ input)
int//unsigned-low)]
- (|> high (r.+ 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))])))
-(do-template [<name> <high> <low>]
+(do-template [<name> <value>]
[(runtime: <name>
- (int//new (r.int <high>) (r.int <low>)))]
+ (..int <value>))]
- [int//zero 0 0]
- [int//one 0 1]
- [int//min (hex "80000000") 0]
- [int//max (hex "7FFFFFFF") (hex "FFFFFFFF")]
+ [int//zero 0]
+ [int//one 1]
+ [int//min ("lux int min")]
+ [int//max ("lux int max")]
)
-(def: int64-high (r.nth (r.string //.int-high-field)))
-(def: int64-low (r.nth (r.string //.int-low-field)))
+(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)
@@ -186,11 +213,18 @@
(new-half (@@ x16) (@@ x00))))))))
(runtime: (int//= reference sample)
- (let [comparison (: (-> (-> Expression Expression) Expression)
+ (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))))))]
+ (|> (|> (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)))))
+ (r.and (comparison int64-low))
+ isTRUE?)))
(runtime: (int//negate input)
(r.if (|> (@@ input) (int//= int//min))
@@ -432,9 +466,6 @@
(def: runtime//int
Runtime
($_ r.then
- @@int//unsigned-low
- @@int//to-float
- @@int//new
@@int//zero
@@int//one
@@int//min
@@ -443,11 +474,13 @@
@@int//<
@@int//+
@@int//-
+ @@int//negate
+ @@int//-one
+ @@int//unsigned-low
+ @@int//to-float
@@int//*
@@int///
- @@int//%
- @@int//negate
- @@int//from-float))
+ @@int//%))
(runtime: (lux//try op)
(with-vars [error value]
@@ -456,7 +489,8 @@
(..right (@@ value)))
#.None
(#.Some (r.function (list error)
- (..left (@@ error))))
+ (..left (r.nth (r.string "message")
+ (@@ error)))))
#.None)))
(runtime: (lux//program-args program-args)
@@ -590,20 +624,25 @@
(@@ count))))
(runtime: (bit//count input)
- (int//from-float (r.+ (int64-high (@@ input))
- (int64-low (@@ input)))))
+ (int//from-float (r.+ (bit//count-32 (int64-high (@@ input)))
+ (bit//count-32 (int64-low (@@ input))))))
(runtime: (bit//shift-right 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)) (r.bit-ushr (@@ shift)))
- low (|> (int64-low (@@ input))
- (r.bit-ushr (@@ shift))
- (r.bit-or mid))]
- (int//new high low))]
+ (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))])
@@ -710,14 +749,14 @@
(r.set! pL (int//from-float (int64-low (@@ param))))
(r.set! pH (int//from-float (int64-high (@@ param))))
(let [bottom (bit//shift-right (r.int 32)
- (r.* (@@ pL) (@@ sL)))
- middle (r.+ (r.* (@@ pL) (@@ sH))
- (r.* (@@ pH) (@@ sL)))
- top (r.* (@@ pH) (@@ sH))]
+ (int//* (@@ pL) (@@ sL)))
+ middle (int//+ (int//* (@@ pL) (@@ sH))
+ (int//* (@@ pH) (@@ sL)))
+ top (int//* (@@ pH) (@@ sH))]
(|> bottom
- (r.+ middle)
+ (int//+ middle)
(bit//shift-right (r.int 32))
- (r.+ top))))))
+ (int//+ top))))))
(runtime: (deg//leading-zeroes input)
(with-vars [zeroes remaining]
@@ -740,7 +779,7 @@
(deg//leading-zeroes (@@ subject)))
(r.global "min")))
(let [subject' (|> (@@ subject) (bit//shift-left (@@ min-shift)))
- param' (|> (@@ param) (bit//shift-left (@@ min-shift)) int64-low int//from-float)]
+ param' (|> (@@ param) (bit//shift-left (@@ min-shift)) int64-high int//from-float)]
(|> subject'
(int/// param')
(bit//shift-left (r.int 32))))))))
@@ -755,12 +794,9 @@
(int//new high low)))))
(runtime: (deg//to-frac input)
- (with-vars [two32]
- ($_ r.then
- (r.set! two32 f2^32)
- (let [high (|> (int64-high (@@ input)) (r./ (@@ two32)))
- low (|> (int64-low (@@ input)) (r./ (@@ two32)) (r./ (@@ two32)))]
- (|> low (r.+ high))))))
+ (let [high (|> (int64-high (@@ input)) (r./ f2^32))
+ low (|> (int64-low (@@ input)) (r./ f2^32) (r./ f2^32))]
+ (|> low (r.+ high))))
(def: runtime//deg
Runtime
@@ -936,7 +972,9 @@
(def: (list-append! value rlist)
(-> Expression SVar Expression)
- (r.set-nth! (r.length (@@ rlist)) value rlist))
+ (r.set-nth! (|> (@@ rlist) r.length (r.+ (r.int 1)))
+ value
+ rlist))
(runtime: (process//loop _)
(let [empty (r.list (list))]
@@ -965,7 +1003,7 @@
(with-vars [start now seconds _arg elapsed-time]
($_ r.then
(r.set! start current-time-float)
- (r.set! seconds (to-seconds (@@ milli-seconds)))
+ (r.set! seconds (to-seconds (int//to-float (@@ milli-seconds))))
(list-append! (r.function (list _arg)
($_ r.then
(r.set! now current-time-float)
@@ -989,10 +1027,14 @@
(def: runtime
Runtime
($_ r.then
- runtime//int
runtime//lux
- runtime//adt
+ @@f2^32
+ @@f2^63
+ @@int//new
+ @@int//from-float
runtime//bit
+ runtime//int
+ runtime//adt
runtime//nat
runtime//deg
runtime//frac
diff --git a/new-luxc/test/test/luxc/lang/translation/case.lux b/new-luxc/test/test/luxc/lang/translation/case.lux
index 04a373e42..dc198b633 100644
--- a/new-luxc/test/test/luxc/lang/translation/case.lux
+++ b/new-luxc/test/test/luxc/lang/translation/case.lux
@@ -83,7 +83,8 @@
(:! Bool valueT)
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can bind values."
(|> (run (` ("lux case" (~ (code.nat to-bind))
("lux case seq" ("lux case bind" +0)
@@ -92,7 +93,17 @@
(n/= to-bind (:! Nat valueT))
(#e.Error error)
- false))))))
+ (exec (log! error)
+ false))))
+ (test "Can translate \"let\" expressions."
+ (|> (run (` ("lux let" +0 (~ (code.nat to-bind))
+ (0))))
+ (case> (#e.Success valueT)
+ (n/= to-bind (:! Nat valueT))
+
+ (#e.Error error)
+ (exec (log! error)
+ false)))))))
(context: "[JVM] Pattern-matching."
(<| (times +100)
diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux
index e29931667..4ab1b879d 100644
--- a/new-luxc/test/test/luxc/lang/translation/common.lux
+++ b/new-luxc/test/test/luxc/lang/translation/common.lux
@@ -33,7 +33,8 @@
(n/= (<reference> param subject) (:! Nat valueT))
(#e.Error error)
- false)
+ (exec (log! error)
+ false))
(let [param <param-expr>])))]
["lux bit and" bit.and param]
@@ -49,7 +50,8 @@
(n/= (bit.count subject) (:! Nat valueT))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
<binary>
(test "lux bit shift-right"
@@ -61,7 +63,8 @@
(:! Int valueT))
(#e.Error error)
- false)
+ (exec (log! error)
+ false))
(let [param (n/% +64 param)])))
))))
@@ -78,7 +81,8 @@
(n/= <reference> (:! Nat valueT))
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux nat min" nat/bottom]
["lux nat max" nat/top]
@@ -90,7 +94,8 @@
(<comp> (<prepare> subject) (:! <type> valueT))
(#e.Error error)
- false)
+ (exec (log! error)
+ false))
(let [subject <subject-expr>])))]
["lux nat to-int" Int nat-to-int i/= subject]
@@ -103,7 +108,8 @@
(<comp> (<reference> param subject) (:! <outputT> valueT))
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux nat +" n/+ Nat n/=]
["lux nat -" n/- Nat n/=]
@@ -130,7 +136,8 @@
(i/= <reference> (:! Int valueT))
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux int min" int/bottom]
["lux int max" int/top]
@@ -142,7 +149,8 @@
(<comp> (<prepare> subject) (:! <type> valueT))
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux int to-nat" Nat int-to-nat n/=]
["lux int to-frac" Frac int-to-frac f/=]
@@ -155,7 +163,8 @@
(<comp> (<reference> param subject) (:! <outputT> valueT))
(#e.Error error)
- false))))]
+ (exec (log! error)
+ false)))))]
["lux int +" i/+ Int i/=]
["lux int -" i/- Int i/=]
@@ -221,7 +230,8 @@
(|> valueT (:! Frac) (f/- subject) frac/abs <test>)
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux frac to-int" "lux int to-frac" (f/< 1.0)]
["lux frac to-deg" "lux deg to-frac" (f/<= 0.000000001)]))
@@ -295,7 +305,8 @@
(<comp> (<reference> param subject) (:! <outputT> valueT))
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux deg +" d/+ Deg d/=]
["lux deg -" d/- Deg d/=]
@@ -418,7 +429,8 @@
(:! Bool valueV)
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can replace sub-text once."
(|> (run (` ("lux text ="
(~ (code.text post-rep-once))
@@ -430,7 +442,8 @@
(:! Bool valueV)
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can replace sub-text all times."
(|> (run (` ("lux text ="
(~ (code.text post-rep-all))
@@ -442,7 +455,8 @@
(:! Bool valueV)
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(let [test-clip (function (_ from to expected)
(|> (run (` ("lux text clip"
(~ concatenatedS)
@@ -485,7 +499,8 @@
(n/= size (:! Nat valueV))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can get element from array (if it exists)."
(and (|> (run (` ("lux array get" (~ array0S) (~ (code.nat idx)))))
(case> (^multi (#e.Success valueV)
@@ -527,7 +542,8 @@
true
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux math cos"]
["lux math sin"]
@@ -546,7 +562,8 @@
true
(#e.Error error)
- false)))]
+ (exec (log! error)
+ false))))]
["lux math pow"]))
))))
@@ -562,7 +579,8 @@
true
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can throw runtime errors."
(and (|> (run (` ("lux try" ("lux function" +1 []
("lux io error" (~ (code.text message)))))))
@@ -587,7 +605,8 @@
(n/>= pre post))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
)))
(def: (atom-spec run)
@@ -605,7 +624,8 @@
(n/= pre (:! Nat valueV))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can compare-and-swap atoms."
(and (|> (run (` ("lux let" +0 (~ preS)
("lux let" +1 ("lux atom new" (0))
@@ -617,7 +637,8 @@
(n/= post current-value)))
(#e.Error error)
- false))
+ (exec (log! error)
+ false)))
(|> (run (` ("lux let" +0 (~ preS)
("lux let" +1 ("lux atom new" (0))
[("lux atom compare-and-swap" (1) (~ postS) (~ postS))
@@ -628,7 +649,8 @@
(n/= pre current-value)))
(#e.Error error)
- false))))
+ (exec (log! error)
+ false)))))
)))
(def: (box-spec run)
@@ -646,7 +668,8 @@
(n/= pre (:! Nat valueV))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can write boxes."
(|> (run (` ("lux let" +0 (~ boxS)
("lux let" +1 ("lux box write" (~ postS) (0))
@@ -655,7 +678,8 @@
(n/= post (:! Nat valueV))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
)))
(def: (process-spec run)
@@ -667,7 +691,8 @@
(n/>= +1 (:! Nat valueV))
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(do r.Monad<Random>
[delay (|> r.nat (:: @ map (n/% +10)))
message (r.text +5)]
@@ -680,7 +705,8 @@
true
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
(test "Can schedule I/O operations for future execution."
(|> (run (` ("lux process schedule"
(~ (code.nat delay))
@@ -690,7 +716,8 @@
true
(#e.Error error)
- false)))
+ (exec (log! error)
+ false))))
))))
(def: (all-specs run)
diff --git a/new-luxc/test/test/luxc/lang/translation/function.lux b/new-luxc/test/test/luxc/lang/translation/function.lux
index 105072df7..b0baaaa03 100644
--- a/new-luxc/test/test/luxc/lang/translation/function.lux
+++ b/new-luxc/test/test/luxc/lang/translation/function.lux
@@ -38,16 +38,16 @@
(do r.Monad<Random>
[[arity arg functionS] gen-function
cut-off (|> r.nat (:: @ map (n/% arity)))
- args (r.list arity r.nat)
+ args (r.list arity r.frac)
#let [arg-value (maybe.assume (list.nth arg args))
- argsS (list/map code.nat args)
+ argsS (list/map code.frac args)
last-arg (n/dec arity)
cut-off (|> cut-off (n/min (n/dec last-arg)))]]
($_ seq
(test "Can read arguments."
(|> (run (` ("lux call" (~ functionS) (~+ argsS))))
(case> (#e.Success valueT)
- (n/= arg-value (:! Nat valueT))
+ (f/= arg-value (:! Frac valueT))
(#e.Error error)
(exec (log! error)
@@ -61,7 +61,7 @@
("lux call" (~ functionS) (~+ preS))
(~+ postS))))
(case> (#e.Success valueT)
- (n/= arg-value (:! Nat valueT))
+ (f/= arg-value (:! Frac valueT))
(#e.Error error)
(exec (log! error)
@@ -80,7 +80,7 @@
((~ (code.int arg-var))))))]
(|> (run (` ("lux call" (~ functionS) (~+ argsS))))
(case> (#e.Success valueT)
- (n/= arg-value (:! Nat valueT))
+ (f/= arg-value (:! Frac valueT))
(#e.Error error)
(exec (log! error)
diff --git a/new-luxc/test/test/luxc/lang/translation/structure.lux b/new-luxc/test/test/luxc/lang/translation/structure.lux
index deb015727..cf186364c 100644
--- a/new-luxc/test/test/luxc/lang/translation/structure.lux
+++ b/new-luxc/test/test/luxc/lang/translation/structure.lux
@@ -92,15 +92,18 @@
(and (n/= +3 (array.size valueT))
(let [_tag (:! Integer (maybe.assume (array.read +0 valueT)))
_last? (array.read +1 valueT)
- _value (:! Top (maybe.assume (array.read +2 valueT)))]
- (and (n/= tag (|> _tag host.int-to-long (:! Nat)))
- (case _last?
- (#.Some _last?')
- (and last? (text/= "" (:! Text _last?')))
-
- #.None
- (not last?))
- (corresponds? [member _value])))))
+ _value (:! Top (maybe.assume (array.read +2 valueT)))
+ same-tag? (n/= tag (|> _tag host.int-to-long (:! Nat)))
+ same-flag? (case _last?
+ (#.Some _last?')
+ (and last? (text/= "" (:! Text _last?')))
+
+ #.None
+ (not last?))
+ same-value? (corresponds? [member _value])]
+ (and same-tag?
+ same-flag?
+ same-value?))))
(#e.Error error)
(exec (log! error)