diff options
Diffstat (limited to 'stdlib/source')
7 files changed, 175 insertions, 144 deletions
diff --git a/stdlib/source/lux/target/common_lisp.lux b/stdlib/source/lux/target/common_lisp.lux index 19f70cde8..25ee6e44d 100644 --- a/stdlib/source/lux/target/common_lisp.lux +++ b/stdlib/source/lux/target/common_lisp.lux @@ -149,10 +149,16 @@ (def: #export (args& singles rest) (-> (List Var/1) Var/1 Var/*) - (|> (format (|> singles - (list\map ..code) - (text.join_with " ")) - " &rest " (:representation rest)) + (|> (case singles + #.Nil + "" + + (#.Cons _) + (|> singles + (list\map ..code) + (text.join_with " ") + (text.suffix " "))) + (format "&rest " (:representation rest)) ..as_form :abstraction)) @@ -226,7 +232,9 @@ [hash-table-size/1 "hash-table-size"] [hash-table-rehash-size/1 "hash-table-rehash-size"] [code-char/1 "code-char"] - [string/1 "string"]]] + [string/1 "string"] + [write-line/1 "write-line"] + [pprint/1 "pprint"]]] [call/2 [in0 in1] [(Expression Any) (Expression Any)] [[apply/2 "apply"] [append/2 "append"] @@ -234,7 +242,13 @@ [char/2 "char"] [nth/2 "nth"] [nthcdr/2 "nthcdr"] - [coerce/2 "coerce"]]] + [coerce/2 "coerce"] + [eq/2 "eq"] + [equal/2 "equal"] + [string=/2 "string="] + [=/2 "="] + [+/2 "+"] + [*/2 "*"]]] [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] [[subseq/3 "subseq"] [map/3 "map"] @@ -292,30 +306,24 @@ ) (template [<lux_name> <host_name>] - [(def: #export (<lux_name> param subject) - (-> (Expression Any) (Expression Any) (Computation Any)) + [(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"] + [</2 "<"] + [<=/2 "<="] + [>/2 ">"] + [>=/2 ">="] + [string</2 "string<"] + [-/2 "-"] + [//2 "/"] + [rem/2 "rem"] + [floor/2 "floor"] + [mod/2 "mod"] + [ash/2 "ash"] + [logand/2 "logand"] + [logior/2 "logior"] + [logxor/2 "logxor"] ) (def: #export (if test then else) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux index d5d528631..2a64aeb1e 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux @@ -92,40 +92,41 @@ ## (-> Expression Expression Expression)) ## (//runtime.i64//64 (operation parameter subject))) -## (def: i64_procs -## Bundle -## (<| (/.prefix "i64") -## (|> /.empty -## (/.install "and" (binary (product.uncurry //runtime.i64//and))) -## (/.install "or" (binary (product.uncurry //runtime.i64//or))) -## (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) -## (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) -## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) -## (/.install "=" (binary (product.uncurry _.=/2))) -## (/.install "<" (binary (product.uncurry _.</2))) -## (/.install "+" (binary (product.uncurry (..capped _.+/2)))) -## (/.install "-" (binary (product.uncurry (..capped _.-/2)))) -## (/.install "*" (binary (product.uncurry (..capped _.*/2)))) -## (/.install "/" (binary (product.uncurry //runtime.i64//division))) -## (/.install "%" (binary (product.uncurry _.remainder/2))) -## (/.install "f64" (unary (_.//2 (_.float +1.0)))) -## (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1))))) -## ))) +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary _.logand/2)) + (/.install "or" (binary _.logior/2)) + (/.install "xor" (binary _.logxor/2)) + (/.install "left-shift" (binary _.ash/2)) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.install "=" (binary _.=/2)) + (/.install "<" (binary _.</2)) + (/.install "+" (binary _.+/2)) + (/.install "-" (binary _.-/2)) + (/.install "*" (binary _.*/2)) + (/.install "/" (binary _.floor/2)) + (/.install "%" (binary _.rem/2)) + ## (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> _.code-char/1 _.string/1))) + ))) -## (def: f64_procs -## Bundle -## (<| (/.prefix "f64") -## (|> /.empty -## (/.install "=" (binary (product.uncurry _.=/2))) -## (/.install "<" (binary (product.uncurry _.</2))) -## (/.install "+" (binary (product.uncurry _.+/2))) -## (/.install "-" (binary (product.uncurry _.-/2))) -## (/.install "*" (binary (product.uncurry _.*/2))) -## (/.install "/" (binary (product.uncurry _.//2))) -## (/.install "%" (binary (product.uncurry _.remainder/2))) -## (/.install "i64" (unary _.truncate/1)) -## (/.install "encode" (unary _.number->string/1)) -## (/.install "decode" (unary //runtime.f64//decode))))) +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + ## (/.install "=" (binary (product.uncurry _.=/2))) + ## (/.install "<" (binary (product.uncurry _.</2))) + ## (/.install "+" (binary (product.uncurry _.+/2))) + ## (/.install "-" (binary (product.uncurry _.-/2))) + ## (/.install "*" (binary (product.uncurry _.*/2))) + ## (/.install "/" (binary (product.uncurry _.//2))) + ## (/.install "%" (binary (product.uncurry _.rem/2))) + ## (/.install "i64" (unary _.truncate/1)) + (/.install "encode" (unary _.write-to-string/1)) + ## (/.install "decode" (unary //runtime.f64//decode)) + ))) ## (def: (text//index [offset sub text]) ## (Trinary Expression) @@ -135,41 +136,41 @@ ## (Trinary Expression) ## (//runtime.text//clip paramO extraO subjectO)) -## (def: text_procs -## Bundle -## (<| (/.prefix "text") -## (|> /.empty -## (/.install "=" (binary (product.uncurry _.string=?/2))) -## (/.install "<" (binary (product.uncurry _.string<?/2))) -## (/.install "concat" (binary (product.uncurry _.string-append/2))) -## (/.install "index" (trinary ..text//index)) -## (/.install "size" (unary _.string-length/1)) -## (/.install "char" (binary (product.uncurry //runtime.text//char))) -## (/.install "clip" (trinary ..text//clip)) -## ))) +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary _.string=/2)) + ## (/.install "<" (binary (product.uncurry _.string<?/2))) + (/.install "concat" (binary (function (_ [left right]) + (_.concatenate/3 [(_.symbol "string") left right])))) + ## (/.install "index" (trinary ..text//index)) + ## (/.install "size" (unary _.string-length/1)) + ## (/.install "char" (binary (product.uncurry //runtime.text//char))) + ## (/.install "clip" (trinary ..text//clip)) + ))) -## (def: (io//log! message) -## (Unary Expression) -## (_.begin (list (_.display/1 message) -## (_.display/1 (_.string text.new_line)) -## //runtime.unit))) +(def: (io//log! message) + (Unary (Expression Any)) + (_.progn (_.write-line/1 message) + //runtime.unit)) -## (def: io_procs -## Bundle -## (<| (/.prefix "io") -## (|> /.empty -## (/.install "log" (unary ..io//log!)) -## (/.install "error" (unary _.raise/1)) -## (/.install "current-time" (nullary (function.constant (//runtime.io//current_time //runtime.unit)))) -## ))) +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary _.error/1)) + ## (/.install "current-time" (nullary (function.constant (//runtime.io//current_time //runtime.unit)))) + ))) (def: #export bundle Bundle (<| (/.prefix "lux") (|> /.empty ## (dictionary.merge lux_procs) - ## (dictionary.merge i64_procs) - ## (dictionary.merge f64_procs) - ## (dictionary.merge text_procs) - ## (dictionary.merge io_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/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux index 252532489..1c669ae52 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux @@ -111,7 +111,7 @@ (template [<name> <flag> <prep>] [(def: (<name> simple? idx) (-> Bit Nat (Expression Any)) - (.let [<failure_condition> (_.eq @variant @temp)] + (.let [<failure_condition> (_.eq/2 [@variant @temp])] (_.let (list [@variant ..peek]) ($_ _.progn (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>))) @@ -172,17 +172,17 @@ [clauses (monad.map ! (function (_ [match then]) (do ! [then! (recur then)] - (wrap [(<=> (|> match <format>) - ..peek) + (wrap [(<=> [(|> match <format>) + ..peek]) then!]))) (#.Cons cons))] (wrap (list\fold (function (_ [when then] else) (_.if when then else)) ..fail! clauses)))]) - ([#/////synthesis.I64_Fork //primitive.i64 _.=] - [#/////synthesis.F64_Fork //primitive.f64 _.=] - [#/////synthesis.Text_Fork //primitive.text _.string=]) + ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] + [#/////synthesis.F64_Fork //primitive.f64 _.=/2] + [#/////synthesis.Text_Fork //primitive.text _.string=/2]) (^template [<complex> <simple> <choice>] [(^ (<complex> idx)) @@ -234,8 +234,16 @@ (Generator [Synthesis Path]) (do ///////phase.monad [initG (expression archive valueS) - pattern_matching! (pattern_matching expression archive pathP)] - (wrap (_.let (list [@cursor (_.list/* (list initG))] - [@savepoint (_.list/* (list))] - [@temp _.nil]) + pattern_matching! (pattern_matching expression archive pathP) + #let [storage (|> pathP + ////synthesis/case.storage + (get@ #////synthesis/case.bindings) + set.to_list + (list\map (function (_ register) + [(..register register) + _.nil])))]] + (wrap (_.let (list& [@cursor (_.list/* (list initG))] + [@savepoint (_.list/* (list))] + [@temp _.nil] + storage) pattern_matching!)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux index 7f4134c86..23f60e9d0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux @@ -78,12 +78,12 @@ (with_closure closureG+ (_.labels (list [@self [(_.args& (list) @curried) (_.let (list [@num_args (_.length/1 @curried)]) - (_.cond (list [(|> @num_args (_.= arityG)) + (_.cond (list [(_.=/2 [arityG @num_args]) (_.let (list initialize_self!) (_.destructuring-bind initialize! bodyG))] - [(|> @num_args (_.> arityG)) + [(_.>/2 [arityG @num_args]) (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG]) extra_inputs (_.subseq/3 [@curried arityG @num_args])] (_.apply/2 [(_.apply/2 [(_.function/1 @self) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux index 32275cdc3..14aa89668 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux @@ -33,17 +33,24 @@ (def: #export (scope expression archive [start initsS+ bodyS]) (Generator (Scope Synthesis)) - (do {! ///////phase.monad} - [@scope (\ ! map (|>> %.nat (format "scope") _.var) /////generation.next) - initsG+ (monad.map ! (expression archive) initsS+) - bodyG (/////generation.with_anchor @scope - (expression archive bodyS))] - (wrap (_.labels (list [@scope {#_.input (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register)) - _.args) - #_.output bodyG}]) - (_.funcall/+ [(_.function/1 @scope) initsG+]))))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [@scope (\ ! map (|>> %.nat (format "scope") _.var) /////generation.next) + initsG+ (monad.map ! (expression archive) initsS+) + bodyG (/////generation.with_anchor @scope + (expression archive bodyS))] + (wrap (_.labels (list [@scope {#_.input (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register)) + _.args) + #_.output bodyG}]) + (_.funcall/+ [(_.function/1 @scope) initsG+])))))) (def: #export (recur expression archive argsS+) (Generator (List Synthesis)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux index 3ac79fa7d..b8c9149d3 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux @@ -163,19 +163,19 @@ )) (def: last_index - (|>> _.length/1 (_.- (_.int +1)))) + (|>> _.length/1 [(_.int +1)] _.-/2)) (with_expansions [<recur> (as_is ($_ _.then - (_.; (_.set lefts (_.- last_index_right lefts))) + (_.; (_.set lefts (_.-/2 [last_index_right lefts]))) (_.; (_.set tuple (_.nth last_index_right tuple)))))] (template: (!recur <side>) - (<side> (|> lefts (_.- last_index_right)) + (<side> (_.-/2 [last_index_right lefts]) (_.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) + (_.if (_.>/2 [lefts last_index_right]) ## No need for recursion (_.elt/2 [tuple lefts]) ## Needs recursion @@ -184,10 +184,10 @@ (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 [(_.= last_index_right right_index) + [right_index (_.+/2 [(_.int +1) lefts])]) + (_.cond (list [(_.=/2 [last_index_right right_index]) (_.elt/2 [tuple right_index])] - [(_.> last_index_right right_index) + [(_.>/2 [last_index_right right_index]) ## Needs recursion. (!recur tuple//right)]) (_.subseq/3 [tuple right_index (_.length/1 tuple)])) @@ -204,24 +204,24 @@ test_recursion! (_.if sum_flag ## Must iterate. ($_ _.progn - (_.setq wantedTag (_.- sum_tag wantedTag)) + (_.setq wantedTag (_.-/2 [sum_tag wantedTag])) (_.setq sum sum_value)) no_match!)] (<| (_.progn (_.setq sum_tag (_.nth/2 [(_.int +0) sum]))) (_.progn (_.setq sum_flag (_.nth/2 [(_.int +1) sum]))) (_.block @exit) (_.while (_.bool true)) - (_.cond (list [(_.= sum_tag wantedTag) - (_.if (_.equal wantsLast sum_flag) + (_.cond (list [(_.=/2 [sum_tag wantedTag]) + (_.if (_.equal/2 [wantsLast sum_flag]) (return! sum_value) test_recursion!)] - [(_.> sum_tag wantedTag) + [(_.>/2 [sum_tag wantedTag]) test_recursion!] - [(_.and (_.< sum_tag wantedTag) + [(_.and (_.</2 [sum_tag wantedTag]) wantsLast) - (return! (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) + (return! (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))]) no_match!))))) @@ -232,16 +232,20 @@ @sum//get )) -(runtime: (i64//logic_right_shift shift input) - (_.if (_.= (_.int +0) shift) +(runtime: (i64//right_shift shift input) + (_.if (_.=/2 [(_.int +0) shift]) input - (|> input - (_.ash (_.* (_.int -1) shift)) - (_.logand (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + (let [anti_shift (_.-/2 [shift (_.int +64)]) + mask (|> (_.int +1) + [anti_shift] _.ash/2 + [(_.int +1)] _.-/2)] + (|> input + [(_.*/2 [(_.int -1) shift])] _.ash/2 + [mask] _.logand/2)))) (def: runtime//i64 ($_ _.progn - @i64//logic_right_shift + @i64//right_shift )) (runtime: (text//clip from to text) @@ -273,8 +277,8 @@ (_.call/* (_.var "cl-user::quit") (list code)))) (runtime: (io//current_time _) - (|> (_.get-universal-time/0 []) - (_.* (_.int +1,000)))) + (_.*/2 [(_.int +1,000) + (_.get-universal-time/0 [])])) (def: runtime//io ($_ _.progn diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 6bc35147b..4d847ec2e 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -14,8 +14,8 @@ ["." set (#+ Set)]]] [math [number - ["." i64] ["n" nat] + ["." i64] ["." frac ("#\." equivalence)]]]] ["." /// #_ [// @@ -316,12 +316,12 @@ "Invalid expression for pattern-matching.") (type: #export Storage - {#bindings (Set Variable) + {#bindings (Set Register) #dependencies (Set Variable)}) (def: empty Storage - {#bindings (set.new ///reference/variable.hash) + {#bindings (set.new n.hash) #dependencies (set.new ///reference/variable.hash)}) ## TODO: Use this to declare all local variables at the beginning of @@ -340,7 +340,7 @@ path_storage (^ (/.path/bind register)) - (update@ #bindings (set.add (#///reference/variable.Local register)) + (update@ #bindings (set.add register) path_storage) (#/.Bit_Fork _ default otherwise) @@ -374,10 +374,13 @@ (^ (/.tuple members)) (list\fold for_synthesis synthesis_storage members) - (#/.Reference (#///reference.Variable var)) - (if (set.member? (get@ #bindings synthesis_storage) var) + (#/.Reference (#///reference.Variable (#///reference/variable.Local register))) + (if (set.member? (get@ #bindings synthesis_storage) register) synthesis_storage - (update@ #dependencies (set.add var) synthesis_storage)) + (update@ #dependencies (set.add (#///reference/variable.Local register)) synthesis_storage)) + + (#/.Reference (#///reference.Variable var)) + (update@ #dependencies (set.add var) synthesis_storage) (^ (/.function/apply [functionS argsS])) (list\fold for_synthesis synthesis_storage (#.Cons functionS argsS)) @@ -393,7 +396,7 @@ (^ (/.branch/let [inputS register exprS])) (update@ #dependencies (set.union (|> synthesis_storage - (update@ #bindings (set.add (#///reference/variable.Local register))) + (update@ #bindings (set.add register)) (for_synthesis exprS) (get@ #dependencies))) (for_synthesis inputS synthesis_storage)) @@ -409,8 +412,8 @@ (set.union (|> synthesis_storage (update@ #bindings (set.union (|> initsS+ list.enumeration - (list\map (|>> product.left (n.+ start) #///reference/variable.Local)) - (set.from_list ///reference/variable.hash)))) + (list\map (|>> product.left (n.+ start))) + (set.from_list n.hash)))) (for_synthesis iterationS) (get@ #dependencies))) (list\fold for_synthesis synthesis_storage initsS+)) |