More adjustments for Common Lisp.

5 files changed, 180 insertions, 171 deletions

diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
index 2a64aeb1e..b47bade2d 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
@@ -53,7 +53,7 @@
 (template: (!unary function)
   (|>> list _.apply/* (|> (_.constant function))))
 
-## TODO: Get rid of this ASAP
+## ## TODO: Get rid of this ASAP
 ## (def: lux::syntax_char_case!
 ##   (..custom [($_ <>.and
 ##                  <s>.any
@@ -74,18 +74,18 @@
 ##                                                            branchG])))
 ##                                               conditionals))]
 ##                  (wrap (_.let (list [@input inputG])
-##                          (list\fold (function (_ [test then] else)
-##                                       (_.if test then else))
-##                                     elseG
-##                                     conditionalsG)))))]))
+##                          (list (list\fold (function (_ [test then] else)
+##                                             (_.if test then else))
+##                                           elseG
+##                                           conditionalsG))))))]))
 
-## (def: lux_procs
-##   Bundle
-##   (|> /.empty
-##       (/.install "syntax char case!" lux::syntax_char_case!)
-##       (/.install "is" (binary (product.uncurry _.eq?/2)))
-##       (/.install "try" (unary //runtime.lux//try))
-##       ))
+(def: lux_procs
+  Bundle
+  (|> /.empty
+      ## (/.install "syntax char case!" lux::syntax_char_case!)
+      (/.install "is" (binary _.eq/2))
+      ## (/.install "try" (unary //runtime.lux//try))
+      ))
 
 ## (def: (capped operation parameter subject)
 ##   (-> (-> Expression Expression Expression)
@@ -128,13 +128,17 @@
           ## (/.install "decode" (unary //runtime.f64//decode))
           )))
 
-## (def: (text//index [offset sub text])
-##   (Trinary Expression)
-##   (//runtime.text//index offset sub text))
+(def: (text//index [offset sub text])
+  (Trinary (Expression Any))
+  (//runtime.text//index offset sub text))
+
+(def: (text//clip [offset length text])
+  (Trinary (Expression Any))
+  (//runtime.text//clip offset length text))
 
-## (def: (text//clip [paramO extraO subjectO])
-##   (Trinary Expression)
-##   (//runtime.text//clip paramO extraO subjectO))
+(def: (text//char [index text])
+  (Binary (Expression Any))
+  (_.char-code/1 (_.char/2 [text index])))
 
 (def: text_procs
   Bundle
@@ -144,16 +148,17 @@
           ## (/.install "<" (binary (product.uncurry _.string<?/2)))
           (/.install "concat" (binary (function (_ [left right])
                                         (_.concatenate/3 [(_.symbol "string") left right]))))
-          ## (/.install "index" (trinary ..text//index))
-          ## (/.install "size" (unary _.string-length/1))
-          ## (/.install "char" (binary (product.uncurry //runtime.text//char)))
-          ## (/.install "clip" (trinary ..text//clip))
+          (/.install "index" (trinary ..text//index))
+          (/.install "size" (unary _.length/1))
+          (/.install "char" (binary ..text//char))
+          (/.install "clip" (trinary ..text//clip))
           )))
 
 (def: (io//log! message)
   (Unary (Expression Any))
-  (_.progn (_.write-line/1 message)
-           //runtime.unit))
+  (_.progn (list (_.pprint/1 message)
+                 ## (_.write-line/1 message)
+                 //runtime.unit)))
 
 (def: io_procs
   Bundle
@@ -168,7 +173,7 @@
   Bundle
   (<| (/.prefix "lux")
       (|> /.empty
-          ## (dictionary.merge lux_procs)
+          (dictionary.merge lux_procs)
           (dictionary.merge i64_procs)
           (dictionary.merge f64_procs)
           (dictionary.merge text_procs)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
index 1c669ae52..08250d5d9 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
@@ -7,7 +7,7 @@
    [data
     ["." text]
     [collection
-     ["." list ("#\." functor fold)]
+     ["." list ("#\." functor fold monoid)]
      ["." set]]]
    [math
     [number
@@ -47,7 +47,7 @@
     [valueG (expression archive valueS)
      bodyG (expression archive bodyS)]
     (wrap (_.let (list [(..register register) valueG])
-            bodyG))))
+            (list bodyG)))))
 
 (def: #export (if expression archive [testS thenS elseS])
   (Generator [Synthesis Synthesis Synthesis])
@@ -94,10 +94,9 @@
   (_.setq @savepoint (_.cons/2 [@cursor @savepoint])))
 
 (def: restore!
-  (Expression Any)
-  ($_ _.progn
-      (_.setq @cursor (_.car/1 @savepoint))
-      (_.setq @savepoint (_.cdr/1 @savepoint))))
+  (List (Expression Any))
+  (list (_.setq @cursor (_.car/1 @savepoint))
+        (_.setq @savepoint (_.cdr/1 @savepoint))))
 
 (def: @fail (_.label "lux_pm_fail"))
 (def: @done (_.label "lux_pm_done"))
@@ -109,19 +108,23 @@
   (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor])))
 
 (template [<name> <flag> <prep>]
-  [(def: (<name> simple? idx)
-     (-> Bit Nat (Expression Any))
+  [(def: (<name> simple? idx next!)
+     (-> Bit Nat (Maybe (Expression Any)) (Expression Any))
      (.let [<failure_condition> (_.eq/2 [@variant @temp])]
        (_.let (list [@variant ..peek])
-         ($_ _.progn
-             (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
-             (.if simple?
-               (_.when <failure_condition>
-                       fail!)
-               (_.if <failure_condition>
-                 fail!
-                 (..push! @temp))
-               )))))]
+         (list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
+                (.if simple?
+                  (_.when <failure_condition>
+                          fail!)
+                  (_.if <failure_condition>
+                    fail!
+                    (..push! @temp)))
+                (.case next!
+                  (#.Some next!)
+                  (list next!)
+                  
+                  #.None
+                  (list))))))]
 
   [left_choice  _.nil         (<|)]
   [right_choice (_.string "") inc]
@@ -129,12 +132,12 @@
 
 (def: (alternation pre! post!)
   (-> (Expression Any) (Expression Any) (Expression Any))
-  (_.progn (<| (_.block ..@fail)
-               (_.progn ..save!)
-               pre!)
-           ($_ _.progn
+  (_.progn ($_ list\compose
+               (list (_.block ..@fail
+                              (list ..save!
+                                    pre!)))
                ..restore!
-               post!)))
+               (list post!))))
 
 (def: (pattern_matching' expression archive)
   (Generator Path)
@@ -186,12 +189,12 @@
 
       (^template [<complex> <simple> <choice>]
         [(^ (<complex> idx))
-         (///////phase\wrap (<choice> false idx))
+         (///////phase\wrap (<choice> false idx #.None))
 
          (^ (<simple> idx nextP))
          (|> nextP
              recur
-             (\ ///////phase.monad map (_.progn (<choice> true idx))))])
+             (\ ///////phase.monad map (|>> #.Some (<choice> true idx))))])
       ([/////synthesis.side/left  /////synthesis.simple_left_side  ..left_choice]
        [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
 
@@ -208,27 +211,29 @@
       (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
         (do ///////phase.monad
           [next! (recur nextP')]
-          (///////phase\wrap ($_ _.progn
-                                 (..multi_pop! (n.+ 2 extra_pops))
-                                 next!))))
-
-      (^template [<tag> <combinator>]
-        [(^ (<tag> preP postP))
-         (do ///////phase.monad
-           [pre! (recur preP)
-            post! (recur postP)]
-           (wrap (<combinator> pre! post!)))])
-      ([/////synthesis.path/alt ..alternation]
-       [/////synthesis.path/seq _.progn]))))
+          (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops))
+                                            next!)))))
+
+      (^ (/////synthesis.path/alt preP postP))
+      (do ///////phase.monad
+        [pre! (recur preP)
+         post! (recur postP)]
+        (wrap (..alternation pre! post!)))
+
+      (^ (/////synthesis.path/seq preP postP))
+      (do ///////phase.monad
+        [pre! (recur preP)
+         post! (recur postP)]
+        (wrap (_.progn (list pre! post!)))))))
 
 (def: (pattern_matching expression archive pathP)
   (Generator Path)
   (do ///////phase.monad
     [pattern_matching! (pattern_matching' expression archive pathP)]
     (wrap (_.block ..@done
-                   (_.progn (_.block ..@fail
-                                     pattern_matching!)
-                            (_.error/1 (_.string ////synthesis/case.pattern_matching_error)))))))
+                   (list (_.block ..@fail
+                                  (list pattern_matching!))
+                         (_.error/1 (_.string ////synthesis/case.pattern_matching_error)))))))
 
 (def: #export (case expression archive [valueS pathP])
   (Generator [Synthesis Path])
@@ -246,4 +251,4 @@
                         [@savepoint (_.list/* (list))]
                         [@temp _.nil]
                         storage)
-            pattern_matching!))))
+            (list pattern_matching!)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
index 23f60e9d0..2a5896e92 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
@@ -6,6 +6,8 @@
     pipe]
    [data
     ["." product]
+    [text
+     ["%" format (#+ format)]]
     [collection
      ["." list ("#\." functor fold)]]]
    [target
@@ -58,12 +60,11 @@
 (def: #export (function expression archive [environment arity bodyS])
   (Generator (Abstraction Synthesis))
   (do {! ///////phase.monad}
-    [[function_name bodyG] (/////generation.with_new_context archive
-                             (do !
-                               [@self (\ ! map (|>> ///reference.artifact _.var)
-                                         (/////generation.context archive))]
-                               (/////generation.with_anchor @self
-                                 (expression archive bodyS))))
+    [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next)
+     @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
+     [function_name bodyG] (/////generation.with_new_context archive
+                             (/////generation.with_anchor [@scope 1]
+                               (expression archive bodyS)))
      closureG+ (monad.map ! (expression archive) environment)
      #let [@curried (_.var "curried")
            @missing (_.var "missing")
@@ -78,20 +79,24 @@
     (with_closure closureG+
       (_.labels (list [@self [(_.args& (list) @curried)
                               (_.let (list [@num_args (_.length/1 @curried)])
-                                (_.cond (list [(_.=/2 [arityG @num_args])
-                                               (_.let (list initialize_self!)
-                                                 (_.destructuring-bind initialize!
-                                                                       bodyG))]
+                                (list (_.cond (list [(_.=/2 [arityG @num_args])
+                                                     (_.let (list [@output _.nil]
+                                                                  initialize_self!)
+                                                       (list (_.destructuring-bind initialize!
+                                                                                   (list (_.tagbody
+                                                                                          (list @scope
+                                                                                                (_.setq @output bodyG)))
+                                                                                         @output))))]
 
-                                              [(_.>/2 [arityG @num_args])
-                                               (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG])
-                                                     extra_inputs (_.subseq/3 [@curried arityG @num_args])]
-                                                 (_.apply/2 [(_.apply/2 [(_.function/1 @self)
-                                                                         arity_inputs])
-                                                             extra_inputs]))])
-                                        ## (|> @num_args (_.< arityG))
-                                        (_.lambda (_.args& (list) @missing)
-                                                  (_.apply/2 [(_.function/1 @self)
-                                                              (_.append/2 [@curried @missing])]))))]])
+                                                    [(_.>/2 [arityG @num_args])
+                                                     (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG])
+                                                           extra_inputs (_.subseq/3 [@curried arityG @num_args])]
+                                                       (_.apply/2 [(_.apply/2 [(_.function/1 @self)
+                                                                               arity_inputs])
+                                                                   extra_inputs]))])
+                                              ## (|> @num_args (_.< arityG))
+                                              (_.lambda (_.args& (list) @missing)
+                                                        (_.apply/2 [(_.function/1 @self)
+                                                                    (_.append/2 [@curried @missing])])))))]])
                 (_.function/1 @self)))
     ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
index 14aa89668..7256e926d 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
@@ -41,20 +41,29 @@
     ## true loop
     _
     (do {! ///////phase.monad}
-      [@scope (\ ! map (|>> %.nat (format "scope") _.var) /////generation.next)
+      [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next)
+       @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
        initsG+ (monad.map ! (expression archive) initsS+)
-       bodyG (/////generation.with_anchor @scope
+       bodyG (/////generation.with_anchor [@scope start]
                (expression archive bodyS))]
-      (wrap (_.labels (list [@scope {#_.input (|> initsS+
-                                                  list.enumeration
-                                                  (list\map (|>> product.left (n.+ start) //case.register))
-                                                  _.args)
-                                     #_.output bodyG}])
-                      (_.funcall/+ [(_.function/1 @scope) initsG+]))))))
+      (wrap (_.let (|> initsG+
+                       list.enumeration
+                       (list\map (function (_ [idx init])
+                                   [(|> idx (n.+ start) //case.register)
+                                    init]))
+                       (list& [@output _.nil]))
+              (list (_.tagbody (list @scope
+                                     (_.setq @output bodyG)))
+                    @output))))))
 
 (def: #export (recur expression archive argsS+)
   (Generator (List Synthesis))
   (do {! ///////phase.monad}
-    [@scope /////generation.anchor
-     argsO+ (monad.map ! (expression archive) argsS+)]
-    (wrap (_.call/* @scope argsO+))))
+    [[tag offset] /////generation.anchor
+     argsO+ (monad.map ! (expression archive) argsS+)
+     #let [bindings (|> argsO+
+                        list.enumeration
+                        (list\map (|>> product.left (n.+ offset) //case.register))
+                        _.args)]]
+    (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+))
+                         (_.go tag))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
index b8c9149d3..73f885ebd 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
@@ -22,7 +22,7 @@
     [number (#+ hex)
      ["." i64]]]
    ["@" target
-    ["_" common_lisp (#+ Expression Var/1 Computation Literal)]]]
+    ["_" common_lisp (#+ Expression Computation Literal)]]]
   ["." /// #_
    ["#." reference]
    ["//#" /// #_
@@ -42,7 +42,7 @@
 
 (template [<name> <base>]
   [(type: #export <name>
-     (<base> Var/1 (Expression Any) (Expression Any)))]
+     (<base> [_.Tag Register] (Expression Any) (Expression Any)))]
 
   [Operation /////generation.Operation]
   [Phase /////generation.Phase]
@@ -157,10 +157,8 @@
                                   ..none)]))))
 
 (def: runtime//lux
-  ($_ _.progn
-      @lux//try
-      @lux//program_args
-      ))
+  (_.progn (list @lux//try
+                 @lux//program_args)))
 
 (def: last_index
   (|>> _.length/1 [(_.int +1)] _.-/2))
@@ -175,23 +173,22 @@
   (runtime: (tuple//left lefts tuple)
     (with_vars [last_index_right]
       (_.let (list [last_index_right (..last_index tuple)])
-        (_.if (_.>/2 [lefts last_index_right])
-          ## No need for recursion
-          (_.elt/2 [tuple lefts])
-          ## Needs recursion
-          (!recur tuple//left)))))
+        (list (_.if (_.>/2 [lefts last_index_right])
+                ## No need for recursion
+                (_.elt/2 [tuple lefts])
+                ## Needs recursion
+                (!recur tuple//left))))))
 
   (runtime: (tuple//right lefts tuple)
     (with_vars [last_index_right right_index]
       (_.let (list [last_index_right (..last_index tuple)]
                    [right_index (_.+/2 [(_.int +1) lefts])])
-        (_.cond (list [(_.=/2 [last_index_right right_index])
-                       (_.elt/2 [tuple right_index])]
-                      [(_.>/2 [last_index_right right_index])
-                       ## Needs recursion.
-                       (!recur tuple//right)])
-                (_.subseq/3 [tuple right_index (_.length/1 tuple)]))
-        ))))
+        (list (_.cond (list [(_.=/2 [last_index_right right_index])
+                             (_.elt/2 [tuple right_index])]
+                            [(_.>/2 [last_index_right right_index])
+                             ## Needs recursion.
+                             (!recur tuple//right)])
+                      (_.subseq/3 [tuple right_index (_.length/1 tuple)])))))))
 
 ## TODO: Find a way to extract parts of the sum without "nth", which
 ## does a linear search, and is thus expensive.
@@ -203,34 +200,31 @@
           sum_value (_.nth/2 [(_.int +2) sum])
           test_recursion! (_.if sum_flag
                             ## Must iterate.
-                            ($_ _.progn
-                                (_.setq wantedTag (_.-/2 [sum_tag wantedTag]))
-                                (_.setq sum sum_value))
+                            (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag]))
+                                           (_.setq sum sum_value)))
                             no_match!)]
-      (<| (_.progn (_.setq sum_tag (_.nth/2 [(_.int +0) sum])))
-          (_.progn (_.setq sum_flag (_.nth/2 [(_.int +1) sum])))
-          (_.block @exit)
-          (_.while (_.bool true))
-          (_.cond (list [(_.=/2 [sum_tag wantedTag])
-                         (_.if (_.equal/2 [wantsLast sum_flag])
-                           (return! sum_value)
-                           test_recursion!)]
+      (_.progn (list (_.setq sum_tag (_.nth/2 [(_.int +0) sum]))
+                     (_.setq sum_flag (_.nth/2 [(_.int +1) sum]))
+                     (_.block @exit
+                              (list (_.while (_.bool true)
+                                             (_.cond (list [(_.=/2 [sum_tag wantedTag])
+                                                            (_.if (_.equal/2 [wantsLast sum_flag])
+                                                              (return! sum_value)
+                                                              test_recursion!)]
 
-                        [(_.>/2 [sum_tag wantedTag])
-                         test_recursion!]
+                                                           [(_.>/2 [sum_tag wantedTag])
+                                                            test_recursion!]
 
-                        [(_.and (_.</2 [sum_tag wantedTag])
-                                wantsLast)
-                         (return! (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))])
+                                                           [(_.and (_.</2 [sum_tag wantedTag])
+                                                                   wantsLast)
+                                                            (return! (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))])
 
-                  no_match!)))))
+                                                     no_match!)))))))))
 
 (def: runtime//adt
-  ($_ _.progn
-      @tuple//left
-      @tuple//right
-      @sum//get
-      ))
+  (_.progn (list @tuple//left
+                 @tuple//right
+                 @sum//get)))
 
 (runtime: (i64//right_shift shift input)
   (_.if (_.=/2 [(_.int +0) shift])
@@ -244,56 +238,47 @@
           [mask] _.logand/2))))
 
 (def: runtime//i64
-  ($_ _.progn
-      @i64//right_shift
-      ))
+  @i64//right_shift)
 
-(runtime: (text//clip from to text)
-  (_.subseq/3 [text from to]))
+(runtime: (text//clip offset length text)
+  (_.subseq/3 [text offset (_.+/2 [offset length])]))
 
-(runtime: (text//index reference start space)
+(runtime: (text//index offset sub text)
   (with_vars [index]
-    (_.let (list [index (_.search/3 [reference space start])])
-      (_.if index
-        (..some index)
-        ..none))))
+    (_.let (list [index (_.search/3 [sub text offset])])
+      (list (_.if index
+              (..some index)
+              ..none)))))
 
 (def: runtime//text
-  ($_ _.progn
-      @text//index
-      @text//clip
-      ))
+  (_.progn (list @text//index
+                 @text//clip)))
 
 (runtime: (io//exit code)
-  ($_ _.progn
-      (_.conditional+ (list "sbcl")
-                      (_.call/* (_.var "sb-ext:quit") (list code)))
-      (_.conditional+ (list "clisp")
-                      (_.call/* (_.var "ext:exit") (list code)))
-      (_.conditional+ (list "ccl")
-                      (_.call/* (_.var "ccl:quit") (list code)))
-      (_.conditional+ (list "allegro")
-                      (_.call/* (_.var "excl:exit") (list code)))
-      (_.call/* (_.var "cl-user::quit") (list code))))
+  (_.progn (list (_.conditional+ (list "sbcl")
+                                 (_.call/* (_.var "sb-ext:quit") (list code)))
+                 (_.conditional+ (list "clisp")
+                                 (_.call/* (_.var "ext:exit") (list code)))
+                 (_.conditional+ (list "ccl")
+                                 (_.call/* (_.var "ccl:quit") (list code)))
+                 (_.conditional+ (list "allegro")
+                                 (_.call/* (_.var "excl:exit") (list code)))
+                 (_.call/* (_.var "cl-user::quit") (list code)))))
 
 (runtime: (io//current_time _)
   (_.*/2 [(_.int +1,000)
           (_.get-universal-time/0 [])]))
 
 (def: runtime//io
-  ($_ _.progn
-      @io//exit
-      @io//current_time
-      ))
+  (_.progn (list @io//exit
+                 @io//current_time)))
 
 (def: runtime
-  ($_ _.progn
-      runtime//adt
-      runtime//lux
-      runtime//i64
-      runtime//text
-      runtime//io
-      ))
+  (_.progn (list runtime//adt
+                 runtime//lux
+                 runtime//i64
+                 runtime//text
+                 runtime//io)))
 
 (def: #export generate
   (Operation [Registry Output])