@@ -0,0 +1,554 @@
5+((eval-chunk chunk) *state)
11+ %blok (eval-blok +.chunk)
15+ |$ obj [objs=(map (object-id obj) obj) next-id=(object-id obj)]
18+ [%table val=(object-id table) meta=(unit (object-id table))]
21+ [%multires (lest value)]
29+ [%table-field (object-id table) value]
31++$ table (map value value)
34+ tables=$~([(malt ~[[0 *table]]) 1] (objects table))
36+ local-envs=$~(~[(malt ~[['_ENV' table+[0 ~]]])] (lest (map name value)))
40+ $-(state [st=state val=val])
47+ |* [prev=(eval-m) cont=$-(* (eval-m mold))]
50+ =/ [st=state val=_val:$:prev] (prev st)
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)
82+ ;< res=_val:$:act bind act
88+ =. local-envs.st [*(map name value) local-envs.st]
94+ ?~ t.local-envs.st !!
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)
115+ ;< lhs=(lest lval) bind (process-varlist +<.stat)
116+ ;< rhs=(lest value) bind (eval-exprlist +>.stat)
117+ =/ asmnts (zip lhs (normalize-multires-exprlist rhs))
122+ %var ((set-var ->.i.asmnts) +.i.asmnts)
124+ ;< tabl=table bind (get-table ->-.i.asmnts)
125+ (set-table ->-.i.asmnts (~(put by tabl) ->+.i.asmnts +.i.asmnts))
130+ %+ turn attrnamelist.stat
131+ |= [=name attr=(unit attrib)]
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
140+ %- ~(uni by i.local-envs.st)
142+ (weld (turn lhs |=(=name [name `value`nil+~])) actual-values)
149+ ;< envs=(list (map name value)) bind get-local-envs
150+ =/ new-envs=(unit (lest (map name value)))
152+ ^- (unit (lest (map name value)))
154+ ?. (~(has by i.envs) var)
155+ =/ rest $(envs t.envs)
158+ `[(~(put by i.envs) var val) t.envs]
162+ =. local-envs.st u.new-envs
164+ =/ global-env (need ((get-from-local-envs envs) '_ENV'))
165+ :: TODO: proper error
168+ ;< tabl=table bind (get-table +<.global-env)
169+ (set-table +<.global-env (~(put by tabl) (string-val var) val))
171+++ normalize-multires-exprlist
172+ |= vals=(list value)
175+ ?~ t.vals ~[(normalize-multires i.vals)]
176+ [i.vals $(vals t.vals)]
177+++ normalize-multires
183+ =/ vals=(lest value) +.val
186+ =/ tail=value (normalize-multires i.vals)
187+ ?: ?=(%multires -.tail) +.tail [tail ~]
188+ [i.vals $(vals t.vals)]
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)
205+ %name (pure var++.var)
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])
213+ ;< prefix=value bind (eval-prefix-expr +<.var)
214+ :: TODO: proper error
215+ ?. ?=(%table -.prefix) !!
216+ (pure table-field+[val.prefix (string-val +>.var)])
228+ %binop (eval-binop +.expr)
229+ %prefix-expr (eval-prefix-expr +.expr)
230+ %unop (eval-unop +.expr)
232+ ;< tabl-id=(object-id table) bind (eval-table +.expr)
233+ (pure table+[tabl-id ~])
238+ ^- (eval-m (object-id table))
239+ ;< felds=(list [value value]) bind
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)
250+ ;< v=value bind (eval-expr +.i.tabl)
251+ ?: &(?=(~ t.tabl) ?=(%multires -.v))
252+ =/ vals=(list value) +.v
254+ ^- (list [value value])
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])
261+ (new-table (malt felds))
269+ ;< val=value bind (eval-expr expr)
270+ ;< num=numeral bind (assert-numeral val)
273+ %int num+int+(neg:st +.num)
274+ %float num+float+(sub:rd *@rd +.num)
277+ ;< val=value bind (eval-expr expr)
279+ ?: (falsy val) [%false ~] [%true ~]
281+ ;< val=value bind (eval-expr expr)
282+ ;< n=numeral bind (assert-numeral val)
283+ ;< i=@st bind (to-int n)
285+ num+int+(mix i mask:st)
288+ |= [lhs=expr op=binop rhs=expr]
293+ ;< lhs=value bind (eval-expr lhs)
294+ ;< rhs=value bind (eval-expr rhs)
295+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
299+ %i :- %int (add:st a.unified b.unified)
300+ %f :- %float (add:rd a.unified b.unified)
303+ ;< lhs=value bind (eval-expr lhs)
304+ ;< rhs=value bind (eval-expr rhs)
305+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
309+ %i :- %int (sub:st a.unified b.unified)
310+ %f :- %float (sub:rd a.unified b.unified)
313+ ;< lhs=value bind (eval-expr lhs)
314+ ;< rhs=value bind (eval-expr rhs)
315+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
319+ %i :- %int (mul:st a.unified b.unified)
320+ %f :- %float (mul:rd a.unified b.unified)
323+ ;< lhs=value bind (eval-expr lhs)
324+ ;< rhs=value bind (eval-expr rhs)
325+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
329+ %i :- %int (div:st +.unified)
330+ %f :- %float (int-div-float +.unified)
333+ ;< lhs=value bind (eval-expr lhs)
334+ ;< rhs=value bind (eval-expr rhs)
335+ ;< unified=unified-numerals bind (unify-numeral-values lhs rhs)
339+ %i :- %int (mod:st +.unified)
342+ (sub:rd a.unified (mul:rd (int-div-float +.unified) b.unified))
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))
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)
359+ num+int+(dis lhs rhs)
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)
368+ num+int+(con lhs rhs)
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)
377+ num+int+(mix lhs rhs)
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)
386+ num+int+(dis mask:st (?:((sig:st rhs) lsh rsh) [0 (abs:st rhs)] lhs))
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)
395+ num+int+(dis mask:st (?:((sig:st rhs) rsh lsh) [0 (abs:st rhs)] lhs))
397+ ;< lhs=value bind (eval-expr lhs)
398+ ?. (falsy lhs) (pure lhs)
401+ ;< lhs=value bind (eval-expr lhs)
402+ ?: (falsy lhs) (pure lhs)
410+ %int (scow %s (to-s:st +.n))
411+ %float (scow %rd +.n)
415+ =/ whole=(unit @s) (~(toi rd %d) (div:rd a b))
416+ ?~ whole (div:rd .~0 .~0)
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))
426+ |= [a=numeral b=numeral]
428+ ?: &(?=(%int -.a) ?=(%int -.b)) [%i +.a +.b]
429+ [%f (to-float a) (to-float b)]
433+ ?: ?=(%float -.n) +.n
434+ (san:rd (to-s:st +.n))
439+ ?: ?=(%int -.n) (pure +.n)
440+ =/ i=(unit @s) (toi:rd +.n)
441+ :: TODO: proper error
444+ =/ cycled (san:rd i)
445+ :: TODO: proper error
446+ :: checks that we don't lose any information
448+ (pure (from-s:st i))
459+ :: TODO: throw a proper error
466+ %expr (eval-expr +.prefix-expr)
467+ %call (eval-functioncall +.prefix-expr)
470+ %name (lookup-var +>.prefix-expr)
472+ ;< tabl=value bind (eval-prefix-expr +>-.prefix-expr)
473+ (lookup-table-field tabl (string-val +>+.prefix-expr))
475+ ;< tabl=value bind (eval-prefix-expr +>-.prefix-expr)
476+ ;< idx=value bind (eval-expr +>+.prefix-expr)
477+ (lookup-table-field tabl idx)
480+++ lookup-table-field
481+ |= [val=value fild=value]
483+ :: TODO: proper error
486+ ;< tabl=table bind (get-table val.val)
487+ =/ res (~(get by tabl) fild)
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')
501+ (lookup-table-field u.global-env (string-val name))
502+++ get-from-local-envs
503+ |= envs=(list (map name value))
507+ =/ val=(unit value) (~(get by i.envs) name)
508+ ?~ val $(envs t.envs)
520+ |= id=(object-id table)
522+ ;< tables=(objects table) bind
523+ %- get |=(st=state tables.st)
524+ =/ table (~(get by objs.tables) id)
525+ :: TODO: proper error
529+ |= [id=(object-id table) tabl=table]
532+ =. objs.tables.st (~(put by objs.tables.st) id tabl)
535+ ^- (eval-m (list (map name value)))
536+ %- get |=(st=state local-envs.st)
543+ ^- (eval-m (object-id table))
545+ =/ id next-id.tables.st
546+ =. next-id.tables.st +(id)
547+ =. objs.tables.st (~(put by objs.tables.st) id tabl)
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)]