aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2021-05-25 01:55:09 -0400
committerEduardo Julian2021-05-25 01:55:09 -0400
commit2df8e4bc8c53a831f3cd8605707ca08d66cecb02 (patch)
tree839af4a3c1b2c1629946111d58373946d367becc
parentf01e246f468c948d41423248809443570f48c7a4 (diff)
Updates for Common-Lisp compiler.
-rw-r--r--compilers.md24
-rw-r--r--lux-cl/commands.md23
-rw-r--r--lux-cl/source/program.lux476
-rw-r--r--lux-scheme/source/program.lux70
-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
28 files changed, 1489 insertions, 1063 deletions
diff --git a/compilers.md b/compilers.md
index 7a9afdc4c..5494eafd4 100644
--- a/compilers.md
+++ b/compilers.md
@@ -1,27 +1,3 @@
-# Common Lisp compiler
-
-## Test
-
-```
-cd ~/lux/lux-cl/ && lein lux auto test
-cd ~/lux/lux-cl/ && lein clean && lein lux auto test
-```
-
-## Build
-
-```
-cd ~/lux/lux-cl/ && lein lux auto build
-cd ~/lux/lux-cl/ && lein clean && lein lux auto build
-```
-
-## Try
-
-```
-cd ~/lux/lux-cl/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux
-```
-
----
-
# R compiler
## Test
diff --git a/lux-cl/commands.md b/lux-cl/commands.md
new file mode 100644
index 000000000..baefd65b7
--- /dev/null
+++ b/lux-cl/commands.md
@@ -0,0 +1,23 @@
+# Common Lisp compiler
+
+## Test
+
+```
+cd ~/lux/lux-cl/ && lein lux auto test
+cd ~/lux/lux-cl/ && lein clean && lein lux auto test
+```
+
+## Build
+
+```
+## Develop
+cd ~/lux/lux-cl/ \
+&& lein clean \
+&& lein lux auto build
+```
+
+## Try
+
+```
+cd ~/lux/lux-cl/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux
+```
diff --git a/lux-cl/source/program.lux b/lux-cl/source/program.lux
index 8d6218297..89b2b937c 100644
--- a/lux-cl/source/program.lux
+++ b/lux-cl/source/program.lux
@@ -1,116 +1,151 @@
(.module:
[lux #*
- ["." host (#+ import: interface: do-to object)]
+ [program (#+ program:)]
+ ["." ffi]
+ ["." debug]
[abstract
- [monad (#+ do)]]
+ ["." monad (#+ do)]]
[control
- [pipe (#+ new> case>)]
+ [pipe (#+ exec> case> new>)]
+ ["." try (#+ Try)]
["." exception (#+ exception:)]
["." io (#+ IO io)]
- [parser
- [cli (#+ program:)]]]
+ [concurrency
+ ["." promise (#+ Promise)]]]
[data
["." maybe]
- ["." error (#+ Error)]
- [number
- ["." i64]]
- ["." text ("#/." hash)
- format]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ ["." encoding]]
[collection
- ["." array (#+ Array)]
- ["." list ("#/." functor)]]]
+ ["." array (#+ Array)]]]
[macro
["." template]]
- [world
- ["." file]]
- ["." debug]
- [target
- ["_" common-lisp]]
+ [math
+ [number (#+ hex)
+ ["n" nat]
+ ["." i64]]]
+ ["." world #_
+ ["." file]
+ ["#/." program]]
+ ["@" target
+ ["_" common_lisp]]
[tool
[compiler
- ["." name]
- ["." synthesis]
- [phase
- [macro (#+ Expander)]
- ["." generation
- ["." common-lisp
- ["." runtime]
- ["." extension]]]]
+ [phase (#+ Operation Phase)]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ [program (#+ Program)]
+ [generation (#+ Context Host)]
+ ["." synthesis]
+ [analysis
+ [macro (#+ Expander)]]
+ [phase
+ ["." extension (#+ Extender Handler)
+ ["#/." bundle]
+ ["." analysis #_
+ ["#" common_lisp]]
+ ["." generation #_
+ ["#" common_lisp]]]
+ [generation
+ ["." reference]
+ ["." common_lisp
+ ["." runtime]]]]]]
[default
- ["." platform (#+ Platform)]]]]]
+ ["." platform (#+ Platform)]]
+ [meta
+ ["." packager #_
+ ["#" script]]]]]]
[program
["/" compositor
- ["/." cli]]])
-
-(import: #long java/lang/String)
-
-(import: #long (java/lang/Class a)
- (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object)))
-
-(import: #long java/lang/Object
- (toString [] java/lang/String)
- (getClass [] (java/lang/Class java/lang/Object)))
-
-(import: #long java/lang/Long
- (intValue [] java/lang/Integer))
-
-(import: #long java/lang/Integer
- (longValue [] long))
-
-(import: #long java/lang/Number
- (intValue [] java/lang/Integer)
- (longValue [] long)
- (doubleValue [] double))
-
-(import: #long org/armedbear/lisp/LispObject
- (length [] int)
- (NTH [int] org/armedbear/lisp/LispObject)
- (SVREF [int] org/armedbear/lisp/LispObject)
- (elt [int] org/armedbear/lisp/LispObject)
- (execute [org/armedbear/lisp/LispObject org/armedbear/lisp/LispObject] #try org/armedbear/lisp/LispObject))
+ ["#." cli]
+ ["#." static]]])
+
+(ffi.import: java/lang/String)
+
+(ffi.import: (java/lang/Class a)
+ ["#::."
+ (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))])
+
+(ffi.import: java/lang/Object
+ ["#::."
+ (toString [] java/lang/String)
+ (getClass [] (java/lang/Class java/lang/Object))])
+
+(ffi.import: java/lang/Long
+ ["#::."
+ (intValue [] java/lang/Integer)])
+
+(ffi.import: java/lang/Integer
+ ["#::."
+ (longValue [] long)])
+
+(ffi.import: java/lang/Number
+ ["#::."
+ (intValue [] java/lang/Integer)
+ (longValue [] long)
+ (doubleValue [] double)])
+
+(ffi.import: org/armedbear/lisp/LispObject
+ ["#::."
+ (length [] int)
+ (NTH [int] org/armedbear/lisp/LispObject)
+ (SVREF [int] org/armedbear/lisp/LispObject)
+ (elt [int] org/armedbear/lisp/LispObject)
+ (execute [org/armedbear/lisp/LispObject org/armedbear/lisp/LispObject] #try org/armedbear/lisp/LispObject)])
## The org/armedbear/lisp/Interpreter must be imported before the
## other ones, because there is an order dependency in their static initialization.
-(import: #long org/armedbear/lisp/Interpreter
- (#static getInstance [] org/armedbear/lisp/Interpreter)
- (#static createInstance [] #? org/armedbear/lisp/Interpreter)
- (eval [java/lang/String] #try org/armedbear/lisp/LispObject))
+(ffi.import: org/armedbear/lisp/Interpreter
+ ["#::."
+ (#static getInstance [] org/armedbear/lisp/Interpreter)
+ (#static createInstance [] #? org/armedbear/lisp/Interpreter)
+ (eval [java/lang/String] #try org/armedbear/lisp/LispObject)])
-(import: #long org/armedbear/lisp/Symbol
- (#static T org/armedbear/lisp/Symbol))
+(ffi.import: org/armedbear/lisp/Symbol
+ ["#::."
+ (#static T org/armedbear/lisp/Symbol)])
-(import: #long org/armedbear/lisp/DoubleFloat
- (new [double])
- (doubleValue [] double))
+(ffi.import: org/armedbear/lisp/DoubleFloat
+ ["#::."
+ (new [double])
+ (doubleValue [] double)])
-(import: #long org/armedbear/lisp/SimpleString
- (new [java/lang/String])
- (getStringValue [] java/lang/String))
+(ffi.import: org/armedbear/lisp/SimpleString
+ ["#::."
+ (new [java/lang/String])
+ (getStringValue [] java/lang/String)])
-(import: #long org/armedbear/lisp/LispInteger)
+(ffi.import: org/armedbear/lisp/LispInteger)
-(import: #long org/armedbear/lisp/Bignum
- (longValue [] long)
- (#static getInstance [long] org/armedbear/lisp/LispInteger))
+(ffi.import: org/armedbear/lisp/Bignum
+ ["#::."
+ (longValue [] long)
+ (#static getInstance [long] org/armedbear/lisp/LispInteger)])
-(import: #long org/armedbear/lisp/Fixnum
- (longValue [] long)
- (#static getInstance [int] org/armedbear/lisp/Fixnum))
+(ffi.import: org/armedbear/lisp/Fixnum
+ ["#::."
+ (longValue [] long)
+ (#static getInstance [int] org/armedbear/lisp/Fixnum)])
-(import: #long org/armedbear/lisp/Nil
- (#static NIL org/armedbear/lisp/Symbol))
+(ffi.import: org/armedbear/lisp/Nil
+ ["#::."
+ (#static NIL org/armedbear/lisp/Symbol)])
-(import: #long org/armedbear/lisp/SimpleVector)
+(ffi.import: org/armedbear/lisp/SimpleVector)
-(import: #long org/armedbear/lisp/Cons)
+(ffi.import: org/armedbear/lisp/Cons)
-(import: #long org/armedbear/lisp/Closure)
+(ffi.import: org/armedbear/lisp/Closure)
-(interface: LuxADT
+(ffi.interface: LuxADT
(getValue [] java/lang/Object))
-(import: #long program/LuxADT
- (getValue [] java/lang/Object))
+(ffi.import: program/LuxADT
+ ["#::."
+ (getValue [] java/lang/Object)])
(template [<name>]
[(exception: (<name> {object java/lang/Object})
@@ -118,44 +153,44 @@
["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
["Object" (java/lang/Object::toString object)]))]
- [unknown-kind-of-object]
- [cannot-apply-a-non-function]
+ [unknown_kind_of_object]
+ [cannot_apply_a_non_function]
)
-(def: host-bit
+(def: host_bit
(-> Bit org/armedbear/lisp/LispObject)
(|>> (case> #0 (org/armedbear/lisp/Nil::NIL)
#1 (org/armedbear/lisp/Symbol::T))))
-(def: (host-value value)
+(def: (host_value value)
(-> Any org/armedbear/lisp/LispObject)
- (let [to-sub (: (-> Any org/armedbear/lisp/LispObject)
- (function (_ sub-value)
- (let [sub-value (:coerce java/lang/Object sub-value)]
+ (let [to_sub (: (-> Any org/armedbear/lisp/LispObject)
+ (function (_ sub_value)
+ (let [sub_value (:coerce java/lang/Object sub_value)]
(`` (<| (~~ (template [<type> <then>]
- [(case (host.check <type> sub-value)
- (#.Some sub-value)
- (`` (|> sub-value (~~ (template.splice <then>))))
+ [(case (ffi.check <type> sub_value)
+ (#.Some sub_value)
+ (`` (|> sub_value (~~ (template.splice <then>))))
#.None)]
- [[java/lang/Object] [host-value]]
- [java/lang/Boolean [..host-bit]]
+ [[java/lang/Object] [host_value]]
+ [java/lang/Boolean [..host_bit]]
[java/lang/Integer [java/lang/Integer::longValue org/armedbear/lisp/Fixnum::getInstance]]
[java/lang/Long [org/armedbear/lisp/Bignum::getInstance]]
[java/lang/Double [org/armedbear/lisp/DoubleFloat::new]]
[java/lang/String [org/armedbear/lisp/SimpleString::new]]
))
## else
- (:coerce org/armedbear/lisp/LispObject sub-value))))))]
- (`` (object [] org/armedbear/lisp/LispObject [program/LuxADT]
+ (:coerce org/armedbear/lisp/LispObject sub_value))))))]
+ (`` (ffi.object [] org/armedbear/lisp/LispObject [program/LuxADT]
[]
## Methods
(program/LuxADT
- (getValue) java/lang/Object
+ [] (getValue self) java/lang/Object
(:coerce java/lang/Object value))
(org/armedbear/lisp/LispObject
- (length)
+ [] (length self)
int
(|> value
(:coerce (Array java/lang/Object))
@@ -165,12 +200,12 @@
(~~ (template [<name>]
[(org/armedbear/lisp/LispObject
- (<name> {idx int})
+ [] (<name> self {idx int})
org/armedbear/lisp/LispObject
(case (array.read (|> idx java/lang/Integer::longValue (:coerce Nat))
(:coerce (Array java/lang/Object) value))
(#.Some sub)
- (to-sub sub)
+ (to_sub sub)
#.None
(org/armedbear/lisp/Nil::NIL)))]
@@ -180,128 +215,135 @@
))))
(type: (Reader a)
- (-> a (Error Any)))
+ (-> a (Try Any)))
-(def: (read-variant read host-object)
+(def: (read_variant read host_object)
(-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/Cons))
- (do error.monad
- [tag (read (org/armedbear/lisp/LispObject::NTH +0 host-object))
- value (read (org/armedbear/lisp/LispObject::NTH +2 host-object))]
+ (do try.monad
+ [tag (read (org/armedbear/lisp/LispObject::NTH +0 host_object))
+ value (read (org/armedbear/lisp/LispObject::NTH +2 host_object))]
(wrap [(java/lang/Long::intValue (:coerce java/lang/Long tag))
- (case (host.check org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host-object))
+ (case (ffi.check org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host_object))
(#.Some _)
- (: Any (host.null))
+ (: Any (ffi.null))
_
(: Any synthesis.unit))
value])))
-(def: (read-tuple read host-object)
+(def: (read_tuple read host_object)
(-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/SimpleVector))
- (let [size (.nat (org/armedbear/lisp/LispObject::length host-object))]
+ (let [size (.nat (org/armedbear/lisp/LispObject::length host_object))]
(loop [idx 0
output (:coerce (Array Any) (array.new size))]
- (if (n/< size idx)
+ (if (n.< size idx)
## TODO: Start using "SVREF" instead of "elt" ASAP
- (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host-object))
- (#error.Failure error)
- (#error.Failure error)
+ (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host_object))
+ (#try.Failure error)
+ (#try.Failure error)
- (#error.Success member)
- (recur (inc idx) (array.write idx (:coerce Any member) output)))
- (#error.Success output)))))
+ (#try.Success member)
+ (recur (inc idx) (array.write! idx (:coerce Any member) output)))
+ (#try.Success output)))))
-(def: (read host-object)
+(def: (read host_object)
(Reader org/armedbear/lisp/LispObject)
- (`` (<| (~~ (template [<class> <post-processing>]
- [(case (host.check <class> host-object)
- (#.Some host-object)
- (`` (|> host-object (~~ (template.splice <post-processing>))))
+ (`` (<| (~~ (template [<class> <post_processing>]
+ [(case (ffi.check <class> host_object)
+ (#.Some host_object)
+ (`` (|> host_object (~~ (template.splice <post_processing>))))
#.None)]
- [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue #error.Success]]
- [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue #error.Success]]
- [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #error.Success]]
- [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue #error.Success]]
- [org/armedbear/lisp/Cons [(read-variant read)]]
- [org/armedbear/lisp/SimpleVector [(read-tuple read)]]
- [org/armedbear/lisp/Nil [(new> (#error.Success false) [])]]
- [org/armedbear/lisp/Closure [#error.Success]]
- [program/LuxADT [program/LuxADT::getValue #error.Success]]))
- (case (host.check org/armedbear/lisp/Symbol host-object)
- (#.Some host-object)
- (if (is? (org/armedbear/lisp/Symbol::T) host-object)
- (#error.Success true)
- (exception.throw unknown-kind-of-object (:coerce java/lang/Object host-object)))
+ [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue #try.Success]]
+ [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue #try.Success]]
+ [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #try.Success]]
+ [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue #try.Success]]
+ [org/armedbear/lisp/Cons [(read_variant read)]]
+ [org/armedbear/lisp/SimpleVector [(read_tuple read)]]
+ [org/armedbear/lisp/Nil [(new> (#try.Success false) [])]]
+ [org/armedbear/lisp/Closure [#try.Success]]
+ [program/LuxADT [program/LuxADT::getValue #try.Success]]))
+ (case (ffi.check org/armedbear/lisp/Symbol host_object)
+ (#.Some host_object)
+ (if (is? (org/armedbear/lisp/Symbol::T) host_object)
+ (#try.Success true)
+ (exception.throw ..unknown_kind_of_object (:coerce java/lang/Object host_object)))
#.None)
## else
- (exception.throw unknown-kind-of-object (:coerce java/lang/Object host-object))
+ (exception.throw ..unknown_kind_of_object (:coerce java/lang/Object host_object))
)))
-(def: ensure-macro
+(def: ensure_macro
(-> Macro (Maybe org/armedbear/lisp/Closure))
- (|>> (:coerce java/lang/Object) (host.check org/armedbear/lisp/Closure)))
+ (|>> (:coerce java/lang/Object) (ffi.check org/armedbear/lisp/Closure)))
-(def: (call-macro inputs lux macro)
- (-> (List Code) Lux org/armedbear/lisp/Closure (Error (Error [Lux (List Code)])))
- (do error.monad
- [raw-output (org/armedbear/lisp/LispObject::execute (..host-value inputs) (..host-value lux) macro)]
- (:coerce (Error (Error [Lux (List Code)]))
- (..read raw-output))))
+(def: (call_macro inputs lux macro)
+ (-> (List Code) Lux org/armedbear/lisp/Closure (Try (Try [Lux (List Code)])))
+ (do try.monad
+ [raw_output (org/armedbear/lisp/LispObject::execute (..host_value inputs) (..host_value lux) macro)]
+ (:coerce (Try (Try [Lux (List Code)]))
+ (..read raw_output))))
(def: (expander macro inputs lux)
Expander
- (case (ensure-macro macro)
+ (case (ensure_macro macro)
(#.Some macro)
- (call-macro inputs lux macro)
+ (call_macro inputs lux macro)
#.None
- (exception.throw cannot-apply-a-non-function (:coerce java/lang/Object macro))))
-
-(def: separator "$")
-
-(type: Host
- (generation.Host (_.Expression Any) (_.Expression Any)))
+ (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))))
(def: host
- (IO Host)
+ (IO (Host (_.Expression Any) (_.Expression Any)))
(io (let [_ (org/armedbear/lisp/Interpreter::createInstance)
- interpreter (org/armedbear/lisp/Interpreter::getInstance)]
- (: Host
+ interpreter (org/armedbear/lisp/Interpreter::getInstance)
+ run! (: (-> (_.Code Any) (Try Any))
+ (function (_ code)
+ (do try.monad
+ [host_value (org/armedbear/lisp/Interpreter::eval (_.code code) interpreter)]
+ (read host_value))))]
+ (: (Host (_.Expression Any) (_.Expression Any))
(structure
- (def: (evaluate! alias input)
- (do error.monad
- [host-value (org/armedbear/lisp/Interpreter::eval (_.code input) interpreter)]
- (read host-value)))
+ (def: (evaluate! context code)
+ (run! code))
- (def: (execute! alias input)
+ (def: (execute! input)
(org/armedbear/lisp/Interpreter::eval (_.code input) interpreter))
- (def: (define! [module name] input)
- (let [global (format (text.replace-all .module-separator ..separator module)
- ..separator (name.normalize name)
- "___" (%n (text/hash name)))
+ (def: (define! context input)
+ (let [global (reference.artifact context)
@global (_.var global)]
- (do error.monad
+ (do try.monad
[#let [definition (_.defparameter @global input)]
_ (org/armedbear/lisp/Interpreter::eval (_.code definition) interpreter)
- host-value (org/armedbear/lisp/Interpreter::eval (_.code @global) interpreter)
- lux-value (read host-value)]
- (wrap [global lux-value definition])))))))))
+ value (run! @global)]
+ (wrap [global value definition]))))
+
+ (def: (ingest context content)
+ (|> content (\ encoding.utf8 decode) try.assume (:coerce (_.Expression Any))))
+
+ (def: (re_learn context content)
+ (run! content))
+
+ (def: (re_load context content)
+ (do try.monad
+ [_ (run! content)]
+ (run! (_.var (reference.artifact context)))))
+ )))))
(def: platform
- (IO (Platform IO _.Var/1 (_.Expression Any) (_.Expression Any)))
+ (IO (Platform _.Var/1 (_.Expression Any) (_.Expression Any)))
(do io.monad
[host ..host]
- (wrap {#platform.&monad io.monad
- #platform.&file-system file.system
+ (wrap {#platform.&file_system (file.async file.default)
#platform.host host
- #platform.phase common-lisp.generate
- #platform.runtime runtime.generate})))
+ #platform.phase common_lisp.generate
+ #platform.runtime runtime.generate
+ #platform.write (|>> _.code (\ encoding.utf8 encode))})))
-(def: get-ecl-cli-inputs
+(def: get_ecl_cli_inputs
(let [@idx (_.var "i")]
(_.call/* (_.var "loop")
(list (_.var "for") @idx
@@ -309,23 +351,87 @@
(_.var "below") (_.call/* (_.var "si:argc") (list))
(_.var "collect") (_.call/* (_.var "si:argv") (list @idx))))))
-(def: program
- (-> (_.Expression Any) (_.Expression Any))
- (let [raw-inputs ($_ _.progn
+(def: (program context program)
+ (Program (_.Expression Any) (_.Expression Any))
+ (let [raw_inputs ($_ _.progn
(_.conditional+ (list "clisp") (_.var "ext:*args*"))
(_.conditional+ (list "sbcl") (_.var "sb-ext:*posix-argv*"))
(_.conditional+ (list "clozure") (_.call/* (_.var "ccl::command-line-arguments") (list)))
(_.conditional+ (list "gcl") (_.var "si:*command-args*"))
- (_.conditional+ (list "ecl") ..get-ecl-cli-inputs)
+ (_.conditional+ (list "ecl") ..get_ecl_cli_inputs)
(_.conditional+ (list "cmu") (_.var "extensions:*command-line-strings*"))
(_.conditional+ (list "allegro") (_.call/* (_.var "sys:command-line-arguments") (list)))
(_.conditional+ (list "lispworks") (_.var "sys:*line-arguments-list*"))
(_.list/* (list)))]
- (|>> (_.call/2 [(runtime.lux//program-args raw-inputs) _.nil]))))
-
-(program: [{service /cli.service}]
- (/.compiler ..expander
- ..platform
- extension.bundle
- ..program
- service))
+ (_.call/2 [(runtime.lux//program_args raw_inputs) _.nil] program)))
+
+(for {@.old
+ (def: extender
+ Extender
+ ## TODO: Stop relying on coercions ASAP.
+ (<| (:coerce Extender)
+ (function (@self handler))
+ (:coerce Handler)
+ (function (@self name phase))
+ (:coerce Phase)
+ (function (@self archive parameters))
+ (:coerce Operation)
+ (function (@self state))
+ (:coerce Try)
+ try.assume
+ (:coerce Try)
+ (exec
+ ("lux io log" "TODO: Extender")
+ (#try.Failure "TODO: Extender"))))
+
+ @.common_lisp
+ (def: (extender handler)
+ Extender
+ (:assume handler))})
+
+(def: (declare_success! _)
+ (-> Any (Promise Any))
+ (promise.future (\ world/program.default exit +0)))
+
+(def: (then pre post)
+ (-> (_.Expression Any) (_.Expression Any) (_.Expression Any))
+ (_.manual (format (_.code pre)
+ text.new_line
+ (_.code post))))
+
+(def: (scope body)
+ (-> (_.Expression Any) (_.Expression Any))
+ (let [@program (_.var "lux_program")]
+ ($_ ..then
+ (_.defun @program (_.args (list)) body)
+ (_.call/* @program (list))
+ )))
+
+(`` (program: [{service /cli.service}]
+ (let [extension ".cl"]
+ (do io.monad
+ [platform ..platform]
+ (exec (do promise.monad
+ [_ (/.compiler {#/static.host @.common_lisp
+ #/static.host_module_extension extension
+ #/static.target (/cli.target service)
+ #/static.artifact_extension extension}
+ ..expander
+ analysis.bundle
+ (io.io platform)
+ generation.bundle
+ extension/bundle.empty
+ ..program
+ [_.Var _.Expression _.Expression]
+ ..extender
+ service
+ [(packager.package (_.manual "")
+ _.code
+ ..then
+ ..scope)
+ (format (/cli.target service)
+ (\ file.default separator)
+ "program"
+ extension)])]
+ (..declare_success! []))
+ (io.io []))))))
diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux
index e318c6abd..24d26945d 100644
--- a/lux-scheme/source/program.lux
+++ b/lux-scheme/source/program.lux
@@ -1,7 +1,7 @@
(.module:
[lux #*
[program (#+ program:)]
- ["." host]
+ ["." ffi]
["." debug]
[abstract
["." monad (#+ do)]]
@@ -63,82 +63,82 @@
["#." cli]
["#." static]]])
-(host.import: java/lang/Boolean)
-(host.import: java/lang/String)
+(ffi.import: java/lang/Boolean)
+(ffi.import: java/lang/String)
-(host.import: (java/lang/Class a))
+(ffi.import: (java/lang/Class a))
-(host.import: java/lang/Object
+(ffi.import: java/lang/Object
["#::."
(toString [] java/lang/String)
(getClass [] (java/lang/Class java/lang/Object))])
-(host.import: java/lang/Long
+(ffi.import: java/lang/Long
["#::."
(intValue [] java/lang/Integer)])
-(host.import: java/lang/Integer
+(ffi.import: java/lang/Integer
["#::."
(longValue [] java/lang/Long)])
-(host.import: gnu/math/IntNum
+(ffi.import: gnu/math/IntNum
["#::."
(new #manual [int])
(longValue [] long)])
-(host.import: gnu/math/DFloNum
+(ffi.import: gnu/math/DFloNum
["#::."
(doubleValue [] double)])
-(host.import: gnu/lists/FString
+(ffi.import: gnu/lists/FString
["#::."
(toString [] String)])
-(host.import: gnu/lists/IString
+(ffi.import: gnu/lists/IString
["#::."
(toString [] String)])
-(host.import: gnu/lists/Pair
+(ffi.import: gnu/lists/Pair
["#::."
(getCar [] java/lang/Object)
(getCdr [] java/lang/Object)])
-(host.import: gnu/lists/EmptyList
+(ffi.import: gnu/lists/EmptyList
["#::."
(#static emptyList gnu/lists/EmptyList)])
-(host.import: (gnu/lists/FVector E)
+(ffi.import: (gnu/lists/FVector E)
["#::."
(getBufferLength [] int)
(getRaw [int] E)])
-(host.import: gnu/lists/U8Vector)
+(ffi.import: gnu/lists/U8Vector)
-(host.import: gnu/mapping/Procedure
+(ffi.import: gnu/mapping/Procedure
["#::."
(apply2 [java/lang/Object java/lang/Object] #try java/lang/Object)
(applyN [[java/lang/Object]] #try java/lang/Object)])
-(host.import: gnu/mapping/Environment)
+(ffi.import: gnu/mapping/Environment)
-(host.import: gnu/expr/Language
+(ffi.import: gnu/expr/Language
["#::."
(eval [java/lang/String] #try java/lang/Object)])
-(host.import: kawa/standard/Scheme
+(ffi.import: kawa/standard/Scheme
["#::."
(#static getR7rsInstance [] kawa/standard/Scheme)])
(def: (variant? value)
(-> Any Bit)
- (case (host.check [java/lang/Object] (:coerce java/lang/Object value))
+ (case (ffi.check [java/lang/Object] (:coerce java/lang/Object value))
(#.Some array)
## TODO: Get rid of this coercion ASAP.
(let [array (:coerce (Array java/lang/Object) array)]
(and (n.= 3 (array.size array))
(case (array.read 0 array)
(#.Some tag)
- (case (host.check java/lang/Integer tag)
+ (case (ffi.check java/lang/Integer tag)
(#.Some _)
true
@@ -152,10 +152,10 @@
false))
(template [<name>]
- [(host.interface: <name>
+ [(ffi.interface: <name>
(getValue [] java/lang/Object))
- (`` (host.import: (~~ (template.identifier ["program/" <name>]))
+ (`` (ffi.import: (~~ (template.identifier ["program/" <name>]))
["#::."
(getValue [] java/lang/Object)]))]
@@ -165,7 +165,7 @@
(def: (variant_value lux_value cdr? value)
(-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair)
- (host.object [] gnu/lists/Pair [program/VariantValue]
+ (ffi.object [] gnu/lists/Pair [program/VariantValue]
[]
## Methods
(program/VariantValue
@@ -196,7 +196,7 @@
(def: (tuple_value lux_value value)
(-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector)
- (host.object [] gnu/lists/SimpleVector [program/TupleValue gnu/lists/GVector]
+ (ffi.object [] gnu/lists/SimpleVector [program/TupleValue gnu/lists/GVector]
[]
## Methods
(program/TupleValue
@@ -204,7 +204,7 @@
(:coerce java/lang/Object value))
(gnu/lists/SimpleVector
[] (getBufferLength self) int
- (host.long_to_int (array.size value)))
+ (ffi.long_to_int (array.size value)))
(gnu/lists/SimpleVector
[] (getRaw self {idx int}) java/lang/Object
(|> value
@@ -240,7 +240,7 @@
(def: (lux_value value)
(-> java/lang/Object java/lang/Object)
- (<| (case (host.check [java/lang/Object] value)
+ (<| (case (ffi.check [java/lang/Object] value)
(#.Some value)
## TODO: Get rid of the coercions below.
(if (variant? value)
@@ -258,7 +258,7 @@
(: Any
(if flag
synthesis.unit
- (host.null)))
+ (ffi.null)))
value])
(def: (read_variant read host_object)
@@ -266,7 +266,7 @@
(do try.monad
[tag (read (gnu/lists/Pair::getCar host_object))
#let [host_object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host_object))
- flag (case (host.check java/lang/Boolean (gnu/lists/Pair::getCar host_object))
+ flag (case (ffi.check java/lang/Boolean (gnu/lists/Pair::getCar host_object))
(#.Some flag)
(:coerce Bit flag)
@@ -293,7 +293,7 @@
(def: (read host_object)
(Reader java/lang/Object)
(`` (<| (~~ (template [<class>]
- [(case (host.check <class> host_object)
+ [(case (ffi.check <class> host_object)
(#.Some host_object)
(#try.Success host_object)
#.None)]
@@ -302,7 +302,7 @@
[gnu/mapping/Procedure] [gnu/lists/U8Vector]
))
(~~ (template [<class> <processing>]
- [(case (host.check <class> host_object)
+ [(case (ffi.check <class> host_object)
(#.Some host_object)
(#try.Success (<| <processing> host_object))
#.None)]
@@ -318,11 +318,11 @@
[program/VariantValue program/VariantValue::getValue]
[program/TupleValue program/TupleValue::getValue]
))
- (case (host.check gnu/lists/Pair host_object)
+ (case (ffi.check gnu/lists/Pair host_object)
(#.Some host_object)
(read_variant read host_object)
#.None)
- (case (host.check gnu/lists/FVector host_object)
+ (case (ffi.check gnu/lists/FVector host_object)
(#.Some host_object)
(read_tuple read (:coerce (gnu/lists/FVector java/lang/Object) host_object))
#.None)
@@ -331,7 +331,7 @@
(def: ensure_macro
(-> Macro (Maybe gnu/mapping/Procedure))
- (|>> (:coerce java/lang/Object) (host.check gnu/mapping/Procedure)))
+ (|>> (:coerce java/lang/Object) (ffi.check gnu/mapping/Procedure)))
(def: (expander macro inputs lux)
Expander
@@ -352,8 +352,6 @@
(exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro)))
)
-(def: separator "$")
-
(def: host
(IO (Host _.Expression _.Expression))
(io (let [interpreter (kawa/standard/Scheme::getR7rsInstance)
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)