A2JAXDJWT2FAKADYOY6QOQ7LQRMTTCDIOYT7STSESVHLZQEQJBMAC
# the first result 3 is the return value of setq; the second is the
# result of evaluating symbol three
lisp_eval_should_be '(setq three 3)
three' \
'3
3' \
'setq global'
lisp_eval_should_be '(setq fst (lambda (a b) a))
(fst 9 8)' \
'(*lambda (a b) a)
9' \
'setq global tailable lambda'
lisp_eval_should_be '(quote unimplemented)' 'eh' 'nconc'
# faster than lib-eval: about 12ms per startup (n=1000); but gnarly
# and write-only, and slower than using an image.awk dumped by
# dump.awk (~8ms per startup). (with no lib at all, it takes about 3ms
# to start up; speed figures have this subtracted out.)
# an elisp function to turn lists of symbols written in LISP into
# mazes of calls to _cons and _symbol and _nil. quite unprepared for
# numbers or punctuation.
# (defun awkify ()
# (interactive)
# ;; ind: level of lisp parentheses; 0 is toplevel. argno: stack of
# ;; numbers of _cons arg, 1-based; one entry for each pair of awk
# ;; parentheses we are in.
# (let ((ind 0) (argno '(1)))
# (cl-flet
# ((nlc ()
# (when (not (= (car argno) 1))
# (insert ",")
# (if (looking-at " ")
# (progn (newline-and-indent)
# (insert " ")
# (backward-char))
# (newline-and-indent))))
# (ec ()
# (while (and (not (null argno))
# (>= (car argno) 3))
# (insert ")")
# (pop argno)))
# (next-arg () (cl-incf (car argno))))
# (save-mark-and-excursion
# (setf (car argno) 1) ;; ???? why is it 3 sometimes
# (while (not (looking-at "\n"))
# (cond ((looking-at "(")
# (delete-char 1)
# (nlc) (next-arg)
# (insert "_cons(")
# (cl-incf ind)
# (push 1 argno))
# ((looking-at " ")
# (if (> ind 0)
# (progn
# (delete-char 1)
# (nlc) (next-arg)
# (insert "_cons(")
# (push 1 argno))
# (forward-char)))
# ((looking-at "[a-z]")
# (kill-word 1)
# (nlc) (next-arg)
# (insert "_symbol(\"")
# (yank)
# (insert "\")"))
# ((looking-at ")")
# (delete-char 1)
# (nlc) (next-arg)
# (insert "_nil()")
# (cl-decf ind)
# (ec))
# ((looking-at "\\\\")
# (delete-char 1))))))))
BEGIN {
x = _cons(_symbol("quote"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("quote"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("atom"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("atom"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("eq"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("eq"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("car"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("car"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cdr"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cdr"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cons"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("cons"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cond"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cond"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("list"),
_cons(_cons(_symbol("*lambda"),
_cons(_symbol("a"),
_cons(_symbol("a"),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("not"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("not"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("null"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("null"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("equal"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("equal"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("caar"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("caar"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cadr"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cadr"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("memq"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("memq"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("member"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("member"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("assoc"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("assoc"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("setq"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("setq"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("caaar"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("caaar"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("caadr"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("caadr"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cadar"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cadar"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("caddr"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("caddr"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cdaar"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cdaar"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cdadr"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cdadr"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cddar"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cddar"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("cdddr"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("cdddr"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("rplaca"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("rplaca"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("rplacd"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("rplacd"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("nreverse"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_nil()),
_cons(_cons(_symbol("nreverse"),
_cons(_symbol("a"),
_nil())),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("nconc"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("nconc"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("append"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("b"),
_nil())),
_cons(_cons(_symbol("append"),
_cons(_symbol("a"),
_cons(_symbol("b"),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
x = _cons(_symbol("mapcar"),
_cons(_cons(_symbol("*lambda"),
_cons(_cons(_symbol("f"),
_cons(_symbol("a"),
_nil())),
_cons(_cons(_symbol("label"),
_cons(_cons(_cons(_symbol("map"),
_cons(_cons(_symbol("lambda"),
_cons(_cons(_symbol("a"),
_cons(_symbol("r"),
_nil())),
_cons(_cons(_symbol("cond"),
_cons(_cons(_cons(_symbol("eq"),
_cons(_symbol("a"),
_cons(_symbol("nil"),
_nil()))),
_cons(_cons(_symbol("nreverse"),
_cons(_symbol("r"),
_nil())),
_nil())),
_cons(_cons(_true(),
_cons(_cons(_symbol("map"),
_cons(_cons(_symbol("cdr"),
_cons(_symbol("a"),
_nil())),
_cons(_cons(_symbol("cons"),
_cons(_cons(_symbol("f"),
_cons(_cons(_symbol("car"),
_cons(_symbol("a"),
_nil())),
_nil())),
_cons(_symbol("r"),
_nil()))),
_nil()))),
_nil())),
_nil()))),
_nil()))),
_nil())),
_nil()),
_cons(_cons(_symbol("map"),
_cons(_symbol("a"),
_cons(_symbol("nil"),
_nil()))),
_nil()))),
_nil()))),
_nil()))
_GLOBALS = _cons(x, _GLOBALS)
# search all those bindings in the order we wrote them: most
# commonly used first
_GLOBALS = _nreverse(_GLOBALS)
}
# concise but quite slow: about 73ms at each startup (n=1000)
BEGIN {
_eval(read_str("\
(progn \
(setq quote (lambda (a) (quote a))) \
(setq atom (lambda (a) (atom a))) \
(setq eq (lambda (a b) (eq a b))) \
(setq car (lambda (a) (car a))) \
(setq cdr (lambda (a) (cdr a))) \
(setq cons (lambda (a b) (cons a b))) \
(setq list (lambda a a)) \
(setq not (lambda (a) (not a))) \
(setq null (lambda (a) (null a))) \
(setq equal (lambda (a b) (equal a b))) \
(setq caar (lambda (a) (caar a))) \
(setq cadr (lambda (a) (cadr a))) \
(setq memq (lambda (a b) (memq a b))) \
(setq member (lambda (a b) (member a b))) \
(setq assoc (lambda (a b) (assoc a b))) \
(setq caaar (lambda (a) (caaar a))) \
(setq caadr (lambda (a) (caadr a))) \
(setq cadar (lambda (a) (cadar a))) \
(setq caddr (lambda (a) (caddr a))) \
(setq cdaar (lambda (a) (cdaar a))) \
(setq cdadr (lambda (a) (cdadr a))) \
(setq cddar (lambda (a) (cddar a))) \
(setq cdddr (lambda (a) (cdddr a))) \
(setq rplaca (lambda (a b) (rplaca a b))) \
(setq rplacd (lambda (a b) (rplacd a b))) \
(setq nreverse (lambda (a) (nreverse a))) \
(setq nconc (lambda (a b) (nconc a b))) \
(setq append (lambda (a b) (append a b))) \
(setq mapcar \
(lambda (f a) \
(label \
((map (lambda (a r) \
(cond ((eq a nil) (nreverse r)) \
(true (map (cdr a) \
(cons (f (car a)) \
r))))))) \
(map a nil)))) \
) \
"))
}
@include gc.awk
@include dump.awk
#@include image.awk
#@include lib.awk
function _gc_mark_list(lis, car, tv, t, v, i) {
logg_dbg("_gc_mark_list", "cons number " lis)
i = 0
while(!_is_null(lis)) {
car = _car(lis)
lis = _cdr(lis)
if(_falsy(car)) continue
t = _TYPE[car]
_MARK[car] = 1
if(t == "(") {
i += _gc_mark_list(car)
}
i += 1
}
return i
}
function _gc(envs, i, t, name, ngcd, nmarks) {
# y'know... the envs given had better add up to everything, not
# just globals and not just one stack of envs. hmm
delete _MARK
ngcd = 0
logg_dbg("_gc", "marking")
nmarks = _gc_mark_list(envs)
logg_dbg("_gc", "sweeping")
for(i in _TYPE) {
if(!(i in _MARK)) {
t = _TYPE[i]
if(t == "s") {
delete _STRING[i]
} else if(t == "(") {
delete _CAR[i]
delete _CDR[i]
} else if(t == "'") {
name = _SYM_NUMBERS[i]
delete _SYM_NUMBERS[i]
delete _SYM_NAMES[name]
} else { #
}
delete _TYPE[i]
ngcd += 1
}
}
return _cons(_cons(_symbol("marks"),
_cons(_number(nmarks), _nil())),
_cons(_cons(_symbol("marked"),
_cons(_number(length(_MARK)), _nil())),
_cons(_cons(_symbol("collected"),
_cons(_number(ngcd), _nil())),
_nil())))
}
for(here=alis; !_is_null(here); here=rest_pairs) {
this_pair = _car(here)
rest_pairs = _cdr(here)
logg_dbg("_assoc", "is it " _repr(this_pair) "?")
name = _car(this_pair)
value = _cadr(this_pair)
logg_dbg("_assoc", "name is " name "; value is " value)
if(_truthy(_eq(name, sym))) {
logg_dbg("_assoc", "found. value is " value " containing " _repr(value))
its = value
break
} # otherwise we loop
} # if we have not found something, its still _nil()
return its
# _car(alis) is the first pair; _caar(alis) is the name
for(; !_is_null(alis) && _falsy(_eq(_caar(alis), sym));
alis=_cdr(alis)) {
logg_dbg("_assoc", "is it " _repr(_car(alis)) "?")
}
if(_is_null(alis)) # we did not find sym.
return _nil()
else {
logg_dbg("_assoc", "found: " _car(alis) " containing " _repr(_car(alis)))
return _car(alis)
}
}
function _lookup(sym, locals, binding) {
binding = _assoc(sym, locals)
if(_is_null(binding)) # not in locals
binding = _assoc(sym, _GLOBALS)
if(_is_null(binding)) # also not in globals
return _nil()
logg_dbg("_lookup", "found binding: " _repr(binding) "; value is " _cadr(binding) " working out to " _repr(_cadr(binding)))
# if here, we found a binding. return the value
return _cadr(binding)
function _evcon(con, env) {
logg_dbg("_evcon", "con is " _repr(con))
if(_is_null(con)) {
return con
} else if(_truthy(_eval(_caar(con), env))) {
return _eval(_cadar(con), env)
# do implicit progn's
function _evprog(forms, env, outer_env) {
logg_dbg("_evprog", "forms are " forms " containing " _repr(forms))
if(_is_null(forms))
return _nil()
# iterativified. see [LFN] p. 150, 151
while(!_is_null(_cdr(forms))) {
logg_dbg("_evprog", "non-tail evaluating " _repr(_car(forms)))
_eval3(_car(forms), env, env) # and throw away return value
forms = _cdr(forms)
}
# now _car(forms) should be the last form. evaluate and return
# result. "By replacing the regular environmnt by the outer one,
# the inner binding is removed..."
logg_dbg("_evprog", "tail-eval-ing " _car(forms) " which contains "_repr(_car(forms)))
return _eval3(_car(forms), env, outer_env)
}
function _evcon(clauses, env, outer_env, tmp, actions) {
logg_dbg("_evcon", "clauses are " _repr(clauses))
tmp = _nil()
# iterativized. if clauses is already null, the body won't happen.
while(!_is_null(clauses) && _falsy(tmp)) {
tmp = _eval3(_caar(clauses), env, env) # the condition
logg_dbg("_evcon", "thinking about clause " _repr(_car(clauses)) ". its condition works out to " _repr(tmp))
if(_falsy(tmp)) {
logg_dbg("_evcon", "advancing")
clauses=_cdr(clauses)
}
}
# either we found a true one or we ran out of clauses
if(_truthy(tmp)) {
actions = _cdar(clauses)
logg_dbg("_evcon", _repr(tmp) " was truthy! We shall " _repr(actions))
if(_is_null(actions)) # predicate-only clause
return tmp
else
return _evprog(actions, env, outer_env)
} else {
# ran out of clauses, or had none
return _nil()
}
}
function _bind(vars, args, env, outer_env, arg_value, lexpr_list) {
if(_is_null(vars)) {
logg_dbg("_bind", "no more vars")
return outer_env
} else if(_truthy(_atom(vars))) {
# LEXPR: bind vars to a list of all the args
logg_dbg("_bind lexpr", _repr(vars) " gets all the args")
lexpr_list = _nil()
for(; !_is_null(args); args=_cdr(args)) {
arg_value = _eval3(_car(args), env, env)
lexpr_list = _cons(arg_value, lexpr_list)
}
lexpr_list = _nreverse(lexpr_list)
return _cons(_cons(vars, _cons(lexpr_list, _nil())),
outer_env)
return _evcon(_cdr(con), env)
logg_dbg("_bind 1by1",
"now, what to bind to " _repr(_car(vars)) "?")
arg_value = _cons(_car(vars),
_cons(_eval3(_car(args), env, env),
_nil()))
logg_dbg("_bind", "consing " _repr(arg_value) " onto ... ")
return _cons(arg_value,
_bind(_cdr(vars), _cdr(args), env, outer_env))
function _bind(vars, args, env, s, tv, vcar, vcdr, acar, acdr) {
while(!_is_null(vars)) {
vcar = _car(vars)
vcdr = _cdr(vars)
acar = _car(args)
acdr = _cdr(args)
logg_dbg("_bind", "this var is " vcar " which is " _repr(vcar))
logg_dbg("_bind", "this arg is " acar " which is " _repr(acar))
logg_dbg("_bind", "env before: " env)
env = _cons(_cons(vcar, _cons(_eval(acar, env),_nil())), env)
logg_dbg("_bind", "env after: " env)
vars = vcdr
args = acdr
function _bindseq(bindings, env, b, v) {
# [LFN], p. 154. bindings looks like ((name1 expr1) (name2
# expr2)...). its caar is name1; cadar is expr1. Iterativized!
for(; !_is_null(bindings); bindings=_cdr(bindings)) {
v = _eval3(_cadar(bindings), env, env)
b = _cons(_caar(bindings), _cons(v, _nil()))
env = _cons(b, env)
function _modify(var, val, env, binding) {
binding = _assoc(var, env)
logg_dbg("_modify", "original binding " _repr(binding))
if(!_is_null(binding)) {
_set_car(_cdr(binding), val)
logg_dbg("_modify", "modified to " _repr(binding))
} else { # global
binding = _assoc(var, _GLOBALS)
logg_dbg("_modify", "original global binding " _repr(binding))
if(!_is_null(binding)) {
_set_car(_cdr(binding), val)
logg_dbg("_modify", "modified to " _repr(binding))
} else { # make a new global
logg_dbg("_modify", "adding new global to " _repr(_GLOBALS))
_GLOBALS = _nconc(_cons(_cons(var, _cons(val, _nil())),
_nil()),
_GLOBALS)
logg_dbg("_modify", "now the globals are " _repr(_GLOBALS))
}
}
return val
}
logg_dbg("_eval","form is " form " containing " _repr(form) "; env is " env " containing " _repr(env))
logg_dbg("_eval3","form is " form " containing " _repr(form) "; env is " env " containing " _repr(env) "; outer_env is " outer_env " containing " _repr(outer_env))
logg_dbg("_eval label", "env before: " env "; appending " _cadr(cell))
env = _append(_cadr(form), env)
logg_dbg("_eval label", "env after: " env " containing " _repr(env))
return _eval(_caddr(form), env)
} else if(car == _symbol("lambda")) return form
else return _eval(_cons(_eval(car, env), cdr),env)
logg_dbg("_eval3 label", "env before: " env "; appending " _cadr(cell))
inner_env = _bindseq(_cadr(form), env)
logg_dbg("_eval3 label", "inner_env: " inner_env " containing " _repr(inner_env))
return _evprog(_cddr(form), inner_env, inner_env)
} else if(car == _symbol("lambda")) # tailable. p156
return _cons(_symbol("*lambda"), _cdr(form))
else if(car == _symbol("not"))
return _falsy(_eval3(_cadr(form), env, env))
else if(car == _symbol("null"))
return _is_null(_eval3(_cadr(form), env, env))
else if(car == _symbol("equal"))
return _equal(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("caar"))
return _caar(_eval3(_cadr(form), env, env))
else if(car == _symbol("cadr"))
return _cadr(_eval3(_cadr(form), env, env))
else if(car == _symbol("memq"))
return _memq(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("member"))
return _member(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("assoc"))
return _assoc(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("setq"))
return _modify(_cadr(form),
_eval3(_caddr(form), env, env),
env)
else if(car == _symbol("caaar"))
return _caaar(_eval3(_cadr(form), env, env))
else if(car == _symbol("caadr"))
return _caadr(_eval3(_cadr(form), env, env))
else if(car == _symbol("cadar"))
return _cadar(_eval3(_cadr(form), env, env))
else if(car == _symbol("caddr"))
return _caddr(_eval3(_cadr(form), env, env))
else if(car == _symbol("cdaar"))
return _cdaar(_eval3(_cadr(form), env, env))
else if(car == _symbol("cdadr"))
return _cdadr(_eval3(_cadr(form), env, env))
else if(car == _symbol("cddar"))
return _cddar(_eval3(_cadr(form), env, env))
else if(car == _symbol("cdddr"))
return _cdddr(_eval3(_cadr(form), env, env))
else if(car == _symbol("rplaca"))
return _set_car(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("rplacd"))
return _set_cdr(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("nreverse"))
return _nreverse(_eval3(_cadr(form), env, env))
else if(car == _symbol("nconc"))
return _nconc(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("append"))
return _append(_eval3(_cadr(form), env, env),
_eval3(_caddr(form), env, env))
else if(car == _symbol("progn"))
return _evprog(_cdr(form), env, env)
else if(car == _symbol("+")) {
a = _eval3(_cadr(form), env, env)
b = _eval3(_caddr(form), env, env)
logg_dbg("_eval3 +", "adding " a " and " b)
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return ("# " a+b)
}
}
# if either a or b was not a number, we're here
logg_err("_eval3 +", "non-numeric operand")
return _nil()
} else if(car == _symbol("gc"))
return _gc(_cons(env, _cons(outer_env, _cons(_GLOBALS, _nil()))))
else if(car == _symbol("dump"))
return _dump(_STRING[_cadr(form)])
else {
x = _eval3(car, env, env)
if(_is_null(x)) {
logg_err("_eval3 funcall", "operator " _repr(car) " evaluates to nil; is it defined?")
return _nil()
} else
return _eval3(_cons(x, _cdr(form)), env, env)
}
if(_car(car) == _symbol("lambda")) {
if(_car(car) == _symbol("*lambda")) {
# tail-callable (*lambda args form form...)
# _cadr(car) is args, _cddr(args) is the forms
logg_dbg("_eval3 *lambda",
"args: " _repr(_cadr(car)) \
"; body: " _repr(_cddr(car)))
return _evprog(_cddr(car),
_bind(_cadr(car), cdr,
env, outer_env), outer_env)
} else if(_car(car) == _symbol("lambda")) {
# un-tail-callable
if(_atom(_cadr(car)) == _true()) {
# the something is an atom: this is a LEXPR
logg_dbg("_eval lambda lexpr", "body is " _caddr(car) " containing " _repr(_caddr(car)))
logg_dbg("_eval lambda lexpr", "all arguments " _repr(cdr) " are going into the list " _cadr(car))
return _eval(_caddr(car), _cons(_cons(_cadr(car), _cons(cdr, _nil())), env))
} else {
logg_dbg("_eval lambda args", "body is " _caddr(car) " containing " _repr(_caddr(car)))
logg_dbg("_eval lambda args", "variable list is " _cadr(car) " containing " _repr(_cadr(car)))
logg_dbg("_eval lambda args", "argument list is " cdr " which is " _repr(cdr))
return _eval(_caddr(car), _bind(_cadr(car), cdr, env))
}
logg_dbg("_eval3 lambda",
"args: " _repr(_cadr(car)) \
"; body: " _repr(_cddr(car)))
inner_env = _bind(_cadr(car), cdr, env, env)
logg_dbg("_eval3 lambda",
"inner env: " _repr(inner_env) \
"; evprogging body in that env")
return _evprog(_cddr(car), inner_env, inner_env)
function _eval(form) {
return _eval3(form, _nil(), _nil())
}
function awkescape(string) {
gsub("\\", "\\\\", string)
gsub("\"", "\\\"", string)
gsub("\n", "\\\n", string)
}
function awkrepr(v) {
if(v == _nil())
return "_nil()"
else if(v == _true())
return "_true()"
else if(v == _false())
return "_false()"
else if(v+0 == v)
return v
else {
awkescape(v)
return "\"" v "\""
}
}
function _dump(filename, i, t, v, s, line) {
print "BEGIN {" >filename
print " N = " N " # next cell number" >>filename
for(i in _TYPE) {
t = _TYPE[i]
line = " _TYPE[" i "] = \"" t "\"; "
if(t == "'") {
v = _SYM_NUMBERS[i]
awkescape(v)
line = line \
"_SYM_NUMBERS[" i "] = \"" v "\"; " \
"_SYM_NAMES[\"" v "\"] = " i "; "
} else if(t == "s") {
v = _STRING[i]
awkescape(v)
line = line "_STRING[" i "] = \"" v "\"; "
} else if(t == "(") {
line = line \
"_CAR[" i "] = " awkrepr(_CAR[i]) "; " \
"_CDR[" i "] = " awkrepr(_CDR[i]) "; "
}
print line >>filename
}
print " _GLOBALS = " _GLOBALS " # global environment " >>filename
print "}" >>filename
close(filename)
return _true()
}
# "NCONC finds the end of A and then changes its cdr part to B." -
# [LFN], p. 47.
function _nconc(a, b, a_end) {
# _atom(_nil()) is _truthy
if(_truthy(_atom(a)))
return b
for(a_end=a; _falsy(_atom(_cdr(a_end))); a_end=_cdr(a_end));
# a_end now is a cons with an atom as its cdr, such as maybe nil
_set_cdr(a_end, b)
return a
}
}
function _equal(a, b) {
# [LFN], p. 48
if(_truthy(_eq(a, b)))
return _true()
else if(_truthy(_atom(a)))
# if they were both atoms above, they weren't eq
return _false()
else if(_truthy(_atom(b)))
# a wasn't an atom above, but b is.
return _false()
# now they must both be lists; they are equal if all members are
# equal. iterativized. if they have different lengths,
ans = _false()
for(; !_is_null(a) && !_is_null(b) &&
(ans = _truthy(_equal(_car(a), _car(b))));
a = _cdr(a) && b = _cdr(b));
return ans
# [LFN], p. 49, iterativized. this returns a cdr of lis or nil.
function _memq(thing, lis) {
for(; !_is_null(lis) && _falsy(_eq(thing, _car(lis)));
lis=_cdr(lis)) ;
# if we got to the end without finding thing, lis is now nil
return lis
}
# same as memq but with equal instead of eq
function _member(thing, lis) {
for(; !_is_null(lis) && _falsy(_equal(thing, _car(lis)));
lis=_cdr(lis)) ;
return lis
}