aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2021-05-25 20:08:37 -0400
committerEduardo Julian2021-05-25 20:08:37 -0400
commit2466d4983c2d5ca46822f45cca863d07ce2b1ee0 (patch)
tree1036cd0a1785c18b48c2662f644309fb2724dccd /stdlib/source
parent2df8e4bc8c53a831f3cd8605707ca08d66cecb02 (diff)
Fix for pattern-matching register binding.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/common_lisp.lux64
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux125
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux28
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux29
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux46
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux23
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+))