The Common Lisp compiler is alive.

13 files changed, 1365 insertions, 30 deletions

diff --git a/stdlib/source/lux/target/common-lisp.lux b/stdlib/source/lux/target/common-lisp.lux
new file mode 100644
index 000000000..eb7e78d01
--- /dev/null
+++ b/stdlib/source/lux/target/common-lisp.lux
@@ -0,0 +1,429 @@
+(.module:
+  [lux (#- Code int if cond or and comment let)
+   [control
+    [pipe (#+ case> cond> new>)]]
+   [data
+    [number
+     ["." frac]]
+    ["." text
+     format]
+    [collection
+     ["." list ("#@." monad fold)]]]
+   [macro
+    ["." template]]
+   [type
+    abstract]])
+
+(def: as-form
+  (-> Text Text)
+  (text.enclose ["(" ")"]))
+
+(abstract: #export (Code brand)
+  {}
+  
+  Text
+
+  (def: #export manual
+    (-> Text Code)
+    (|>> :abstraction))
+
+  (def: #export code
+    (-> (Code Any) Text)
+    (|>> :representation))
+
+  (template [<type> <super>]
+    [(with-expansions [<brand> (template.identifier [<type> "'"])]
+       (`` (abstract: #export (<brand> brand) {} Any))
+       (`` (type: #export (<type> brand)
+             (<super> (<brand> brand)))))]
+    
+    [Expression Code]
+    [Computation Expression]
+    [Access Computation]
+    [Var Access]
+
+    [Input Code]
+    )
+
+  (template [<type> <super>]
+    [(with-expansions [<brand> (template.identifier [<type> "'"])]
+       (`` (abstract: #export <brand> {} Any))
+       (`` (type: #export <type> (<super> <brand>))))]
+
+    [Tag Code]
+    [Literal Expression]
+    [Var/1 Var]
+    [Var/* Input]
+    )
+
+  (type: #export Lambda
+    {#input Var/*
+     #output (Expression Any)})
+
+  (def: #export nil
+    Literal
+    (:abstraction "()"))
+
+  (def: #export bool
+    (-> Bit Literal)
+    (|>> (case> #0 ..nil
+                #1 (:abstraction "t"))))
+
+  (def: #export int
+    (-> Int Literal)
+    (|>> %i :abstraction))
+
+  (def: #export float
+    (-> Frac Literal)
+    (|>> (cond> [(f/= frac.positive-infinity)]
+                [(new> "(/ 1.0 0.0)" [])]
+                
+                [(f/= frac.negative-infinity)]
+                [(new> "(/ -1.0 0.0)" [])]
+                
+                [frac.not-a-number?]
+                [(new> "(/ 0.0 0.0)" [])]
+                
+                ## else
+                [%f])
+         :abstraction))
+
+  (def: #export (double value)
+    (-> Frac Literal)
+    (:abstraction
+     (.cond (f/= frac.positive-infinity value)
+            "(/ 1.0d0 0.0d0)"
+            
+            (f/= frac.negative-infinity value)
+            "(/ -1.0d0 0.0d0)"
+            
+            (frac.not-a-number? value)
+            "(/ 0.0d0 0.0d0)"
+            
+            ## else
+            (.let [raw (%f value)]
+              (.if (text.contains? "E" raw)
+                (text.replace-once "E" "d" raw)
+                (format raw "d0"))))))
+
+  (def: sanitize
+    (-> Text Text)
+    (`` (|>> (~~ (template [<find> <replace>]
+                   [(text.replace-all <find> <replace>)]
+
+                   ["\" "\\"]
+                   [text.tab "\t"]
+                   [text.vertical-tab "\v"]
+                   [text.null "\0"]
+                   [text.back-space "\b"]
+                   [text.form-feed "\f"]
+                   [text.new-line "\n"]
+                   [text.carriage-return "\r"]
+                   [text.double-quote (format "\" text.double-quote)]
+                   ))
+             )))
+
+  (def: #export string
+    (-> Text Literal)
+    (|>> ..sanitize
+         (text.enclose' text.double-quote)
+         :abstraction))
+
+  (template [<name> <prefix>]
+    [(def: #export <name>
+       (-> Text Literal)
+       (|>> (format <prefix>) :abstraction))]
+
+    [symbol "'"]
+    [keyword ":"])
+
+  (def: #export var
+    (-> Text Var/1)
+    (|>> :abstraction))
+
+  (def: #export args
+    (-> (List Var/1) Var/*)
+    (|>> (list@map ..code)
+         (text.join-with " ")
+         ..as-form
+         :abstraction))
+
+  (def: #export (args& singles rest)
+    (-> (List Var/1) Var/1 Var/*)
+    (|> (format (|> singles
+                    (list@map ..code)
+                    (text.join-with " "))
+                " &rest " (:representation rest))
+        ..as-form
+        :abstraction))
+
+  (def: form
+    (-> (List (Expression Any)) Expression)
+    (|>> (list@map ..code)
+         (text.join-with " ")
+         ..as-form
+         :abstraction))
+
+  (def: #export (call/* func)
+    (-> (Expression Any) (-> (List (Expression Any)) (Computation Any)))
+    (|>> (#.Cons func) ..form))
+  
+  (template [<name> <function>]
+    [(def: #export <name>
+       (-> (List (Expression Any)) (Computation Any))
+       (..call/* (..var <function>)))]
+
+    [vector/* "vector"]
+    [list/*   "list"]
+    )
+
+  (def: #export (labels definitions body)
+    (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any))
+    (..form (list (..var "labels")
+                  (..form (list@map (function (_ [def-name [def-args def-body]])
+                                      (..form (list def-name (:transmutation def-args) def-body)))
+                                    definitions))
+                  body)))
+
+  (def: #export (destructuring-bind [bindings expression] body)
+    (-> [Var/* (Expression Any)] (Expression Any) (Computation Any))
+    (..form (list (..var "destructuring-bind")
+                  (:transmutation bindings) expression
+                  body)))
+
+  (template [<call> <input-var>+ <input-type>+ <function>+]
+    [(`` (def: #export (<call> [(~~ (template.splice <input-var>+))] function)
+           (-> [(~~ (template.splice <input-type>+))] (Expression Any) (Computation Any))
+           (..call/* function (list (~~ (template.splice <input-var>+))))))
+
+     (`` (template [<lux-name> <host-name>]
+           [(def: #export (<lux-name> args)
+              (-> [(~~ (template.splice <input-type>+))] (Computation Any))
+              (<call> args (..var <host-name>)))]
+           
+           (~~ (template.splice <function>+))))]
+
+    [call/0 [] []
+     [[get-universal-time/0 "get-universal-time"]
+      [make-hash-table/0 "make-hash-table"]]]
+    [call/1 [in0] [(Expression Any)]
+     [[length/1 "length"]
+      [function/1 "function"]
+      [copy-seq/1 "copy-seq"]
+      [null/1 "null"]
+      [error/1 "error"]
+      [not/1 "not"]
+      [floor/1 "floor"]
+      [type-of/1 "type-of"]
+      [write-to-string/1 "write-to-string"]
+      [read-from-string/1 "read-from-string"]
+      [print/1 "print"]
+      [reverse/1 "reverse"]
+      [sxhash/1 "sxhash"]
+      [string-upcase/1 "string-upcase"]
+      [string-downcase/1 "string-downcase"]
+      [char-int/1 "char-int"]
+      [text/1 "text"]
+      [hash-table-size/1 "hash-table-size"]
+      [hash-table-rehash-size/1 "hash-table-rehash-size"]
+      [code-char/1 "code-char"]
+      [string/1 "string"]]]
+    [call/2 [in0 in1] [(Expression Any) (Expression Any)]
+     [[apply/2 "apply"]
+      [append/2 "append"]
+      [cons/2 "cons"]
+      [char/2 "char"]
+      [nth/2 "nth"]
+      [nthcdr/2 "nthcdr"]
+      [coerce/2 "coerce"]]]
+    [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)]
+     [[subseq/3 "subseq"]
+      [map/3 "map"]
+      [concatenate/3 "concatenate"]
+      [format/3 "format"]]]
+    )
+
+  (template [<call> <input-type>+ <function>+]
+    [(`` (template [<lux-name> <host-name>]
+           [(def: #export (<lux-name> args)
+              (-> [(~~ (template.splice <input-type>+))] (Access Any))
+              (:transmutation (<call> args (..var <host-name>))))]
+           
+           (~~ (template.splice <function>+))))]
+
+    [call/1 [(Expression Any)]
+     [[car/1 "car"]
+      [cdr/1 "cdr"]
+      [cadr/1 "cadr"]
+      [cddr/1 "cddr"]]]
+    [call/2 [(Expression Any) (Expression Any)]
+     [[svref/2 "svref"]
+      [elt/2 "elt"]
+      [gethash/2 "gethash"]]]
+    )
+
+  (def: #export (make-hash-table/with-size size)
+    (-> (Expression Any) (Computation Any))
+    (..call/* (..var "make-hash-table")
+              (list (..keyword "size")
+                    size)))
+
+  (def: #export (funcall/+ [func args])
+    (-> [(Expression Any) (List (Expression Any))] (Computation Any))
+    (..call/* (..var "funcall") (list& func args)))
+
+  (def: #export (search/3 [reference space start])
+    (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any))
+    (..call/* (..var "search")
+              (list reference
+                    space
+                    (..keyword "start2") start)))
+
+  (def: #export (concatenate/2|string [left right])
+    (-> [(Expression Any) (Expression Any)] (Computation Any))
+    (concatenate/3 [(..symbol "string") left right]))
+
+  (template [<lux-name> <host-name>]
+    [(def: #export (<lux-name> left right)
+       (-> (Expression Any) (Expression Any) (Computation Any))
+       (..form (list (..var <host-name>) left right)))]
+
+    [or "or"]
+    [and "and"]
+    )
+
+  (template [<lux-name> <host-name>]
+    [(def: #export (<lux-name> param subject)
+       (-> (Expression Any) (Expression Any) (Computation Any))
+       (..form (list (..var <host-name>) subject param)))]
+
+    [=   "="]
+    [eq "eq"]
+    [equal "equal"]
+    [<   "<"]
+    [<=  "<="]
+    [>   ">"]
+    [>=  ">="]
+    [string= "string="]
+    [string< "string<"]
+    [+   "+"]
+    [-   "-"]
+    [/   "/"]
+    [*   "*"]
+    [rem "rem"]
+    [floor "floor"]
+    [mod "mod"]
+    [ash "ash"]
+    [logand "logand"]
+    [logior "logior"]
+    [logxor "logxor"]
+    )
+
+  (def: #export (if test then else)
+    (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
+    (..form (list (..var "if") test then else)))
+
+  (def: #export (when test then)
+    (-> (Expression Any) (Expression Any) (Computation Any))
+    (..form (list (..var "when") test then)))
+
+  (def: #export (lambda input body)
+    (-> Var/* (Expression Any) Literal)
+    (..form (list (..var "lambda") (:transmutation input) body)))
+
+  (template [<lux-name> <host-name>]
+    [(def: #export (<lux-name> bindings body)
+       (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any))
+       (..form (list (..var <host-name>)
+                     (|> bindings
+                         (list@map (function (_ [name value])
+                                     (..form (list name value))))
+                         ..form)
+                     body)))]
+
+    [let  "let"]
+    [let* "let*"]
+    )
+
+  (def: #export (defparameter name body)
+    (-> Var/1 (Expression Any) (Expression Any))
+    (..form (list (..var "defparameter") name body)))
+
+  (def: #export (defun name inputs body)
+    (-> Var/1 Var/* (Expression Any) (Expression Any))
+    (..form (list (..var "defun") name (:transmutation inputs) body)))
+
+  (def: #export (progn pre post)
+    (-> (Expression Any) (Expression Any) (Computation Any))
+    (..form (list (..var "progn") pre post)))
+
+  (def: #export (setq name value)
+    (-> Var/1 (Expression Any) (Expression Any))
+    (..form (list (..var "setq") name value)))
+
+  (def: #export (setf access value)
+    (-> (Access Any) (Expression Any) (Expression Any))
+    (..form (list (..var "setf") access value)))
+
+  (type: #export Handler
+    {#condition-type (Expression Any)
+     #condition Var/1
+     #body (Expression Any)})
+  
+  (def: #export (handler-case handlers body)
+    (-> (List Handler) (Expression Any) (Computation Any))
+    (..form (list& (..var "handler-case")
+                   body
+                   (list@map (function (_ [type condition handler])
+                               (..form (list type
+                                             (:transmutation (..args (list condition)))
+                                             handler)))
+                             handlers))))
+
+  (template [<name> <prefix>]
+    [(def: #export (<name> conditions expression)
+       (-> (List Text) (Expression Any) (Expression Any))
+       (case conditions
+         #.Nil
+         expression
+         
+         (#.Cons single #.Nil)
+         (:abstraction
+          (format <prefix> single " " (:representation expression)))
+         
+         _
+         (:abstraction
+          (format <prefix> (|> conditions (list@map ..symbol)
+                               (list& (..symbol "or")) ..form
+                               :representation)
+                  " " (:representation expression)))))]
+
+    [conditional+ "#+"]
+    [conditional- "#-"])
+
+  (def: #export tag
+    (-> Text Tag)
+    (|>> :abstraction))
+
+  (def: #export (go tag)
+    (-> Tag (Expression Any))
+    (..form (list (..var "go") (:transmutation tag))))
+
+  (def: #export (tagbody main tagged)
+    (-> (Expression Any)
+        (List [Tag (Expression Any)])
+        (Computation Any))
+    (|> tagged
+        (list@map (function (_ [tag then])
+                    (list (:transmutation tag) then)))
+        list@join
+        (list& (..var "tagbody") main)
+        ..form))
+
+  (def: #export (cond clauses else)
+    (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any))
+    (list@fold (function (_ [test then] next)
+                 (..if test then next))
+               (:transmutation else)
+               (list.reverse clauses)))
+  )
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux
new file mode 100644
index 000000000..480c473bf
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux
@@ -0,0 +1,60 @@
+(.module:
+  [lux #*
+   [abstract
+    [monad (#+ do)]]]
+  [/
+   [runtime (#+ Phase)]
+   ["." primitive]
+   ["." structure]
+   ["." reference ("#@." system)]
+   ["." case]
+   ["." loop]
+   ["." function]
+   ["." ///
+    ["." extension]
+    [//
+     ["." synthesis]]]])
+
+(def: #export (generate synthesis)
+  Phase
+  (case synthesis
+    (^template [<tag> <generator>]
+      (^ (<tag> value))
+      (:: ///.monad wrap (<generator> value)))
+    ([synthesis.bit  primitive.bit]
+     [synthesis.i64  primitive.i64]
+     [synthesis.f64  primitive.f64]
+     [synthesis.text primitive.text])
+
+    (^ (synthesis.variant variantS))
+    (structure.variant generate variantS)
+
+    (^ (synthesis.tuple members))
+    (structure.tuple generate members)
+
+    (#synthesis.Reference value)
+    (reference@reference value)
+
+    (^ (synthesis.branch/case case))
+    (case.case generate case)
+
+    (^ (synthesis.branch/let let))
+    (case.let generate let)
+
+    (^ (synthesis.branch/if if))
+    (case.if generate if)
+
+    (^ (synthesis.loop/scope scope))
+    (loop.scope generate scope)
+
+    (^ (synthesis.loop/recur updates))
+    (loop.recur generate updates)
+
+    (^ (synthesis.function/abstraction abstraction))
+    (function.function generate abstraction)
+
+    (^ (synthesis.function/apply application))
+    (function.apply generate application)
+
+    (#synthesis.Extension extension)
+    (extension.apply generate extension)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux
new file mode 100644
index 000000000..144c0236e
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux
@@ -0,0 +1,223 @@
+(.module:
+  [lux (#- case let if)
+   [abstract
+    [monad (#+ do)]]
+   [control
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." text
+     format]
+    [collection
+     ["." list ("#@." functor fold)]
+     ["." set]]]
+   [target
+    ["_" common-lisp (#+ Expression Var/1)]]]
+  ["." // #_
+   ["#." runtime (#+ Operation Phase)]
+   ["#." reference]
+   ["#." primitive]
+   ["#/" //
+    ["#." reference]
+    ["#/" // ("#@." monad)
+     [synthesis
+      ["." case]]
+     ["#/" // #_
+      ["." reference (#+ Register)]
+      ["#." synthesis (#+ Synthesis Path)]]]]])
+
+(def: #export register
+  (///reference.local _.var))
+
+(def: #export capture
+  (///reference.foreign _.var))
+
+(def: #export (let generate [valueS register bodyS])
+  (-> Phase [Synthesis Register Synthesis]
+      (Operation (Expression Any)))
+  (do ////.monad
+    [valueG (generate valueS)
+     bodyG (generate bodyS)]
+    (wrap (_.let (list [(..register register) valueG])
+            bodyG))))
+
+(def: #export (record-get generate valueS pathP)
+  (-> Phase Synthesis (List (Either Nat Nat))
+      (Operation (Expression Any)))
+  (do ////.monad
+    [valueG (generate valueS)]
+    (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)))
+                     valueG
+                     pathP))))
+
+(def: #export (if generate [testS thenS elseS])
+  (-> Phase [Synthesis Synthesis Synthesis]
+      (Operation (Expression Any)))
+  (do ////.monad
+    [testG (generate testS)
+     thenG (generate thenS)
+     elseG (generate elseS)]
+    (wrap (_.if testG thenG elseG))))
+
+(def: @savepoint (_.var "lux_pm_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+(def: @variant (_.var "lux_pm_variant"))
+(def: @return (_.var "lux_pm_return"))
+
+(def: (push! value)
+  (-> (Expression Any) (Expression Any))
+  (_.setq @cursor (_.cons/2 [value @cursor])))
+
+(def: pop!
+  (Expression Any)
+  (_.setq @cursor (_.cdr/1 @cursor)))
+
+(def: peek
+  (Expression Any)
+  (_.car/1 @cursor))
+
+(def: save!
+  (Expression Any)
+  (_.setq @savepoint (_.cons/2 [@cursor @savepoint])))
+
+(def: restore!
+  (Expression Any)
+  ($_ _.progn
+      (_.setq @cursor (_.car/1 @savepoint))
+      (_.setq @savepoint (_.cdr/1 @savepoint))))
+
+(def: fail-tag (_.tag "lux_pm_fail"))
+(def: done-tag (_.tag "lux_pm_done"))
+
+(def: fail! (_.go ..fail-tag))
+(def: return! (_.go ..done-tag))
+
+(exception: #export unrecognized-path)
+
+(def: (multi-pop! pops)
+  (-> Nat (Expression Any))
+  (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor])))
+
+(template [<name> <flag> <prep>]
+  [(def: (<name> simple? idx)
+     (-> Bit Nat (Expression Any))
+     (.let [<failure-condition> (_.eq @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))
+               )))))]
+
+  [left-choice  _.nil         (<|)]
+  [right-choice (_.string "") inc]
+  )
+
+(def: (alternation pre! post!)
+  (-> (Expression Any) (Expression Any) (Expression Any))
+  (_.tagbody ($_ _.progn
+                 ..save!
+                 pre!)
+             (list [fail-tag
+                    ($_ _.progn
+                        ..restore!
+                        post!)])))
+
+(def: (pattern-matching' generate pathP)
+  (-> Phase Path (Operation (Expression Any)))
+  (.case pathP
+    (^ (/////synthesis.path/then bodyS))
+    (do ////.monad
+      [bodyG (generate bodyS)]
+      (wrap ($_ _.progn
+                (_.setq @return bodyG)
+                ..return!)))
+
+    #/////synthesis.Pop
+    (////@wrap ..pop!)
+
+    (#/////synthesis.Bind register)
+    (////@wrap (_.setq (..register register) ..peek))
+
+    (^template [<tag> <format> <=>]
+      (^ (<tag> value))
+      (////@wrap (_.if (|> value <format> (<=> ..peek))
+                   _.nil
+                   fail!)))
+    ([/////synthesis.path/bit //primitive.bit _.equal]
+     [/////synthesis.path/i64  //primitive.i64  _.=]
+     [/////synthesis.path/f64 //primitive.f64   _.=]
+     [/////synthesis.path/text //primitive.text _.string=])
+
+    (^template [<complex> <simple> <choice>]
+      (^ (<complex> idx))
+      (////@wrap (<choice> false idx))
+
+      (^ (<simple> idx nextP))
+      (|> nextP
+          (pattern-matching' generate)
+          (:: ////.monad map (_.progn (<choice> true idx)))))
+    ([/////synthesis.side/left  /////synthesis.simple-left-side  ..left-choice]
+     [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice])
+
+    (^ (/////synthesis.member/left 0))
+    (////@wrap (..push! (_.elt/2 [..peek (_.int +0)])))
+    
+    (^template [<pm> <getter>]
+      (^ (<pm> lefts))
+      (////@wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!)))
+    ([/////synthesis.member/left  //runtime.tuple//left]
+     [/////synthesis.member/right //runtime.tuple//right])
+
+    (^ (/////synthesis.!multi-pop nextP))
+    (.let [[extra-pops nextP'] (case.count-pops nextP)]
+      (do ////.monad
+        [next! (pattern-matching' generate nextP')]
+        (////@wrap ($_ _.progn
+                       (..multi-pop! (n/+ 2 extra-pops))
+                       next!))))
+
+    (^template [<tag> <combinator>]
+      (^ (<tag> preP postP))
+      (do ////.monad
+        [pre! (pattern-matching' generate preP)
+         post! (pattern-matching' generate postP)]
+        (wrap (<combinator> pre! post!))))
+    ([/////synthesis.path/alt ..alternation]
+     [/////synthesis.path/seq _.progn])
+
+    _
+    (////.throw unrecognized-path [])))
+
+(def: (pattern-matching generate pathP)
+  (-> Phase Path (Operation (Expression Any)))
+  (do ////.monad
+    [pattern-matching! (pattern-matching' generate pathP)]
+    (wrap ($_ _.progn
+              (_.tagbody pattern-matching!
+                         (list [..fail-tag
+                                (_.error/1 (_.string "Invalid expression for pattern-matching."))]
+                               [..done-tag
+                                _.nil]))
+              @return))))
+
+(def: #export (case generate [valueS pathP])
+  (-> Phase [Synthesis Path] (Operation (Expression Any)))
+  (do ////.monad
+    [initG (generate valueS)
+     pattern-matching! (pattern-matching generate pathP)]
+    (wrap (_.let (list [@cursor (_.list/* (list initG))]
+                       [@savepoint (_.list/* (list))]
+                       [@temp _.nil])
+            pattern-matching!))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension.lux
new file mode 100644
index 000000000..3bc0a0887
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension.lux
@@ -0,0 +1,13 @@
+(.module:
+  [lux #*
+   [data
+    [collection
+     ["." dictionary]]]]
+  [//
+   [runtime (#+ Bundle)]]
+  [/
+   ["." common]])
+
+(def: #export bundle
+  Bundle
+  common.bundle)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux
new file mode 100644
index 000000000..a72239982
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux
@@ -0,0 +1,154 @@
+(.module:
+  [lux #*
+   [host (#+ import:)]
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." function]]
+   [data
+    ["." product]
+    [collection
+     ["." dictionary]]]
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  ["." /// #_
+   ["#." runtime (#+ Operation Phase Handler Bundle)]
+   ["#." primitive]
+   [//
+    [extension (#+ Nullary Unary Binary Trinary
+                   nullary unary binary trinary)]
+    [//
+     [extension
+      ["." bundle]]]]])
+
+(def: lux-procs
+  Bundle
+  (|> bundle.empty
+      (bundle.install "is" (binary (product.uncurry _.eq)))
+      (bundle.install "try" (unary ///runtime.lux//try))))
+
+(def: (i64//left-shift [paramG subjectG])
+  (Binary (Expression Any))
+  (_.ash (_.rem (_.int +64) paramG) subjectG))
+
+(def: (i64//arithmetic-right-shift [paramG subjectG])
+  (Binary (Expression Any))
+  (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1)))
+         subjectG))
+
+(def: (i64//logic-right-shift [paramG subjectG])
+  (Binary (Expression Any))
+  (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG))
+
+(def: i64-procs
+  Bundle
+  (<| (bundle.prefix "i64")
+      (|> bundle.empty
+          (bundle.install "and" (binary (product.uncurry _.logand)))
+          (bundle.install "or" (binary (product.uncurry _.logior)))
+          (bundle.install "xor" (binary (product.uncurry _.logxor)))
+          (bundle.install "left-shift" (binary i64//left-shift))
+          (bundle.install "logical-right-shift" (binary i64//logic-right-shift))
+          (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift))
+          (bundle.install "=" (binary (product.uncurry _.=)))
+          (bundle.install "<" (binary (product.uncurry _.<)))
+          (bundle.install "+" (binary (product.uncurry _.+)))
+          (bundle.install "-" (binary (product.uncurry _.-)))
+          (bundle.install "*" (binary (product.uncurry _.*)))
+          (bundle.install "/" (binary (product.uncurry _.floor)))
+          (bundle.install "%" (binary (product.uncurry _.rem)))
+          (bundle.install "f64" (unary (function (_ value)
+                                         (_.coerce/2 [value (_.symbol "double-float")]))))
+          (bundle.install "char" (unary (|>> _.code-char/1 _.string/1)))
+          )))
+
+(import: #long java/lang/Double
+  (#static MIN_VALUE Double)
+  (#static MAX_VALUE Double))
+
+(template [<name> <const>]
+  [(def: (<name> _)
+     (Nullary (Expression Any))
+     (_.double <const>))]
+
+  [f64//smallest (java/lang/Double::MIN_VALUE)]
+  [f64//min      (f/* -1.0 (java/lang/Double::MAX_VALUE))]
+  [f64//max      (java/lang/Double::MAX_VALUE)]
+  )
+
+(def: f64-procs
+  Bundle
+  (<| (bundle.prefix "f64")
+      (|> bundle.empty
+          (bundle.install "+" (binary (product.uncurry _.+)))
+          (bundle.install "-" (binary (product.uncurry _.-)))
+          (bundle.install "*" (binary (product.uncurry _.*)))
+          (bundle.install "/" (binary (product.uncurry _./)))
+          (bundle.install "%" (binary (product.uncurry _.mod)))
+          (bundle.install "=" (binary (product.uncurry _.=)))
+          (bundle.install "<" (binary (product.uncurry _.<)))
+          (bundle.install "smallest" (nullary f64//smallest))
+          (bundle.install "min" (nullary f64//min))
+          (bundle.install "max" (nullary f64//max))
+          (bundle.install "i64" (unary _.floor/1))
+          (bundle.install "encode" (unary _.write-to-string/1))
+          (bundle.install "decode" (unary (let [@temp (_.var "temp")]
+                                            (function (_ input)
+                                              (_.let (list [@temp (_.read-from-string/1 input)])
+                                                (_.if (_.equal (_.symbol "DOUBLE-FLOAT")
+                                                               (_.type-of/1 @temp))
+                                                  (///runtime.some @temp)
+                                                  ///runtime.none)))))))))
+
+(def: (text//< [paramG subjectG])
+  (Binary (Expression Any))
+  (|> (_.string< paramG subjectG)
+      _.null/1
+      _.not/1))
+
+(def: (text//clip [paramO extraO subjectO])
+  (Trinary (Expression Any))
+  (///runtime.text//clip subjectO paramO extraO))
+
+(def: (text//index [startO partO textO])
+  (Trinary (Expression Any))
+  (///runtime.text//index textO partO startO))
+
+(def: text-procs
+  Bundle
+  (<| (bundle.prefix "text")
+      (|> bundle.empty
+          (bundle.install "=" (binary (product.uncurry _.string=)))
+          (bundle.install "<" (binary text//<))
+          (bundle.install "concat" (binary _.concatenate/2|string))
+          (bundle.install "index" (trinary text//index))
+          (bundle.install "size" (unary _.length/1))
+          (bundle.install "char" (binary (|>> _.char/2 _.char-int/1)))
+          (bundle.install "clip" (trinary text//clip))
+          )))
+
+(def: (void code)
+  (-> (Expression Any) (Expression Any))
+  ($_ _.progn
+      code
+      ///runtime.unit))
+
+(def: io-procs
+  Bundle
+  (<| (bundle.prefix "io")
+      (|> bundle.empty
+          (bundle.install "log" (unary (|>> _.print/1 ..void)))
+          (bundle.install "error" (unary _.error/1))
+          (bundle.install "exit" (unary ///runtime.io//exit))
+          (bundle.install "current-time" (nullary (function (_ _)
+                                                    (///runtime.io//current-time ///runtime.unit)))))))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "lux")
+      (|> lux-procs
+          (dictionary.merge i64-procs)
+          (dictionary.merge f64-procs)
+          (dictionary.merge text-procs)
+          (dictionary.merge io-procs)
+          )))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux
new file mode 100644
index 000000000..d32f1b772
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux
@@ -0,0 +1,94 @@
+(.module:
+  [lux (#- function)
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    pipe]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("#@." functor fold)]]]
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  ["." // #_
+   [runtime (#+ Operation Phase)]
+   ["#." reference]
+   ["#." case]
+   ["#/" //
+    ["#." reference]
+    ["#/" //
+     ["." // #_
+      [reference (#+ Register Variable)]
+      [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)]
+      [synthesis (#+ Synthesis)]]]]])
+
+(def: #export (apply generate [functionS argsS+])
+  (-> Phase (Application Synthesis) (Operation (Expression Any)))
+  (do ////.monad
+    [functionG (generate functionS)
+     argsG+ (monad.map @ generate argsS+)]
+    (wrap (_.funcall/+ [functionG argsG+]))))
+
+(def: #export capture
+  (///reference.foreign _.var))
+
+(def: (with-closure function-name inits function-definition)
+  (-> Text (List (Expression Any)) (Expression Any) (Operation (Expression Any)))
+  (case inits
+    #.Nil
+    (:: ////.monad wrap function-definition)
+
+    _
+    (do ////.monad
+      [@closure (:: @ map _.var (///.gensym "closure"))]
+      (wrap (_.labels (list [@closure [(|> (list.enumerate inits)
+                                           (list@map (|>> product.left ..capture))
+                                           _.args)
+                                       function-definition]])
+                      (_.funcall/+ [(_.function/1 @closure) inits]))))))
+
+(def: input
+  (|>> inc //case.register))
+
+(def: #export (function generate [environment arity bodyS])
+  (-> Phase (Abstraction Synthesis) (Operation (Expression Any)))
+  (do ////.monad
+    [[function-name bodyG] (///.with-context
+                             (do @
+                               [function-name ///.context]
+                               (///.with-anchor (_.var function-name)
+                                 (generate bodyS))))
+     closureG+ (: (Operation (List (Expression Any)))
+                  (monad.map @ (:: //reference.system variable) environment))
+     #let [@curried (_.var "curried")
+           @missing (_.var "missing")
+           arityG (|> arity .int _.int)
+           @num-args (_.var "num_args")
+           @self (_.var function-name)
+           initialize-self! [(//case.register 0) (_.function/1 @self)]
+           initialize! [(|> (list.indices arity)
+                            (list@map ..input)
+                            _.args)
+                        @curried]]]
+    (with-closure function-name closureG+
+      (_.labels (list [@self [(_.args& (list) @curried)
+                              (_.let (list [@num-args (_.length/1 @curried)])
+                                (_.cond (list [(|> @num-args (_.= arityG))
+                                               (_.let (list initialize-self!)
+                                                 (_.destructuring-bind initialize!
+                                                                       bodyG))]
+
+                                              [(|> @num-args (_.> arityG))
+                                               (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/phase/generation/common-lisp/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/loop.lux
new file mode 100644
index 000000000..29326e358
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/loop.lux
@@ -0,0 +1,40 @@
+(.module:
+  [lux (#- Scope)
+   [abstract
+    ["." monad (#+ do)]]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("#@." functor)]]]
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  ["." // #_
+   [runtime (#+ Operation Phase)]
+   ["#." case]
+   ["#/" //
+    ["#/" //
+     [//
+      [synthesis (#+ Scope Synthesis)]]]]])
+
+(def: #export (scope generate [start initsS+ bodyS])
+  (-> Phase (Scope Synthesis) (Operation (Expression Any)))
+  (do ////.monad
+    [@scope (:: @ map (|>> %n (format "scope") _.var) ///.next)
+     initsG+ (monad.map @ generate initsS+)
+     bodyG (///.with-anchor @scope
+             (generate bodyS))]
+    (wrap (_.labels (list [@scope {#_.input (|> initsS+
+                                                list.enumerate
+                                                (list@map (|>> product.left (n/+ start) //case.register))
+                                                _.args)
+                                   #_.output bodyG}])
+                    (_.funcall/+ [(_.function/1 @scope) initsG+])))))
+
+(def: #export (recur generate argsS+)
+  (-> Phase (List Synthesis) (Operation (Expression Any)))
+  (do ////.monad
+    [@scope ///.anchor
+     argsO+ (monad.map @ generate argsS+)]
+    (wrap (_.call/* @scope argsO+))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/primitive.lux
new file mode 100644
index 000000000..4177f814a
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/primitive.lux
@@ -0,0 +1,27 @@
+(.module:
+  [lux (#- i64)
+   [control
+    [pipe (#+ cond> new>)]]
+   [data
+    [number
+     ["." frac]]]
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  ["." // #_
+   ["#." runtime]])
+
+(def: #export bit
+  (-> Bit (Expression Any))
+  _.bool)
+
+(def: #export i64
+  (-> (I64 Any) (Expression Any))
+  (|>> .int _.int))
+
+(def: #export f64
+  (-> Frac (Expression Any))
+  _.double)
+
+(def: #export text
+  (-> Text (Expression Any))
+  _.string)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux
new file mode 100644
index 000000000..206f3f0e9
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux
@@ -0,0 +1,10 @@
+(.module:
+  [lux #*
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  [///
+   ["." reference]])
+
+(def: #export system
+  (reference.system (: (-> Text (Expression Any)) _.var)
+                    (: (-> Text (Expression Any)) _.var)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux
new file mode 100644
index 000000000..87fc7741d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux
@@ -0,0 +1,276 @@
+(.module:
+  [lux (#- inc)
+   [abstract
+    [monad (#+ do)]]
+   [control
+    ["." function]
+    ["p" parser
+     ["s" code]]]
+   [data
+    [number (#+ hex)
+     ["." i64]]
+    ["." text
+     format]
+    [collection
+     ["." list ("#@." functor)]]]
+   ["." macro
+    ["." code]
+    [syntax (#+ syntax:)]]
+   [target
+    ["_" common-lisp (#+ Expression Var/1 Computation Literal)]]]
+  ["." ///
+   ["//." //
+    [//
+     ["/////." name]
+     ["." synthesis]]]]
+  )
+
+(template [<name> <base>]
+  [(type: #export <name>
+     (<base> Var/1 (Expression Any) (Expression Any)))]
+
+  [Operation ///.Operation]
+  [Phase ///.Phase]
+  [Handler ///.Handler]
+  [Bundle ///.Bundle]
+  )
+
+(def: prefix "LuxRuntime")
+
+(def: #export unit (_.string synthesis.unit))
+
+(def: (flag value)
+  (-> Bit Literal)
+  (if value
+    (_.string "")
+    _.nil))
+
+(def: (variant' tag last? value)
+  (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
+  (_.list/* (list tag last? value)))
+
+(def: #export (variant tag last? value)
+  (-> Nat Bit (Expression Any) (Computation Any))
+  (variant' (_.int (.int tag))
+            (flag last?)
+            value))
+
+(def: #export none
+  (Computation Any)
+  (..variant 0 false ..unit))
+
+(def: #export some
+  (-> (Expression Any) (Computation Any))
+  (..variant 1 true))
+
+(def: #export left
+  (-> (Expression Any) (Computation Any))
+  (..variant 0 false))
+
+(def: #export right
+  (-> (Expression Any) (Computation Any))
+  (..variant 1 true))
+
+(def: runtime-name
+  (-> Text Var/1)
+  (|>> /////name.normalize
+       (format ..prefix "_")
+       _.var))
+
+(def: (feature name definition)
+  (-> Var/1 (-> Var/1 (Expression Any)) (Expression Any))
+  (definition name))
+
+(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))}
+                   body)
+  (wrap (list (` (let [(~+ (|> vars
+                               (list@map (function (_ var)
+                                           (list (code.local-identifier var)
+                                                 (` (_.var (~ (code.text (/////name.normalize var))))))))
+                               list.concat))]
+                   (~ body))))))
+
+(syntax: (runtime: {declaration (p.or s.local-identifier
+                                      (s.form (p.and s.local-identifier
+                                                     (p.some s.local-identifier))))}
+           code)
+  (macro.with-gensyms [g!_ g!L]
+    (case declaration
+      (#.Left name)
+      (let [code-nameC (code.local-identifier (format "@" name))
+            runtime-nameC (` (runtime-name (~ (code.text name))))]
+        (wrap (list (` (def: #export (~ (code.local-identifier name)) _.Var/1 (~ runtime-nameC)))
+                    (` (def: (~ code-nameC)
+                         (_.Expression Any)
+                         (..feature (~ runtime-nameC)
+                                    (function ((~ g!_) (~ g!L))
+                                      (_.defparameter (~ g!L) (~ code)))))))))
+      
+      (#.Right [name inputs])
+      (let [code-nameC (code.local-identifier (format "@" name))
+            runtime-nameC (` (runtime-name (~ (code.text name))))
+            inputsC (list@map code.local-identifier inputs)
+            inputs-typesC (list@map (function.constant (` (_.Expression Any)))
+                                    inputs)]
+        (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~+ inputsC))
+                         (-> (~+ inputs-typesC) (_.Computation Any))
+                         (_.call/* (~ runtime-nameC) (list (~+ inputsC)))))
+                    (` (def: (~ code-nameC)
+                         (_.Expression Any)
+                         (..feature (~ runtime-nameC)
+                                    (function ((~ g!_) (~ g!L))
+                                      (..with-vars [(~+ inputsC)]
+                                        (_.defun (~ g!L) (_.args (list (~+ inputsC)))
+                                                 (~ code)))))))))))))
+
+(runtime: (lux//try op)
+  (with-vars [error]
+    (_.handler-case
+     (list [(_.bool true) error
+            (..left (_.format/3 [_.nil (_.string "~A") error]))])
+     (..right (_.funcall/+ [op (list ..unit)])))))
+
+## TODO: Use Common Lisp's swiss-army loop macro instead.
+(runtime: (lux//program-args inputs)
+  (with-vars [loop input tail]
+    (_.labels (list [loop [(_.args (list input tail))
+                           (_.if (_.null/1 input)
+                             tail
+                             (_.funcall/+ [(_.function/1 loop)
+                                           (list (_.cdr/1 input)
+                                                 (..some (_.vector/* (list (_.car/1 input) tail))))]))]])
+              (_.funcall/+ [(_.function/1 loop)
+                            (list (_.reverse/1 inputs)
+                                  ..none)]))))
+
+(def: runtime//lux
+  ($_ _.progn
+      @lux//try
+      @lux//program-args))
+
+(def: last-index
+  (|>> _.length/1 (_.- (_.int +1))))
+
+(with-expansions [<recur> (as-is ($_ _.then
+                                     (_.; (_.set lefts (_.- last-index-right lefts)))
+                                     (_.; (_.set tuple (_.nth last-index-right tuple)))))]
+  (template: (!recur <side>)
+    (<side> (|> lefts (_.- last-index-right))
+            (_.elt/2 [tuple last-index-right])))
+  
+  (runtime: (tuple//left lefts tuple)
+    (with-vars [last-index-right]
+      (_.let (list [last-index-right (..last-index tuple)])
+        (_.if (_.> 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 (_.+ (_.int +1) lefts)])
+        (_.cond (list [(_.= right-index last-index-right)
+                       (_.elt/2 [tuple right-index])]
+                      [(_.> right-index last-index-right)
+                       ## 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.
+(runtime: (sum//get sum wantsLast wantedTag)
+  (let [no-match! sum
+        sum-tag (_.nth/2 [(_.int +0) sum])
+        sum-flag (_.nth/2 [(_.int +1) sum])
+        sum-value (_.nth/2 [(_.int +2) sum])
+        test-recursion! (_.if sum-flag
+                          ## Must recurse.
+                          (sum//get sum-value wantsLast (_.- sum-tag wantedTag))
+                          no-match!)]
+    (_.cond (list [(_.= sum-tag wantedTag)
+                   (_.if (_.equal wantsLast sum-flag)
+                     sum-value
+                     test-recursion!)]
+
+                  [(_.> sum-tag wantedTag)
+                   test-recursion!]
+
+                  [(_.and (_.< sum-tag wantedTag)
+                          wantsLast)
+                   (variant' (_.- wantedTag sum-tag) sum-flag sum-value)])
+
+            no-match!)))
+
+(def: runtime//adt
+  ($_ _.progn
+      @tuple//left
+      @tuple//right
+      @sum//get))
+
+(runtime: (i64//logic-right-shift shift input)
+  (_.if (_.= (_.int +0) shift)
+    input
+    (|> input
+        (_.ash (_.* (_.int -1) shift))
+        (_.logand (_.int (hex "+7FFFFFFFFFFFFFFF"))))))
+
+(def: runtime//i64
+  ($_ _.progn
+      @i64//logic-right-shift))
+
+(runtime: (text//clip from to text)
+  (_.subseq/3 [text from to]))
+
+(runtime: (text//index reference start space)
+  (with-vars [index]
+    (_.let (list [index (_.search/3 [reference space start])])
+      (_.if index
+        (..some index)
+        ..none))))
+
+(def: runtime//text
+  ($_ _.progn
+      @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))))
+
+(runtime: (io//current-time _)
+  (|> (_.get-universal-time/0 [])
+      (_.* (_.int +1,000))))
+
+(def: runtime//io
+  ($_ _.progn
+      @io//exit
+      @io//current-time))
+
+(def: runtime
+  ($_ _.progn
+      runtime//adt
+      runtime//lux
+      runtime//i64
+      runtime//text
+      runtime//io))
+
+(def: #export artifact ..prefix)
+
+(def: #export generate
+  (Operation Any)
+  (///.with-buffer
+    (do ////.monad
+      [_ (///.save! true ["" ..prefix]
+                    ..runtime)]
+      (///.save-buffer! ..artifact))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux
new file mode 100644
index 000000000..ef29d33dc
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux
@@ -0,0 +1,36 @@
+(.module:
+  [lux #*
+   [abstract
+    ["." monad (#+ do)]]
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  ["." // #_
+   ["#." runtime (#+ Operation Phase)]
+   ["#." primitive]
+   ["//#" ///
+    ["/#" // #_
+     [analysis (#+ Variant Tuple)]
+     ["#." synthesis (#+ Synthesis)]]]])
+
+(def: #export (tuple generate elemsS+)
+  (-> Phase (Tuple Synthesis) (Operation (Expression Any)))
+  (case elemsS+
+    #.Nil
+    (:: ////.monad wrap (//primitive.text /////synthesis.unit))
+
+    (#.Cons singletonS #.Nil)
+    (generate singletonS)
+
+    _
+    (|> elemsS+
+        (monad.map ////.monad generate)
+        (:: ////.monad map _.vector/*))))
+
+(def: #export (variant generate [lefts right? valueS])
+  (-> Phase (Variant Synthesis) (Operation (Expression Any)))
+  (:: ////.monad map
+      (//runtime.variant (if right?
+                           (inc lefts)
+                           lefts)
+                         right?)
+      (generate valueS)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux
index e325b1fca..e04befc25 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux
@@ -317,34 +317,6 @@
       @text//clip
       @text//char))
 
-(runtime: (array//get array idx)
-  (with-vars [temp]
-    ($_ _.then
-        (_.set (list temp) (_.nth idx array))
-        (_.if (_.= _.none temp)
-          (_.return ..none)
-          (_.return (..some temp))))))
-
-(runtime: (array//put array idx value)
-  ($_ _.then
-      (_.set (list (_.nth idx array)) value)
-      (_.return array)))
-
-(def: runtime//array
-  (Statement Any)
-  ($_ _.then
-      @array//get
-      @array//put))
-
-(runtime: (box//write value box)
-  ($_ _.then
-      (_.set (list (_.nth (_.int +0) box)) value)
-      (_.return ..unit)))
-
-(def: runtime//box
-  (Statement Any)
-  @box//write)
-
 (def: runtime
   (Statement Any)
   ($_ _.then
@@ -353,8 +325,6 @@
       runtime//i64
       runtime//frac
       runtime//text
-      runtime//array
-      runtime//box
       runtime//io
       ))
 
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index a881dae3f..b69a6b969 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -41,6 +41,7 @@
       [lua (#+)]
       [ruby (#+)]
       [php (#+)]
+      [common-lisp (#+)]
       [scheme (#+)]]
      [tool
       [compiler
@@ -56,6 +57,8 @@
           <host-modules>]
          [php (#+)
           <host-modules>]
+         [common-lisp (#+)
+          <host-modules>]
          [scheme (#+)
           <host-modules>]]]]]
      ## [control