1 files changed, 374 insertions, 0 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/runtime.jvm.lux
new file mode 100644
index 000000000..c67c2623f
--- /dev/null
+++ b/stdlib/source/lux/compiler/default/phase/translation/scheme/runtime.jvm.lux
@@ -0,0 +1,374 @@
+(.module:
+  [lux #*
+   [control
+    ["p" parser ("parser/." Monad<Parser>)]
+    [monad (#+ do)]]
+   [data
+    [number (#+ hex)]
+    [text
+     format]
+    [collection
+     ["." list ("list/." Monad<List>)]]]
+   ["." function]
+   [macro
+    ["." code]
+    ["s" syntax (#+ syntax:)]]]
+  ["." ///
+   ["//." //
+    [analysis (#+ Variant)]
+    ["." synthesis]
+    [//
+     ["." name]
+     [//
+      [host
+       ["_" scheme (#+ Expression Computation Var)]]]]]])
+
+(do-template [<name> <base>]
+  [(type: #export <name>
+     (<base> Var Expression Expression))]
+
+  [Operation ///.Operation]
+  [Phase ///.Phase]
+  [Handler ///.Handler]
+  [Bundle ///.Bundle]
+  )
+
+(def: prefix Text "LuxRuntime")
+
+(def: unit (_.string synthesis.unit))
+
+(def: #export variant-tag "lux-variant")
+
+(def: (flag value)
+  (-> Bit Computation)
+  (if value
+    (_.string "")
+    _.nil))
+
+(def: (variant' tag last? value)
+  (-> Expression Expression Expression Computation)
+  (<| (_.cons/2 (_.symbol ..variant-tag))
+      (_.cons/2 tag)
+      (_.cons/2 last?)
+      value))
+
+(def: #export (variant [lefts right? value])
+  (-> (Variant Expression) Computation)
+  (variant' (_.int (.int lefts)) (flag right?) value))
+
+(def: #export none
+  Computation
+  (variant [+0 #0 ..unit]))
+
+(def: #export some
+  (-> Expression Computation)
+  (|>> [+0 #1] ..variant))
+
+(def: #export left
+  (-> Expression Computation)
+  (|>> [+0 #0] ..variant))
+
+(def: #export right
+  (-> Expression Computation)
+  (|>> [+0 #1] ..variant))
+
+(def: declaration
+  (s.Syntax [Text (List Text)])
+  (p.either (p.seq s.local-symbol (parser/wrap (list)))
+            (s.form (p.seq s.local-symbol (p.some s.local-symbol)))))
+
+(syntax: (runtime: {[name args] declaration}
+           definition)
+  (let [implementation (code.local-symbol (format "@@" name))
+        runtime (format prefix "__" (name.normalize name))
+        @runtime (` (_.var (~ (code.text runtime))))
+        argsC+ (list/map code.local-symbol args)
+        argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`))
+                          args)
+        declaration (` ((~ (code.local-symbol name))
+                        (~+ argsC+)))
+        type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression)))
+                    _.Computation))]
+    (wrap (list (` (def: (~' #export) (~ declaration)
+                     (~ type)
+                     (~ (case argsC+
+                          #.Nil
+                          @runtime
+
+                          _
+                          (` (_.apply/* (~ @runtime) (list (~+ argsC+))))))))
+                (` (def: (~ implementation)
+                     _.Computation
+                     (~ (case argsC+
+                          #.Nil
+                          (` (_.define (~ @runtime) [(list) #.None] (~ definition)))
+
+                          _
+                          (` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
+                                           (list/map (function (_ [left right])
+                                                       (list left right)))
+                                           list/join))]
+                               (_.define (~ @runtime) [(list (~+ argsLC+)) #.None]
+                                         (~ definition))))))))))))
+
+(runtime: (slice offset length list)
+  (<| (_.if (_.null?/1 list)
+        list)
+      (_.if (|> offset (_.>/2 (_.int 0)))
+        (slice (|> offset (_.-/2 (_.int 1)))
+               length
+               (_.cdr/1 list)))
+      (_.if (|> length (_.>/2 (_.int 0)))
+        (_.cons/2 (_.car/1 list)
+                  (slice offset
+                         (|> length (_.-/2 (_.int 1)))
+                         (_.cdr/1 list))))
+      _.nil))
+
+(syntax: #export (with-vars {vars (s.tuple (p.many s.local-symbol))}
+                   body)
+  (wrap (list (` (let [(~+ (|> vars
+                               (list/map (function (_ var)
+                                           (list (code.local-symbol var)
+                                                 (` (_.var (~ (code.text (format "LRV__" (name.normalize var)))))))))
+                               list/join))]
+                   (~ body))))))
+
+(runtime: (lux//try op)
+  (with-vars [error]
+    (_.with-exception-handler
+      (_.lambda [(list error) #.None]
+           (..left error))
+      (_.lambda [(list) #.None]
+           (..right (_.apply/* op (list ..unit)))))))
+
+(runtime: (lux//program-args program-args)
+  (with-vars [@loop @input @output]
+    (_.letrec (list [@loop (_.lambda [(list @input @output) #.None]
+                                (_.if (_.eqv?/2 _.nil @input)
+                                  @output
+                                  (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))])
+              (_.apply/2 @loop (_.reverse/1 program-args) ..none))))
+
+(def: runtime//lux
+  Computation
+  (_.begin (list @@lux//try
+                 @@lux//program-args)))
+
+(def: minimum-index-length
+  (-> Expression Computation)
+  (|>> (_.+/2 (_.int 1))))
+
+(def: product-element
+  (-> Expression Expression Computation)
+  (function.flip _.vector-ref/2))
+
+(def: (product-tail product)
+  (-> Expression Computation)
+  (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int 1)))))
+
+(def: (updated-index min-length product)
+  (-> Expression Expression Computation)
+  (|> min-length (_.-/2 (_.length/1 product))))
+
+(runtime: (product//left product index)
+  (let [@index_min_length (_.var "index_min_length")]
+    (_.begin
+     (list (_.define @index_min_length [(list) #.None]
+                     (minimum-index-length index))
+           (_.if (|> product _.length/1 (_.>/2 @index_min_length))
+             ## No need for recursion
+             (product-element index product)
+             ## Needs recursion
+             (product//left (product-tail product)
+                            (updated-index @index_min_length product)))))))
+
+(runtime: (product//right product index)
+  (let [@index_min_length (_.var "index_min_length")
+        @product_length (_.var "product_length")
+        @slice (_.var "slice")
+        last-element? (|> @product_length (_.=/2 @index_min_length))
+        needs-recursion? (|> @product_length (_.</2 @index_min_length))]
+    (_.begin
+     (list
+      (_.define @index_min_length [(list) #.None] (minimum-index-length index))
+      (_.define @product_length [(list) #.None] (_.length/1 product))
+      (<| (_.if last-element?
+            (product-element index product))
+          (_.if needs-recursion?
+            (product//right (product-tail product)
+                            (updated-index @index_min_length product)))
+          ## Must slice
+          (_.begin
+           (list (_.define @slice [(list) #.None]
+                           (_.make-vector/1 (|> @product_length (_.-/2 index))))
+                 (_.vector-copy!/5 @slice (_.int 0) product index @product_length)
+                 @slice)))))))
+
+(runtime: (sum//get sum last? wanted-tag)
+  (with-vars [variant-tag sum-tag sum-flag sum-value]
+    (let [no-match _.nil
+          is-last? (|> sum-flag (_.eqv?/2 (_.string "")))
+          test-recursion (_.if is-last?
+                           ## Must recurse.
+                           (sum//get sum-value
+                                     (|> wanted-tag (_.-/2 sum-tag))
+                                     last?)
+                           no-match)]
+      (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None]
+                               (_.apply/* (_.global "apply") (list (_.global "values") sum))]))
+          (_.if (|> wanted-tag (_.=/2 sum-tag))
+            (_.if (|> sum-flag (_.eqv?/2 last?))
+              sum-value
+              test-recursion))
+          (_.if (|> wanted-tag (_.>/2 sum-tag))
+            test-recursion)
+          (_.if (_.and (list (|> last? (_.eqv?/2 (_.string "")))
+                             (|> wanted-tag (_.</2 sum-tag))))
+            (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value))
+          no-match))))
+
+(def: runtime//adt
+  Computation
+  (_.begin (list @@product//left
+                 @@product//right
+                 @@sum//get)))
+
+(runtime: (bit//logical-right-shift shift input)
+  (_.if (_.=/2 (_.int 0) shift)
+    input
+    (|> input
+        (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift))
+        (_.bit-and/2 (_.int (hex "7FFFFFFFFFFFFFFF"))))))
+
+(def: runtime//bit
+  Computation
+  (_.begin (list @@bit//logical-right-shift)))
+
+(runtime: (frac//decode input)
+  (with-vars [@output]
+    (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)])
+      (_.if (_.and (list (_.not/1 (_.=/2 @output @output))
+                         (_.not/1 (_.eqv?/2 (_.string "+nan.0") input))))
+        ..none
+        (..some @output)))))
+
+(def: runtime//frac
+  Computation
+  (_.begin
+   (list @@frac//decode)))
+
+(def: (check-index-out-of-bounds array idx body)
+  (-> Expression Expression Expression Computation)
+  (_.if (|> idx (_.<=/2 (_.length/1 array)))
+    body
+    (_.raise/1 (_.string "Array index out of bounds!"))))
+
+(runtime: (array//get array idx)
+  (with-vars [@temp]
+    (<| (check-index-out-of-bounds array idx)
+        (_.let (list [@temp (_.vector-ref/2 array idx)])
+          (_.if (|> @temp (_.eqv?/2 _.nil))
+            ..none
+            (..some @temp))))))
+
+(runtime: (array//put array idx value)
+  (<| (check-index-out-of-bounds array idx)
+      (_.begin
+       (list (_.vector-set!/3 array idx value)
+             array))))
+
+(def: runtime//array
+  Computation
+  (_.begin
+   (list @@array//get
+         @@array//put)))
+
+(runtime: (atom//compare-and-swap atom old new)
+  (with-vars [@temp]
+    (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))])
+      (_.if (_.eq?/2 old @temp)
+        (_.begin
+         (list (_.vector-set!/3 atom (_.int 0) new)
+               (_.bool #1)))
+        (_.bool #0)))))
+
+(def: runtime//atom
+  Computation
+  @@atom//compare-and-swap)
+
+(runtime: (box//write value box)
+  (_.begin
+   (list
+    (_.vector-set!/3 box (_.int 0) value)
+    ..unit)))
+
+(def: runtime//box
+  Computation
+  (_.begin (list @@box//write)))
+
+(runtime: (io//current-time _)
+  (|> (_.apply/* (_.global "current-second") (list))
+      (_.*/2 (_.int 1_000))
+      _.exact/1))
+
+(def: runtime//io
+  (_.begin (list @@io//current-time)))
+
+(def: process//incoming
+  Var
+  (_.var (name.normalize "process//incoming")))
+
+(runtime: (process//loop _)
+  (_.when (_.not/1 (_.null?/1 process//incoming))
+          (with-vars [queue process]
+            (_.let (list [queue process//incoming])
+              (_.begin (list (_.set! process//incoming (_.list/* (list)))
+                             (_.map/2 (_.lambda [(list process) #.None]
+                                           (_.apply/1 process ..unit))
+                                      queue)
+                             (process//loop ..unit)))))))
+
+(runtime: (process//schedule milli-seconds procedure)
+  (let [process//future (function (_ process)
+                          (_.set! process//incoming (_.cons/2 process process//incoming)))]
+    (_.begin
+     (list
+      (_.if (_.=/2 (_.int 0) milli-seconds)
+        (process//future procedure)
+        (with-vars [@start @process @now @ignored]
+          (_.let (list [@start (io//current-time ..unit)])
+            (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)]
+                                           (_.let (list [@now (io//current-time ..unit)])
+                                             (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds))
+                                               (_.apply/1 procedure ..unit)
+                                               (process//future @process))))])
+                      (process//future @process)))))
+      ..unit))))
+
+(def: runtime//process
+  Computation
+  (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list)))
+                 @@process//loop
+                 @@process//schedule)))
+
+(def: runtime
+  Computation
+  (_.begin (list @@slice
+                 runtime//lux
+                 runtime//bit
+                 runtime//adt
+                 runtime//frac
+                 runtime//array
+                 runtime//atom
+                 runtime//box
+                 runtime//io
+                 runtime//process
+                 )))
+
+(def: #export translate
+  (Operation Any)
+  (///.with-buffer
+    (do ////.Monad<Operation>
+      [_ (///.save! ["" ..prefix] ..runtime)]
+      (///.save-buffer! ""))))