aboutsummaryrefslogtreecommitdiff
path: root/lux-cl/source
diff options
context:
space:
mode:
authorEduardo Julian2019-05-01 20:33:42 -0400
committerEduardo Julian2019-05-01 20:33:42 -0400
commitc923517c864dad362ef00ae78b449bb40cc27e84 (patch)
treea758099e76424db4fc8ec8d8cc18a8a699d68d66 /lux-cl/source
parent0c20f4a8362d42572edecb6ef9844b75c4c859f8 (diff)
The Common Lisp compiler is alive.
Diffstat (limited to 'lux-cl/source')
-rw-r--r--lux-cl/source/program.lux322
1 files changed, 322 insertions, 0 deletions
diff --git a/lux-cl/source/program.lux b/lux-cl/source/program.lux
new file mode 100644
index 000000000..fc1f37765
--- /dev/null
+++ b/lux-cl/source/program.lux
@@ -0,0 +1,322 @@
+(.module:
+ [lux #*
+ ["." host (#+ import: interface: do-to object)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ new> case>)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ [parser
+ [cli (#+ program:)]]]
+ [data
+ ["." maybe]
+ ["." error (#+ Error)]
+ [number
+ ["." i64]]
+ ["." text ("#/." hash)
+ format]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#/." functor)]]]
+ [macro
+ ["." template]]
+ [world
+ ["." file]]
+ ["." debug]
+ [target
+ ["_" common-lisp]]
+ [tool
+ [compiler
+ ["." name]
+ ["." synthesis]
+ [phase
+ [macro (#+ Expander)]
+ ["." generation
+ ["." common-lisp
+ ["." runtime]
+ ["." extension]]]]
+ [default
+ ["." platform (#+ Platform)]]]]]
+ [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))
+
+## 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))
+
+(import: #long org/armedbear/lisp/Symbol
+ (#static T org/armedbear/lisp/Symbol))
+
+(import: #long org/armedbear/lisp/DoubleFloat
+ (new [double])
+ (doubleValue [] double))
+
+(import: #long org/armedbear/lisp/SimpleString
+ (new [java/lang/String])
+ (getStringValue [] java/lang/String))
+
+(import: #long org/armedbear/lisp/LispInteger)
+
+(import: #long 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))
+
+(import: #long org/armedbear/lisp/Nil
+ (#static NIL org/armedbear/lisp/Symbol))
+
+(import: #long org/armedbear/lisp/SimpleVector)
+
+(import: #long org/armedbear/lisp/Cons)
+
+(import: #long org/armedbear/lisp/Closure)
+
+(interface: LuxADT
+ (getValue [] java/lang/Object))
+
+(import: #long program/LuxADT
+ (getValue [] java/lang/Object))
+
+(template [<name>]
+ [(exception: (<name> {object java/lang/Object})
+ (exception.report
+ ["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]
+ )
+
+(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)
+ (-> 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)]
+ (`` (<| (~~ (template [<type> <then>]
+ [(case (host.check <type> sub-value)
+ (#.Some sub-value)
+ (`` (|> sub-value (~~ (template.splice <then>))))
+ #.None)]
+
+ [(Array 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]
+ []
+ ## Methods
+ (program/LuxADT
+ (getValue) java/lang/Object
+ (:coerce java/lang/Object value))
+
+ (org/armedbear/lisp/LispObject
+ (length)
+ int
+ (|> value
+ (:coerce (Array java/lang/Object))
+ array.size
+ (:coerce java/lang/Long)
+ java/lang/Number::intValue))
+
+ (~~ (template [<name>]
+ [(org/armedbear/lisp/LispObject
+ (<name> {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)
+
+ #.None
+ (org/armedbear/lisp/Nil::NIL)))]
+
+ [NTH] [SVREF] [elt]
+ ))
+ ))))
+
+(type: (Reader a)
+ (-> a (Error Any)))
+
+(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))]
+ (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))
+ (#.Some _)
+ (: Any (host.null))
+
+ _
+ (: Any synthesis.unit))
+ value])))
+
+(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))]
+ (loop [idx 0
+ output (:coerce (Array Any) (array.new size))]
+ (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)
+
+ (#error.Success member)
+ (recur (inc idx) (array.write idx (:coerce Any member) output)))
+ (#error.Success output)))))
+
+(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>))))
+
+ #.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)))
+
+ #.None)
+ ## else
+ (exception.throw unknown-kind-of-object (:coerce java/lang/Object host-object))
+ )))
+
+(def: ensure-macro
+ (-> Macro (Maybe org/armedbear/lisp/Closure))
+ (|>> (:coerce java/lang/Object) (host.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: (expander macro inputs lux)
+ Expander
+ (case (ensure-macro macro)
+ (#.Some 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)))
+
+(def: host
+ (IO Host)
+ (io (let [_ (org/armedbear/lisp/Interpreter::createInstance)
+ interpreter (org/armedbear/lisp/Interpreter::getInstance)]
+ (: Host
+ (structure
+ (def: (evaluate! alias input)
+ (do error.monad
+ [host-value (org/armedbear/lisp/Interpreter::eval (_.code input) interpreter)]
+ (read host-value)))
+
+ (def: (execute! alias 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)))
+ @global (_.var global)]
+ (do error.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])))))))))
+
+(def: platform
+ (IO (Platform IO _.Var/1 (_.Expression Any) (_.Expression Any)))
+ (do io.monad
+ [host ..host]
+ (wrap {#platform.&monad io.monad
+ #platform.&file-system file.system
+ #platform.host host
+ #platform.phase common-lisp.generate
+ #platform.runtime runtime.generate})))
+
+(def: 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 "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))