diff options
Diffstat (limited to '')
31 files changed, 1735 insertions, 1858 deletions
diff --git a/.gitignore b/.gitignore index a5e435077..15b96b13d 100644 --- a/.gitignore +++ b/.gitignore @@ -51,3 +51,9 @@ pom.xml.asc /lux-php/source/program /lux-php/source/spec +/lux-cl/target +/lux-cl/source/lux.lux +/lux-cl/source/lux +/lux-cl/source/program +/lux-cl/source/spec + @@ -9,7 +9,8 @@ cd ~/lux/lux-js/ && lein clean && \ cd ~/lux/lux-python/ && lein clean && \ cd ~/lux/lux-lua/ && lein clean && \ cd ~/lux/lux-ruby/ && lein clean && \ -cd ~/lux/lux-php/ && lein clean +cd ~/lux/lux-php/ && lein clean && \ +cd ~/lux/lux-cl/ && lein clean # Old Lux compiler # Re-build and re-install @@ -88,6 +89,16 @@ cd ~/lux/lux-php/ && lein clean # Try cd ~/lux/lux-php/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +# Common Lisp compiler + # Test + cd ~/lux/lux-cl/ && lein_2_7_1 lux auto test + cd ~/lux/lux-cl/ && lein clean && lein_2_7_1 lux auto test + # Build + cd ~/lux/lux-cl/ && lein_2_7_1 lux auto build + cd ~/lux/lux-cl/ && lein clean && lein_2_7_1 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 + # Run compiler test suite cd ~/lux/new-luxc/ && lein_2_7_1 lux auto test cd ~/lux/new-luxc/ && lein clean && lein_2_7_1 lux auto test 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)) diff --git a/new-luxc/project.clj b/new-luxc/project.clj index f3864bf06..322800e29 100644 --- a/new-luxc/project.clj +++ b/new-luxc/project.clj @@ -25,8 +25,6 @@ [org.ow2.asm/asm-all "5.0.3"] ;; ;; Scheme ;; [kawa-scheme/kawa-core "2.4"] - ;; ;; Common Lisp - ;; [org.abcl/abcl "1.5.0"] ] :manifest {"lux" ~version} diff --git a/new-luxc/source/luxc/lang/host/common-lisp.lux b/new-luxc/source/luxc/lang/host/common-lisp.lux deleted file mode 100644 index 50a942636..000000000 --- a/new-luxc/source/luxc/lang/host/common-lisp.lux +++ /dev/null @@ -1,365 +0,0 @@ -(.module: - [lux #- not or and list if function cond when let] - (lux (control pipe) - (data [maybe "maybe/" Functor<Maybe>] - [text] - text/format - [number] - (coll [list "list/" Functor<List> Fold<List>])) - (type abstract))) - -(abstract: #export Single {} Any) -(abstract: #export Poly {} Any) - -(abstract: #export (Var kind) - {} - - Text - - (def: name (All [k] (-> (Var k) Text)) (|>> :representation)) - - (def: #export var (-> Text (Var Single)) (|>> :abstraction)) - - (def: #export (poly vars) - (-> (List (Var Single)) (Var Poly)) - (:abstraction - (format "(" (|> vars (list/map ..name) (text.join-with " ")) ")"))) - - (def: #export (poly+ vars rest) - (-> (List (Var Single)) (Var Single) (Var Poly)) - (:abstraction - (format "(" (|> vars (list/map ..name) (text.join-with " ")) - " &rest " (..name rest) - ")"))) - ) - -(type: #export SVar (Var Single)) -(type: #export PVar (Var Poly)) -(type: #export *Var (Ex [k] (Var k))) - -(abstract: #export Expression - {} - - Text - - (def: #export expression (-> Expression Text) (|>> :representation)) - - (def: #export code (-> Text Expression) (|>> :abstraction)) - - (type: #export Lambda [PVar Expression]) - - (def: #export nil - Expression - (:abstraction "()")) - - (def: #export bool - (-> Bit Expression) - (|>> (case> #0 ..nil - #1 (:abstraction "t")))) - - (def: #export int - (-> Int Expression) - (|>> %i :abstraction)) - - (def: #export float - (-> Frac Expression) - (|>> (cond> [(f/= number.positive-infinity)] - [(new> "(/ 1.0 0.0)")] - - [(f/= number.negative-infinity)] - [(new> "(/ -1.0 0.0)")] - - [number.not-a-number?] - [(new> "(/ 0.0 0.0)")] - - ## else - [%f]) - :abstraction)) - - (def: #export (double value) - (-> Frac Expression) - (:abstraction - (.cond (f/= number.positive-infinity value) - "(/ 1.0d0 0.0d0)" - - (f/= number.negative-infinity value) - "(/ -1.0d0 0.0d0)" - - (number.not-a-number? value) - "(/ 0.0d0 0.0d0)" - - ## else - (.let [raw (%f value)] - (.if (text.contains? "E" raw) - (text.replace-once "E" "d" raw) - (format raw "d0")))))) - - (def: #export positive-infinity Expression (..float number.positive-infinity)) - (def: #export negative-infinity Expression (..float number.negative-infinity)) - (def: #export not-a-number Expression (..float number.not-a-number)) - - (def: #export string - (-> Text Expression) - (|>> %t :abstraction)) - - (template [<name> <prefix>] - [(def: #export <name> - (-> Text Expression) - (|>> (format <prefix>) :abstraction))] - - [symbol "'"] - [keyword ":"]) - - (def: #export (form elements) - (-> (List Expression) Expression) - (:abstraction - (format "(" (|> elements (list/map expression) (text.join-with " ")) ")"))) - - (def: #export @@ - (All [k] (-> (Var k) Expression)) - (|>> ..name :abstraction)) - - (def: #export global - (-> Text Expression) - (|>> var @@)) - - (def: #export ($apply func args) - (-> Expression (List Expression) Expression) - (form (#.Cons func args))) - - (template [<name> <function>] - [(def: #export <name> - (-> (List Expression) Expression) - ($apply (..global <function>)))] - - [vector "vector"] - [list "list"] - ) - - (def: #export (labels definitions body) - (-> (List [SVar Lambda]) Expression Expression) - (..form (.list (..global "labels") - (..form (list/map (.function (_ [def-name [def-args def-body]]) - (..form (.list (@@ def-name) - (@@ def-args) - def-body))) - definitions)) - body))) - - (def: #export (destructuring-bind [bindings expression] body) - (-> [PVar Expression] Expression Expression) - (..form (.list (..global "destructuring-bind") - (@@ bindings) expression - body))) - - (def: #export ($apply1 func) - (-> Expression (-> Expression Expression)) - (|>> (.list) (..$apply func))) - - (template [<lux-name> <scheme-name>] - [(def: #export <lux-name> (..$apply1 (..global <scheme-name>)))] - - [length "length"] - [function "function"] - [copy-seq "copy-seq"] - [null "null"] - [car "car"] - [cdr "cdr"] - [error "error"] - [not "not"] - [floor/1 "floor"] - [type-of "type-of"] - [write-to-string "write-to-string"] - [read-from-string "read-from-string"] - [print "print"] - [reverse "reverse"] - [sxhash/1 "sxhash"] - [string-upcase/1 "string-upcase"] - [string-downcase/1 "string-downcase"] - [char-int/1 "char-int"] - [text/1 "text"] - ) - - (def: #export (make-array/init size init) - (-> Expression Expression Expression) - (..$apply (..global "make-array") - (.list (..list (.list size)) - (..keyword "initial-element") - init))) - - (def: #export get-universal-time - Expression - (..$apply (..global "get-universal-time") (.list))) - - (def: #export (funcall args func) - (-> (List Expression) Expression Expression) - (..$apply (..global "funcall") (list& func args))) - - (def: #export (apply args func) - (-> Expression Expression Expression) - (..$apply (..global "apply") (.list func args))) - - (def: #export ($apply2 func) - (-> Expression (-> Expression Expression Expression)) - (.function (_ _0 _1) - (..$apply func (.list _0 _1)))) - - (template [<lux-name> <scheme-name>] - [(def: #export <lux-name> (..$apply2 (..global <scheme-name>)))] - - [append "append"] - [cons "cons"] - [svref "svref"] - [char/2 "char"] - ) - - (def: #export (search/start2 reference space start) - (-> Expression Expression Expression Expression) - (..$apply (..global "search") - (.list reference space - (..keyword "start2") start))) - - (def: #export ($apply3 func) - (-> Expression (-> Expression Expression Expression Expression)) - (.function (_ _0 _1 _2) - (..$apply func (.list _0 _1 _2)))) - - (template [<lux-name> <scheme-name>] - [(def: #export <lux-name> ($apply3 (..global <scheme-name>)))] - - [subseq/3 "subseq"] - [map/3 "map"] - [concatenate/3 "concatenate"] - [format/3 "format"] - ) - - (def: #export concatenate/string - (-> Expression Expression Expression) - (concatenate/3 (..symbol "string"))) - - (template [<lux-name> <scheme-name>] - [(def: #export <lux-name> - (-> (List Expression) Expression) - (|>> (.list& (..global <scheme-name>)) ..form))] - - [or "or"] - [and "and"] - ) - - (template [<lux-name> <scheme-name>] - [(def: #export (<lux-name> param subject) - (-> Expression Expression Expression) - (..form (.list (..global <scheme-name>) subject param)))] - - [= "="] - [eq "eq"] - [equal "equal"] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [string= "string="] - [string< "string<"] - [+ "+"] - [- "-"] - [/ "/"] - [* "*"] - [rem "rem"] - [floor "floor"] - [mod "mod"] - [ash "ash"] - [logand "logand"] - [logior "logior"] - [logxor "logxor"] - ) - - (template [<lux-name> <scheme-name>] - [(def: #export (<lux-name> bindings body) - (-> (List [SVar Expression]) Expression Expression) - (..form (.list (..global <scheme-name>) - (|> bindings - (list/map (.function (_ [fname fvalue]) - (..form (.list (@@ fname) fvalue)))) - ..form) - body)))] - - [let "let"] - [let* "let*"] - ) - - (def: #export (if test then else) - (-> Expression Expression Expression Expression) - (..form (.list (..global "if") test then else))) - - (def: #export (when test then) - (-> Expression Expression Expression) - (..form (.list (..global "when") test then))) - - (def: #export (cond clauses else) - (-> (List [Expression Expression]) Expression Expression) - (list/fold (.function (_ [test then] next) - (if test then next)) - else - (list.reverse clauses))) - - (def: #export (lambda input body) - (-> PVar Expression Expression) - (..form (.list (..global "lambda") - (@@ input) - body))) - - (def: #export (defparameter name body) - (-> SVar Expression Expression) - (..form (.list (..global "defparameter") (@@ name) body))) - - (def: #export (defun name inputs body) - (-> SVar (List SVar) Expression Expression) - (..form (.list (..global "defun") (@@ name) (@@ (..poly inputs)) body))) - - (def: #export progn - (-> (List Expression) Expression) - (|>> (#.Cons (..global "progn")) ..form)) - - (def: #export (setq! name value) - (-> SVar Expression Expression) - (..form (.list (..global "setq") (@@ name) value))) - - (def: #export (setf! access value) - (-> Expression Expression Expression) - (..form (.list (..global "setf") access value))) - - (type: #export Handler - {#condition-type Expression - #condition SVar - #body Expression}) - - (def: #export (handler-case handlers body) - (-> (List Handler) Expression Expression) - (..form (.list& (..global "handler-case") - body - (list/map (.function (_ [type condition handler]) - (..form (.list type (@@ (..poly (.list condition))) - handler))) - handlers)))) - - (template [<name> <prefix>] - [(def: #export (<name> conditions expression) - (-> (List Text) Expression Expression) - (case conditions - #.Nil - expression - - (#.Cons single #.Nil) - (:abstraction - (format <prefix> single " " (:representation expression))) - - _ - (:abstraction - (format <prefix> (|> conditions (list/map ..symbol) - (.list& (..symbol "or")) ..form - :representation) - " " (:representation expression)))))] - - [conditional+ "#+"] - [conditional- "#-"]) - ) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp.lux b/new-luxc/source/luxc/lang/translation/common-lisp.lux deleted file mode 100644 index a9ea2c215..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp.lux +++ /dev/null @@ -1,212 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - pipe - [monad #+ do]) - (data [bit] - [maybe] - ["e" error #+ Error] - [text "text/" Eq<Text>] - text/format - (coll [array])) - [macro] - [io #+ IO Process io] - [host #+ class: interface: object] - (world [file #+ File])) - (luxc [lang] - (lang [".L" variable #+ Register] - (host ["_" common-lisp #+ Expression])) - [".C" io])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [No-Active-Module-Buffer] - [Cannot-Execute] - - [No-Anchor] - ) - -(host.import: java/lang/String - (getBytes [String] #try (Array byte))) - -(host.import: java/lang/CharSequence) - -(host.import: java/lang/Appendable - (append [CharSequence] Appendable)) - -(host.import: java/lang/StringBuilder - (new []) - (toString [] String)) - -(host.import: org/armedbear/lisp/LispObject) - -(host.import: org/armedbear/lisp/Interpreter - (#static getInstance [] Interpreter) - (#static createInstance [] #? Interpreter) - (eval [String] #try LispObject)) - -(type: #export Anchor [Text Register]) - -(type: #export Host - {#context [Text Nat] - #anchor (Maybe Anchor) - #loader (-> Expression (Error Any)) - #interpreter (-> Expression (Error LispObject)) - #module-buffer (Maybe StringBuilder) - #program-buffer StringBuilder}) - -(def: ____ (Interpreter::createInstance [])) - -(def: #export init - (IO Host) - (io (let [## interpreter ____ - _ (Interpreter::createInstance []) - interpreter (Interpreter::getInstance [])] - {#context ["" +0] - #anchor #.None - #loader (function (_ code) - (do e.Monad<Error> - [_ (Interpreter::eval [(_.expression code)] interpreter)] - (wrap []))) - #interpreter (function (_ code) - (Interpreter::eval [(_.expression code)] interpreter)) - #module-buffer #.None - #program-buffer (StringBuilder::new [])}))) - -(def: #export file-extension ".lisp") - -(def: #export r-module-name Text (format "module" file-extension)) - -(def: #export init-module-buffer - (Meta Any) - (function (_ compiler) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #module-buffer (#.Some (StringBuilder::new []))) - (:coerce Nothing)) - compiler) - []]))) - -(def: #export (with-sub-context expr) - (All [a] (-> (Meta a) (Meta [Text a]))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler)) - [old-name old-sub] (get@ #context old) - new-name (format old-name "f___" (%i (.int old-sub)))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #context [new-name +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #context [old-name (inc old-sub)]) - (:coerce Nothing)) - compiler') - [new-name output]]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export context - (Meta Text) - (function (_ compiler) - (#e.Success [compiler - (|> (get@ #.host compiler) - (:coerce Host) - (get@ #context) - (let> [name sub] - name))]))) - -(def: #export (with-anchor anchor expr) - (All [a] (-> Anchor (Meta a) (Meta a))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #anchor (#.Some anchor) old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #anchor (get@ #anchor old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export anchor - (Meta Anchor) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #anchor)) - (#.Some anchor) - (#e.Success [compiler anchor]) - - #.None - ((lang.throw No-Anchor "") compiler)))) - -(def: #export module-buffer - (Meta StringBuilder) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #module-buffer)) - #.None - ((lang.throw No-Active-Module-Buffer "") compiler) - - (#.Some module-buffer) - (#e.Success [compiler module-buffer])))) - -(def: #export program-buffer - (Meta StringBuilder) - (function (_ compiler) - (#e.Success [compiler (|> compiler (get@ #.host) (:coerce Host) (get@ #program-buffer))]))) - -(template [<name> <field> <outputT>] - [(def: (<name> code) - (-> Expression (Meta <outputT>)) - (function (_ compiler) - (let [runner (|> compiler (get@ #.host) (:coerce Host) (get@ <field>))] - (case (runner code) - (#e.Error error) - ((lang.throw Cannot-Execute error) compiler) - - (#e.Success output) - (#e.Success [compiler output])))))] - - [load! #loader Any] - [interpret #interpreter LispObject] - ) - -(def: #export variant-tag "LUX-VARIANT") - -(def: #export unit Text "") - -(def: #export (definition-name [module name]) - (-> Name Text) - (lang.normalize-name (format module "$" name))) - -(def: #export (save code) - (-> Expression (Meta Any)) - (do macro.Monad<Meta> - [module-buffer module-buffer - #let [_ (Appendable::append [(:coerce CharSequence (_.expression code))] - module-buffer)]] - (load! code))) - -(def: #export run interpret) - -(def: #export (save-module! target) - (-> File (Meta (Process Any))) - (do macro.Monad<Meta> - [module macro.current-module-name - module-buffer module-buffer - program-buffer program-buffer - #let [module-code (StringBuilder::toString [] module-buffer) - _ (Appendable::append [(:coerce CharSequence (format module-code "\n"))] - program-buffer)]] - (wrap (ioC.write target - (format (lang.normalize-name module) "/" r-module-name) - (|> module-code - (String::getBytes ["UTF-8"]) - e.assume))))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/case.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/case.jvm.lux deleted file mode 100644 index 78149471d..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/case.jvm.lux +++ /dev/null @@ -1,183 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [number] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>] - (set ["set" unordered #+ Set]))) - [macro #+ "meta/" Monad<Meta>] - (macro [code])) - (luxc [lang] - (lang [".L" variable #+ Register Variable] - ["ls" synthesis #+ Synthesis Path] - (host ["_" common-lisp #+ Expression Handler SVar @@]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" reference])) - -(def: #export (translate-let translate register valueS bodyS) - (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS) - bodyO (translate bodyS) - #let [$register (referenceT.variable register)]] - (wrap (_.let (list [$register valueO]) - bodyO)))) - -(def: #export (translate-record-get translate valueS pathP) - (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bit]) - (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS)] - (wrap (list/fold (function (_ [idx tail?] source) - (let [method (if tail? - runtimeT.product//right - runtimeT.product//left)] - (method source (_.int (:coerce Int idx))))) - valueO - pathP)))) - -(def: #export (translate-if testO thenO elseO) - (-> Expression Expression Expression Expression) - (_.if testO thenO elseO)) - -(def: $savepoint (_.var "lux_pm_cursor_savepoint")) -(def: $cursor (_.var "lux_pm_cursor")) - -(def: top _.length) -(def: (push! value var) - (-> Expression SVar Expression) - (_.setq! var (_.cons value (@@ var)))) -(def: (pop! var) - (-> SVar Expression) - (_.setq! var (@@ var))) - -(def: (push-cursor! value) - (-> Expression Expression) - (push! value $cursor)) - -(def: save-cursor! - Expression - (push! (@@ $cursor) $savepoint)) - -(def: restore-cursor! - Expression - (_.setq! $cursor (_.car (@@ $savepoint)))) - -(def: cursor-top - Expression - (_.car (@@ $cursor))) - -(def: pop-cursor! - Expression - (pop! $cursor)) - -(def: pm-error (_.string "PM-ERROR")) - -(def: fail-pm! (_.error pm-error)) - -(def: $temp (_.var "lux_pm_temp")) - -(exception: #export (Unrecognized-Path {message Text}) - message) - -(def: $alt_error (_.var "alt_error")) - -(def: (pm-catch handler) - (-> Expression Handler) - [(_.bool #1) $alt_error - (_.progn - (list - (_.setq! $alt_error (_.format/3 _.nil (_.string "~A") (@@ $alt_error))) - (_.if (|> (@@ $alt_error) (_.equal pm-error)) - handler - (_.error (@@ $alt_error)))))]) - -(def: (translate-pattern-matching' translate pathP) - (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) - (case pathP - (^code ("lux case exec" (~ bodyS))) - (do macro.Monad<Meta> - [bodyO (translate bodyS)] - (wrap bodyO)) - - (^code ("lux case pop")) - (meta/wrap pop-cursor!) - - (^code ("lux case bind" (~ [_ (#.Nat register)]))) - (meta/wrap (_.setq! (referenceT.variable register) cursor-top)) - - (^template [<tag> <format> <=>] - [_ (<tag> value)] - (meta/wrap (_.when (|> value <format> (<=> cursor-top) _.not) - fail-pm!))) - ([#.Bit _.bool _.equal] - [#.Nat (<| _.int (:coerce Int)) _.=] - [#.Int _.int _.=] - [#.Rev (<| _.int (:coerce Int)) _.=] - [#.Frac _.float _.=] - [#.Text _.string _.equal]) - - (^template [<pm> <getter>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor! (<getter> cursor-top (_.int (:coerce Int idx)))))) - (["lux case tuple left" runtimeT.product//left] - ["lux case tuple right" runtimeT.product//right]) - - (^template [<pm> <flag>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (_.progn (list (_.setq! $temp (runtimeT.sum//get cursor-top (_.int (:coerce Int idx)) <flag>)) - (_.if (_.null (@@ $temp)) - fail-pm! - (push-cursor! (@@ $temp))))))) - (["lux case variant left" _.nil] - ["lux case variant right" (_.string "")]) - - (^code ("lux case seq" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap (_.progn (list leftO - rightO)))) - - (^code ("lux case alt" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap (runtimeT.with-vars [error] - (_.handler-case - (list (pm-catch (_.progn (list restore-cursor! - rightO)))) - (_.progn (list save-cursor! - leftO)))))) - - _ - (lang.throw Unrecognized-Path (%code pathP)) - )) - -(def: (translate-pattern-matching translate pathP) - (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) - (do macro.Monad<Meta> - [pattern-matching! (translate-pattern-matching' translate pathP)] - (wrap (_.handler-case - (list (pm-catch (_.error (_.string "Invalid expression for pattern-matching.")))) - pattern-matching!)))) - -(def: (initialize-pattern-matching! stack-init body) - (-> Expression Expression Expression) - (_.let (list [$cursor (_.list (list stack-init))] - [$savepoint (_.list (list))] - [$temp _.nil]) - body)) - -(def: #export (translate-case translate valueS pathP) - (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS) - pattern-matching! (translate-pattern-matching translate pathP)] - (wrap (<| (initialize-pattern-matching! valueO) - pattern-matching!)))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/expression.jvm.lux deleted file mode 100644 index 437648fbb..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/expression.jvm.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - text/format) - [macro] - (macro ["s" syntax])) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - [".L" extension] - ["ls" synthesis] - (host ["_" common-lisp #+ Expression]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" structure] - [".T" function] - [".T" reference] - [".T" case] - [".T" procedure])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Invalid-Function-Syntax] - [Unrecognized-Synthesis] - ) - -(def: #export (translate synthesis) - (-> ls.Synthesis (Meta Expression)) - (case synthesis - (^code []) - (:: macro.Monad<Meta> wrap runtimeT.unit) - - (^template [<tag> <generator>] - [_ (<tag> value)] - (<generator> value)) - ([#.Bit primitiveT.translate-bit] - [#.Nat primitiveT.translate-nat] - [#.Int primitiveT.translate-int] - [#.Rev primitiveT.translate-rev] - [#.Frac primitiveT.translate-frac] - [#.Text primitiveT.translate-text]) - - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) - - (^code [(~ singleton)]) - (translate singleton) - - (^code [(~+ members)]) - (structureT.translate-tuple translate members) - - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (referenceT.translate-variable var) - - [_ (#.Identifier definition)] - (referenceT.translate-definition definition) - - (^code ("lux call" (~ functionS) (~+ argsS))) - (functionT.translate-apply translate functionS argsS) - - (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) - (case (s.run environment (p.some s.int)) - (#e.Success environment) - (functionT.translate-function translate environment arity bodyS) - - _ - (&.throw Invalid-Function-Syntax (%code synthesis))) - - (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) - (caseT.translate-let translate register inputS exprS) - - (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT.translate-case translate inputS pathPS) - - (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) - (procedureT.translate-procedure translate procedure argsS) - ## (do macro.Monad<Meta> - ## [translation (extensionL.find-translation procedure)] - ## (translation argsS)) - - _ - (&.throw Unrecognized-Synthesis (%code synthesis)))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux deleted file mode 100644 index 54834b65c..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [product] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>])) - [macro]) - (luxc ["&" lang] - (lang ["ls" synthesis] - [".L" variable #+ Variable] - (host ["_" common-lisp #+ Expression @@]))) - [//] - (// [".T" reference] - [".T" runtime])) - -(def: #export (translate-apply translate functionS argsS+) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) - (do macro.Monad<Meta> - [functionO (translate functionS) - argsO+ (monad.map @ translate argsS+)] - (wrap (_.funcall argsO+ functionO)))) - -(def: $curried (_.var "curried")) -(def: $missing (_.var "missing")) - -(def: input-declaration - (|>> inc referenceT.variable)) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Expression (Meta Expression)) - (let [$closure (_.var (format function-name "___CLOSURE"))] - (do macro.Monad<Meta> - [] - (case inits - #.Nil - (wrap function-definition) - - _ - (wrap (_.labels (list [$closure [(|> (list.enumerate inits) - (list/map (|>> product.left referenceT.closure)) - _.poly) - function-definition]]) - (_.funcall inits (_.function (@@ $closure))))))))) - -(def: #export (translate-function translate env arity bodyS) - (-> (-> ls.Synthesis (Meta Expression)) - (List Variable) ls.Arity ls.Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [[function-name bodyO] (//.with-sub-context - (do @ - [function-name //.context] - (//.with-anchor [function-name +1] - (translate bodyS)))) - closureO+ (monad.map @ referenceT.translate-variable env) - #let [arityO (|> arity .int _.int) - $num_args (_.var "num_args") - $function (_.var function-name)]] - (with-closure function-name closureO+ - (_.labels (list [$function [(_.poly+ (list) $curried) - (_.let (list [$num_args (_.length (@@ $curried))]) - (<| (_.if (|> (@@ $num_args) (_.= arityO)) - (_.let (list [(referenceT.variable +0) (_.function (@@ $function))]) - (_.destructuring-bind [(|> (list.n/range +0 (dec arity)) - (list/map input-declaration) - _.poly) - (@@ $curried)] - bodyO))) - (_.if (|> (@@ $num_args) (_.> arityO)) - (let [arity-args (_.subseq/3 (@@ $curried) (_.int 0) arityO) - output-func-args (_.subseq/3 (@@ $curried) arityO (@@ $num_args))] - (|> (_.function (@@ $function)) - (_.apply arity-args) - (_.apply output-func-args)))) - ## (|> (@@ $num_args) (_.< arityO)) - (_.lambda (_.poly+ (list) $missing) - (|> (_.function (@@ $function)) - (_.apply (_.append (@@ $curried) (@@ $missing)))))))]]) - (_.function (@@ $function)))) - )) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/loop.jvm.lux deleted file mode 100644 index c64973d8f..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/loop.jvm.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>])) - [macro]) - (luxc [lang] - (lang ["ls" synthesis] - (host [r #+ Expression @@]))) - [//] - (// [".T" reference])) - -(def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [loop-name (|> (macro.gensym "loop") - (:: @ map (|>> %code lang.normalize-name))) - initsO+ (monad.map @ translate initsS+) - bodyO (//.with-anchor [loop-name offset] - (translate bodyS)) - #let [$loop-name (r.var loop-name) - @loop-name (@@ $loop-name)] - _ (//.save (r.set! $loop-name - (r.function (|> (list.n/range +0 (dec (list.size initsS+))) - (list/map (|>> (n/+ offset) referenceT.variable))) - bodyO)))] - (wrap (r.apply initsO+ @loop-name)))) - -(def: #export (translate-recur translate argsS+) - (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis) - (Meta Expression)) - (do macro.Monad<Meta> - [[loop-name offset] //.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (r.apply argsO+ (r.global loop-name))))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/primitive.jvm.lux deleted file mode 100644 index 7556e6ebb..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/primitive.jvm.lux +++ /dev/null @@ -1,22 +0,0 @@ -(.module: - lux - (lux [macro "meta/" Monad<Meta>]) - (luxc (lang (host ["_" common-lisp #+ Expression]))) - [//] - (// [".T" runtime])) - -(def: #export translate-bit - (-> Bit (Meta Expression)) - (|>> _.bool meta/wrap)) - -(def: #export translate-int - (-> Int (Meta Expression)) - (|>> _.int meta/wrap)) - -(def: #export translate-frac - (-> Frac (Meta Expression)) - (|>> _.double meta/wrap)) - -(def: #export translate-text - (-> Text (Meta Expression)) - (|>> _.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux deleted file mode 100644 index 3eaa60821..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux +++ /dev/null @@ -1,314 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number #+ hex] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host ["_" common-lisp #+ Expression]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash<Text>))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .int %i) "\n" - " Actual: " (|> actual .int %i))) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!proc g!name g!translate g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad<Meta> - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do macro.Monad<Meta> - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftO rightO]) - Binary - (_.eq leftO rightO)) - -(def: (lux//if [testO thenO elseO]) - Trinary - (caseT.translate-if testO thenO elseO)) - -(exception: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (wrong-syntax procedure args) - (-> Text (List ls.Synthesis) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - -(def: lux//loop - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) - (#e.Success [offset initsS+ bodyS]) - (loopT.translate-loop translate offset initsS+ bodyS) - - (#e.Error error) - (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) - ))) - -(def: lux//recur - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (loopT.translate-recur translate inputsS)))) - -(def: lux-procs - Bundle - (|> (dict.new text.Hash<Text>) - (install "is" (binary lux//is)) - (install "try" (unary runtimeT.lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -## [[Bits]] -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [bit//and _.logand] - [bit//or _.logior] - [bit//xor _.logxor] - ) - -(def: (bit//left-shift [subjectO paramO]) - Binary - (_.ash (_.rem (_.int 64) paramO) subjectO)) - -(def: (bit//arithmetic-right-shift [subjectO paramO]) - Binary - (_.ash (|> paramO (_.rem (_.int 64)) (_.* (_.int -1))) - subjectO)) - -(def: (bit//logical-right-shift [subjectO paramO]) - Binary - (runtimeT.bit//logical-right-shift (_.rem (_.int 64) paramO) subjectO)) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -## [[Numbers]] -(host.import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(template [<name> <const> <encode>] - [(def: (<name> _) - Nullary - (<encode> <const>))] - - [frac//smallest Double::MIN_VALUE _.double] - [frac//min (f/* -1.0 Double::MAX_VALUE) _.double] - [frac//max Double::MAX_VALUE _.double] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO (<op> paramO)))] - - [int//+ _.+] - [int//- _.-] - [int//* _.*] - [int/// _.floor] - [int//% _.rem] - [int//= _.=] - [int//< _.<] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [frac//+ _.+] - [frac//- _.-] - [frac//* _.*] - [frac/// _./] - [frac//% _.mod] - [frac//= _.=] - [frac//< _.<] - - [text//= _.string=] - ) - -(def: (text//< [subjectO paramO]) - Binary - (|> (_.string< paramO subjectO) - _.null - _.not)) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash<Text>) - (install "+" (binary int//+)) - (install "-" (binary int//-)) - (install "*" (binary int//*)) - (install "/" (binary int///)) - (install "%" (binary int//%)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "to-frac" (unary (|>> (_./ (_.double 1.0)))))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash<Text>) - (install "+" (binary frac//+)) - (install "-" (binary frac//-)) - (install "*" (binary frac//*)) - (install "/" (binary frac///)) - (install "%" (binary frac//%)) - (install "=" (binary frac//=)) - (install "<" (binary frac//<)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "to-int" (unary _.floor/1))))) - -## ## [[Text]] -(def: (text//concat [subjectO paramO]) - Binary - (_.concatenate/string subjectO paramO)) - -(def: (text//char [text idx]) - Binary - (runtimeT.text//char idx text)) - -(def: (text//clip [text from to]) - Trinary - (runtimeT.text//clip from to text)) - -(def: (text//index [space reference start]) - Trinary - (runtimeT.text//index reference start space)) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash<Text>) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary text//concat)) - (install "index" (trinary text//index)) - (install "size" (unary _.length)) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - ))) - -## [[IO]] -(def: (void code) - (-> Expression Expression) - (_.progn (list code runtimeT.unit))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary (|>> _.print ..void))) - (install "error" (unary _.error)) - (install "exit" (unary runtimeT.io//exit)) - (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time runtimeT.unit))))))) - -## [Bundles] -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge io-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/host.jvm.lux deleted file mode 100644 index 2793b40e8..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/host.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -## (template [<name> <lua>] -## [(def: (<name> _) @.Nullary <lua>)] - -## [lua//nil "nil"] -## [lua//table "{}"] -## ) - -## (def: (lua//global proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list [_ (#.Text name)])) -## (do macro.Monad<Meta> -## [] -## (wrap name)) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (lua//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& functionS argsS+)) -## (do macro.Monad<Meta> -## [functionO (translate functionS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.apply functionO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: lua-procs -## @.Bundle -## (|> (dict.new text.Hash<Text>) -## (@.install "nil" (@.nullary lua//nil)) -## (@.install "table" (@.nullary lua//table)) -## (@.install "global" lua//global) -## (@.install "call" lua//call))) - -## (def: (table//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& tableS [_ (#.Text field)] argsS+)) -## (do macro.Monad<Meta> -## [tableO (translate tableS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.method field tableO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (table//get [fieldO tableO]) -## @.Binary -## (runtimeT.lua//get tableO fieldO)) - -## (def: (table//set [fieldO valueO tableO]) -## @.Trinary -## (runtimeT.lua//set tableO fieldO valueO)) - -## (def: table-procs -## @.Bundle -## (<| (@.prefix "table") -## (|> (dict.new text.Hash<Text>) -## (@.install "call" table//call) -## (@.install "get" (@.binary table//get)) -## (@.install "set" (@.trinary table//set))))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "lua") - (dict.new text.Hash<Text>) - ## (|> lua-procs - ## (dict.merge table-procs)) - )) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/reference.jvm.lux deleted file mode 100644 index def77fc35..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/reference.jvm.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - lux - (lux [macro] - (data [text] - text/format)) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host ["_" common-lisp #+ Expression SVar @@]))) - [//] - (// [".T" runtime])) - -(template [<register> <translation> <prefix>] - [(def: #export (<register> register) - (-> Register SVar) - (_.var (format <prefix> (%i (.int register))))) - - (def: #export (<translation> register) - (-> Register (Meta Expression)) - (:: macro.Monad<Meta> wrap (@@ (<register> register))))] - - [closure translate-captured "c"] - [variable translate-local "v"]) - -(def: #export (local var) - (-> Variable SVar) - (if (variableL.captured? var) - (closure (variableL.captured-register var)) - (variable (.nat var)))) - -(def: #export (translate-variable var) - (-> Variable (Meta Expression)) - (if (variableL.captured? var) - (translate-captured (variableL.captured-register var)) - (translate-local (.nat var)))) - -(def: #export global - (-> Name SVar) - (|>> //.definition-name _.var)) - -(def: #export (translate-definition name) - (-> Name (Meta Expression)) - (:: macro.Monad<Meta> wrap (@@ (global name)))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux deleted file mode 100644 index 5fa6179c7..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux +++ /dev/null @@ -1,316 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad<Parser>] - [monad #+ do]) - (data [bit] - [number #+ hex] - text/format - (coll [list "list/" Monad<List>])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [io #+ Process]) - [//] - (luxc [lang] - (lang (host ["_" common-lisp #+ SVar Expression @@])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Expression (_.string //.unit)) - -(def: (flag value) - (-> Bit Expression) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Expression) - (<| (_.cons (_.symbol //.variant-tag)) - (_.cons tag) - (_.cons last?) - value)) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Expression) - (variant' (_.int (:coerce Int tag)) (flag last?) value)) - -(def: #export none - Expression - (variant +0 #0 unit)) - -(def: #export some - (-> Expression Expression) - (variant +1 #1)) - -(def: #export left - (-> Expression Expression) - (variant +0 #0)) - -(def: #export right - (-> Expression Expression) - (variant +1 #1)) - -(type: Runtime Expression) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.seq s.local-identifier (p/wrap (list))) - (s.form (p.seq s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format prefix "__" (lang.normalize-name name)) - $runtime (` (_.var (~ (code.text runtime)))) - @runtime (` (@@ (~ $runtime))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Expression))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.$apply (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Expression - (~ (case argsC+ - #.Nil - (` (_.defparameter (~ $runtime) (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (_.defun (~ $runtime) (list (~+ argsLC+)) - (~ definition)))))))))))) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) - list/join))] - (~ body)))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.handler-case - (list [(_.bool #1) error - (..left (_.format/3 _.nil (_.string "~A") (@@ error)))]) - (..right (_.funcall (list ..unit) (@@ op)))))) - -(runtime: (lux//program-args program-args) - (with-vars [loop input output] - (_.labels (list [loop [(_.poly (list input output)) - (_.if (_.null (@@ input)) - (@@ output) - (_.funcall (list (_.cdr (@@ input)) - (..some (_.vector (list (_.car (@@ input)) (@@ output))))) - (_.function (@@ loop))))]]) - (_.funcall (list (_.reverse (@@ program-args)) - ..none) - (_.function (@@ loop)))))) - -(def: runtime//lux - Runtime - (_.progn (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Expression) - (|>> (_.+ (_.int 1)))) - -(def: product-element - (-> Expression Expression Expression) - _.svref) - -(def: (product-tail product) - (-> Expression Expression) - (_.svref product (|> (_.length product) (_.- (_.int 1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Expression) - (|> min-length (_.- (_.length product)))) - -(runtime: (product//left product index) - (with-vars [$index_min_length] - (_.let (list [$index_min_length (minimum-index-length (@@ index))]) - (_.if (|> (_.length (@@ product)) (_.> (@@ $index_min_length))) - ## No need for recursion - (product-element (@@ product) (@@ index)) - ## Needs recursion - (product//left (product-tail (@@ product)) - (updated-index (@@ $index_min_length) (@@ product))))))) - -(runtime: (product//right product index) - (with-vars [$index_min_length $product_length] - (_.let (list [$index_min_length (minimum-index-length (@@ index))] - [$product_length (_.length (@@ product))]) - (<| (_.if (|> (@@ $product_length) (_.= (@@ $index_min_length))) - ## Last element. - (product-element (@@ product) (@@ index))) - (_.if (|> (@@ $product_length) (_.< (@@ $index_min_length))) - ## Needs recursion - (product//right (product-tail (@@ product)) - (updated-index (@@ $index_min_length) (@@ product)))) - ## Must slice - (_.subseq/3 (@@ product) (@@ index) (@@ $product_length)))))) - -(runtime: (sum//get sum wanted_tag wants_last) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> (@@ sum-flag) (_.equal (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get (@@ sum-value) - (|> (@@ wanted_tag) (_.- (@@ sum-tag))) - (@@ wants_last)) - no-match)] - (<| (_.destructuring-bind [(_.poly (list variant-tag sum-tag sum-flag sum-value)) - (@@ sum)]) - (_.if (|> (@@ wanted_tag) (_.= (@@ sum-tag))) - (_.if (|> (@@ sum-flag) (_.equal (@@ wants_last))) - (@@ sum-value) - test-recursion)) - (_.if (|> (@@ wanted_tag) (_.> (@@ sum-tag))) - test-recursion) - (_.if (_.and (list (|> (@@ wants_last) (_.equal (_.string ""))) - (|> (@@ wanted_tag) (_.< (@@ sum-tag))))) - (variant' (|> (@@ sum-tag) (_.- (@@ wanted_tag))) (@@ sum-flag) (@@ sum-value))) - no-match)))) - -(def: runtime//adt - Runtime - (_.progn (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.= (_.int 0) (@@ shift)) - (@@ input) - (|> (@@ input) - (_.ash (_.* (_.int -1) (@@ shift))) - (_.logand (_.int (hex "7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Runtime - (_.progn (list @@bit//logical-right-shift))) - -(template [<name> <top-cmp>] - [(def: (<name> top value) - (-> Expression Expression Expression) - (_.and (list (|> value (_.>= (_.int 0))) - (|> value (<top-cmp> top)))))] - - [within? _.<] - [up-to? _.<=] - ) - -(runtime: (text//char idx text) - (_.if (|> (@@ idx) (within? (_.length (@@ text)))) - (..some (_.char-int/1 (_.char/2 (@@ text) (@@ idx)))) - ..none)) - -(runtime: (text//clip from to text) - (_.if (_.and (list (|> (@@ to) (within? (_.length (@@ text)))) - (|> (@@ from) (up-to? (@@ to))))) - (..some (_.subseq/3 (@@ text) (@@ from) (@@ to))) - ..none)) - -(runtime: (text//index reference start space) - (with-vars [index] - (_.let (list [index (_.search/start2 (@@ reference) (@@ space) (@@ start))]) - (_.if (@@ index) - (..some (@@ index)) - ..none)))) - -(def: runtime//text - Runtime - (_.progn (list @@text//index - @@text//clip - @@text//char))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Expression) - (_.if (|> idx (_.<= (_.length array))) - body - (_.error (_.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (with-vars [temp] - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - (_.let (list [temp (_.svref (@@ array) (@@ idx))]) - (_.if (_.null (@@ temp)) - ..none - (..some (@@ temp))))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - (_.progn - (list (_.setf! (_.svref (@@ array) (@@ idx)) (@@ value)) - (@@ array))))) - -(def: runtime//array - Runtime - (_.progn - (list @@array//get - @@array//put))) - -(runtime: (box//write value box) - (_.progn - (list - (_.setf! (_.svref (@@ box) (_.int 0)) (@@ value)) - ..unit))) - -(def: runtime//box - Runtime - (_.progn (list @@box//write))) - -(runtime: (io//exit code) - (_.progn - (list (_.conditional+ (list "sbcl") - (_.$apply (_.global "sb-ext:quit") (list (@@ code)))) - (_.conditional+ (list "clisp") - (_.$apply (_.global "ext:exit") (list (@@ code)))) - (_.conditional+ (list "ccl") - (_.$apply (_.global "ccl:quit") (list (@@ code)))) - (_.conditional+ (list "allegro") - (_.$apply (_.global "excl:exit") (list (@@ code)))) - (_.$apply (_.global "cl-user::quit") (list (@@ code)))))) - -(runtime: (io//current-time _) - (|> _.get-universal-time - (_.* (_.int 1,000)))) - -(def: runtime//io - (_.progn (list @@io//exit - @@io//current-time))) - -(def: runtime - Runtime - (_.progn (list runtime//lux - runtime//bit - runtime//adt - runtime//text - runtime//array - runtime//box - runtime//io))) - -(def: #export artifact Text (format prefix //.file-extension)) - -(def: #export translate - (Meta (Process Any)) - (do macro.Monad<Meta> - [_ //.init-module-buffer - _ (//.save runtime)] - (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/statement.jvm.lux deleted file mode 100644 index 48ec2a2fa..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/statement.jvm.lux +++ /dev/null @@ -1,45 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - [macro] - (data text/format)) - (luxc (lang [".L" module] - (host ["_" common-lisp #+ Expression @@]))) - [//] - (// [".T" runtime] - [".T" reference] - [".T" eval])) - -(def: #export (translate-def name expressionT expressionO metaV) - (-> Text Type Expression Code (Meta Any)) - (do macro.Monad<Meta> - [current-module macro.current-module-name - #let [def-name [current-module name]]] - (case (macro.get-identifier-ann (name-of #.alias) metaV) - (#.Some real-def) - (do @ - [[realT realA realV] (macro.find-def real-def) - _ (moduleL.define def-name [realT metaV realV])] - (wrap [])) - - _ - (do @ - [#let [def-name (referenceT.global def-name)] - _ (//.save (_.defparameter def-name expressionO)) - expressionV (evalT.eval (@@ def-name)) - _ (moduleL.define def-name [expressionT metaV expressionV]) - _ (if (macro.type? metaV) - (case (macro.declared-tags metaV) - #.Nil - (wrap []) - - tags - (moduleL.declare-tags tags (macro.export? metaV) (:coerce Type expressionV))) - (wrap [])) - #let [_ (log! (format "DEF " (%name def-name)))]] - (wrap [])) - ))) - -(def: #export (translate-program programO) - (-> Expression (Meta Expression)) - (macro.fail "translate-program NOT IMPLEMENTED YET")) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/structure.jvm.lux deleted file mode 100644 index dcf7e5693..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/structure.jvm.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format) - [macro]) - (luxc ["&" lang] - (lang [synthesis #+ Synthesis] - (host ["_" common-lisp #+ Expression]))) - [//] - (// [".T" runtime])) - -(def: #export (translate-tuple translate elemsS+) - (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression)) - (case elemsS+ - #.Nil - (:: macro.Monad<Meta> wrap runtimeT.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do macro.Monad<Meta> - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (_.vector elemsT+))))) - -(def: #export (translate-variant translate tag tail? valueS) - (-> (-> Synthesis (Meta Expression)) Nat Bit Synthesis (Meta Expression)) - (do macro.Monad<Meta> - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) diff --git a/stdlib/source/lux/target/common-lisp.lux b/stdlib/source/lux/target/common-lisp.lux new file mode 100644 index 000000000..eb7e78d01 --- /dev/null +++ b/stdlib/source/lux/target/common-lisp.lux @@ -0,0 +1,429 @@ +(.module: + [lux (#- Code int if cond or and comment let) + [control + [pipe (#+ case> cond> new>)]] + [data + [number + ["." frac]] + ["." text + format] + [collection + ["." list ("#@." monad fold)]]] + [macro + ["." template]] + [type + abstract]]) + +(def: as-form + (-> Text Text) + (text.enclose ["(" ")"])) + +(abstract: #export (Code brand) + {} + + Text + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export (<brand> brand) {} Any)) + (`` (type: #export (<type> brand) + (<super> (<brand> brand)))))] + + [Expression Code] + [Computation Expression] + [Access Computation] + [Var Access] + + [Input Code] + ) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export <brand> {} Any)) + (`` (type: #export <type> (<super> <brand>))))] + + [Tag Code] + [Literal Expression] + [Var/1 Var] + [Var/* Input] + ) + + (type: #export Lambda + {#input Var/* + #output (Expression Any)}) + + (def: #export nil + Literal + (:abstraction "()")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 ..nil + #1 (:abstraction "t")))) + + (def: #export int + (-> Int Literal) + (|>> %i :abstraction)) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f/= frac.positive-infinity)] + [(new> "(/ 1.0 0.0)" [])] + + [(f/= frac.negative-infinity)] + [(new> "(/ -1.0 0.0)" [])] + + [frac.not-a-number?] + [(new> "(/ 0.0 0.0)" [])] + + ## else + [%f]) + :abstraction)) + + (def: #export (double value) + (-> Frac Literal) + (:abstraction + (.cond (f/= frac.positive-infinity value) + "(/ 1.0d0 0.0d0)" + + (f/= frac.negative-infinity value) + "(/ -1.0d0 0.0d0)" + + (frac.not-a-number? value) + "(/ 0.0d0 0.0d0)" + + ## else + (.let [raw (%f value)] + (.if (text.contains? "E" raw) + (text.replace-once "E" "d" raw) + (format raw "d0")))))) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace-all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical-tab "\v"] + [text.null "\0"] + [text.back-space "\b"] + [text.form-feed "\f"] + [text.new-line "\n"] + [text.carriage-return "\r"] + [text.double-quote (format "\" text.double-quote)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose' text.double-quote) + :abstraction)) + + (template [<name> <prefix>] + [(def: #export <name> + (-> Text Literal) + (|>> (format <prefix>) :abstraction))] + + [symbol "'"] + [keyword ":"]) + + (def: #export var + (-> Text Var/1) + (|>> :abstraction)) + + (def: #export args + (-> (List Var/1) Var/*) + (|>> (list@map ..code) + (text.join-with " ") + ..as-form + :abstraction)) + + (def: #export (args& singles rest) + (-> (List Var/1) Var/1 Var/*) + (|> (format (|> singles + (list@map ..code) + (text.join-with " ")) + " &rest " (:representation rest)) + ..as-form + :abstraction)) + + (def: form + (-> (List (Expression Any)) Expression) + (|>> (list@map ..code) + (text.join-with " ") + ..as-form + :abstraction)) + + (def: #export (call/* func) + (-> (Expression Any) (-> (List (Expression Any)) (Computation Any))) + (|>> (#.Cons func) ..form)) + + (template [<name> <function>] + [(def: #export <name> + (-> (List (Expression Any)) (Computation Any)) + (..call/* (..var <function>)))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def: #export (labels definitions body) + (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any)) + (..form (list (..var "labels") + (..form (list@map (function (_ [def-name [def-args def-body]]) + (..form (list def-name (:transmutation def-args) def-body))) + definitions)) + body))) + + (def: #export (destructuring-bind [bindings expression] body) + (-> [Var/* (Expression Any)] (Expression Any) (Computation Any)) + (..form (list (..var "destructuring-bind") + (:transmutation bindings) expression + body))) + + (template [<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.splice <function>+))))] + + [call/0 [] [] + [[get-universal-time/0 "get-universal-time"] + [make-hash-table/0 "make-hash-table"]]] + [call/1 [in0] [(Expression Any)] + [[length/1 "length"] + [function/1 "function"] + [copy-seq/1 "copy-seq"] + [null/1 "null"] + [error/1 "error"] + [not/1 "not"] + [floor/1 "floor"] + [type-of/1 "type-of"] + [write-to-string/1 "write-to-string"] + [read-from-string/1 "read-from-string"] + [print/1 "print"] + [reverse/1 "reverse"] + [sxhash/1 "sxhash"] + [string-upcase/1 "string-upcase"] + [string-downcase/1 "string-downcase"] + [char-int/1 "char-int"] + [text/1 "text"] + [hash-table-size/1 "hash-table-size"] + [hash-table-rehash-size/1 "hash-table-rehash-size"] + [code-char/1 "code-char"] + [string/1 "string"]]] + [call/2 [in0 in1] [(Expression Any) (Expression Any)] + [[apply/2 "apply"] + [append/2 "append"] + [cons/2 "cons"] + [char/2 "char"] + [nth/2 "nth"] + [nthcdr/2 "nthcdr"] + [coerce/2 "coerce"]]] + [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] + [[subseq/3 "subseq"] + [map/3 "map"] + [concatenate/3 "concatenate"] + [format/3 "format"]]] + ) + + (template [<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>+))))] + + [call/1 [(Expression Any)] + [[car/1 "car"] + [cdr/1 "cdr"] + [cadr/1 "cadr"] + [cddr/1 "cddr"]]] + [call/2 [(Expression Any) (Expression Any)] + [[svref/2 "svref"] + [elt/2 "elt"] + [gethash/2 "gethash"]]] + ) + + (def: #export (make-hash-table/with-size size) + (-> (Expression Any) (Computation Any)) + (..call/* (..var "make-hash-table") + (list (..keyword "size") + size))) + + (def: #export (funcall/+ [func args]) + (-> [(Expression Any) (List (Expression Any))] (Computation Any)) + (..call/* (..var "funcall") (list& func args))) + + (def: #export (search/3 [reference space start]) + (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any)) + (..call/* (..var "search") + (list reference + space + (..keyword "start2") start))) + + (def: #export (concatenate/2|string [left right]) + (-> [(Expression Any) (Expression Any)] (Computation Any)) + (concatenate/3 [(..symbol "string") left right])) + + (template [<lux-name> <host-name>] + [(def: #export (<lux-name> left right) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var <host-name>) left right)))] + + [or "or"] + [and "and"] + ) + + (template [<lux-name> <host-name>] + [(def: #export (<lux-name> param subject) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var <host-name>) subject param)))] + + [= "="] + [eq "eq"] + [equal "equal"] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [string= "string="] + [string< "string<"] + [+ "+"] + [- "-"] + [/ "/"] + [* "*"] + [rem "rem"] + [floor "floor"] + [mod "mod"] + [ash "ash"] + [logand "logand"] + [logior "logior"] + [logxor "logxor"] + ) + + (def: #export (if test then else) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "if") test then else))) + + (def: #export (when test then) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "when") test then))) + + (def: #export (lambda input body) + (-> Var/* (Expression Any) Literal) + (..form (list (..var "lambda") (:transmutation input) body))) + + (template [<lux-name> <host-name>] + [(def: #export (<lux-name> bindings body) + (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any)) + (..form (list (..var <host-name>) + (|> bindings + (list@map (function (_ [name value]) + (..form (list name value)))) + ..form) + body)))] + + [let "let"] + [let* "let*"] + ) + + (def: #export (defparameter name body) + (-> Var/1 (Expression Any) (Expression Any)) + (..form (list (..var "defparameter") name body))) + + (def: #export (defun name inputs body) + (-> Var/1 Var/* (Expression Any) (Expression Any)) + (..form (list (..var "defun") name (:transmutation inputs) body))) + + (def: #export (progn pre post) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "progn") pre post))) + + (def: #export (setq name value) + (-> Var/1 (Expression Any) (Expression Any)) + (..form (list (..var "setq") name value))) + + (def: #export (setf access value) + (-> (Access Any) (Expression Any) (Expression Any)) + (..form (list (..var "setf") access value))) + + (type: #export Handler + {#condition-type (Expression Any) + #condition Var/1 + #body (Expression Any)}) + + (def: #export (handler-case handlers body) + (-> (List Handler) (Expression Any) (Computation Any)) + (..form (list& (..var "handler-case") + body + (list@map (function (_ [type condition handler]) + (..form (list type + (:transmutation (..args (list condition))) + handler))) + handlers)))) + + (template [<name> <prefix>] + [(def: #export (<name> conditions expression) + (-> (List Text) (Expression Any) (Expression Any)) + (case conditions + #.Nil + expression + + (#.Cons single #.Nil) + (:abstraction + (format <prefix> single " " (:representation expression))) + + _ + (:abstraction + (format <prefix> (|> conditions (list@map ..symbol) + (list& (..symbol "or")) ..form + :representation) + " " (:representation expression)))))] + + [conditional+ "#+"] + [conditional- "#-"]) + + (def: #export tag + (-> Text Tag) + (|>> :abstraction)) + + (def: #export (go tag) + (-> Tag (Expression Any)) + (..form (list (..var "go") (:transmutation tag)))) + + (def: #export (tagbody main tagged) + (-> (Expression Any) + (List [Tag (Expression Any)]) + (Computation Any)) + (|> tagged + (list@map (function (_ [tag then]) + (list (:transmutation tag) then))) + list@join + (list& (..var "tagbody") main) + ..form)) + + (def: #export (cond clauses else) + (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any)) + (list@fold (function (_ [test then] next) + (..if test then next)) + (:transmutation else) + (list.reverse clauses))) + ) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux new file mode 100644 index 000000000..480c473bf --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux @@ -0,0 +1,60 @@ +(.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/phase/generation/common-lisp/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux new file mode 100644 index 000000000..144c0236e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux @@ -0,0 +1,223 @@ +(.module: + [lux (#- case let if) + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["." text + format] + [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: @return (_.var "lux_pm_return")) + +(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-tag (_.tag "lux_pm_fail")) +(def: done-tag (_.tag "lux_pm_done")) + +(def: fail! (_.go ..fail-tag)) +(def: return! (_.go ..done-tag)) + +(exception: #export unrecognized-path) + +(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)) + (_.tagbody ($_ _.progn + ..save! + pre!) + (list [fail-tag + ($_ _.progn + ..restore! + post!)]))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation (Expression Any))) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (do ////.monad + [bodyG (generate bodyS)] + (wrap ($_ _.progn + (_.setq @return bodyG) + ..return!))) + + #/////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]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation (Expression Any))) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap ($_ _.progn + (_.tagbody pattern-matching! + (list [..fail-tag + (_.error/1 (_.string "Invalid expression for pattern-matching."))] + [..done-tag + _.nil])) + @return)))) + +(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/phase/generation/common-lisp/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension.lux new file mode 100644 index 000000000..3bc0a0887 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension.lux @@ -0,0 +1,13 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux new file mode 100644 index 000000000..a72239982 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux @@ -0,0 +1,154 @@ +(.module: + [lux #* + [host (#+ import:)] + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + [collection + ["." dictionary]]] + [target + ["_" common-lisp (#+ Expression)]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.eq))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: (i64//left-shift [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (_.rem (_.int +64) paramG) subjectG)) + +(def: (i64//arithmetic-right-shift [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) + subjectG)) + +(def: (i64//logic-right-shift [paramG subjectG]) + (Binary (Expression Any)) + (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG)) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.logand))) + (bundle.install "or" (binary (product.uncurry _.logior))) + (bundle.install "xor" (binary (product.uncurry _.logxor))) + (bundle.install "left-shift" (binary i64//left-shift)) + (bundle.install "logical-right-shift" (binary i64//logic-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _.floor))) + (bundle.install "%" (binary (product.uncurry _.rem))) + (bundle.install "f64" (unary (function (_ value) + (_.coerce/2 [value (_.symbol "double-float")])))) + (bundle.install "char" (unary (|>> _.code-char/1 _.string/1))) + ))) + +(import: #long java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(template [<name> <const>] + [(def: (<name> _) + (Nullary (Expression Any)) + (_.double <const>))] + + [f64//smallest (java/lang/Double::MIN_VALUE)] + [f64//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] + [f64//max (java/lang/Double::MAX_VALUE)] + ) + +(def: f64-procs + Bundle + (<| (bundle.prefix "f64") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.mod))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "smallest" (nullary f64//smallest)) + (bundle.install "min" (nullary f64//min)) + (bundle.install "max" (nullary f64//max)) + (bundle.install "i64" (unary _.floor/1)) + (bundle.install "encode" (unary _.write-to-string/1)) + (bundle.install "decode" (unary (let [@temp (_.var "temp")] + (function (_ input) + (_.let (list [@temp (_.read-from-string/1 input)]) + (_.if (_.equal (_.symbol "DOUBLE-FLOAT") + (_.type-of/1 @temp)) + (///runtime.some @temp) + ///runtime.none))))))))) + +(def: (text//< [paramG subjectG]) + (Binary (Expression Any)) + (|> (_.string< paramG subjectG) + _.null/1 + _.not/1)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (///runtime.text//clip subjectO paramO extraO)) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.string=))) + (bundle.install "<" (binary text//<)) + (bundle.install "concat" (binary _.concatenate/2|string)) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.length/1)) + (bundle.install "char" (binary (|>> _.char/2 _.char-int/1))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: (void code) + (-> (Expression Any) (Expression Any)) + ($_ _.progn + code + ///runtime.unit)) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> _.print/1 ..void))) + (bundle.install "error" (unary _.error/1)) + (bundle.install "exit" (unary ///runtime.io//exit)) + (bundle.install "current-time" (nullary (function (_ _) + (///runtime.io//current-time ///runtime.unit))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge f64-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux new file mode 100644 index 000000000..d32f1b772 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux @@ -0,0 +1,94 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor fold)]]] + [target + ["_" common-lisp (#+ Expression)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." reference] + ["#." case] + ["#/" // + ["#." reference] + ["#/" // + ["." // #_ + [reference (#+ Register Variable)] + [analysis (#+ Variant Tuple Environment Arity 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.enumerate 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/phase/generation/common-lisp/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/loop.lux new file mode 100644 index 000000000..29326e358 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/loop.lux @@ -0,0 +1,40 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + 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 (|>> %n (format "scope") _.var) ///.next) + initsG+ (monad.map @ generate initsS+) + bodyG (///.with-anchor @scope + (generate bodyS))] + (wrap (_.labels (list [@scope {#_.input (|> initsS+ + list.enumerate + (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/phase/generation/common-lisp/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/primitive.lux new file mode 100644 index 000000000..4177f814a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/primitive.lux @@ -0,0 +1,27 @@ +(.module: + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [data + [number + ["." frac]]] + [target + ["_" common-lisp (#+ Expression)]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + (-> Bit (Expression Any)) + _.bool) + +(def: #export i64 + (-> (I64 Any) (Expression Any)) + (|>> .int _.int)) + +(def: #export f64 + (-> Frac (Expression Any)) + _.double) + +(def: #export text + (-> Text (Expression Any)) + _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux new file mode 100644 index 000000000..206f3f0e9 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux @@ -0,0 +1,10 @@ +(.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/phase/generation/common-lisp/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux new file mode 100644 index 000000000..87fc7741d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux @@ -0,0 +1,276 @@ +(.module: + [lux (#- inc) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["p" parser + ["s" code]]] + [data + [number (#+ hex) + ["." i64]] + ["." text + 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 [(_.= right-index last-index-right) + (_.elt/2 [tuple right-index])] + [(_.> right-index last-index-right) + ## 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) + (let [no-match! sum + sum-tag (_.nth/2 [(_.int +0) sum]) + sum-flag (_.nth/2 [(_.int +1) sum]) + sum-value (_.nth/2 [(_.int +2) sum]) + test-recursion! (_.if sum-flag + ## Must recurse. + (sum//get sum-value wantsLast (_.- sum-tag wantedTag)) + no-match!)] + (_.cond (list [(_.= sum-tag wantedTag) + (_.if (_.equal wantsLast sum-flag) + sum-value + test-recursion!)] + + [(_.> sum-tag wantedTag) + test-recursion!] + + [(_.and (_.< sum-tag wantedTag) + wantsLast) + (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 + [_ (///.save! true ["" ..prefix] + ..runtime)] + (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux new file mode 100644 index 000000000..ef29d33dc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux @@ -0,0 +1,36 @@ +(.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/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux index e325b1fca..e04befc25 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux @@ -317,34 +317,6 @@ @text//clip @text//char)) -(runtime: (array//get array idx) - (with-vars [temp] - ($_ _.then - (_.set (list temp) (_.nth idx array)) - (_.if (_.= _.none temp) - (_.return ..none) - (_.return (..some temp)))))) - -(runtime: (array//put array idx value) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array))) - -(def: runtime//array - (Statement Any) - ($_ _.then - @array//get - @array//put)) - -(runtime: (box//write value box) - ($_ _.then - (_.set (list (_.nth (_.int +0) box)) value) - (_.return ..unit))) - -(def: runtime//box - (Statement Any) - @box//write) - (def: runtime (Statement Any) ($_ _.then @@ -353,8 +325,6 @@ runtime//i64 runtime//frac runtime//text - runtime//array - runtime//box runtime//io )) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index a881dae3f..b69a6b969 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -41,6 +41,7 @@ [lua (#+)] [ruby (#+)] [php (#+)] + [common-lisp (#+)] [scheme (#+)]] [tool [compiler @@ -56,6 +57,8 @@ <host-modules>] [php (#+) <host-modules>] + [common-lisp (#+) + <host-modules>] [scheme (#+) <host-modules>]]]]] ## [control |