- Initial Common Lisp back-end implementation.

7 files changed, 104 insertions, 264 deletions

diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux
index 35ec86c1b..7a6cabe73 100644
--- a/new-luxc/test/test/luxc/common.lux
+++ b/new-luxc/test/test/luxc/common.lux
@@ -39,11 +39,16 @@
                            ##    [".T_r" eval]
                            ##    [".T_r" runtime]
                            ##    [".T_r" statement])
-                           [scheme]
-                           (scheme [".T_scheme" expression]
-                                   [".T_scheme" eval]
-                                   [".T_scheme" runtime]
-                                   [".T_scheme" statement])
+                           ## [scheme]
+                           ## (scheme [".T_scheme" expression]
+                           ##         [".T_scheme" eval]
+                           ##         [".T_scheme" runtime]
+                           ##         [".T_scheme" statement])
+                           [common-lisp]
+                           (common-lisp [".T_common-lisp" expression]
+                                        [".T_common-lisp" eval]
+                                        [".T_common-lisp" runtime]
+                                        [".T_common-lisp" statement])
                            ))))
 
 (type: #export Runner (-> Synthesis (e.Error Top)))
@@ -62,7 +67,8 @@
   ## [init-ruby ruby.init]
   ## [init-python python.init]
   ## [init-r r.init]
-  [init-scheme scheme.init]
+  ## [init-scheme scheme.init]
+  [init-common-lisp common-lisp.init]
   )
 
 (def: (runner translate-runtime translate-expression eval init)
@@ -109,5 +115,8 @@
 ## (def: #export run-r (runner runtimeT_r.translate expressionT_r.translate evalT_r.eval init-r))
 ## (def: #export def-r (definer runtimeT_r.translate expressionT_r.translate evalT_r.eval init-r statementT_r.translate-def))
 
-(def: #export run-scheme (runner runtimeT_scheme.translate expressionT_scheme.translate evalT_scheme.eval init-scheme))
-(def: #export def-scheme (definer runtimeT_scheme.translate expressionT_scheme.translate evalT_scheme.eval init-scheme statementT_scheme.translate-def))
+## (def: #export run-scheme (runner runtimeT_scheme.translate expressionT_scheme.translate evalT_scheme.eval init-scheme))
+## (def: #export def-scheme (definer runtimeT_scheme.translate expressionT_scheme.translate evalT_scheme.eval init-scheme statementT_scheme.translate-def))
+
+(def: #export run-common-lisp (runner runtimeT_common-lisp.translate expressionT_common-lisp.translate evalT_common-lisp.eval init-common-lisp))
+(def: #export def-common-lisp (definer runtimeT_common-lisp.translate expressionT_common-lisp.translate evalT_common-lisp.eval init-common-lisp statementT_common-lisp.translate-def))
diff --git a/new-luxc/test/test/luxc/lang/translation/case.lux b/new-luxc/test/test/luxc/lang/translation/case.lux
index 75736d223..bca451332 100644
--- a/new-luxc/test/test/luxc/lang/translation/case.lux
+++ b/new-luxc/test/test/luxc/lang/translation/case.lux
@@ -120,6 +120,10 @@
 ##   (<| (times +100)
 ##       (pattern-matching-spec run-r)))
 
-(context: "[Scheme] Function."
+## (context: "[Scheme] Pattern-matching."
+##   (<| (times +100)
+##       (pattern-matching-spec run-scheme)))
+
+(context: "[Common Lisp] Pattern-matching."
   (<| (times +100)
-      (pattern-matching-spec run-scheme)))
+      (pattern-matching-spec run-common-lisp)))
diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux
index 8734336aa..ad10fb8bd 100644
--- a/new-luxc/test/test/luxc/lang/translation/common.lux
+++ b/new-luxc/test/test/luxc/lang/translation/common.lux
@@ -44,15 +44,6 @@
                                  ["lux bit unsigned-shift-right" bit.shift-right (n/% +64 param)]
                                  )]
       ($_ seq
-          (test "lux bit count"
-                (|> (run (` ("lux bit count" (~ (code.nat subject)))))
-                    (case> (#e.Success valueT)
-                           (n/= (bit.count subject) (:! Nat valueT))
-
-                           (#e.Error error)
-                           (exec (log! error)
-                             false))))
-
           <binary>
           (test "lux bit shift-right"
                 (|> (run (` ("lux bit shift-right"
@@ -68,59 +59,6 @@
                     (let [param (n/% +64 param)])))
           ))))
 
-(def: (nat-spec run)
-  (-> Runner Test)
-  (do r.Monad<Random>
-    [param (|> r.nat (r.filter (|>> (n/= +0) not)))
-     subject r.nat]
-    (`` ($_ seq
-            (~~ (do-template [<name> <reference>]
-                  [(test <name>
-                         (|> (run (` (<name>)))
-                             (case> (#e.Success valueT)
-                                    (n/= <reference> (:! Nat valueT))
-
-                                    (#e.Error error)
-                                    (exec (log! error)
-                                      false))))]
-
-                  ["lux nat min" nat/bottom]
-                  ["lux nat max" nat/top]
-                  ))
-            (~~ (do-template [<name> <type> <prepare> <comp> <subject-expr>]
-                  [(test <name>
-                         (|> (run (` (<name> (~ (code.nat subject)))))
-                             (case> (#e.Success valueT)
-                                    (<comp> (<prepare> subject) (:! <type> valueT))
-
-                                    (#e.Error error)
-                                    (exec (log! error)
-                                      false))
-                             (let [subject <subject-expr>])))]
-
-                  ["lux nat to-int" Int  nat-to-int     i/=    subject]
-                  ["lux nat char"   Text text.from-code text/= (n/% (bit.shift-left +8 +1) subject)]
-                  ))
-            (~~ (do-template [<name> <reference> <outputT> <comp>]
-                  [(test <name>
-                         (|> (run (` (<name> (~ (code.nat subject)) (~ (code.nat param)))))
-                             (case> (#e.Success valueT)
-                                    (<comp> (<reference> param subject) (:! <outputT> valueT))
-
-                                    (#e.Error error)
-                                    (exec (log! error)
-                                      false))))]
-
-                  ["lux nat +" n/+ Nat  n/=]
-                  ["lux nat -" n/- Nat  n/=]
-                  ["lux nat *" n/* Nat  n/=]
-                  ["lux nat /" n// Nat  n/=]
-                  ["lux nat %" n/% Nat  n/=]
-                  ["lux nat =" n/= Bool bool/=]
-                  ["lux nat <" n/< Bool bool/=]
-                  ))
-            ))))
-
 (def: (int-spec run)
   (-> Runner Test)
   (do r.Monad<Random>
@@ -142,7 +80,7 @@
                   ["lux int min" int/bottom]
                   ["lux int max" int/top]
                   ))
-            (~~ (do-template [<name> <type> <prepare> <comp>]
+            (~~ (do-template [<name> <type> <prepare> <comp> <subject-expr>]
                   [(test <name>
                          (|> (run (` (<name> (~ (code.int subject)))))
                              (case> (#e.Success valueT)
@@ -150,10 +88,14 @@
 
                                     (#e.Error error)
                                     (exec (log! error)
-                                      false))))]
+                                      false))
+                             (let [subject <subject-expr>])))]
 
-                  ["lux int to-nat"  Nat  int-to-nat  n/=]
-                  ["lux int to-frac" Frac int-to-frac f/=]
+                  ["lux int to-frac" Frac int-to-frac f/= subject]
+                  ["lux int char"    Text (|>> (:! Nat) text.from-code) text/= (|> subject
+                                                                                   (:! Nat)
+                                                                                   (n/% (bit.shift-left +8 +1))
+                                                                                   (:! Int))]
                   ))
             (~~ (do-template [<name> <reference> <outputT> <comp>]
                   [(test <name>
@@ -233,16 +175,7 @@
                                     (exec (log! error)
                                       false))))]
 
-                  ["lux frac to-int" "lux int to-frac" (f/< 1.0)]
-                  ["lux frac to-deg" "lux deg to-frac" (f/<= 0.000000001)]))
-            (test "frac encode|decode"
-                  (|> (run (` ("lux frac decode" ("lux frac encode" (~ (code.frac subject))))))
-                      (case> (^multi (#e.Success valueT)
-                                     [(:! (Maybe Frac) valueT) (#.Some value)])
-                             (f/= subject value)
-
-                             _
-                             false)))
+                  ["lux frac to-int" "lux int to-frac" (f/< 1.0)]))
             ))))
 
 (def: (frac-spec run)
@@ -251,85 +184,6 @@
       (frac-spec|0 run)
       (frac-spec|1 run)))
 
-(def: deg-threshold
-  {#.doc "~ 1/(2^30)"}
-  Deg
-  .000000001)
-
-(def: (above-threshold value)
-  (-> Deg Deg)
-  (if (d/< deg-threshold value)
-    (d/+ deg-threshold value)
-    value))
-
-(def: (deg-difference reference sample)
-  (-> Deg Deg Deg)
-  (if (d/> reference sample)
-    (d/- reference sample)
-    (d/- sample reference)))
-
-(def: (deg-spec run)
-  (-> Runner Test)
-  (do r.Monad<Random>
-    [param (|> r.deg (:: @ map above-threshold))
-     special r.nat
-     subject (|> r.deg (:: @ map above-threshold))]
-    (`` ($_ seq
-            (~~ (do-template [<name> <reference>]
-                  [(test <name>
-                         (|> (run (` (<name>)))
-                             (case> (#e.Success valueT)
-                                    (d/= <reference> (:! Deg valueT))
-
-                                    _
-                                    false)))]
-
-                  ["lux deg min" deg/bottom]
-                  ["lux deg max" deg/top]
-                  ))
-            (~~ (do-template [<forward> <backward> <type>]
-                  [(test <forward>
-                         (|> (run (` (<backward> (<forward> (~ (code.deg subject))))))
-                             (case> (#e.Success valueV)
-                                    (d/<= deg-threshold (deg-difference subject (:! <type> valueV)))
-
-                                    _
-                                    false)))]
-
-                  ["lux deg to-frac" "lux frac to-deg" Deg]
-                  ))
-            (~~ (do-template [<name> <reference> <outputT> <comp>]
-                  [(test <name>
-                         (|> (run (` (<name> (~ (code.deg subject)) (~ (code.deg param)))))
-                             (case> (#e.Success valueT)
-                                    (<comp> (<reference> param subject) (:! <outputT> valueT))
-
-                                    (#e.Error error)
-                                    (exec (log! error)
-                                      false))))]
-
-                  ["lux deg +" d/+ Deg  d/=]
-                  ["lux deg -" d/- Deg  d/=]
-                  ["lux deg *" d/* Deg  d/=]
-                  ["lux deg /" d// Deg  d/=]
-                  ["lux deg %" d/% Deg  d/=]
-                  ["lux deg =" d/= Bool bool/=]
-                  ["lux deg <" d/< Bool bool/=]
-                  ))
-            (~~ (do-template [<name> <reference> <outputT> <comp>]
-                  [(test <name>
-                         (|> (run (` (<name> (~ (code.deg subject)) (~ (code.nat special)))))
-                             (case> (#e.Success valueT)
-                                    (<comp> (<reference> special subject) (:! <outputT> valueT))
-
-                                    _
-                                    false)))]
-
-                  ["lux deg scale"      d/scale      Deg d/=]
-                  ["lux deg reciprocal" d/reciprocal Deg d/=]
-                  ))
-            ))))
-
 (def: lower-alpha
   (r.Random Nat)
   (|> r.nat (:: r.Functor<Random> map (|>> (n/% +26) (n/+ +97)))))
@@ -424,7 +278,9 @@
                               _
                               false))))
         (test "Text hashing is consistent."
-              (|> (run (` ("lux nat =" ("lux text hash" (~ sample0S)) ("lux text hash" (~ sample0S)))))
+              (|> (run (` ("lux int ="
+                           ("lux text hash" (~ sample0S))
+                           ("lux text hash" (~ sample0S)))))
                   (case> (#e.Success valueV)
                          (:! Bool valueV)
                          
@@ -696,37 +552,24 @@
       (do r.Monad<Random>
         [delay (|> r.nat (:: @ map (n/% +10)))
          message (r.text +5)]
-        ($_ seq
-            (test "Can execute I/O operations in parallel."
-                  (|> (run (` ("lux process future"
-                               ("lux function" +1 []
-                                ("lux io log" (~ (code.text (format "EXECUTE: " message))))))))
-                      (case> (#e.Success valueV)
-                             true
-
-                             (#e.Error error)
-                             (exec (log! error)
-                               false))))
-            (test "Can schedule I/O operations for future execution."
-                  (|> (run (` ("lux process schedule"
-                               (~ (code.nat delay))
-                               ("lux function" +1 []
-                                ("lux io log" (~ (code.text (format "SCHEDULE: " message))))))))
-                      (case> (#e.Success valueV)
-                             true
-
-                             (#e.Error error)
-                             (exec (log! error)
-                               false))))
-            ))))
+        (test "Can schedule I/O operations for future execution."
+              (|> (run (` ("lux process schedule"
+                           (~ (code.nat delay))
+                           ("lux function" +1 []
+                            ("lux io log" (~ (code.text (format "SCHEDULE: " message))))))))
+                  (case> (#e.Success valueV)
+                         true
+
+                         (#e.Error error)
+                         (exec (log! error)
+                           false)))))
+      ))
 
 (def: (all-specs run)
   (-> Runner Test)
   ($_ seq
       (bit-spec run)
-      (nat-spec run)
       (int-spec run)
-      (deg-spec run)
       (frac-spec run)
       (text-spec run)
       (array-spec run)
@@ -761,6 +604,10 @@
 ##   (<| (times +100)
 ##       (all-specs run-r)))
 
-(context: "[Scheme] Common procedures."
+## (context: "[Scheme] Common procedures."
+##   (<| (times +100)
+##       (all-specs run-scheme)))
+
+(context: "[Common Lisp] Common procedures."
   (<| (times +100)
-      (all-specs run-scheme)))
+      (all-specs run-common-lisp)))
diff --git a/new-luxc/test/test/luxc/lang/translation/function.lux b/new-luxc/test/test/luxc/lang/translation/function.lux
index 0a3d8ca62..e8f99e09e 100644
--- a/new-luxc/test/test/luxc/lang/translation/function.lux
+++ b/new-luxc/test/test/luxc/lang/translation/function.lux
@@ -111,6 +111,10 @@
 ##   (<| (times +100)
 ##       (function-spec run-r)))
 
-(context: "[Scheme] Function."
+## (context: "[Scheme] Function."
+##   (<| (times +100)
+##       (function-spec run-scheme)))
+
+(context: "[Common Lisp] Function."
   (<| (times +100)
-      (function-spec run-scheme)))
+      (function-spec run-common-lisp)))
diff --git a/new-luxc/test/test/luxc/lang/translation/primitive.lux b/new-luxc/test/test/luxc/lang/translation/primitive.lux
index d36a02eb7..d832a6ccf 100644
--- a/new-luxc/test/test/luxc/lang/translation/primitive.lux
+++ b/new-luxc/test/test/luxc/lang/translation/primitive.lux
@@ -16,9 +16,9 @@
               [synthesis #+ Synthesis]))
   (test/luxc common))
 
-(def: ascii
+(def: upper-alpha-ascii
   (r.Random Nat)
-  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +256) (n/max +1)))))
+  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +91) (n/max +65)))))
 
 (def: (spec run)
   (-> (-> Synthesis (e.Error Top)) Test)
@@ -28,7 +28,7 @@
      %int% r.int
      %deg% r.deg
      %frac% r.frac
-     %text% (r.text' ascii +5)]
+     %text% (r.text' upper-alpha-ascii +5)]
     (`` ($_ seq
             (test "Can translate unit."
                   (|> (run (' []))
@@ -80,6 +80,10 @@
 ##   (<| (times +100)
 ##       (spec run-r)))
 
-(context: "[Scheme] Primitives."
+## (context: "[Scheme] Primitives."
+##   (<| (times +100)
+##       (spec run-scheme)))
+
+(context: "[Common Lisp] Primitives."
   (<| (times +100)
-      (spec run-scheme)))
+      (spec run-common-lisp)))
diff --git a/new-luxc/test/test/luxc/lang/translation/reference.lux b/new-luxc/test/test/luxc/lang/translation/reference.lux
index 7cef493e6..8579663b4 100644
--- a/new-luxc/test/test/luxc/lang/translation/reference.lux
+++ b/new-luxc/test/test/luxc/lang/translation/reference.lux
@@ -18,7 +18,8 @@
                            ## (ruby [".T_ruby" statement])
                            ## (python [".T_python" statement])
                            ## (r [".T_r" statement])
-                           (scheme [".T_scheme" statement]))))
+                           ## (scheme [".T_scheme" statement])
+                           (common-lisp [".T_common-lisp" statement]))))
   (test/luxc common))
 
 (def: upper-alpha-ascii
@@ -92,6 +93,10 @@
 ##   (<| (times +100)
 ##       (references-spec run-r def-r)))
 
-(context: "[Scheme] References."
+## (context: "[Scheme] References."
+##   (<| (times +100)
+##       (references-spec run-scheme def-scheme)))
+
+(context: "[Common Lisp] References."
   (<| (times +100)
-      (references-spec run-scheme def-scheme)))
+      (references-spec run-common-lisp def-common-lisp)))
diff --git a/new-luxc/test/test/luxc/lang/translation/structure.lux b/new-luxc/test/test/luxc/lang/translation/structure.lux
index 5f2439394..a28a877dd 100644
--- a/new-luxc/test/test/luxc/lang/translation/structure.lux
+++ b/new-luxc/test/test/luxc/lang/translation/structure.lux
@@ -9,7 +9,7 @@
              [text "text/" Eq<Text>]
              text/format
              (coll [array]
-                   [list]))
+                   [list "list/" Functor<List>]))
        ["r" math/random "r/" Monad<Random>]
        [macro]
        (macro [code])
@@ -22,56 +22,19 @@
 
 (host.import java/lang/Integer)
 
-(def: upper-alpha
-  (r.Random Nat)
-  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +91) (n/max +65)))))
-
-(def: gen-primitive
-  (r.Random Synthesis)
-  (r.either (r.either (r.either (r/wrap (' []))
-                                (r/map code.bool r.bool))
-                      (r.either (r/map code.nat r.nat)
-                                (r/map code.int r.int)))
-            (r.either (r.either (r/map code.deg r.deg)
-                                (r/map code.frac r.frac))
-                      (r/map code.text (r.text' upper-alpha +5)))))
-
-(def: (corresponds? [prediction sample])
-  (-> [Synthesis Top] Bool)
-  (case prediction
-    [_ (#.Tuple #.Nil)]
-    (text/= hostL.unit (:! Text sample))
-
-    (^template [<tag> <type> <test>]
-      [_ (<tag> prediction')]
-      (case (host.try (<test> prediction' (:! <type> sample)))
-        (#e.Success result)
-        result
-
-        (#e.Error error)
-        false))
-    ([#.Bool Bool bool/=]
-     [#.Nat  Nat n/=]
-     [#.Int  Int i/=]
-     [#.Deg  Deg d/=]
-     [#.Frac Frac f/=]
-     [#.Text Text text/=])
-
-    _
-    false
-    ))
-
 (def: (tuples-spec run)
   (-> (-> Synthesis (e.Error Top)) Test)
   (do r.Monad<Random>
     [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
-     members (r.list size gen-primitive)]
+     tuple-in (r.list size r.int)]
     (test "Can translate tuple."
-          (|> (run (code.tuple members))
-              (case> (#e.Success valueT)
-                     (let [valueT (:! (Array Top) valueT)]
-                       (and (n/= size (array.size valueT))
-                            (list.every? corresponds? (list.zip2 members (array.to-list valueT)))))
+          (|> (run (code.tuple (list/map code.int tuple-in)))
+              (case> (#e.Success tuple-out)
+                     (let [tuple-out (:! (Array Top) tuple-out)]
+                       (and (n/= size (array.size tuple-out))
+                            (list.every? (function (_ [left right])
+                                           (i/= left (:! Int right)))
+                                         (list.zip2 tuple-in (array.to-list tuple-out)))))
 
                      (#e.Error error)
                      (exec (log! error)
@@ -81,25 +44,25 @@
   (-> (-> Synthesis (e.Error Top)) Test)
   (do r.Monad<Random>
     [num-tags (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
-     tag (|> r.nat (:: @ map (n/% num-tags)))
-     #let [last? (n/= (n/dec num-tags) tag)]
-     member gen-primitive]
+     tag-in (|> r.nat (:: @ map (n/% num-tags)))
+     #let [last?-in (n/= (n/dec num-tags) tag-in)]
+     value-in r.int]
     (test "Can translate variant."
-          (|> (run (` ((~ (code.nat tag)) (~ (code.bool last?)) (~ member))))
+          (|> (run (` ((~ (code.nat tag-in)) (~ (code.bool last?-in)) (~ (code.int value-in)))))
               (case> (#e.Success valueT)
                      (let [valueT (:! (Array Top) valueT)]
                        (and (n/= +3 (array.size valueT))
-                            (let [_tag (:! Integer (maybe.assume (array.read +0 valueT)))
-                                  _last? (array.read +1 valueT)
-                                  _value (:! Top (maybe.assume (array.read +2 valueT)))
-                                  same-tag? (n/= tag (|> _tag host.int-to-long (:! Nat)))
-                                  same-flag? (case _last?
-                                               (#.Some _last?')
-                                               (and last? (text/= "" (:! Text _last?')))
+                            (let [tag-out (:! Integer (maybe.assume (array.read +0 valueT)))
+                                  last?-out (array.read +1 valueT)
+                                  value-out (:! Top (maybe.assume (array.read +2 valueT)))
+                                  same-tag? (n/= tag-in (|> tag-out host.int-to-long (:! Nat)))
+                                  same-flag? (case last?-out
+                                               (#.Some last?-out')
+                                               (and last?-in (text/= "" (:! Text last?-out')))
 
                                                #.None
-                                               (not last?))
-                                  same-value? (corresponds? [member _value])]
+                                               (not last?-in))
+                                  same-value? (i/= value-in (:! Int value-out))]
                               (and same-tag?
                                    same-flag?
                                    same-value?))))
@@ -138,6 +101,10 @@
 ##   (<| (times +100)
 ##       (structure-spec run-r)))
 
-(context: "[Scheme] Structures."
+## (context: "[Scheme] Structures."
+##   (<| (times +100)
+##       (structure-spec run-scheme)))
+
+(context: "[Common Lisp] Structures."
   (<| (times +100)
-      (structure-spec run-scheme)))
+      (structure-spec run-common-lisp)))