# SPDX-License-Identifier: BSD-2-Clause
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 _falsy(thing) {
# hmm, awk can't distinguish "0" and 0 i think
return ((thing == 0) || _is_null(thing) || (thing == "f"));
}
function _truthy(thing) {
return !_falsy(thing)
}
# do implicit progn's
function _evprog(forms, env, outer_env, d) {
# logg_dbg("_evprog", "forms are " forms " containing " _repr(forms), d)
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)), d)
_eval3(_car(forms), env, env, d) # 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)), d)
return _eval3(_car(forms), env, outer_env, d)
}
function _evcon(clauses, env, outer_env, d, tmp, actions) {
# logg_dbg("_evcon", "clauses are " _repr(clauses), d)
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, d+1) # the condition
# logg_dbg("_evcon", "thinking about clause " _repr(_car(clauses)) ". its condition works out to " _repr(tmp), d)
if(_falsy(tmp)) {
# logg_dbg("_evcon", "advancing", d)
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), d)
if(_is_null(actions)) # predicate-only clause
return tmp
else
return _evprog(actions, env, outer_env, d+1)
} else {
# ran out of clauses, or had none
return _nil()
}
}
function _bind(vars, args, env, outer_env, d, arg_value, lexpr_list) {
if(_is_null(vars)) {
# logg_dbg("_bind", "no more vars", d)
return outer_env
} else if(_atom_awk(vars)) {
# LEXPR: bind vars to a list of all the args
# logg_dbg("_bind lexpr", _repr(vars) " gets all the args", d)
lexpr_list = _nil()
for(; !_is_null(args); args=_cdr(args)) {
arg_value = _eval3(_car(args), env, env, d+1)
lexpr_list = _cons(arg_value, lexpr_list)
}
lexpr_list = _nreverse(lexpr_list)
return _cons(_cons(vars, _cons(lexpr_list, _nil())),
outer_env)
} else {
# logg_dbg("_bind 1by1",
# "now, what to bind to " _repr(_car(vars)) "?", d)
arg_value = _cons(_car(vars),
_cons(_eval3(_car(args), env, env, d+1),
_nil()))
# logg_dbg("_bind", "consing " _repr(arg_value) " onto ... ", d)
return _cons(arg_value,
_bind(_cdr(vars), _cdr(args), env, outer_env, d))
}
}
function _bindseq(bindings, env, d, 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, d+1)
b = _cons(_caar(bindings), _cons(v, _nil()))
env = _cons(b, env)
}
return env
}
function _modify(var, val, env, d, binding) {
binding = _assoc(var, env)
# logg_dbg("_modify", "original binding " _repr(binding), d)
if(!_is_null(binding)) {
_set_car(_cdr(binding), val)
# logg_dbg("_modify", "modified to " _repr(binding), d)
} else { # global
binding = _assoc(var, _GLOBALS)
# logg_dbg("_modify", "original global binding " _repr(binding), d)
if(!_is_null(binding)) {
_set_car(_cdr(binding), val)
# logg_dbg("_modify", "modified to " _repr(binding), d)
} else { # make a new global
# logg_dbg("_modify", "adding new global to " _repr(_GLOBALS), d)
_GLOBALS = _nconc(_cons(_cons(var, _cons(val, _nil())),
_nil()),
_GLOBALS)
# logg_dbg("_modify", "now the globals are " _repr(_GLOBALS), d)
}
}
return val
}
function _append(la, lb, tv, t, v, as, acar, acdr) {
# i have iterativized many algorithms but not this one. by
# recursing, we effectively store pointers to traverse `la`
# backward, using the call stack.
# logg_dbg("_append", "la " la "; lb " lb)
if(_is_null(la)) return lb
else {
return _cons(_car(la), _append(_cdr(la), lb))
}
}
function _list_length(l, x) {
for(x=0; !_is_null(l); x++) {
l = _cdr(l)
}
return _number(x)
}
function _expand(form, depth, car, mpair, app, acc) {
# logg_dbg("_expand", "expanding " form " -> "_repr(form), depth)
if(_atom_awk(form)) {
# "atoms cannot be macro applications," LFN p.168
# logg_dbg("_expand", _repr(form) " is an atom", depth)
return form
} else {
car = _car(form)
if(car == _symbol("quote")) {
# don't expand macros inside quote calls
# logg_dbg("_expand quoted", _repr(form), depth)
return form
} else {
mpair = _assoc(car, _MACROS)
if(_is_null(mpair)) {
# logg_dbg("_expand not macro", _repr(form), depth)
# expand everything in form. don't worry, form is a
# list (see first case).
for(acc=_nil(); !_is_null(form); form=_cdr(form)) {
acc = _cons(_expand(_car(form), depth+1), acc)
}
acc = _nreverse(acc)
# logg_dbg("_expand not macro", "expanded: " _repr(acc), depth)
return acc
} else {
# a macro call! _cadr(mpair) is the expression to
# apply, and we want to apply it to the quoted rest of
# the form.
#
# logg_dbg("_expand macro call", "mpair is " _repr(mpair), depth+1)
acc = _cons(_cadr(mpair),
_cons(_cons(_symbol("quote"),
_cons(_cdr(form),
_nil())),
_nil()),
_nil())
# logg_dbg("_expand macro call", "_evaling " _repr(acc), depth)
return _expand(_eval(acc, depth+1), depth+1)
}
}
}
}
function _expand1(form, depth, car, mpair, app, acc) {
if(_atom_awk(form)) {
return form
} else {
car = _car(form)
if(car == _symbol("quote")) {
return form
} else {
mpair = _assoc(car, _MACROS)
if(_is_null(mpair)) {
logg_dbg("_expand1 not macro", _repr(_car(form)), depth)
# unlike expand, don't recurse in to find more macros
return form
} else {
logg_dbg("_expand1 macro call",
"found macro " _repr(_car(mpair)),
depth+1)
acc = _cons(_cadr(mpair),
_cons(_cons(_cons(_symbol("quote"),
_cons(_symbol("quote"),
_nil())),
_cons(_cdr(form),
_nil())),
_nil()),
_nil())
logg_dbg("_expand1 expanded", _repr(acc), depth)
acc = _eval3(acc, _nil(), _nil(), depth+1)
logg_dbg("_expand1 evalled once", _repr(acc), depth)
return acc
}
}
}
}
function _builtin_mischaracterization(where, what) {
logg_err(where, "builtin mischaracterization for symbol " what)
exit(55)
}
function _eval3_other_lispy(form, env, d, car, a) {
car = _car(form)
if(car == _symbol("memq"))
return _memq(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("member"))
return _member(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("assoc"))
return _assoc(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("setq"))
return _modify(_cadr(form),
_eval3(_caddr(form), env, env, d+1),
env)
else if(car == _symbol("caaar"))
return _caaar(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("caadr"))
return _caadr(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cadar"))
return _cadar(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("caddr"))
return _caddr(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cdaar"))
return _cdaar(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cdadr"))
return _cdadr(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cddar"))
return _cddar(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cdddr"))
return _cdddr(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("rplaca"))
return _set_car(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("rplacd"))
return _set_cdr(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("nreverse"))
return _nreverse(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("nconc"))
return _nconc(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("append"))
return _append(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("list-length"))
return _list_length(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("print")) {
_print(_eval3(_cadr(form), env, env, d+1))
return _nil()
} else if(car == _symbol("progn"))
return _evprog(_cdr(form), env, env, d+1)
else if(car == _symbol("macro"))
# don't eval. hope the name is a symbol!
return _addmacro(_cadr(form), _caddr(form))
else if(car == _symbol("expand1"))
return _expand1(_eval3(_cadr(form), env, env, d+1),
d+1)
else if(car == _symbol("eval")) {
# logg_dbg("_eval3 eval", "expression is " _cadr(form) " -> " _repr(_cadr(form)), d)
a = _eval3(_cadr(form), env, env, d+1)
# logg_dbg("_eval3 eval", "value is " a " -> " _repr(a), d)
a = _eval3(a, env, env, d+1)
# logg_dbg("_eval3 eval", "and that works out to " a " -> " _repr(a), d)
return a
} else {
_builtin_mischaracterization("_eval3_other_lispy", car)
}
}
function _eval3(form, env, outer_env, d, tv, t, v, n, cell, car, cdr, x, inner_env, a, b) {
# logg_dbg("_eval3","form is " form " containing " _repr(form) "; env is " env " containing " _repr(env) "; outer_env is " outer_env " containing " _repr(outer_env), d)
if(_is_literal(form)) {
# true, false, nil, and literal numbers evaluate to themselves
return form
} else {
# it's a string, symbol or cons.
t = _TYPE[form]
if(t == "(") {
car = _car(form)
# logg_dbg("_eval3", "car is " car " containing " _repr(car), d)
if(_TYPE[car] == "'") { # (symbol-in-operator-position ...
if(car == _symbol("quote")) return _cadr(form)
else if(car == _symbol("atom"))
return _atom_lisp(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("eq"))
return _eq_lisp(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("car"))
return _car(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cdr"))
return _cdr(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cons"))
return _cons(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("cond"))
return _evcon(_cdr(form), env, env, d+1)
else if(car == _symbol("label")) {
# logg_dbg("_eval3 label", "env before: " env "; appending " _cadr(cell), d)
inner_env = _bindseq(_cadr(form), env, d+1)
# logg_dbg("_eval3 label", "inner_env: " inner_env " containing " _repr(inner_env), d)
return _evprog(_cddr(form), inner_env, inner_env, d+1)
} 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, d+1))
else if(car == _symbol("null"))
return _is_null(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("equal"))
return _equal_lisp(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("caar"))
return _caar(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("cadr"))
return _cadr(_eval3(_cadr(form), env, env, d+1))
# less-often-used special forms shipped off to
# subfunctions.
else if(car < _symbol("%last-special-form%")) {
if(car < _symbol("%other-lispy%"))
return _eval3_other_lispy(form, env, d)
else if(car < _symbol("%math%"))
return _eval3_math(form, env, d)
else return _eval3_other_special_forms(form, env, d)
} else {
x = _eval3(car, env, env, d+1)
if(_is_null(x)) {
logg_err("_eval3 funcall", "operator " _repr(car) " evaluates to nil; is it defined?", d)
return _nil()
} else {
return _eval3(_cons(x, _cdr(form)), env, env, d+1)
}
}
} else if(_TYPE[car] == "(") {
cdr = _cdr(form)
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)), d)
return _evprog(_cddr(car),
_bind(_cadr(car), cdr,
env, outer_env, d), outer_env, d)
} else if(_car(car) == _symbol("lambda")) {
# un-tail-callable
# form is like ( (lambda something body) arg1 arg2 )
# car is the whole lambda form; cdr is the args
# logg_dbg("_eval3 lambda",
# "args: " _repr(_cadr(car)) \
# "; body: " _repr(_cddr(car)), d)
inner_env = _bind(_cadr(car), cdr, env, env, d+1)
# logg_dbg("_eval3 lambda",
# "inner env: " _repr(inner_env) \
# "; evprogging body in that env", d)
return _evprog(_cddr(car), inner_env, inner_env, d+1)
} else {
# logg_dbg("_eval3", "evaluating list in function position: " _repr(car), d)
return _eval3(_cons(_eval3(car, env, d+1), cdr), env, env, d+1)
}
} else {
logg_err("_eval3", "unexpected thing in function position: " _repr(car), d)
return _nil()
}
} else if(t == "'") {
# logg_dbg("_eval3", "evaluating symbol " _SYM_NUMBERS[form], d)
return _lookup(form, env, outer_env)
} else if(t == "s") {
return form
} else {
logg_err("_eval3", "how do i eval " t " ?", d)
exit 1
}
}
}
function _eval(form, depth) {
return _eval3(_expand(form, depth+1), _nil(), _nil(), depth)
}