diff options
| author | Eduardo Julian | 2021-05-25 01:55:09 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2021-05-25 01:55:09 -0400 |
| commit | 2df8e4bc8c53a831f3cd8605707ca08d66cecb02 (patch) | |
| tree | 839af4a3c1b2c1629946111d58373946d367becc | |
| parent | f01e246f468c948d41423248809443570f48c7a4 (diff) | |
Updates for Common-Lisp compiler.
28 files changed, 1489 insertions, 1063 deletions
diff --git a/compilers.md b/compilers.md index 7a9afdc4c..5494eafd4 100644 --- a/compilers.md +++ b/compilers.md @@ -1,27 +1,3 @@ -# Common Lisp compiler - -## Test - -``` -cd ~/lux/lux-cl/ && lein lux auto test -cd ~/lux/lux-cl/ && lein clean && lein lux auto test -``` - -## Build - -``` -cd ~/lux/lux-cl/ && lein lux auto build -cd ~/lux/lux-cl/ && lein clean && lein lux auto build -``` - -## Try - -``` -cd ~/lux/lux-cl/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux -``` - ---- - # R compiler ## Test diff --git a/lux-cl/commands.md b/lux-cl/commands.md new file mode 100644 index 000000000..baefd65b7 --- /dev/null +++ b/lux-cl/commands.md @@ -0,0 +1,23 @@ +# Common Lisp compiler + +## Test + +``` +cd ~/lux/lux-cl/ && lein lux auto test +cd ~/lux/lux-cl/ && lein clean && lein lux auto test +``` + +## Build + +``` +## Develop +cd ~/lux/lux-cl/ \ +&& lein clean \ +&& lein lux auto build +``` + +## Try + +``` +cd ~/lux/lux-cl/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +``` diff --git a/lux-cl/source/program.lux b/lux-cl/source/program.lux index 8d6218297..89b2b937c 100644 --- a/lux-cl/source/program.lux +++ b/lux-cl/source/program.lux @@ -1,116 +1,151 @@ (.module: [lux #* - ["." host (#+ import: interface: do-to object)] + [program (#+ program:)] + ["." ffi] + ["." debug] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control - [pipe (#+ new> case>)] + [pipe (#+ exec> case> new>)] + ["." try (#+ Try)] ["." exception (#+ exception:)] ["." io (#+ IO io)] - [parser - [cli (#+ program:)]]] + [concurrency + ["." promise (#+ Promise)]]] [data ["." maybe] - ["." error (#+ Error)] - [number - ["." i64]] - ["." text ("#/." hash) - format] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] [collection - ["." array (#+ Array)] - ["." list ("#/." functor)]]] + ["." array (#+ Array)]]] [macro ["." template]] - [world - ["." file]] - ["." debug] - [target - ["_" common-lisp]] + [math + [number (#+ hex) + ["n" nat] + ["." i64]]] + ["." world #_ + ["." file] + ["#/." program]] + ["@" target + ["_" common_lisp]] [tool [compiler - ["." name] - ["." synthesis] - [phase - [macro (#+ Expander)] - ["." generation - ["." common-lisp - ["." runtime] - ["." extension]]]] + [phase (#+ Operation Phase)] + [reference + [variable (#+ Register)]] + [language + [lux + [program (#+ Program)] + [generation (#+ Context Host)] + ["." synthesis] + [analysis + [macro (#+ Expander)]] + [phase + ["." extension (#+ Extender Handler) + ["#/." bundle] + ["." analysis #_ + ["#" common_lisp]] + ["." generation #_ + ["#" common_lisp]]] + [generation + ["." reference] + ["." common_lisp + ["." runtime]]]]]] [default - ["." platform (#+ Platform)]]]]] + ["." platform (#+ Platform)]] + [meta + ["." packager #_ + ["#" script]]]]]] [program ["/" compositor - ["/." cli]]]) - -(import: #long java/lang/String) - -(import: #long (java/lang/Class a) - (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))) - -(import: #long java/lang/Object - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))) - -(import: #long java/lang/Long - (intValue [] java/lang/Integer)) - -(import: #long java/lang/Integer - (longValue [] long)) - -(import: #long java/lang/Number - (intValue [] java/lang/Integer) - (longValue [] long) - (doubleValue [] double)) - -(import: #long org/armedbear/lisp/LispObject - (length [] int) - (NTH [int] org/armedbear/lisp/LispObject) - (SVREF [int] org/armedbear/lisp/LispObject) - (elt [int] org/armedbear/lisp/LispObject) - (execute [org/armedbear/lisp/LispObject org/armedbear/lisp/LispObject] #try org/armedbear/lisp/LispObject)) + ["#." cli] + ["#." static]]]) + +(ffi.import: java/lang/String) + +(ffi.import: (java/lang/Class a) + ["#::." + (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))]) + +(ffi.import: java/lang/Object + ["#::." + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))]) + +(ffi.import: java/lang/Long + ["#::." + (intValue [] java/lang/Integer)]) + +(ffi.import: java/lang/Integer + ["#::." + (longValue [] long)]) + +(ffi.import: java/lang/Number + ["#::." + (intValue [] java/lang/Integer) + (longValue [] long) + (doubleValue [] double)]) + +(ffi.import: org/armedbear/lisp/LispObject + ["#::." + (length [] int) + (NTH [int] org/armedbear/lisp/LispObject) + (SVREF [int] org/armedbear/lisp/LispObject) + (elt [int] org/armedbear/lisp/LispObject) + (execute [org/armedbear/lisp/LispObject org/armedbear/lisp/LispObject] #try org/armedbear/lisp/LispObject)]) ## The org/armedbear/lisp/Interpreter must be imported before the ## other ones, because there is an order dependency in their static initialization. -(import: #long org/armedbear/lisp/Interpreter - (#static getInstance [] org/armedbear/lisp/Interpreter) - (#static createInstance [] #? org/armedbear/lisp/Interpreter) - (eval [java/lang/String] #try org/armedbear/lisp/LispObject)) +(ffi.import: org/armedbear/lisp/Interpreter + ["#::." + (#static getInstance [] org/armedbear/lisp/Interpreter) + (#static createInstance [] #? org/armedbear/lisp/Interpreter) + (eval [java/lang/String] #try org/armedbear/lisp/LispObject)]) -(import: #long org/armedbear/lisp/Symbol - (#static T org/armedbear/lisp/Symbol)) +(ffi.import: org/armedbear/lisp/Symbol + ["#::." + (#static T org/armedbear/lisp/Symbol)]) -(import: #long org/armedbear/lisp/DoubleFloat - (new [double]) - (doubleValue [] double)) +(ffi.import: org/armedbear/lisp/DoubleFloat + ["#::." + (new [double]) + (doubleValue [] double)]) -(import: #long org/armedbear/lisp/SimpleString - (new [java/lang/String]) - (getStringValue [] java/lang/String)) +(ffi.import: org/armedbear/lisp/SimpleString + ["#::." + (new [java/lang/String]) + (getStringValue [] java/lang/String)]) -(import: #long org/armedbear/lisp/LispInteger) +(ffi.import: org/armedbear/lisp/LispInteger) -(import: #long org/armedbear/lisp/Bignum - (longValue [] long) - (#static getInstance [long] org/armedbear/lisp/LispInteger)) +(ffi.import: org/armedbear/lisp/Bignum + ["#::." + (longValue [] long) + (#static getInstance [long] org/armedbear/lisp/LispInteger)]) -(import: #long org/armedbear/lisp/Fixnum - (longValue [] long) - (#static getInstance [int] org/armedbear/lisp/Fixnum)) +(ffi.import: org/armedbear/lisp/Fixnum + ["#::." + (longValue [] long) + (#static getInstance [int] org/armedbear/lisp/Fixnum)]) -(import: #long org/armedbear/lisp/Nil - (#static NIL org/armedbear/lisp/Symbol)) +(ffi.import: org/armedbear/lisp/Nil + ["#::." + (#static NIL org/armedbear/lisp/Symbol)]) -(import: #long org/armedbear/lisp/SimpleVector) +(ffi.import: org/armedbear/lisp/SimpleVector) -(import: #long org/armedbear/lisp/Cons) +(ffi.import: org/armedbear/lisp/Cons) -(import: #long org/armedbear/lisp/Closure) +(ffi.import: org/armedbear/lisp/Closure) -(interface: LuxADT +(ffi.interface: LuxADT (getValue [] java/lang/Object)) -(import: #long program/LuxADT - (getValue [] java/lang/Object)) +(ffi.import: program/LuxADT + ["#::." + (getValue [] java/lang/Object)]) (template [<name>] [(exception: (<name> {object java/lang/Object}) @@ -118,44 +153,44 @@ ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] ["Object" (java/lang/Object::toString object)]))] - [unknown-kind-of-object] - [cannot-apply-a-non-function] + [unknown_kind_of_object] + [cannot_apply_a_non_function] ) -(def: host-bit +(def: host_bit (-> Bit org/armedbear/lisp/LispObject) (|>> (case> #0 (org/armedbear/lisp/Nil::NIL) #1 (org/armedbear/lisp/Symbol::T)))) -(def: (host-value value) +(def: (host_value value) (-> Any org/armedbear/lisp/LispObject) - (let [to-sub (: (-> Any org/armedbear/lisp/LispObject) - (function (_ sub-value) - (let [sub-value (:coerce java/lang/Object sub-value)] + (let [to_sub (: (-> Any org/armedbear/lisp/LispObject) + (function (_ sub_value) + (let [sub_value (:coerce java/lang/Object sub_value)] (`` (<| (~~ (template [<type> <then>] - [(case (host.check <type> sub-value) - (#.Some sub-value) - (`` (|> sub-value (~~ (template.splice <then>)))) + [(case (ffi.check <type> sub_value) + (#.Some sub_value) + (`` (|> sub_value (~~ (template.splice <then>)))) #.None)] - [[java/lang/Object] [host-value]] - [java/lang/Boolean [..host-bit]] + [[java/lang/Object] [host_value]] + [java/lang/Boolean [..host_bit]] [java/lang/Integer [java/lang/Integer::longValue org/armedbear/lisp/Fixnum::getInstance]] [java/lang/Long [org/armedbear/lisp/Bignum::getInstance]] [java/lang/Double [org/armedbear/lisp/DoubleFloat::new]] [java/lang/String [org/armedbear/lisp/SimpleString::new]] )) ## else - (:coerce org/armedbear/lisp/LispObject sub-value))))))] - (`` (object [] org/armedbear/lisp/LispObject [program/LuxADT] + (:coerce org/armedbear/lisp/LispObject sub_value))))))] + (`` (ffi.object [] org/armedbear/lisp/LispObject [program/LuxADT] [] ## Methods (program/LuxADT - (getValue) java/lang/Object + [] (getValue self) java/lang/Object (:coerce java/lang/Object value)) (org/armedbear/lisp/LispObject - (length) + [] (length self) int (|> value (:coerce (Array java/lang/Object)) @@ -165,12 +200,12 @@ (~~ (template [<name>] [(org/armedbear/lisp/LispObject - (<name> {idx int}) + [] (<name> self {idx int}) org/armedbear/lisp/LispObject (case (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)) (:coerce (Array java/lang/Object) value)) (#.Some sub) - (to-sub sub) + (to_sub sub) #.None (org/armedbear/lisp/Nil::NIL)))] @@ -180,128 +215,135 @@ )))) (type: (Reader a) - (-> a (Error Any))) + (-> a (Try Any))) -(def: (read-variant read host-object) +(def: (read_variant read host_object) (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/Cons)) - (do error.monad - [tag (read (org/armedbear/lisp/LispObject::NTH +0 host-object)) - value (read (org/armedbear/lisp/LispObject::NTH +2 host-object))] + (do try.monad + [tag (read (org/armedbear/lisp/LispObject::NTH +0 host_object)) + value (read (org/armedbear/lisp/LispObject::NTH +2 host_object))] (wrap [(java/lang/Long::intValue (:coerce java/lang/Long tag)) - (case (host.check org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host-object)) + (case (ffi.check org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host_object)) (#.Some _) - (: Any (host.null)) + (: Any (ffi.null)) _ (: Any synthesis.unit)) value]))) -(def: (read-tuple read host-object) +(def: (read_tuple read host_object) (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/SimpleVector)) - (let [size (.nat (org/armedbear/lisp/LispObject::length host-object))] + (let [size (.nat (org/armedbear/lisp/LispObject::length host_object))] (loop [idx 0 output (:coerce (Array Any) (array.new size))] - (if (n/< size idx) + (if (n.< size idx) ## TODO: Start using "SVREF" instead of "elt" ASAP - (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host-object)) - (#error.Failure error) - (#error.Failure error) + (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host_object)) + (#try.Failure error) + (#try.Failure error) - (#error.Success member) - (recur (inc idx) (array.write idx (:coerce Any member) output))) - (#error.Success output))))) + (#try.Success member) + (recur (inc idx) (array.write! idx (:coerce Any member) output))) + (#try.Success output))))) -(def: (read host-object) +(def: (read host_object) (Reader org/armedbear/lisp/LispObject) - (`` (<| (~~ (template [<class> <post-processing>] - [(case (host.check <class> host-object) - (#.Some host-object) - (`` (|> host-object (~~ (template.splice <post-processing>)))) + (`` (<| (~~ (template [<class> <post_processing>] + [(case (ffi.check <class> host_object) + (#.Some host_object) + (`` (|> host_object (~~ (template.splice <post_processing>)))) #.None)] - [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue #error.Success]] - [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue #error.Success]] - [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #error.Success]] - [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue #error.Success]] - [org/armedbear/lisp/Cons [(read-variant read)]] - [org/armedbear/lisp/SimpleVector [(read-tuple read)]] - [org/armedbear/lisp/Nil [(new> (#error.Success false) [])]] - [org/armedbear/lisp/Closure [#error.Success]] - [program/LuxADT [program/LuxADT::getValue #error.Success]])) - (case (host.check org/armedbear/lisp/Symbol host-object) - (#.Some host-object) - (if (is? (org/armedbear/lisp/Symbol::T) host-object) - (#error.Success true) - (exception.throw unknown-kind-of-object (:coerce java/lang/Object host-object))) + [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue #try.Success]] + [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue #try.Success]] + [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #try.Success]] + [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue #try.Success]] + [org/armedbear/lisp/Cons [(read_variant read)]] + [org/armedbear/lisp/SimpleVector [(read_tuple read)]] + [org/armedbear/lisp/Nil [(new> (#try.Success false) [])]] + [org/armedbear/lisp/Closure [#try.Success]] + [program/LuxADT [program/LuxADT::getValue #try.Success]])) + (case (ffi.check org/armedbear/lisp/Symbol host_object) + (#.Some host_object) + (if (is? (org/armedbear/lisp/Symbol::T) host_object) + (#try.Success true) + (exception.throw ..unknown_kind_of_object (:coerce java/lang/Object host_object))) #.None) ## else - (exception.throw unknown-kind-of-object (:coerce java/lang/Object host-object)) + (exception.throw ..unknown_kind_of_object (:coerce java/lang/Object host_object)) ))) -(def: ensure-macro +(def: ensure_macro (-> Macro (Maybe org/armedbear/lisp/Closure)) - (|>> (:coerce java/lang/Object) (host.check org/armedbear/lisp/Closure))) + (|>> (:coerce java/lang/Object) (ffi.check org/armedbear/lisp/Closure))) -(def: (call-macro inputs lux macro) - (-> (List Code) Lux org/armedbear/lisp/Closure (Error (Error [Lux (List Code)]))) - (do error.monad - [raw-output (org/armedbear/lisp/LispObject::execute (..host-value inputs) (..host-value lux) macro)] - (:coerce (Error (Error [Lux (List Code)])) - (..read raw-output)))) +(def: (call_macro inputs lux macro) + (-> (List Code) Lux org/armedbear/lisp/Closure (Try (Try [Lux (List Code)]))) + (do try.monad + [raw_output (org/armedbear/lisp/LispObject::execute (..host_value inputs) (..host_value lux) macro)] + (:coerce (Try (Try [Lux (List Code)])) + (..read raw_output)))) (def: (expander macro inputs lux) Expander - (case (ensure-macro macro) + (case (ensure_macro macro) (#.Some macro) - (call-macro inputs lux macro) + (call_macro inputs lux macro) #.None - (exception.throw cannot-apply-a-non-function (:coerce java/lang/Object macro)))) - -(def: separator "$") - -(type: Host - (generation.Host (_.Expression Any) (_.Expression Any))) + (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro)))) (def: host - (IO Host) + (IO (Host (_.Expression Any) (_.Expression Any))) (io (let [_ (org/armedbear/lisp/Interpreter::createInstance) - interpreter (org/armedbear/lisp/Interpreter::getInstance)] - (: Host + interpreter (org/armedbear/lisp/Interpreter::getInstance) + run! (: (-> (_.Code Any) (Try Any)) + (function (_ code) + (do try.monad + [host_value (org/armedbear/lisp/Interpreter::eval (_.code code) interpreter)] + (read host_value))))] + (: (Host (_.Expression Any) (_.Expression Any)) (structure - (def: (evaluate! alias input) - (do error.monad - [host-value (org/armedbear/lisp/Interpreter::eval (_.code input) interpreter)] - (read host-value))) + (def: (evaluate! context code) + (run! code)) - (def: (execute! alias input) + (def: (execute! input) (org/armedbear/lisp/Interpreter::eval (_.code input) interpreter)) - (def: (define! [module name] input) - (let [global (format (text.replace-all .module-separator ..separator module) - ..separator (name.normalize name) - "___" (%n (text/hash name))) + (def: (define! context input) + (let [global (reference.artifact context) @global (_.var global)] - (do error.monad + (do try.monad [#let [definition (_.defparameter @global input)] _ (org/armedbear/lisp/Interpreter::eval (_.code definition) interpreter) - host-value (org/armedbear/lisp/Interpreter::eval (_.code @global) interpreter) - lux-value (read host-value)] - (wrap [global lux-value definition]))))))))) + value (run! @global)] + (wrap [global value definition])))) + + (def: (ingest context content) + (|> content (\ encoding.utf8 decode) try.assume (:coerce (_.Expression Any)))) + + (def: (re_learn context content) + (run! content)) + + (def: (re_load context content) + (do try.monad + [_ (run! content)] + (run! (_.var (reference.artifact context))))) + ))))) (def: platform - (IO (Platform IO _.Var/1 (_.Expression Any) (_.Expression Any))) + (IO (Platform _.Var/1 (_.Expression Any) (_.Expression Any))) (do io.monad [host ..host] - (wrap {#platform.&monad io.monad - #platform.&file-system file.system + (wrap {#platform.&file_system (file.async file.default) #platform.host host - #platform.phase common-lisp.generate - #platform.runtime runtime.generate}))) + #platform.phase common_lisp.generate + #platform.runtime runtime.generate + #platform.write (|>> _.code (\ encoding.utf8 encode))}))) -(def: get-ecl-cli-inputs +(def: get_ecl_cli_inputs (let [@idx (_.var "i")] (_.call/* (_.var "loop") (list (_.var "for") @idx @@ -309,23 +351,87 @@ (_.var "below") (_.call/* (_.var "si:argc") (list)) (_.var "collect") (_.call/* (_.var "si:argv") (list @idx)))))) -(def: program - (-> (_.Expression Any) (_.Expression Any)) - (let [raw-inputs ($_ _.progn +(def: (program context program) + (Program (_.Expression Any) (_.Expression Any)) + (let [raw_inputs ($_ _.progn (_.conditional+ (list "clisp") (_.var "ext:*args*")) (_.conditional+ (list "sbcl") (_.var "sb-ext:*posix-argv*")) (_.conditional+ (list "clozure") (_.call/* (_.var "ccl::command-line-arguments") (list))) (_.conditional+ (list "gcl") (_.var "si:*command-args*")) - (_.conditional+ (list "ecl") ..get-ecl-cli-inputs) + (_.conditional+ (list "ecl") ..get_ecl_cli_inputs) (_.conditional+ (list "cmu") (_.var "extensions:*command-line-strings*")) (_.conditional+ (list "allegro") (_.call/* (_.var "sys:command-line-arguments") (list))) (_.conditional+ (list "lispworks") (_.var "sys:*line-arguments-list*")) (_.list/* (list)))] - (|>> (_.call/2 [(runtime.lux//program-args raw-inputs) _.nil])))) - -(program: [{service /cli.service}] - (/.compiler ..expander - ..platform - extension.bundle - ..program - service)) + (_.call/2 [(runtime.lux//program_args raw_inputs) _.nil] program))) + +(for {@.old + (def: extender + Extender + ## TODO: Stop relying on coercions ASAP. + (<| (:coerce Extender) + (function (@self handler)) + (:coerce Handler) + (function (@self name phase)) + (:coerce Phase) + (function (@self archive parameters)) + (:coerce Operation) + (function (@self state)) + (:coerce Try) + try.assume + (:coerce Try) + (exec + ("lux io log" "TODO: Extender") + (#try.Failure "TODO: Extender")))) + + @.common_lisp + (def: (extender handler) + Extender + (:assume handler))}) + +(def: (declare_success! _) + (-> Any (Promise Any)) + (promise.future (\ world/program.default exit +0))) + +(def: (then pre post) + (-> (_.Expression Any) (_.Expression Any) (_.Expression Any)) + (_.manual (format (_.code pre) + text.new_line + (_.code post)))) + +(def: (scope body) + (-> (_.Expression Any) (_.Expression Any)) + (let [@program (_.var "lux_program")] + ($_ ..then + (_.defun @program (_.args (list)) body) + (_.call/* @program (list)) + ))) + +(`` (program: [{service /cli.service}] + (let [extension ".cl"] + (do io.monad + [platform ..platform] + (exec (do promise.monad + [_ (/.compiler {#/static.host @.common_lisp + #/static.host_module_extension extension + #/static.target (/cli.target service) + #/static.artifact_extension extension} + ..expander + analysis.bundle + (io.io platform) + generation.bundle + extension/bundle.empty + ..program + [_.Var _.Expression _.Expression] + ..extender + service + [(packager.package (_.manual "") + _.code + ..then + ..scope) + (format (/cli.target service) + (\ file.default separator) + "program" + extension)])] + (..declare_success! [])) + (io.io [])))))) diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux index e318c6abd..24d26945d 100644 --- a/lux-scheme/source/program.lux +++ b/lux-scheme/source/program.lux @@ -1,7 +1,7 @@ (.module: [lux #* [program (#+ program:)] - ["." host] + ["." ffi] ["." debug] [abstract ["." monad (#+ do)]] @@ -63,82 +63,82 @@ ["#." cli] ["#." static]]]) -(host.import: java/lang/Boolean) -(host.import: java/lang/String) +(ffi.import: java/lang/Boolean) +(ffi.import: java/lang/String) -(host.import: (java/lang/Class a)) +(ffi.import: (java/lang/Class a)) -(host.import: java/lang/Object +(ffi.import: java/lang/Object ["#::." (toString [] java/lang/String) (getClass [] (java/lang/Class java/lang/Object))]) -(host.import: java/lang/Long +(ffi.import: java/lang/Long ["#::." (intValue [] java/lang/Integer)]) -(host.import: java/lang/Integer +(ffi.import: java/lang/Integer ["#::." (longValue [] java/lang/Long)]) -(host.import: gnu/math/IntNum +(ffi.import: gnu/math/IntNum ["#::." (new #manual [int]) (longValue [] long)]) -(host.import: gnu/math/DFloNum +(ffi.import: gnu/math/DFloNum ["#::." (doubleValue [] double)]) -(host.import: gnu/lists/FString +(ffi.import: gnu/lists/FString ["#::." (toString [] String)]) -(host.import: gnu/lists/IString +(ffi.import: gnu/lists/IString ["#::." (toString [] String)]) -(host.import: gnu/lists/Pair +(ffi.import: gnu/lists/Pair ["#::." (getCar [] java/lang/Object) (getCdr [] java/lang/Object)]) -(host.import: gnu/lists/EmptyList +(ffi.import: gnu/lists/EmptyList ["#::." (#static emptyList gnu/lists/EmptyList)]) -(host.import: (gnu/lists/FVector E) +(ffi.import: (gnu/lists/FVector E) ["#::." (getBufferLength [] int) (getRaw [int] E)]) -(host.import: gnu/lists/U8Vector) +(ffi.import: gnu/lists/U8Vector) -(host.import: gnu/mapping/Procedure +(ffi.import: gnu/mapping/Procedure ["#::." (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object) (applyN [[java/lang/Object]] #try java/lang/Object)]) -(host.import: gnu/mapping/Environment) +(ffi.import: gnu/mapping/Environment) -(host.import: gnu/expr/Language +(ffi.import: gnu/expr/Language ["#::." (eval [java/lang/String] #try java/lang/Object)]) -(host.import: kawa/standard/Scheme +(ffi.import: kawa/standard/Scheme ["#::." (#static getR7rsInstance [] kawa/standard/Scheme)]) (def: (variant? value) (-> Any Bit) - (case (host.check [java/lang/Object] (:coerce java/lang/Object value)) + (case (ffi.check [java/lang/Object] (:coerce java/lang/Object value)) (#.Some array) ## TODO: Get rid of this coercion ASAP. (let [array (:coerce (Array java/lang/Object) array)] (and (n.= 3 (array.size array)) (case (array.read 0 array) (#.Some tag) - (case (host.check java/lang/Integer tag) + (case (ffi.check java/lang/Integer tag) (#.Some _) true @@ -152,10 +152,10 @@ false)) (template [<name>] - [(host.interface: <name> + [(ffi.interface: <name> (getValue [] java/lang/Object)) - (`` (host.import: (~~ (template.identifier ["program/" <name>])) + (`` (ffi.import: (~~ (template.identifier ["program/" <name>])) ["#::." (getValue [] java/lang/Object)]))] @@ -165,7 +165,7 @@ (def: (variant_value lux_value cdr? value) (-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair) - (host.object [] gnu/lists/Pair [program/VariantValue] + (ffi.object [] gnu/lists/Pair [program/VariantValue] [] ## Methods (program/VariantValue @@ -196,7 +196,7 @@ (def: (tuple_value lux_value value) (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector) - (host.object [] gnu/lists/SimpleVector [program/TupleValue gnu/lists/GVector] + (ffi.object [] gnu/lists/SimpleVector [program/TupleValue gnu/lists/GVector] [] ## Methods (program/TupleValue @@ -204,7 +204,7 @@ (:coerce java/lang/Object value)) (gnu/lists/SimpleVector [] (getBufferLength self) int - (host.long_to_int (array.size value))) + (ffi.long_to_int (array.size value))) (gnu/lists/SimpleVector [] (getRaw self {idx int}) java/lang/Object (|> value @@ -240,7 +240,7 @@ (def: (lux_value value) (-> java/lang/Object java/lang/Object) - (<| (case (host.check [java/lang/Object] value) + (<| (case (ffi.check [java/lang/Object] value) (#.Some value) ## TODO: Get rid of the coercions below. (if (variant? value) @@ -258,7 +258,7 @@ (: Any (if flag synthesis.unit - (host.null))) + (ffi.null))) value]) (def: (read_variant read host_object) @@ -266,7 +266,7 @@ (do try.monad [tag (read (gnu/lists/Pair::getCar host_object)) #let [host_object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host_object)) - flag (case (host.check java/lang/Boolean (gnu/lists/Pair::getCar host_object)) + flag (case (ffi.check java/lang/Boolean (gnu/lists/Pair::getCar host_object)) (#.Some flag) (:coerce Bit flag) @@ -293,7 +293,7 @@ (def: (read host_object) (Reader java/lang/Object) (`` (<| (~~ (template [<class>] - [(case (host.check <class> host_object) + [(case (ffi.check <class> host_object) (#.Some host_object) (#try.Success host_object) #.None)] @@ -302,7 +302,7 @@ [gnu/mapping/Procedure] [gnu/lists/U8Vector] )) (~~ (template [<class> <processing>] - [(case (host.check <class> host_object) + [(case (ffi.check <class> host_object) (#.Some host_object) (#try.Success (<| <processing> host_object)) #.None)] @@ -318,11 +318,11 @@ [program/VariantValue program/VariantValue::getValue] [program/TupleValue program/TupleValue::getValue] )) - (case (host.check gnu/lists/Pair host_object) + (case (ffi.check gnu/lists/Pair host_object) (#.Some host_object) (read_variant read host_object) #.None) - (case (host.check gnu/lists/FVector host_object) + (case (ffi.check gnu/lists/FVector host_object) (#.Some host_object) (read_tuple read (:coerce (gnu/lists/FVector java/lang/Object) host_object)) #.None) @@ -331,7 +331,7 @@ (def: ensure_macro (-> Macro (Maybe gnu/mapping/Procedure)) - (|>> (:coerce java/lang/Object) (host.check gnu/mapping/Procedure))) + (|>> (:coerce java/lang/Object) (ffi.check gnu/mapping/Procedure))) (def: (expander macro inputs lux) Expander @@ -352,8 +352,6 @@ (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))) ) -(def: separator "$") - (def: host (IO (Host _.Expression _.Expression)) (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance) diff --git a/stdlib/source/lux/target.lux b/stdlib/source/lux/target.lux index c33e5b045..a5188a907 100644 --- a/stdlib/source/lux/target.lux +++ b/stdlib/source/lux/target.lux @@ -10,7 +10,7 @@ ## TODO: Delete ASAP [old "{old}"] - [common-lisp "Common Lisp"] + [common_lisp "Common Lisp"] [js "JavaScript"] [jvm "JVM"] [lua "Lua"] diff --git a/stdlib/source/lux/target/common-lisp.lux b/stdlib/source/lux/target/common_lisp.lux index 38788c49a..19f70cde8 100644 --- a/stdlib/source/lux/target/common-lisp.lux +++ b/stdlib/source/lux/target/common_lisp.lux @@ -3,18 +3,19 @@ [control [pipe (#+ case> cond> new>)]] [data - [number - ["f" frac]] ["." text ["%" format (#+ format)]] [collection ["." list ("#\." monad fold)]]] [macro ["." template]] + [math + [number + ["f" frac]]] [type abstract]]) -(def: as-form +(def: as_form (-> Text Text) (text.enclose ["(" ")"])) @@ -30,7 +31,7 @@ (|>> :representation)) (template [<type> <super>] - [(with-expansions [<brand> (template.identifier [<type> "'"])] + [(with_expansions [<brand> (template.identifier [<type> "'"])] (`` (abstract: #export (<brand> brand) Any)) (`` (type: #export (<type> brand) (<super> (<brand> brand)))))] @@ -44,7 +45,7 @@ ) (template [<type> <super>] - [(with-expansions [<brand> (template.identifier [<type> "'"])] + [(with_expansions [<brand> (template.identifier [<type> "'"])] (`` (abstract: #export <brand> Any)) (`` (type: #export <type> (<super> <brand>))))] @@ -81,13 +82,13 @@ (def: #export float (-> Frac Literal) - (|>> (cond> [(f.= f.positive-infinity)] + (|>> (cond> [(f.= f.positive_infinity)] [(new> "(/ 1.0 0.0)" [])] - [(f.= f.negative-infinity)] + [(f.= f.negative_infinity)] [(new> "(/ -1.0 0.0)" [])] - [f.not-a-number?] + [f.not_a_number?] [(new> "(/ 0.0 0.0)" [])] ## else @@ -97,42 +98,42 @@ (def: #export (double value) (-> Frac Literal) (:abstraction - (.cond (f.= f.positive-infinity value) + (.cond (f.= f.positive_infinity value) "(/ 1.0d0 0.0d0)" - (f.= f.negative-infinity value) + (f.= f.negative_infinity value) "(/ -1.0d0 0.0d0)" - (f.not-a-number? value) + (f.not_a_number? value) "(/ 0.0d0 0.0d0)" ## else (.let [raw (%.frac value)] (.if (text.contains? "E" raw) - (text.replace-once "E" "d" raw) + (text.replace_once "E" "d" raw) (format raw "d0")))))) (def: sanitize (-> Text Text) (`` (|>> (~~ (template [<find> <replace>] - [(text.replace-all <find> <replace>)] + [(text.replace_all <find> <replace>)] ["\" "\\"] [text.tab "\t"] - [text.vertical-tab "\v"] + [text.vertical_tab "\v"] [text.null "\0"] - [text.back-space "\b"] - [text.form-feed "\f"] - [text.new-line "\n"] - [text.carriage-return "\r"] - [text.double-quote (format "\" text.double-quote)] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] )) ))) (def: #export string (-> Text Literal) (|>> ..sanitize - (text.enclose' text.double-quote) + (text.enclose' text.double_quote) :abstraction)) (def: #export var @@ -142,24 +143,24 @@ (def: #export args (-> (List Var/1) Var/*) (|>> (list\map ..code) - (text.join-with " ") - ..as-form + (text.join_with " ") + ..as_form :abstraction)) (def: #export (args& singles rest) (-> (List Var/1) Var/1 Var/*) (|> (format (|> singles (list\map ..code) - (text.join-with " ")) + (text.join_with " ")) " &rest " (:representation rest)) - ..as-form + ..as_form :abstraction)) (def: form (-> (List (Expression Any)) Expression) (|>> (list\map ..code) - (text.join-with " ") - ..as-form + (text.join_with " ") + ..as_form :abstraction)) (def: #export (call/* func) @@ -178,8 +179,8 @@ (def: #export (labels definitions body) (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any)) (..form (list (..var "labels") - (..form (list\map (function (_ [def-name [def-args def-body]]) - (..form (list def-name (:transmutation def-args) def-body))) + (..form (list\map (function (_ [def_name [def_args def_body]]) + (..form (list def_name (:transmutation def_args) def_body))) definitions)) body))) @@ -189,15 +190,15 @@ (:transmutation bindings) expression body))) - (template [<call> <input-var>+ <input-type>+ <function>+] - [(`` (def: #export (<call> [(~~ (template.splice <input-var>+))] function) - (-> [(~~ (template.splice <input-type>+))] (Expression Any) (Computation Any)) - (..call/* function (list (~~ (template.splice <input-var>+)))))) + (template [<call> <input_var>+ <input_type>+ <function>+] + [(`` (def: #export (<call> [(~~ (template.splice <input_var>+))] function) + (-> [(~~ (template.splice <input_type>+))] (Expression Any) (Computation Any)) + (..call/* function (list (~~ (template.splice <input_var>+)))))) - (`` (template [<lux-name> <host-name>] - [(def: #export (<lux-name> args) - (-> [(~~ (template.splice <input-type>+))] (Computation Any)) - (<call> args (..var <host-name>)))] + (`` (template [<lux_name> <host_name>] + [(def: #export (<lux_name> args) + (-> [(~~ (template.splice <input_type>+))] (Computation Any)) + (<call> args (..var <host_name>)))] (~~ (template.splice <function>+))))] @@ -241,11 +242,11 @@ [format/3 "format"]]] ) - (template [<call> <input-type>+ <function>+] - [(`` (template [<lux-name> <host-name>] - [(def: #export (<lux-name> args) - (-> [(~~ (template.splice <input-type>+))] (Access Any)) - (:transmutation (<call> args (..var <host-name>))))] + (template [<call> <input_type>+ <function>+] + [(`` (template [<lux_name> <host_name>] + [(def: #export (<lux_name> args) + (-> [(~~ (template.splice <input_type>+))] (Access Any)) + (:transmutation (<call> args (..var <host_name>))))] (~~ (template.splice <function>+))))] @@ -260,7 +261,7 @@ [gethash/2 "gethash"]]] ) - (def: #export (make-hash-table/with-size size) + (def: #export (make-hash-table/with_size size) (-> (Expression Any) (Computation Any)) (..call/* (..var "make-hash-table") (list (..keyword "size") @@ -281,19 +282,19 @@ (-> [(Expression Any) (Expression Any)] (Computation Any)) (concatenate/3 [(..symbol "string") left right])) - (template [<lux-name> <host-name>] - [(def: #export (<lux-name> left right) + (template [<lux_name> <host_name>] + [(def: #export (<lux_name> left right) (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var <host-name>) left right)))] + (..form (list (..var <host_name>) left right)))] [or "or"] [and "and"] ) - (template [<lux-name> <host-name>] - [(def: #export (<lux-name> param subject) + (template [<lux_name> <host_name>] + [(def: #export (<lux_name> param subject) (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var <host-name>) subject param)))] + (..form (list (..var <host_name>) subject param)))] [= "="] [eq "eq"] @@ -329,10 +330,10 @@ (-> Var/* (Expression Any) Literal) (..form (list (..var "lambda") (:transmutation input) body))) - (template [<lux-name> <host-name>] - [(def: #export (<lux-name> bindings body) + (template [<lux_name> <host_name>] + [(def: #export (<lux_name> bindings body) (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any)) - (..form (list (..var <host-name>) + (..form (list (..var <host_name>) (|> bindings (list\map (function (_ [name value]) (..form (list name value)))) @@ -364,7 +365,7 @@ (..form (list (..var "setf") access value))) (type: #export Handler - {#condition-type (Expression Any) + {#condition_type (Expression Any) #condition Var/1 #body (Expression Any)}) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux new file mode 100644 index 000000000..887d639f1 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" common_lisp]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "common_lisp") + (|> bundle.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux new file mode 100644 index 000000000..dc81d4b18 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [common_lisp + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux new file mode 100644 index 000000000..d5d528631 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux @@ -0,0 +1,175 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" common_lisp (#+ Expression)]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" common_lisp #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.constant function)))) + +## TODO: Get rid of this ASAP +## (def: lux::syntax_char_case! +## (..custom [($_ <>.and +## <s>.any +## <s>.any +## (<>.some (<s>.tuple ($_ <>.and +## (<s>.tuple (<>.many <s>.i64)) +## <s>.any)))) +## (function (_ extension_name phase archive [input else conditionals]) +## (do {! /////.monad} +## [@input (\ ! map _.var (generation.gensym "input")) +## inputG (phase archive input) +## elseG (phase archive else) +## conditionalsG (: (Operation (List [Expression Expression])) +## (monad.map ! (function (_ [chars branch]) +## (do ! +## [branchG (phase archive branch)] +## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) +## branchG]))) +## conditionals))] +## (wrap (_.let (list [@input inputG]) +## (list\fold (function (_ [test then] else) +## (_.if test then else)) +## elseG +## conditionalsG)))))])) + +## (def: lux_procs +## Bundle +## (|> /.empty +## (/.install "syntax char case!" lux::syntax_char_case!) +## (/.install "is" (binary (product.uncurry _.eq?/2))) +## (/.install "try" (unary //runtime.lux//try)) +## )) + +## (def: (capped operation parameter subject) +## (-> (-> Expression Expression Expression) +## (-> Expression Expression Expression)) +## (//runtime.i64//64 (operation parameter subject))) + +## (def: i64_procs +## Bundle +## (<| (/.prefix "i64") +## (|> /.empty +## (/.install "and" (binary (product.uncurry //runtime.i64//and))) +## (/.install "or" (binary (product.uncurry //runtime.i64//or))) +## (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) +## (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) +## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) +## (/.install "=" (binary (product.uncurry _.=/2))) +## (/.install "<" (binary (product.uncurry _.</2))) +## (/.install "+" (binary (product.uncurry (..capped _.+/2)))) +## (/.install "-" (binary (product.uncurry (..capped _.-/2)))) +## (/.install "*" (binary (product.uncurry (..capped _.*/2)))) +## (/.install "/" (binary (product.uncurry //runtime.i64//division))) +## (/.install "%" (binary (product.uncurry _.remainder/2))) +## (/.install "f64" (unary (_.//2 (_.float +1.0)))) +## (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1))))) +## ))) + +## (def: f64_procs +## Bundle +## (<| (/.prefix "f64") +## (|> /.empty +## (/.install "=" (binary (product.uncurry _.=/2))) +## (/.install "<" (binary (product.uncurry _.</2))) +## (/.install "+" (binary (product.uncurry _.+/2))) +## (/.install "-" (binary (product.uncurry _.-/2))) +## (/.install "*" (binary (product.uncurry _.*/2))) +## (/.install "/" (binary (product.uncurry _.//2))) +## (/.install "%" (binary (product.uncurry _.remainder/2))) +## (/.install "i64" (unary _.truncate/1)) +## (/.install "encode" (unary _.number->string/1)) +## (/.install "decode" (unary //runtime.f64//decode))))) + +## (def: (text//index [offset sub text]) +## (Trinary Expression) +## (//runtime.text//index offset sub text)) + +## (def: (text//clip [paramO extraO subjectO]) +## (Trinary Expression) +## (//runtime.text//clip paramO extraO subjectO)) + +## (def: text_procs +## Bundle +## (<| (/.prefix "text") +## (|> /.empty +## (/.install "=" (binary (product.uncurry _.string=?/2))) +## (/.install "<" (binary (product.uncurry _.string<?/2))) +## (/.install "concat" (binary (product.uncurry _.string-append/2))) +## (/.install "index" (trinary ..text//index)) +## (/.install "size" (unary _.string-length/1)) +## (/.install "char" (binary (product.uncurry //runtime.text//char))) +## (/.install "clip" (trinary ..text//clip)) +## ))) + +## (def: (io//log! message) +## (Unary Expression) +## (_.begin (list (_.display/1 message) +## (_.display/1 (_.string text.new_line)) +## //runtime.unit))) + +## (def: io_procs +## Bundle +## (<| (/.prefix "io") +## (|> /.empty +## (/.install "log" (unary ..io//log!)) +## (/.install "error" (unary _.raise/1)) +## (/.install "current-time" (nullary (function.constant (//runtime.io//current_time //runtime.unit)))) +## ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + ## (dictionary.merge lux_procs) + ## (dictionary.merge i64_procs) + ## (dictionary.merge f64_procs) + ## (dictionary.merge text_procs) + ## (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux new file mode 100644 index 000000000..f6d164404 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" common_lisp (#+ Var Expression)]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" common_lisp #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (/.prefix "common_lisp") + (|> /.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux deleted file mode 100644 index f3afe14a6..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux +++ /dev/null @@ -1,60 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]]] - [/ - [runtime (#+ Phase)] - ["." primitive] - ["." structure] - ["." reference ("#\." system)] - ["." case] - ["." loop] - ["." function] - ["." /// - ["." extension] - [// - ["." synthesis]]]]) - -(def: #export (generate synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (\ ///.monad wrap (<generator> value))]) - ([synthesis.bit primitive.bit] - [synthesis.i64 primitive.i64] - [synthesis.f64 primitive.f64] - [synthesis.text primitive.text]) - - (^ (synthesis.variant variantS)) - (structure.variant generate variantS) - - (^ (synthesis.tuple members)) - (structure.tuple generate members) - - (#synthesis.Reference value) - (reference\reference value) - - (^ (synthesis.branch/case case)) - (case.case generate case) - - (^ (synthesis.branch/let let)) - (case.let generate let) - - (^ (synthesis.branch/if if)) - (case.if generate if) - - (^ (synthesis.loop/scope scope)) - (loop.scope generate scope) - - (^ (synthesis.loop/recur updates)) - (loop.recur generate updates) - - (^ (synthesis.function/abstraction abstraction)) - (function.function generate abstraction) - - (^ (synthesis.function/apply application)) - (function.apply generate application) - - (#synthesis.Extension extension) - (extension.apply generate extension))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux deleted file mode 100644 index 6953a9987..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux +++ /dev/null @@ -1,209 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] - [data - ["." text] - [number - ["n" nat]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [target - ["_" common-lisp (#+ Expression Var/1)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase)] - ["#." reference] - ["#." primitive] - ["#/" // - ["#." reference] - ["#/" // ("#\." monad) - [synthesis - ["." case]] - ["#/" // #_ - ["." reference (#+ Register)] - ["#." synthesis (#+ Synthesis Path)]]]]]) - -(def: #export register - (///reference.local _.var)) - -(def: #export capture - (///reference.foreign _.var)) - -(def: #export (let generate [valueS register bodyS]) - (-> Phase [Synthesis Register Synthesis] - (Operation (Expression Any))) - (do ////.monad - [valueG (generate valueS) - bodyG (generate bodyS)] - (wrap (_.let (list [(..register register) valueG]) - bodyG)))) - -(def: #export (record-get generate valueS pathP) - (-> Phase Synthesis (List (Either Nat Nat)) - (Operation (Expression Any))) - (do ////.monad - [valueG (generate valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueG - pathP)))) - -(def: #export (if generate [testS thenS elseS]) - (-> Phase [Synthesis Synthesis Synthesis] - (Operation (Expression Any))) - (do ////.monad - [testG (generate testS) - thenG (generate thenS) - elseG (generate elseS)] - (wrap (_.if testG thenG elseG)))) - -(def: @savepoint (_.var "lux_pm_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) -(def: @variant (_.var "lux_pm_variant")) - -(def: (push! value) - (-> (Expression Any) (Expression Any)) - (_.setq @cursor (_.cons/2 [value @cursor]))) - -(def: pop! - (Expression Any) - (_.setq @cursor (_.cdr/1 @cursor))) - -(def: peek - (Expression Any) - (_.car/1 @cursor)) - -(def: save! - (Expression Any) - (_.setq @savepoint (_.cons/2 [@cursor @savepoint]))) - -(def: restore! - (Expression Any) - ($_ _.progn - (_.setq @cursor (_.car/1 @savepoint)) - (_.setq @savepoint (_.cdr/1 @savepoint)))) - -(def: @fail (_.label "lux_pm_fail")) -(def: @done (_.label "lux_pm_done")) - -(def: fail! (_.return-from ..@fail _.nil)) - -(def: (multi-pop! pops) - (-> Nat (Expression Any)) - (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor]))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat (Expression Any)) - (.let [<failure-condition> (_.eq @variant @temp)] - (_.let (list [@variant ..peek]) - ($_ _.progn - (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>))) - (.if simple? - (_.when <failure-condition> - fail!) - (_.if <failure-condition> - fail! - (..push! @temp)) - )))))] - - [left-choice _.nil (<|)] - [right-choice (_.string "") inc] - ) - -(def: (alternation pre! post!) - (-> (Expression Any) (Expression Any) (Expression Any)) - (_.progn (<| (_.block ..@fail) - (_.progn ..save!) - pre!) - ($_ _.progn - ..restore! - post!))) - -(def: (pattern-matching' generate pathP) - (-> Phase Path (Operation (Expression Any))) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (\ ////.monad map (_.return-from ..@done) (generate bodyS)) - - #/////synthesis.Pop - (////\wrap ..pop!) - - (#/////synthesis.Bind register) - (////\wrap (_.setq (..register register) ..peek)) - - (^template [<tag> <format> <=>] - [(^ (<tag> value)) - (////\wrap (_.if (|> value <format> (<=> ..peek)) - _.nil - fail!))]) - ([/////synthesis.path/bit //primitive.bit _.equal] - [/////synthesis.path/i64 //primitive.i64 _.=] - [/////synthesis.path/f64 //primitive.f64 _.=] - [/////synthesis.path/text //primitive.text _.string=]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (////\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - (pattern-matching' generate) - (\ ////.monad map (_.progn (<choice> true idx))))]) - ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice] - [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) - - (^ (/////synthesis.member/left 0)) - (////\wrap (..push! (_.elt/2 [..peek (_.int +0)]))) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (////\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!multi-pop nextP)) - (.let [[extra-pops nextP'] (case.count-pops nextP)] - (do ////.monad - [next! (pattern-matching' generate nextP')] - (////\wrap ($_ _.progn - (..multi-pop! (n.+ 2 extra-pops)) - next!)))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ////.monad - [pre! (pattern-matching' generate preP) - post! (pattern-matching' generate postP)] - (wrap (<combinator> pre! post!)))]) - ([/////synthesis.path/alt ..alternation] - [/////synthesis.path/seq _.progn]))) - -(def: (pattern-matching generate pathP) - (-> Phase Path (Operation (Expression Any))) - (do ////.monad - [pattern-matching! (pattern-matching' generate pathP)] - (wrap (_.block ..@done - (_.progn (_.block ..@fail - pattern-matching!) - (_.error/1 (_.string case.pattern-matching-error))))))) - -(def: #export (case generate [valueS pathP]) - (-> Phase [Synthesis Path] (Operation (Expression Any))) - (do ////.monad - [initG (generate valueS) - pattern-matching! (pattern-matching generate pathP)] - (wrap (_.let (list [@cursor (_.list/* (list initG))] - [@savepoint (_.list/* (list))] - [@temp _.nil]) - pattern-matching!)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux deleted file mode 100644 index d68f22ef0..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux +++ /dev/null @@ -1,93 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." // #_ - [runtime (#+ Operation Phase)] - ["#." reference] - ["#." case] - ["#/" // - ["#." reference] - ["#/" // - ["." // #_ - [reference (#+ Register Variable)] - [arity (#+ Arity)] - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)]]]]]) - -(def: #export (apply generate [functionS argsS+]) - (-> Phase (Application Synthesis) (Operation (Expression Any))) - (do {! ////.monad} - [functionG (generate functionS) - argsG+ (monad.map ! generate argsS+)] - (wrap (_.funcall/+ [functionG argsG+])))) - -(def: #export capture - (///reference.foreign _.var)) - -(def: (with-closure function-name inits function-definition) - (-> Text (List (Expression Any)) (Expression Any) (Operation (Expression Any))) - (case inits - #.Nil - (\ ////.monad wrap function-definition) - - _ - (do {! ////.monad} - [@closure (\ ! map _.var (///.gensym "closure"))] - (wrap (_.labels (list [@closure [(|> (list.enumeration inits) - (list\map (|>> product.left ..capture)) - _.args) - function-definition]]) - (_.funcall/+ [(_.function/1 @closure) inits])))))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function generate [environment arity bodyS]) - (-> Phase (Abstraction Synthesis) (Operation (Expression Any))) - (do {! ////.monad} - [[function-name bodyG] (///.with-context - (do ! - [function-name ///.context] - (///.with-anchor (_.var function-name) - (generate bodyS)))) - closureG+ (: (Operation (List (Expression Any))) - (monad.map ! (\ //reference.system variable) environment)) - #let [@curried (_.var "curried") - @missing (_.var "missing") - arityG (|> arity .int _.int) - @num-args (_.var "num_args") - @self (_.var function-name) - initialize-self! [(//case.register 0) (_.function/1 @self)] - initialize! [(|> (list.indices arity) - (list\map ..input) - _.args) - @curried]]] - (with-closure function-name closureG+ - (_.labels (list [@self [(_.args& (list) @curried) - (_.let (list [@num-args (_.length/1 @curried)]) - (_.cond (list [(|> @num-args (_.= arityG)) - (_.let (list initialize-self!) - (_.destructuring-bind initialize! - bodyG))] - - [(|> @num-args (_.> arityG)) - (let [arity-inputs (_.subseq/3 [@curried (_.int +0) arityG]) - extra-inputs (_.subseq/3 [@curried arityG @num-args])] - (_.apply/2 [(_.apply/2 [(_.function/1 @self) - arity-inputs]) - extra-inputs]))]) - ## (|> @num-args (_.< arityG)) - (_.lambda (_.args& (list) @missing) - (_.apply/2 [(_.function/1 @self) - (_.append/2 [@curried @missing])]))))]]) - (_.function/1 @self))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux deleted file mode 100644 index bc214399e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [number - ["n" nat]] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." // #_ - [runtime (#+ Operation Phase)] - ["#." case] - ["#/" // - ["#/" // - [// - [synthesis (#+ Scope Synthesis)]]]]]) - -(def: #export (scope generate [start initsS+ bodyS]) - (-> Phase (Scope Synthesis) (Operation (Expression Any))) - (do {! ////.monad} - [@scope (\ ! map (|>> %.nat (format "scope") _.var) ///.next) - initsG+ (monad.map ! generate initsS+) - bodyG (///.with-anchor @scope - (generate bodyS))] - (wrap (_.labels (list [@scope {#_.input (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register)) - _.args) - #_.output bodyG}]) - (_.funcall/+ [(_.function/1 @scope) initsG+]))))) - -(def: #export (recur generate argsS+) - (-> Phase (List Synthesis) (Operation (Expression Any))) - (do {! ////.monad} - [@scope ///.anchor - argsO+ (monad.map ! generate argsS+)] - (wrap (_.call/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux deleted file mode 100644 index 206f3f0e9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #* - [target - ["_" common-lisp (#+ Expression)]]] - [/// - ["." reference]]) - -(def: #export system - (reference.system (: (-> Text (Expression Any)) _.var) - (: (-> Text (Expression Any)) _.var))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux deleted file mode 100644 index 2d9017bcb..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux +++ /dev/null @@ -1,288 +0,0 @@ -(.module: - [lux (#- inc) - [abstract - [monad (#+ do)]] - [control - ["." function] - ["p" parser - ["s" code]]] - [data - [number (#+ hex) - ["." i64]] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - ["." macro - ["." code] - [syntax (#+ syntax:)]] - [target - ["_" common-lisp (#+ Expression Var/1 Computation Literal)]]] - ["." /// - ["//." // - [// - ["/////." name] - ["." synthesis]]]] - ) - -(template [<name> <base>] - [(type: #export <name> - (<base> Var/1 (Expression Any) (Expression Any)))] - - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] - ) - -(def: prefix "LuxRuntime") - -(def: #export unit (_.string synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) - (_.list/* (list tag last? value))) - -(def: #export (variant tag last? value) - (-> Nat Bit (Expression Any) (Computation Any)) - (variant' (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - (Computation Any) - (..variant 0 false ..unit)) - -(def: #export some - (-> (Expression Any) (Computation Any)) - (..variant 1 true)) - -(def: #export left - (-> (Expression Any) (Computation Any)) - (..variant 0 false)) - -(def: #export right - (-> (Expression Any) (Computation Any)) - (..variant 1 true)) - -(def: runtime-name - (-> Text Var/1) - (|>> /////name.normalize - (format ..prefix "_") - _.var)) - -(def: (feature name definition) - (-> Var/1 (-> Var/1 (Expression Any)) (Expression Any)) - (definition name)) - -(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list\map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (/////name.normalize var)))))))) - list.concat))] - (~ body)))))) - -(syntax: (runtime: {declaration (p.or s.local-identifier - (s.form (p.and s.local-identifier - (p.some s.local-identifier))))} - code) - (macro.with-gensyms [g!_ g!L] - (case declaration - (#.Left name) - (let [code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name))))] - (wrap (list (` (def: #export (~ (code.local-identifier name)) _.Var/1 (~ runtime-nameC))) - (` (def: (~ code-nameC) - (_.Expression Any) - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ g!L)) - (_.defparameter (~ g!L) (~ code))))))))) - - (#.Right [name inputs]) - (let [code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name)))) - inputsC (list\map code.local-identifier inputs) - inputs-typesC (list\map (function.constant (` (_.Expression Any))) - inputs)] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~+ inputsC)) - (-> (~+ inputs-typesC) (_.Computation Any)) - (_.call/* (~ runtime-nameC) (list (~+ inputsC))))) - (` (def: (~ code-nameC) - (_.Expression Any) - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ g!L)) - (..with-vars [(~+ inputsC)] - (_.defun (~ g!L) (_.args (list (~+ inputsC))) - (~ code))))))))))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.handler-case - (list [(_.bool true) error - (..left (_.format/3 [_.nil (_.string "~A") error]))]) - (..right (_.funcall/+ [op (list ..unit)]))))) - -## TODO: Use Common Lisp's swiss-army loop macro instead. -(runtime: (lux//program-args inputs) - (with-vars [loop input tail] - (_.labels (list [loop [(_.args (list input tail)) - (_.if (_.null/1 input) - tail - (_.funcall/+ [(_.function/1 loop) - (list (_.cdr/1 input) - (..some (_.vector/* (list (_.car/1 input) tail))))]))]]) - (_.funcall/+ [(_.function/1 loop) - (list (_.reverse/1 inputs) - ..none)])))) - -(def: runtime//lux - ($_ _.progn - @lux//try - @lux//program-args - )) - -(def: last-index - (|>> _.length/1 (_.- (_.int +1)))) - -(with-expansions [<recur> (as-is ($_ _.then - (_.; (_.set lefts (_.- last-index-right lefts))) - (_.; (_.set tuple (_.nth last-index-right tuple)))))] - (template: (!recur <side>) - (<side> (|> lefts (_.- last-index-right)) - (_.elt/2 [tuple last-index-right]))) - - (runtime: (tuple//left lefts tuple) - (with-vars [last-index-right] - (_.let (list [last-index-right (..last-index tuple)]) - (_.if (_.> lefts last-index-right) - ## No need for recursion - (_.elt/2 [tuple lefts]) - ## Needs recursion - (!recur tuple//left))))) - - (runtime: (tuple//right lefts tuple) - (with-vars [last-index-right right-index] - (_.let (list [last-index-right (..last-index tuple)] - [right-index (_.+ (_.int +1) lefts)]) - (_.cond (list [(_.= last-index-right right-index) - (_.elt/2 [tuple right-index])] - [(_.> last-index-right right-index) - ## Needs recursion. - (!recur tuple//right)]) - (_.subseq/3 [tuple right-index (_.length/1 tuple)])) - )))) - -## TODO: Find a way to extract parts of the sum without "nth", which -## does a linear search, and is thus expensive. -(runtime: (sum//get sum wantsLast wantedTag) - (with-vars [sum-tag sum-flag] - (let [@exit (_.label "exit") - return! (_.return-from @exit) - no-match! (return! sum) - sum-value (_.nth/2 [(_.int +2) sum]) - test-recursion! (_.if sum-flag - ## Must iterate. - ($_ _.progn - (_.setq wantedTag (_.- sum-tag wantedTag)) - (_.setq sum sum-value)) - no-match!)] - (<| (_.progn (_.setq sum-tag (_.nth/2 [(_.int +0) sum]))) - (_.progn (_.setq sum-flag (_.nth/2 [(_.int +1) sum]))) - (_.block @exit) - (_.while (_.bool true)) - (_.cond (list [(_.= sum-tag wantedTag) - (_.if (_.equal wantsLast sum-flag) - (return! sum-value) - test-recursion!)] - - [(_.> sum-tag wantedTag) - test-recursion!] - - [(_.and (_.< sum-tag wantedTag) - wantsLast) - (return! (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) - - no-match!))))) - -(def: runtime//adt - ($_ _.progn - @tuple//left - @tuple//right - @sum//get - )) - -(runtime: (i64//logic-right-shift shift input) - (_.if (_.= (_.int +0) shift) - input - (|> input - (_.ash (_.* (_.int -1) shift)) - (_.logand (_.int (hex "+7FFFFFFFFFFFFFFF")))))) - -(def: runtime//i64 - ($_ _.progn - @i64//logic-right-shift - )) - -(runtime: (text//clip from to text) - (_.subseq/3 [text from to])) - -(runtime: (text//index reference start space) - (with-vars [index] - (_.let (list [index (_.search/3 [reference space start])]) - (_.if index - (..some index) - ..none)))) - -(def: runtime//text - ($_ _.progn - @text//index - @text//clip - )) - -(runtime: (io//exit code) - ($_ _.progn - (_.conditional+ (list "sbcl") - (_.call/* (_.var "sb-ext:quit") (list code))) - (_.conditional+ (list "clisp") - (_.call/* (_.var "ext:exit") (list code))) - (_.conditional+ (list "ccl") - (_.call/* (_.var "ccl:quit") (list code))) - (_.conditional+ (list "allegro") - (_.call/* (_.var "excl:exit") (list code))) - (_.call/* (_.var "cl-user::quit") (list code)))) - -(runtime: (io//current-time _) - (|> (_.get-universal-time/0 []) - (_.* (_.int +1,000)))) - -(def: runtime//io - ($_ _.progn - @io//exit - @io//current-time - )) - -(def: runtime - ($_ _.progn - runtime//adt - runtime//lux - runtime//i64 - runtime//text - runtime//io)) - -(def: #export artifact ..prefix) - -(def: #export generate - (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.execute! ..runtime) - _ (///.save! ..prefix ..runtime)] - (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux deleted file mode 100644 index 45241a601..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase)] - ["#." primitive] - ["//#" /// - ["/#" // #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)]]]]) - -(def: #export (tuple generate elemsS+) - (-> Phase (Tuple Synthesis) (Operation (Expression Any))) - (case elemsS+ - #.Nil - (\ ////.monad wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate singletonS) - - _ - (|> elemsS+ - (monad.map ////.monad generate) - (\ ////.monad map _.vector/*)))) - -(def: #export (variant generate [lefts right? valueS]) - (-> Phase (Variant Synthesis) (Operation (Expression Any))) - (\ ////.monad map - (//runtime.variant (if right? - (inc lefts) - lefts) - right?) - (generate valueS))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux new file mode 100644 index 000000000..7b81d9d4a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux @@ -0,0 +1,56 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux new file mode 100644 index 000000000..252532489 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux @@ -0,0 +1,241 @@ +(.module: + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [data + ["." text] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["n" nat]]] + [target + ["_" common_lisp (#+ Expression Var/1)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register Var/1) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register Var/1) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS) + bodyG (expression archive bodyS)] + (wrap (_.let (list [(..register register) valueG]) + bodyG)))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testG (expression archive testS) + thenG (expression archive thenS) + elseG (expression archive elseS)] + (wrap (_.if testG thenG elseG)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueG + pathP)))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @variant (_.var "lux_pm_variant")) + +(def: (push! value) + (-> (Expression Any) (Expression Any)) + (_.setq @cursor (_.cons/2 [value @cursor]))) + +(def: pop! + (Expression Any) + (_.setq @cursor (_.cdr/1 @cursor))) + +(def: peek + (Expression Any) + (_.car/1 @cursor)) + +(def: save! + (Expression Any) + (_.setq @savepoint (_.cons/2 [@cursor @savepoint]))) + +(def: restore! + (Expression Any) + ($_ _.progn + (_.setq @cursor (_.car/1 @savepoint)) + (_.setq @savepoint (_.cdr/1 @savepoint)))) + +(def: @fail (_.label "lux_pm_fail")) +(def: @done (_.label "lux_pm_done")) + +(def: fail! (_.return-from ..@fail _.nil)) + +(def: (multi_pop! pops) + (-> Nat (Expression Any)) + (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor]))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat (Expression Any)) + (.let [<failure_condition> (_.eq @variant @temp)] + (_.let (list [@variant ..peek]) + ($_ _.progn + (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>))) + (.if simple? + (_.when <failure_condition> + fail!) + (_.if <failure_condition> + fail! + (..push! @temp)) + )))))] + + [left_choice _.nil (<|)] + [right_choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> (Expression Any) (Expression Any) (Expression Any)) + (_.progn (<| (_.block ..@fail) + (_.progn ..save!) + pre!) + ($_ _.progn + ..restore! + post!))) + +(def: (pattern_matching' expression archive) + (Generator Path) + (function (recur pathP) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (\ ///////phase.monad map (_.return-from ..@done) (expression archive bodyS)) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.setq (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format> <=>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([#/////synthesis.I64_Fork //primitive.i64 _.=] + [#/////synthesis.F64_Fork //primitive.f64 _.=] + [#/////synthesis.Text_Fork //primitive.text _.string=]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + recur + (\ ///////phase.monad map (_.progn (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (..push! (_.elt/2 [..peek (_.int +0)]))) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!multi_pop nextP)) + (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + (do ///////phase.monad + [next! (recur nextP')] + (///////phase\wrap ($_ _.progn + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (^template [<tag> <combinator>] + [(^ (<tag> preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap (<combinator> pre! post!)))]) + ([/////synthesis.path/alt ..alternation] + [/////synthesis.path/seq _.progn])))) + +(def: (pattern_matching expression archive pathP) + (Generator Path) + (do ///////phase.monad + [pattern_matching! (pattern_matching' expression archive pathP)] + (wrap (_.block ..@done + (_.progn (_.block ..@fail + pattern_matching!) + (_.error/1 (_.string ////synthesis/case.pattern_matching_error))))))) + +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do ///////phase.monad + [initG (expression archive valueS) + pattern_matching! (pattern_matching expression archive pathP)] + (wrap (_.let (list [@cursor (_.list/* (list initG))] + [@savepoint (_.list/* (list))] + [@temp _.nil]) + pattern_matching!)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux index 3bc0a0887..3bc0a0887 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux index 750688dd6..750688dd6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux new file mode 100644 index 000000000..7f4134c86 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux @@ -0,0 +1,97 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" common_lisp (#+ Expression Var/1)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionG (expression archive functionS) + argsG+ (monad.map ! (expression archive) argsS+)] + (wrap (_.funcall/+ [functionG argsG+])))) + +(def: capture + (-> Register Var/1) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure inits function_definition) + (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any))) + (case inits + #.Nil + (\ ///////phase.monad wrap function_definition) + + _ + (do {! ///////phase.monad} + [@closure (\ ! map _.var (/////generation.gensym "closure"))] + (wrap (_.labels (list [@closure [(|> (list.enumeration inits) + (list\map (|>> product.left ..capture)) + _.args) + function_definition]]) + (_.funcall/+ [(_.function/1 @closure) inits])))))) + +(def: input + (|>> inc //case.register)) + +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [[function_name bodyG] (/////generation.with_new_context archive + (do ! + [@self (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor @self + (expression archive bodyS)))) + closureG+ (monad.map ! (expression archive) environment) + #let [@curried (_.var "curried") + @missing (_.var "missing") + arityG (|> arity .int _.int) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact function_name)) + initialize_self! [(//case.register 0) (_.function/1 @self)] + initialize! [(|> (list.indices arity) + (list\map ..input) + _.args) + @curried]]] + (with_closure closureG+ + (_.labels (list [@self [(_.args& (list) @curried) + (_.let (list [@num_args (_.length/1 @curried)]) + (_.cond (list [(|> @num_args (_.= arityG)) + (_.let (list initialize_self!) + (_.destructuring-bind initialize! + bodyG))] + + [(|> @num_args (_.> arityG)) + (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG]) + extra_inputs (_.subseq/3 [@curried arityG @num_args])] + (_.apply/2 [(_.apply/2 [(_.function/1 @self) + arity_inputs]) + extra_inputs]))]) + ## (|> @num_args (_.< arityG)) + (_.lambda (_.args& (list) @missing) + (_.apply/2 [(_.function/1 @self) + (_.append/2 [@curried @missing])]))))]]) + (_.function/1 @self))) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux new file mode 100644 index 000000000..32275cdc3 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux @@ -0,0 +1,53 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] + [target + ["_" common_lisp (#+ Expression)]]] + ["." // #_ + [runtime (#+ Operation Phase Generator)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export (scope expression archive [start initsS+ bodyS]) + (Generator (Scope Synthesis)) + (do {! ///////phase.monad} + [@scope (\ ! map (|>> %.nat (format "scope") _.var) /////generation.next) + initsG+ (monad.map ! (expression archive) initsS+) + bodyG (/////generation.with_anchor @scope + (expression archive bodyS))] + (wrap (_.labels (list [@scope {#_.input (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register)) + _.args) + #_.output bodyG}]) + (_.funcall/+ [(_.function/1 @scope) initsG+]))))) + +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [@scope /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.call/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux index 4177f814a..7840ccccc 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux @@ -2,11 +2,8 @@ [lux (#- i64) [control [pipe (#+ cond> new>)]] - [data - [number - ["." frac]]] [target - ["_" common-lisp (#+ Expression)]]] + ["_" common_lisp (#+ Expression)]]] ["." // #_ ["#." runtime]]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux new file mode 100644 index 000000000..977396fab --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux @@ -0,0 +1,12 @@ +(.module: + [lux #* + [target + ["_" common_lisp (#+ Expression)]]] + [/// + [reference (#+ System)]]) + +(structure: #export system + (System (Expression Any)) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux new file mode 100644 index 000000000..3ac79fa7d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux @@ -0,0 +1,305 @@ +(.module: + [lux (#- Location inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target + ["_" common_lisp (#+ Expression Var/1 Computation Literal)]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) + +(template [<name> <base>] + [(type: #export <name> + (<base> Var/1 (Expression Any) (Expression Any)))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation (Expression Any)))) + +(def: #export unit + (_.string /////synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (_.list/* (list tag last? value))) + +(def: #export (variant [lefts right? value]) + (-> (Variant (Expression Any)) (Computation Any)) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + (Computation Any) + (|> ..unit [0 #0] ..variant)) + +(def: #export some + (-> (Expression Any) (Computation Any)) + (|>> [1 #1] ..variant)) + +(def: #export left + (-> (Expression Any) (Computation Any)) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> (Expression Any) (Computation Any)) + (|>> [1 #1] ..variant)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name))] + (wrap (list (` (def: #export (~ g!name) + _.Var/1 + (~ runtime_name))) + + (` (def: (~ code_nameC) + (_.Expression Any) + (_.defparameter (~ runtime_name) (~ code))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name)) + + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` (_.Expression Any))) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) (_.Computation Any)) + (_.call/* (~ runtime_name) (list (~+ inputsC))))) + + (` (def: (~ code_nameC) + (_.Expression Any) + (..with_vars [(~+ inputsC)] + (_.defun (~ runtime_name) (_.args (list (~+ inputsC))) + (~ code))))))))))))) + +(runtime: (lux//try op) + (with_vars [error] + (_.handler-case + (list [(_.bool true) error + (..left (_.format/3 [_.nil (_.string "~A") error]))]) + (..right (_.funcall/+ [op (list ..unit)]))))) + +## TODO: Use Common Lisp's swiss-army loop macro instead. +(runtime: (lux//program_args inputs) + (with_vars [loop input tail] + (_.labels (list [loop [(_.args (list input tail)) + (_.if (_.null/1 input) + tail + (_.funcall/+ [(_.function/1 loop) + (list (_.cdr/1 input) + (..some (_.vector/* (list (_.car/1 input) tail))))]))]]) + (_.funcall/+ [(_.function/1 loop) + (list (_.reverse/1 inputs) + ..none)])))) + +(def: runtime//lux + ($_ _.progn + @lux//try + @lux//program_args + )) + +(def: last_index + (|>> _.length/1 (_.- (_.int +1)))) + +(with_expansions [<recur> (as_is ($_ _.then + (_.; (_.set lefts (_.- last_index_right lefts))) + (_.; (_.set tuple (_.nth last_index_right tuple)))))] + (template: (!recur <side>) + (<side> (|> lefts (_.- last_index_right)) + (_.elt/2 [tuple last_index_right]))) + + (runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (_.let (list [last_index_right (..last_index tuple)]) + (_.if (_.> lefts last_index_right) + ## No need for recursion + (_.elt/2 [tuple lefts]) + ## Needs recursion + (!recur tuple//left))))) + + (runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (_.let (list [last_index_right (..last_index tuple)] + [right_index (_.+ (_.int +1) lefts)]) + (_.cond (list [(_.= last_index_right right_index) + (_.elt/2 [tuple right_index])] + [(_.> last_index_right right_index) + ## Needs recursion. + (!recur tuple//right)]) + (_.subseq/3 [tuple right_index (_.length/1 tuple)])) + )))) + +## TODO: Find a way to extract parts of the sum without "nth", which +## does a linear search, and is thus expensive. +(runtime: (sum//get sum wantsLast wantedTag) + (with_vars [sum_tag sum_flag] + (let [@exit (_.label "exit") + return! (_.return-from @exit) + no_match! (return! sum) + sum_value (_.nth/2 [(_.int +2) sum]) + test_recursion! (_.if sum_flag + ## Must iterate. + ($_ _.progn + (_.setq wantedTag (_.- sum_tag wantedTag)) + (_.setq sum sum_value)) + no_match!)] + (<| (_.progn (_.setq sum_tag (_.nth/2 [(_.int +0) sum]))) + (_.progn (_.setq sum_flag (_.nth/2 [(_.int +1) sum]))) + (_.block @exit) + (_.while (_.bool true)) + (_.cond (list [(_.= sum_tag wantedTag) + (_.if (_.equal wantsLast sum_flag) + (return! sum_value) + test_recursion!)] + + [(_.> sum_tag wantedTag) + test_recursion!] + + [(_.and (_.< sum_tag wantedTag) + wantsLast) + (return! (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) + + no_match!))))) + +(def: runtime//adt + ($_ _.progn + @tuple//left + @tuple//right + @sum//get + )) + +(runtime: (i64//logic_right_shift shift input) + (_.if (_.= (_.int +0) shift) + input + (|> input + (_.ash (_.* (_.int -1) shift)) + (_.logand (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + +(def: runtime//i64 + ($_ _.progn + @i64//logic_right_shift + )) + +(runtime: (text//clip from to text) + (_.subseq/3 [text from to])) + +(runtime: (text//index reference start space) + (with_vars [index] + (_.let (list [index (_.search/3 [reference space start])]) + (_.if index + (..some index) + ..none)))) + +(def: runtime//text + ($_ _.progn + @text//index + @text//clip + )) + +(runtime: (io//exit code) + ($_ _.progn + (_.conditional+ (list "sbcl") + (_.call/* (_.var "sb-ext:quit") (list code))) + (_.conditional+ (list "clisp") + (_.call/* (_.var "ext:exit") (list code))) + (_.conditional+ (list "ccl") + (_.call/* (_.var "ccl:quit") (list code))) + (_.conditional+ (list "allegro") + (_.call/* (_.var "excl:exit") (list code))) + (_.call/* (_.var "cl-user::quit") (list code)))) + +(runtime: (io//current_time _) + (|> (_.get-universal-time/0 []) + (_.* (_.int +1,000)))) + +(def: runtime//io + ($_ _.progn + @io//exit + @io//current_time + )) + +(def: runtime + ($_ _.progn + runtime//adt + runtime//lux + runtime//i64 + runtime//text + runtime//io + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux new file mode 100644 index 000000000..566fc148e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [target + ["_" common_lisp (#+ Expression)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.vector/*)))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> [tag right?] //runtime.variant) + (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux index 815b5a8a5..f27dc1154 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -79,31 +79,29 @@ runtime_name (` (_.var (~ (code.text (%.code runtime)))))] (case declaration (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Computation - (_.define_constant (~ runtime_name) (~ code)))))))) + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Computation + (_.define_constant (~ runtime_name) (~ code))))))) (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) _.Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Computation - (..with_vars [(~+ inputsC)] - (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None] - (~ code)))))))))))))) + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) _.Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Computation + (..with_vars [(~+ inputsC)] + (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None] + (~ code))))))))))))) (def: last_index (-> Expression Computation) |