aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2021-05-30 01:23:42 -0400
committerEduardo Julian2021-05-30 01:23:42 -0400
commit6e0eb104c7682ea11692ecb66a186898ae6e706f (patch)
treedf9266d176dc2133cae15691ae47a20b7a868568 /stdlib/source
parentef3a84b05c924ae5978bdc7336120a5adb9713b4 (diff)
Some improvements to pattern-matching compilation.
But will have to postpone Common Lisp, as ABCL is getting overwhelmed.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux101
1 files changed, 54 insertions, 47 deletions
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 08250d5d9..2896e0030 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
@@ -5,7 +5,8 @@
[control
["." exception (#+ exception:)]]
[data
- ["." text]
+ ["." text
+ ["%" format (#+ format)]]
[collection
["." list ("#\." functor fold monoid)]
["." set]]]
@@ -98,26 +99,21 @@
(list (_.setq @cursor (_.car/1 @savepoint))
(_.setq @savepoint (_.cdr/1 @savepoint))))
-(def: @fail (_.label "lux_pm_fail"))
-(def: @done (_.label "lux_pm_done"))
-
-(def: fail! (_.return-from ..@fail _.nil))
-
(def: (multi_pop! pops)
(-> Nat (Expression Any))
(_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor])))
(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx next!)
- (-> Bit Nat (Maybe (Expression Any)) (Expression Any))
+ [(def: (<name> @fail simple? idx next!)
+ (-> _.Tag Bit Nat (Maybe (Expression Any)) (Expression Any))
(.let [<failure_condition> (_.eq/2 [@variant @temp])]
(_.let (list [@variant ..peek])
(list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
(.if simple?
(_.when <failure_condition>
- fail!)
+ (_.go @fail))
(_.if <failure_condition>
- fail!
+ (_.go @fail)
(..push! @temp)))
(.case next!
(#.Some next!)
@@ -130,21 +126,25 @@
[right_choice (_.string "") inc]
)
-(def: (alternation pre! post!)
- (-> (Expression Any) (Expression Any) (Expression Any))
- (_.progn ($_ list\compose
- (list (_.block ..@fail
- (list ..save!
- pre!)))
- ..restore!
- (list post!))))
+(def: (alternation @otherwise pre! post!)
+ (-> _.Tag (Expression Any) (Expression Any) (Expression Any))
+ (_.tagbody ($_ list\compose
+ (list ..save!
+ pre!
+ @otherwise)
+ ..restore!
+ (list post!))))
(def: (pattern_matching' expression archive)
- (Generator Path)
- (function (recur pathP)
+ (Generator [Var/1 _.Tag _.Tag Path])
+ (function (recur [$output @done @fail pathP])
(.case pathP
(^ (/////synthesis.path/then bodyS))
- (\ ///////phase.monad map (_.return-from ..@done) (expression archive bodyS))
+ (\ ///////phase.monad map
+ (function (_ outputV)
+ (_.progn (list (_.setq $output outputV)
+ (_.go @done))))
+ (expression archive bodyS))
#/////synthesis.Pop
(///////phase\wrap ..pop!)
@@ -154,13 +154,13 @@
(#/////synthesis.Bit_Fork when thenP elseP)
(do {! ///////phase.monad}
- [then! (recur thenP)
+ [then! (recur [$output @done @fail thenP])
else! (.case elseP
(#.Some elseP)
- (recur elseP)
+ (recur [$output @done @fail elseP])
#.None
- (wrap ..fail!))]
+ (wrap (_.go @fail)))]
(wrap (.if when
(_.if ..peek
then!
@@ -174,14 +174,14 @@
(do {! ///////phase.monad}
[clauses (monad.map ! (function (_ [match then])
(do !
- [then! (recur then)]
+ [then! (recur [$output @done @fail then])]
(wrap [(<=> [(|> match <format>)
..peek])
then!])))
(#.Cons cons))]
(wrap (list\fold (function (_ [when then] else)
(_.if when then else))
- ..fail!
+ (_.go @fail)
clauses)))])
([#/////synthesis.I64_Fork //primitive.i64 _.=/2]
[#/////synthesis.F64_Fork //primitive.f64 _.=/2]
@@ -189,12 +189,12 @@
(^template [<complex> <simple> <choice>]
[(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx #.None))
+ (///////phase\wrap (<choice> @fail false idx #.None))
(^ (<simple> idx nextP))
(|> nextP
- recur
- (\ ///////phase.monad map (|>> #.Some (<choice> true idx))))])
+ [$output @done @fail] recur
+ (\ ///////phase.monad map (|>> #.Some (<choice> @fail true idx))))])
([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
[/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
@@ -210,36 +210,41 @@
(^ (/////synthesis.!multi_pop nextP))
(.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
(do ///////phase.monad
- [next! (recur nextP')]
+ [next! (recur [$output @done @fail nextP'])]
(///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops))
next!)))))
(^ (/////synthesis.path/alt preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
- (wrap (..alternation pre! post!)))
+ (do {! ///////phase.monad}
+ [@otherwise (\ ! map (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next)
+ pre! (recur [$output @done @otherwise preP])
+ post! (recur [$output @done @fail postP])]
+ (wrap (..alternation @otherwise pre! post!)))
(^ (/////synthesis.path/seq preP postP))
(do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
+ [pre! (recur [$output @done @fail preP])
+ post! (recur [$output @done @fail postP])]
(wrap (_.progn (list pre! post!)))))))
-(def: (pattern_matching expression archive pathP)
- (Generator Path)
- (do ///////phase.monad
- [pattern_matching! (pattern_matching' expression archive pathP)]
- (wrap (_.block ..@done
- (list (_.block ..@fail
- (list pattern_matching!))
- (_.error/1 (_.string ////synthesis/case.pattern_matching_error)))))))
+(def: (pattern_matching $output expression archive pathP)
+ (-> Var/1 (Generator Path))
+ (do {! ///////phase.monad}
+ [@done (\ ! map (|>> %.nat (format "lux_case_done") _.tag) /////generation.next)
+ @fail (\ ! map (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next)
+ pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])]
+ (wrap (_.tagbody
+ (list pattern_matching!
+ @fail
+ (_.error/1 (_.string ////synthesis/case.pattern_matching_error))
+ @done)))))
(def: #export (case expression archive [valueS pathP])
(Generator [Synthesis Path])
- (do ///////phase.monad
+ (do {! ///////phase.monad}
[initG (expression archive valueS)
- pattern_matching! (pattern_matching expression archive pathP)
+ $output (\ ! map (|>> %.nat (format "lux_case_output") _.var) /////generation.next)
+ pattern_matching! (pattern_matching $output expression archive pathP)
#let [storage (|> pathP
////synthesis/case.storage
(get@ #////synthesis/case.bindings)
@@ -250,5 +255,7 @@
(wrap (_.let (list& [@cursor (_.list/* (list initG))]
[@savepoint (_.list/* (list))]
[@temp _.nil]
+ [$output _.nil]
storage)
- (list pattern_matching!)))))
+ (list pattern_matching!
+ $output)))))