diff options
| -rw-r--r-- | stdlib/source/lux/target/common-lisp.lux | 45 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux | 38 |
2 files changed, 33 insertions, 50 deletions
diff --git a/stdlib/source/lux/target/common-lisp.lux b/stdlib/source/lux/target/common-lisp.lux index eb7e78d01..ad3d9be8f 100644 --- a/stdlib/source/lux/target/common-lisp.lux +++ b/stdlib/source/lux/target/common-lisp.lux @@ -50,7 +50,7 @@ (`` (abstract: #export <brand> {} Any)) (`` (type: #export <type> (<super> <brand>))))] - [Tag Code] + [Label Code] [Literal Expression] [Var/1 Var] [Var/* Input] @@ -64,10 +64,18 @@ Literal (:abstraction "()")) + (template [<prefix> <name>] + [(def: #export <name> + (-> Text Literal) + (|>> (format <prefix>) :abstraction))] + + ["'" symbol] + [":" keyword]) + (def: #export bool (-> Bit Literal) (|>> (case> #0 ..nil - #1 (:abstraction "t")))) + #1 (..symbol "t")))) (def: #export int (-> Int Literal) @@ -129,14 +137,6 @@ (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)) @@ -401,24 +401,17 @@ [conditional+ "#+"] [conditional- "#-"]) - (def: #export tag - (-> Text Tag) + (def: #export label + (-> Text Label) (|>> :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 (block name body) + (-> Label (Expression Any) (Computation Any)) + (..form (list (..var "block") (:transmutation name) body))) + + (def: #export (return-from target value) + (-> Label (Expression Any) (Computation Any)) + (..form (list (..var "return-from") (:transmutation target) value))) (def: #export (cond clauses else) (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any)) 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 index 144c0236e..dd5b89e38 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux @@ -69,7 +69,6 @@ (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)) @@ -93,11 +92,10 @@ (_.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 (_.label "lux_pm_fail")) +(def: @done (_.label "lux_pm_done")) -(def: fail! (_.go ..fail-tag)) -(def: return! (_.go ..done-tag)) +(def: fail! (_.return-from ..@fail _.nil)) (exception: #export unrecognized-path) @@ -126,23 +124,18 @@ (def: (alternation pre! post!) (-> (Expression Any) (Expression Any) (Expression Any)) - (_.tagbody ($_ _.progn - ..save! - pre!) - (list [fail-tag - ($_ _.progn - ..restore! - post!)]))) + (_.progn (<| (_.block ..@fail) + (_.progn ..save!) + pre!) + ($_ _.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!))) + (:: ////.monad map (_.return-from ..@done) (generate bodyS)) #/////synthesis.Pop (////@wrap ..pop!) @@ -204,13 +197,10 @@ (-> 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)))) + (wrap (_.block ..@done + (_.progn (_.block ..@fail + pattern-matching!) + (_.error/1 (_.string case.pattern-matching-error))))))) (def: #export (case generate [valueS pathP]) (-> Phase [Synthesis Path] (Operation (Expression Any))) |