diff options
Diffstat (limited to '')
5 files changed, 138 insertions, 75 deletions
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 |