blob: 2f7344c6ebcdf03e50bae155c9e3baa07b73dffc (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
(;module:
lux
(lux (data text/format
[number]
(coll [list "L/" Functor<List> Fold<List> Monoid<List>]
["d" dict])))
(luxc ["&" base]
(lang ["la" analysis]
["ls" synthesis])
(synthesizer ["&&;" structure]
["&&;" function]
["&&;" loop])
))
(def: init-env (List ls;Variable) (list))
(def: init-resolver (d;Dict Int Int) (d;new number;Hash<Int>))
(def: (prepare-body inner-arity arity body)
(-> Nat Nat ls;Synthesis ls;Synthesis)
(if (&&function;nested? inner-arity)
body
(&&loop;reify-recursion arity body)))
(def: #export (synthesize analysis)
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
resolver init-resolver
num-locals +0
exprA analysis]
(case exprA
(^template [<from> <to>]
(<from> value)
(<to> value))
([#la;Unit #ls;Unit]
[#la;Bool #ls;Bool]
[#la;Nat #ls;Nat]
[#la;Int #ls;Int]
[#la;Deg #ls;Deg]
[#la;Real #ls;Real]
[#la;Char #ls;Char]
[#la;Text #ls;Text]
[#la;Absolute #ls;Definition])
(#la;Product _)
(#ls;Tuple (L/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))
(#la;Sum choice)
(let [[tag last? value] (&&structure;unfold-variant choice)]
(#ls;Variant tag last? (recur +0 resolver num-locals value)))
(#la;Relative ref)
(case ref
(#;Local register)
(if (&&function;nested? outer-arity)
(if (n.= +0 register)
(<| (#ls;Call (#ls;Variable 0))
(L/map (|>. &&function;to-local #ls;Variable))
(list;n.range +1 (n.dec outer-arity)))
(#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register))))
(#ls;Variable (&&function;to-local register)))
(#;Captured register)
(#ls;Variable (let [var (&&function;to-captured register)]
(default var (d;get var resolver)))))
(#la;Function scope bodyA)
(let [inner-arity (n.inc outer-arity)
raw-env (&&function;environment scope)
env (L/map (function [var] (default var (d;get var resolver))) raw-env)
env-vars (let [env-size (list;size raw-env)]
(: (List ls;Variable)
(case env-size
+0 (list)
_ (L/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
resolver' (if (&&function;nested? inner-arity)
(L/fold (function [[from to] resolver']
(d;put from to resolver'))
init-resolver
(list;zip2 env-vars env))
(L/fold (function [var resolver']
(d;put var var resolver'))
init-resolver
env-vars))]
(case (recur inner-arity resolver' +0 bodyA)
(#ls;Function arity' env' bodyS')
(let [arity (n.inc arity')]
(#ls;Function arity env (prepare-body inner-arity arity bodyS')))
bodyS
(#ls;Function +1 env (prepare-body inner-arity +1 bodyS))))
(#la;Apply _)
(let [[funcA argsA] (&&function;unfold-apply exprA)
funcS (recur +0 resolver num-locals funcA)
argsS (L/map (recur +0 resolver num-locals) argsA)]
(case funcS
(^multi (#ls;Function _arity _env _bodyS)
(and (n.= _arity (list;size argsS))
(not (&&loop;contains-self-reference? _bodyS))))
(let [register-offset (if (&&function;top? outer-arity)
num-locals
(|> outer-arity n.inc (n.+ num-locals)))]
(#ls;Loop register-offset argsS
(&&loop;adjust _env register-offset _bodyS)))
(#ls;Call funcS' argsS')
(#ls;Call funcS' (L/append argsS' argsS))
_
(#ls;Call funcS argsS)))
(#la;Procedure name args)
(#ls;Procedure name (L/map (recur +0 resolver num-locals) args))
_
(undefined)
## (#la;Case inputA branchesA)
## (let [inputS (recur +0 local-offset false inputA)]
## (case branchesA
## (^multi (^ (list [(#lp;Bind input-register)
## (#la;Variable (#;Local output-register))]))
## (n.= input-register output-register))
## inputS
## (^ (list [(#lp;Bind register) bodyA]))
## (#ls;Let register inputS (recur +0 local-offset tail? bodyA))
## (^or (^ (list [(#lp;Bool true) thenA] [(#lp;Bool false) elseA]))
## (^ (list [(#lp;Bool false) elseA] [(#lp;Bool true) thenA])))
## (#ls;If inputS
## (recur +0 local-offset tail? thenA)
## (recur +0 local-offset tail? elseA))
## (#;Cons [headP headA] tailPA)
## (let [headP+ (|> (recur +0 local-offset tail? headA)
## #ls;ExecP
## (#ls;SeqP (&&case;path headP)))
## tailP+ (L/map (function [[pattern bodyA]]
## (|> (recur +0 local-offset tail? bodyA)
## #ls;ExecP
## (#ls;SeqP (&&case;path pattern))))
## tailPA)]
## (#ls;Case inputS (&&case;weave-paths headP+ tailP+)))
## ))
)))
|
