- Fixes for R back-end.

6 files changed, 154 insertions, 86 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