aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2021-05-25 01:55:09 -0400
committerEduardo Julian2021-05-25 01:55:09 -0400
commit2df8e4bc8c53a831f3cd8605707ca08d66cecb02 (patch)
tree839af4a3c1b2c1629946111d58373946d367becc /stdlib
parentf01e246f468c948d41423248809443570f48c7a4 (diff)
Updates for Common-Lisp compiler.
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/target.lux2
-rw-r--r--stdlib/source/lux/target/common_lisp.lux (renamed from stdlib/source/lux/target/common-lisp.lux)105
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux175
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux39
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux60
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux209
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux93
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux288
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux241
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux (renamed from stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux)0
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux (renamed from stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux)0
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux97
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux53
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux (renamed from stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux)5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux305
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux44
24 files changed, 1141 insertions, 818 deletions
diff --git a/stdlib/source/lux/target.lux b/stdlib/source/lux/target.lux
index c33e5b045..a5188a907 100644
--- a/stdlib/source/lux/target.lux
+++ b/stdlib/source/lux/target.lux
@@ -10,7 +10,7 @@
## TODO: Delete ASAP
[old "{old}"]
- [common-lisp "Common Lisp"]
+ [common_lisp "Common Lisp"]
[js "JavaScript"]
[jvm "JVM"]
[lua "Lua"]
diff --git a/stdlib/source/lux/target/common-lisp.lux b/stdlib/source/lux/target/common_lisp.lux
index 38788c49a..19f70cde8 100644
--- a/stdlib/source/lux/target/common-lisp.lux
+++ b/stdlib/source/lux/target/common_lisp.lux
@@ -3,18 +3,19 @@
[control
[pipe (#+ case> cond> new>)]]
[data
- [number
- ["f" frac]]
["." text
["%" format (#+ format)]]
[collection
["." list ("#\." monad fold)]]]
[macro
["." template]]
+ [math
+ [number
+ ["f" frac]]]
[type
abstract]])
-(def: as-form
+(def: as_form
(-> Text Text)
(text.enclose ["(" ")"]))
@@ -30,7 +31,7 @@
(|>> :representation))
(template [<type> <super>]
- [(with-expansions [<brand> (template.identifier [<type> "'"])]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
(`` (abstract: #export (<brand> brand) Any))
(`` (type: #export (<type> brand)
(<super> (<brand> brand)))))]
@@ -44,7 +45,7 @@
)
(template [<type> <super>]
- [(with-expansions [<brand> (template.identifier [<type> "'"])]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
(`` (abstract: #export <brand> Any))
(`` (type: #export <type> (<super> <brand>))))]
@@ -81,13 +82,13 @@
(def: #export float
(-> Frac Literal)
- (|>> (cond> [(f.= f.positive-infinity)]
+ (|>> (cond> [(f.= f.positive_infinity)]
[(new> "(/ 1.0 0.0)" [])]
- [(f.= f.negative-infinity)]
+ [(f.= f.negative_infinity)]
[(new> "(/ -1.0 0.0)" [])]
- [f.not-a-number?]
+ [f.not_a_number?]
[(new> "(/ 0.0 0.0)" [])]
## else
@@ -97,42 +98,42 @@
(def: #export (double value)
(-> Frac Literal)
(:abstraction
- (.cond (f.= f.positive-infinity value)
+ (.cond (f.= f.positive_infinity value)
"(/ 1.0d0 0.0d0)"
- (f.= f.negative-infinity value)
+ (f.= f.negative_infinity value)
"(/ -1.0d0 0.0d0)"
- (f.not-a-number? value)
+ (f.not_a_number? value)
"(/ 0.0d0 0.0d0)"
## else
(.let [raw (%.frac value)]
(.if (text.contains? "E" raw)
- (text.replace-once "E" "d" raw)
+ (text.replace_once "E" "d" raw)
(format raw "d0"))))))
(def: sanitize
(-> Text Text)
(`` (|>> (~~ (template [<find> <replace>]
- [(text.replace-all <find> <replace>)]
+ [(text.replace_all <find> <replace>)]
["\" "\\"]
[text.tab "\t"]
- [text.vertical-tab "\v"]
+ [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)]
+ [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)
+ (text.enclose' text.double_quote)
:abstraction))
(def: #export var
@@ -142,24 +143,24 @@
(def: #export args
(-> (List Var/1) Var/*)
(|>> (list\map ..code)
- (text.join-with " ")
- ..as-form
+ (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 " "))
+ (text.join_with " "))
" &rest " (:representation rest))
- ..as-form
+ ..as_form
:abstraction))
(def: form
(-> (List (Expression Any)) Expression)
(|>> (list\map ..code)
- (text.join-with " ")
- ..as-form
+ (text.join_with " ")
+ ..as_form
:abstraction))
(def: #export (call/* func)
@@ -178,8 +179,8 @@
(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)))
+ (..form (list\map (function (_ [def_name [def_args def_body]])
+ (..form (list def_name (:transmutation def_args) def_body)))
definitions))
body)))
@@ -189,15 +190,15 @@
(: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 [<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 [<lux_name> <host_name>]
+ [(def: #export (<lux_name> args)
+ (-> [(~~ (template.splice <input_type>+))] (Computation Any))
+ (<call> args (..var <host_name>)))]
(~~ (template.splice <function>+))))]
@@ -241,11 +242,11 @@
[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 [<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>+))))]
@@ -260,7 +261,7 @@
[gethash/2 "gethash"]]]
)
- (def: #export (make-hash-table/with-size size)
+ (def: #export (make-hash-table/with_size size)
(-> (Expression Any) (Computation Any))
(..call/* (..var "make-hash-table")
(list (..keyword "size")
@@ -281,19 +282,19 @@
(-> [(Expression Any) (Expression Any)] (Computation Any))
(concatenate/3 [(..symbol "string") left right]))
- (template [<lux-name> <host-name>]
- [(def: #export (<lux-name> 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)))]
+ (..form (list (..var <host_name>) left right)))]
[or "or"]
[and "and"]
)
- (template [<lux-name> <host-name>]
- [(def: #export (<lux-name> param subject)
+ (template [<lux_name> <host_name>]
+ [(def: #export (<lux_name> param subject)
(-> (Expression Any) (Expression Any) (Computation Any))
- (..form (list (..var <host-name>) subject param)))]
+ (..form (list (..var <host_name>) subject param)))]
[= "="]
[eq "eq"]
@@ -329,10 +330,10 @@
(-> Var/* (Expression Any) Literal)
(..form (list (..var "lambda") (:transmutation input) body)))
- (template [<lux-name> <host-name>]
- [(def: #export (<lux-name> bindings 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>)
+ (..form (list (..var <host_name>)
(|> bindings
(list\map (function (_ [name value])
(..form (list name value))))
@@ -364,7 +365,7 @@
(..form (list (..var "setf") access value)))
(type: #export Handler
- {#condition-type (Expression Any)
+ {#condition_type (Expression Any)
#condition Var/1
#body (Expression Any)})
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux
new file mode 100644
index 000000000..887d639f1
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux
@@ -0,0 +1,34 @@
+(.module:
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" common_lisp]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "common_lisp")
+ (|> bundle.empty
+ )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux
new file mode 100644
index 000000000..dc81d4b18
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux
@@ -0,0 +1,17 @@
+(.module:
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [common_lisp
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
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
new file mode 100644
index 000000000..d5d528631
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
@@ -0,0 +1,175 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." set]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" common_lisp (#+ Expression)]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" common_lisp #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
+ ["#." case]]]
+ [//
+ ["." synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+(template: (!unary function)
+ (|>> list _.apply/* (|> (_.constant function))))
+
+## TODO: Get rid of this ASAP
+## (def: lux::syntax_char_case!
+## (..custom [($_ <>.and
+## <s>.any
+## <s>.any
+## (<>.some (<s>.tuple ($_ <>.and
+## (<s>.tuple (<>.many <s>.i64))
+## <s>.any))))
+## (function (_ extension_name phase archive [input else conditionals])
+## (do {! /////.monad}
+## [@input (\ ! map _.var (generation.gensym "input"))
+## inputG (phase archive input)
+## elseG (phase archive else)
+## conditionalsG (: (Operation (List [Expression Expression]))
+## (monad.map ! (function (_ [chars branch])
+## (do !
+## [branchG (phase archive branch)]
+## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
+## branchG])))
+## conditionals))]
+## (wrap (_.let (list [@input inputG])
+## (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: (capped operation parameter subject)
+## (-> (-> Expression Expression Expression)
+## (-> Expression Expression Expression))
+## (//runtime.i64//64 (operation parameter subject)))
+
+## (def: i64_procs
+## Bundle
+## (<| (/.prefix "i64")
+## (|> /.empty
+## (/.install "and" (binary (product.uncurry //runtime.i64//and)))
+## (/.install "or" (binary (product.uncurry //runtime.i64//or)))
+## (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
+## (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
+## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+## (/.install "=" (binary (product.uncurry _.=/2)))
+## (/.install "<" (binary (product.uncurry _.</2)))
+## (/.install "+" (binary (product.uncurry (..capped _.+/2))))
+## (/.install "-" (binary (product.uncurry (..capped _.-/2))))
+## (/.install "*" (binary (product.uncurry (..capped _.*/2))))
+## (/.install "/" (binary (product.uncurry //runtime.i64//division)))
+## (/.install "%" (binary (product.uncurry _.remainder/2)))
+## (/.install "f64" (unary (_.//2 (_.float +1.0))))
+## (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1)))))
+## )))
+
+## (def: f64_procs
+## Bundle
+## (<| (/.prefix "f64")
+## (|> /.empty
+## (/.install "=" (binary (product.uncurry _.=/2)))
+## (/.install "<" (binary (product.uncurry _.</2)))
+## (/.install "+" (binary (product.uncurry _.+/2)))
+## (/.install "-" (binary (product.uncurry _.-/2)))
+## (/.install "*" (binary (product.uncurry _.*/2)))
+## (/.install "/" (binary (product.uncurry _.//2)))
+## (/.install "%" (binary (product.uncurry _.remainder/2)))
+## (/.install "i64" (unary _.truncate/1))
+## (/.install "encode" (unary _.number->string/1))
+## (/.install "decode" (unary //runtime.f64//decode)))))
+
+## (def: (text//index [offset sub text])
+## (Trinary Expression)
+## (//runtime.text//index offset sub text))
+
+## (def: (text//clip [paramO extraO subjectO])
+## (Trinary Expression)
+## (//runtime.text//clip paramO extraO subjectO))
+
+## (def: text_procs
+## Bundle
+## (<| (/.prefix "text")
+## (|> /.empty
+## (/.install "=" (binary (product.uncurry _.string=?/2)))
+## (/.install "<" (binary (product.uncurry _.string<?/2)))
+## (/.install "concat" (binary (product.uncurry _.string-append/2)))
+## (/.install "index" (trinary ..text//index))
+## (/.install "size" (unary _.string-length/1))
+## (/.install "char" (binary (product.uncurry //runtime.text//char)))
+## (/.install "clip" (trinary ..text//clip))
+## )))
+
+## (def: (io//log! message)
+## (Unary Expression)
+## (_.begin (list (_.display/1 message)
+## (_.display/1 (_.string text.new_line))
+## //runtime.unit)))
+
+## (def: io_procs
+## Bundle
+## (<| (/.prefix "io")
+## (|> /.empty
+## (/.install "log" (unary ..io//log!))
+## (/.install "error" (unary _.raise/1))
+## (/.install "current-time" (nullary (function.constant (//runtime.io//current_time //runtime.unit))))
+## )))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> /.empty
+ ## (dictionary.merge 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/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux
new file mode 100644
index 000000000..f6d164404
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux
@@ -0,0 +1,39 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" common_lisp (#+ Var Expression)]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" common_lisp #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "common_lisp")
+ (|> /.empty
+ )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux
deleted file mode 100644
index f3afe14a6..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux
+++ /dev/null
@@ -1,60 +0,0 @@
-(.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/language/lux/phase/generation/common-lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux
deleted file mode 100644
index 6953a9987..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux
+++ /dev/null
@@ -1,209 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- [monad (#+ do)]]
- [control
- ["ex" exception (#+ exception:)]]
- [data
- ["." text]
- [number
- ["n" nat]]
- [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: (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 (_.label "lux_pm_fail"))
-(def: @done (_.label "lux_pm_done"))
-
-(def: fail! (_.return-from ..@fail _.nil))
-
-(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))
- (_.progn (<| (_.block ..@fail)
- (_.progn ..save!)
- pre!)
- ($_ _.progn
- ..restore!
- post!)))
-
-(def: (pattern-matching' generate pathP)
- (-> Phase Path (Operation (Expression Any)))
- (.case pathP
- (^ (/////synthesis.path/then bodyS))
- (\ ////.monad map (_.return-from ..@done) (generate bodyS))
-
- #/////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])))
-
-(def: (pattern-matching generate pathP)
- (-> Phase Path (Operation (Expression Any)))
- (do ////.monad
- [pattern-matching! (pattern-matching' generate pathP)]
- (wrap (_.block ..@done
- (_.progn (_.block ..@fail
- pattern-matching!)
- (_.error/1 (_.string case.pattern-matching-error)))))))
-
-(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/language/lux/phase/generation/common-lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux
deleted file mode 100644
index d68f22ef0..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux
+++ /dev/null
@@ -1,93 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" common-lisp (#+ Expression)]]]
- ["." // #_
- [runtime (#+ Operation Phase)]
- ["#." reference]
- ["#." case]
- ["#/" //
- ["#." reference]
- ["#/" //
- ["." // #_
- [reference (#+ Register Variable)]
- [arity (#+ Arity)]
- [analysis (#+ Variant Tuple Environment 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.enumeration 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/language/lux/phase/generation/common-lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux
deleted file mode 100644
index bc214399e..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux
+++ /dev/null
@@ -1,42 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [number
- ["n" nat]]
- [text
- ["%" format (#+ 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 (|>> %.nat (format "scope") _.var) ///.next)
- initsG+ (monad.map ! generate initsS+)
- bodyG (///.with-anchor @scope
- (generate 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+])))))
-
-(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/language/lux/phase/generation/common-lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux
deleted file mode 100644
index 206f3f0e9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux
+++ /dev/null
@@ -1,10 +0,0 @@
-(.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/language/lux/phase/generation/common-lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux
deleted file mode 100644
index 2d9017bcb..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux
+++ /dev/null
@@ -1,288 +0,0 @@
-(.module:
- [lux (#- inc)
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]
- ["p" parser
- ["s" code]]]
- [data
- [number (#+ hex)
- ["." i64]]
- ["." text
- ["%" format (#+ 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 [(_.= last-index-right right-index)
- (_.elt/2 [tuple right-index])]
- [(_.> 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.
-(runtime: (sum//get sum wantsLast wantedTag)
- (with-vars [sum-tag sum-flag]
- (let [@exit (_.label "exit")
- return! (_.return-from @exit)
- no-match! (return! sum)
- sum-value (_.nth/2 [(_.int +2) sum])
- test-recursion! (_.if sum-flag
- ## Must iterate.
- ($_ _.progn
- (_.setq wantedTag (_.- 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 [(_.= sum-tag wantedTag)
- (_.if (_.equal wantsLast sum-flag)
- (return! sum-value)
- test-recursion!)]
-
- [(_.> sum-tag wantedTag)
- test-recursion!]
-
- [(_.and (_.< sum-tag wantedTag)
- wantsLast)
- (return! (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
- [_ (///.execute! ..runtime)
- _ (///.save! ..prefix ..runtime)]
- (///.save-buffer! ..artifact))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux
deleted file mode 100644
index 45241a601..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(.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/language/lux/phase/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux
new file mode 100644
index 000000000..7b81d9d4a
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux
@@ -0,0 +1,56 @@
+(.module:
+ [lux #*
+ [abstract
+ [monad (#+ do)]]]
+ ["." / #_
+ [runtime (#+ Phase)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: #export (generate archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> generate archive value)])
+ ([////synthesis.variant /structure.variant]
+ [////synthesis.tuple /structure.tuple]
+ [////synthesis.branch/let /case.let]
+ [////synthesis.branch/if /case.if]
+ [////synthesis.branch/get /case.get]
+ [////synthesis.function/apply /function.apply]
+
+ [////synthesis.branch/case /case.case]
+ [////synthesis.loop/scope /loop.scope]
+ [////synthesis.loop/recur /loop.recur]
+ [////synthesis.function/abstraction /function.function])
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive generate extension)
+ ))
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
new file mode 100644
index 000000000..252532489
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
@@ -0,0 +1,241 @@
+(.module:
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" common_lisp (#+ Expression Var/1)]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register Var/1)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register Var/1)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueG (expression archive valueS)
+ bodyG (expression archive bodyS)]
+ (wrap (_.let (list [(..register register) valueG])
+ bodyG))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testG (expression archive testS)
+ thenG (expression archive thenS)
+ elseG (expression archive elseS)]
+ (wrap (_.if testG thenG elseG))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueG (expression archive 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: @savepoint (_.var "lux_pm_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+(def: @variant (_.var "lux_pm_variant"))
+
+(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 (_.label "lux_pm_fail"))
+(def: @done (_.label "lux_pm_done"))
+
+(def: fail! (_.return-from ..@fail _.nil))
+
+(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))
+ (_.progn (<| (_.block ..@fail)
+ (_.progn ..save!)
+ pre!)
+ ($_ _.progn
+ ..restore!
+ post!)))
+
+(def: (pattern_matching' expression archive)
+ (Generator Path)
+ (function (recur pathP)
+ (.case pathP
+ (^ (/////synthesis.path/then bodyS))
+ (\ ///////phase.monad map (_.return-from ..@done) (expression archive bodyS))
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.setq (..register register) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format> <=>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur then)]
+ (wrap [(<=> (|> match <format>)
+ ..peek)
+ then!])))
+ (#.Cons cons))]
+ (wrap (list\fold (function (_ [when then] else)
+ (_.if when then else))
+ ..fail!
+ clauses)))])
+ ([#/////synthesis.I64_Fork //primitive.i64 _.=]
+ [#/////synthesis.F64_Fork //primitive.f64 _.=]
+ [#/////synthesis.Text_Fork //primitive.text _.string=])
+
+ (^template [<complex> <simple> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> false idx))
+
+ (^ (<simple> idx nextP))
+ (|> nextP
+ recur
+ (\ ///////phase.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))
+ (///////phase\wrap (..push! (_.elt/2 [..peek (_.int +0)])))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\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'] (////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]))))
+
+(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)))))))
+
+(def: #export (case expression archive [valueS pathP])
+ (Generator [Synthesis Path])
+ (do ///////phase.monad
+ [initG (expression archive valueS)
+ pattern_matching! (pattern_matching expression archive pathP)]
+ (wrap (_.let (list [@cursor (_.list/* (list initG))]
+ [@savepoint (_.list/* (list))]
+ [@temp _.nil])
+ pattern_matching!))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux
index 3bc0a0887..3bc0a0887 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux
index 750688dd6..750688dd6 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux
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
new file mode 100644
index 000000000..7f4134c86
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
@@ -0,0 +1,97 @@
+(.module:
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" common_lisp (#+ Expression Var/1)]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionG (expression archive functionS)
+ argsG+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.funcall/+ [functionG argsG+]))))
+
+(def: capture
+ (-> Register Var/1)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure inits function_definition)
+ (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any)))
+ (case inits
+ #.Nil
+ (\ ///////phase.monad wrap function_definition)
+
+ _
+ (do {! ///////phase.monad}
+ [@closure (\ ! map _.var (/////generation.gensym "closure"))]
+ (wrap (_.labels (list [@closure [(|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture))
+ _.args)
+ function_definition]])
+ (_.funcall/+ [(_.function/1 @closure) inits]))))))
+
+(def: input
+ (|>> inc //case.register))
+
+(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))))
+ closureG+ (monad.map ! (expression archive) environment)
+ #let [@curried (_.var "curried")
+ @missing (_.var "missing")
+ arityG (|> arity .int _.int)
+ @num_args (_.var "num_args")
+ @self (_.var (///reference.artifact function_name))
+ initialize_self! [(//case.register 0) (_.function/1 @self)]
+ initialize! [(|> (list.indices arity)
+ (list\map ..input)
+ _.args)
+ @curried]]]
+ (with_closure 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/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
new file mode 100644
index 000000000..32275cdc3
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
@@ -0,0 +1,53 @@
+(.module:
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" common_lisp (#+ Expression)]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["."synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: #export (scope expression archive [start initsS+ bodyS])
+ (Generator (Scope Synthesis))
+ (do {! ///////phase.monad}
+ [@scope (\ ! map (|>> %.nat (format "scope") _.var) /////generation.next)
+ initsG+ (monad.map ! (expression archive) initsS+)
+ bodyG (/////generation.with_anchor @scope
+ (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+])))))
+
+(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+))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux
index 4177f814a..7840ccccc 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux
@@ -2,11 +2,8 @@
[lux (#- i64)
[control
[pipe (#+ cond> new>)]]
- [data
- [number
- ["." frac]]]
[target
- ["_" common-lisp (#+ Expression)]]]
+ ["_" common_lisp (#+ Expression)]]]
["." // #_
["#." runtime]])
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux
new file mode 100644
index 000000000..977396fab
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux
@@ -0,0 +1,12 @@
+(.module:
+ [lux #*
+ [target
+ ["_" common_lisp (#+ Expression)]]]
+ [///
+ [reference (#+ System)]])
+
+(structure: #export system
+ (System (Expression Any))
+
+ (def: constant _.var)
+ (def: variable _.var))
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
new file mode 100644
index 000000000..3ac79fa7d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
@@ -0,0 +1,305 @@
+(.module:
+ [lux (#- Location inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ ["." encoding]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ ["@" target
+ ["_" common_lisp (#+ Expression Var/1 Computation Literal)]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant)]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(def: module_id
+ 0)
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> Var/1 (Expression Any) (Expression Any)))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation (Expression Any))))
+
+(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 [lefts right? value])
+ (-> (Variant (Expression Any)) (Computation Any))
+ (variant' (_.int (.int lefts)) (flag right?) value))
+
+(def: #export none
+ (Computation Any)
+ (|> ..unit [0 #0] ..variant))
+
+(def: #export some
+ (-> (Expression Any) (Computation Any))
+ (|>> [1 #1] ..variant))
+
+(def: #export left
+ (-> (Expression Any) (Computation Any))
+ (|>> [0 #0] ..variant))
+
+(def: #export right
+ (-> (Expression Any) (Computation Any))
+ (|>> [1 #1] ..variant))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (let [g!name (code.local_identifier name)
+ code_nameC (code.local_identifier (format "@" name))]
+ (wrap (list (` (def: #export (~ g!name)
+ _.Var/1
+ (~ runtime_name)))
+
+ (` (def: (~ code_nameC)
+ (_.Expression Any)
+ (_.defparameter (~ runtime_name) (~ code)))))))
+
+ (#.Right [name inputs])
+ (let [g!name (code.local_identifier name)
+ code_nameC (code.local_identifier (format "@" name))
+
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` (_.Expression Any)))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) (_.Computation Any))
+ (_.call/* (~ runtime_name) (list (~+ inputsC)))))
+
+ (` (def: (~ code_nameC)
+ (_.Expression Any)
+ (..with_vars [(~+ inputsC)]
+ (_.defun (~ runtime_name) (_.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 [(_.= last_index_right right_index)
+ (_.elt/2 [tuple right_index])]
+ [(_.> 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.
+(runtime: (sum//get sum wantsLast wantedTag)
+ (with_vars [sum_tag sum_flag]
+ (let [@exit (_.label "exit")
+ return! (_.return-from @exit)
+ no_match! (return! sum)
+ sum_value (_.nth/2 [(_.int +2) sum])
+ test_recursion! (_.if sum_flag
+ ## Must iterate.
+ ($_ _.progn
+ (_.setq wantedTag (_.- 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 [(_.= sum_tag wantedTag)
+ (_.if (_.equal wantsLast sum_flag)
+ (return! sum_value)
+ test_recursion!)]
+
+ [(_.> sum_tag wantedTag)
+ test_recursion!]
+
+ [(_.and (_.< sum_tag wantedTag)
+ wantsLast)
+ (return! (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 generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! (%.nat ..module_id) ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [(%.nat ..module_id)
+ (|> ..runtime
+ _.code
+ (\ encoding.utf8 encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux
new file mode 100644
index 000000000..566fc148e
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux
@@ -0,0 +1,36 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [target
+ ["_" common_lisp (#+ Expression)]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple expression archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (expression archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (expression archive))
+ (///////phase\map _.vector/*))))
+
+(def: #export (variant expression archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (|>> [tag right?] //runtime.variant)
+ (expression archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
index 815b5a8a5..f27dc1154 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
@@ -79,31 +79,29 @@
runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
(case declaration
(#.Left name)
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name)
- Var
- (~ runtime_name)))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- _.Computation
- (_.define_constant (~ runtime_name) (~ code))))))))
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name)
+ Var
+ (~ runtime_name)))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ _.Computation
+ (_.define_constant (~ runtime_name) (~ code)))))))
(#.Right [name inputs])
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) _.Computation)
- (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- _.Computation
- (..with_vars [(~+ inputsC)]
- (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None]
- (~ code))))))))))))))
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) _.Computation)
+ (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ _.Computation
+ (..with_vars [(~+ inputsC)]
+ (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None]
+ (~ code)))))))))))))
(def: last_index
(-> Expression Computation)