aboutsummaryrefslogtreecommitdiff
path: root/lux-cl/source
diff options
context:
space:
mode:
authorEduardo Julian2021-05-25 01:55:09 -0400
committerEduardo Julian2021-05-25 01:55:09 -0400
commit2df8e4bc8c53a831f3cd8605707ca08d66cecb02 (patch)
tree839af4a3c1b2c1629946111d58373946d367becc /lux-cl/source
parentf01e246f468c948d41423248809443570f48c7a4 (diff)
Updates for Common-Lisp compiler.
Diffstat (limited to 'lux-cl/source')
-rw-r--r--lux-cl/source/program.lux476
1 files changed, 291 insertions, 185 deletions
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 []))))))