aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/synthesis
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/synthesis')
-rw-r--r--new-luxc/source/luxc/lang/synthesis/case.lux22
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux44
2 files changed, 45 insertions, 21 deletions
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
index 8bc1e43f9..e230e2799 100644
--- a/new-luxc/source/luxc/lang/synthesis/case.lux
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -6,8 +6,10 @@
[number]
(coll [list "list/" Fold<List>]))
(meta [code "code/" Eq<Code>]))
- (luxc (lang ["la" analysis]
- ["ls" synthesis])))
+ (luxc (lang [";L" variable #+ Variable]
+ ["la" analysis]
+ ["ls" synthesis]
+ (synthesis [";S" function]))))
(def: #export (path outer-arity pattern)
(-> ls;Arity la;Pattern ls;Path)
@@ -44,8 +46,8 @@
(^code ("lux case bind" (~ [_ (#;Nat register)])))
(` ("lux case seq"
- ("lux case bind" (~ (if (n.> +1 outer-arity)
- (code;nat (n.+ (n.dec outer-arity) register))
+ ("lux case bind" (~ (if (functionS;nested? outer-arity)
+ (code;nat (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register))
(code;nat register))))
("lux case pop")))
@@ -69,16 +71,16 @@
["lux case variant left"]
["lux case variant right"])
- (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))]
- [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]])
- (case (weave left-pre right-pre)
- (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))])
+ (^ [(^code ("lux case seq" (~ preL) (~ postL)))
+ (^code ("lux case seq" (~ preR) (~ postR)))])
+ (case (weave preL preR)
+ (^code ("lux case alt" (~ thenP) (~ elseP)))
<default>
weavedP
- (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post)))))
+ (` ("lux case seq" (~ weavedP) (~ (weave postL postR)))))
_
(if (code/= leftP rightP)
- leftP
+ rightP
<default>))))
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux
index 9ea397576..f761fb57c 100644
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ b/new-luxc/source/luxc/lang/synthesis/expression.lux
@@ -23,7 +23,7 @@
(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>))
(def: (prepare-body inner-arity arity body)
- (-> Nat Nat ls;Synthesis ls;Synthesis)
+ (-> ls;Arity ls;Arity ls;Synthesis ls;Synthesis)
(if (functionS;nested? inner-arity)
body
(loopS;reify-recursion arity body)))
@@ -73,7 +73,11 @@
inputS
(^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA]))
- (let$ register inputS (synthesize bodyA))
+ (let$ (if (functionS;nested? outer-arity)
+ (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register)
+ register)
+ inputS
+ (synthesize bodyA))
(^or (^ (list [(^code true) thenA] [(^code false) elseA]))
(^ (list [(^code false) elseA] [(^code true) thenA])))
@@ -121,16 +125,17 @@
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
resolver init-resolver
+ direct? false
num-locals +0
expressionA expressionA]
(case expressionA
(^code [(~ _left) (~ _right)])
- (` [(~@ (list/map (recur outer-arity resolver num-locals) (la;unfold-tuple expressionA)))])
+ (` [(~@ (list/map (recur outer-arity resolver false num-locals) (la;unfold-tuple expressionA)))])
(^or (^code ("lux sum left" (~ _)))
(^code ("lux sum right" (~ _))))
(let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))]
- (variant$ tag last? (recur outer-arity resolver num-locals value)))
+ (variant$ tag last? (recur outer-arity resolver false num-locals value)))
(^code ((~ [_ (#;Int var)])))
(if (variableL;local? var)
@@ -143,17 +148,34 @@
(var$ (maybe;default var (dict;get var resolver))))
(^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
- (synthesize-case (recur outer-arity resolver num-locals) outer-arity inputA branchesA)
+ (synthesize-case (recur outer-arity resolver false num-locals) outer-arity 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)
+ (let [inner-arity (if direct?
+ (n.inc outer-arity)
+ +1)
+ env (list/map (function [closure]
+ (case (dict;get closure resolver)
+ (#;Some resolved)
+ (if (and (variableL;local? resolved)
+ (functionS;nested? outer-arity)
+ (|> resolved variableL;local-register (n.>= outer-arity)))
+ (functionS;adjust-var outer-arity resolved)
+ resolved)
+
+ #;None
+ (if (and (variableL;local? closure)
+ (functionS;nested? outer-arity))
+ (functionS;adjust-var outer-arity closure)
+ closure)))
+ raw-env)
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)
+ resolver' (if (and (functionS;nested? inner-arity)
+ direct?)
(list/fold (function [[from to] resolver']
(dict;put from to resolver'))
init-resolver
@@ -162,7 +184,7 @@
(dict;put var var resolver'))
init-resolver
env-vars))]
- (case (recur inner-arity resolver' num-locals bodyA)
+ (case (recur inner-arity resolver' true 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')))
@@ -171,10 +193,10 @@
(function$ +1 env (prepare-body inner-arity +1 bodyS))))
(^code ("lux apply" (~@ _)))
- (synthesize-apply (recur outer-arity resolver num-locals) outer-arity num-locals expressionA)
+ (synthesize-apply (recur outer-arity resolver false num-locals) outer-arity num-locals expressionA)
(^code ((~ [_ (#;Text name)]) (~@ args)))
- (procedure$ name (list/map (recur outer-arity resolver num-locals) args))
+ (procedure$ name (list/map (recur outer-arity resolver false num-locals) args))
_
expressionA)))