@@ -1,554 +0,0 @@
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−--