aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/synthesis
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/synthesis/case.lux17
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux58
2 files changed, 38 insertions, 37 deletions
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
index 15cb6eca3..e66bbf3a8 100644
--- a/new-luxc/source/luxc/lang/synthesis/case.lux
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -2,6 +2,7 @@
lux
(lux (data [bool "bool/" Eq<Bool>]
[text "text/" Eq<Text>]
+ text/format
[number]
(coll [list "list/" Fold<List>]))
(meta [code "code/" Eq<Code>]))
@@ -11,7 +12,7 @@
(def: #export (path pattern)
(-> la;Pattern ls;Path)
(case pattern
- (^code [(~@ membersP)])
+ (^code ("lux case tuple" [(~@ membersP)]))
(case (list;reverse membersP)
#;Nil
(' ("lux case pop"))
@@ -30,12 +31,16 @@
[(n.dec last-idx)
(` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))]
prevsP)]
- tuple-path))
+ (` ("lux case seq"
+ (~ tuple-path)
+ ("lux case pop")))))
- (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
- (if (n.= (n.dec num-tags) tag)
- (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP))))
- (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))
+ (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
+ (` ("lux case seq"
+ (~ (if (n.= (n.dec num-tags) tag)
+ (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP))))
+ (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP))))))
+ ("lux case pop")))
_
pattern))
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux
index 05b99923b..531606ba7 100644
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ b/new-luxc/source/luxc/lang/synthesis/expression.lux
@@ -85,11 +85,11 @@
(|> (synthesize expr)
(~) ("lux case exec")
("lux case seq" (~ (caseS;path pattern)))
- (`))))]
- (` ("lux case" (~ inputS)
- (~ (list/fold caseS;weave
- (transform-branch lastP lastA)
- (list/map (product;uncurry transform-branch) prevsPA))))))
+ (`))))
+ pathS (list/fold caseS;weave
+ (transform-branch lastP lastA)
+ (list/map (product;uncurry transform-branch) prevsPA))]
+ (` ("lux case" (~ inputS) (~ pathS))))
_
(undefined)
@@ -117,46 +117,42 @@
_
(call$ funcS argsS))))
-(def: #export (synthesize analysis)
+(def: #export (synthesize expressionA)
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
resolver init-resolver
num-locals +0
- exprA analysis]
- (case exprA
+ expressionA expressionA]
+ (case expressionA
(^code [(~ _left) (~ _right)])
- (` [(~@ (list/map (recur +0 resolver num-locals) (la;unfold-tuple exprA)))])
+ (` [(~@ (list/map (recur outer-arity resolver num-locals) (la;unfold-tuple expressionA)))])
(^or (^code ("lux sum left" (~ _)))
(^code ("lux sum right" (~ _))))
- (let [[tag last? value] (maybe;assume (la;unfold-variant exprA))]
- (variant$ tag last? (recur +0 resolver num-locals value)))
+ (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))]
+ (variant$ tag last? (recur outer-arity resolver num-locals value)))
(^code ((~ [_ (#;Int var)])))
(if (variableL;local? var)
- (let [register (variableL;local-register var)]
- (if (functionS;nested? outer-arity)
- (if (n.= +0 register)
- (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
- (list/map (|>. variableL;local code;int (~) () (`)))))
- (var$ (functionS;adjust-var outer-arity (variableL;local register))))
- (var$ (variableL;local register))))
- (let [register (variableL;captured-register var)]
- (var$ (let [var (variableL;captured register)]
- (maybe;default var (dict;get var resolver))))))
+ (if (functionS;nested? outer-arity)
+ (if (variableL;self? var)
+ (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
+ (list/map (|>. variableL;local code;int (~) () (`)))))
+ (var$ (functionS;adjust-var outer-arity var)))
+ (var$ var))
+ (var$ (maybe;default var (dict;get var resolver))))
(^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
- (synthesize-case (recur +0 resolver num-locals) inputA branchesA)
+ (synthesize-case (recur outer-arity resolver num-locals) inputA branchesA)
(^multi (^code ("lux function" [(~@ scope)] (~ bodyA)))
[(s;run scope (p;some s;int)) (#e;Success raw-env)])
(let [inner-arity (n.inc outer-arity)
env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env)
- env-vars (let [env-size (list;size raw-env)]
- (: (List Variable)
- (case env-size
- +0 (list)
- _ (list/map variableL;captured (list;n.range +0 (n.dec env-size))))))
+ env-vars (: (List Variable)
+ (case raw-env
+ #;Nil (list)
+ _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured))))
resolver' (if (functionS;nested? inner-arity)
(list/fold (function [[from to] resolver']
(dict;put from to resolver'))
@@ -166,7 +162,7 @@
(dict;put var var resolver'))
init-resolver
env-vars))]
- (case (recur inner-arity resolver' +0 bodyA)
+ (case (recur inner-arity resolver' num-locals bodyA)
(^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))])
(let [arity (n.inc arity')]
(function$ arity env (prepare-body inner-arity arity bodyS')))
@@ -175,10 +171,10 @@
(function$ +1 env (prepare-body inner-arity +1 bodyS))))
(^code ("lux apply" (~@ _)))
- (synthesize-apply synthesize outer-arity num-locals exprA)
+ (synthesize-apply (recur outer-arity resolver num-locals) outer-arity num-locals expressionA)
(^code ((~ [_ (#;Text name)]) (~@ args)))
- (procedure$ name (list/map (recur +0 resolver num-locals) args))
+ (procedure$ name (list/map (recur outer-arity resolver num-locals) args))
_
- exprA)))
+ expressionA)))