shell/evaluate.mu

   1 # env is an alist of ((sym . val) (sym . val) ...)
   2 # we never modify `_in-ah` or `env`
   3 # ignore args past 'trace' on a first reading; they're for the environment not the language
   4 # 'call-number' is just for showing intermediate progress; this is a _slow_ interpreter
   5 # side-effects if not in a test (inner-screen-var != 0):
   6 #   prints intermediate states of the inner screen to outer screen
   7 #     (which may not be the real screen if we're using double-buffering)
   8 #   stops if a keypress is encountered
   9 # Inner screen is what Lisp programs modify. Outer screen is shows the program
  10 # and its inner screen to the environment.
  11 fn evaluate _in-ah: (addr handle cell), _out-ah: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), inner-screen-var: (addr handle cell), inner-keyboard-var: (addr handle cell), definitions-created: (addr stream int), call-number: (addr int) {
  12   # stack overflow?   # disable when enabling Really-debug-print
  13   check-stack
  14   {
  15     var running-tests?/eax: boolean <- running-tests?
  16     compare running-tests?, 0/false
  17     break-if-!=
  18     var old-x/eax: int <- copy 0
  19     var old-y/ecx: int <- copy 0
  20     old-x, old-y <- cursor-position 0/screen
  21     show-stack-state
  22     set-cursor-position 0/screen, old-x, old-y
  23   }
  24   # show intermediate progress on screen if necessary
  25   # treat input at the real keyboard as interrupting
  26   {
  27     compare inner-screen-var, 0
  28     break-if-=
  29     var call-number/eax: (addr int) <- copy call-number
  30     compare call-number, 0
  31     break-if-=
  32     increment *call-number
  33     var tmp/eax: int <- copy *call-number
  34     tmp <- and 0xf/responsiveness=16  # every 16 calls to evaluate
  35     compare tmp, 0
  36     break-if-!=
  37     var inner-screen-var/eax: (addr handle cell) <- copy inner-screen-var
  38     var inner-screen-var-addr/eax: (addr cell) <- lookup *inner-screen-var
  39     compare inner-screen-var-addr, 0
  40     break-if-=
  41     var screen-obj-ah/eax: (addr handle screen) <- get inner-screen-var-addr, screen-data
  42     var screen-obj/eax: (addr screen) <- lookup *screen-obj-ah
  43     compare screen-obj, 0
  44     break-if-=
  45     render-screen 0/screen, screen-obj, 0x58/xmin, 2/ymin
  46     var key/eax: byte <- read-key 0/keyboard
  47     compare key, 0
  48     break-if-=
  49     error trace, "key pressed; interrupting..."
  50   }
  51   # errors? skip
  52   {
  53     var error?/eax: boolean <- has-errors? trace
  54     compare error?, 0/false
  55     break-if-=
  56     return
  57   }
  58   var in-ah/esi: (addr handle cell) <- copy _in-ah
  59 #?   dump-cell in-ah
  60 #?   {
  61 #?     var foo/eax: byte <- read-key 0/keyboard
  62 #?     compare foo, 0
  63 #?     loop-if-=
  64 #?   }
  65   # trace "evaluate " in " in environment " env {{{
  66   {
  67     var should-trace?/eax: boolean <- should-trace? trace
  68     compare should-trace?, 0/false
  69     break-if-=
  70     var stream-storage: (stream byte 0x300)
  71     var stream/ecx: (addr stream byte) <- address stream-storage
  72     write stream, "evaluate "
  73     var nested-trace-storage: trace
  74     var nested-trace/edi: (addr trace) <- address nested-trace-storage
  75     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
  76     print-cell in-ah, stream, nested-trace
  77     write stream, " in environment "
  78     var env-ah/eax: (addr handle cell) <- address env-h
  79     clear-trace nested-trace
  80     print-cell env-ah, stream, nested-trace
  81     trace trace, "eval", stream
  82   }
  83   # }}}
  84   trace-lower trace
  85   var in/eax: (addr cell) <- lookup *in-ah
  86   {
  87     var nil?/eax: boolean <- nil? in
  88     compare nil?, 0/false
  89     break-if-=
  90     # nil is a literal
  91     trace-text trace, "eval", "nil"
  92     copy-object _in-ah, _out-ah
  93     trace-higher trace
  94     return
  95   }
  96   var in-type/ecx: (addr int) <- get in, type
  97   compare *in-type, 1/number
  98   {
  99     break-if-!=
 100     # numbers are literals
 101     trace-text trace, "eval", "number"
 102     copy-object _in-ah, _out-ah
 103     trace-higher trace
 104     return
 105   }
 106   compare *in-type, 3/stream
 107   {
 108     break-if-!=
 109     # streams are literals
 110     trace-text trace, "eval", "stream"
 111     copy-object _in-ah, _out-ah
 112     trace-higher trace
 113     return
 114   }
 115   compare *in-type, 2/symbol
 116   {
 117     break-if-!=
 118     trace-text trace, "eval", "symbol"
 119     debug-print "a", 7/fg, 0/bg
 120     lookup-symbol in, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var
 121     debug-print "z", 7/fg, 0/bg
 122     trace-higher trace
 123     return
 124   }
 125   compare *in-type, 5/screen
 126   {
 127     break-if-!=
 128     trace-text trace, "eval", "screen"
 129     copy-object _in-ah, _out-ah
 130     trace-higher trace
 131     return
 132   }
 133   compare *in-type, 6/keyboard
 134   {
 135     break-if-!=
 136     trace-text trace, "eval", "keyboard"
 137     copy-object _in-ah, _out-ah
 138     trace-higher trace
 139     return
 140   }
 141   compare *in-type, 7/array
 142   {
 143     break-if-!=
 144     trace-text trace, "eval", "array"
 145     copy-object _in-ah, _out-ah
 146     trace-higher trace
 147     return
 148   }
 149   # 'in' is a syntax tree
 150   $evaluate:literal-function: {
 151     # trees starting with "litfn" are literals
 152     var expr/esi: (addr cell) <- copy in
 153     var in/edx: (addr cell) <- copy in
 154     var first-ah/ecx: (addr handle cell) <- get in, left
 155     var first/eax: (addr cell) <- lookup *first-ah
 156     var litfn?/eax: boolean <- litfn? first
 157     compare litfn?, 0/false
 158     break-if-=
 159     trace-text trace, "eval", "literal function"
 160     copy-object _in-ah, _out-ah
 161     trace-higher trace
 162     return
 163   }
 164   $evaluate:literal-macro: {
 165     # trees starting with "litmac" are literals
 166     var expr/esi: (addr cell) <- copy in
 167     var in/edx: (addr cell) <- copy in
 168     var first-ah/ecx: (addr handle cell) <- get in, left
 169     var first/eax: (addr cell) <- lookup *first-ah
 170     var litmac?/eax: boolean <- litmac? first
 171     compare litmac?, 0/false
 172     break-if-=
 173     trace-text trace, "eval", "literal macro"
 174     copy-object _in-ah, _out-ah
 175     trace-higher trace
 176     return
 177   }
 178   $evaluate:literal-image: {
 179     # trees starting with "litimg" are literals
 180     var expr/esi: (addr cell) <- copy in
 181     var in/edx: (addr cell) <- copy in
 182     var first-ah/ecx: (addr handle cell) <- get in, left
 183     var first/eax: (addr cell) <- lookup *first-ah
 184     var litimg?/eax: boolean <- litimg? first
 185     compare litimg?, 0/false
 186     break-if-=
 187     trace-text trace, "eval", "literal image"
 188     copy-object _in-ah, _out-ah
 189     trace-higher trace
 190     return
 191   }
 192   $evaluate:anonymous-function: {
 193     # trees starting with "fn" are anonymous functions
 194     var expr/esi: (addr cell) <- copy in
 195     var in/edx: (addr cell) <- copy in
 196     var first-ah/ecx: (addr handle cell) <- get in, left
 197     var first/eax: (addr cell) <- lookup *first-ah
 198     var fn?/eax: boolean <- fn? first
 199     compare fn?, 0/false
 200     break-if-=
 201     # turn (fn ...) into (litfn env ...)
 202     trace-text trace, "eval", "anonymous function"
 203     var rest-ah/eax: (addr handle cell) <- get in, right
 204     var tmp: (handle cell)
 205     var tmp-ah/edi: (addr handle cell) <- address tmp
 206     new-pair tmp-ah, env-h, *rest-ah
 207     var litfn: (handle cell)
 208     var litfn-ah/eax: (addr handle cell) <- address litfn
 209     new-symbol litfn-ah, "litfn"
 210     new-pair _out-ah, *litfn-ah, *tmp-ah
 211     trace-higher trace
 212     return
 213   }
 214   # builtins with "special" evaluation rules
 215   $evaluate:quote: {
 216     # trees starting with single quote create literals
 217     var expr/esi: (addr cell) <- copy in
 218     # if its first elem is not "'", break
 219     var first-ah/ecx: (addr handle cell) <- get in, left
 220     var rest-ah/edx: (addr handle cell) <- get in, right
 221     var first/eax: (addr cell) <- lookup *first-ah
 222     var quote?/eax: boolean <- symbol-equal? first, "'"
 223     compare quote?, 0/false
 224     break-if-=
 225     #
 226     trace-text trace, "eval", "quote"
 227     copy-object rest-ah, _out-ah
 228     trace-higher trace
 229     return
 230   }
 231   $evaluate:backquote: {
 232     # trees starting with single backquote create literals
 233     var expr/esi: (addr cell) <- copy in
 234     # if its first elem is not "'", break
 235     var first-ah/ecx: (addr handle cell) <- get in, left
 236     var rest-ah/edx: (addr handle cell) <- get in, right
 237     var first/eax: (addr cell) <- lookup *first-ah
 238     var backquote?/eax: boolean <- symbol-equal? first, "`"
 239     compare backquote?, 0/false
 240     break-if-=
 241     #
 242     trace-text trace, "eval", "backquote"
 243     debug-print "`(", 7/fg, 0/bg
 244     evaluate-backquote rest-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 245     debug-print ")", 7/fg, 0/bg
 246     trace-higher trace
 247     return
 248   }
 249   $evaluate:apply: {
 250     var expr/esi: (addr cell) <- copy in
 251     # if its first elem is not "apply", break
 252     var first-ah/ecx: (addr handle cell) <- get in, left
 253     var rest-ah/edx: (addr handle cell) <- get in, right
 254     var first/eax: (addr cell) <- lookup *first-ah
 255     var apply?/eax: boolean <- symbol-equal? first, "apply"
 256     compare apply?, 0/false
 257     break-if-=
 258     #
 259     trace-text trace, "eval", "apply"
 260     trace-text trace, "eval", "evaluating first arg"
 261     var first-arg-value-h: (handle cell)
 262     var first-arg-value-ah/esi: (addr handle cell) <- address first-arg-value-h
 263     var rest/eax: (addr cell) <- lookup *rest-ah
 264     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 265     debug-print "A2", 4/fg, 0/bg
 266     evaluate first-arg-ah, first-arg-value-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 267     debug-print "Y2", 4/fg, 0/bg
 268     # errors? skip
 269     {
 270       var error?/eax: boolean <- has-errors? trace
 271       compare error?, 0/false
 272       break-if-=
 273       trace-higher trace
 274       return
 275     }
 276     #
 277     trace-text trace, "eval", "evaluating second arg"
 278     var rest/eax: (addr cell) <- lookup *rest-ah
 279     rest-ah <- get rest, right
 280     rest <- lookup *rest-ah
 281     var second-ah/eax: (addr handle cell) <- get rest, left
 282     var second-arg-value-h: (handle cell)
 283     var second-arg-value-ah/edi: (addr handle cell) <- address second-arg-value-h
 284     debug-print "T2", 4/fg, 0/bg
 285     evaluate second-ah, second-arg-value-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 286     debug-print "U2", 4/fg, 0/bg
 287     # apply
 288     apply first-arg-value-ah, second-arg-value-ah, _out-ah, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 289     #
 290     trace-higher trace
 291     return
 292   }
 293   $evaluate:define: {
 294     # trees starting with "define" define globals
 295     var expr/esi: (addr cell) <- copy in
 296     # if its first elem is not "define", break
 297     var first-ah/ecx: (addr handle cell) <- get in, left
 298     var rest-ah/edx: (addr handle cell) <- get in, right
 299     var first/eax: (addr cell) <- lookup *first-ah
 300     var define?/eax: boolean <- symbol-equal? first, "define"
 301     compare define?, 0/false
 302     break-if-=
 303     #
 304     trace-text trace, "eval", "define"
 305     trace-text trace, "eval", "evaluating second arg"
 306     var rest/eax: (addr cell) <- lookup *rest-ah
 307     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 308     {
 309       var first-arg/eax: (addr cell) <- lookup *first-arg-ah
 310       var first-arg-type/eax: (addr int) <- get first-arg, type
 311       compare *first-arg-type, 2/symbol
 312       break-if-=
 313       error trace, "first arg to define must be a symbol"
 314       trace-higher trace
 315       return
 316     }
 317     rest-ah <- get rest, right
 318     rest <- lookup *rest-ah
 319     var second-arg-ah/edx: (addr handle cell) <- get rest, left
 320     debug-print "P", 4/fg, 0/bg
 321     evaluate second-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 322     debug-print "Q", 4/fg, 0/bg
 323     # errors? skip
 324     {
 325       var error?/eax: boolean <- has-errors? trace
 326       compare error?, 0/false
 327       break-if-=
 328       trace-higher trace
 329       return
 330     }
 331     trace-text trace, "eval", "saving global binding"
 332     var first-arg/eax: (addr cell) <- lookup *first-arg-ah
 333     var first-arg-data-ah/eax: (addr handle stream byte) <- get first-arg, text-data
 334     var first-arg-data/eax: (addr stream byte) <- lookup *first-arg-data-ah
 335     var tmp-string: (handle array byte)
 336     var tmp-ah/edx: (addr handle array byte) <- address tmp-string
 337     rewind-stream first-arg-data
 338     stream-to-array first-arg-data, tmp-ah
 339     var first-arg-data-string/eax: (addr array byte) <- lookup *tmp-ah
 340     var out-ah/edi: (addr handle cell) <- copy _out-ah
 341     var defined-index: int
 342     var defined-index-addr/ecx: (addr int) <- address defined-index
 343     assign-or-create-global globals, first-arg-data-string, *out-ah, defined-index-addr, trace
 344     {
 345       compare definitions-created, 0
 346       break-if-=
 347       write-to-stream definitions-created, defined-index-addr
 348     }
 349     trace-higher trace
 350     return
 351   }
 352   $evaluate:set: {
 353     # trees starting with "set" mutate bindings
 354     var expr/esi: (addr cell) <- copy in
 355     # if its first elem is not "set", break
 356     var first-ah/ecx: (addr handle cell) <- get in, left
 357     var rest-ah/edx: (addr handle cell) <- get in, right
 358     var first/eax: (addr cell) <- lookup *first-ah
 359     var set?/eax: boolean <- symbol-equal? first, "set"
 360     compare set?, 0/false
 361     break-if-=
 362     #
 363     trace-text trace, "eval", "set"
 364     trace-text trace, "eval", "evaluating second arg"
 365     var rest/eax: (addr cell) <- lookup *rest-ah
 366     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 367     {
 368       var first-arg/eax: (addr cell) <- lookup *first-arg-ah
 369       var first-arg-type/eax: (addr int) <- get first-arg, type
 370       compare *first-arg-type, 2/symbol
 371       break-if-=
 372       error trace, "first arg to set must be a symbol"
 373       trace-higher trace
 374       return
 375     }
 376     rest-ah <- get rest, right
 377     rest <- lookup *rest-ah
 378     var second-arg-ah/edx: (addr handle cell) <- get rest, left
 379     debug-print "P", 4/fg, 0/bg
 380     evaluate second-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 381     debug-print "Q", 4/fg, 0/bg
 382     # errors? skip
 383     {
 384       var error?/eax: boolean <- has-errors? trace
 385       compare error?, 0/false
 386       break-if-=
 387       trace-higher trace
 388       return
 389     }
 390     trace-text trace, "eval", "mutating binding"
 391     var first-arg/eax: (addr cell) <- lookup *first-arg-ah
 392     var first-arg-data-ah/eax: (addr handle stream byte) <- get first-arg, text-data
 393     var first-arg-data/eax: (addr stream byte) <- lookup *first-arg-data-ah
 394     mutate-binding first-arg-data, _out-ah, env-h, globals, trace
 395     trace-higher trace
 396     return
 397   }
 398   $evaluate:and: {
 399     var expr/esi: (addr cell) <- copy in
 400     # if its first elem is not "and", break
 401     var first-ah/ecx: (addr handle cell) <- get in, left
 402     var rest-ah/edx: (addr handle cell) <- get in, right
 403     var first/eax: (addr cell) <- lookup *first-ah
 404     var and?/eax: boolean <- symbol-equal? first, "and"
 405     compare and?, 0/false
 406     break-if-=
 407     #
 408     trace-text trace, "eval", "and"
 409     trace-text trace, "eval", "evaluating first arg"
 410     var rest/eax: (addr cell) <- lookup *rest-ah
 411     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 412     debug-print "R2", 4/fg, 0/bg
 413     evaluate first-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 414     debug-print "S2", 4/fg, 0/bg
 415     # errors? skip
 416     {
 417       var error?/eax: boolean <- has-errors? trace
 418       compare error?, 0/false
 419       break-if-=
 420       trace-higher trace
 421       return
 422     }
 423     # if first arg is nil, short-circuit
 424     var out-ah/eax: (addr handle cell) <- copy _out-ah
 425     var out/eax: (addr cell) <- lookup *out-ah
 426     var nil?/eax: boolean <- nil? out
 427     compare nil?, 0/false
 428     {
 429       break-if-=
 430       trace-higher trace
 431       return
 432     }
 433     #
 434     trace-text trace, "eval", "evaluating second arg"
 435     var rest/eax: (addr cell) <- lookup *rest-ah
 436     rest-ah <- get rest, right
 437     rest <- lookup *rest-ah
 438     var second-ah/eax: (addr handle cell) <- get rest, left
 439     debug-print "T2", 4/fg, 0/bg
 440     evaluate second-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 441     debug-print "U2", 4/fg, 0/bg
 442     trace-higher trace
 443     return
 444   }
 445   $evaluate:or: {
 446     var expr/esi: (addr cell) <- copy in
 447     # if its first elem is not "or", break
 448     var first-ah/ecx: (addr handle cell) <- get in, left
 449     var rest-ah/edx: (addr handle cell) <- get in, right
 450     var first/eax: (addr cell) <- lookup *first-ah
 451     var or?/eax: boolean <- symbol-equal? first, "or"
 452     compare or?, 0/false
 453     break-if-=
 454     #
 455     trace-text trace, "eval", "or"
 456     trace-text trace, "eval", "evaluating first arg"
 457     var rest/eax: (addr cell) <- lookup *rest-ah
 458     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 459     debug-print "R2", 4/fg, 0/bg
 460     evaluate first-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 461     debug-print "S2", 4/fg, 0/bg
 462     # errors? skip
 463     {
 464       var error?/eax: boolean <- has-errors? trace
 465       compare error?, 0/false
 466       break-if-=
 467       trace-higher trace
 468       return
 469     }
 470     # if first arg is not nil, short-circuit
 471     var out-ah/eax: (addr handle cell) <- copy _out-ah
 472     var out/eax: (addr cell) <- lookup *out-ah
 473     var nil?/eax: boolean <- nil? out
 474     compare nil?, 0/false
 475     {
 476       break-if-!=
 477       trace-higher trace
 478       return
 479     }
 480     #
 481     trace-text trace, "eval", "evaluating second arg"
 482     var rest/eax: (addr cell) <- lookup *rest-ah
 483     rest-ah <- get rest, right
 484     rest <- lookup *rest-ah
 485     var second-ah/eax: (addr handle cell) <- get rest, left
 486     debug-print "T2", 4/fg, 0/bg
 487     evaluate second-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 488     debug-print "U2", 4/fg, 0/bg
 489     # errors? skip
 490     {
 491       var error?/eax: boolean <- has-errors? trace
 492       compare error?, 0/false
 493       break-if-=
 494       trace-higher trace
 495       return
 496     }
 497     trace-higher trace
 498     return
 499   }
 500   $evaluate:if: {
 501     # trees starting with "if" are conditionals
 502     var expr/esi: (addr cell) <- copy in
 503     # if its first elem is not "if", break
 504     var first-ah/ecx: (addr handle cell) <- get in, left
 505     var rest-ah/edx: (addr handle cell) <- get in, right
 506     var first/eax: (addr cell) <- lookup *first-ah
 507     var if?/eax: boolean <- symbol-equal? first, "if"
 508     compare if?, 0/false
 509     break-if-=
 510     #
 511     trace-text trace, "eval", "if"
 512     trace-text trace, "eval", "evaluating first arg"
 513     var rest/eax: (addr cell) <- lookup *rest-ah
 514     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 515     var guard-h: (handle cell)
 516     var guard-ah/esi: (addr handle cell) <- address guard-h
 517     debug-print "R", 4/fg, 0/bg
 518     evaluate first-arg-ah, guard-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 519     debug-print "S", 4/fg, 0/bg
 520     # errors? skip
 521     {
 522       var error?/eax: boolean <- has-errors? trace
 523       compare error?, 0/false
 524       break-if-=
 525       trace-higher trace
 526       return
 527     }
 528     rest-ah <- get rest, right
 529     rest <- lookup *rest-ah
 530     var branch-ah/edi: (addr handle cell) <- get rest, left
 531     var guard-a/eax: (addr cell) <- lookup *guard-ah
 532     var skip-to-third-arg?/eax: boolean <- nil? guard-a
 533     compare skip-to-third-arg?, 0/false
 534     {
 535       break-if-=
 536       trace-text trace, "eval", "skipping to third arg"
 537       var rest/eax: (addr cell) <- lookup *rest-ah
 538       rest-ah <- get rest, right
 539       rest <- lookup *rest-ah
 540       branch-ah <- get rest, left
 541     }
 542     debug-print "T", 4/fg, 0/bg
 543     evaluate branch-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 544     debug-print "U", 4/fg, 0/bg
 545     trace-higher trace
 546     return
 547   }
 548   $evaluate:while: {
 549     # trees starting with "while" are loops
 550     var expr/esi: (addr cell) <- copy in
 551     # if its first elem is not "while", break
 552     var first-ah/ecx: (addr handle cell) <- get in, left
 553     var rest-ah/edx: (addr handle cell) <- get in, right
 554     var first/eax: (addr cell) <- lookup *first-ah
 555     var first-type/ecx: (addr int) <- get first, type
 556     compare *first-type, 2/symbol
 557     break-if-!=
 558     var sym-data-ah/eax: (addr handle stream byte) <- get first, text-data
 559     var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
 560     var while?/eax: boolean <- stream-data-equal? sym-data, "while"
 561     compare while?, 0/false
 562     break-if-=
 563     #
 564     trace-text trace, "eval", "while"
 565     var rest/eax: (addr cell) <- lookup *rest-ah
 566     var first-arg-ah/ecx: (addr handle cell) <- get rest, left
 567     rest-ah <- get rest, right
 568     var guard-h: (handle cell)
 569     var guard-ah/esi: (addr handle cell) <- address guard-h
 570     $evaluate:while:loop-execution: {
 571       {
 572         var error?/eax: boolean <- has-errors? trace
 573         compare error?, 0/false
 574         break-if-!= $evaluate:while:loop-execution
 575       }
 576       trace-text trace, "eval", "loop termination check"
 577       debug-print "V", 4/fg, 0/bg
 578       evaluate first-arg-ah, guard-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 579       debug-print "W", 4/fg, 0/bg
 580       # errors? skip
 581       {
 582         var error?/eax: boolean <- has-errors? trace
 583         compare error?, 0/false
 584         break-if-=
 585         trace-higher trace
 586         return
 587       }
 588       var guard-a/eax: (addr cell) <- lookup *guard-ah
 589       var done?/eax: boolean <- nil? guard-a
 590       compare done?, 0/false
 591       break-if-!=
 592       evaluate-exprs rest-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 593       # errors? skip
 594       {
 595         var error?/eax: boolean <- has-errors? trace
 596         compare error?, 0/false
 597         break-if-=
 598         trace-higher trace
 599         return
 600       }
 601       loop
 602     }
 603     trace-text trace, "eval", "loop terminated"
 604     trace-higher trace
 605     return
 606   }
 607   # trace "evaluate function call elements in " in {{{
 608   {
 609     var should-trace?/eax: boolean <- should-trace? trace
 610     compare should-trace?, 0/false
 611     break-if-=
 612     var stream-storage: (stream byte 0x300)
 613     var stream/ecx: (addr stream byte) <- address stream-storage
 614     write stream, "evaluate function call elements in "
 615     var nested-trace-storage: trace
 616     var nested-trace/edi: (addr trace) <- address nested-trace-storage
 617     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
 618     print-cell in-ah, stream, nested-trace
 619     trace trace, "eval", stream
 620   }
 621   # }}}
 622   trace-lower trace
 623   var evaluated-list-storage: (handle cell)
 624   var evaluated-list-ah/esi: (addr handle cell) <- address evaluated-list-storage
 625   var curr-out-ah/edx: (addr handle cell) <- copy evaluated-list-ah
 626   var curr/ecx: (addr cell) <- copy in
 627   $evaluate-list:loop: {
 628     allocate-pair curr-out-ah
 629     var nil?/eax: boolean <- nil? curr
 630     compare nil?, 0/false
 631     break-if-!=
 632     # eval left
 633     var curr-out/eax: (addr cell) <- lookup *curr-out-ah
 634     var left-out-ah/edi: (addr handle cell) <- get curr-out, left
 635     var left-ah/esi: (addr handle cell) <- get curr, left
 636     debug-print "A", 4/fg, 0/bg
 637     evaluate left-ah, left-out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 638     debug-print "B", 4/fg, 0/bg
 639     # errors? skip
 640     {
 641       var error?/eax: boolean <- has-errors? trace
 642       compare error?, 0/false
 643       break-if-=
 644       trace-higher trace
 645       trace-higher trace
 646       return
 647     }
 648     #
 649     curr-out-ah <- get curr-out, right
 650     var right-ah/eax: (addr handle cell) <- get curr, right
 651     var right/eax: (addr cell) <- lookup *right-ah
 652     curr <- copy right
 653     loop
 654   }
 655   trace-higher trace
 656   var evaluated-list/eax: (addr cell) <- lookup *evaluated-list-ah
 657   var function-ah/ecx: (addr handle cell) <- get evaluated-list, left
 658   var args-ah/edx: (addr handle cell) <- get evaluated-list, right
 659   debug-print "C", 4/fg, 0/bg
 660   apply function-ah, args-ah, _out-ah, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 661   debug-print "Y", 4/fg, 0/bg
 662   trace-higher trace
 663   # trace "=> " _out-ah {{{
 664   {
 665     var should-trace?/eax: boolean <- should-trace? trace
 666     compare should-trace?, 0/false
 667     break-if-=
 668     var stream-storage: (stream byte 0x200)
 669     var stream/ecx: (addr stream byte) <- address stream-storage
 670     write stream, "=> "
 671     var nested-trace-storage: trace
 672     var nested-trace/edi: (addr trace) <- address nested-trace-storage
 673     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
 674     print-cell _out-ah, stream, nested-trace
 675     trace trace, "eval", stream
 676   }
 677   # }}}
 678   debug-print "Z", 4/fg, 0/bg
 679 }
 680
 681 fn apply _f-ah: (addr handle cell), args-ah: (addr handle cell), out: (addr handle cell), globals: (addr global-table), trace: (addr trace), inner-screen-var: (addr handle cell), inner-keyboard-var: (addr handle cell), definitions-created: (addr stream int), call-number: (addr int) {
 682   var f-ah/eax: (addr handle cell) <- copy _f-ah
 683   var _f/eax: (addr cell) <- lookup *f-ah
 684   var f/esi: (addr cell) <- copy _f
 685   # call primitive functions
 686   {
 687     var f-type/eax: (addr int) <- get f, type
 688     compare *f-type, 4/primitive-function
 689     break-if-!=
 690     apply-primitive f, args-ah, out, globals, trace
 691     return
 692   }
 693   # if it's not a primitive function it must be an anonymous function
 694   # trace "apply anonymous function " f " in environment " env {{{
 695   {
 696     var should-trace?/eax: boolean <- should-trace? trace
 697     compare should-trace?, 0/false
 698     break-if-=
 699     var stream-storage: (stream byte 0x200)
 700     var stream/ecx: (addr stream byte) <- address stream-storage
 701     write stream, "apply anonymous function "
 702     var nested-trace-storage: trace
 703     var nested-trace/edi: (addr trace) <- address nested-trace-storage
 704     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
 705     print-cell _f-ah, stream, nested-trace
 706 #?     write stream, " in environment "
 707 #?     var callee-env-ah/eax: (addr handle cell) <- address callee-env-h
 708 #?     clear-trace nested-trace
 709 #?     print-cell callee-env-ah, stream, nested-trace
 710     trace trace, "eval", stream
 711   }
 712   # }}}
 713   trace-lower trace
 714   {
 715     var f-type/ecx: (addr int) <- get f, type
 716     compare *f-type, 0/pair
 717     break-if-!=
 718     var first-ah/eax: (addr handle cell) <- get f, left
 719     var first/eax: (addr cell) <- lookup *first-ah
 720     var litfn?/eax: boolean <- litfn? first
 721     compare litfn?, 0/false
 722     break-if-=
 723     var rest-ah/esi: (addr handle cell) <- get f, right
 724     var rest/eax: (addr cell) <- lookup *rest-ah
 725     var callee-env-ah/edx: (addr handle cell) <- get rest, left
 726     rest-ah <- get rest, right
 727     rest <- lookup *rest-ah
 728     var params-ah/ecx: (addr handle cell) <- get rest, left
 729     var body-ah/eax: (addr handle cell) <- get rest, right
 730     debug-print "D", 7/fg, 0/bg
 731     apply-function params-ah, args-ah, body-ah, out, *callee-env-ah, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 732     debug-print "Y", 7/fg, 0/bg
 733     trace-higher trace
 734     return
 735   }
 736   error trace, "unknown function"
 737 }
 738
 739 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), inner-screen-var: (addr handle cell), inner-keyboard-var: (addr handle cell), definitions-created: (addr stream int), call-number: (addr int) {
 740   # push bindings for params to env
 741   var new-env-h: (handle cell)
 742   var new-env-ah/esi: (addr handle cell) <- address new-env-h
 743   push-bindings params-ah, args-ah, env-h, new-env-ah, trace
 744   # errors? skip
 745   {
 746     var error?/eax: boolean <- has-errors? trace
 747     compare error?, 0/false
 748     break-if-=
 749     return
 750   }
 751   #
 752   evaluate-exprs body-ah, out, new-env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 753 }
 754
 755 fn evaluate-exprs _exprs-ah: (addr handle cell), out: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), inner-screen-var: (addr handle cell), inner-keyboard-var: (addr handle cell), definitions-created: (addr stream int), call-number: (addr int) {
 756   # eval all exprs, writing result to `out` each time
 757   var exprs-ah/ecx: (addr handle cell) <- copy _exprs-ah
 758   $evaluate-exprs:loop: {
 759     var exprs/eax: (addr cell) <- lookup *exprs-ah
 760     # stop when exprs is nil
 761     {
 762       var exprs-nil?/eax: boolean <- nil? exprs
 763       compare exprs-nil?, 0/false
 764       break-if-!= $evaluate-exprs:loop
 765     }
 766     # evaluate each expression, writing result to `out`
 767     {
 768       var curr-ah/eax: (addr handle cell) <- get exprs, left
 769       debug-print "E", 7/fg, 0/bg
 770       evaluate curr-ah, out, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
 771       debug-print "X", 7/fg, 0/bg
 772       # errors? skip
 773       {
 774         var error?/eax: boolean <- has-errors? trace
 775         compare error?, 0/false
 776         break-if-=
 777         return
 778       }
 779     }
 780     #
 781     exprs-ah <- get exprs, right
 782     loop
 783   }
 784   # `out` contains result of evaluating final expression
 785 }
 786
 787 # Bind params to corresponding args and add the bindings to old-env. Return
 788 # the result in env-ah.
 789 #
 790 # We never modify old-env, but we point to it. This way other parts of the
 791 # interpreter can continue using old-env, and everything works harmoniously
 792 # even though no cells are copied around.
 793 #
 794 # env should always be a DAG (ignoring internals of values). It doesn't have
 795 # to be a tree (some values may be shared), but there are also no cycles.
 796 #
 797 # Learn more: https://en.wikipedia.org/wiki/Persistent_data_structure
 798 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) {
 799   var params-ah/edx: (addr handle cell) <- copy _params-ah
 800   var args-ah/ebx: (addr handle cell) <- copy _args-ah
 801   var _params/eax: (addr cell) <- lookup *params-ah
 802   var params/esi: (addr cell) <- copy _params
 803   {
 804     var params-nil?/eax: boolean <- nil? params
 805     compare params-nil?, 0/false
 806     break-if-=
 807     # nil is a literal
 808     trace-text trace, "eval", "done with push-bindings"
 809     copy-handle old-env-h, env-ah
 810     return
 811   }
 812   # Params can only be symbols or pairs. Args can be anything.
 813   # trace "pushing bindings from " params " to " args {{{
 814   {
 815     var should-trace?/eax: boolean <- should-trace? trace
 816     compare should-trace?, 0/false
 817     break-if-=
 818     var stream-storage: (stream byte 0x200)
 819     var stream/ecx: (addr stream byte) <- address stream-storage
 820     var overflow?/eax: boolean <- try-write stream, "pushing bindings from "
 821     compare overflow?, 0/false
 822     break-if-!=
 823     var nested-trace-storage: trace
 824     var nested-trace/edi: (addr trace) <- address nested-trace-storage
 825     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
 826     print-cell params-ah, stream, nested-trace
 827     var overflow?/eax: boolean <- try-write stream, " to "
 828     compare overflow?, 0/false
 829     break-if-!=
 830     clear-trace nested-trace
 831     print-cell args-ah, stream, nested-trace
 832     var overflow?/eax: boolean <- try-write stream, " onto "
 833     compare overflow?, 0/false
 834     break-if-!=
 835     var old-env-ah/eax: (addr handle cell) <- address old-env-h
 836     clear-trace nested-trace
 837     print-cell old-env-ah, stream, nested-trace
 838     trace trace, "eval", stream
 839   }
 840   # }}}
 841   trace-lower trace
 842   var params-type/eax: (addr int) <- get params, type
 843   compare *params-type, 2/symbol
 844   {
 845     break-if-!=
 846     trace-text trace, "eval", "symbol; binding to all remaining args"
 847     # create a new binding
 848     var new-binding-storage: (handle cell)
 849     var new-binding-ah/eax: (addr handle cell) <- address new-binding-storage
 850     new-pair new-binding-ah, *params-ah, *args-ah
 851     # push it to env
 852     new-pair env-ah, *new-binding-ah, old-env-h
 853     trace-higher trace
 854     return
 855   }
 856   compare *params-type, 0/pair
 857   {
 858     break-if-=
 859     error trace, "cannot bind a non-symbol"
 860     trace-higher trace
 861     return
 862   }
 863   var _args/eax: (addr cell) <- lookup *args-ah
 864   var args/edi: (addr cell) <- copy _args
 865   # params is now a pair, so args must be also
 866   {
 867     var args-nil?/eax: boolean <- nil? args
 868     compare args-nil?, 0/false
 869     break-if-=
 870     error trace, "not enough args to bind"
 871     return
 872   }
 873   var args-type/eax: (addr int) <- get args, type
 874   compare *args-type, 0/pair
 875   {
 876     break-if-=
 877     error trace, "args not in a proper list"
 878     trace-higher trace
 879     return
 880   }
 881   var intermediate-env-storage: (handle cell)
 882   var intermediate-env-ah/edx: (addr handle cell) <- address intermediate-env-storage
 883   var first-param-ah/eax: (addr handle cell) <- get params, left
 884   var first-arg-ah/ecx: (addr handle cell) <- get args, left
 885   push-bindings first-param-ah, first-arg-ah, old-env-h, intermediate-env-ah, trace
 886   # errors? skip
 887   {
 888     var error?/eax: boolean <- has-errors? trace
 889     compare error?, 0/false
 890     break-if-=
 891     trace-higher trace
 892     return
 893   }
 894   var remaining-params-ah/eax: (addr handle cell) <- get params, right
 895   var remaining-args-ah/ecx: (addr handle cell) <- get args, right
 896   push-bindings remaining-params-ah, remaining-args-ah, *intermediate-env-ah, env-ah, trace
 897   trace-higher trace
 898 }
 899
 900 fn lookup-symbol sym: (addr cell), out: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), inner-screen-var: (addr handle cell), inner-keyboard-var: (addr handle cell) {
 901   # trace sym
 902   {
 903     var should-trace?/eax: boolean <- should-trace? trace
 904     compare should-trace?, 0/false
 905     break-if-=
 906     var stream-storage: (stream byte 0x800)  # pessimistically sized just for the large alist loaded from disk in `main`
 907     var stream/ecx: (addr stream byte) <- address stream-storage
 908     var overflow?/eax: boolean <- try-write stream, "look up "
 909     compare overflow?, 0/false
 910     break-if-!=
 911     var sym2/eax: (addr cell) <- copy sym
 912     var sym-data-ah/eax: (addr handle stream byte) <- get sym2, text-data
 913     var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
 914     rewind-stream sym-data
 915     write-stream stream, sym-data
 916     var overflow?/eax: boolean <- try-write stream, " in "
 917     compare overflow?, 0/false
 918     break-if-!=
 919     var env-ah/eax: (addr handle cell) <- address env-h
 920     var nested-trace-storage: trace
 921     var nested-trace/edi: (addr trace) <- address nested-trace-storage
 922     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
 923     print-cell env-ah, stream, nested-trace
 924     trace trace, "eval", stream
 925   }
 926   trace-lower trace
 927   var _env/eax: (addr cell) <- lookup env-h
 928   var env/ebx: (addr cell) <- copy _env
 929   # if env is not a list, error
 930   {
 931     var env-type/ecx: (addr int) <- get env, type
 932     compare *env-type, 0/pair
 933     break-if-=
 934     error trace, "eval found a non-list environment"
 935     trace-higher trace
 936     return
 937   }
 938   # if env is nil, look up in globals
 939   {
 940     var env-nil?/eax: boolean <- nil? env
 941     compare env-nil?, 0/false
 942     break-if-=
 943     debug-print "b", 7/fg, 0/bg
 944     lookup-symbol-in-globals sym, out, globals, trace, inner-screen-var, inner-keyboard-var
 945     debug-print "x", 7/fg, 0/bg
 946     trace-higher trace
 947     # trace "=> " out " (global)" {{{
 948     {
 949       var should-trace?/eax: boolean <- should-trace? trace
 950       compare should-trace?, 0/false
 951       break-if-=
 952       var error?/eax: boolean <- has-errors? trace
 953       compare error?, 0/false
 954       break-if-!=
 955       var stream-storage: (stream byte 0x200)
 956       var stream/ecx: (addr stream byte) <- address stream-storage
 957       var overflow?/eax: boolean <- try-write stream, "=> "
 958       compare overflow?, 0/false
 959       break-if-!=
 960       var nested-trace-storage: trace
 961       var nested-trace/edi: (addr trace) <- address nested-trace-storage
 962       initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
 963       print-cell out, stream, nested-trace
 964       var overflow?/eax: boolean <- try-write stream, " (global)"
 965       compare overflow?, 0/false
 966       break-if-!=
 967       trace trace, "eval", stream
 968     }
 969     # }}}
 970     debug-print "y", 7/fg, 0/bg
 971     return
 972   }
 973   # check car
 974   var env-head-storage: (handle cell)
 975   var env-head-ah/eax: (addr handle cell) <- address env-head-storage
 976   car env, env-head-ah, trace
 977   var _env-head/eax: (addr cell) <- lookup *env-head-ah
 978   var env-head/ecx: (addr cell) <- copy _env-head
 979   # if car is not a list, abort
 980   {
 981     var env-head-type/eax: (addr int) <- get env-head, type
 982     compare *env-head-type, 0/pair
 983     break-if-=
 984     error trace, "environment is not a list of (key . value) pairs"
 985     trace-higher trace
 986     return
 987   }
 988   # check key
 989   var curr-key-storage: (handle cell)
 990   var curr-key-ah/eax: (addr handle cell) <- address curr-key-storage
 991   car env-head, curr-key-ah, trace
 992   var curr-key/eax: (addr cell) <- lookup *curr-key-ah
 993   # if key is not a symbol, abort
 994   {
 995     var curr-key-type/eax: (addr int) <- get curr-key, type
 996     compare *curr-key-type, 2/symbol
 997     break-if-=
 998     error trace, "environment contains a binding for a non-symbol"
 999     trace-higher trace
1000     return
1001   }
1002   # if key matches sym, return val
1003   var match?/eax: boolean <- cell-isomorphic? curr-key, sym, trace
1004   compare match?, 0/false
1005   {
1006     break-if-=
1007     cdr env-head, out, trace
1008     # trace "=> " out " (match)" {{{
1009     {
1010       var should-trace?/eax: boolean <- should-trace? trace
1011       compare should-trace?, 0/false
1012       break-if-=
1013       var error?/eax: boolean <- has-errors? trace
1014       compare error?, 0/false
1015       break-if-!=
1016       var stream-storage: (stream byte 0x800)
1017       var stream/ecx: (addr stream byte) <- address stream-storage
1018       var overflow?/eax: boolean <- try-write stream, "=> "
1019       compare overflow?, 0/false
1020       break-if-!=
1021       var nested-trace-storage: trace
1022       var nested-trace/edi: (addr trace) <- address nested-trace-storage
1023       initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
1024       print-cell out, stream, nested-trace
1025       var overflow?/eax: boolean <- try-write stream, " (match)"
1026       compare overflow?, 0/false
1027       break-if-!=
1028       trace trace, "eval", stream
1029     }
1030     # }}}
1031     trace-higher trace
1032     return
1033   }
1034   # otherwise recurse
1035   var env-tail-storage: (handle cell)
1036   var env-tail-ah/eax: (addr handle cell) <- address env-tail-storage
1037   cdr env, env-tail-ah, trace
1038   lookup-symbol sym, out, *env-tail-ah, globals, trace, inner-screen-var, inner-keyboard-var
1039   trace-higher trace
1040   # trace "=> " out " (recurse)" {{{
1041   {
1042     var should-trace?/eax: boolean <- should-trace? trace
1043     compare should-trace?, 0/false
1044     break-if-=
1045     var error?/eax: boolean <- has-errors? trace
1046     compare error?, 0/false
1047     break-if-!=
1048     var stream-storage: (stream byte 0x200)
1049     var stream/ecx: (addr stream byte) <- address stream-storage
1050     var overflow?/eax: boolean <- try-write stream, "=> "
1051     compare overflow?, 0/false
1052     break-if-!=
1053     var nested-trace-storage: trace
1054     var nested-trace/edi: (addr trace) <- address nested-trace-storage
1055     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
1056     print-cell out, stream, nested-trace
1057     var overflow?/eax: boolean <- try-write stream, " (recurse)"
1058     compare overflow?, 0/false
1059     break-if-!=
1060     trace trace, "eval", stream
1061   }
1062   # }}}
1063 }
1064
1065 fn test-lookup-symbol-in-env {
1066   # tmp = (a . 3)
1067   var val-storage: (handle cell)
1068   var val-ah/ecx: (addr handle cell) <- address val-storage
1069   new-integer val-ah, 3
1070   var key-storage: (handle cell)
1071   var key-ah/edx: (addr handle cell) <- address key-storage
1072   new-symbol key-ah, "a"
1073   var env-storage: (handle cell)
1074   var env-ah/ebx: (addr handle cell) <- address env-storage
1075   new-pair env-ah, *key-ah, *val-ah
1076   # env = ((a . 3))
1077   var nil-storage: (handle cell)
1078   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1079   allocate-pair nil-ah
1080   new-pair env-ah, *env-ah, *nil-ah
1081   # lookup sym(a) in env tmp
1082   var tmp-storage: (handle cell)
1083   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
1084   new-symbol tmp-ah, "a"
1085   var in/eax: (addr cell) <- lookup *tmp-ah
1086   var trace-storage: trace
1087   var trace/edi: (addr trace) <- address trace-storage
1088   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1089   lookup-symbol in, tmp-ah, *env-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard
1090   var result/eax: (addr cell) <- lookup *tmp-ah
1091   var result-type/edx: (addr int) <- get result, type
1092   check-ints-equal *result-type, 1/number, "F - test-lookup-symbol-in-env/0"
1093   var result-value-addr/eax: (addr float) <- get result, number-data
1094   var result-value/eax: int <- convert *result-value-addr
1095   check-ints-equal result-value, 3, "F - test-lookup-symbol-in-env/1"
1096 }
1097
1098 fn test-lookup-symbol-in-globals {
1099   var globals-storage: global-table
1100   var globals/edi: (addr global-table) <- address globals-storage
1101   initialize-globals globals
1102   # env = nil
1103   var nil-storage: (handle cell)
1104   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1105   allocate-pair nil-ah
1106   # lookup sym(a), env
1107   var tmp-storage: (handle cell)
1108   var tmp-ah/ebx: (addr handle cell) <- address tmp-storage
1109   new-symbol tmp-ah, "+"
1110   var in/eax: (addr cell) <- lookup *tmp-ah
1111   var trace-storage: trace
1112   var trace/esi: (addr trace) <- address trace-storage
1113   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1114   lookup-symbol in, tmp-ah, *nil-ah, globals, trace, 0/no-screen, 0/no-keyboard
1115   var result/eax: (addr cell) <- lookup *tmp-ah
1116   var result-type/edx: (addr int) <- get result, type
1117   check-ints-equal *result-type, 4/primitive-function, "F - test-lookup-symbol-in-globals/0"
1118   var result-value/eax: (addr int) <- get result, index-data
1119   check-ints-equal *result-value, 1/add, "F - test-lookup-symbol-in-globals/1"
1120 }
1121
1122 fn mutate-binding name: (addr stream byte), val: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace) {
1123   # trace name
1124   {
1125     var should-trace?/eax: boolean <- should-trace? trace
1126     compare should-trace?, 0/false
1127     break-if-=
1128     var stream-storage: (stream byte 0x800)  # pessimistically sized just for the large alist loaded from disk in `main`
1129     var stream/ecx: (addr stream byte) <- address stream-storage
1130     write stream, "bind "
1131     rewind-stream name
1132     write-stream stream, name
1133     write stream, " to "
1134     var nested-trace-storage: trace
1135     var nested-trace/edi: (addr trace) <- address nested-trace-storage
1136     initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
1137     print-cell val, stream, nested-trace
1138     write stream, " in "
1139     var env-ah/eax: (addr handle cell) <- address env-h
1140     clear-trace nested-trace
1141     print-cell env-ah, stream, nested-trace
1142     trace trace, "eval", stream
1143   }
1144   trace-lower trace
1145   var _env/eax: (addr cell) <- lookup env-h
1146   var env/ebx: (addr cell) <- copy _env
1147   # if env is not a list, abort
1148   {
1149     var env-type/ecx: (addr int) <- get env, type
1150     compare *env-type, 0/pair
1151     break-if-=
1152     error trace, "eval found a non-list environment"
1153     trace-higher trace
1154     return
1155   }
1156   # if env is nil, look in globals
1157   {
1158     var env-nil?/eax: boolean <- nil? env
1159     compare env-nil?, 0/false
1160     break-if-=
1161     debug-print "b", 3/fg, 0/bg
1162     mutate-binding-in-globals name, val, globals, trace
1163     debug-print "x", 3/fg, 0/bg
1164     trace-higher trace
1165     # trace "=> " val " (global)" {{{
1166     {
1167       var should-trace?/eax: boolean <- should-trace? trace
1168       compare should-trace?, 0/false
1169       break-if-=
1170       var error?/eax: boolean <- has-errors? trace
1171       compare error?, 0/false
1172       break-if-!=
1173       var stream-storage: (stream byte 0x200)
1174       var stream/ecx: (addr stream byte) <- address stream-storage
1175       write stream, "=> "
1176       var nested-trace-storage: trace
1177       var nested-trace/edi: (addr trace) <- address nested-trace-storage
1178       initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
1179       print-cell val, stream, nested-trace
1180       write stream, " (global)"
1181       trace trace, "eval", stream
1182     }
1183     # }}}
1184     debug-print "y", 3/fg, 0/bg
1185     return
1186   }
1187   # check car
1188   var env-head-storage: (handle cell)
1189   var env-head-ah/eax: (addr handle cell) <- address env-head-storage
1190   car env, env-head-ah, trace
1191   var _env-head/eax: (addr cell) <- lookup *env-head-ah
1192   var env-head/ecx: (addr cell) <- copy _env-head
1193   # if car is not a list, abort
1194   {
1195     var env-head-type/eax: (addr int) <- get env-head, type
1196     compare *env-head-type, 0/pair
1197     break-if-=
1198     error trace, "environment is not a list of (key . value) pairs"
1199     trace-higher trace
1200     return
1201   }
1202   # check key
1203   var curr-key-storage: (handle cell)
1204   var curr-key-ah/eax: (addr handle cell) <- address curr-key-storage
1205   car env-head, curr-key-ah, trace
1206   var curr-key/eax: (addr cell) <- lookup *curr-key-ah
1207   # if key is not a symbol, abort
1208   {
1209     var curr-key-type/eax: (addr int) <- get curr-key, type
1210     compare *curr-key-type, 2/symbol
1211     break-if-=
1212     error trace, "environment contains a binding for a non-symbol"
1213     trace-higher trace
1214     return
1215   }
1216   # if key matches name, return val
1217   var curr-key-data-ah/eax: (addr handle stream byte) <- get curr-key, text-data
1218   var curr-key-data/eax: (addr stream byte) <- lookup *curr-key-data-ah
1219   var match?/eax: boolean <- streams-data-equal? curr-key-data, name
1220   compare match?, 0/false
1221   {
1222     break-if-=
1223     var dest/eax: (addr handle cell) <- get env-head, right
1224     copy-object val, dest
1225     trace-text trace, "eval", "=> done"
1226     trace-higher trace
1227     return
1228   }
1229   # otherwise recurse
1230   var env-tail-storage: (handle cell)
1231   var env-tail-ah/eax: (addr handle cell) <- address env-tail-storage
1232   cdr env, env-tail-ah, trace
1233   mutate-binding name, val, *env-tail-ah, globals, trace
1234   trace-higher trace
1235 }
1236
1237 fn car _in: (addr cell), out: (addr handle cell), trace: (addr trace) {
1238   trace-text trace, "eval", "car"
1239   trace-lower trace
1240   var in/eax: (addr cell) <- copy _in
1241   # if in is not a list, abort
1242   {
1243     var in-type/ecx: (addr int) <- get in, type
1244     compare *in-type, 0/pair
1245     break-if-=
1246     error trace, "car on a non-list"
1247     trace-higher trace
1248     return
1249   }
1250   # if in is nil, abort
1251   {
1252     var in-nil?/eax: boolean <- nil? in
1253     compare in-nil?, 0/false
1254     break-if-=
1255     error trace, "car on nil"
1256     trace-higher trace
1257     return
1258   }
1259   var in-left/eax: (addr handle cell) <- get in, left
1260   copy-object in-left, out
1261   trace-higher trace
1262   return
1263 }
1264
1265 fn cdr _in: (addr cell), out: (addr handle cell), trace: (addr trace) {
1266   trace-text trace, "eval", "cdr"
1267   trace-lower trace
1268   var in/eax: (addr cell) <- copy _in
1269   # if in is not a list, abort
1270   {
1271     var in-type/ecx: (addr int) <- get in, type
1272     compare *in-type, 0/pair
1273     break-if-=
1274     error trace, "car on a non-list"
1275     trace-higher trace
1276     return
1277   }
1278   # if in is nil, abort
1279   {
1280     var in-nil?/eax: boolean <- nil? in
1281     compare in-nil?, 0/false
1282     break-if-=
1283     error trace, "car on nil"
1284     trace-higher trace
1285     return
1286   }
1287   var in-right/eax: (addr handle cell) <- get in, right
1288   copy-object in-right, out
1289   trace-higher trace
1290   return
1291 }
1292
1293 fn cell-isomorphic? _a: (addr cell), _b: (addr cell), trace: (addr trace) -> _/eax: boolean {
1294   trace-text trace, "eval", "cell-isomorphic?"
1295   trace-lower trace
1296   var a/esi: (addr cell) <- copy _a
1297   var b/edi: (addr cell) <- copy _b
1298   # if types don't match, return false
1299   var a-type-addr/eax: (addr int) <- get a, type
1300   var b-type-addr/ecx: (addr int) <- get b, type
1301   var b-type/ecx: int <- copy *b-type-addr
1302   compare b-type, *a-type-addr
1303   {
1304     break-if-=
1305     trace-higher trace
1306     trace-text trace, "eval", "=> false (type)"
1307     return 0/false
1308   }
1309   # if types are number, compare number-data
1310   # TODO: exactly comparing floats is a bad idea
1311   compare b-type, 1/number
1312   {
1313     break-if-!=
1314     var a-val-addr/eax: (addr float) <- get a, number-data
1315     var b-val-addr/ecx: (addr float) <- get b, number-data
1316     var a-val/xmm0: float <- copy *a-val-addr
1317     compare a-val, *b-val-addr
1318     {
1319       break-if-=
1320       trace-higher trace
1321       trace-text trace, "eval", "=> false (numbers)"
1322       return 0/false
1323     }
1324     trace-higher trace
1325     trace-text trace, "eval", "=> true (numbers)"
1326     return 1/true
1327   }
1328   {
1329     compare b-type, 2/symbol
1330     break-if-!=
1331     var b-val-ah/eax: (addr handle stream byte) <- get b, text-data
1332     var _b-val/eax: (addr stream byte) <- lookup *b-val-ah
1333     var b-val/ecx: (addr stream byte) <- copy _b-val
1334     var a-val-ah/eax: (addr handle stream byte) <- get a, text-data
1335     var a-val/eax: (addr stream byte) <- lookup *a-val-ah
1336     var tmp-array: (handle array byte)
1337     var tmp-ah/edx: (addr handle array byte) <- address tmp-array
1338     rewind-stream a-val
1339     stream-to-array a-val, tmp-ah
1340     var tmp/eax: (addr array byte) <- lookup *tmp-ah
1341     var match?/eax: boolean <- stream-data-equal? b-val, tmp
1342     trace-higher trace
1343     {
1344       compare match?, 0/false
1345       break-if-=
1346       trace-text trace, "eval", "=> true (symbols)"
1347     }
1348     {
1349       compare match?, 0/false
1350       break-if-!=
1351       trace-text trace, "eval", "=> false (symbols)"
1352     }
1353     return match?
1354   }
1355   {
1356     compare b-type, 3/stream
1357     break-if-!=
1358     var a-val-ah/eax: (addr handle stream byte) <- get a, text-data
1359     var a-val/eax: (addr stream byte) <- lookup *a-val-ah
1360     var a-data-h: (handle array byte)
1361     var a-data-ah/edx: (addr handle array byte) <- address a-data-h
1362     stream-to-array a-val, a-data-ah
1363     var _a-data/eax: (addr array byte) <- lookup *a-data-ah
1364     var a-data/edx: (addr array byte) <- copy _a-data
1365     var b-val-ah/eax: (addr handle stream byte) <- get b, text-data
1366     var b-val/eax: (addr stream byte) <- lookup *b-val-ah
1367     var b-data-h: (handle array byte)
1368     var b-data-ah/ecx: (addr handle array byte) <- address b-data-h
1369     stream-to-array b-val, b-data-ah
1370     var b-data/eax: (addr array byte) <- lookup *b-data-ah
1371     var match?/eax: boolean <- string-equal? a-data, b-data
1372     trace-higher trace
1373     {
1374       compare match?, 0/false
1375       break-if-=
1376       trace-text trace, "eval", "=> true (streams)"
1377     }
1378     {
1379       compare match?, 0/false
1380       break-if-!=
1381       trace-text trace, "eval", "=> false (streams)"
1382     }
1383     return match?
1384   }
1385   # if objects are primitive functions, compare index-data
1386   compare b-type, 4/primitive
1387   {
1388     break-if-!=
1389     var a-val-addr/eax: (addr int) <- get a, index-data
1390     var b-val-addr/ecx: (addr int) <- get b, index-data
1391     var a-val/eax: int <- copy *a-val-addr
1392     compare a-val, *b-val-addr
1393     {
1394       break-if-=
1395       trace-higher trace
1396       trace-text trace, "eval", "=> false (primitives)"
1397       return 0/false
1398     }
1399     trace-higher trace
1400     trace-text trace, "eval", "=> true (primitives)"
1401     return 1/true
1402   }
1403   # if objects are screens, check if they're the same object
1404   compare b-type, 5/screen
1405   {
1406     break-if-!=
1407     var a-val-ah/eax: (addr handle screen) <- get a, screen-data
1408     var b-val-ah/ecx: (addr handle screen) <- get b, screen-data
1409     var result/eax: boolean <- handle-equal? *a-val-ah, *b-val-ah
1410     compare result, 0/false
1411     return result
1412   }
1413   # if objects are keyboards, check if they have the same contents
1414   compare b-type, 6/keyboard
1415   {
1416     break-if-!=
1417     var a-val-ah/ecx: (addr handle gap-buffer) <- get a, keyboard-data
1418     var _a-val/eax: (addr gap-buffer) <- lookup *a-val-ah
1419     var a-val/ecx: (addr gap-buffer) <- copy _a-val
1420     var b-val-ah/eax: (addr handle gap-buffer) <- get b, keyboard-data
1421     var b-val/eax: (addr gap-buffer) <- lookup *b-val-ah
1422     var result/eax: boolean <- gap-buffers-equal? a-val, b-val
1423     return result
1424   }
1425   # if objects are arrays, check if they have the same contents
1426   compare b-type, 7/array
1427   {
1428     break-if-!=
1429     var a-val-ah/ecx: (addr handle array handle cell) <- get a, array-data
1430     var _a-val/eax: (addr array handle cell) <- lookup *a-val-ah
1431     var a-val/ecx: (addr array handle cell) <- copy _a-val
1432     var b-val-ah/eax: (addr handle array handle cell) <- get b, array-data
1433     var _b-val/eax: (addr array handle cell) <- lookup *b-val-ah
1434     var b-val/edx: (addr array handle cell) <- copy _b-val
1435     var a-len/eax: int <- length a-val
1436     var b-len/ebx: int <- length b-val
1437     {
1438       compare a-len, b-len
1439       break-if-=
1440       return 0/false
1441     }
1442     var i/esi: int <- copy 0
1443     {
1444       compare i, b-len
1445       break-if->=
1446       var a-elem-ah/eax: (addr handle cell) <- index a-val, i
1447       var _a-elem/eax: (addr cell) <- lookup *a-elem-ah
1448       var a-elem/edi: (addr cell) <- copy _a-elem
1449       var b-elem-ah/eax: (addr handle cell) <- index b-val, i
1450       var b-elem/eax: (addr cell) <- lookup *b-elem-ah
1451       var curr-result/eax: boolean <- cell-isomorphic? a-elem, b-elem, trace
1452       {
1453         compare curr-result, 0/false
1454         break-if-!=
1455         return 0/false
1456       }
1457       i <- increment
1458       loop
1459     }
1460     return 1/true
1461   }
1462   # if a is nil, b should be nil
1463   {
1464     # (assumes nil? returns 0 or 1)
1465     var _b-nil?/eax: boolean <- nil? b
1466     var b-nil?/ecx: boolean <- copy _b-nil?
1467     var a-nil?/eax: boolean <- nil? a
1468     # a == nil and b == nil => return true
1469     {
1470       compare a-nil?, 0/false
1471       break-if-=
1472       compare b-nil?, 0/false
1473       break-if-=
1474       trace-higher trace
1475       trace-text trace, "eval", "=> true (nils)"
1476       return 1/true
1477     }
1478     # a == nil => return false
1479     {
1480       compare a-nil?, 0/false
1481       break-if-=
1482       trace-higher trace
1483       trace-text trace, "eval", "=> false (b != nil)"
1484       return 0/false
1485     }
1486     # b == nil => return false
1487     {
1488       compare b-nil?, 0/false
1489       break-if-=
1490       trace-higher trace
1491       trace-text trace, "eval", "=> false (a != nil)"
1492       return 0/false
1493     }
1494   }
1495   # a and b are pairs
1496   var a-tmp-storage: (handle cell)
1497   var a-tmp-ah/edx: (addr handle cell) <- address a-tmp-storage
1498   var b-tmp-storage: (handle cell)
1499   var b-tmp-ah/ebx: (addr handle cell) <- address b-tmp-storage
1500   # if cars aren't equal, return false
1501   car a, a-tmp-ah, trace
1502   car b, b-tmp-ah, trace
1503   {
1504     var _a-tmp/eax: (addr cell) <- lookup *a-tmp-ah
1505     var a-tmp/ecx: (addr cell) <- copy _a-tmp
1506     var b-tmp/eax: (addr cell) <- lookup *b-tmp-ah
1507     var result/eax: boolean <- cell-isomorphic? a-tmp, b-tmp, trace
1508     compare result, 0/false
1509     break-if-!=
1510     trace-higher trace
1511     trace-text trace, "eval", "=> false (car mismatch)"
1512     return 0/false
1513   }
1514   # recurse on cdrs
1515   cdr a, a-tmp-ah, trace
1516   cdr b, b-tmp-ah, trace
1517   var _a-tmp/eax: (addr cell) <- lookup *a-tmp-ah
1518   var a-tmp/ecx: (addr cell) <- copy _a-tmp
1519   var b-tmp/eax: (addr cell) <- lookup *b-tmp-ah
1520   var result/eax: boolean <- cell-isomorphic? a-tmp, b-tmp, trace
1521   trace-higher trace
1522   return result
1523 }
1524
1525 fn fn? _x: (addr cell) -> _/eax: boolean {
1526   var x/esi: (addr cell) <- copy _x
1527   var type/eax: (addr int) <- get x, type
1528   compare *type, 2/symbol
1529   {
1530     break-if-=
1531     return 0/false
1532   }
1533   var contents-ah/eax: (addr handle stream byte) <- get x, text-data
1534   var contents/eax: (addr stream byte) <- lookup *contents-ah
1535   var result/eax: boolean <- stream-data-equal? contents, "fn"
1536   return result
1537 }
1538
1539 fn litfn? _x: (addr cell) -> _/eax: boolean {
1540   var x/esi: (addr cell) <- copy _x
1541   var type/eax: (addr int) <- get x, type
1542   compare *type, 2/symbol
1543   {
1544     break-if-=
1545     return 0/false
1546   }
1547   var contents-ah/eax: (addr handle stream byte) <- get x, text-data
1548   var contents/eax: (addr stream byte) <- lookup *contents-ah
1549   var result/eax: boolean <- stream-data-equal? contents, "litfn"
1550   return result
1551 }
1552
1553 fn litmac? _x: (addr cell) -> _/eax: boolean {
1554   var x/esi: (addr cell) <- copy _x
1555   var type/eax: (addr int) <- get x, type
1556   compare *type, 2/symbol
1557   {
1558     break-if-=
1559     return 0/false
1560   }
1561   var contents-ah/eax: (addr handle stream byte) <- get x, text-data
1562   var contents/eax: (addr stream byte) <- lookup *contents-ah
1563   var result/eax: boolean <- stream-data-equal? contents, "litmac"
1564   return result
1565 }
1566
1567 fn litimg? _x: (addr cell) -> _/eax: boolean {
1568   var x/esi: (addr cell) <- copy _x
1569   var type/eax: (addr int) <- get x, type
1570   compare *type, 2/symbol
1571   {
1572     break-if-=
1573     return 0/false
1574   }
1575   var contents-ah/eax: (addr handle stream byte) <- get x, text-data
1576   var contents/eax: (addr stream byte) <- lookup *contents-ah
1577   var result/eax: boolean <- stream-data-equal? contents, "litimg"
1578   return result
1579 }
1580
1581 fn test-evaluate-is-well-behaved {
1582   var t-storage: trace
1583   var t/esi: (addr trace) <- address t-storage
1584   initialize-trace t, 0x100/max-depth, 0x10/capacity, 0/visible  # we don't use trace UI
1585   # env = nil
1586   var env-storage: (handle cell)
1587   var env-ah/ecx: (addr handle cell) <- address env-storage
1588   allocate-pair env-ah
1589   # eval sym(a), nil env
1590   var tmp-storage: (handle cell)
1591   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
1592   new-symbol tmp-ah, "a"
1593   evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, t, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1594   # doesn't die
1595   check-trace-contains t, "error", "unbound symbol: a", "F - test-evaluate-is-well-behaved"
1596 }
1597
1598 fn test-evaluate-number {
1599   # env = nil
1600   var env-storage: (handle cell)
1601   var env-ah/ecx: (addr handle cell) <- address env-storage
1602   allocate-pair env-ah
1603   # tmp = 3
1604   var tmp-storage: (handle cell)
1605   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
1606   new-integer tmp-ah, 3
1607   var trace-storage: trace
1608   var trace/edi: (addr trace) <- address trace-storage
1609   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1610   evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1611   #
1612   var result/eax: (addr cell) <- lookup *tmp-ah
1613   var result-type/edx: (addr int) <- get result, type
1614   check-ints-equal *result-type, 1/number, "F - test-evaluate-number/0"
1615   var result-value-addr/eax: (addr float) <- get result, number-data
1616   var result-value/eax: int <- convert *result-value-addr
1617   check-ints-equal result-value, 3, "F - test-evaluate-number/1"
1618 }
1619
1620 fn test-evaluate-symbol {
1621   # tmp = (a . 3)
1622   var val-storage: (handle cell)
1623   var val-ah/ecx: (addr handle cell) <- address val-storage
1624   new-integer val-ah, 3
1625   var key-storage: (handle cell)
1626   var key-ah/edx: (addr handle cell) <- address key-storage
1627   new-symbol key-ah, "a"
1628   var env-storage: (handle cell)
1629   var env-ah/ebx: (addr handle cell) <- address env-storage
1630   new-pair env-ah, *key-ah, *val-ah
1631   # env = ((a . 3))
1632   var nil-storage: (handle cell)
1633   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1634   allocate-pair nil-ah
1635   new-pair env-ah, *env-ah, *nil-ah
1636   # eval sym(a), env
1637   var tmp-storage: (handle cell)
1638   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
1639   new-symbol tmp-ah, "a"
1640   var trace-storage: trace
1641   var trace/edi: (addr trace) <- address trace-storage
1642   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1643   evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1644   var result/eax: (addr cell) <- lookup *tmp-ah
1645   var result-type/edx: (addr int) <- get result, type
1646   check-ints-equal *result-type, 1/number, "F - test-evaluate-symbol/0"
1647   var result-value-addr/eax: (addr float) <- get result, number-data
1648   var result-value/eax: int <- convert *result-value-addr
1649   check-ints-equal result-value, 3, "F - test-evaluate-symbol/1"
1650 }
1651
1652 fn test-evaluate-quote {
1653   # env = nil
1654   var nil-storage: (handle cell)
1655   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1656   allocate-pair nil-ah
1657   # eval `a, env
1658   var tmp-storage: (handle cell)
1659   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
1660   new-symbol tmp-ah, "'"
1661   var tmp2-storage: (handle cell)
1662   var tmp2-ah/ebx: (addr handle cell) <- address tmp2-storage
1663   new-symbol tmp2-ah, "a"
1664   new-pair tmp-ah, *tmp-ah, *tmp2-ah
1665   var trace-storage: trace
1666   var trace/edi: (addr trace) <- address trace-storage
1667   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1668   evaluate tmp-ah, tmp-ah, *nil-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1669   var result/eax: (addr cell) <- lookup *tmp-ah
1670   var result-type/edx: (addr int) <- get result, type
1671   check-ints-equal *result-type, 2/symbol, "F - test-evaluate-quote/0"
1672   var sym?/eax: boolean <- symbol-equal? result, "a"
1673   check sym?, "F - test-evaluate-quote/1"
1674 }
1675
1676 fn test-evaluate-primitive-function {
1677   var globals-storage: global-table
1678   var globals/edi: (addr global-table) <- address globals-storage
1679   initialize-globals globals
1680   var nil-storage: (handle cell)
1681   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1682   allocate-pair nil-ah
1683   var add-storage: (handle cell)
1684   var add-ah/ebx: (addr handle cell) <- address add-storage
1685   new-symbol add-ah, "+"
1686   # eval +, nil env
1687   var tmp-storage: (handle cell)
1688   var tmp-ah/esi: (addr handle cell) <- address tmp-storage
1689   var trace-storage: trace
1690   var trace/edx: (addr trace) <- address trace-storage
1691   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1692   evaluate add-ah, tmp-ah, *nil-ah, globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1693   #
1694   var result/eax: (addr cell) <- lookup *tmp-ah
1695   var result-type/edx: (addr int) <- get result, type
1696   check-ints-equal *result-type, 4/primitive-function, "F - test-evaluate-primitive-function/0"
1697   var result-value/eax: (addr int) <- get result, index-data
1698   check-ints-equal *result-value, 1/add, "F - test-evaluate-primitive-function/1"
1699 }
1700
1701 fn test-evaluate-primitive-function-call {
1702   var t-storage: trace
1703   var t/edi: (addr trace) <- address t-storage
1704   initialize-trace t, 0x100/max-depth, 0x100/capacity, 0/visible  # we don't use trace UI
1705   #
1706   var nil-storage: (handle cell)
1707   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1708   allocate-pair nil-ah
1709   var one-storage: (handle cell)
1710   var one-ah/edx: (addr handle cell) <- address one-storage
1711   new-integer one-ah, 1
1712   var add-storage: (handle cell)
1713   var add-ah/ebx: (addr handle cell) <- address add-storage
1714   new-symbol add-ah, "+"
1715   # input is (+ 1 1)
1716   var tmp-storage: (handle cell)
1717   var tmp-ah/esi: (addr handle cell) <- address tmp-storage
1718   new-pair tmp-ah, *one-ah, *nil-ah
1719   new-pair tmp-ah, *one-ah, *tmp-ah
1720   new-pair tmp-ah, *add-ah, *tmp-ah
1721 #?   dump-cell tmp-ah
1722   #
1723   var globals-storage: global-table
1724   var globals/edx: (addr global-table) <- address globals-storage
1725   initialize-globals globals
1726   #
1727   evaluate tmp-ah, tmp-ah, *nil-ah, globals, t, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1728 #?   dump-trace t
1729   #
1730   var result/eax: (addr cell) <- lookup *tmp-ah
1731   var result-type/edx: (addr int) <- get result, type
1732   check-ints-equal *result-type, 1/number, "F - test-evaluate-primitive-function-call/0"
1733   var result-value-addr/eax: (addr float) <- get result, number-data
1734   var result-value/eax: int <- convert *result-value-addr
1735   check-ints-equal result-value, 2, "F - test-evaluate-primitive-function-call/1"
1736 }
1737
1738 fn test-evaluate-backquote {
1739   # env = nil
1740   var nil-storage: (handle cell)
1741   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1742   allocate-pair nil-ah
1743   # eval `a, env
1744   var tmp-storage: (handle cell)
1745   var tmp-ah/edx: (addr handle cell) <- address tmp-storage
1746   new-symbol tmp-ah, "`"
1747   var tmp2-storage: (handle cell)
1748   var tmp2-ah/ebx: (addr handle cell) <- address tmp2-storage
1749   new-symbol tmp2-ah, "a"
1750   new-pair tmp-ah, *tmp-ah, *tmp2-ah
1751   clear-object tmp2-ah
1752   var trace-storage: trace
1753   var trace/edi: (addr trace) <- address trace-storage
1754   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1755   evaluate tmp-ah, tmp2-ah, *nil-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1756   var result/eax: (addr cell) <- lookup *tmp2-ah
1757   var result-type/edx: (addr int) <- get result, type
1758   check-ints-equal *result-type, 2/symbol, "F - test-evaluate-backquote/0"
1759   var sym?/eax: boolean <- symbol-equal? result, "a"
1760   check sym?, "F - test-evaluate-backquote/1"
1761 }
1762
1763 fn evaluate-backquote _in-ah: (addr handle cell), _out-ah: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace), inner-screen-var: (addr handle cell), inner-keyboard-var: (addr handle cell), definitions-created: (addr stream int), call-number: (addr int) {
1764   # stack overflow?   # disable when enabling Really-debug-print
1765 #?   dump-cell-from-cursor-over-full-screen _in-ah
1766   check-stack
1767   {
1768     var inner-screen-var/eax: (addr handle cell) <- copy inner-screen-var
1769     compare inner-screen-var, 0
1770     break-if-=
1771     var inner-screen-var-addr/eax: (addr cell) <- lookup *inner-screen-var
1772     compare inner-screen-var-addr, 0
1773     break-if-=
1774     # if inner-screen-var exists, we're probably not in a test
1775     show-stack-state
1776   }
1777   # errors? skip
1778   {
1779     var error?/eax: boolean <- has-errors? trace
1780     compare error?, 0/false
1781     break-if-=
1782     return
1783   }
1784   trace-lower trace
1785   var in-ah/esi: (addr handle cell) <- copy _in-ah
1786   var in/eax: (addr cell) <- lookup *in-ah
1787   {
1788     var nil?/eax: boolean <- nil? in
1789     compare nil?, 0/false
1790     break-if-=
1791     # nil is a literal
1792     trace-text trace, "eval", "backquote nil"
1793     copy-object _in-ah, _out-ah
1794     trace-higher trace
1795     return
1796   }
1797   var in-type/ecx: (addr int) <- get in, type
1798   compare *in-type, 0/pair
1799   {
1800     break-if-=
1801     # copy non-pairs directly
1802     # TODO: streams might need to be copied
1803     trace-text trace, "eval", "backquote atom"
1804     copy-object _in-ah, _out-ah
1805     trace-higher trace
1806     return
1807   }
1808   # 'in' is a pair
1809   debug-print "()", 4/fg, 0/bg
1810   var in-ah/esi: (addr handle cell) <- copy _in-ah
1811   var _in/eax: (addr cell) <- lookup *in-ah
1812   var in/ebx: (addr cell) <- copy _in
1813   var in-left-ah/ecx: (addr handle cell) <- get in, left
1814   debug-print "10", 4/fg, 0/bg
1815   # check for unquote
1816   $evaluate-backquote:unquote: {
1817     var in-left/eax: (addr cell) <- lookup *in-left-ah
1818     var unquote?/eax: boolean <- symbol-equal? in-left, ","
1819     compare unquote?, 0/false
1820     break-if-=
1821     trace-text trace, "eval", "unquote"
1822     var rest-ah/eax: (addr handle cell) <- get in, right
1823     debug-print ",", 3/fg, 0/bg
1824     evaluate rest-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
1825     debug-print ",)", 3/fg, 0/bg
1826     trace-higher trace
1827     return
1828   }
1829   # check for unquote-splice in in-left
1830   debug-print "11", 4/fg, 0/bg
1831   var out-ah/edi: (addr handle cell) <- copy _out-ah
1832   $evaluate-backquote:unquote-splice: {
1833 #?     dump-cell-from-cursor-over-full-screen in-left-ah
1834     var in-left/eax: (addr cell) <- lookup *in-left-ah
1835     {
1836       debug-print "12", 4/fg, 0/bg
1837       {
1838         var in-left-is-nil?/eax: boolean <- nil? in-left
1839         compare in-left-is-nil?, 0/false
1840       }
1841       break-if-!= $evaluate-backquote:unquote-splice
1842       var in-left-type/ecx: (addr int) <- get in-left, type
1843       debug-print "13", 4/fg, 0/bg
1844       compare *in-left-type, 0/pair
1845       break-if-!= $evaluate-backquote:unquote-splice
1846       var in-left-left-ah/eax: (addr handle cell) <- get in-left, left
1847       debug-print "14", 4/fg, 0/bg
1848       var in-left-left/eax: (addr cell) <- lookup *in-left-left-ah
1849       debug-print "15", 4/fg, 0/bg
1850       var in-left-left-type/ecx: (addr int) <- get in-left-left, type
1851       var left-is-unquote-splice?/eax: boolean <- symbol-equal? in-left-left, ",@"
1852       debug-print "16", 4/fg, 0/bg
1853       compare left-is-unquote-splice?, 0/false
1854     }
1855     break-if-=
1856     debug-print "17", 4/fg, 0/bg
1857     trace-text trace, "eval", "unquote-splice"
1858     var in-unquote-payload-ah/eax: (addr handle cell) <- get in-left, right
1859     evaluate in-unquote-payload-ah, out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
1860     # errors? skip
1861     {
1862       var error?/eax: boolean <- has-errors? trace
1863       compare error?, 0/false
1864       break-if-=
1865       trace-higher trace
1866       return
1867     }
1868     # while (*out-ah != null) out-ah = cdr(out-ah)
1869     {
1870       var out/eax: (addr cell) <- lookup *out-ah
1871       {
1872         var done?/eax: boolean <- nil? out
1873         compare done?, 0/false
1874       }
1875       break-if-!=
1876       out-ah <- get out, right
1877       loop
1878     }
1879     # append result of in-right
1880     var in-right-ah/ecx: (addr handle cell) <- get in, right
1881     evaluate-backquote in-right-ah, out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
1882     trace-higher trace
1883     return
1884   }
1885   debug-print "19", 4/fg, 0/bg
1886   # otherwise continue copying
1887   trace-text trace, "eval", "backquote: copy"
1888   var out-ah/edi: (addr handle cell) <- copy _out-ah
1889   allocate-pair out-ah
1890   debug-print "20", 7/fg, 0/bg
1891 #?   dump-cell-from-cursor-over-full-screen out-ah
1892   var out/eax: (addr cell) <- lookup *out-ah
1893   var out-left-ah/edx: (addr handle cell) <- get out, left
1894   debug-print "`(l", 3/fg, 0/bg
1895   evaluate-backquote in-left-ah, out-left-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
1896   debug-print "`r)", 3/fg, 0/bg
1897   # errors? skip
1898   {
1899     var error?/eax: boolean <- has-errors? trace
1900     compare error?, 0/false
1901     break-if-=
1902     trace-higher trace
1903     return
1904   }
1905   var in-right-ah/ecx: (addr handle cell) <- get in, right
1906   var out-right-ah/edx: (addr handle cell) <- get out, right
1907   debug-print "`r(", 3/fg, 0/bg
1908   evaluate-backquote in-right-ah, out-right-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
1909   debug-print "`r)", 3/fg, 0/bg
1910   trace-higher trace
1911 }
1912
1913 fn test-evaluate-backquote-list {
1914   var nil-storage: (handle cell)
1915   var nil-ah/ecx: (addr handle cell) <- address nil-storage
1916   allocate-pair nil-ah
1917   var backquote-storage: (handle cell)
1918   var backquote-ah/edx: (addr handle cell) <- address backquote-storage
1919   new-symbol backquote-ah, "`"
1920   # input is `(a b)
1921   var a-storage: (handle cell)
1922   var a-ah/ebx: (addr handle cell) <- address a-storage
1923   new-symbol a-ah, "a"
1924   var b-storage: (handle cell)
1925   var b-ah/esi: (addr handle cell) <- address b-storage
1926   new-symbol b-ah, "b"
1927   var tmp-storage: (handle cell)
1928   var tmp-ah/eax: (addr handle cell) <- address tmp-storage
1929   new-pair tmp-ah, *b-ah, *nil-ah
1930   new-pair tmp-ah, *a-ah, *tmp-ah
1931   new-pair tmp-ah, *backquote-ah, *tmp-ah
1932   #
1933   var trace-storage: trace
1934   var trace/edi: (addr trace) <- address trace-storage
1935   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
1936   evaluate tmp-ah, tmp-ah, *nil-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
1937   # result is (a b)
1938   var result/eax: (addr cell) <- lookup *tmp-ah
1939   {
1940     var result-type/eax: (addr int) <- get result, type
1941     check-ints-equal *result-type, 0/pair, "F - test-evaluate-backquote-list/0"
1942   }
1943   {
1944     var a1-ah/eax: (addr handle cell) <- get result, left
1945     var a1/eax: (addr cell) <- lookup *a1-ah
1946     var check1/eax: boolean <- symbol-equal? a1, "a"
1947     check check1, "F - test-evaluate-backquote-list/1"
1948   }
1949   var rest-ah/eax: (addr handle cell) <- get result, right
1950   var rest/eax: (addr cell) <- lookup *rest-ah
1951   {
1952     var a2-ah/eax: (addr handle cell) <- get rest, left
1953     var a2/eax: (addr cell) <- lookup *a2-ah
1954     var check2/eax: boolean <- symbol-equal? a2, "b"
1955     check check2, "F - test-evaluate-backquote-list/2"
1956   }
1957   var rest-ah/eax: (addr handle cell) <- get rest, right
1958   var rest/eax: (addr cell) <- lookup *rest-ah
1959   var check3/eax: boolean <- nil? rest
1960   check check3, "F - test-evaluate-backquote-list/3"
1961 }
1962
1963 fn test-evaluate-backquote-list-with-unquote {
1964   var nil-h: (handle cell)
1965   var nil-ah/eax: (addr handle cell) <- address nil-h
1966   allocate-pair nil-ah
1967   var backquote-h: (handle cell)
1968   var backquote-ah/eax: (addr handle cell) <- address backquote-h
1969   new-symbol backquote-ah, "`"
1970   var unquote-h: (handle cell)
1971   var unquote-ah/eax: (addr handle cell) <- address unquote-h
1972   new-symbol unquote-ah, ","
1973   var a-h: (handle cell)
1974   var a-ah/eax: (addr handle cell) <- address a-h
1975   new-symbol a-ah, "a"
1976   var b-h: (handle cell)
1977   var b-ah/eax: (addr handle cell) <- address b-h
1978   new-symbol b-ah, "b"
1979   # env = ((b . 3))
1980   var val-h: (handle cell)
1981   var val-ah/eax: (addr handle cell) <- address val-h
1982   new-integer val-ah, 3
1983   var env-h: (handle cell)
1984   var env-ah/eax: (addr handle cell) <- address env-h
1985   new-pair env-ah, b-h, val-h
1986   new-pair env-ah, env-h, nil-h
1987   # input is `(a ,b)
1988   var tmp-h: (handle cell)
1989   var tmp-ah/eax: (addr handle cell) <- address tmp-h
1990   # tmp = cons(unquote, b)
1991   new-pair tmp-ah, unquote-h, b-h
1992   # tmp = cons(tmp, nil)
1993   new-pair tmp-ah, tmp-h, nil-h
1994   # tmp = cons(a, tmp)
1995   new-pair tmp-ah, a-h, tmp-h
1996   # tmp = cons(backquote, tmp)
1997   new-pair tmp-ah, backquote-h, tmp-h
1998   #
1999   var trace-storage: trace
2000   var trace/edi: (addr trace) <- address trace-storage
2001   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
2002   evaluate tmp-ah, tmp-ah, env-h, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
2003   # result is (a 3)
2004   var result/eax: (addr cell) <- lookup *tmp-ah
2005   {
2006     var result-type/eax: (addr int) <- get result, type
2007     check-ints-equal *result-type, 0/pair, "F - test-evaluate-backquote-list-with-unquote/0"
2008   }
2009   {
2010     var a1-ah/eax: (addr handle cell) <- get result, left
2011     var a1/eax: (addr cell) <- lookup *a1-ah
2012     var check1/eax: boolean <- symbol-equal? a1, "a"
2013     check check1, "F - test-evaluate-backquote-list-with-unquote/1"
2014   }
2015   var rest-ah/eax: (addr handle cell) <- get result, right
2016   var rest/eax: (addr cell) <- lookup *rest-ah
2017   {
2018     var a2-ah/eax: (addr handle cell) <- get rest, left
2019     var a2/eax: (addr cell) <- lookup *a2-ah
2020     var a2-value-addr/eax: (addr float) <- get a2, number-data
2021     var a2-value/eax: int <- convert *a2-value-addr
2022     check-ints-equal a2-value, 3, "F - test-evaluate-backquote-list-with-unquote/2"
2023   }
2024   var rest-ah/eax: (addr handle cell) <- get rest, right
2025   var rest/eax: (addr cell) <- lookup *rest-ah
2026   var check3/eax: boolean <- nil? rest
2027   check check3, "F - test-evaluate-backquote-list-with-unquote/3"
2028 }
2029
2030 fn test-evaluate-backquote-list-with-unquote-splice {
2031   var nil-h: (handle cell)
2032   var nil-ah/eax: (addr handle cell) <- address nil-h
2033   allocate-pair nil-ah
2034   var backquote-h: (handle cell)
2035   var backquote-ah/eax: (addr handle cell) <- address backquote-h
2036   new-symbol backquote-ah, "`"
2037   var unquote-splice-h: (handle cell)
2038   var unquote-splice-ah/eax: (addr handle cell) <- address unquote-splice-h
2039   new-symbol unquote-splice-ah, ",@"
2040   var a-h: (handle cell)
2041   var a-ah/eax: (addr handle cell) <- address a-h
2042   new-symbol a-ah, "a"
2043   var b-h: (handle cell)
2044   var b-ah/eax: (addr handle cell) <- address b-h
2045   new-symbol b-ah, "b"
2046   # env = ((b . (a 3)))
2047   var val-h: (handle cell)
2048   var val-ah/eax: (addr handle cell) <- address val-h
2049   new-integer val-ah, 3
2050   new-pair val-ah, val-h, nil-h
2051   new-pair val-ah, a-h, val-h
2052   var env-h: (handle cell)
2053   var env-ah/eax: (addr handle cell) <- address env-h
2054   new-pair env-ah, b-h, val-h
2055   new-pair env-ah, env-h, nil-h
2056   # input is `(a ,@b b)
2057   var tmp-h: (handle cell)
2058   var tmp-ah/eax: (addr handle cell) <- address tmp-h
2059   # tmp = cons(b, nil)
2060   new-pair tmp-ah, b-h, nil-h
2061   # tmp2 = cons(unquote-splice, b)
2062   var tmp2-h: (handle cell)
2063   var tmp2-ah/ecx: (addr handle cell) <- address tmp2-h
2064   new-pair tmp2-ah, unquote-splice-h, b-h
2065   # tmp = cons(tmp2, tmp)
2066   new-pair tmp-ah, tmp2-h, tmp-h
2067   # tmp = cons(a, tmp)
2068   new-pair tmp-ah, a-h, tmp-h
2069   # tmp = cons(backquote, tmp)
2070   new-pair tmp-ah, backquote-h, tmp-h
2071 #?   dump-cell-from-cursor-over-full-screen tmp-ah
2072   #
2073   var trace-storage: trace
2074   var trace/edi: (addr trace) <- address trace-storage
2075   initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
2076   evaluate tmp-ah, tmp-ah, env-h, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
2077   # result is (a a 3 b)
2078 #?   dump-cell-from-cursor-over-full-screen tmp-ah
2079   var result/eax: (addr cell) <- lookup *tmp-ah
2080   {
2081     var result-type/eax: (addr int) <- get result, type
2082     check-ints-equal *result-type, 0/pair, "F - test-evaluate-backquote-list-with-unquote-splice/0"
2083   }
2084   {
2085     var a1-ah/eax: (addr handle cell) <- get result, left
2086     var a1/eax: (addr cell) <- lookup *a1-ah
2087     var check1/eax: boolean <- symbol-equal? a1, "a"
2088     check check1, "F - test-evaluate-backquote-list-with-unquote-splice/1"
2089   }
2090   var rest-ah/eax: (addr handle cell) <- get result, right
2091   var rest/eax: (addr cell) <- lookup *rest-ah
2092   {
2093     var a2-ah/eax: (addr handle cell) <- get rest, left
2094     var a2/eax: (addr cell) <- lookup *a2-ah
2095     var check2/eax: boolean <- symbol-equal? a2, "a"
2096     check check2, "F - test-evaluate-backquote-list-with-unquote-splice/2"
2097   }
2098   var rest-ah/eax: (addr handle cell) <- get rest, right
2099   var rest/eax: (addr cell) <- lookup *rest-ah
2100   {
2101     var a3-ah/eax: (addr handle cell) <- get rest, left
2102     var a3/eax: (addr cell) <- lookup *a3-ah
2103     var a3-value-addr/eax: (addr float) <- get a3, number-data
2104     var a3-value/eax: int <- convert *a3-value-addr
2105     check-ints-equal a3-value, 3, "F - test-evaluate-backquote-list-with-unquote-splice/3"
2106   }
2107   var rest-ah/eax: (addr handle cell) <- get rest, right
2108   var rest/eax: (addr cell) <- lookup *rest-ah
2109   {
2110     var a4-ah/eax: (addr handle cell) <- get rest, left
2111     var a4/eax: (addr cell) <- lookup *a4-ah
2112     var check4/eax: boolean <- symbol-equal? a4, "b"
2113     check check4, "F - test-evaluate-backquote-list-with-unquote-splice/4"
2114   }
2115   var rest-ah/eax: (addr handle cell) <- get rest, right
2116   var rest/eax: (addr cell) <- lookup *rest-ah
2117   var check5/eax: boolean <- nil? rest
2118   check check5, "F - test-evaluate-backquote-list-with-unquote-splice/5"
2119 }