1 # env is an alist of ((sym . val) (sym . val) ...)
  2 # we never modify `in` or `env`
  3 # ignore 'screen-cell' on a first reading; it's a hack for sandboxes
  4 # 'call-number' is just for showing intermediate progress; this is a _slow_ interpreter
  5 fn evaluate _in: (addr handle cell), out: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), screen-cell: (addr handle cell), keyboard-cell: (addr handle cell), call-number: int {
  6   # stack overflow?   # disable when enabling Really-debug-print
  7   check-stack
  8   show-stack-state
  9   # errors? skip
 10   {
 11     compare trace, 0
 12     break-if-=
 13     var error?/eax: boolean <- has-errors? trace
 14     compare error?, 0/false
 15     break-if-=
 16     return
 17   }
 18   var in/esi: (addr handle cell) <- copy _in
 19   # show intermediate progress on screen if necessary
 20   {
 21     compare screen-cell, 0
 22     break-if-=
 23     var tmp/eax: int <- copy call-number
 24     tmp <- and 0x3f  # every 64 calls to evaluate
 25     compare tmp, 0
 26     break-if-!=
 27     var screen-cell/eax: (addr handle cell) <- copy screen-cell
 28     var screen-cell-addr/eax: (addr cell) <- lookup *screen-cell
 29     compare screen-cell-addr, 0
 30     break-if-=
 31     var screen-obj-ah/eax: (addr handle screen) <- get screen-cell-addr, screen-data
 32     var screen-obj/eax: (addr screen) <- lookup *screen-obj-ah
 33     compare screen-obj, 0
 34     break-if-=
 35     var y/ecx: int <- render-screen 0/screen, screen-obj, 0x70/xmin, 2/ymin
 36   }
 37 #?   dump-cell in
 38 #?   {
 39 #?     var foo/eax: byte <- read-key 0/keyboard
 40 #?     compare foo, 0
 41 #?     loop-if-=
 42 #?   }
 43 +-- 14 lines: # trace "evaluate " in " in environment " env -----------------------------------------------------------------------------------------------------------------------------
 57   trace-lower trace
 58   var in-addr/eax: (addr cell) <- lookup *in
 59   {
 60     var nil?/eax: boolean <- nil? in-addr
 61     compare nil?, 0/false
 62     break-if-=
 63     # nil is a literal
 64     trace-text trace, "eval", "nil"
 65     copy-object _in, out
 66     trace-higher trace
 67     return
 68   }
 69   var in-type/ecx: (addr int) <- get in-addr, type
 70   compare *in-type, 1/number
 71   {
 72     break-if-!=
 73     # numbers are literals
 74     trace-text trace, "eval", "number"
 75     copy-object _in, out
 76     trace-higher trace
 77     return
 78   }
 79   compare *in-type, 2/symbol
 80   {
 81     break-if-!=
 82     trace-text trace, "eval", "symbol"
 83     debug-print "a", 7/fg, 0/bg
 84     lookup-symbol in-addr, out, env-h, globals, trace, screen-cell, keyboard-cell
 85     debug-print "z", 7/fg, 0/bg
 86     trace-higher trace
 87     return
 88   }
 89   compare *in-type, 5/screen
 90   {
 91     break-if-!=
 92     trace-text trace, "eval", "screen"
 93     copy-object _in, out
 94     trace-higher trace
 95     return
 96   }
 97   compare *in-type, 6/keyboard
 98   {
 99     break-if-!=
100     trace-text trace, "eval", "keyboard"
101     copy-object _in, out
102     trace-higher trace
103     return
104   }
105   # in-addr is a syntax tree
106   $evaluate:anonymous-function: {
107     # trees starting with "fn" are anonymous functions
108     var expr/esi: (addr cell) <- copy in-addr
109     # if its first elem is not "fn", break
110     var in-addr/edx: (addr cell) <- copy in-addr
111     var first-ah/ecx: (addr handle cell) <- get in-addr, left
112     var first/eax: (addr cell) <- lookup *first-ah
113     var fn?/eax: boolean <- fn? first
114     compare fn?, 0/false
115     break-if-=
116     # turn (fn ...) into (fn env ...)
117     trace-text trace, "eval", "anonymous function"
118     var rest-ah/eax: (addr handle cell) <- get in-addr, right
119     var tmp: (handle cell)
120     var tmp-ah/edi: (addr handle cell) <- address tmp
121     new-pair tmp-ah, env-h, *rest-ah
122     new-pair out, *first-ah, *tmp-ah
123     trace-higher trace
124     return
125   }
126   # builtins with "special" evaluation rules
127   $evaluate:quote: {
128     # trees starting with single quote create literals
129     var expr/esi: (addr cell) <- copy in-addr
130     # if its first elem is not "'", break
131     var first-ah/ecx: (addr handle cell) <- get in-addr, left
132     var rest-ah/edx: (addr handle cell) <- get in-addr, right
133     var first/eax: (addr cell) <- lookup *first-ah
134     var first-type/ecx: (addr int) <- get first, type
135     compare *first-type, 2/symbol
136     break-if-!=
137     var sym-data-ah/eax: (addr handle stream byte) <- get first, text-data
138     var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
139     var quote?/eax: boolean <- stream-data-equal? sym-data, "'"
140     compare quote?, 0/false
141     break-if-=
142     #
143     trace-text trace, "eval", "quote"
144     copy-object rest-ah, out
145     trace-higher trace
146     return
147   }
148   $evaluate:set: {
149     # trees starting with "set" define globals
150     var expr/esi: (addr cell) <- copy in-addr
151     # if its first elem is not "set", break
152     var first-ah/ecx: (addr handle cell) <- get in-addr, left
153     var rest-ah/edx: (addr handle cell) <- get in-addr, right
154     var first/eax: (addr cell) <- lookup *first-ah
155     var first-type/ecx: (addr int) <- get first, type
156     compare *first-type, 2/symbol
157     break-if-!=
158     var sym-data-ah/eax: (addr handle stream byte) <- get first, text-data
159     var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
160     var set?/eax: boolean <- stream-data-equal? sym-data, "set"
161     compare set?, 0/false
162     break-if-=
163     #
164     trace-text trace, "eval", "set"
165     trace-text trace, "eval", "evaluating second arg"
166     var rest/eax: (addr cell) <- lookup *rest-ah
167     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
168     {
169       var first-arg/eax: (addr cell) <- lookup *first-arg-ah
170       var first-arg-type/eax: (addr int) <- get first-arg, type
171       compare *first-arg-type, 2/symbol
172       break-if-=
173       error trace, "first arg to set must be a symbol"
174       trace-higher trace
175       return
176     }
177     rest-ah <- get rest, right
178     rest <- lookup *rest-ah
179     var second-arg-ah/edx: (addr handle cell) <- get rest, left
180     debug-print "P", 4/fg, 0/bg
181     increment call-number
182     evaluate second-arg-ah, out, env-h, globals, trace, screen-cell, keyboard-cell, call-number
183     debug-print "Q", 4/fg, 0/bg
184     trace-text trace, "eval", "saving global binding"
185     var first-arg/eax: (addr cell) <- lookup *first-arg-ah
186     var first-arg-data-ah/eax: (addr handle stream byte) <- get first-arg, text-data
187     var first-arg-data/eax: (addr stream byte) <- lookup *first-arg-data-ah
188     var tmp-string: (handle array byte)
189     var tmp-ah/edx: (addr handle array byte) <- address tmp-string
190     rewind-stream first-arg-data
191     stream-to-array first-arg-data, tmp-ah
192     var first-arg-data-string/eax: (addr array byte) <- lookup *tmp-ah
193     var out2/edi: (addr handle cell) <- copy out
194     append-global globals, first-arg-data-string, *out2
195     trace-higher trace
196     return
197   }
198   $evaluate:if: {
199     # trees starting with "if" are conditionals
200     var expr/esi: (addr cell) <- copy in-addr
201     # if its first elem is not "if", break
202     var first-ah/ecx: (addr handle cell) <- get in-addr, left
203     var rest-ah/edx: (addr handle cell) <- get in-addr, right
204     var first/eax: (addr cell) <- lookup *first-ah
205     var first-type/ecx: (addr int) <- get first, type
206     compare *first-type, 2/symbol
207     break-if-!=
208     var sym-data-ah/eax: (addr handle stream byte) <- get first, text-data
209     var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
210     var if?/eax: boolean <- stream-data-equal? sym-data, "if"
211     compare if?, 0/false
212     break-if-=
213     #
214     trace-text trace, "eval", "if"
215     trace-text trace, "eval", "evaluating first arg"
216     var rest/eax: (addr cell) <- lookup *rest-ah
217     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
218     var guard-h: (handle cell)
219     var guard-ah/esi: (addr handle cell) <- address guard-h
220     debug-print "R", 4/fg, 0/bg
221     increment call-number
222     evaluate first-arg-ah, guard-ah, env-h, globals, trace, screen-cell, keyboard-cell, call-number
223     debug-print "S", 4/fg, 0/bg
224     rest-ah <- get rest, right
225     rest <- lookup *rest-ah
226     var branch-ah/edi: (addr handle cell) <- get rest, left
227     var guard-a/eax: (addr cell) <- lookup *guard-ah
228     var skip-to-third-arg?/eax: boolean <- nil? guard-a
229     compare skip-to-third-arg?, 0/false
230     {
231       break-if-=
232       trace-text trace, "eval", "skipping to third arg"
233       var rest/eax: (addr cell) <- lookup *rest-ah
234       rest-ah <- get rest, right
235       rest <- lookup *rest-ah
236       branch-ah <- get rest, left
237     }
238     debug-print "T", 4/fg, 0/bg
239     increment call-number
240     evaluate branch-ah, out, env-h, globals, trace, screen-cell, keyboard-cell, call-number
241     debug-print "U", 4/fg, 0/bg
242     trace-higher trace
243     return
244   }
245   trace-text trace, "eval", "function call"
246   trace-text trace, "eval", "evaluating list elements"
247   trace-lower trace
248   var evaluated-list-storage: (handle cell)
249   var evaluated-list-ah/esi: (addr handle cell) <- address evaluated-list-storage
250   var curr-out-ah/edx: (addr handle cell) <- copy evaluated-list-ah
251   var curr/ecx: (addr cell) <- copy in-addr
252   $evaluate-list:loop: {
253     allocate-pair curr-out-ah
254     var nil?/eax: boolean <- nil? curr
255     compare nil?, 0/false
256     break-if-!=
257     # eval left
258     var curr-out/eax: (addr cell) <- lookup *curr-out-ah
259     var left-out-ah/edi: (addr handle cell) <- get curr-out, left
260     var left-ah/esi: (addr handle cell) <- get curr, left
261     debug-print "A", 4/fg, 0/bg
262     increment call-number
263     evaluate left-ah, left-out-ah, env-h, globals, trace, screen-cell, keyboard-cell, call-number
264     debug-print "B", 4/fg, 0/bg
265     #
266     curr-out-ah <- get curr-out, right
267     var right-ah/eax: (addr handle cell) <- get curr, right
268     var right/eax: (addr cell) <- lookup *right-ah
269     curr <- copy right
270     loop
271   }
272   trace-higher trace
273   var evaluated-list/eax: (addr cell) <- lookup *evaluated-list-ah
274   var function-ah/ecx: (addr handle cell) <- get evaluated-list, left
275   var args-ah/edx: (addr handle cell) <- get evaluated-list, right
276   debug-print "C", 4/fg, 0/bg
277   apply function-ah, args-ah, out, globals, trace, screen-cell, keyboard-cell, call-number
278   debug-print "Y", 4/fg, 0/bg
279   trace-higher trace
280 +-- 11 lines: # trace "=> " out ---------------------------------------------------------------------------------------------------------------------------------------------------------
291   debug-print "Z", 4/fg, 0/bg
292 }
293 
294 fn apply _f-ah: (addr handle cell), args-ah: (addr handle cell), out: (addr handle cell), globals: (addr global-table), trace: (addr trace), screen-cell: (addr handle cell), keyboard-cell: (addr handle cell), call-number: int {
295   var f-ah/eax: (addr handle cell) <- copy _f-ah
296   var _f/eax: (addr cell) <- lookup *f-ah
297   var f/esi: (addr cell) <- copy _f
298   # call primitive functions
299   {
300     var f-type/eax: (addr int) <- get f, type
301     compare *f-type, 4/primitive-function
302     break-if-!=
303     apply-primitive f, args-ah, out, globals, trace
304     return
305   }
306   # if it's not a primitive function it must be an anonymous function
307 +-- 14 lines: # trace "apply anonymous function " f " in environment " env --------------------------------------------------------------------------------------------------------------
321   trace-lower trace
322   {
323     var f-type/ecx: (addr int) <- get f, type
324     compare *f-type, 0/pair
325     break-if-!=
326     var first-ah/eax: (addr handle cell) <- get f, left
327     var first/eax: (addr cell) <- lookup *first-ah
328     var fn?/eax: boolean <- fn? first
329     compare fn?, 0/false
330     break-if-=
331     var rest-ah/esi: (addr handle cell) <- get f, right
332     var rest/eax: (addr cell) <- lookup *rest-ah
333     var callee-env-ah/edx: (addr handle cell) <- get rest, left
334     rest-ah <- get rest, right
335     rest <- lookup *rest-ah
336     var params-ah/ecx: (addr handle cell) <- get rest, left
337     var body-ah/eax: (addr handle cell) <- get rest, right
338     debug-print "D", 7/fg, 0/bg
339     apply-function params-ah, args-ah, body-ah, out, *callee-env-ah, globals, trace, screen-cell, keyboard-cell, call-number
340     debug-print "Y", 7/fg, 0/bg
341     trace-higher trace
342     return
343   }
344   error trace, "unknown function"
345 }
346 
347 fn apply-function params-ah: (addr handle cell), args-ah: (addr handle cell), _body-ah: (addr handle cell), out: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), screen-cell: (addr handle cell), keyboard-cell: (addr handle cell), call-number: int {
348   # push bindings for params to env
349   var new-env-storage: (handle cell)
350   var new-env-ah/esi: (addr handle cell) <- address new-env-storage
351   push-bindings params-ah, args-ah, env-h, new-env-ah, trace
352   # eval all expressions in body, writing result to `out` each time
353   var body-ah/ecx: (addr handle cell) <- copy _body-ah
354   $apply-function:body: {
355     var body/eax: (addr cell) <- lookup *body-ah
356     # stop when body is nil
357     {
358       var body-nil?/eax: boolean <- nil? body
359       compare body-nil?, 0/false
360       break-if-!= $apply-function:body
361     }
362     # evaluate each expression, writing result to `out`
363     {
364       var curr-ah/eax: (addr handle cell) <- get body, left
365       debug-print "E", 7/fg, 0/bg
366       increment call-number
367       evaluate curr-ah, out, *new-env-ah, globals, trace, screen-cell, keyboard-cell, call-number
368       debug-print "X", 7/fg, 0/bg
369     }
370     #
371     body-ah <- get body, right
372     loop
373   }
374   # `out` contains result of evaluating final expression
375 }
376 
377 # Bind params to corresponding args and add the bindings to old-env. Return
378 # the result in env-ah.
379 #
380 # We never modify old-env, but we point to it. This way other parts of the
381 # interpreter can continue using old-env, and everything works harmoniously
382 # even though no cells are copied around.
383 #
384 # env should always be a DAG (ignoring internals of values). It doesn't have
385 # to be a tree (some values may be shared), but there are also no cycles.
386 #
387 # Learn more: https://en.wikipedia.org/wiki/Persistent_data_structure
388 fn push-bindings _params-ah: (addr handle cell), _args-ah: (addr handle cell), old-env-h: (handle cell), env-ah: (addr handle cell), trace: (addr trace) {
389   var params-ah/edx: (addr handle cell) <- copy _params-ah
390   var args-ah/ebx: (addr handle cell) <- copy _args-ah
391   var _params/eax: (addr cell) <- lookup *params-ah
392   var params/esi: (addr cell) <- copy _params
393   {
394     var params-nil?/eax: boolean <- nil? params
395     compare params-nil?, 0/false
396     break-if-=
397     # nil is a literal
398     trace-text trace, "eval", "done with push-bindings"
399     copy-handle old-env-h, env-ah
400     return
401   }
402   # Params can only be symbols or pairs. Args can be anything.
403 +-- 16 lines: # trace "pushing bindings from " params " to " args -----------------------------------------------------------------------------------------------------------------------
419   trace-lower trace
420   var params-type/eax: (addr int) <- get params, type
421   compare *params-type, 2/symbol
422   {
423     break-if-!=
424     trace-text trace, "eval", "symbol; binding to all remaining args"
425     # create a new binding
426     var new-binding-storage: (handle cell)
427     var new-binding-ah/eax: (addr handle cell) <- address new-binding-storage
428     new-pair new-binding-ah, *params-ah, *args-ah
429     # push it to env
430     new-pair env-ah, *new-binding-ah, old-env-h
431     trace-higher trace
432     return
433   }
434   compare *params-type, 0/pair
435   {
436     break-if-=
437     error trace, "cannot bind a non-symbol"
438     trace-higher trace
439     return
440   }
441   var _args/eax: (addr cell) <- lookup *args-ah
442   var args/edi: (addr cell) <- copy _args
443   # params is now a pair, so args must be also
444   var args-type/eax: (addr int) <- get args, type
445   compare *args-type, 0/pair
446   {
447     break-if-=
448     error trace, "args not in a proper list"
449     trace-higher trace
450     return
451   }
452   var intermediate-env-storage: (handle cell)
453   var intermediate-env-ah/edx: (addr handle cell) <- address intermediate-env-storage
454   var first-param-ah/eax: (addr handle cell) <- get params, left
455   var first-arg-ah/ecx: (addr handle cell) <- get args, left
456   push-bindings first-param-ah, first-arg-ah, old-env-h, intermediate-env-ah, trace
457   var remaining-params-ah/eax: (addr handle cell) <- get params, right
458   var remaining-args-ah/ecx: (addr handle cell) <- get args, right
459   push-bindings remaining-params-ah, remaining-args-ah, *intermediate-env-ah, env-ah, trace
460   trace-higher trace
461 }
462 
463 fn lookup-symbol sym: (addr cell), out: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), screen-cell: (addr handle cell), keyboard-cell: (addr handle cell) {
464   # trace sym
465   {
466     compare trace, 0
467     break-if-=
468     var stream-storage: (stream byte 0x800)  # pessimistically sized just for the large alist loaded from disk in `main`
469     var stream/ecx: (addr stream byte) <- address stream-storage
470     write stream, "look up "
471     var sym2/eax: (addr cell) <- copy sym
472     var sym-data-ah/eax: (addr handle stream byte) <- get sym2, text-data
473     var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
474     rewind-stream sym-data
475     write-stream stream, sym-data
476     write stream, " in "
477     var env-ah/eax: (addr handle cell) <- address env-h
478     print-cell env-ah, stream, 0/no-trace
479     trace trace, "eval", stream
480   }
481   trace-lower trace
482   var _env/eax: (addr cell) <- lookup env-h
483   var env/ebx: (addr cell) <- copy _env
484   # if env is not a list, abort
485   {
486     var env-type/ecx: (addr int) <- get env, type
487     compare *env-type, 0/pair
488     break-if-=
489     error trace, "eval found a non-list environment"
490     trace-higher trace
491     return
492   }
493   # if env is nil, look up in globals
494   {
495     var env-nil?/eax: boolean <- nil? env
496     compare env-nil?, 0/false
497     break-if-=
498     debug-print "b", 7/fg, 0/bg
499     lookup-symbol-in-globals sym, out, globals, trace, screen-cell, keyboard-cell
500     debug-print "x", 7/fg, 0/bg
501     trace-higher trace
502 +-- 15 lines: # trace "=> " out " (global)" ---------------------------------------------------------------------------------------------------------------------------------------------
517     debug-print "y", 7/fg, 0/bg
518     return
519   }
520   # check car
521   var env-head-storage: (handle cell)
522   var env-head-ah/eax: (addr handle cell) <- address env-head-storage
523   car env, env-head-ah, 0/no-trace
524   var _env-head/eax: (addr cell) <- lookup *env-head-ah
525   var env-head/ecx: (addr cell) <- copy _env-head
526   # if car is not a list, abort
527   {
528     var env-head-type/eax: (addr int) <- get env-head, type
529     compare *env-head-type, 0/pair
530     break-if-=
531     error trace, "environment is not a list of (key . value) pairs"
532     trace-higher trace
533     return
534   }
535   # check key
536   var curr-key-storage: (handle cell)
537   var curr-key-ah/eax: (addr handle cell) <- address curr-key-storage
538   car env-head, curr-key-ah, trace
539   var curr-key/eax: (addr cell) <- lookup *curr-key-ah
540   # if key is not a symbol, abort
541   {
542     var curr-key-type/eax: (addr int) <- get curr-key, type
543     compare *curr-key-type, 2/symbol
544     break-if-=
545     error trace, "environment contains a binding for a non-symbol"
546     trace-higher trace
547     return
548   }
549   # if key matches sym, return val
550   var match?/eax: boolean <- cell-isomorphic? curr-key, sym, trace
551   compare match?, 0/false
552   {
553     break-if-=
554     cdr env-head, out, 0/no-trace
555 +-- 15 lines: # trace "=> " out " (match)" ----------------------------------------------------------------------------------------------------------------------------------------------
570     trace-higher trace
571     return
572   }
573   # otherwise recurse
574   var env-tail-storage: (handle cell)
575   var env-tail-ah/eax: (addr handle cell) <- address env-tail-storage
576   cdr env, env-tail-ah, trace
577   lookup-symbol sym, out, *env-tail-ah, globals, trace, screen-cell, keyboard-cell
578   trace-higher trace
579 +-- 15 lines: # trace "=> " out " (recurse)" --------------------------------------------------------------------------------------------------------------------------------------------
594 }
595 
596 fn test-lookup-symbol-in-env {
597   # tmp = (a . 3)
598   var val-storage: (handle cell)
599   var val-ah/ecx: (addr handle cell) <- address val-storage
600   new-integer val-ah, 3
601   var key-storage: (handle cell)
602   var key-ah/edx: (addr handle cell) <- address key-storage
603   new-symbol key-ah, "a"
604   var env-storage: (handle cell)
605   var env-ah/ebx: (addr handle cell) <- address env-storage
606   new-pair env-ah, *key-ah, *val-ah
607   # env = ((a . 3))
608   var nil-storage: (handle cell)
609   var nil-ah/ecx: (addr handle cell) <- address nil-storage
610   allocate-pair nil-ah
611   new-pair env-ah, *env-ah, *nil-ah
612   # lookup sym(a) in env tmp
613   var tmp-storage: (handle cell)
614   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
615   new-symbol tmp-ah, "a"
616   var in/eax: (addr cell) <- lookup *tmp-ah
617   lookup-symbol in, tmp-ah, *env-ah, 0/no-globals, 0/no-trace, 0/no-screen, 0/no-keyboard
618   var result/eax: (addr cell) <- lookup *tmp-ah
619   var result-type/edx: (addr int) <- get result, type
620   check-ints-equal *result-type, 1/number, "F - test-lookup-symbol-in-env/0"
621   var result-value-addr/eax: (addr float) <- get result, number-data
622   var result-value/eax: int <- convert *result-value-addr
623   check-ints-equal result-value, 3, "F - test-lookup-symbol-in-env/1"
624 }
625 
626 fn test-lookup-symbol-in-globals {
627   var globals-storage: global-table
628   var globals/edi: (addr global-table) <- address globals-storage
629   initialize-globals globals
630   # env = nil
631   var nil-storage: (handle cell)
632   var nil-ah/ecx: (addr handle cell) <- address nil-storage
633   allocate-pair nil-ah
634   # lookup sym(a), env
635   var tmp-storage: (handle cell)
636   var tmp-ah/ebx: (addr handle cell) <- address tmp-storage
637   new-symbol tmp-ah, "+"
638   var in/eax: (addr cell) <- lookup *tmp-ah
639   lookup-symbol in, tmp-ah, *nil-ah, globals, 0/no-trace, 0/no-screen, 0/no-keyboard
640   var result/eax: (addr cell) <- lookup *tmp-ah
641   var result-type/edx: (addr int) <- get result, type
642   check-ints-equal *result-type, 4/primitive-function, "F - test-lookup-symbol-in-globals/0"
643   var result-value/eax: (addr int) <- get result, index-data
644   check-ints-equal *result-value, 2/add, "F - test-lookup-symbol-in-globals/1"
645 }
646 
647 fn car _in: (addr cell), out: (addr handle cell), trace: (addr trace) {
648   trace-text trace, "eval", "car"
649   trace-lower trace
650   var in/eax: (addr cell) <- copy _in
651   # if in is not a list, abort
652   {
653     var in-type/ecx: (addr int) <- get in, type
654     compare *in-type, 0/pair
655     break-if-=
656     error trace, "car on a non-list"
657     trace-higher trace
658     return
659   }
660   # if in is nil, abort
661   {
662     var in-nil?/eax: boolean <- nil? in
663     compare in-nil?, 0/false
664     break-if-=
665     error trace, "car on nil"
666     trace-higher trace
667     return
668   }
669   var in-left/eax: (addr handle cell) <- get in, left
670   copy-object in-left, out
671   trace-higher trace
672   return
673 }
674 
675 fn cdr _in: (addr cell), out: (addr handle cell), trace: (addr trace) {
676   trace-text trace, "eval", "cdr"
677   trace-lower trace
678   var in/eax: (addr cell) <- copy _in
679   # if in is not a list, abort
680   {
681     var in-type/ecx: (addr int) <- get in, type
682     compare *in-type, 0/pair
683     break-if-=
684     error trace, "car on a non-list"
685     trace-higher trace
686     return
687   }
688   # if in is nil, abort
689   {
690     var in-nil?/eax: boolean <- nil? in
691     compare in-nil?, 0/false
692     break-if-=
693     error trace, "car on nil"
694     trace-higher trace
695     return
696   }
697   var in-right/eax: (addr handle cell) <- get in, right
698   copy-object in-right, out
699   trace-higher trace
700   return
701 }
702 
703 fn cell-isomorphic? _a: (addr cell), _b: (addr cell), trace: (addr trace) -> _/eax: boolean {
704   trace-text trace, "eval", "cell-isomorphic?"
705   trace-lower trace
706   var a/esi: (addr cell) <- copy _a
707   var b/edi: (addr cell) <- copy _b
708   # if types don't match, return false
709   var a-type-addr/eax: (addr int) <- get a, type
710   var b-type-addr/ecx: (addr int) <- get b, type
711   var b-type/ecx: int <- copy *b-type-addr
712   compare b-type, *a-type-addr
713   {
714     break-if-=
715     trace-higher trace
716     trace-text trace, "eval", "=> false (type)"
717     return 0/false
718   }
719   # if types are number, compare number-data
720   # TODO: exactly comparing floats is a bad idea
721   compare b-type, 1/number
722   {
723     break-if-!=
724     var a-val-addr/eax: (addr float) <- get a, number-data
725     var b-val-addr/ecx: (addr float) <- get b, number-data
726     var a-val/xmm0: float <- copy *a-val-addr
727     compare a-val, *b-val-addr
728     {
729       break-if-=
730       trace-higher trace
731       trace-text trace, "eval", "=> false (numbers)"
732       return 0/false
733     }
734     trace-higher trace
735     trace-text trace, "eval", "=> true (numbers)"
736     return 1/true
737   }
738   compare b-type, 2/symbol
739   {
740     break-if-!=
741     var b-val-ah/eax: (addr handle stream byte) <- get b, text-data
742     var _b-val/eax: (addr stream byte) <- lookup *b-val-ah
743     var b-val/ecx: (addr stream byte) <- copy _b-val
744     var a-val-ah/eax: (addr handle stream byte) <- get a, text-data
745     var a-val/eax: (addr stream byte) <- lookup *a-val-ah
746     var tmp-array: (handle array byte)
747     var tmp-ah/edx: (addr handle array byte) <- address tmp-array
748     rewind-stream a-val
749     stream-to-array a-val, tmp-ah
750     var tmp/eax: (addr array byte) <- lookup *tmp-ah
751     var match?/eax: boolean <- stream-data-equal? b-val, tmp
752     trace-higher trace
753     {
754       compare match?, 0/false
755       break-if-=
756       trace-text trace, "eval", "=> true (symbols)"
757     }
758     {
759       compare match?, 0/false
760       break-if-!=
761       trace-text trace, "eval", "=> false (symbols)"
762     }
763     return match?
764   }
765   # if a is nil, b should be nil
766   {
767     # (assumes nil? returns 0 or 1)
768     var _b-nil?/eax: boolean <- nil? b
769     var b-nil?/ecx: boolean <- copy _b-nil?
770     var a-nil?/eax: boolean <- nil? a
771     # a == nil and b == nil => return true
772     {
773       compare a-nil?, 0/false
774       break-if-=
775       compare b-nil?, 0/false
776       break-if-=
777       trace-higher trace
778       trace-text trace, "eval", "=> true (nils)"
779       return 1/true
780     }
781     # a == nil => return false
782     {
783       compare a-nil?, 0/false
784       break-if-=
785       trace-higher trace
786       trace-text trace, "eval", "=> false (b != nil)"
787       return 0/false
788     }
789     # b == nil => return false
790     {
791       compare b-nil?, 0/false
792       break-if-=
793       trace-higher trace
794       trace-text trace, "eval", "=> false (a != nil)"
795       return 0/false
796     }
797   }
798   # a and b are pairs
799   var a-tmp-storage: (handle cell)
800   var a-tmp-ah/edx: (addr handle cell) <- address a-tmp-storage
801   var b-tmp-storage: (handle cell)
802   var b-tmp-ah/ebx: (addr handle cell) <- address b-tmp-storage
803   # if cars aren't equal, return false
804   car a, a-tmp-ah, trace
805   car b, b-tmp-ah, trace
806   {
807     var _a-tmp/eax: (addr cell) <- lookup *a-tmp-ah
808     var a-tmp/ecx: (addr cell) <- copy _a-tmp
809     var b-tmp/eax: (addr cell) <- lookup *b-tmp-ah
810     var result/eax: boolean <- cell-isomorphic? a-tmp, b-tmp, trace
811     compare result, 0/false
812     break-if-!=
813     trace-higher trace
814     trace-text trace, "eval", "=> false (car mismatch)"
815     return 0/false
816   }
817   # recurse on cdrs
818   cdr a, a-tmp-ah, trace
819   cdr b, b-tmp-ah, trace
820   var _a-tmp/eax: (addr cell) <- lookup *a-tmp-ah
821   var a-tmp/ecx: (addr cell) <- copy _a-tmp
822   var b-tmp/eax: (addr cell) <- lookup *b-tmp-ah
823   var result/eax: boolean <- cell-isomorphic? a-tmp, b-tmp, trace
824   trace-higher trace
825   return result
826 }
827 
828 fn fn? _x: (addr cell) -> _/eax: boolean {
829   var x/esi: (addr cell) <- copy _x
830   var type/eax: (addr int) <- get x, type
831   compare *type, 2/symbol
832   {
833     break-if-=
834     return 0/false
835   }
836   var contents-ah/eax: (addr handle stream byte) <- get x, text-data
837   var contents/eax: (addr stream byte) <- lookup *contents-ah
838   var result/eax: boolean <- stream-data-equal? contents, "fn"
839   return result
840 }
841 
842 fn test-evaluate-is-well-behaved {
843   var t-storage: trace
844   var t/esi: (addr trace) <- address t-storage
845   initialize-trace t, 0x10, 0/visible  # we don't use trace UI
846   # env = nil
847   var env-storage: (handle cell)
848   var env-ah/ecx: (addr handle cell) <- address env-storage
849   allocate-pair env-ah
850   # eval sym(a), nil env
851   var tmp-storage: (handle cell)
852   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
853   new-symbol tmp-ah, "a"
854   evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, t, 0/no-screen, 0/no-keyboard, 0/call-number
855   # doesn't die
856   check-trace-contains t, "error", "unbound symbol: a", "F - test-evaluate-is-well-behaved"
857 }
858 
859 fn test-evaluate-number {
860   # env = nil
861   var env-storage: (handle cell)
862   var env-ah/ecx: (addr handle cell) <- address env-storage
863   allocate-pair env-ah
864   # tmp = 3
865   var tmp-storage: (handle cell)
866   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
867   new-integer tmp-ah, 3
868   evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, 0/no-trace, 0/no-screen, 0/no-keyboard, 0/call-number
869   #
870   var result/eax: (addr cell) <- lookup *tmp-ah
871   var result-type/edx: (addr int) <- get result, type
872   check-ints-equal *result-type, 1/number, "F - test-evaluate-number/0"
873   var result-value-addr/eax: (addr float) <- get result, number-data
874   var result-value/eax: int <- convert *result-value-addr
875   check-ints-equal result-value, 3, "F - test-evaluate-number/1"
876 }
877 
878 fn test-evaluate-symbol {
879   # tmp = (a . 3)
880   var val-storage: (handle cell)
881   var val-ah/ecx: (addr handle cell) <- address val-storage
882   new-integer val-ah, 3
883   var key-storage: (handle cell)
884   var key-ah/edx: (addr handle cell) <- address key-storage
885   new-symbol key-ah, "a"
886   var env-storage: (handle cell)
887   var env-ah/ebx: (addr handle cell) <- address env-storage
888   new-pair env-ah, *key-ah, *val-ah
889   # env = ((a . 3))
890   var nil-storage: (handle cell)
891   var nil-ah/ecx: (addr handle cell) <- address nil-storage
892   allocate-pair nil-ah
893   new-pair env-ah, *env-ah, *nil-ah
894   # eval sym(a), env
895   var tmp-storage: (handle cell)
896   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
897   new-symbol tmp-ah, "a"
898   evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, 0/no-trace, 0/no-screen, 0/no-keyboard, 0/call-number
899   var result/eax: (addr cell) <- lookup *tmp-ah
900   var result-type/edx: (addr int) <- get result, type
901   check-ints-equal *result-type, 1/number, "F - test-evaluate-symbol/0"
902   var result-value-addr/eax: (addr float) <- get result, number-data
903   var result-value/eax: int <- convert *result-value-addr
904   check-ints-equal result-value, 3, "F - test-evaluate-symbol/1"
905 }
906 
907 fn test-evaluate-primitive-function {
908   var globals-storage: global-table
909   var globals/edi: (addr global-table) <- address globals-storage
910   initialize-globals globals
911   var nil-storage: (handle cell)
912   var nil-ah/ecx: (addr handle cell) <- address nil-storage
913   allocate-pair nil-ah
914   var add-storage: (handle cell)
915   var add-ah/ebx: (addr handle cell) <- address add-storage
916   new-symbol add-ah, "+"
917   # eval +, nil env
918   var tmp-storage: (handle cell)
919   var tmp-ah/esi: (addr handle cell) <- address tmp-storage
920   evaluate add-ah, tmp-ah, *nil-ah, globals, 0/no-trace, 0/no-screen, 0/no-keyboard, 0/call-number
921   #
922   var result/eax: (addr cell) <- lookup *tmp-ah
923   var result-type/edx: (addr int) <- get result, type
924   check-ints-equal *result-type, 4/primitive-function, "F - test-evaluate-primitive-function/0"
925   var result-value/eax: (addr int) <- get result, index-data
926   check-ints-equal *result-value, 2/add, "F - test-evaluate-primitive-function/1"
927 }
928 
929 fn test-evaluate-primitive-function-call {
930   var t-storage: trace
931   var t/edi: (addr trace) <- address t-storage
932   initialize-trace t, 0x100, 0/visible  # we don't use trace UI
933   #
934   var nil-storage: (handle cell)
935   var nil-ah/ecx: (addr handle cell) <- address nil-storage
936   allocate-pair nil-ah
937   var one-storage: (handle cell)
938   var one-ah/edx: (addr handle cell) <- address one-storage
939   new-integer one-ah, 1
940   var add-storage: (handle cell)
941   var add-ah/ebx: (addr handle cell) <- address add-storage
942   new-symbol add-ah, "+"
943   # input is (+ 1 1)
944   var tmp-storage: (handle cell)
945   var tmp-ah/esi: (addr handle cell) <- address tmp-storage
946   new-pair tmp-ah, *one-ah, *nil-ah
947   new-pair tmp-ah, *one-ah, *tmp-ah
948   new-pair tmp-ah, *add-ah, *tmp-ah
949 #?   dump-cell tmp-ah
950   #
951   var globals-storage: global-table
952   var globals/edx: (addr global-table) <- address globals-storage
953   initialize-globals globals
954   #
955   evaluate tmp-ah, tmp-ah, *nil-ah, globals, t, 0/no-screen, 0/no-keyboard, 0/call-number
956 #?   dump-trace t
957   #
958   var result/eax: (addr cell) <- lookup *tmp-ah
959   var result-type/edx: (addr int) <- get result, type
960   check-ints-equal *result-type, 1/number, "F - test-evaluate-primitive-function-call/0"
961   var result-value-addr/eax: (addr float) <- get result, number-data
962   var result-value/eax: int <- convert *result-value-addr
963   check-ints-equal result-value, 2, "F - test-evaluate-primitive-function-call/1"
964 }