@@ -0,0 +1,508 @@
1+/- *lua
2+/+ st
3+=<
4+|= =chunk
5+((eval-chunk chunk) *state)
6+|%
7+++ eval-chunk
8+ |= =chunk
9+ ^- (eval-m value)
10+ ?- -.chunk
11+ %blok (eval-blok +.chunk)
12+ ==
13+++ object-id |$ obj @
14+++ objects
15+ |$ obj [objs=(map (object-id obj) obj) next-id=(object-id obj)]
16++$ value
17+ $%
18+ [%table val=(object-id table) meta=(unit (object-id table))]
19+ [%string string]
20+ [%num numeral]
21+ [%multires (lest value)]
22+ [%true ~]
23+ [%false ~]
24+ [%nil ~]
25+ ==
26++$ lval
27+ $%
28+ [%var name]
29+ [%table-field (object-id table) value]
30+ ==
31++$ table (map value value)
32++$ state
33+ $:
34+ tables=$~([(malt ~[[0 *table]]) 1] (objects table))
35+ global-env=table
36+ local-envs=$~(~[(malt ~[['_ENV' table+[0 ~]]])] (list (map name value)))
37+ ==
38+++ eval-m
39+ |$ [val]
40+ $-(state [st=state val=val])
41+++ pure
42+ |* x=*
43+ ^- (eval-m _x)
44+ |=(st=state [st x])
45+++ bind
46+ |* =mold
47+ |* [prev=(eval-m) cont=$-(* (eval-m mold))]
48+ ^+ $:cont
49+ |= st=state
50+ =/ [st=state val=_val:$:prev] (prev st)
51+ ((cont val) st)
52+++ get-state
53+ ^- (eval-m state)
54+ |= st=state
55+ [st st]
56+++ set-state
57+ |= st=state
58+ ^- (eval-m ~)
59+ |= state
60+ [st ~]
61+++ eval-blok
62+ |= =blok
63+ ^- (eval-m value)
64+ =/ body body.blok
65+ |-
66+ ^- (eval-m value)
67+ ?~ body
68+ ?~ ret.blok (pure nil+~)
69+ ?~ u.ret.blok (pure nil+~)
70+ ;< rets=(lest value) bind (eval-exprlist u.u.ret.blok)
71+ (pure multires+rets)
72+ ;< ~ bind (eval-stat i.body)
73+ $(body t.body)
74+++ eval-exprlist
75+ |= vals=exprlist
76+ ^- (eval-m (lest value))
77+ ;< val=value bind (eval-expr i.vals)
78+ ?~ t.vals (pure [val ~])
79+ ;< tail=(list value) bind $(vals t.vals)
80+ (pure [val tail])
81+++ eval-stat
82+ |= =stat
83+ ^- (eval-m ~)
84+ ?+ -.stat !!
85+ %asmnt
86+ ;< lhs=(lest lval) bind (process-varlist +<.stat)
87+ ;< rhs=(lest value) bind (eval-exprlist +>.stat)
88+ =/ asmnts (zip lhs (normalize-multires-exprlist rhs))
89+ |-
90+ ?~ asmnts (pure ~)
91+ ;< * bind
92+ ?- -<.i.asmnts
93+ %var ((set-var ->.i.asmnts) +.i.asmnts)
94+ %table-field
95+ ;< tabl=table bind (get-table ->-.i.asmnts)
96+ (set-table ->-.i.asmnts (~(put by tabl) ->+.i.asmnts +.i.asmnts))
97+ ==
98+ $(asmnts t.asmnts)
99+ ==
100+++ set-var
101+ |= var=name
102+ |= val=value
103+ ^- (eval-m ~)
104+ ;< envs=(list (map name value)) bind get-local-envs
105+ =/ new-envs=(unit (list (map name value)))
106+ |-
107+ ^- (unit (list (map name value)))
108+ ?~ envs ~
109+ ?. (~(has by i.envs) var)
110+ =/ rest $(envs t.envs)
111+ ?~ rest ~
112+ `[i.envs u.rest]
113+ `[(~(put by i.envs) var val) t.envs]
114+ ^- (eval-m ~)
115+ ?. ?=(~ new-envs)
116+ |= st=state
117+ =. local-envs.st u.new-envs
118+ [st ~]
119+ =/ global-env (need ((get-from-local-envs envs) '_ENV'))
120+ :: TODO: proper error
121+ ?+ -.global-env !!
122+ %table
123+ ;< tabl=table bind (get-table +<.global-env)
124+ (set-table +<.global-env (~(put by tabl) (string-val var) val))
125+ ==
126+++ normalize-multires-exprlist
127+ |= vals=(list value)
128+ ^- (list value)
129+ ?~ vals ~
130+ ?~ t.vals ~[(normalize-multires)]
131+ [i.vals $(vals t.vals)]
132+++ normalize-multires
133+ |= val=value
134+ ^- value
135+ ?+ -.val val
136+ %multires
137+ =/ res=(lest value)
138+ =/ vals=(lest value) +.val
139+ |-
140+ ?~ t.vals
141+ =/ tail=value (normalize-multires i.vals)
142+ ?: ?=(%multires -.tail) +.tail [tail ~]
143+ [i.vals $(vals t.vals)]
144+ multires+res
145+ ==
146+++ process-varlist
147+ =<
148+ |= =varlist
149+ ^- (eval-m (lest lval))
150+ ;< val=lval bind (process-var i.varlist)
151+ ?~ t.varlist (pure ~[val])
152+ ;< tail=(list lval) bind $(varlist t.varlist)
153+ (pure [val tail])
154+ |%
155+ ++ process-var
156+ |= =var
157+ ^- (eval-m lval)
158+ ?- -.var
159+ %name (pure var++.var)
160+ %indexed
161+ ;< prefix=value bind (eval-prefix-expr +<.var)
162+ ;< idx=value bind (eval-expr +>.var)
163+ :: TODO: proper error
164+ ?. ?=(%table -.prefix) !!
165+ (pure table-field+[val.prefix idx])
166+ %dot
167+ ;< prefix=value bind (eval-prefix-expr +<.var)
168+ :: TODO: proper error
169+ ?. ?=(%table -.prefix) !!
170+ (pure table-field+[val.prefix (string-val +>.var)])
171+ ==
172+ --
173+++ eval-expr
174+ |= =expr
175+ ^- (eval-m value)
176+ ?+ -.expr !!
177+ %false (pure expr)
178+ %true (pure expr)
179+ %nil (pure expr)
180+ %string (pure expr)
181+ %num (pure expr)
182+ %binop (eval-binop +.expr)
183+ %prefix-expr (eval-prefix-expr +.expr)
184+ %unop (eval-unop +.expr)
185+ %table
186+ ;< tabl-id=(object-id table) bind (eval-table +.expr)
187+ (pure table+[tabl-id ~])
188+ ==
189+++ eval-table
190+ |= tabl=^table
191+ =<
192+ ^- (eval-m (object-id table))
193+ ;< felds=(list [value value]) bind
194+ =/ counter 1
195+ |-
196+ ?~ tabl (pure ~)
197+ ?- -.i.tabl
198+ %keyed
199+ ;< k=value bind (eval-expr +<.i.tabl)
200+ ;< v=value bind (eval-expr +>.i.tabl)
201+ ;< tail=(list [value value]) bind $(tabl t.tabl)
202+ (pure [[k v] tail])
203+ %unkeyed
204+ ;< v=value bind (eval-expr +.i.tabl)
205+ ?: &(?=(~ t.tabl) ?=(%multires -.v))
206+ =/ vals=(list value) +.v
207+ %- pure
208+ ^- (list [value value])
209+ |-
210+ ?~ vals ~
211+ [[num+int+(new:st counter) i.vals] $(vals t.vals, counter +(counter))]
212+ ;< tail=(list [value value]) bind $(tabl t.tabl, counter +(counter))
213+ (pure [[num+int+(new:st counter) v] tail])
214+ ==
215+ (new-table (malt felds))
216+ |%
217+ --
218+++ eval-unop
219+ |= [op=unop =expr]
220+ ^- (eval-m value)
221+ ?+ op !!
222+ %minus
223+ ;< val=value bind (eval-expr expr)
224+ ;< num=numeral bind (assert-numeral val)
225+ %- pure
226+ ?- -.num
227+ %int num+int+(neg:st +.num)
228+ %float num+float+(sub:rd *@rd +.num)
229+ ==
230+ %not
231+ ;< val=value bind (eval-expr expr)
232+ %- pure
233+ ?: (falsy val) [%false ~] [%true ~]
234+ %sig
235+ ;< val=value bind (eval-expr expr)
236+ ;< n=numeral bind (assert-numeral val)
237+ ;< i=@st bind (to-int n)
238+ %- pure
239+ num+int+(mix i mask:st)
240+ ==
241+++ eval-binop
242+ |= [lhs=expr op=binop rhs=expr]
243+ ^- (eval-m value)
244+ =<
245+ ?+ op !!
246+ %add
247+ ;< lhs=value bind (eval-expr lhs)
248+ ;< rhs=value bind (eval-expr rhs)
249+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
250+ %- pure
251+ :- %num
252+ ?- -.unified
253+ %i :- %int (add:st a.unified b.unified)
254+ %f :- %float (add:rd a.unified b.unified)
255+ ==
256+ %sub
257+ ;< lhs=value bind (eval-expr lhs)
258+ ;< rhs=value bind (eval-expr rhs)
259+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
260+ %- pure
261+ :- %num
262+ ?- -.unified
263+ %i :- %int (sub:st a.unified b.unified)
264+ %f :- %float (sub:rd a.unified b.unified)
265+ ==
266+ %mul
267+ ;< lhs=value bind (eval-expr lhs)
268+ ;< rhs=value bind (eval-expr rhs)
269+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
270+ %- pure
271+ :- %num
272+ ?- -.unified
273+ %i :- %int (mul:st a.unified b.unified)
274+ %f :- %float (mul:rd a.unified b.unified)
275+ ==
276+ %int-div
277+ ;< lhs=value bind (eval-expr lhs)
278+ ;< rhs=value bind (eval-expr rhs)
279+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
280+ %- pure
281+ :- %num
282+ ?- -.unified
283+ %i :- %int (div:st +.unified)
284+ %f :- %float (int-div-float +.unified)
285+ ==
286+ %mod
287+ ;< lhs=value bind (eval-expr lhs)
288+ ;< rhs=value bind (eval-expr rhs)
289+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
290+ %- pure
291+ :- %num
292+ ?- -.unified
293+ %i :- %int (mod:st +.unified)
294+ %f
295+ :- %float
296+ (sub:rd a.unified (mul:rd (int-div-float +.unified) b.unified))
297+ ==
298+ %div
299+ ;< lhs=value bind (eval-expr lhs)
300+ ;< rhs=value bind (eval-expr rhs)
301+ ;< lhs=numeral bind (assert-numeral lhs)
302+ ;< rhs=numeral bind (assert-numeral rhs)
303+ %- pure num+float+(div:rd (to-float lhs) (to-float rhs))
304+ %exp !!
305+ %band
306+ ;< lhs=value bind (eval-expr lhs)
307+ ;< rhs=value bind (eval-expr rhs)
308+ ;< lhs=numeral bind (assert-numeral lhs)
309+ ;< rhs=numeral bind (assert-numeral rhs)
310+ ;< lhs=@st bind (to-int lhs)
311+ ;< rhs=@st bind (to-int rhs)
312+ %- pure
313+ num+int+(dis lhs rhs)
314+ %bor
315+ ;< lhs=value bind (eval-expr lhs)
316+ ;< rhs=value bind (eval-expr rhs)
317+ ;< lhs=numeral bind (assert-numeral lhs)
318+ ;< rhs=numeral bind (assert-numeral rhs)
319+ ;< lhs=@st bind (to-int lhs)
320+ ;< rhs=@st bind (to-int rhs)
321+ %- pure
322+ num+int+(con lhs rhs)
323+ %bxor
324+ ;< lhs=value bind (eval-expr lhs)
325+ ;< rhs=value bind (eval-expr rhs)
326+ ;< lhs=numeral bind (assert-numeral lhs)
327+ ;< rhs=numeral bind (assert-numeral rhs)
328+ ;< lhs=@st bind (to-int lhs)
329+ ;< rhs=@st bind (to-int rhs)
330+ %- pure
331+ num+int+(mix lhs rhs)
332+ %rshft
333+ ;< lhs=value bind (eval-expr lhs)
334+ ;< rhs=value bind (eval-expr rhs)
335+ ;< lhs=numeral bind (assert-numeral lhs)
336+ ;< rhs=numeral bind (assert-numeral rhs)
337+ ;< lhs=@st bind (to-int lhs)
338+ ;< rhs=@st bind (to-int rhs)
339+ %- pure
340+ num+int+(dis mask:st (?:((sig:st rhs) lsh rsh) [0 (abs:st rhs)] lhs))
341+ %lshft
342+ ;< lhs=value bind (eval-expr lhs)
343+ ;< rhs=value bind (eval-expr rhs)
344+ ;< lhs=numeral bind (assert-numeral lhs)
345+ ;< rhs=numeral bind (assert-numeral rhs)
346+ ;< lhs=@st bind (to-int lhs)
347+ ;< rhs=@st bind (to-int rhs)
348+ %- pure
349+ num+int+(dis mask:st (?:((sig:st rhs) rsh lsh) [0 (abs:st rhs)] lhs))
350+ %or
351+ ;< lhs=value bind (eval-expr lhs)
352+ ?. (falsy lhs) (pure lhs)
353+ (eval-expr rhs)
354+ %and
355+ ;< lhs=value bind (eval-expr lhs)
356+ ?: (falsy lhs) (pure lhs)
357+ (eval-expr rhs)
358+ ==
359+ |%
360+ ++ show-numeral
361+ |= n=numeral
362+ ^- tape
363+ ?- -.n
364+ %int (scow %s (to-s:st +.n))
365+ %float (scow %rd +.n)
366+ ==
367+ ++ int-div-float
368+ |= [a=@rd b=@rd]
369+ =/ whole=(unit @s) (~(toi rd %d) (div:rd a b))
370+ ?~ whole (div:rd .~0 .~0)
371+ (san:rd u.whole)
372+ +$ unified-numerals $%([%i a=@st b=@st] [%f a=@rd b=@rd])
373+ ++ unify-numeral-values
374+ |= [a=value b=value]
375+ ^- (eval-m unified-numerals)
376+ ;< a=numeral bind (assert-numeral a)
377+ ;< b=numeral bind (assert-numeral b)
378+ (pure (unify-numerals a b))
379+ ++ unify-numerals
380+ |= [a=numeral b=numeral]
381+ ^- unified-numerals
382+ ?: &(?=(%int -.a) ?=(%int -.b)) [%i +.a +.b]
383+ [%f (to-float a) (to-float b)]
384+ ++ to-float
385+ |= n=numeral
386+ ^- @rd
387+ ?: ?=(%float -.n) +.n
388+ (san:rd (to-s:st +.n))
389+ --
390+++ to-int
391+ |= n=numeral
392+ ^- (eval-m @st)
393+ ?: ?=(%int -.n) (pure +.n)
394+ =/ i=(unit @s) (toi:rd +.n)
395+ :: TODO: proper error
396+ ?~ i !!
397+ =/ i u.i
398+ =/ cycled (san:rd i)
399+ :: TODO: proper error
400+ :: checks that we don't lose any information
401+ ?. =(+.n cycled) !!
402+ (pure (from-s:st i))
403+++ falsy
404+ |= v=value
405+ ^- ?
406+ ?+ -.v |
407+ %false &
408+ %nil &
409+ ==
410+++ assert-numeral
411+ |= [a=value]
412+ ^- (eval-m numeral)
413+ :: TODO: throw a proper error
414+ ?. ?=(%num -.a) !!
415+ (pure +.a)
416+++ eval-prefix-expr
417+ |= =prefix-expr
418+ ^- (eval-m value)
419+ ?- -.prefix-expr
420+ %expr (eval-expr +.prefix-expr)
421+ %call (eval-functioncall +.prefix-expr)
422+ %var
423+ ?- +<.prefix-expr
424+ %name (lookup-var +>.prefix-expr)
425+ %dot
426+ ;< tabl=value bind (eval-prefix-expr +>-.prefix-expr)
427+ (lookup-table-field tabl (string-val +>+.prefix-expr))
428+ %indexed
429+ ;< tabl=value bind (eval-prefix-expr +>-.prefix-expr)
430+ ;< idx=value bind (eval-expr +>+.prefix-expr)
431+ (lookup-table-field tabl idx)
432+ ==
433+ ==
434+++ lookup-table-field
435+ |= [val=value fild=value]
436+ ^- (eval-m value)
437+ :: TODO: proper error
438+ ?+ -.val !!
439+ %table
440+ ;< tabl=table bind (get-table val.val)
441+ =/ res (~(get by tabl) fild)
442+ :: TODO: error
443+ ?~ res !!
444+ (pure u.res)
445+ ==
446+++ lookup-var
447+ |= =name
448+ ^- (eval-m value)
449+ ;< envs=(list (map ^name value)) bind get-local-envs
450+ =/ get-local (get-from-local-envs envs)
451+ =/ local=(unit value) (get-local name)
452+ ?. ?=(~ local) (pure u.local)
453+ =/ global-env (get-local '_ENV')
454+ ?~ global-env !!
455+ (lookup-table-field u.global-env (string-val name))
456+++ get-from-local-envs
457+ |= envs=(list (map name value))
458+ |= =name
459+ ^- (unit value)
460+ ?~ envs ~
461+ =/ val=(unit value) (~(get by i.envs) name)
462+ ?~ val $(envs t.envs)
463+ val
464+++ string-val
465+ |= val=@t
466+ ^- value
467+ string+(trip val)
468+++ get
469+ |* f=$-(state *)
470+ ^- (eval-m _$:f)
471+ |= st=state
472+ [st (f st)]
473+++ get-table
474+ |= id=(object-id table)
475+ ^- (eval-m table)
476+ ;< tables=(objects table) bind
477+ %- get |=(st=state tables.st)
478+ =/ table (~(get by objs.tables) id)
479+ :: TODO: proper error
480+ ?~ table !!
481+ (pure u.table)
482+++ set-table
483+ |= [id=(object-id table) tabl=table]
484+ ^- (eval-m ~)
485+ |= st=state
486+ =. objs.tables.st (~(put by objs.tables.st) id tabl)
487+ [st ~]
488+++ get-local-envs
489+ ^- (eval-m (list (map name value)))
490+ %- get |=(st=state local-envs.st)
491+++ eval-functioncall
492+ |= =functioncall
493+ ^- (eval-m value)
494+ !!
495+++ new-table
496+ |= tabl=table
497+ ^- (eval-m (object-id table))
498+ |= st=state
499+ =/ id next-id.tables.st
500+ =. next-id.tables.st +(id)
501+ =. objs.tables.st (~(put by objs.tables.st) id tabl)
502+ [st id]
503+++ zip
504+ |* [lhs=(list) rhs=(list)]
505+ ^- (list [_?<(?=(~ lhs) i.lhs) _?<(?=(~ rhs) i.rhs)])
506+ ?: |(?=(~ lhs) ?=(~ rhs)) ~
507+ [[i.lhs i.rhs] $(lhs t.lhs, rhs t.rhs)]
508+--