diff options
Diffstat (limited to '')
15 files changed, 2227 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/host/common-lisp.lux b/new-luxc/source/luxc/lang/host/common-lisp.lux new file mode 100644 index 000000000..3ab94b1a1 --- /dev/null +++ b/new-luxc/source/luxc/lang/host/common-lisp.lux @@ -0,0 +1,365 @@ +(.module: + [lux #- not or and list if function cond when let type-of] + (lux (control pipe) + (data [maybe "maybe/" Functor<Maybe>] + [text] + text/format + [number] + (coll [list "list/" Functor<List> Fold<List>])) + (type abstract))) + +(abstract: #export Single {} Unit) +(abstract: #export Poly {} Unit) + +(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 + (-> Bool Expression) + (|>> (case> true (@abstraction "t") + false ..nil))) + + (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)) + + (do-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))) + + (do-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))) + + (do-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)))) + + (do-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)))) + + (do-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"))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> + (-> (List Expression) Expression) + (|>> (.list& (..global <scheme-name>)) ..form))] + + [or "or"] + [and "and"] + ) + + (do-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"] + ) + + (do-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)))) + + (do-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 new file mode 100644 index 000000000..e76e614f8 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp.lux @@ -0,0 +1,212 @@ +(.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])) + +(do-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 Unit)) + #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 Unit) + (function (_ compiler) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #module-buffer (#.Some (StringBuilder::new []))) + (:! Void)) + compiler) + []]))) + +(def: #export (with-sub-context expr) + (All [a] (-> (Meta a) (Meta [Text a]))) + (function (_ compiler) + (let [old (:! Host (get@ #.host compiler)) + [old-name old-sub] (get@ #context old) + new-name (format old-name "f___" (%i (nat-to-int old-sub)))] + (case (expr (set@ #.host + (:! Void (set@ #context [new-name +0] old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #context [old-name (n/inc old-sub)]) + (:! Void)) + compiler') + [new-name output]]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export context + (Meta Text) + (function (_ compiler) + (#e.Success [compiler + (|> (get@ #.host compiler) + (:! Host) + (get@ #context) + (let> [name sub] + name))]))) + +(def: #export (with-anchor anchor expr) + (All [a] (-> Anchor (Meta a) (Meta a))) + (function (_ compiler) + (let [old (:! Host (get@ #.host compiler))] + (case (expr (set@ #.host + (:! Void (set@ #anchor (#.Some anchor) old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #anchor (get@ #anchor old)) + (:! Void)) + compiler') + output]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export anchor + (Meta Anchor) + (function (_ compiler) + (case (|> compiler (get@ #.host) (:! 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) (:! 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) (:! Host) (get@ #program-buffer))]))) + +(do-template [<name> <field> <outputT>] + [(def: (<name> code) + (-> Expression (Meta <outputT>)) + (function (_ compiler) + (let [runner (|> compiler (get@ #.host) (:! Host) (get@ <field>))] + (case (runner code) + (#e.Error error) + ((lang.throw Cannot-Execute error) compiler) + + (#e.Success output) + (#e.Success [compiler output])))))] + + [load! #loader Unit] + [interpret #interpreter LispObject] + ) + +(def: #export variant-tag "lux-variant") + +(def: #export unit Text "") + +(def: #export (definition-name [module name]) + (-> Ident Text) + (lang.normalize-name (format module "$" name))) + +(def: #export (save code) + (-> Expression (Meta Unit)) + (do macro.Monad<Meta> + [module-buffer module-buffer + #let [_ (Appendable::append [(:! CharSequence (_.expression code))] + module-buffer)]] + (load! code))) + +(def: #export run interpret) + +(def: #export (save-module! target) + (-> File (Meta (Process Unit))) + (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 [(:! 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 new file mode 100644 index 000000000..576fa8cc9 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/case.jvm.lux @@ -0,0 +1,183 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>] + [set #+ 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 Bool]) + (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 (:! 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 true) $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!))) + ([#.Bool _.bool _.equal] + [#.Nat (<| _.int (:! Int)) _.=] + [#.Int _.int _.=] + [#.Deg (<| _.int (:! Int)) _.=] + [#.Frac _.float _.=] + [#.Text _.string _.equal]) + + (^template [<pm> <getter>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! (<getter> cursor-top (_.int (:! 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 (:! 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/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/eval.jvm.lux new file mode 100644 index 000000000..fa59ee45e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/eval.jvm.lux @@ -0,0 +1,166 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + [monad #+ do]) + (data [bit] + [maybe] + ["e" error #+ Error] + [text "text/" Eq<Text>] + text/format + (coll [array])) + [host]) + (luxc [lang] + (lang (host ["_" common-lisp #+ Expression]))) + [//]) + +(host.import java/lang/Object + (toString [] String) + (getClass [] (Class Object))) + +(host.import java/lang/Long + (intValue [] Integer)) + +(host.import (java/lang/Class ?) + (#static forName [String] #try (Class Object))) + +(def: _0 + Unit + (case (Class::forName "org.armedbear.lisp.Symbol") + (#e.Success _) + (log! "LOADED") + + (#e.Error error) + (log! error))) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Null-Has-No-Lux-Representation] + [Cannot-Evaluate] + [invalid-variant] + ) + +(exception: #export (Unknown-Kind-Of-Host-Object {host-object Object}) + (let [object-class (:! Text (Object::toString [] (Object::getClass [] (:! Object host-object)))) + text-representation (:! Text (Object::toString [] (:! Object host-object)))] + (format object-class " --- " text-representation))) + +(host.import org/armedbear/lisp/LispObject) + +(host.import org/armedbear/lisp/SimpleString + (getStringValue [] String)) + +(host.import org/armedbear/lisp/Symbol + (#static T Symbol) + (getName [] String)) + +(host.import org/armedbear/lisp/DoubleFloat + (doubleValue [] double)) + +(host.import org/armedbear/lisp/Bignum + (longValue [] long)) + +(host.import org/armedbear/lisp/Fixnum + (longValue [] long)) + +(host.import org/armedbear/lisp/Nil) + +(host.import org/armedbear/lisp/SimpleVector + (length [] int) + (elt [int] LispObject)) + +(def: (parse-tuple lux-object host-object) + (-> (-> Object (Error Top)) SimpleVector (Error Top)) + (let [size (:! Nat (SimpleVector::length [] host-object))] + (loop [idx +0 + output (:! (Array Top) (array.new size))] + (if (n/< size idx) + (case (lux-object (SimpleVector::elt [(:! Int idx)] host-object)) + (#e.Error error) + (#e.Error error) + + (#e.Success lux-value) + (recur (n/inc idx) (array.write idx (:! Top lux-value) output))) + (#e.Success output))))) + +(def: (variant tag flag value) + (-> Nat Bool Top Top) + [(Long::intValue [] (:! Long tag)) + (: Top + (if flag + //.unit + (host.null))) + value]) + +(host.import org/armedbear/lisp/Cons + (car LispObject) + (cdr LispObject)) + +(def: (parse-variant lux-object host-object) + (-> (-> Object (Error Top)) Cons (Error Top)) + (let [variant-tag (Cons::car host-object)] + (if (and (host.instance? org/armedbear/lisp/Symbol variant-tag) + (text/= //.variant-tag (text.lower-case (Symbol::getName [] (:! Symbol variant-tag))))) + (do e.Monad<Error> + [#let [host-object (:! Cons (Cons::cdr host-object))] + tag (lux-object (Cons::car host-object)) + #let [host-object (:! Cons (Cons::cdr host-object))] + #let [flag (host.instance? org/armedbear/lisp/SimpleString + (Cons::car host-object))] + value (lux-object (Cons::cdr host-object))] + (wrap (..variant (:! Nat tag) flag value))) + (ex.throw invalid-variant (:! Text (Object::toString [] (:! Object host-object))))))) + +(def: (lux-object host-object) + (-> Object (Error Top)) + (cond (host.instance? org/armedbear/lisp/Bignum host-object) + (#e.Success (Bignum::longValue [] (:! Bignum host-object))) + + (host.instance? org/armedbear/lisp/Fixnum host-object) + (#e.Success (Fixnum::longValue [] (:! Fixnum host-object))) + + (host.instance? org/armedbear/lisp/DoubleFloat host-object) + (#e.Success (DoubleFloat::doubleValue [] (:! DoubleFloat host-object))) + + (host.instance? org/armedbear/lisp/Nil host-object) + (#e.Success false) + + (host.instance? org/armedbear/lisp/Symbol host-object) + (if (is? Symbol::T (:! Symbol host-object)) + (#e.Success true) + (ex.throw Unknown-Kind-Of-Host-Object (:! Object host-object))) + + (host.instance? org/armedbear/lisp/SimpleString host-object) + (#e.Success (SimpleString::getStringValue [] (:! SimpleString host-object))) + + (host.instance? org/armedbear/lisp/SimpleVector host-object) + (parse-tuple lux-object (:! SimpleVector host-object)) + + (host.instance? org/armedbear/lisp/Cons host-object) + (parse-variant lux-object (:! Cons host-object)) + + ## else + (ex.throw Unknown-Kind-Of-Host-Object (:! Object host-object)))) + +(def: #export (eval code) + (-> Expression (Meta Top)) + (function (_ compiler) + (let [interpreter (|> compiler (get@ #.host) (:! //.Host) (get@ #//.interpreter))] + (case (interpreter code) + (#e.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (_.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler)) + + (#e.Success output) + (case (lux-object output) + (#e.Success parsed-output) + (#e.Success [compiler parsed-output]) + + (#e.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (_.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler))))))) 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 new file mode 100644 index 000000000..b002341cc --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/expression.jvm.lux @@ -0,0 +1,87 @@ +(.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])) + +(do-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)) + ([#.Bool primitiveT.translate-bool] + [#.Nat primitiveT.translate-nat] + [#.Int primitiveT.translate-int] + [#.Deg primitiveT.translate-deg] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) + + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool 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) + + [_ (#.Symbol 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 new file mode 100644 index 000000000..543cbe899 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux @@ -0,0 +1,82 @@ +(.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 + (|>> n/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 nat-to-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 (n/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 new file mode 100644 index 000000000..ecaf12c7c --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/loop.jvm.lux @@ -0,0 +1,37 @@ +(.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 (n/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 new file mode 100644 index 000000000..6bb4ec140 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/primitive.jvm.lux @@ -0,0 +1,30 @@ +(.module: + lux + (lux [macro "meta/" Monad<Meta>]) + (luxc (lang (host ["_" common-lisp #+ Expression]))) + [//] + (// [".T" runtime])) + +(def: #export translate-bool + (-> Bool (Meta Expression)) + (|>> _.bool meta/wrap)) + +(def: #export translate-int + (-> Int (Meta Expression)) + (|>> _.int meta/wrap)) + +(def: #export translate-nat + (-> Nat (Meta Expression)) + (|>> (:! Int) _.int meta/wrap)) + +(def: #export translate-deg + (-> Deg (Meta Expression)) + (|>> (:! Int) _.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.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/procedure.jvm.lux new file mode 100644 index 000000000..0b9fa3544 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/procedure.jvm.lux @@ -0,0 +1,29 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll [dict]))) + (luxc ["&" lang] + (lang ["ls" synthesis] + (host ["_" common-lisp #+ Expression]))) + [//] + (/ ["/." common] + ["/." host])) + +(exception: #export (Unknown-Procedure {message Text}) + message) + +(def: procedures + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) + +(def: #export (translate-procedure translate name args) + (-> (-> ls.Synthesis (Meta Expression)) Text (List ls.Synthesis) + (Meta Expression)) + (<| (maybe.default (&.throw Unknown-Procedure (%t name))) + (do maybe.Monad<Maybe> + [proc (dict.get name procedures)] + (wrap (proc translate args))))) 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 new file mode 100644 index 000000000..42edae95b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux @@ -0,0 +1,457 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number #+ hex] + (coll [list "list/" Functor<List>] + [dict #+ 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 nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s.local-symbol] [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-symbol 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)) + +(def: (lux//noop valueO) + Unary + valueO) + +(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 "noop" (unary lux//noop)) + (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]] +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and _.logand] + [bit//or _.logior] + [bit//xor _.logxor] + ) + +(def: (bit//shift-left [subjectO paramO]) + Binary + (_.ash (_.rem (_.int 64) paramO) subjectO)) + +(def: (bit//signed-shift-right [subjectO paramO]) + Binary + (_.ash (|> paramO (_.rem (_.int 64)) (_.* (_.int -1))) + subjectO)) + +(def: (bit//shift-right [subjectO paramO]) + Binary + (runtimeT.bit//shift-right (_.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 "shift-left" (binary bit//shift-left)) + (install "unsigned-shift-right" (binary bit//shift-right)) + (install "shift-right" (binary bit//signed-shift-right)) + ))) + +## [[Arrays]] +(def: (array//new size0) + Unary + (_.make-array/init size0 _.nil)) + +(def: (array//get [arrayO idxO]) + Binary + (runtimeT.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) + Trinary + (runtimeT.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) + Binary + (runtimeT.array//put arrayO idxO _.nil)) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash<Text>) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary _.length)) + ))) + +## [[Numbers]] +(host.import java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-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] + ) + +(do-template [<name> <expression>] + [(def: (<name> _) + Nullary + (_.int <expression>))] + + [int//min ("lux int min")] + [int//max ("lux int max")] + ) + +(do-template [<name> <frac>] + [(def: (<name> _) + Nullary + (_.double <frac>))] + + [frac//not-a-number number.not-a-number] + [frac//positive-infinity number.positive-infinity] + [frac//negative-infinity number.negative-infinity] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [int//+ _.+] + [int//- _.-] + [int//* _.*] + [int/// _.floor] + [int//% _.rem] + [int//= _.=] + [int//< _.<] + ) + +(do-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 "min" (nullary int//min)) + (install "max" (nullary int//max)) + (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 "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (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 "hash" (unary _.sxhash/1)) + ## (install "replace-once" (trinary text//replace-once)) + ## (install "replace-all" (trinary text//replace-all)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + (install "upper" (unary _.string-upcase/1)) + (install "lower" (unary _.string-downcase/1)) + ))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + ((_.$apply2 (_.global "expt")) subject param)) + +(def: math-func + (-> Text (-> Expression Expression)) + (|>> _.global _.$apply1)) + +(def: math-procs + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash<Text>) + (install "cos" (unary (math-func "cos"))) + (install "sin" (unary (math-func "sin"))) + (install "tan" (unary (math-func "tan"))) + (install "acos" (unary (math-func "acos"))) + (install "asin" (unary (math-func "asin"))) + (install "atan" (unary (math-func "atan"))) + (install "exp" (unary (math-func "exp"))) + (install "log" (unary (math-func "log"))) + (install "ceil" (unary (math-func "ceiling"))) + (install "floor" (unary (math-func "floor"))) + (install "pow" (binary math//pow)) + ))) + +## [[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))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> (list) _.vector)) + +(def: (atom//read atom) + Unary + (_.svref atom (_.int 0))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (runtimeT.atom//compare-and-swap atomO oldO newO)) + +(def: atom-procs + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +## [[Box]] +(def: (box//write [valueO boxO]) + Binary + (runtimeT.box//write valueO boxO)) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "write" (binary box//write))))) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (_.int 1)) + +(def: (process//schedule [milli-secondsO procedureO]) + Binary + (runtimeT.process//schedule milli-secondsO procedureO)) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash<Text>) + (install "concurrency-level" (nullary process//concurrency-level)) + (install "schedule" (binary process//schedule))))) + +## [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 array-procs) + (dict.merge math-procs) + (dict.merge io-procs) + (dict.merge atom-procs) + (dict.merge box-procs) + (dict.merge process-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 new file mode 100644 index 000000000..c1b43da2f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/host.jvm.lux @@ -0,0 +1,89 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro "macro/" Monad<Meta>]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [ruby #+ Ruby Expression Statement]))) + [///] + (/// [".T" runtime]) + (// ["@" common])) + +## (do-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 new file mode 100644 index 000000000..9de2121a1 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/reference.jvm.lux @@ -0,0 +1,42 @@ +(.module: + lux + (lux [macro] + (data [text] + text/format)) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + (host ["_" common-lisp #+ Expression SVar @@]))) + [//] + (// [".T" runtime])) + +(do-template [<register> <translation> <prefix>] + [(def: #export (<register> register) + (-> Register SVar) + (_.var (format <prefix> (%i (nat-to-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 (int-to-nat var)))) + +(def: #export (translate-variable var) + (-> Variable (Meta Expression)) + (if (variableL.captured? var) + (translate-captured (variableL.captured-register var)) + (translate-local (int-to-nat var)))) + +(def: #export global + (-> Ident SVar) + (|>> //.definition-name _.var)) + +(def: #export (translate-definition name) + (-> Ident (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 new file mode 100644 index 000000000..eae90e771 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux @@ -0,0 +1,372 @@ +(.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) + (-> Bool 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 Bool Expression Expression) + (variant' (_.int (:! Int tag)) (flag last?) value)) + +(def: #export none + Expression + (variant +0 false unit)) + +(def: #export some + (-> Expression Expression) + (variant +1 true)) + +(def: #export left + (-> Expression Expression) + (variant +0 false)) + +(def: #export right + (-> Expression Expression) + (variant +1 true)) + +(type: Runtime Expression) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-symbol (p/wrap (list))) + (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: [[name args] declaration] + definition) + (let [implementation (code.local-symbol (format "@@" name)) + runtime (format prefix "__" (lang.normalize-name name)) + $runtime (` (_.var (~ (code.text runtime)))) + @runtime (` (@@ (~ $runtime))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol 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-symbol))] + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-symbol var) + (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.handler-case + (list [(_.bool true) 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//shift-right shift input) + (_.if (_.= (_.int 0) (@@ shift)) + (@@ input) + (|> (@@ input) + (_.ash (_.* (_.int -1) (@@ shift))) + (_.logand (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Runtime + (_.progn (list @@bit//shift-right))) + +(do-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: (atom//compare-and-swap atom old new) + (with-vars [temp] + (_.let (list [temp (_.svref (@@ atom) (_.int 0))]) + (_.if (_.eq (@@ old) (@@ temp)) + (_.progn + (list (_.setf! (_.svref (@@ atom) (_.int 0)) (@@ new)) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Runtime + @@atom//compare-and-swap) + +(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: process//incoming + SVar + (_.var (lang.normalize-name "process//incoming"))) + +(runtime: (process//loop _) + (_.if (_.not (_.null (@@ process//incoming))) + (with-vars [queue process] + (_.let (list [queue (@@ process//incoming)]) + (_.progn (list (_.setq! process//incoming (_.list (list))) + (_.map/3 _.nil + (_.lambda (_.poly (list process)) + (_.funcall (list ..unit) (@@ process))) + (@@ queue)) + (process//loop ..unit))))) + ..unit)) + +(runtime: (process//schedule milli-seconds procedure) + (_.progn + (list + (_.if (_.= (_.int 0) (@@ milli-seconds)) + (_.setq! process//incoming (_.cons (@@ procedure) (@@ process//incoming))) + (with-vars [start scheduled now diff _ignored] + (_.let (list [start (io//current-time ..unit)]) + (_.labels (list [scheduled [(_.poly+ (list) _ignored) + (_.let (list [now (io//current-time ..unit)] + [diff (|> (@@ now) (_.- (@@ start)))]) + (_.if (|> (@@ diff) (_.>= (@@ milli-seconds))) + (_.funcall (list ..unit) (@@ procedure)) + (process//schedule (|> (@@ milli-seconds) (_.- (@@ diff))) + (_.function (@@ scheduled)))))]]) + (_.setq! process//incoming (_.cons (_.function (@@ scheduled)) + (@@ process//incoming))))))) + ..unit))) + +(def: runtime//process + Runtime + (_.progn (list (_.defparameter process//incoming (_.list (list))) + @@process//loop + @@process//schedule))) + +(def: runtime + Runtime + (_.progn (list runtime//lux + runtime//bit + runtime//adt + runtime//text + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process)) + ) + +(def: #export artifact Text (format prefix //.file-extension)) + +(def: #export translate + (Meta (Process Unit)) + (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 new file mode 100644 index 000000000..17f8b4ccb --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/statement.jvm.lux @@ -0,0 +1,45 @@ +(.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 Unit)) + (do macro.Monad<Meta> + [current-module macro.current-module-name + #let [def-ident [current-module name]]] + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) + (do @ + [[realT realA realV] (macro.find-def real-def) + _ (moduleL.define def-ident [realT metaV realV])] + (wrap [])) + + _ + (do @ + [#let [def-name (referenceT.global def-ident)] + _ (//.save (_.defparameter def-name expressionO)) + expressionV (evalT.eval (@@ def-name)) + _ (moduleL.define def-ident [expressionT metaV expressionV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil + (wrap []) + + tags + (moduleL.declare-tags tags (macro.export? metaV) (:! Type expressionV))) + (wrap [])) + #let [_ (log! (format "DEF " (%ident def-ident)))]] + (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 new file mode 100644 index 000000000..fe7009627 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/structure.jvm.lux @@ -0,0 +1,31 @@ +(.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 Bool Synthesis (Meta Expression)) + (do macro.Monad<Meta> + [valueT (translate valueS)] + (wrap (runtimeT.variant tag tail? valueT)))) |