diff options
Diffstat (limited to '')
13 files changed, 1365 insertions, 30 deletions
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 |