WIP: Separate Scheme compiler.

4 files changed, 123 insertions, 181 deletions

diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux
index d4cd440fb..04d3bae1d 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux
@@ -9,7 +9,7 @@
     ["." text
      format]
     [collection
-     ["." list ("#;." functor fold)]]]
+     ["." list ("#@." functor fold)]]]
    [target
     ["_" scheme (#+ Expression Computation Var)]]]
   ["." // #_
@@ -17,7 +17,7 @@
    ["#." primitive]
    ["#/" // #_
     ["#." reference]
-    ["#/" // ("#;." monad)
+    ["#/" // ("#@." monad)
      ["#/" // #_
       [reference (#+ Register)]
       ["#." synthesis (#+ Synthesis Path)]]]]])
@@ -35,15 +35,18 @@
             bodyO))))
 
 (def: #export (record-get generate valueS pathP)
-  (-> Phase Synthesis (List [Nat Bit])
+  (-> Phase Synthesis (List (Either Nat Nat))
       (Operation Expression))
   (do ////.monad
     [valueO (generate valueS)]
-    (wrap (list;fold (function (_ [idx tail?] source)
-                       (.let [method (.if tail?
-                                       //runtime.product//right
-                                       //runtime.product//left)]
-                         (method source (_.int (.int idx)))))
+    (wrap (list@fold (function (_ side source)
+                       (.let [method (.case side
+                                       (^template [<side> <accessor>]
+                                         (<side> lefts)
+                                         (<accessor> (_.int (.int lefts))))
+                                       ([#.Left  //runtime.tuple//left]
+                                        [#.Right //runtime.tuple//right]))]
+                         (method source)))
                      valueO
                      pathP))))
 
@@ -98,9 +101,9 @@
 (def: (pm-catch handler)
   (-> Expression Computation)
   (_.lambda [(list @alt-error) #.None]
-            (_.if (|> @alt-error (_.eqv?/2 pm-error))
-              handler
-              (_.raise/1 @alt-error))))
+       (_.if (|> @alt-error (_.eqv?/2 pm-error))
+         handler
+         (_.raise/1 @alt-error))))
 
 (def: (pattern-matching' generate pathP)
   (-> Phase Path (Operation Expression))
@@ -109,15 +112,14 @@
     (generate bodyS)
 
     #/////synthesis.Pop
-    (////;wrap pop-cursor!)
+    (////@wrap pop-cursor!)
 
     (#/////synthesis.Bind register)
-    (////;wrap (_.define (..register register) [(list) #.None]
-                         cursor-top))
+    (////@wrap (_.define-constant (..register register) ..cursor-top))
 
     (^template [<tag> <format> <=>]
       (^ (<tag> value))
-      (////;wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
+      (////@wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
                          fail-pm!)))
     ([/////synthesis.path/bit  //primitive.bit           _.eqv?/2]
      [/////synthesis.path/i64  (<| //primitive.i64 .int) _.=/2]
@@ -126,18 +128,18 @@
 
     (^template [<pm> <flag> <prep>]
       (^ (<pm> idx))
-      (////;wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))])
+      (////@wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))])
                    (_.if (_.null?/1 @temp)
                      fail-pm!
                      (push-cursor! @temp)))))
     ([/////synthesis.side/left  _.nil         (<|)]
      [/////synthesis.side/right (_.string "") inc])
 
-    (^template [<pm> <getter> <prep>]
+    (^template [<pm> <getter>]
       (^ (<pm> idx))
-      (////;wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!)))
-    ([/////synthesis.member/left  //runtime.product//left  (<|)]
-     [/////synthesis.member/right //runtime.product//right inc])
+      (////@wrap (push-cursor! (<getter> (_.int (.int idx)) cursor-top))))
+    ([/////synthesis.member/left  //runtime.tuple//left]
+     [/////synthesis.member/right //runtime.tuple//right])
 
     (^template [<tag> <computation>]
       (^ (<tag> leftP rightP))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux
index f33cb9599..6701bc078 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux
@@ -82,36 +82,24 @@
      Binary
      (<op> paramO subjectO))]
   
-  [bit::and _.bit-and/2]
-  [bit::or  _.bit-or/2]
-  [bit::xor _.bit-xor/2]
+  [i64::and _.bit-and/2]
+  [i64::or  _.bit-or/2]
+  [i64::xor _.bit-xor/2]
   )
 
-(def: (bit::left-shift [subjectO paramO])
+(def: (i64::left-shift [subjectO paramO])
   Binary
   (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO)
                         subjectO))
 
-(def: (bit::arithmetic-right-shift [subjectO paramO])
+(def: (i64::arithmetic-right-shift [subjectO paramO])
   Binary
   (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1)))
                         subjectO))
 
-(def: (bit::logical-right-shift [subjectO paramO])
+(def: (i64::logical-right-shift [subjectO paramO])
   Binary
-  (///runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
-
-(def: bundle::bit
-  Bundle
-  (<| (bundle.prefix "bit")
-      (|> bundle.empty
-          (bundle.install "and" (binary bit::and))
-          (bundle.install "or" (binary bit::or))
-          (bundle.install "xor" (binary bit::xor))
-          (bundle.install "left-shift" (binary bit::left-shift))
-          (bundle.install "logical-right-shift" (binary bit::logical-right-shift))
-          (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift))
-          )))
+  (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
 
 (import: java/lang/Double
   (#static MIN_VALUE Double)
@@ -122,9 +110,9 @@
      Nullary
      (<encode> <const>))]
 
-  [frac::smallest (Double::MIN_VALUE)            _.float]
-  [frac::min      (f/* -1.0 (Double::MAX_VALUE)) _.float]
-  [frac::max      (Double::MAX_VALUE)            _.float]
+  [f64::smallest (Double::MIN_VALUE)            _.float]
+  [f64::min      (f/* -1.0 (Double::MAX_VALUE)) _.float]
+  [f64::max      (Double::MAX_VALUE)            _.float]
   )
 
 (template [<name> <op>]
@@ -132,11 +120,11 @@
      Binary
      (|> subjectO (<op> paramO)))]
 
-  [int::+ _.+/2]
-  [int::- _.-/2]
-  [int::* _.*/2]
-  [int::/ _.quotient/2]
-  [int::% _.remainder/2]
+  [i64::+ _.+/2]
+  [i64::- _.-/2]
+  [i64::* _.*/2]
+  [i64::/ _.quotient/2]
+  [i64::% _.remainder/2]
   )
 
 (template [<name> <op>]
@@ -144,13 +132,13 @@
      Binary
      (<op> paramO subjectO))]
 
-  [frac::+ _.+/2]
-  [frac::- _.-/2]
-  [frac::* _.*/2]
-  [frac::/ _.//2]
-  [frac::% _.mod/2]
-  [frac::= _.=/2]
-  [frac::< _.</2]
+  [f64::+ _.+/2]
+  [f64::- _.-/2]
+  [f64::* _.*/2]
+  [f64::/ _.//2]
+  [f64::% _.mod/2]
+  [f64::= _.=/2]
+  [f64::< _.</2]
 
   [text::= _.string=?/2]
   [text::< _.string<?/2]
@@ -161,41 +149,47 @@
      Binary
      (<cmp> paramO subjectO))]
 
-  [int::= _.=/2]
-  [int::< _.</2]
+  [i64::= _.=/2]
+  [i64::< _.</2]
   )
 
-(def: int::char (|>> _.integer->char/1 _.string/1))
+(def: i64::char (|>> _.integer->char/1 _.string/1))
 
-(def: bundle::int
+(def: bundle::i64
   Bundle
-  (<| (bundle.prefix "int")
+  (<| (bundle.prefix "i64")
       (|> bundle.empty
-          (bundle.install "+" (binary int::+))
-          (bundle.install "-" (binary int::-))
-          (bundle.install "*" (binary int::*))
-          (bundle.install "/" (binary int::/))
-          (bundle.install "%" (binary int::%))
-          (bundle.install "=" (binary int::=))
-          (bundle.install "<" (binary int::<))
-          (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0)))))
-          (bundle.install "char" (unary int::char)))))
-
-(def: bundle::frac
+          (bundle.install "and" (binary i64::and))
+          (bundle.install "or" (binary i64::or))
+          (bundle.install "xor" (binary i64::xor))
+          (bundle.install "left-shift" (binary i64::left-shift))
+          (bundle.install "logical-right-shift" (binary i64::logical-right-shift))
+          (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift))
+          (bundle.install "+" (binary i64::+))
+          (bundle.install "-" (binary i64::-))
+          (bundle.install "*" (binary i64::*))
+          (bundle.install "/" (binary i64::/))
+          (bundle.install "%" (binary i64::%))
+          (bundle.install "=" (binary i64::=))
+          (bundle.install "<" (binary i64::<))
+          (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0)))))
+          (bundle.install "char" (unary i64::char)))))
+
+(def: bundle::f64
   Bundle
-  (<| (bundle.prefix "frac")
+  (<| (bundle.prefix "f64")
       (|> bundle.empty
-          (bundle.install "+" (binary frac::+))
-          (bundle.install "-" (binary frac::-))
-          (bundle.install "*" (binary frac::*))
-          (bundle.install "/" (binary frac::/))
-          (bundle.install "%" (binary frac::%))
-          (bundle.install "=" (binary frac::=))
-          (bundle.install "<" (binary frac::<))
-          (bundle.install "smallest" (nullary frac::smallest))
-          (bundle.install "min" (nullary frac::min))
-          (bundle.install "max" (nullary frac::max))
-          (bundle.install "to-int" (unary _.exact/1))
+          (bundle.install "+" (binary f64::+))
+          (bundle.install "-" (binary f64::-))
+          (bundle.install "*" (binary f64::*))
+          (bundle.install "/" (binary f64::/))
+          (bundle.install "%" (binary f64::%))
+          (bundle.install "=" (binary f64::=))
+          (bundle.install "<" (binary f64::<))
+          (bundle.install "smallest" (nullary f64::smallest))
+          (bundle.install "min" (nullary f64::min))
+          (bundle.install "max" (nullary f64::max))
+          (bundle.install "i64" (unary _.exact/1))
           (bundle.install "encode" (unary _.number->string/1))
           (bundle.install "decode" (unary ///runtime.frac//decode)))))
 
@@ -240,9 +234,8 @@
   Bundle
   (<| (bundle.prefix "lux")
       (|> bundle::lux
-          (dict.merge bundle::bit)
-          (dict.merge bundle::int)
-          (dict.merge bundle::frac)
+          (dict.merge bundle::i64)
+          (dict.merge bundle::f64)
           (dict.merge bundle::text)
           (dict.merge bundle::io)
           )))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux
index 3fe02a55d..94269b4aa 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux
@@ -38,8 +38,6 @@
 
 (def: unit (_.string /////synthesis.unit))
 
-(def: #export variant-tag "lux-variant")
-
 (def: (flag value)
   (-> Bit Computation)
   (if value
@@ -48,8 +46,7 @@
 
 (def: (variant' tag last? value)
   (-> Expression Expression Expression Computation)
-  (<| (_.cons/2 (_.symbol ..variant-tag))
-      (_.cons/2 tag)
+  (<| (_.cons/2 tag)
       (_.cons/2 last?)
       value))
 
@@ -102,15 +99,15 @@
                      _.Computation
                      (~ (case argsC+
                           #.Nil
-                          (` (_.define (~ @runtime) [(list) #.None] (~ definition)))
+                          (` (_.define-constant (~ @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))))))))))))
+                               (_.define-function (~ @runtime) [(list (~+ argsLC+)) #.None]
+                                                  (~ definition))))))))))))
 
 (runtime: (slice offset length list)
   (<| (_.if (_.null?/1 list)
@@ -156,58 +153,40 @@
   (_.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)
+(def: last-index
   (-> Expression Computation)
-  (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1)))))
+  (|>> _.length/1 (_.-/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")]
+(runtime: (tuple//left lefts tuple)
+  (with-vars [last-index-right]
     (_.begin
-     (list (_.define @index_min_length [(list) #.None]
-                     (minimum-index-length index))
-           (_.if (|> product _.length/1 (_.>/2 @index_min_length))
+     (list (_.define-constant last-index-right (..last-index tuple))
+           (_.if (_.>/2 lefts last-index-right)
              ## No need for recursion
-             (product-element index product)
+             (_.vector-ref/2 tuple lefts)
              ## 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))]
+             (tuple//left (_.-/2 last-index-right lefts)
+                          (_.vector-ref/2 tuple last-index-right)))))))
+
+(runtime: (tuple//right lefts tuple)
+  (with-vars [last-index-right right-index @slice]
     (_.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)))))))
+     (list (_.define-constant last-index-right (..last-index tuple))
+           (_.define-constant right-index (_.+/2 (_.int +1) lefts))
+           (_.cond (list [(_.=/2 right-index last-index-right)
+                          (_.vector-ref/2 tuple right-index)]
+                         [(_.>/2 right-index last-index-right)
+                          ## Needs recursion.
+                          (tuple//right (_.-/2 last-index-right lefts)
+                                        (_.vector-ref/2 tuple last-index-right))])
+                   (_.begin
+                    (list (_.define-constant @slice (_.make-vector/1 (_.-/2 right-index (_.length/1 tuple))))
+                          (_.vector-copy!/5 @slice (_.int +0) tuple right-index (_.length/1 tuple))
+                          @slice))))
+     )))
 
 (runtime: (sum//get sum last? wanted-tag)
-  (with-vars [variant-tag sum-tag sum-flag sum-value]
+  (with-vars [sum-tag sum-flag sum-value]
     (let [no-match _.nil
           is-last? (|> sum-flag (_.eqv?/2 (_.string "")))
           test-recursion (_.if is-last?
@@ -216,8 +195,10 @@
                                      (|> 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))]))
+      (<| (_.let (list [sum-tag (_.car/1 sum)]
+                       [sum-value (_.cdr/1 sum)]))
+          (_.let (list [sum-flag (_.car/1 sum-value)]
+                       [sum-value (_.cdr/1 sum-value)]))
           (_.if (|> wanted-tag (_.=/2 sum-tag))
             (_.if (|> sum-flag (_.eqv?/2 last?))
               sum-value
@@ -231,11 +212,11 @@
 
 (def: runtime//adt
   Computation
-  (_.begin (list @@product//left
-                 @@product//right
+  (_.begin (list @@tuple//left
+                 @@tuple//right
                  @@sum//get)))
 
-(runtime: (bit//logical-right-shift shift input)
+(runtime: (i64//logical-right-shift shift input)
   (_.if (_.=/2 (_.int +0) shift)
     input
     (|> input
@@ -244,7 +225,7 @@
 
 (def: runtime//bit
   Computation
-  (_.begin (list @@bit//logical-right-shift)))
+  (_.begin (list @@i64//logical-right-shift)))
 
 (runtime: (frac//decode input)
   (with-vars [@output]
@@ -259,42 +240,6 @@
   (_.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: (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))
@@ -310,8 +255,6 @@
                  runtime//bit
                  runtime//adt
                  runtime//frac
-                 runtime//array
-                 runtime//box
                  runtime//io
                  )))
 
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux
index e101effeb..f435442cc 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux
@@ -30,4 +30,8 @@
   (-> Phase (Variant Synthesis) (Operation Expression))
   (do ///.monad
     [valueT (generate valueS)]
-    (wrap (runtime.variant [lefts right? valueT]))))
+    (wrap (runtime.variant [(if right?
+                              (inc lefts)
+                              lefts)
+                            right?
+                            valueT]))))