From 2df8e4bc8c53a831f3cd8605707ca08d66cecb02 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 25 May 2021 01:55:09 -0400 Subject: Updates for Common-Lisp compiler. --- compilers.md | 24 -- lux-cl/commands.md | 23 + lux-cl/source/program.lux | 476 +++++++++++++-------- lux-scheme/source/program.lux | 70 ++- stdlib/source/lux/target.lux | 2 +- stdlib/source/lux/target/common-lisp.lux | 425 ------------------ stdlib/source/lux/target/common_lisp.lux | 426 ++++++++++++++++++ .../lux/phase/extension/analysis/common_lisp.lux | 34 ++ .../lux/phase/extension/generation/common_lisp.lux | 17 + .../extension/generation/common_lisp/common.lux | 175 ++++++++ .../extension/generation/common_lisp/host.lux | 39 ++ .../language/lux/phase/generation/common-lisp.lux | 60 --- .../lux/phase/generation/common-lisp/case.lux | 209 --------- .../lux/phase/generation/common-lisp/extension.lux | 13 - .../generation/common-lisp/extension/common.lux | 138 ------ .../lux/phase/generation/common-lisp/function.lux | 93 ---- .../lux/phase/generation/common-lisp/loop.lux | 42 -- .../lux/phase/generation/common-lisp/primitive.lux | 27 -- .../lux/phase/generation/common-lisp/reference.lux | 10 - .../lux/phase/generation/common-lisp/runtime.lux | 288 ------------- .../lux/phase/generation/common-lisp/structure.lux | 36 -- .../language/lux/phase/generation/common_lisp.lux | 56 +++ .../lux/phase/generation/common_lisp/case.lux | 241 +++++++++++ .../lux/phase/generation/common_lisp/extension.lux | 13 + .../generation/common_lisp/extension/common.lux | 138 ++++++ .../lux/phase/generation/common_lisp/function.lux | 97 +++++ .../lux/phase/generation/common_lisp/loop.lux | 53 +++ .../lux/phase/generation/common_lisp/primitive.lux | 24 ++ .../lux/phase/generation/common_lisp/reference.lux | 12 + .../lux/phase/generation/common_lisp/runtime.lux | 305 +++++++++++++ .../lux/phase/generation/common_lisp/structure.lux | 36 ++ .../lux/phase/generation/scheme/runtime.lux | 44 +- 32 files changed, 2036 insertions(+), 1610 deletions(-) create mode 100644 lux-cl/commands.md delete mode 100644 stdlib/source/lux/target/common-lisp.lux create mode 100644 stdlib/source/lux/target/common_lisp.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux 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 [] [(exception: ( {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 [ ] - [(case (host.check sub-value) - (#.Some sub-value) - (`` (|> sub-value (~~ (template.splice )))) + [(case (ffi.check sub_value) + (#.Some sub_value) + (`` (|> sub_value (~~ (template.splice )))) #.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 [] [(org/armedbear/lisp/LispObject - ( {idx int}) + [] ( 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 [ ] - [(case (host.check host-object) - (#.Some host-object) - (`` (|> host-object (~~ (template.splice )))) + (`` (<| (~~ (template [ ] + [(case (ffi.check host_object) + (#.Some host_object) + (`` (|> host_object (~~ (template.splice )))) #.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 [] - [(host.interface: + [(ffi.interface: (getValue [] java/lang/Object)) - (`` (host.import: (~~ (template.identifier ["program/" ])) + (`` (ffi.import: (~~ (template.identifier ["program/" ])) ["#::." (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 [] - [(case (host.check host_object) + [(case (ffi.check host_object) (#.Some host_object) (#try.Success host_object) #.None)] @@ -302,7 +302,7 @@ [gnu/mapping/Procedure] [gnu/lists/U8Vector] )) (~~ (template [ ] - [(case (host.check host_object) + [(case (ffi.check host_object) (#.Some host_object) (#try.Success (<| 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 deleted file mode 100644 index 38788c49a..000000000 --- a/stdlib/source/lux/target/common-lisp.lux +++ /dev/null @@ -1,425 +0,0 @@ -(.module: - [lux (#- Code int if cond or and comment let) - [control - [pipe (#+ case> cond> new>)]] - [data - [number - ["f" frac]] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." monad fold)]]] - [macro - ["." template]] - [type - abstract]]) - -(def: as-form - (-> Text Text) - (text.enclose ["(" ")"])) - -(abstract: #export (Code brand) - Text - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [ ] - [(with-expansions [ (template.identifier [ "'"])] - (`` (abstract: #export ( brand) Any)) - (`` (type: #export ( brand) - ( ( brand)))))] - - [Expression Code] - [Computation Expression] - [Access Computation] - [Var Access] - - [Input Code] - ) - - (template [ ] - [(with-expansions [ (template.identifier [ "'"])] - (`` (abstract: #export Any)) - (`` (type: #export ( ))))] - - [Label Code] - [Literal Expression] - [Var/1 Var] - [Var/* Input] - ) - - (type: #export Lambda - {#input Var/* - #output (Expression Any)}) - - (def: #export nil - Literal - (:abstraction "()")) - - (template [ ] - [(def: #export - (-> Text Literal) - (|>> (format ) :abstraction))] - - ["'" symbol] - [":" keyword]) - - (def: #export bool - (-> Bit Literal) - (|>> (case> #0 ..nil - #1 (..symbol "t")))) - - (def: #export int - (-> Int Literal) - (|>> %.int :abstraction)) - - (def: #export float - (-> Frac Literal) - (|>> (cond> [(f.= f.positive-infinity)] - [(new> "(/ 1.0 0.0)" [])] - - [(f.= f.negative-infinity)] - [(new> "(/ -1.0 0.0)" [])] - - [f.not-a-number?] - [(new> "(/ 0.0 0.0)" [])] - - ## else - [%.frac]) - :abstraction)) - - (def: #export (double value) - (-> Frac Literal) - (:abstraction - (.cond (f.= f.positive-infinity value) - "(/ 1.0d0 0.0d0)" - - (f.= f.negative-infinity value) - "(/ -1.0d0 0.0d0)" - - (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) - (format raw "d0")))))) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [ ] - [(text.replace-all )] - - ["\" "\\"] - [text.tab "\t"] - [text.vertical-tab "\v"] - [text.null "\0"] - [text.back-space "\b"] - [text.form-feed "\f"] - [text.new-line "\n"] - [text.carriage-return "\r"] - [text.double-quote (format "\" text.double-quote)] - )) - ))) - - (def: #export string - (-> Text Literal) - (|>> ..sanitize - (text.enclose' text.double-quote) - :abstraction)) - - (def: #export var - (-> Text Var/1) - (|>> :abstraction)) - - (def: #export args - (-> (List Var/1) Var/*) - (|>> (list\map ..code) - (text.join-with " ") - ..as-form - :abstraction)) - - (def: #export (args& singles rest) - (-> (List Var/1) Var/1 Var/*) - (|> (format (|> singles - (list\map ..code) - (text.join-with " ")) - " &rest " (:representation rest)) - ..as-form - :abstraction)) - - (def: form - (-> (List (Expression Any)) Expression) - (|>> (list\map ..code) - (text.join-with " ") - ..as-form - :abstraction)) - - (def: #export (call/* func) - (-> (Expression Any) (-> (List (Expression Any)) (Computation Any))) - (|>> (#.Cons func) ..form)) - - (template [ ] - [(def: #export - (-> (List (Expression Any)) (Computation Any)) - (..call/* (..var )))] - - [vector/* "vector"] - [list/* "list"] - ) - - (def: #export (labels definitions body) - (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any)) - (..form (list (..var "labels") - (..form (list\map (function (_ [def-name [def-args def-body]]) - (..form (list def-name (:transmutation def-args) def-body))) - definitions)) - body))) - - (def: #export (destructuring-bind [bindings expression] body) - (-> [Var/* (Expression Any)] (Expression Any) (Computation Any)) - (..form (list (..var "destructuring-bind") - (:transmutation bindings) expression - body))) - - (template [ + + +] - [(`` (def: #export ( [(~~ (template.splice +))] function) - (-> [(~~ (template.splice +))] (Expression Any) (Computation Any)) - (..call/* function (list (~~ (template.splice +)))))) - - (`` (template [ ] - [(def: #export ( args) - (-> [(~~ (template.splice +))] (Computation Any)) - ( args (..var )))] - - (~~ (template.splice +))))] - - [call/0 [] [] - [[get-universal-time/0 "get-universal-time"] - [make-hash-table/0 "make-hash-table"]]] - [call/1 [in0] [(Expression Any)] - [[length/1 "length"] - [function/1 "function"] - [copy-seq/1 "copy-seq"] - [null/1 "null"] - [error/1 "error"] - [not/1 "not"] - [floor/1 "floor"] - [type-of/1 "type-of"] - [write-to-string/1 "write-to-string"] - [read-from-string/1 "read-from-string"] - [print/1 "print"] - [reverse/1 "reverse"] - [sxhash/1 "sxhash"] - [string-upcase/1 "string-upcase"] - [string-downcase/1 "string-downcase"] - [char-int/1 "char-int"] - [text/1 "text"] - [hash-table-size/1 "hash-table-size"] - [hash-table-rehash-size/1 "hash-table-rehash-size"] - [code-char/1 "code-char"] - [string/1 "string"]]] - [call/2 [in0 in1] [(Expression Any) (Expression Any)] - [[apply/2 "apply"] - [append/2 "append"] - [cons/2 "cons"] - [char/2 "char"] - [nth/2 "nth"] - [nthcdr/2 "nthcdr"] - [coerce/2 "coerce"]]] - [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] - [[subseq/3 "subseq"] - [map/3 "map"] - [concatenate/3 "concatenate"] - [format/3 "format"]]] - ) - - (template [ + +] - [(`` (template [ ] - [(def: #export ( args) - (-> [(~~ (template.splice +))] (Access Any)) - (:transmutation ( args (..var ))))] - - (~~ (template.splice +))))] - - [call/1 [(Expression Any)] - [[car/1 "car"] - [cdr/1 "cdr"] - [cadr/1 "cadr"] - [cddr/1 "cddr"]]] - [call/2 [(Expression Any) (Expression Any)] - [[svref/2 "svref"] - [elt/2 "elt"] - [gethash/2 "gethash"]]] - ) - - (def: #export (make-hash-table/with-size size) - (-> (Expression Any) (Computation Any)) - (..call/* (..var "make-hash-table") - (list (..keyword "size") - size))) - - (def: #export (funcall/+ [func args]) - (-> [(Expression Any) (List (Expression Any))] (Computation Any)) - (..call/* (..var "funcall") (list& func args))) - - (def: #export (search/3 [reference space start]) - (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any)) - (..call/* (..var "search") - (list reference - space - (..keyword "start2") start))) - - (def: #export (concatenate/2|string [left right]) - (-> [(Expression Any) (Expression Any)] (Computation Any)) - (concatenate/3 [(..symbol "string") left right])) - - (template [ ] - [(def: #export ( left right) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var ) left right)))] - - [or "or"] - [and "and"] - ) - - (template [ ] - [(def: #export ( param subject) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var ) subject param)))] - - [= "="] - [eq "eq"] - [equal "equal"] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [string= "string="] - [string< "string<"] - [+ "+"] - [- "-"] - [/ "/"] - [* "*"] - [rem "rem"] - [floor "floor"] - [mod "mod"] - [ash "ash"] - [logand "logand"] - [logior "logior"] - [logxor "logxor"] - ) - - (def: #export (if test then else) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "if") test then else))) - - (def: #export (when test then) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "when") test then))) - - (def: #export (lambda input body) - (-> Var/* (Expression Any) Literal) - (..form (list (..var "lambda") (:transmutation input) body))) - - (template [ ] - [(def: #export ( bindings body) - (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any)) - (..form (list (..var ) - (|> bindings - (list\map (function (_ [name value]) - (..form (list name value)))) - ..form) - body)))] - - [let "let"] - [let* "let*"] - ) - - (def: #export (defparameter name body) - (-> Var/1 (Expression Any) (Expression Any)) - (..form (list (..var "defparameter") name body))) - - (def: #export (defun name inputs body) - (-> Var/1 Var/* (Expression Any) (Expression Any)) - (..form (list (..var "defun") name (:transmutation inputs) body))) - - (def: #export (progn pre post) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "progn") pre post))) - - (def: #export (setq name value) - (-> Var/1 (Expression Any) (Expression Any)) - (..form (list (..var "setq") name value))) - - (def: #export (setf access value) - (-> (Access Any) (Expression Any) (Expression Any)) - (..form (list (..var "setf") access value))) - - (type: #export Handler - {#condition-type (Expression Any) - #condition Var/1 - #body (Expression Any)}) - - (def: #export (handler-case handlers body) - (-> (List Handler) (Expression Any) (Computation Any)) - (..form (list& (..var "handler-case") - body - (list\map (function (_ [type condition handler]) - (..form (list type - (:transmutation (..args (list condition))) - handler))) - handlers)))) - - (template [ ] - [(def: #export ( conditions expression) - (-> (List Text) (Expression Any) (Expression Any)) - (case conditions - #.Nil - expression - - (#.Cons single #.Nil) - (:abstraction - (format single " " (:representation expression))) - - _ - (:abstraction - (format (|> conditions (list\map ..symbol) - (list& (..symbol "or")) ..form - :representation) - " " (:representation expression)))))] - - [conditional+ "#+"] - [conditional- "#-"]) - - (def: #export label - (-> Text Label) - (|>> :abstraction)) - - (def: #export (block name body) - (-> Label (Expression Any) (Computation Any)) - (..form (list (..var "block") (:transmutation name) body))) - - (def: #export (return-from target value) - (-> Label (Expression Any) (Computation Any)) - (..form (list (..var "return-from") (:transmutation target) value))) - - (def: #export (cond clauses else) - (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any)) - (list\fold (function (_ [test then] next) - (..if test then next)) - (:transmutation else) - (list.reverse clauses))) - ) - -(def: #export (while condition body) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "loop") (..var "while") condition - (..var "do") body))) diff --git a/stdlib/source/lux/target/common_lisp.lux b/stdlib/source/lux/target/common_lisp.lux new file mode 100644 index 000000000..19f70cde8 --- /dev/null +++ b/stdlib/source/lux/target/common_lisp.lux @@ -0,0 +1,426 @@ +(.module: + [lux (#- Code int if cond or and comment let) + [control + [pipe (#+ case> cond> new>)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." monad fold)]]] + [macro + ["." template]] + [math + [number + ["f" frac]]] + [type + abstract]]) + +(def: as_form + (-> Text Text) + (text.enclose ["(" ")"])) + +(abstract: #export (Code brand) + Text + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [ ] + [(with_expansions [ (template.identifier [ "'"])] + (`` (abstract: #export ( brand) Any)) + (`` (type: #export ( brand) + ( ( brand)))))] + + [Expression Code] + [Computation Expression] + [Access Computation] + [Var Access] + + [Input Code] + ) + + (template [ ] + [(with_expansions [ (template.identifier [ "'"])] + (`` (abstract: #export Any)) + (`` (type: #export ( ))))] + + [Label Code] + [Literal Expression] + [Var/1 Var] + [Var/* Input] + ) + + (type: #export Lambda + {#input Var/* + #output (Expression Any)}) + + (def: #export nil + Literal + (:abstraction "()")) + + (template [ ] + [(def: #export + (-> Text Literal) + (|>> (format ) :abstraction))] + + ["'" symbol] + [":" keyword]) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 ..nil + #1 (..symbol "t")))) + + (def: #export int + (-> Int Literal) + (|>> %.int :abstraction)) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "(/ 1.0 0.0)" [])] + + [(f.= f.negative_infinity)] + [(new> "(/ -1.0 0.0)" [])] + + [f.not_a_number?] + [(new> "(/ 0.0 0.0)" [])] + + ## else + [%.frac]) + :abstraction)) + + (def: #export (double value) + (-> Frac Literal) + (:abstraction + (.cond (f.= f.positive_infinity value) + "(/ 1.0d0 0.0d0)" + + (f.= f.negative_infinity value) + "(/ -1.0d0 0.0d0)" + + (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) + (format raw "d0")))))) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [ ] + [(text.replace_all )] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical_tab "\v"] + [text.null "\0"] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose' text.double_quote) + :abstraction)) + + (def: #export var + (-> Text Var/1) + (|>> :abstraction)) + + (def: #export args + (-> (List Var/1) Var/*) + (|>> (list\map ..code) + (text.join_with " ") + ..as_form + :abstraction)) + + (def: #export (args& singles rest) + (-> (List Var/1) Var/1 Var/*) + (|> (format (|> singles + (list\map ..code) + (text.join_with " ")) + " &rest " (:representation rest)) + ..as_form + :abstraction)) + + (def: form + (-> (List (Expression Any)) Expression) + (|>> (list\map ..code) + (text.join_with " ") + ..as_form + :abstraction)) + + (def: #export (call/* func) + (-> (Expression Any) (-> (List (Expression Any)) (Computation Any))) + (|>> (#.Cons func) ..form)) + + (template [ ] + [(def: #export + (-> (List (Expression Any)) (Computation Any)) + (..call/* (..var )))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def: #export (labels definitions body) + (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any)) + (..form (list (..var "labels") + (..form (list\map (function (_ [def_name [def_args def_body]]) + (..form (list def_name (:transmutation def_args) def_body))) + definitions)) + body))) + + (def: #export (destructuring-bind [bindings expression] body) + (-> [Var/* (Expression Any)] (Expression Any) (Computation Any)) + (..form (list (..var "destructuring-bind") + (:transmutation bindings) expression + body))) + + (template [ + + +] + [(`` (def: #export ( [(~~ (template.splice +))] function) + (-> [(~~ (template.splice +))] (Expression Any) (Computation Any)) + (..call/* function (list (~~ (template.splice +)))))) + + (`` (template [ ] + [(def: #export ( args) + (-> [(~~ (template.splice +))] (Computation Any)) + ( args (..var )))] + + (~~ (template.splice +))))] + + [call/0 [] [] + [[get-universal-time/0 "get-universal-time"] + [make-hash-table/0 "make-hash-table"]]] + [call/1 [in0] [(Expression Any)] + [[length/1 "length"] + [function/1 "function"] + [copy-seq/1 "copy-seq"] + [null/1 "null"] + [error/1 "error"] + [not/1 "not"] + [floor/1 "floor"] + [type-of/1 "type-of"] + [write-to-string/1 "write-to-string"] + [read-from-string/1 "read-from-string"] + [print/1 "print"] + [reverse/1 "reverse"] + [sxhash/1 "sxhash"] + [string-upcase/1 "string-upcase"] + [string-downcase/1 "string-downcase"] + [char-int/1 "char-int"] + [text/1 "text"] + [hash-table-size/1 "hash-table-size"] + [hash-table-rehash-size/1 "hash-table-rehash-size"] + [code-char/1 "code-char"] + [string/1 "string"]]] + [call/2 [in0 in1] [(Expression Any) (Expression Any)] + [[apply/2 "apply"] + [append/2 "append"] + [cons/2 "cons"] + [char/2 "char"] + [nth/2 "nth"] + [nthcdr/2 "nthcdr"] + [coerce/2 "coerce"]]] + [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] + [[subseq/3 "subseq"] + [map/3 "map"] + [concatenate/3 "concatenate"] + [format/3 "format"]]] + ) + + (template [ + +] + [(`` (template [ ] + [(def: #export ( args) + (-> [(~~ (template.splice +))] (Access Any)) + (:transmutation ( args (..var ))))] + + (~~ (template.splice +))))] + + [call/1 [(Expression Any)] + [[car/1 "car"] + [cdr/1 "cdr"] + [cadr/1 "cadr"] + [cddr/1 "cddr"]]] + [call/2 [(Expression Any) (Expression Any)] + [[svref/2 "svref"] + [elt/2 "elt"] + [gethash/2 "gethash"]]] + ) + + (def: #export (make-hash-table/with_size size) + (-> (Expression Any) (Computation Any)) + (..call/* (..var "make-hash-table") + (list (..keyword "size") + size))) + + (def: #export (funcall/+ [func args]) + (-> [(Expression Any) (List (Expression Any))] (Computation Any)) + (..call/* (..var "funcall") (list& func args))) + + (def: #export (search/3 [reference space start]) + (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any)) + (..call/* (..var "search") + (list reference + space + (..keyword "start2") start))) + + (def: #export (concatenate/2|string [left right]) + (-> [(Expression Any) (Expression Any)] (Computation Any)) + (concatenate/3 [(..symbol "string") left right])) + + (template [ ] + [(def: #export ( left right) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var ) left right)))] + + [or "or"] + [and "and"] + ) + + (template [ ] + [(def: #export ( param subject) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var ) subject param)))] + + [= "="] + [eq "eq"] + [equal "equal"] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [string= "string="] + [string< "string<"] + [+ "+"] + [- "-"] + [/ "/"] + [* "*"] + [rem "rem"] + [floor "floor"] + [mod "mod"] + [ash "ash"] + [logand "logand"] + [logior "logior"] + [logxor "logxor"] + ) + + (def: #export (if test then else) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "if") test then else))) + + (def: #export (when test then) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "when") test then))) + + (def: #export (lambda input body) + (-> Var/* (Expression Any) Literal) + (..form (list (..var "lambda") (:transmutation input) body))) + + (template [ ] + [(def: #export ( bindings body) + (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any)) + (..form (list (..var ) + (|> bindings + (list\map (function (_ [name value]) + (..form (list name value)))) + ..form) + body)))] + + [let "let"] + [let* "let*"] + ) + + (def: #export (defparameter name body) + (-> Var/1 (Expression Any) (Expression Any)) + (..form (list (..var "defparameter") name body))) + + (def: #export (defun name inputs body) + (-> Var/1 Var/* (Expression Any) (Expression Any)) + (..form (list (..var "defun") name (:transmutation inputs) body))) + + (def: #export (progn pre post) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "progn") pre post))) + + (def: #export (setq name value) + (-> Var/1 (Expression Any) (Expression Any)) + (..form (list (..var "setq") name value))) + + (def: #export (setf access value) + (-> (Access Any) (Expression Any) (Expression Any)) + (..form (list (..var "setf") access value))) + + (type: #export Handler + {#condition_type (Expression Any) + #condition Var/1 + #body (Expression Any)}) + + (def: #export (handler-case handlers body) + (-> (List Handler) (Expression Any) (Computation Any)) + (..form (list& (..var "handler-case") + body + (list\map (function (_ [type condition handler]) + (..form (list type + (:transmutation (..args (list condition))) + handler))) + handlers)))) + + (template [ ] + [(def: #export ( conditions expression) + (-> (List Text) (Expression Any) (Expression Any)) + (case conditions + #.Nil + expression + + (#.Cons single #.Nil) + (:abstraction + (format single " " (:representation expression))) + + _ + (:abstraction + (format (|> conditions (list\map ..symbol) + (list& (..symbol "or")) ..form + :representation) + " " (:representation expression)))))] + + [conditional+ "#+"] + [conditional- "#-"]) + + (def: #export label + (-> Text Label) + (|>> :abstraction)) + + (def: #export (block name body) + (-> Label (Expression Any) (Computation Any)) + (..form (list (..var "block") (:transmutation name) body))) + + (def: #export (return-from target value) + (-> Label (Expression Any) (Computation Any)) + (..form (list (..var "return-from") (:transmutation target) value))) + + (def: #export (cond clauses else) + (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any)) + (list\fold (function (_ [test then] next) + (..if test then next)) + (:transmutation else) + (list.reverse clauses))) + ) + +(def: #export (while condition body) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "loop") (..var "while") condition + (..var "do") body))) 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 + ["" 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 + ["" 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 (.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 +## .any +## .any +## (<>.some (.tuple ($_ <>.and +## (.tuple (<>.many .i64)) +## .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 _.> _.integer->char/1 (_.make-string/2 (_.int +1))))) +## ))) + +## (def: f64_procs +## Bundle +## (<| (/.prefix "f64") +## (|> /.empty +## (/.install "=" (binary (product.uncurry _.=/2))) +## (/.install "<" (binary (product.uncurry _.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 /.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 + ["" 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 [ ] - [(^ ( value)) - (\ ///.monad wrap ( 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 [ ] - [( lefts) - ( (_.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 [ ] - [(def: ( simple? idx) - (-> Bit Nat (Expression Any)) - (.let [ (_.eq @variant @temp)] - (_.let (list [@variant ..peek]) - ($_ _.progn - (_.setq @temp (|> idx .int _.int (//runtime.sum//get @variant ))) - (.if simple? - (_.when - fail!) - (_.if - 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 [ <=>] - [(^ ( value)) - (////\wrap (_.if (|> value (<=> ..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 [ ] - [(^ ( idx)) - (////\wrap ( false idx)) - - (^ ( idx nextP)) - (|> nextP - (pattern-matching' generate) - (\ ////.monad map (_.progn ( 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 [ ] - [(^ ( lefts)) - (////\wrap (|> ..peek ( (_.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 [ ] - [(^ ( preP postP)) - (do ////.monad - [pre! (pattern-matching' generate preP) - post! (pattern-matching' generate postP)] - (wrap ( 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/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) 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 deleted file mode 100644 index 750688dd6..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux +++ /dev/null @@ -1,138 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - [number - ["f" frac]] - [collection - ["." dictionary]]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#." primitive] - [// - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - [// - [extension - ["." bundle]]]]]) - -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "is" (binary (product.uncurry _.eq))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: (i64//left-shift [paramG subjectG]) - (Binary (Expression Any)) - (_.ash (_.rem (_.int +64) paramG) subjectG)) - -(def: (i64//arithmetic-right-shift [paramG subjectG]) - (Binary (Expression Any)) - (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) - subjectG)) - -(def: (i64//logic-right-shift [paramG subjectG]) - (Binary (Expression Any)) - (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG)) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry _.logand))) - (bundle.install "or" (binary (product.uncurry _.logior))) - (bundle.install "xor" (binary (product.uncurry _.logxor))) - (bundle.install "left-shift" (binary i64//left-shift)) - (bundle.install "logical-right-shift" (binary i64//logic-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _.floor))) - (bundle.install "%" (binary (product.uncurry _.rem))) - (bundle.install "f64" (unary (function (_ value) - (_.coerce/2 [value (_.symbol "double-float")])))) - (bundle.install "char" (unary (|>> _.code-char/1 _.string/1))) - ))) - -(def: f64-procs - Bundle - (<| (bundle.prefix "f64") - (|> bundle.empty - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.mod))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "i64" (unary _.floor/1)) - (bundle.install "encode" (unary _.write-to-string/1)) - (bundle.install "decode" (unary (let [@temp (_.var "temp")] - (function (_ input) - (_.let (list [@temp (_.read-from-string/1 input)]) - (_.if (_.equal (_.symbol "DOUBLE-FLOAT") - (_.type-of/1 @temp)) - (///runtime.some @temp) - ///runtime.none))))))))) - -(def: (text//< [paramG subjectG]) - (Binary (Expression Any)) - (|> (_.string< paramG subjectG) - _.null/1 - _.not/1)) - -(def: (text//clip [paramO extraO subjectO]) - (Trinary (Expression Any)) - (///runtime.text//clip subjectO paramO extraO)) - -(def: (text//index [startO partO textO]) - (Trinary (Expression Any)) - (///runtime.text//index textO partO startO)) - -(def: text-procs - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary (product.uncurry _.string=))) - (bundle.install "<" (binary text//<)) - (bundle.install "concat" (binary _.concatenate/2|string)) - (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary _.length/1)) - (bundle.install "char" (binary (|>> _.char/2 _.char-int/1))) - (bundle.install "clip" (trinary text//clip)) - ))) - -(def: (void code) - (-> (Expression Any) (Expression Any)) - ($_ _.progn - code - ///runtime.unit)) - -(def: io-procs - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> _.print/1 ..void))) - (bundle.install "error" (unary _.error/1)) - (bundle.install "exit" (unary ///runtime.io//exit)) - (bundle.install "current-time" (nullary (function (_ _) - (///runtime.io//current-time ///runtime.unit))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge f64-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/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/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux deleted file mode 100644 index 4177f814a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - [lux (#- i64) - [control - [pipe (#+ cond> new>)]] - [data - [number - ["." frac]]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." // #_ - ["#." runtime]]) - -(def: #export bit - (-> Bit (Expression Any)) - _.bool) - -(def: #export i64 - (-> (I64 Any) (Expression Any)) - (|>> .int _.int)) - -(def: #export f64 - (-> Frac (Expression Any)) - _.double) - -(def: #export text - (-> Text (Expression Any)) - _.string) diff --git a/stdlib/source/lux/tool/compiler/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 [ ] - [(type: #export - ( 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 [ (as-is ($_ _.then - (_.; (_.set lefts (_.- last-index-right lefts))) - (_.; (_.set tuple (_.nth last-index-right tuple)))))] - (template: (!recur ) - ( (|> 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 [ ] + [(^ ( value)) + (//////phase\wrap ( 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 [ ] + [(^ ( value)) + ( 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 [ ] + [( lefts) + ( (_.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 [ ] + [(def: ( simple? idx) + (-> Bit Nat (Expression Any)) + (.let [ (_.eq @variant @temp)] + (_.let (list [@variant ..peek]) + ($_ _.progn + (_.setq @temp (|> idx .int _.int (//runtime.sum//get @variant ))) + (.if simple? + (_.when + fail!) + (_.if + 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 [ <=>] + [( cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match ) + ..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 [ ] + [(^ ( idx)) + (///////phase\wrap ( false idx)) + + (^ ( idx nextP)) + (|> nextP + recur + (\ ///////phase.monad map (_.progn ( 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 [ ] + [(^ ( lefts)) + (///////phase\wrap (|> ..peek ( (_.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 [ ] + [(^ ( preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap ( 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 new file mode 100644 index 000000000..3bc0a0887 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux @@ -0,0 +1,13 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux new file mode 100644 index 000000000..750688dd6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux @@ -0,0 +1,138 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + [number + ["f" frac]] + [collection + ["." dictionary]]] + [target + ["_" common-lisp (#+ Expression)]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.eq))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: (i64//left-shift [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (_.rem (_.int +64) paramG) subjectG)) + +(def: (i64//arithmetic-right-shift [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) + subjectG)) + +(def: (i64//logic-right-shift [paramG subjectG]) + (Binary (Expression Any)) + (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG)) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.logand))) + (bundle.install "or" (binary (product.uncurry _.logior))) + (bundle.install "xor" (binary (product.uncurry _.logxor))) + (bundle.install "left-shift" (binary i64//left-shift)) + (bundle.install "logical-right-shift" (binary i64//logic-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _.floor))) + (bundle.install "%" (binary (product.uncurry _.rem))) + (bundle.install "f64" (unary (function (_ value) + (_.coerce/2 [value (_.symbol "double-float")])))) + (bundle.install "char" (unary (|>> _.code-char/1 _.string/1))) + ))) + +(def: f64-procs + Bundle + (<| (bundle.prefix "f64") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.mod))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "i64" (unary _.floor/1)) + (bundle.install "encode" (unary _.write-to-string/1)) + (bundle.install "decode" (unary (let [@temp (_.var "temp")] + (function (_ input) + (_.let (list [@temp (_.read-from-string/1 input)]) + (_.if (_.equal (_.symbol "DOUBLE-FLOAT") + (_.type-of/1 @temp)) + (///runtime.some @temp) + ///runtime.none))))))))) + +(def: (text//< [paramG subjectG]) + (Binary (Expression Any)) + (|> (_.string< paramG subjectG) + _.null/1 + _.not/1)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (///runtime.text//clip subjectO paramO extraO)) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.string=))) + (bundle.install "<" (binary text//<)) + (bundle.install "concat" (binary _.concatenate/2|string)) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.length/1)) + (bundle.install "char" (binary (|>> _.char/2 _.char-int/1))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: (void code) + (-> (Expression Any) (Expression Any)) + ($_ _.progn + code + ///runtime.unit)) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> _.print/1 ..void))) + (bundle.install "error" (unary _.error/1)) + (bundle.install "exit" (unary ///runtime.io//exit)) + (bundle.install "current-time" (nullary (function (_ _) + (///runtime.io//current-time ///runtime.unit))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge f64-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/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 new file mode 100644 index 000000000..7840ccccc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux @@ -0,0 +1,24 @@ +(.module: + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [target + ["_" common_lisp (#+ Expression)]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + (-> Bit (Expression Any)) + _.bool) + +(def: #export i64 + (-> (I64 Any) (Expression Any)) + (|>> .int _.int)) + +(def: #export f64 + (-> Frac (Expression Any)) + _.double) + +(def: #export text + (-> Text (Expression Any)) + _.string) diff --git a/stdlib/source/lux/tool/compiler/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 [ ] + [(type: #export + ( 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 (.tuple (<>.some .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 .local_identifier + (.form (<>.and .local_identifier + (<>.some .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 [ (as_is ($_ _.then + (_.; (_.set lefts (_.- last_index_right lefts))) + (_.; (_.set tuple (_.nth last_index_right tuple)))))] + (template: (!recur ) + ( (|> 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) -- cgit v1.2.3