diff options
Diffstat (limited to 'lux-cl')
| -rw-r--r-- | lux-cl/project.clj | 30 | ||||
| -rw-r--r-- | lux-cl/source/program.lux | 322 |
2 files changed, 352 insertions, 0 deletions
diff --git a/lux-cl/project.clj b/lux-cl/project.clj new file mode 100644 index 000000000..4e9d6a68a --- /dev/null +++ b/lux-cl/project.clj @@ -0,0 +1,30 @@ +(def version "0.6.0-SNAPSHOT") +(def repo "https://github.com/LuxLang/lux") +(def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") +(def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") + +(defproject com.github.luxlang/lux-cl #=(identity version) + :description "A Common Lisp compiler for Lux." + :url ~repo + :license {:name "Lux License v0.1" + :url ~(str repo "/blob/master/license.txt")} + :scm {:name "git" + :url ~(str repo ".git")} + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + + :repositories [["releases" ~sonatype-releases] + ["snapshots" ~sonatype-snapshots]] + :deploy-repositories [["releases" {:url ~sonatype-releases :creds :gpg}] + ["snapshots" {:url ~sonatype-snapshots :creds :gpg}]] + + :plugins [[com.github.luxlang/lein-luxc ~version]] + :dependencies [[com.github.luxlang/luxc-jvm ~version] + [com.github.luxlang/stdlib ~version] + [org.abcl/abcl "1.5.0"]] + + :manifest {"lux" ~version} + :source-paths ["source"] + :lux {:program "program"} + ) 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)) |