From b4d0eba7485caf0c6cf58de1193a9114fa273d8b Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 30 May 2020 15:19:28 -0400
Subject: Split new-luxc into lux-jvm and lux-r.

---
 .../source/luxc/lang/translation/r/runtime.jvm.lux | 802 ---------------------
 1 file changed, 802 deletions(-)
 delete mode 100644 new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux

(limited to 'new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux')

diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
deleted file mode 100644
index d641041d2..000000000
--- a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
+++ /dev/null
@@ -1,802 +0,0 @@
-(.module:
-  lux
-  (lux (control ["p" parser "p/" Monad<Parser>]
-                [monad #+ do])
-       (data [bit]
-             [number (#+ hex) ("int/" Interval<Int>)]
-             text/format
-             (coll [list "list/" Monad<List>]))
-       [macro]
-       (macro [code]
-              ["s" syntax #+ syntax:])
-       [io #+ Process])
-  [//]
-  (luxc [lang]
-        (lang (host [r #+ SVar Expression @@]))))
-
-(def: prefix Text "LuxRuntime")
-
-(def: #export unit Expression (r.string //.unit))
-
-(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) .int (i/* -1))
-        
-        ## else
-        (.int input)))
-
-(def: high-32 (bit.logical-right-shift +32))
-(def: low-32 (|>> (bit.and (hex "+FFFFFFFF"))))
-
-(def: #export (int value)
-  (-> Int Expression)
-  (let [value (.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)
-  (-> Bit Expression)
-  (if value
-    (r.string "")
-    r.null))
-
-(def: (variant' tag last? value)
-  (-> Expression Expression Expression Expression)
-  (r.named-list (list [//.variant-tag-field tag]
-                      [//.variant-flag-field last?]
-                      [//.variant-value-field value])))
-
-(def: #export (variant tag last? value)
-  (-> Nat Bit Expression Expression)
-  (variant' (r.int (.int tag))
-            (flag last?)
-            value))
-
-(def: #export none
-  Expression
-  (variant +0 #0 unit))
-
-(def: #export some
-  (-> Expression Expression)
-  (variant +1 #1))
-
-(def: #export left
-  (-> Expression Expression)
-  (variant +0 #0))
-
-(def: #export right
-  (-> Expression Expression)
-  (variant +1 #1))
-
-(type: Runtime Expression)
-
-(def: declaration
-  (s.Syntax [Text (List Text)])
-  (p.either (p.seq s.local-identifier (p/wrap (list)))
-            (s.form (p.seq s.local-identifier (p.some s.local-identifier)))))
-
-(syntax: (runtime: {[name args] declaration}
-           definition)
-  (let [implementation (code.local-identifier (format "@@" name))
-        runtime (format prefix "__" (lang.normalize-name name))
-        $runtime (` (r.var (~ (code.text runtime))))
-        @runtime (` (@@ (~ $runtime)))
-        argsC+ (list/map code.local-identifier args)
-        argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (r.var) (`))
-                          args)
-        declaration (` ((~ (code.local-identifier name))
-                        (~+ argsC+)))
-        type (` (-> (~+ (list.repeat (list.size argsC+) (` r.Expression)))
-                    r.Expression))]
-    (wrap (list (` (def: (~' #export) (~ declaration)
-                     (~ type)
-                     (~ (case argsC+
-                          #.Nil
-                          @runtime
-
-                          _
-                          (` (r.apply (list (~+ argsC+)) (~ @runtime)))))))
-                (` (def: (~ implementation)
-                     r.Expression
-                     (~ (case argsC+
-                          #.Nil
-                          (` (r.set! (~ $runtime) (~ definition)))
-
-                          _
-                          (` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
-                                           (list/map (function (_ [left right])
-                                                       (list left right)))
-                                           list/join))]
-                               (r.set! (~ $runtime)
-                                       (r.function (list (~+ argsLC+))
-                                         (~ definition)))))))))))))
-
-(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))}
-                   body)
-  (wrap (list (` (let [(~+ (|> vars
-                               (list/map (function (_ var)
-                                           (list (code.local-identifier var)
-                                                 (` (r.var (~ (code.text (format "LRV__" (lang.normalize-name var)))))))))
-                               list/join))]
-                   (~ body))))))
-
-(def: high-shift (r.bit-shl (r.int 32)))
-
-(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)
-  (r.apply (list value) (r.global "as.integer")))
-
-(runtime: (int//unsigned-low input)
-  (with-vars [low]
-    ($_ r.then
-        (r.set! low (|> (@@ input) (r.nth (r.string //.int-low-field))))
-        (r.if (|> (@@ low) (r.>= (r.int 0)))
-          (@@ low)
-          (|> (@@ low) (r.+ f2^32))))))
-
-(runtime: (int//to-float input)
-  (let [high (|> (@@ input)
-                 (r.nth (r.string //.int-high-field))
-                 high-shift)
-        low (|> (@@ input)
-                int//unsigned-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))])))
-
-(template [<name> <value>]
-  [(runtime: <name>
-     (..int <value>))]
-
-  [int//zero 0]
-  [int//one 1]
-  [int//min int/bottom]
-  [int//max int/top]
-  )
-
-(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)
-            (|> (@@ input) int64-low r.bit-not)))
-
-(runtime: (int//+ param subject)
-  (with-vars [sH sL pH pL
-              x00 x16 x32 x48]
-    ($_ r.then
-        (r.set! sH (|> (@@ subject) int64-high))
-        (r.set! sL (|> (@@ subject) int64-low))
-        (r.set! pH (|> (@@ param) int64-high))
-        (r.set! pL (|> (@@ param) int64-low))
-        (let [bits16 (r.code "0xFFFF")
-              move-top-16 (r.bit-shl (r.int 16))
-              top-16 (r.bit-ushr (r.int 16))
-              bottom-16 (r.bit-and bits16)
-              split-16 (function (_ source)
-                         [(|> source top-16)
-                          (|> source bottom-16)])
-              split-int (function (_ high low)
-                          [(split-16 high)
-                           (split-16 low)])
-              
-              [[s48 s32] [s16 s00]] (split-int (@@ sH) (@@ sL))
-              [[p48 p32] [p16 p00]] (split-int (@@ pH) (@@ pL))
-              new-half (function (_ top bottom)
-                         (|> top bottom-16 move-top-16
-                             (r.bit-or (bottom-16 bottom))))]
-          ($_ r.then
-              (r.set! x00 (|> s00 (r.+ p00)))
-              (r.set! x16 (|> (@@ x00) top-16 (r.+ s16) (r.+ p16)))
-              (r.set! x32 (|> (@@ x16) top-16 (r.+ s32) (r.+ p32)))
-              (r.set! x48 (|> (@@ x32) top-16 (r.+ s48) (r.+ p48)))
-              (int//new (new-half (@@ x48) (@@ x32))
-                        (new-half (@@ x16) (@@ x00))))))))
-
-(runtime: (int//= reference sample)
-  (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))))
-                            (r.or (|> (n/a? (field (@@ sample)))
-                                      (r.and (n/a? (field (@@ reference)))))))))]
-    (|> (comparison int64-high)
-        (r.and (comparison int64-low))
-        isTRUE?)))
-
-(runtime: (int//negate input)
-  (r.if (|> (@@ input) (int//= int//min))
-    int//min
-    (|> (@@ input) bit//not (int//+ int//one))))
-
-(runtime: int//-one
-  (int//negate int//one))
-
-(runtime: (int//- param subject)
-  (int//+ (int//negate (@@ param)) (@@ subject)))
-
-(runtime: (int//< reference sample)
-  (with-vars [r-? s-?]
-    ($_ r.then
-        (r.set! s-? (|> (@@ sample) int64-high (r.< (r.int 0))))
-        (r.set! r-? (|> (@@ reference) int64-high (r.< (r.int 0))))
-        (|> (|> (@@ s-?) (r.and (r.not (@@ r-?))))
-            (r.or (|> (r.not (@@ s-?)) (r.and (@@ r-?)) r.not))
-            (r.or (|> (@@ sample)
-                      (int//- (@@ reference))
-                      int64-high
-                      (r.< (r.int 0))))))))
-
-(runtime: (int//from-float input)
-  (r.cond (list [(r.apply (list (@@ input)) (r.global "is.nan"))
-                 int//zero]
-                [(|> (@@ input) (r.<= (r.negate f2^63)))
-                 int//min]
-                [(|> (@@ input) (r.+ (r.float 1.0)) (r.>= f2^63))
-                 int//max]
-                [(|> (@@ input) (r.< (r.float 0.0)))
-                 (|> (@@ input) r.negate int//from-float int//negate)])
-          (int//new (|> (@@ input) (r./ f2^32))
-                    (|> (@@ input) (r.%% f2^32)))))
-
-(runtime: (int//* param subject)
-  (with-vars [sH sL pH pL
-              x00 x16 x32 x48]
-    ($_ r.then
-        (r.set! sH (|> (@@ subject) int64-high))
-        (r.set! pH (|> (@@ param) int64-high))
-        (let [negative-subject? (|> (@@ sH) (r.< (r.int 0)))
-              negative-param? (|> (@@ pH) (r.< (r.int 0)))]
-          (r.cond (list [negative-subject?
-                         (r.if negative-param?
-                           (int//* (int//negate (@@ param))
-                                   (int//negate (@@ subject)))
-                           (int//negate (int//* (@@ param)
-                                                (int//negate (@@ subject)))))]
-
-                        [negative-param?
-                         (int//negate (int//* (int//negate (@@ param))
-                                              (@@ subject)))])
-                  ($_ r.then
-                      (r.set! sL (|> (@@ subject) int64-low))
-                      (r.set! pL (|> (@@ param) int64-low))
-                      (let [bits16 (r.code "0xFFFF")
-                            move-top-16 (r.bit-shl (r.int 16))
-                            top-16 (r.bit-ushr (r.int 16))
-                            bottom-16 (r.bit-and bits16)
-                            split-16 (function (_ source)
-                                       [(|> source top-16)
-                                        (|> source bottom-16)])
-                            split-int (function (_ high low)
-                                        [(split-16 high)
-                                         (split-16 low)])
-                            new-half (function (_ top bottom)
-                                       (|> top bottom-16 move-top-16
-                                           (r.bit-or (bottom-16 bottom))))
-                            x16-top (|> (@@ x16) top-16)
-                            x32-top (|> (@@ x32) top-16)]
-                        (with-vars [s48 s32 s16 s00
-                                    p48 p32 p16 p00]
-                          (let [[[_s48 _s32] [_s16 _s00]] (split-int (@@ sH) (@@ sL))
-                                [[_p48 _p32] [_p16 _p00]] (split-int (@@ pH) (@@ pL))
-                                set-subject-chunks! ($_ r.then (r.set! s48 _s48) (r.set! s32 _s32) (r.set! s16 _s16) (r.set! s00 _s00))
-                                set-param-chunks! ($_ r.then (r.set! p48 _p48) (r.set! p32 _p32) (r.set! p16 _p16) (r.set! p00 _p00))]
-                            ($_ r.then
-                                set-subject-chunks!
-                                set-param-chunks!
-                                (r.set! x00 (|> (@@ s00) (r.* (@@ p00))))
-                                (r.set! x16 (|> (@@ x00) top-16 (r.+ (|> (@@ s16) (r.* (@@ p00))))))
-                                (r.set! x32 x16-top)
-                                (r.set! x16 (|> (@@ x16) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p16))))))
-                                (r.set! x32 (|> (@@ x32) (r.+ x16-top) (r.+ (|> (@@ s32) (r.* (@@ p00))))))
-                                (r.set! x48 x32-top)
-                                (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s16) (r.* (@@ p16))))))
-                                (r.set! x48 (|> (@@ x48) (r.+ x32-top)))
-                                (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p32))))))
-                                (r.set! x48 (|> (@@ x48) (r.+ x32-top)
-                                                (r.+ (|> (@@ s48) (r.* (@@ p00))))
-                                                (r.+ (|> (@@ s32) (r.* (@@ p16))))
-                                                (r.+ (|> (@@ s16) (r.* (@@ p32))))
-                                                (r.+ (|> (@@ s00) (r.* (@@ p48))))))
-                                (int//new (new-half (@@ x48) (@@ x32))
-                                          (new-half (@@ x16) (@@ x00))))))
-                        )))))))
-
-(def: (limit-shift! shift)
-  (-> SVar Expression)
-  (r.set! shift (|> (@@ shift) (r.bit-and (r.int 63)))))
-
-(def: (no-shift-clause shift input)
-  (-> SVar SVar [Expression Expression])
-  [(|> (@@ shift) (r.= (r.int 0)))
-   (@@ input)])
-
-(runtime: (bit//left-shift shift input)
-  ($_ r.then
-      (limit-shift! shift)
-      (r.cond (list (no-shift-clause shift input)
-                    [(|> (@@ shift) (r.< (r.int 32)))
-                     (let [mid (|> (int64-low (@@ input)) (r.bit-ushr (|> (r.int 32) (r.- (@@ shift)))))
-                           high (|> (int64-high (@@ input))
-                                    (r.bit-shl (@@ shift))
-                                    (r.bit-or mid))
-                           low (|> (int64-low (@@ input))
-                                   (r.bit-shl (@@ shift)))]
-                       (int//new high low))])
-              (let [high (|> (int64-high (@@ input))
-                             (r.bit-shl (|> (@@ shift) (r.- (r.int 32)))))]
-                (int//new high (r.int 0))))))
-
-(runtime: (bit//arithmetic-right-shift-32 shift input)
-  (let [top-bit (|> (@@ input) (r.bit-and (r.int (hex "80000000"))))]
-    (|> (@@ input)
-        (r.bit-ushr (@@ shift))
-        (r.bit-or top-bit))))
-
-(runtime: (bit//arithmetic-right-shift 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))
-                                    (bit//arithmetic-right-shift-32 (@@ shift)))
-                           low (|> (int64-low (@@ input))
-                                   (r.bit-ushr (@@ shift))
-                                   (r.bit-or mid))]
-                       (int//new high low))])
-              (let [low (|> (int64-high (@@ input))
-                            (bit//arithmetic-right-shift-32 (|> (@@ shift) (r.- (r.int 32)))))
-                    high (r.if (|> (int64-high (@@ input)) (r.>= (r.int 0)))
-                           (r.int 0)
-                           (r.int -1))]
-                (int//new high low)))))
-
-(runtime: (int/// param subject)
-  (let [negative? (|>> (int//< int//zero))
-        valid-division-check [(|> (@@ param) (int//= int//zero))
-                              (r.stop (r.string "Cannot divide by zero!"))]
-        short-circuit-check [(|> (@@ subject) (int//= int//zero))
-                             int//zero]]
-    (r.cond (list valid-division-check
-                  short-circuit-check
-
-                  [(|> (@@ subject) (int//= int//min))
-                   (r.cond (list [(|> (|> (@@ param) (int//= int//one))
-                                      (r.or (|> (@@ param) (int//= int//-one))))
-                                  int//min]
-                                 [(|> (@@ param) (int//= int//min))
-                                  int//one])
-                           (with-vars [approximation]
-                             ($_ r.then
-                                 (r.set! approximation
-                                         (|> (@@ subject)
-                                             (bit//arithmetic-right-shift (r.int 1))
-                                             (int/// (@@ param))
-                                             (bit//left-shift (r.int 1))))
-                                 (r.if (|> (@@ approximation) (int//= int//zero))
-                                   (r.if (negative? (@@ param))
-                                     int//one
-                                     int//-one)
-                                   (let [remainder (int//- (int//* (@@ param) (@@ approximation))
-                                                           (@@ subject))]
-                                     (|> remainder
-                                         (int/// (@@ param))
-                                         (int//+ (@@ approximation))))))))]
-                  [(|> (@@ param) (int//= int//min))
-                   int//zero]
-
-                  [(negative? (@@ subject))
-                   (r.if (negative? (@@ param))
-                     (|> (int//negate (@@ subject))
-                         (int/// (int//negate (@@ param))))
-                     (|> (int//negate (@@ subject))
-                         (int/// (@@ param))
-                         int//negate))]
-
-                  [(negative? (@@ param))
-                   (|> (@@ param)
-                       int//negate
-                       (int/// (@@ subject))
-                       int//negate)])
-            (with-vars [result remainder approximate approximate-result log2 approximate-remainder]
-              ($_ r.then
-                  (r.set! result int//zero)
-                  (r.set! remainder (@@ subject))
-                  (r.while (|> (|> (@@ remainder) (int//< (@@ param)))
-                               (r.or (|> (@@ remainder) (int//= (@@ param)))))
-                           (let [calc-rough-estimate (r.apply (list (|> (int//to-float (@@ remainder)) (r./ (int//to-float (@@ param)))))
-                                                              (r.global "floor"))
-                                 calc-approximate-result (int//from-float (@@ approximate))
-                                 calc-approximate-remainder (|> (@@ approximate-result) (int//* (@@ param)))
-                                 delta (r.if (|> (r.float 48.0) (r.<= (@@ log2)))
-                                         (r.float 1.0)
-                                         (r.** (|> (@@ log2) (r.- (r.float 48.0)))
-                                               (r.float 2.0)))]
-                             ($_ r.then
-                                 (r.set! approximate (r.apply (list (r.float 1.0) calc-rough-estimate)
-                                                              (r.global "max")))
-                                 (r.set! log2 (let [log (function (_ input)
-                                                          (r.apply (list input) (r.global "log")))]
-                                                (r.apply (list (|> (log (r.int 2))
-                                                                   (r./ (log (@@ approximate)))))
-                                                         (r.global "ceil"))))
-                                 (r.set! approximate-result calc-approximate-result)
-                                 (r.set! approximate-remainder calc-approximate-remainder)
-                                 (r.while (|> (negative? (@@ approximate-remainder))
-                                              (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder)))))
-                                          ($_ r.then
-                                              (r.set! approximate (|> delta (r.- (@@ approximate))))
-                                              (r.set! approximate-result calc-approximate-result)
-                                              (r.set! approximate-remainder calc-approximate-remainder)))
-                                 (r.set! result (|> (r.if (|> (@@ approximate-result) (int//= int//zero))
-                                                      int//one
-                                                      (@@ approximate-result))
-                                                    (int//+ (@@ result))))
-                                 (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder)))))))
-                  (@@ result)))
-            )))
-
-(runtime: (int//% param subject)
-  (let [flat (|> (@@ subject) (int/// (@@ param)) (int//* (@@ param)))]
-    (|> (@@ subject) (int//- flat))))
-
-(def: runtime//int
-  Runtime
-  ($_ r.then
-      @@int//zero
-      @@int//one
-      @@int//min
-      @@int//max
-      @@int//=
-      @@int//<
-      @@int//+
-      @@int//-
-      @@int//negate
-      @@int//-one
-      @@int//unsigned-low
-      @@int//to-float
-      @@int//*
-      @@int///
-      @@int//%))
-
-(runtime: (lux//try op)
-  (with-vars [error value]
-    (r.try ($_ r.then
-               (r.set! value (r.apply (list ..unit) (@@ op)))
-               (..right (@@ value)))
-           #.None
-           (#.Some (r.function (list error)
-                     (..left (r.nth (r.string "message")
-                                    (@@ error)))))
-           #.None)))
-
-(runtime: (lux//program-args program-args)
-  (with-vars [inputs value]
-    ($_ r.then
-        (r.set! inputs ..none)
-        (<| (r.for-in value (@@ program-args))
-            (r.set! inputs (..some (r.list (list (@@ value) (@@ inputs))))))
-        (@@ inputs))))
-
-(def: runtime//lux
-  Runtime
-  ($_ r.then
-      @@lux//try
-      @@lux//program-args))
-
-(def: current-time-float
-  Expression
-  (let [raw-time (r.apply (list) (r.global "Sys.time"))]
-    (r.apply (list raw-time) (r.global "as.numeric"))))
-
-(runtime: (io//current-time! _)
-  (|> current-time-float
-      (r.* (r.float 1,000.0))
-      int//from-float))
-
-(def: runtime//io
-  Runtime
-  ($_ r.then
-      @@io//current-time!))
-
-(def: minimum-index-length
-  (-> SVar Expression)
-  (|>> @@ (r.+ (r.int 1))))
-
-(def: (product-element product index)
-  (-> Expression Expression Expression)
-  (|> product (r.nth (|> index (r.+ (r.int 1))))))
-
-(def: (product-tail product)
-  (-> SVar Expression)
-  (|> (@@ product) (r.nth (r.length (@@ product)))))
-
-(def: (updated-index min-length product)
-  (-> Expression Expression Expression)
-  (|> min-length (r.- (r.length product))))
-
-(runtime: (product//left product index)
-  (let [$index_min_length (r.var "index_min_length")]
-    ($_ r.then
-        (r.set! $index_min_length (minimum-index-length index))
-        (r.if (|> (r.length (@@ product)) (r.> (@@ $index_min_length)))
-          ## No need for recursion
-          (product-element (@@ product) (@@ index))
-          ## Needs recursion
-          (product//left (product-tail product)
-                         (updated-index (@@ $index_min_length) (@@ product)))))))
-
-(runtime: (product//right product index)
-  (let [$index_min_length (r.var "index_min_length")]
-    ($_ r.then
-        (r.set! $index_min_length (minimum-index-length index))
-        (r.cond (list [## Last element.
-                       (|> (r.length (@@ product)) (r.= (@@ $index_min_length)))
-                       (product-element (@@ product) (@@ index))]
-                      [## Needs recursion
-                       (|> (r.length (@@ product)) (r.< (@@ $index_min_length)))
-                       (product//right (product-tail product)
-                                       (updated-index (@@ $index_min_length) (@@ product)))])
-                ## Must slice
-                (|> (@@ product) (r.slice-from (@@ index)))))))
-
-(runtime: (sum//get sum wanted_tag wants_last)
-  (let [no-match r.null
-        sum-tag (|> (@@ sum) (r.nth (r.string //.variant-tag-field)))
-        sum-flag (|> (@@ sum) (r.nth (r.string //.variant-flag-field)))
-        sum-value (|> (@@ sum) (r.nth (r.string //.variant-value-field)))
-        is-last? (|> sum-flag (r.= (r.string "")))
-        test-recursion (r.if is-last?
-                         ## Must recurse.
-                         (sum//get sum-value
-                                   (|> (@@ wanted_tag) (r.- sum-tag))
-                                   (@@ wants_last))
-                         no-match)]
-    (r.cond (list [(r.= sum-tag (@@ wanted_tag))
-                   (r.if (r.= (@@ wants_last) sum-flag)
-                     sum-value
-                     test-recursion)]
-
-                  [(|> (@@ wanted_tag) (r.> sum-tag))
-                   test-recursion]
-
-                  [(|> (|> (@@ wants_last) (r.= (r.string "")))
-                       (r.and (|> (@@ wanted_tag) (r.< sum-tag))))
-                   (variant' (|> sum-tag (r.- (@@ wanted_tag))) sum-flag sum-value)])
-
-            no-match)))
-
-(def: runtime//adt
-  Runtime
-  ($_ r.then
-      @@product//left
-      @@product//right
-      @@sum//get
-      ))
-
-(template [<name> <op>]
-  [(runtime: (<name> mask input)
-     (int//new (<op> (int64-high (@@ mask))
-                     (int64-high (@@ input)))
-               (<op> (int64-low (@@ mask))
-                     (int64-low (@@ input)))))]
-
-  [bit//and r.bit-and]
-  [bit//or  r.bit-or]
-  [bit//xor r.bit-xor]
-  )
-
-(runtime: (bit//logical-right-shift shift input)
-  ($_ r.then
-      (limit-shift! shift)
-      (r.cond (list (no-shift-clause shift input)
-                    [(|> (@@ shift) (r.< (r.int 32)))
-                     (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))])
-              (let [low (|> (int64-high (@@ input)) (r.bit-ushr (|> (@@ shift) (r.- (r.int 32)))))]
-                (int//new (r.int 0) low)))))
-
-(def: runtime//bit
-  Runtime
-  ($_ r.then
-      @@bit//and
-      @@bit//or
-      @@bit//xor
-      @@bit//not
-      @@bit//left-shift
-      @@bit//arithmetic-right-shift-32
-      @@bit//arithmetic-right-shift
-      @@bit//logical-right-shift
-      ))
-
-(runtime: (frac//decode input)
-  (with-vars [output]
-    ($_ r.then
-        (r.set! output (r.apply (list (@@ input)) (r.global "as.numeric")))
-        (r.if (|> (@@ output) (r.= r.n/a))
-          ..none
-          (..some (@@ output))))))
-
-(def: runtime//frac
-  Runtime
-  ($_ r.then
-      @@frac//decode))
-
-(def: inc (-> Expression Expression) (|>> (r.+ (r.int 1))))
-
-(template [<name> <top-cmp>]
-  [(def: (<name> top value)
-     (-> Expression Expression Expression)
-     (|> (|> value (r.>= (r.int 0)))
-         (r.and (|> value (<top-cmp> top)))))]
-
-  [within? r.<]
-  [up-to?  r.<=]
-  )
-
-(def: (text-clip start end text)
-  (-> Expression Expression Expression Expression)
-  (r.apply (list text start end)
-           (r.global "substr")))
-
-(def: (text-length text)
-  (-> Expression Expression)
-  (r.apply (list text) (r.global "nchar")))
-
-(runtime: (text//index subject param start)
-  (with-vars [idx startF subjectL]
-    ($_ r.then
-        (r.set! startF (int//to-float (@@ start)))
-        (r.set! subjectL (text-length (@@ subject)))
-        (r.if (|> (@@ startF) (within? (@@ subjectL)))
-          ($_ r.then
-              (r.set! idx (|> (r.apply-kw (list (@@ param) (r.if (|> (@@ startF) (r.= (r.int 0)))
-                                                             (@@ subject)
-                                                             (text-clip (inc (@@ startF))
-                                                                        (inc (@@ subjectL))
-                                                                        (@@ subject))))
-                                          (list ["fixed" (r.bool #1)])
-                                          (r.global "regexpr"))
-                              (r.nth (r.int 1))))
-              (r.if (|> (@@ idx) (r.= (r.int -1)))
-                ..none
-                (..some (int//from-float (|> (@@ idx) (r.+ (@@ startF)))))))
-          ..none))))
-
-(runtime: (text//clip text from to)
-  (with-vars [length]
-    ($_ r.then
-        (r.set! length (r.length (@@ text)))
-        (r.if ($_ r.and
-                  (|> (@@ to) (within? (@@ length)))
-                  (|> (@@ from) (up-to? (@@ to))))
-          (..some (text-clip (inc (@@ from)) (inc (@@ to)) (@@ text)))
-          ..none))))
-
-(def: (char-at idx text)
-  (-> Expression Expression Expression)
-  (r.apply (list (text-clip idx idx text))
-           (r.global "utf8ToInt")))
-
-(runtime: (text//char text idx)
-  (r.if (|> (@@ idx) (within? (r.length (@@ text))))
-    ($_ r.then
-        (r.set! idx (inc (@@ idx)))
-        (..some (int//from-float (char-at (@@ idx) (@@ text)))))
-    ..none))
-
-(def: runtime//text
-  Runtime
-  ($_ r.then
-      @@text//index
-      @@text//clip
-      @@text//char))
-
-(def: (check-index-out-of-bounds array idx body)
-  (-> Expression Expression Expression Expression)
-  (r.if (|> idx (r.<= (r.length array)))
-    body
-    (r.stop (r.string "Array index out of bounds!"))))
-
-(runtime: (array//new size)
-  (with-vars [output]
-    ($_ r.then
-        (r.set! output (r.list (list)))
-        (r.set-nth! (|> (@@ size) (r.+ (r.int 1)))
-                    r.null
-                    output)
-        (@@ output))))
-
-(runtime: (array//get array idx)
-  (with-vars [temp]
-    (<| (check-index-out-of-bounds (@@ array) (@@ idx))
-        ($_ r.then
-            (r.set! temp (|> (@@ array) (r.nth (@@ idx))))
-            (r.if (|> (@@ temp) (r.= r.null))
-              ..none
-              (..some (@@ temp)))))))
-
-(runtime: (array//put array idx value)
-  (<| (check-index-out-of-bounds (@@ array) (@@ idx))
-      ($_ r.then
-          (r.set-nth! (@@ idx) (@@ value) array)
-          (@@ array))))
-
-(def: runtime//array
-  Runtime
-  ($_ r.then
-      @@array//new
-      @@array//get
-      @@array//put))
-
-(runtime: (box//write value box)
-  ($_ r.then
-      (r.set-nth! (r.int 1) (@@ value) box)
-      ..unit))
-
-(def: runtime//box
-  Runtime
-  ($_ r.then
-      @@box//write))
-
-(def: runtime
-  Runtime
-  ($_ r.then
-      runtime//lux
-      @@f2^32
-      @@f2^63
-      @@int//new
-      @@int//from-float
-      runtime//bit
-      runtime//int
-      runtime//adt
-      runtime//frac
-      runtime//text
-      runtime//array
-      runtime//box
-      runtime//io
-      ))
-
-(def: #export artifact Text (format prefix ".r"))
-
-(def: #export translate
-  (Meta (Process Any))
-  (do macro.Monad<Meta>
-    [_ //.init-module-buffer
-     _ (//.save runtime)]
-    (//.save-module! artifact)))
-- 
cgit v1.2.3