2021 lines
72 KiB
Forth
2021 lines
72 KiB
Forth
# env is an alist of ((sym . val) (sym . val) ...)
|
|
# we never modify `_in-ah` or `env`
|
|
# ignore args past 'trace' on a first reading; they're for the environment not the language
|
|
# 'call-number' is just for showing intermediate progress; this is a _slow_ interpreter
|
|
# side-effects if not in a test (inner-screen-var != 0):
|
|
# prints intermediate states of the inner screen to outer screen
|
|
# (which may not be the real screen if we're using double-buffering)
|
|
# stops if a keypress is encountered
|
|
# Inner screen is what Lisp programs modify. Outer screen is shows the program
|
|
# and its inner screen to the environment.
|
|
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) {
|
|
# stack overflow? # disable when enabling Really-debug-print
|
|
check-stack
|
|
{
|
|
var running-tests?/eax: boolean <- running-tests?
|
|
compare running-tests?, 0/false
|
|
break-if-!=
|
|
show-stack-state
|
|
}
|
|
# show intermediate progress on screen if necessary
|
|
# treat input at the real keyboard as interrupting
|
|
{
|
|
compare inner-screen-var, 0
|
|
break-if-=
|
|
var call-number/eax: (addr int) <- copy call-number
|
|
compare call-number, 0
|
|
break-if-=
|
|
increment *call-number
|
|
var tmp/eax: int <- copy *call-number
|
|
tmp <- and 0xf/responsiveness=16 # every 16 calls to evaluate
|
|
compare tmp, 0
|
|
break-if-!=
|
|
var inner-screen-var/eax: (addr handle cell) <- copy inner-screen-var
|
|
var inner-screen-var-addr/eax: (addr cell) <- lookup *inner-screen-var
|
|
compare inner-screen-var-addr, 0
|
|
break-if-=
|
|
var screen-obj-ah/eax: (addr handle screen) <- get inner-screen-var-addr, screen-data
|
|
var screen-obj/eax: (addr screen) <- lookup *screen-obj-ah
|
|
compare screen-obj, 0
|
|
break-if-=
|
|
render-screen 0/screen, screen-obj, 0x58/xmin, 2/ymin
|
|
var key/eax: byte <- read-key 0/keyboard
|
|
compare key, 0
|
|
break-if-=
|
|
error trace, "key pressed; interrupting..."
|
|
}
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
return
|
|
}
|
|
var in-ah/esi: (addr handle cell) <- copy _in-ah
|
|
#? dump-cell in-ah
|
|
#? {
|
|
#? var foo/eax: byte <- read-key 0/keyboard
|
|
#? compare foo, 0
|
|
#? loop-if-=
|
|
#? }
|
|
# trace "evaluate " in " in environment " env {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x300)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "evaluate "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell in-ah, stream, nested-trace
|
|
write stream, " in environment "
|
|
var env-ah/eax: (addr handle cell) <- address env-h
|
|
clear-trace nested-trace
|
|
print-cell env-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
trace-lower trace
|
|
var in/eax: (addr cell) <- lookup *in-ah
|
|
{
|
|
var nil?/eax: boolean <- nil? in
|
|
compare nil?, 0/false
|
|
break-if-=
|
|
# nil is a literal
|
|
trace-text trace, "eval", "nil"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var in-type/ecx: (addr int) <- get in, type
|
|
compare *in-type, 1/number
|
|
{
|
|
break-if-!=
|
|
# numbers are literals
|
|
trace-text trace, "eval", "number"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
compare *in-type, 3/stream
|
|
{
|
|
break-if-!=
|
|
# streams are literals
|
|
trace-text trace, "eval", "stream"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
compare *in-type, 2/symbol
|
|
{
|
|
break-if-!=
|
|
trace-text trace, "eval", "symbol"
|
|
debug-print "a", 7/fg, 0/bg
|
|
lookup-symbol in, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var
|
|
debug-print "z", 7/fg, 0/bg
|
|
trace-higher trace
|
|
return
|
|
}
|
|
compare *in-type, 5/screen
|
|
{
|
|
break-if-!=
|
|
trace-text trace, "eval", "screen"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
compare *in-type, 6/keyboard
|
|
{
|
|
break-if-!=
|
|
trace-text trace, "eval", "keyboard"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# 'in' is a syntax tree
|
|
$evaluate:literal-function: {
|
|
# trees starting with "litfn" are literals
|
|
var expr/esi: (addr cell) <- copy in
|
|
var in/edx: (addr cell) <- copy in
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var litfn?/eax: boolean <- litfn? first
|
|
compare litfn?, 0/false
|
|
break-if-=
|
|
trace-text trace, "eval", "literal function"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:literal-macro: {
|
|
# trees starting with "litmac" are literals
|
|
var expr/esi: (addr cell) <- copy in
|
|
var in/edx: (addr cell) <- copy in
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var litmac?/eax: boolean <- litmac? first
|
|
compare litmac?, 0/false
|
|
break-if-=
|
|
trace-text trace, "eval", "literal macro"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:anonymous-function: {
|
|
# trees starting with "fn" are anonymous functions
|
|
var expr/esi: (addr cell) <- copy in
|
|
var in/edx: (addr cell) <- copy in
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var fn?/eax: boolean <- fn? first
|
|
compare fn?, 0/false
|
|
break-if-=
|
|
# turn (fn ...) into (litfn env ...)
|
|
trace-text trace, "eval", "anonymous function"
|
|
var rest-ah/eax: (addr handle cell) <- get in, right
|
|
var tmp: (handle cell)
|
|
var tmp-ah/edi: (addr handle cell) <- address tmp
|
|
new-pair tmp-ah, env-h, *rest-ah
|
|
var litfn: (handle cell)
|
|
var litfn-ah/eax: (addr handle cell) <- address litfn
|
|
new-symbol litfn-ah, "litfn"
|
|
new-pair _out-ah, *litfn-ah, *tmp-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# builtins with "special" evaluation rules
|
|
$evaluate:quote: {
|
|
# trees starting with single quote create literals
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "'", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var quote?/eax: boolean <- symbol-equal? first, "'"
|
|
compare quote?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "quote"
|
|
copy-object rest-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:backquote: {
|
|
# trees starting with single backquote create literals
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "'", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var backquote?/eax: boolean <- symbol-equal? first, "`"
|
|
compare backquote?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "backquote"
|
|
debug-print "`(", 7/fg, 0/bg
|
|
evaluate-backquote rest-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print ")", 7/fg, 0/bg
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:apply: {
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "apply", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var apply?/eax: boolean <- symbol-equal? first, "apply"
|
|
compare apply?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "apply"
|
|
trace-text trace, "eval", "evaluating first arg"
|
|
var first-arg-value-h: (handle cell)
|
|
var first-arg-value-ah/esi: (addr handle cell) <- address first-arg-value-h
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
debug-print "A2", 4/fg, 0/bg
|
|
evaluate first-arg-ah, first-arg-value-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "Y2", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
#
|
|
trace-text trace, "eval", "evaluating second arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var second-ah/eax: (addr handle cell) <- get rest, left
|
|
var second-arg-value-h: (handle cell)
|
|
var second-arg-value-ah/edi: (addr handle cell) <- address second-arg-value-h
|
|
debug-print "T2", 4/fg, 0/bg
|
|
evaluate second-ah, second-arg-value-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "U2", 4/fg, 0/bg
|
|
# apply
|
|
apply first-arg-value-ah, second-arg-value-ah, _out-ah, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
#
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:define: {
|
|
# trees starting with "define" define globals
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "define", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var define?/eax: boolean <- symbol-equal? first, "define"
|
|
compare define?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "define"
|
|
trace-text trace, "eval", "evaluating second arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
{
|
|
var first-arg/eax: (addr cell) <- lookup *first-arg-ah
|
|
var first-arg-type/eax: (addr int) <- get first-arg, type
|
|
compare *first-arg-type, 2/symbol
|
|
break-if-=
|
|
error trace, "first arg to define must be a symbol"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var second-arg-ah/edx: (addr handle cell) <- get rest, left
|
|
debug-print "P", 4/fg, 0/bg
|
|
evaluate second-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "Q", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
trace-text trace, "eval", "saving global binding"
|
|
var first-arg/eax: (addr cell) <- lookup *first-arg-ah
|
|
var first-arg-data-ah/eax: (addr handle stream byte) <- get first-arg, text-data
|
|
var first-arg-data/eax: (addr stream byte) <- lookup *first-arg-data-ah
|
|
var tmp-string: (handle array byte)
|
|
var tmp-ah/edx: (addr handle array byte) <- address tmp-string
|
|
rewind-stream first-arg-data
|
|
stream-to-array first-arg-data, tmp-ah
|
|
var first-arg-data-string/eax: (addr array byte) <- lookup *tmp-ah
|
|
var out-ah/edi: (addr handle cell) <- copy _out-ah
|
|
var defined-index: int
|
|
var defined-index-addr/ecx: (addr int) <- address defined-index
|
|
assign-or-create-global globals, first-arg-data-string, *out-ah, defined-index-addr, trace
|
|
{
|
|
compare definitions-created, 0
|
|
break-if-=
|
|
write-to-stream definitions-created, defined-index-addr
|
|
}
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:set: {
|
|
# trees starting with "set" mutate bindings
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "set", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var set?/eax: boolean <- symbol-equal? first, "set"
|
|
compare set?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "set"
|
|
trace-text trace, "eval", "evaluating second arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
{
|
|
var first-arg/eax: (addr cell) <- lookup *first-arg-ah
|
|
var first-arg-type/eax: (addr int) <- get first-arg, type
|
|
compare *first-arg-type, 2/symbol
|
|
break-if-=
|
|
error trace, "first arg to set must be a symbol"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var second-arg-ah/edx: (addr handle cell) <- get rest, left
|
|
debug-print "P", 4/fg, 0/bg
|
|
evaluate second-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "Q", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
trace-text trace, "eval", "mutating binding"
|
|
var first-arg/eax: (addr cell) <- lookup *first-arg-ah
|
|
var first-arg-data-ah/eax: (addr handle stream byte) <- get first-arg, text-data
|
|
var first-arg-data/eax: (addr stream byte) <- lookup *first-arg-data-ah
|
|
mutate-binding first-arg-data, _out-ah, env-h, globals, trace
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:and: {
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "and", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var and?/eax: boolean <- symbol-equal? first, "and"
|
|
compare and?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "and"
|
|
trace-text trace, "eval", "evaluating first arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
debug-print "R2", 4/fg, 0/bg
|
|
evaluate first-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "S2", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if first arg is nil, short-circuit
|
|
var out-ah/eax: (addr handle cell) <- copy _out-ah
|
|
var out/eax: (addr cell) <- lookup *out-ah
|
|
var nil?/eax: boolean <- nil? out
|
|
compare nil?, 0/false
|
|
{
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
#
|
|
trace-text trace, "eval", "evaluating second arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var second-ah/eax: (addr handle cell) <- get rest, left
|
|
debug-print "T2", 4/fg, 0/bg
|
|
evaluate second-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "U2", 4/fg, 0/bg
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:or: {
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "or", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var or?/eax: boolean <- symbol-equal? first, "or"
|
|
compare or?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "or"
|
|
trace-text trace, "eval", "evaluating first arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
debug-print "R2", 4/fg, 0/bg
|
|
evaluate first-arg-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "S2", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if first arg is not nil, short-circuit
|
|
var out-ah/eax: (addr handle cell) <- copy _out-ah
|
|
var out/eax: (addr cell) <- lookup *out-ah
|
|
var nil?/eax: boolean <- nil? out
|
|
compare nil?, 0/false
|
|
{
|
|
break-if-!=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
#
|
|
trace-text trace, "eval", "evaluating second arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var second-ah/eax: (addr handle cell) <- get rest, left
|
|
debug-print "T2", 4/fg, 0/bg
|
|
evaluate second-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "U2", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:if: {
|
|
# trees starting with "if" are conditionals
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "if", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var if?/eax: boolean <- symbol-equal? first, "if"
|
|
compare if?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "if"
|
|
trace-text trace, "eval", "evaluating first arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
var guard-h: (handle cell)
|
|
var guard-ah/esi: (addr handle cell) <- address guard-h
|
|
debug-print "R", 4/fg, 0/bg
|
|
evaluate first-arg-ah, guard-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "S", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var branch-ah/edi: (addr handle cell) <- get rest, left
|
|
var guard-a/eax: (addr cell) <- lookup *guard-ah
|
|
var skip-to-third-arg?/eax: boolean <- nil? guard-a
|
|
compare skip-to-third-arg?, 0/false
|
|
{
|
|
break-if-=
|
|
trace-text trace, "eval", "skipping to third arg"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
branch-ah <- get rest, left
|
|
}
|
|
debug-print "T", 4/fg, 0/bg
|
|
evaluate branch-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "U", 4/fg, 0/bg
|
|
trace-higher trace
|
|
return
|
|
}
|
|
$evaluate:while: {
|
|
# trees starting with "while" are loops
|
|
var expr/esi: (addr cell) <- copy in
|
|
# if its first elem is not "while", break
|
|
var first-ah/ecx: (addr handle cell) <- get in, left
|
|
var rest-ah/edx: (addr handle cell) <- get in, right
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var first-type/ecx: (addr int) <- get first, type
|
|
compare *first-type, 2/symbol
|
|
break-if-!=
|
|
var sym-data-ah/eax: (addr handle stream byte) <- get first, text-data
|
|
var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
|
|
var while?/eax: boolean <- stream-data-equal? sym-data, "while"
|
|
compare while?, 0/false
|
|
break-if-=
|
|
#
|
|
trace-text trace, "eval", "while"
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var first-arg-ah/ecx: (addr handle cell) <- get rest, left
|
|
rest-ah <- get rest, right
|
|
var guard-h: (handle cell)
|
|
var guard-ah/esi: (addr handle cell) <- address guard-h
|
|
$evaluate:while:loop-execution: {
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-!= $evaluate:while:loop-execution
|
|
}
|
|
trace-text trace, "eval", "loop termination check"
|
|
debug-print "V", 4/fg, 0/bg
|
|
evaluate first-arg-ah, guard-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "W", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var guard-a/eax: (addr cell) <- lookup *guard-ah
|
|
var done?/eax: boolean <- nil? guard-a
|
|
compare done?, 0/false
|
|
break-if-!=
|
|
evaluate-exprs rest-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
loop
|
|
}
|
|
trace-text trace, "eval", "loop terminated"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# trace "evaluate function call elements in " in {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x300)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "evaluate function call elements in "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell in-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
trace-lower trace
|
|
var evaluated-list-storage: (handle cell)
|
|
var evaluated-list-ah/esi: (addr handle cell) <- address evaluated-list-storage
|
|
var curr-out-ah/edx: (addr handle cell) <- copy evaluated-list-ah
|
|
var curr/ecx: (addr cell) <- copy in
|
|
$evaluate-list:loop: {
|
|
allocate-pair curr-out-ah
|
|
var nil?/eax: boolean <- nil? curr
|
|
compare nil?, 0/false
|
|
break-if-!=
|
|
# eval left
|
|
var curr-out/eax: (addr cell) <- lookup *curr-out-ah
|
|
var left-out-ah/edi: (addr handle cell) <- get curr-out, left
|
|
var left-ah/esi: (addr handle cell) <- get curr, left
|
|
debug-print "A", 4/fg, 0/bg
|
|
evaluate left-ah, left-out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "B", 4/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-higher trace
|
|
return
|
|
}
|
|
#
|
|
curr-out-ah <- get curr-out, right
|
|
var right-ah/eax: (addr handle cell) <- get curr, right
|
|
var right/eax: (addr cell) <- lookup *right-ah
|
|
curr <- copy right
|
|
loop
|
|
}
|
|
trace-higher trace
|
|
var evaluated-list/eax: (addr cell) <- lookup *evaluated-list-ah
|
|
var function-ah/ecx: (addr handle cell) <- get evaluated-list, left
|
|
var args-ah/edx: (addr handle cell) <- get evaluated-list, right
|
|
debug-print "C", 4/fg, 0/bg
|
|
apply function-ah, args-ah, _out-ah, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "Y", 4/fg, 0/bg
|
|
trace-higher trace
|
|
# trace "=> " _out-ah {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x200)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "=> "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell _out-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
debug-print "Z", 4/fg, 0/bg
|
|
}
|
|
|
|
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) {
|
|
var f-ah/eax: (addr handle cell) <- copy _f-ah
|
|
var _f/eax: (addr cell) <- lookup *f-ah
|
|
var f/esi: (addr cell) <- copy _f
|
|
# call primitive functions
|
|
{
|
|
var f-type/eax: (addr int) <- get f, type
|
|
compare *f-type, 4/primitive-function
|
|
break-if-!=
|
|
apply-primitive f, args-ah, out, globals, trace
|
|
return
|
|
}
|
|
# if it's not a primitive function it must be an anonymous function
|
|
# trace "apply anonymous function " f " in environment " env {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x200)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "apply anonymous function "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell _f-ah, stream, nested-trace
|
|
#? write stream, " in environment "
|
|
#? var callee-env-ah/eax: (addr handle cell) <- address callee-env-h
|
|
#? clear-trace nested-trace
|
|
#? print-cell callee-env-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
trace-lower trace
|
|
{
|
|
var f-type/ecx: (addr int) <- get f, type
|
|
compare *f-type, 0/pair
|
|
break-if-!=
|
|
var first-ah/eax: (addr handle cell) <- get f, left
|
|
var first/eax: (addr cell) <- lookup *first-ah
|
|
var litfn?/eax: boolean <- litfn? first
|
|
compare litfn?, 0/false
|
|
break-if-=
|
|
var rest-ah/esi: (addr handle cell) <- get f, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var callee-env-ah/edx: (addr handle cell) <- get rest, left
|
|
rest-ah <- get rest, right
|
|
rest <- lookup *rest-ah
|
|
var params-ah/ecx: (addr handle cell) <- get rest, left
|
|
var body-ah/eax: (addr handle cell) <- get rest, right
|
|
debug-print "D", 7/fg, 0/bg
|
|
apply-function params-ah, args-ah, body-ah, out, *callee-env-ah, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "Y", 7/fg, 0/bg
|
|
trace-higher trace
|
|
return
|
|
}
|
|
error trace, "unknown function"
|
|
}
|
|
|
|
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) {
|
|
# push bindings for params to env
|
|
var new-env-h: (handle cell)
|
|
var new-env-ah/esi: (addr handle cell) <- address new-env-h
|
|
push-bindings params-ah, args-ah, env-h, new-env-ah, trace
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
return
|
|
}
|
|
#
|
|
evaluate-exprs body-ah, out, new-env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
}
|
|
|
|
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) {
|
|
# eval all exprs, writing result to `out` each time
|
|
var exprs-ah/ecx: (addr handle cell) <- copy _exprs-ah
|
|
$evaluate-exprs:loop: {
|
|
var exprs/eax: (addr cell) <- lookup *exprs-ah
|
|
# stop when exprs is nil
|
|
{
|
|
var exprs-nil?/eax: boolean <- nil? exprs
|
|
compare exprs-nil?, 0/false
|
|
break-if-!= $evaluate-exprs:loop
|
|
}
|
|
# evaluate each expression, writing result to `out`
|
|
{
|
|
var curr-ah/eax: (addr handle cell) <- get exprs, left
|
|
debug-print "E", 7/fg, 0/bg
|
|
evaluate curr-ah, out, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "X", 7/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
return
|
|
}
|
|
}
|
|
#
|
|
exprs-ah <- get exprs, right
|
|
loop
|
|
}
|
|
# `out` contains result of evaluating final expression
|
|
}
|
|
|
|
# Bind params to corresponding args and add the bindings to old-env. Return
|
|
# the result in env-ah.
|
|
#
|
|
# We never modify old-env, but we point to it. This way other parts of the
|
|
# interpreter can continue using old-env, and everything works harmoniously
|
|
# even though no cells are copied around.
|
|
#
|
|
# env should always be a DAG (ignoring internals of values). It doesn't have
|
|
# to be a tree (some values may be shared), but there are also no cycles.
|
|
#
|
|
# Learn more: https://en.wikipedia.org/wiki/Persistent_data_structure
|
|
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) {
|
|
var params-ah/edx: (addr handle cell) <- copy _params-ah
|
|
var args-ah/ebx: (addr handle cell) <- copy _args-ah
|
|
var _params/eax: (addr cell) <- lookup *params-ah
|
|
var params/esi: (addr cell) <- copy _params
|
|
{
|
|
var params-nil?/eax: boolean <- nil? params
|
|
compare params-nil?, 0/false
|
|
break-if-=
|
|
# nil is a literal
|
|
trace-text trace, "eval", "done with push-bindings"
|
|
copy-handle old-env-h, env-ah
|
|
return
|
|
}
|
|
# Params can only be symbols or pairs. Args can be anything.
|
|
# trace "pushing bindings from " params " to " args {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x200)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "pushing bindings from "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell params-ah, stream, nested-trace
|
|
write stream, " to "
|
|
clear-trace nested-trace
|
|
print-cell args-ah, stream, nested-trace
|
|
write stream, " onto "
|
|
var old-env-ah/eax: (addr handle cell) <- address old-env-h
|
|
clear-trace nested-trace
|
|
print-cell old-env-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
trace-lower trace
|
|
var params-type/eax: (addr int) <- get params, type
|
|
compare *params-type, 2/symbol
|
|
{
|
|
break-if-!=
|
|
trace-text trace, "eval", "symbol; binding to all remaining args"
|
|
# create a new binding
|
|
var new-binding-storage: (handle cell)
|
|
var new-binding-ah/eax: (addr handle cell) <- address new-binding-storage
|
|
new-pair new-binding-ah, *params-ah, *args-ah
|
|
# push it to env
|
|
new-pair env-ah, *new-binding-ah, old-env-h
|
|
trace-higher trace
|
|
return
|
|
}
|
|
compare *params-type, 0/pair
|
|
{
|
|
break-if-=
|
|
error trace, "cannot bind a non-symbol"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var _args/eax: (addr cell) <- lookup *args-ah
|
|
var args/edi: (addr cell) <- copy _args
|
|
# params is now a pair, so args must be also
|
|
{
|
|
var args-nil?/eax: boolean <- nil? args
|
|
compare args-nil?, 0/false
|
|
break-if-=
|
|
error trace, "not enough args to bind"
|
|
return
|
|
}
|
|
var args-type/eax: (addr int) <- get args, type
|
|
compare *args-type, 0/pair
|
|
{
|
|
break-if-=
|
|
error trace, "args not in a proper list"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var intermediate-env-storage: (handle cell)
|
|
var intermediate-env-ah/edx: (addr handle cell) <- address intermediate-env-storage
|
|
var first-param-ah/eax: (addr handle cell) <- get params, left
|
|
var first-arg-ah/ecx: (addr handle cell) <- get args, left
|
|
push-bindings first-param-ah, first-arg-ah, old-env-h, intermediate-env-ah, trace
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var remaining-params-ah/eax: (addr handle cell) <- get params, right
|
|
var remaining-args-ah/ecx: (addr handle cell) <- get args, right
|
|
push-bindings remaining-params-ah, remaining-args-ah, *intermediate-env-ah, env-ah, trace
|
|
trace-higher trace
|
|
}
|
|
|
|
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) {
|
|
# trace sym
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x800) # pessimistically sized just for the large alist loaded from disk in `main`
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "look up "
|
|
var sym2/eax: (addr cell) <- copy sym
|
|
var sym-data-ah/eax: (addr handle stream byte) <- get sym2, text-data
|
|
var sym-data/eax: (addr stream byte) <- lookup *sym-data-ah
|
|
rewind-stream sym-data
|
|
write-stream stream, sym-data
|
|
write stream, " in "
|
|
var env-ah/eax: (addr handle cell) <- address env-h
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell env-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
trace-lower trace
|
|
var _env/eax: (addr cell) <- lookup env-h
|
|
var env/ebx: (addr cell) <- copy _env
|
|
# if env is not a list, error
|
|
{
|
|
var env-type/ecx: (addr int) <- get env, type
|
|
compare *env-type, 0/pair
|
|
break-if-=
|
|
error trace, "eval found a non-list environment"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if env is nil, look up in globals
|
|
{
|
|
var env-nil?/eax: boolean <- nil? env
|
|
compare env-nil?, 0/false
|
|
break-if-=
|
|
debug-print "b", 7/fg, 0/bg
|
|
lookup-symbol-in-globals sym, out, globals, trace, inner-screen-var, inner-keyboard-var
|
|
debug-print "x", 7/fg, 0/bg
|
|
trace-higher trace
|
|
# trace "=> " out " (global)" {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-!=
|
|
var stream-storage: (stream byte 0x200)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "=> "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell out, stream, nested-trace
|
|
write stream, " (global)"
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
debug-print "y", 7/fg, 0/bg
|
|
return
|
|
}
|
|
# check car
|
|
var env-head-storage: (handle cell)
|
|
var env-head-ah/eax: (addr handle cell) <- address env-head-storage
|
|
car env, env-head-ah, trace
|
|
var _env-head/eax: (addr cell) <- lookup *env-head-ah
|
|
var env-head/ecx: (addr cell) <- copy _env-head
|
|
# if car is not a list, abort
|
|
{
|
|
var env-head-type/eax: (addr int) <- get env-head, type
|
|
compare *env-head-type, 0/pair
|
|
break-if-=
|
|
error trace, "environment is not a list of (key . value) pairs"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# check key
|
|
var curr-key-storage: (handle cell)
|
|
var curr-key-ah/eax: (addr handle cell) <- address curr-key-storage
|
|
car env-head, curr-key-ah, trace
|
|
var curr-key/eax: (addr cell) <- lookup *curr-key-ah
|
|
# if key is not a symbol, abort
|
|
{
|
|
var curr-key-type/eax: (addr int) <- get curr-key, type
|
|
compare *curr-key-type, 2/symbol
|
|
break-if-=
|
|
error trace, "environment contains a binding for a non-symbol"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if key matches sym, return val
|
|
var match?/eax: boolean <- cell-isomorphic? curr-key, sym, trace
|
|
compare match?, 0/false
|
|
{
|
|
break-if-=
|
|
cdr env-head, out, trace
|
|
# trace "=> " out " (match)" {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-!=
|
|
var stream-storage: (stream byte 0x800)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "=> "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell out, stream, nested-trace
|
|
write stream, " (match)"
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# otherwise recurse
|
|
var env-tail-storage: (handle cell)
|
|
var env-tail-ah/eax: (addr handle cell) <- address env-tail-storage
|
|
cdr env, env-tail-ah, trace
|
|
lookup-symbol sym, out, *env-tail-ah, globals, trace, inner-screen-var, inner-keyboard-var
|
|
trace-higher trace
|
|
# trace "=> " out " (recurse)" {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-!=
|
|
var stream-storage: (stream byte 0x200)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "=> "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell out, stream, nested-trace
|
|
write stream, " (recurse)"
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
}
|
|
|
|
fn test-lookup-symbol-in-env {
|
|
# tmp = (a . 3)
|
|
var val-storage: (handle cell)
|
|
var val-ah/ecx: (addr handle cell) <- address val-storage
|
|
new-integer val-ah, 3
|
|
var key-storage: (handle cell)
|
|
var key-ah/edx: (addr handle cell) <- address key-storage
|
|
new-symbol key-ah, "a"
|
|
var env-storage: (handle cell)
|
|
var env-ah/ebx: (addr handle cell) <- address env-storage
|
|
new-pair env-ah, *key-ah, *val-ah
|
|
# env = ((a . 3))
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
new-pair env-ah, *env-ah, *nil-ah
|
|
# lookup sym(a) in env tmp
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/edx: (addr handle cell) <- address tmp-storage
|
|
new-symbol tmp-ah, "a"
|
|
var in/eax: (addr cell) <- lookup *tmp-ah
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
lookup-symbol in, tmp-ah, *env-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 1/number, "F - test-lookup-symbol-in-env/0"
|
|
var result-value-addr/eax: (addr float) <- get result, number-data
|
|
var result-value/eax: int <- convert *result-value-addr
|
|
check-ints-equal result-value, 3, "F - test-lookup-symbol-in-env/1"
|
|
}
|
|
|
|
fn test-lookup-symbol-in-globals {
|
|
var globals-storage: global-table
|
|
var globals/edi: (addr global-table) <- address globals-storage
|
|
initialize-globals globals
|
|
# env = nil
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
# lookup sym(a), env
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/ebx: (addr handle cell) <- address tmp-storage
|
|
new-symbol tmp-ah, "+"
|
|
var in/eax: (addr cell) <- lookup *tmp-ah
|
|
var trace-storage: trace
|
|
var trace/esi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
lookup-symbol in, tmp-ah, *nil-ah, globals, trace, 0/no-screen, 0/no-keyboard
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 4/primitive-function, "F - test-lookup-symbol-in-globals/0"
|
|
var result-value/eax: (addr int) <- get result, index-data
|
|
check-ints-equal *result-value, 1/add, "F - test-lookup-symbol-in-globals/1"
|
|
}
|
|
|
|
fn mutate-binding name: (addr stream byte), val: (addr handle cell), env-h: (handle cell), globals: (addr global-table), trace: (addr trace) {
|
|
# trace name
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var stream-storage: (stream byte 0x800) # pessimistically sized just for the large alist loaded from disk in `main`
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "bind "
|
|
rewind-stream name
|
|
write-stream stream, name
|
|
write stream, " to "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell val, stream, nested-trace
|
|
write stream, " in "
|
|
var env-ah/eax: (addr handle cell) <- address env-h
|
|
clear-trace nested-trace
|
|
print-cell env-ah, stream, nested-trace
|
|
trace trace, "eval", stream
|
|
}
|
|
trace-lower trace
|
|
var _env/eax: (addr cell) <- lookup env-h
|
|
var env/ebx: (addr cell) <- copy _env
|
|
# if env is not a list, abort
|
|
{
|
|
var env-type/ecx: (addr int) <- get env, type
|
|
compare *env-type, 0/pair
|
|
break-if-=
|
|
error trace, "eval found a non-list environment"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if env is nil, look in globals
|
|
{
|
|
var env-nil?/eax: boolean <- nil? env
|
|
compare env-nil?, 0/false
|
|
break-if-=
|
|
debug-print "b", 3/fg, 0/bg
|
|
mutate-binding-in-globals name, val, globals, trace
|
|
debug-print "x", 3/fg, 0/bg
|
|
trace-higher trace
|
|
# trace "=> " val " (global)" {{{
|
|
{
|
|
var should-trace?/eax: boolean <- should-trace? trace
|
|
compare should-trace?, 0/false
|
|
break-if-=
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-!=
|
|
var stream-storage: (stream byte 0x200)
|
|
var stream/ecx: (addr stream byte) <- address stream-storage
|
|
write stream, "=> "
|
|
var nested-trace-storage: trace
|
|
var nested-trace/edi: (addr trace) <- address nested-trace-storage
|
|
initialize-trace nested-trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
print-cell val, stream, nested-trace
|
|
write stream, " (global)"
|
|
trace trace, "eval", stream
|
|
}
|
|
# }}}
|
|
debug-print "y", 3/fg, 0/bg
|
|
return
|
|
}
|
|
# check car
|
|
var env-head-storage: (handle cell)
|
|
var env-head-ah/eax: (addr handle cell) <- address env-head-storage
|
|
car env, env-head-ah, trace
|
|
var _env-head/eax: (addr cell) <- lookup *env-head-ah
|
|
var env-head/ecx: (addr cell) <- copy _env-head
|
|
# if car is not a list, abort
|
|
{
|
|
var env-head-type/eax: (addr int) <- get env-head, type
|
|
compare *env-head-type, 0/pair
|
|
break-if-=
|
|
error trace, "environment is not a list of (key . value) pairs"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# check key
|
|
var curr-key-storage: (handle cell)
|
|
var curr-key-ah/eax: (addr handle cell) <- address curr-key-storage
|
|
car env-head, curr-key-ah, trace
|
|
var curr-key/eax: (addr cell) <- lookup *curr-key-ah
|
|
# if key is not a symbol, abort
|
|
{
|
|
var curr-key-type/eax: (addr int) <- get curr-key, type
|
|
compare *curr-key-type, 2/symbol
|
|
break-if-=
|
|
error trace, "environment contains a binding for a non-symbol"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if key matches name, return val
|
|
var curr-key-data-ah/eax: (addr handle stream byte) <- get curr-key, text-data
|
|
var curr-key-data/eax: (addr stream byte) <- lookup *curr-key-data-ah
|
|
var match?/eax: boolean <- streams-data-equal? curr-key-data, name
|
|
compare match?, 0/false
|
|
{
|
|
break-if-=
|
|
var dest/eax: (addr handle cell) <- get env-head, right
|
|
copy-object val, dest
|
|
trace-text trace, "eval", "=> done"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# otherwise recurse
|
|
var env-tail-storage: (handle cell)
|
|
var env-tail-ah/eax: (addr handle cell) <- address env-tail-storage
|
|
cdr env, env-tail-ah, trace
|
|
mutate-binding name, val, *env-tail-ah, globals, trace
|
|
trace-higher trace
|
|
}
|
|
|
|
fn car _in: (addr cell), out: (addr handle cell), trace: (addr trace) {
|
|
trace-text trace, "eval", "car"
|
|
trace-lower trace
|
|
var in/eax: (addr cell) <- copy _in
|
|
# if in is not a list, abort
|
|
{
|
|
var in-type/ecx: (addr int) <- get in, type
|
|
compare *in-type, 0/pair
|
|
break-if-=
|
|
error trace, "car on a non-list"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if in is nil, abort
|
|
{
|
|
var in-nil?/eax: boolean <- nil? in
|
|
compare in-nil?, 0/false
|
|
break-if-=
|
|
error trace, "car on nil"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var in-left/eax: (addr handle cell) <- get in, left
|
|
copy-object in-left, out
|
|
trace-higher trace
|
|
return
|
|
}
|
|
|
|
fn cdr _in: (addr cell), out: (addr handle cell), trace: (addr trace) {
|
|
trace-text trace, "eval", "cdr"
|
|
trace-lower trace
|
|
var in/eax: (addr cell) <- copy _in
|
|
# if in is not a list, abort
|
|
{
|
|
var in-type/ecx: (addr int) <- get in, type
|
|
compare *in-type, 0/pair
|
|
break-if-=
|
|
error trace, "car on a non-list"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# if in is nil, abort
|
|
{
|
|
var in-nil?/eax: boolean <- nil? in
|
|
compare in-nil?, 0/false
|
|
break-if-=
|
|
error trace, "car on nil"
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var in-right/eax: (addr handle cell) <- get in, right
|
|
copy-object in-right, out
|
|
trace-higher trace
|
|
return
|
|
}
|
|
|
|
fn cell-isomorphic? _a: (addr cell), _b: (addr cell), trace: (addr trace) -> _/eax: boolean {
|
|
trace-text trace, "eval", "cell-isomorphic?"
|
|
trace-lower trace
|
|
var a/esi: (addr cell) <- copy _a
|
|
var b/edi: (addr cell) <- copy _b
|
|
# if types don't match, return false
|
|
var a-type-addr/eax: (addr int) <- get a, type
|
|
var b-type-addr/ecx: (addr int) <- get b, type
|
|
var b-type/ecx: int <- copy *b-type-addr
|
|
compare b-type, *a-type-addr
|
|
{
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> false (type)"
|
|
return 0/false
|
|
}
|
|
# if types are number, compare number-data
|
|
# TODO: exactly comparing floats is a bad idea
|
|
compare b-type, 1/number
|
|
{
|
|
break-if-!=
|
|
var a-val-addr/eax: (addr float) <- get a, number-data
|
|
var b-val-addr/ecx: (addr float) <- get b, number-data
|
|
var a-val/xmm0: float <- copy *a-val-addr
|
|
compare a-val, *b-val-addr
|
|
{
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> false (numbers)"
|
|
return 0/false
|
|
}
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> true (numbers)"
|
|
return 1/true
|
|
}
|
|
{
|
|
compare b-type, 2/symbol
|
|
break-if-!=
|
|
var b-val-ah/eax: (addr handle stream byte) <- get b, text-data
|
|
var _b-val/eax: (addr stream byte) <- lookup *b-val-ah
|
|
var b-val/ecx: (addr stream byte) <- copy _b-val
|
|
var a-val-ah/eax: (addr handle stream byte) <- get a, text-data
|
|
var a-val/eax: (addr stream byte) <- lookup *a-val-ah
|
|
var tmp-array: (handle array byte)
|
|
var tmp-ah/edx: (addr handle array byte) <- address tmp-array
|
|
rewind-stream a-val
|
|
stream-to-array a-val, tmp-ah
|
|
var tmp/eax: (addr array byte) <- lookup *tmp-ah
|
|
var match?/eax: boolean <- stream-data-equal? b-val, tmp
|
|
trace-higher trace
|
|
{
|
|
compare match?, 0/false
|
|
break-if-=
|
|
trace-text trace, "eval", "=> true (symbols)"
|
|
}
|
|
{
|
|
compare match?, 0/false
|
|
break-if-!=
|
|
trace-text trace, "eval", "=> false (symbols)"
|
|
}
|
|
return match?
|
|
}
|
|
{
|
|
compare b-type, 3/stream
|
|
break-if-!=
|
|
var a-val-ah/eax: (addr handle stream byte) <- get a, text-data
|
|
var a-val/eax: (addr stream byte) <- lookup *a-val-ah
|
|
var a-data-h: (handle array byte)
|
|
var a-data-ah/edx: (addr handle array byte) <- address a-data-h
|
|
stream-to-array a-val, a-data-ah
|
|
var _a-data/eax: (addr array byte) <- lookup *a-data-ah
|
|
var a-data/edx: (addr array byte) <- copy _a-data
|
|
var b-val-ah/eax: (addr handle stream byte) <- get b, text-data
|
|
var b-val/eax: (addr stream byte) <- lookup *b-val-ah
|
|
var b-data-h: (handle array byte)
|
|
var b-data-ah/ecx: (addr handle array byte) <- address b-data-h
|
|
stream-to-array b-val, b-data-ah
|
|
var b-data/eax: (addr array byte) <- lookup *b-data-ah
|
|
var match?/eax: boolean <- string-equal? a-data, b-data
|
|
trace-higher trace
|
|
{
|
|
compare match?, 0/false
|
|
break-if-=
|
|
trace-text trace, "eval", "=> true (streams)"
|
|
}
|
|
{
|
|
compare match?, 0/false
|
|
break-if-!=
|
|
trace-text trace, "eval", "=> false (streams)"
|
|
}
|
|
return match?
|
|
}
|
|
# if objects are primitive functions, compare index-data
|
|
compare b-type, 4/primitive
|
|
{
|
|
break-if-!=
|
|
var a-val-addr/eax: (addr int) <- get a, index-data
|
|
var b-val-addr/ecx: (addr int) <- get b, index-data
|
|
var a-val/eax: int <- copy *a-val-addr
|
|
compare a-val, *b-val-addr
|
|
{
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> false (primitives)"
|
|
return 0/false
|
|
}
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> true (primitives)"
|
|
return 1/true
|
|
}
|
|
# if objects are screens, check if they're the same object
|
|
compare b-type, 5/screen
|
|
{
|
|
break-if-!=
|
|
var a-val-addr/eax: (addr handle screen) <- get a, screen-data
|
|
var b-val-addr/ecx: (addr handle screen) <- get b, screen-data
|
|
var result/eax: boolean <- handle-equal? *a-val-addr, *b-val-addr
|
|
compare result, 0/false
|
|
return result
|
|
}
|
|
# if objects are keyboards, check if they have the same contents
|
|
compare b-type, 6/keyboard
|
|
{
|
|
break-if-!=
|
|
var a-val-addr/ecx: (addr handle gap-buffer) <- get a, keyboard-data
|
|
var _a/eax: (addr gap-buffer) <- lookup *a-val-addr
|
|
var a/ecx: (addr gap-buffer) <- copy _a
|
|
var b-val-addr/eax: (addr handle gap-buffer) <- get b, keyboard-data
|
|
var b/eax: (addr gap-buffer) <- lookup *b-val-addr
|
|
var result/eax: boolean <- gap-buffers-equal? a, b
|
|
return result
|
|
}
|
|
# if a is nil, b should be nil
|
|
{
|
|
# (assumes nil? returns 0 or 1)
|
|
var _b-nil?/eax: boolean <- nil? b
|
|
var b-nil?/ecx: boolean <- copy _b-nil?
|
|
var a-nil?/eax: boolean <- nil? a
|
|
# a == nil and b == nil => return true
|
|
{
|
|
compare a-nil?, 0/false
|
|
break-if-=
|
|
compare b-nil?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> true (nils)"
|
|
return 1/true
|
|
}
|
|
# a == nil => return false
|
|
{
|
|
compare a-nil?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> false (b != nil)"
|
|
return 0/false
|
|
}
|
|
# b == nil => return false
|
|
{
|
|
compare b-nil?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> false (a != nil)"
|
|
return 0/false
|
|
}
|
|
}
|
|
# a and b are pairs
|
|
var a-tmp-storage: (handle cell)
|
|
var a-tmp-ah/edx: (addr handle cell) <- address a-tmp-storage
|
|
var b-tmp-storage: (handle cell)
|
|
var b-tmp-ah/ebx: (addr handle cell) <- address b-tmp-storage
|
|
# if cars aren't equal, return false
|
|
car a, a-tmp-ah, trace
|
|
car b, b-tmp-ah, trace
|
|
{
|
|
var _a-tmp/eax: (addr cell) <- lookup *a-tmp-ah
|
|
var a-tmp/ecx: (addr cell) <- copy _a-tmp
|
|
var b-tmp/eax: (addr cell) <- lookup *b-tmp-ah
|
|
var result/eax: boolean <- cell-isomorphic? a-tmp, b-tmp, trace
|
|
compare result, 0/false
|
|
break-if-!=
|
|
trace-higher trace
|
|
trace-text trace, "eval", "=> false (car mismatch)"
|
|
return 0/false
|
|
}
|
|
# recurse on cdrs
|
|
cdr a, a-tmp-ah, trace
|
|
cdr b, b-tmp-ah, trace
|
|
var _a-tmp/eax: (addr cell) <- lookup *a-tmp-ah
|
|
var a-tmp/ecx: (addr cell) <- copy _a-tmp
|
|
var b-tmp/eax: (addr cell) <- lookup *b-tmp-ah
|
|
var result/eax: boolean <- cell-isomorphic? a-tmp, b-tmp, trace
|
|
trace-higher trace
|
|
return result
|
|
}
|
|
|
|
fn fn? _x: (addr cell) -> _/eax: boolean {
|
|
var x/esi: (addr cell) <- copy _x
|
|
var type/eax: (addr int) <- get x, type
|
|
compare *type, 2/symbol
|
|
{
|
|
break-if-=
|
|
return 0/false
|
|
}
|
|
var contents-ah/eax: (addr handle stream byte) <- get x, text-data
|
|
var contents/eax: (addr stream byte) <- lookup *contents-ah
|
|
var result/eax: boolean <- stream-data-equal? contents, "fn"
|
|
return result
|
|
}
|
|
|
|
fn litfn? _x: (addr cell) -> _/eax: boolean {
|
|
var x/esi: (addr cell) <- copy _x
|
|
var type/eax: (addr int) <- get x, type
|
|
compare *type, 2/symbol
|
|
{
|
|
break-if-=
|
|
return 0/false
|
|
}
|
|
var contents-ah/eax: (addr handle stream byte) <- get x, text-data
|
|
var contents/eax: (addr stream byte) <- lookup *contents-ah
|
|
var result/eax: boolean <- stream-data-equal? contents, "litfn"
|
|
return result
|
|
}
|
|
|
|
fn litmac? _x: (addr cell) -> _/eax: boolean {
|
|
var x/esi: (addr cell) <- copy _x
|
|
var type/eax: (addr int) <- get x, type
|
|
compare *type, 2/symbol
|
|
{
|
|
break-if-=
|
|
return 0/false
|
|
}
|
|
var contents-ah/eax: (addr handle stream byte) <- get x, text-data
|
|
var contents/eax: (addr stream byte) <- lookup *contents-ah
|
|
var result/eax: boolean <- stream-data-equal? contents, "litmac"
|
|
return result
|
|
}
|
|
|
|
fn test-evaluate-is-well-behaved {
|
|
var t-storage: trace
|
|
var t/esi: (addr trace) <- address t-storage
|
|
initialize-trace t, 0x100/max-depth, 0x10/capacity, 0/visible # we don't use trace UI
|
|
# env = nil
|
|
var env-storage: (handle cell)
|
|
var env-ah/ecx: (addr handle cell) <- address env-storage
|
|
allocate-pair env-ah
|
|
# eval sym(a), nil env
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/edx: (addr handle cell) <- address tmp-storage
|
|
new-symbol tmp-ah, "a"
|
|
evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, t, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
# doesn't die
|
|
check-trace-contains t, "error", "unbound symbol: a", "F - test-evaluate-is-well-behaved"
|
|
}
|
|
|
|
fn test-evaluate-number {
|
|
# env = nil
|
|
var env-storage: (handle cell)
|
|
var env-ah/ecx: (addr handle cell) <- address env-storage
|
|
allocate-pair env-ah
|
|
# tmp = 3
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/edx: (addr handle cell) <- address tmp-storage
|
|
new-integer tmp-ah, 3
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
#
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 1/number, "F - test-evaluate-number/0"
|
|
var result-value-addr/eax: (addr float) <- get result, number-data
|
|
var result-value/eax: int <- convert *result-value-addr
|
|
check-ints-equal result-value, 3, "F - test-evaluate-number/1"
|
|
}
|
|
|
|
fn test-evaluate-symbol {
|
|
# tmp = (a . 3)
|
|
var val-storage: (handle cell)
|
|
var val-ah/ecx: (addr handle cell) <- address val-storage
|
|
new-integer val-ah, 3
|
|
var key-storage: (handle cell)
|
|
var key-ah/edx: (addr handle cell) <- address key-storage
|
|
new-symbol key-ah, "a"
|
|
var env-storage: (handle cell)
|
|
var env-ah/ebx: (addr handle cell) <- address env-storage
|
|
new-pair env-ah, *key-ah, *val-ah
|
|
# env = ((a . 3))
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
new-pair env-ah, *env-ah, *nil-ah
|
|
# eval sym(a), env
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/edx: (addr handle cell) <- address tmp-storage
|
|
new-symbol tmp-ah, "a"
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp-ah, *env-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 1/number, "F - test-evaluate-symbol/0"
|
|
var result-value-addr/eax: (addr float) <- get result, number-data
|
|
var result-value/eax: int <- convert *result-value-addr
|
|
check-ints-equal result-value, 3, "F - test-evaluate-symbol/1"
|
|
}
|
|
|
|
fn test-evaluate-quote {
|
|
# env = nil
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
# eval `a, env
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/edx: (addr handle cell) <- address tmp-storage
|
|
new-symbol tmp-ah, "'"
|
|
var tmp2-storage: (handle cell)
|
|
var tmp2-ah/ebx: (addr handle cell) <- address tmp2-storage
|
|
new-symbol tmp2-ah, "a"
|
|
new-pair tmp-ah, *tmp-ah, *tmp2-ah
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp-ah, *nil-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 2/symbol, "F - test-evaluate-quote/0"
|
|
var sym?/eax: boolean <- symbol-equal? result, "a"
|
|
check sym?, "F - test-evaluate-quote/1"
|
|
}
|
|
|
|
fn test-evaluate-primitive-function {
|
|
var globals-storage: global-table
|
|
var globals/edi: (addr global-table) <- address globals-storage
|
|
initialize-globals globals
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
var add-storage: (handle cell)
|
|
var add-ah/ebx: (addr handle cell) <- address add-storage
|
|
new-symbol add-ah, "+"
|
|
# eval +, nil env
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/esi: (addr handle cell) <- address tmp-storage
|
|
var trace-storage: trace
|
|
var trace/edx: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate add-ah, tmp-ah, *nil-ah, globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
#
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 4/primitive-function, "F - test-evaluate-primitive-function/0"
|
|
var result-value/eax: (addr int) <- get result, index-data
|
|
check-ints-equal *result-value, 1/add, "F - test-evaluate-primitive-function/1"
|
|
}
|
|
|
|
fn test-evaluate-primitive-function-call {
|
|
var t-storage: trace
|
|
var t/edi: (addr trace) <- address t-storage
|
|
initialize-trace t, 0x100/max-depth, 0x100/capacity, 0/visible # we don't use trace UI
|
|
#
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
var one-storage: (handle cell)
|
|
var one-ah/edx: (addr handle cell) <- address one-storage
|
|
new-integer one-ah, 1
|
|
var add-storage: (handle cell)
|
|
var add-ah/ebx: (addr handle cell) <- address add-storage
|
|
new-symbol add-ah, "+"
|
|
# input is (+ 1 1)
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/esi: (addr handle cell) <- address tmp-storage
|
|
new-pair tmp-ah, *one-ah, *nil-ah
|
|
new-pair tmp-ah, *one-ah, *tmp-ah
|
|
new-pair tmp-ah, *add-ah, *tmp-ah
|
|
#? dump-cell tmp-ah
|
|
#
|
|
var globals-storage: global-table
|
|
var globals/edx: (addr global-table) <- address globals-storage
|
|
initialize-globals globals
|
|
#
|
|
evaluate tmp-ah, tmp-ah, *nil-ah, globals, t, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
#? dump-trace t
|
|
#
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 1/number, "F - test-evaluate-primitive-function-call/0"
|
|
var result-value-addr/eax: (addr float) <- get result, number-data
|
|
var result-value/eax: int <- convert *result-value-addr
|
|
check-ints-equal result-value, 2, "F - test-evaluate-primitive-function-call/1"
|
|
}
|
|
|
|
fn test-evaluate-backquote {
|
|
# env = nil
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
# eval `a, env
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/edx: (addr handle cell) <- address tmp-storage
|
|
new-symbol tmp-ah, "`"
|
|
var tmp2-storage: (handle cell)
|
|
var tmp2-ah/ebx: (addr handle cell) <- address tmp2-storage
|
|
new-symbol tmp2-ah, "a"
|
|
new-pair tmp-ah, *tmp-ah, *tmp2-ah
|
|
clear-object tmp2-ah
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp2-ah, *nil-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
var result/eax: (addr cell) <- lookup *tmp2-ah
|
|
var result-type/edx: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 2/symbol, "F - test-evaluate-backquote/0"
|
|
var sym?/eax: boolean <- symbol-equal? result, "a"
|
|
check sym?, "F - test-evaluate-backquote/1"
|
|
}
|
|
|
|
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) {
|
|
# stack overflow? # disable when enabling Really-debug-print
|
|
#? dump-cell-from-cursor-over-full-screen _in-ah
|
|
check-stack
|
|
{
|
|
var inner-screen-var/eax: (addr handle cell) <- copy inner-screen-var
|
|
compare inner-screen-var, 0
|
|
break-if-=
|
|
var inner-screen-var-addr/eax: (addr cell) <- lookup *inner-screen-var
|
|
compare inner-screen-var-addr, 0
|
|
break-if-=
|
|
# if inner-screen-var exists, we're probably not in a test
|
|
show-stack-state
|
|
}
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
return
|
|
}
|
|
trace-lower trace
|
|
var in-ah/esi: (addr handle cell) <- copy _in-ah
|
|
var in/eax: (addr cell) <- lookup *in-ah
|
|
{
|
|
var nil?/eax: boolean <- nil? in
|
|
compare nil?, 0/false
|
|
break-if-=
|
|
# nil is a literal
|
|
trace-text trace, "eval", "backquote nil"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var in-type/ecx: (addr int) <- get in, type
|
|
compare *in-type, 0/pair
|
|
{
|
|
break-if-=
|
|
# copy non-pairs directly
|
|
# TODO: streams might need to be copied
|
|
trace-text trace, "eval", "backquote atom"
|
|
copy-object _in-ah, _out-ah
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# 'in' is a pair
|
|
debug-print "()", 4/fg, 0/bg
|
|
var in-ah/esi: (addr handle cell) <- copy _in-ah
|
|
var _in/eax: (addr cell) <- lookup *in-ah
|
|
var in/ebx: (addr cell) <- copy _in
|
|
var in-left-ah/ecx: (addr handle cell) <- get in, left
|
|
debug-print "10", 4/fg, 0/bg
|
|
# check for unquote
|
|
$evaluate-backquote:unquote: {
|
|
var in-left/eax: (addr cell) <- lookup *in-left-ah
|
|
var unquote?/eax: boolean <- symbol-equal? in-left, ","
|
|
compare unquote?, 0/false
|
|
break-if-=
|
|
trace-text trace, "eval", "unquote"
|
|
var rest-ah/eax: (addr handle cell) <- get in, right
|
|
debug-print ",", 3/fg, 0/bg
|
|
evaluate rest-ah, _out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print ",)", 3/fg, 0/bg
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# check for unquote-splice in in-left
|
|
debug-print "11", 4/fg, 0/bg
|
|
var out-ah/edi: (addr handle cell) <- copy _out-ah
|
|
$evaluate-backquote:unquote-splice: {
|
|
#? dump-cell-from-cursor-over-full-screen in-left-ah
|
|
var in-left/eax: (addr cell) <- lookup *in-left-ah
|
|
{
|
|
debug-print "12", 4/fg, 0/bg
|
|
{
|
|
var in-left-is-nil?/eax: boolean <- nil? in-left
|
|
compare in-left-is-nil?, 0/false
|
|
}
|
|
break-if-!= $evaluate-backquote:unquote-splice
|
|
var in-left-type/ecx: (addr int) <- get in-left, type
|
|
debug-print "13", 4/fg, 0/bg
|
|
compare *in-left-type, 0/pair
|
|
break-if-!= $evaluate-backquote:unquote-splice
|
|
var in-left-left-ah/eax: (addr handle cell) <- get in-left, left
|
|
debug-print "14", 4/fg, 0/bg
|
|
var in-left-left/eax: (addr cell) <- lookup *in-left-left-ah
|
|
debug-print "15", 4/fg, 0/bg
|
|
var in-left-left-type/ecx: (addr int) <- get in-left-left, type
|
|
var left-is-unquote-splice?/eax: boolean <- symbol-equal? in-left-left, ",@"
|
|
debug-print "16", 4/fg, 0/bg
|
|
compare left-is-unquote-splice?, 0/false
|
|
}
|
|
break-if-=
|
|
debug-print "17", 4/fg, 0/bg
|
|
trace-text trace, "eval", "unquote-splice"
|
|
var in-unquote-payload-ah/eax: (addr handle cell) <- get in-left, right
|
|
evaluate in-unquote-payload-ah, out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
# while (*out-ah != null) out-ah = cdr(out-ah)
|
|
{
|
|
var out/eax: (addr cell) <- lookup *out-ah
|
|
{
|
|
var done?/eax: boolean <- nil? out
|
|
compare done?, 0/false
|
|
}
|
|
break-if-!=
|
|
out-ah <- get out, right
|
|
loop
|
|
}
|
|
# append result of in-right
|
|
var in-right-ah/ecx: (addr handle cell) <- get in, right
|
|
evaluate-backquote in-right-ah, out-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
trace-higher trace
|
|
return
|
|
}
|
|
debug-print "19", 4/fg, 0/bg
|
|
# otherwise continue copying
|
|
trace-text trace, "eval", "backquote: copy"
|
|
var out-ah/edi: (addr handle cell) <- copy _out-ah
|
|
allocate-pair out-ah
|
|
debug-print "20", 7/fg, 0/bg
|
|
#? dump-cell-from-cursor-over-full-screen out-ah
|
|
var out/eax: (addr cell) <- lookup *out-ah
|
|
var out-left-ah/edx: (addr handle cell) <- get out, left
|
|
debug-print "`(l", 3/fg, 0/bg
|
|
evaluate-backquote in-left-ah, out-left-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "`r)", 3/fg, 0/bg
|
|
# errors? skip
|
|
{
|
|
var error?/eax: boolean <- has-errors? trace
|
|
compare error?, 0/false
|
|
break-if-=
|
|
trace-higher trace
|
|
return
|
|
}
|
|
var in-right-ah/ecx: (addr handle cell) <- get in, right
|
|
var out-right-ah/edx: (addr handle cell) <- get out, right
|
|
debug-print "`r(", 3/fg, 0/bg
|
|
evaluate-backquote in-right-ah, out-right-ah, env-h, globals, trace, inner-screen-var, inner-keyboard-var, definitions-created, call-number
|
|
debug-print "`r)", 3/fg, 0/bg
|
|
trace-higher trace
|
|
}
|
|
|
|
fn test-evaluate-backquote-list {
|
|
var nil-storage: (handle cell)
|
|
var nil-ah/ecx: (addr handle cell) <- address nil-storage
|
|
allocate-pair nil-ah
|
|
var backquote-storage: (handle cell)
|
|
var backquote-ah/edx: (addr handle cell) <- address backquote-storage
|
|
new-symbol backquote-ah, "`"
|
|
# input is `(a b)
|
|
var a-storage: (handle cell)
|
|
var a-ah/ebx: (addr handle cell) <- address a-storage
|
|
new-symbol a-ah, "a"
|
|
var b-storage: (handle cell)
|
|
var b-ah/esi: (addr handle cell) <- address b-storage
|
|
new-symbol b-ah, "b"
|
|
var tmp-storage: (handle cell)
|
|
var tmp-ah/eax: (addr handle cell) <- address tmp-storage
|
|
new-pair tmp-ah, *b-ah, *nil-ah
|
|
new-pair tmp-ah, *a-ah, *tmp-ah
|
|
new-pair tmp-ah, *backquote-ah, *tmp-ah
|
|
#
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp-ah, *nil-ah, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
# result is (a b)
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
{
|
|
var result-type/eax: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 0/pair, "F - test-evaluate-backquote-list/0"
|
|
}
|
|
{
|
|
var a1-ah/eax: (addr handle cell) <- get result, left
|
|
var a1/eax: (addr cell) <- lookup *a1-ah
|
|
var check1/eax: boolean <- symbol-equal? a1, "a"
|
|
check check1, "F - test-evaluate-backquote-list/1"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get result, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
{
|
|
var a2-ah/eax: (addr handle cell) <- get rest, left
|
|
var a2/eax: (addr cell) <- lookup *a2-ah
|
|
var check2/eax: boolean <- symbol-equal? a2, "b"
|
|
check check2, "F - test-evaluate-backquote-list/2"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get rest, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var check3/eax: boolean <- nil? rest
|
|
check check3, "F - test-evaluate-backquote-list/3"
|
|
}
|
|
|
|
fn test-evaluate-backquote-list-with-unquote {
|
|
var nil-h: (handle cell)
|
|
var nil-ah/eax: (addr handle cell) <- address nil-h
|
|
allocate-pair nil-ah
|
|
var backquote-h: (handle cell)
|
|
var backquote-ah/eax: (addr handle cell) <- address backquote-h
|
|
new-symbol backquote-ah, "`"
|
|
var unquote-h: (handle cell)
|
|
var unquote-ah/eax: (addr handle cell) <- address unquote-h
|
|
new-symbol unquote-ah, ","
|
|
var a-h: (handle cell)
|
|
var a-ah/eax: (addr handle cell) <- address a-h
|
|
new-symbol a-ah, "a"
|
|
var b-h: (handle cell)
|
|
var b-ah/eax: (addr handle cell) <- address b-h
|
|
new-symbol b-ah, "b"
|
|
# env = ((b . 3))
|
|
var val-h: (handle cell)
|
|
var val-ah/eax: (addr handle cell) <- address val-h
|
|
new-integer val-ah, 3
|
|
var env-h: (handle cell)
|
|
var env-ah/eax: (addr handle cell) <- address env-h
|
|
new-pair env-ah, b-h, val-h
|
|
new-pair env-ah, env-h, nil-h
|
|
# input is `(a ,b)
|
|
var tmp-h: (handle cell)
|
|
var tmp-ah/eax: (addr handle cell) <- address tmp-h
|
|
# tmp = cons(unquote, b)
|
|
new-pair tmp-ah, unquote-h, b-h
|
|
# tmp = cons(tmp, nil)
|
|
new-pair tmp-ah, tmp-h, nil-h
|
|
# tmp = cons(a, tmp)
|
|
new-pair tmp-ah, a-h, tmp-h
|
|
# tmp = cons(backquote, tmp)
|
|
new-pair tmp-ah, backquote-h, tmp-h
|
|
#
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp-ah, env-h, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
# result is (a 3)
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
{
|
|
var result-type/eax: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 0/pair, "F - test-evaluate-backquote-list-with-unquote/0"
|
|
}
|
|
{
|
|
var a1-ah/eax: (addr handle cell) <- get result, left
|
|
var a1/eax: (addr cell) <- lookup *a1-ah
|
|
var check1/eax: boolean <- symbol-equal? a1, "a"
|
|
check check1, "F - test-evaluate-backquote-list-with-unquote/1"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get result, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
{
|
|
var a2-ah/eax: (addr handle cell) <- get rest, left
|
|
var a2/eax: (addr cell) <- lookup *a2-ah
|
|
var a2-value-addr/eax: (addr float) <- get a2, number-data
|
|
var a2-value/eax: int <- convert *a2-value-addr
|
|
check-ints-equal a2-value, 3, "F - test-evaluate-backquote-list-with-unquote/2"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get rest, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var check3/eax: boolean <- nil? rest
|
|
check check3, "F - test-evaluate-backquote-list-with-unquote/3"
|
|
}
|
|
|
|
fn test-evaluate-backquote-list-with-unquote-splice {
|
|
var nil-h: (handle cell)
|
|
var nil-ah/eax: (addr handle cell) <- address nil-h
|
|
allocate-pair nil-ah
|
|
var backquote-h: (handle cell)
|
|
var backquote-ah/eax: (addr handle cell) <- address backquote-h
|
|
new-symbol backquote-ah, "`"
|
|
var unquote-splice-h: (handle cell)
|
|
var unquote-splice-ah/eax: (addr handle cell) <- address unquote-splice-h
|
|
new-symbol unquote-splice-ah, ",@"
|
|
var a-h: (handle cell)
|
|
var a-ah/eax: (addr handle cell) <- address a-h
|
|
new-symbol a-ah, "a"
|
|
var b-h: (handle cell)
|
|
var b-ah/eax: (addr handle cell) <- address b-h
|
|
new-symbol b-ah, "b"
|
|
# env = ((b . (a 3)))
|
|
var val-h: (handle cell)
|
|
var val-ah/eax: (addr handle cell) <- address val-h
|
|
new-integer val-ah, 3
|
|
new-pair val-ah, val-h, nil-h
|
|
new-pair val-ah, a-h, val-h
|
|
var env-h: (handle cell)
|
|
var env-ah/eax: (addr handle cell) <- address env-h
|
|
new-pair env-ah, b-h, val-h
|
|
new-pair env-ah, env-h, nil-h
|
|
# input is `(a ,@b b)
|
|
var tmp-h: (handle cell)
|
|
var tmp-ah/eax: (addr handle cell) <- address tmp-h
|
|
# tmp = cons(b, nil)
|
|
new-pair tmp-ah, b-h, nil-h
|
|
# tmp2 = cons(unquote-splice, b)
|
|
var tmp2-h: (handle cell)
|
|
var tmp2-ah/ecx: (addr handle cell) <- address tmp2-h
|
|
new-pair tmp2-ah, unquote-splice-h, b-h
|
|
# tmp = cons(tmp2, tmp)
|
|
new-pair tmp-ah, tmp2-h, tmp-h
|
|
# tmp = cons(a, tmp)
|
|
new-pair tmp-ah, a-h, tmp-h
|
|
# tmp = cons(backquote, tmp)
|
|
new-pair tmp-ah, backquote-h, tmp-h
|
|
#? dump-cell-from-cursor-over-full-screen tmp-ah
|
|
#
|
|
var trace-storage: trace
|
|
var trace/edi: (addr trace) <- address trace-storage
|
|
initialize-trace trace, 1/only-errors, 0x10/capacity, 0/visible
|
|
evaluate tmp-ah, tmp-ah, env-h, 0/no-globals, trace, 0/no-screen, 0/no-keyboard, 0/definitions-created, 0/call-number
|
|
# result is (a a 3 b)
|
|
#? dump-cell-from-cursor-over-full-screen tmp-ah
|
|
var result/eax: (addr cell) <- lookup *tmp-ah
|
|
{
|
|
var result-type/eax: (addr int) <- get result, type
|
|
check-ints-equal *result-type, 0/pair, "F - test-evaluate-backquote-list-with-unquote-splice/0"
|
|
}
|
|
{
|
|
var a1-ah/eax: (addr handle cell) <- get result, left
|
|
var a1/eax: (addr cell) <- lookup *a1-ah
|
|
var check1/eax: boolean <- symbol-equal? a1, "a"
|
|
check check1, "F - test-evaluate-backquote-list-with-unquote-splice/1"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get result, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
{
|
|
var a2-ah/eax: (addr handle cell) <- get rest, left
|
|
var a2/eax: (addr cell) <- lookup *a2-ah
|
|
var check2/eax: boolean <- symbol-equal? a2, "a"
|
|
check check2, "F - test-evaluate-backquote-list-with-unquote-splice/2"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get rest, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
{
|
|
var a3-ah/eax: (addr handle cell) <- get rest, left
|
|
var a3/eax: (addr cell) <- lookup *a3-ah
|
|
var a3-value-addr/eax: (addr float) <- get a3, number-data
|
|
var a3-value/eax: int <- convert *a3-value-addr
|
|
check-ints-equal a3-value, 3, "F - test-evaluate-backquote-list-with-unquote-splice/3"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get rest, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
{
|
|
var a4-ah/eax: (addr handle cell) <- get rest, left
|
|
var a4/eax: (addr cell) <- lookup *a4-ah
|
|
var check4/eax: boolean <- symbol-equal? a4, "b"
|
|
check check4, "F - test-evaluate-backquote-list-with-unquote-splice/4"
|
|
}
|
|
var rest-ah/eax: (addr handle cell) <- get rest, right
|
|
var rest/eax: (addr cell) <- lookup *rest-ah
|
|
var check5/eax: boolean <- nil? rest
|
|
check check5, "F - test-evaluate-backquote-list-with-unquote-splice/5"
|
|
}
|