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