JDZASPALXSFZOL3MXCKBPX74CUD3W743ZJ6W2422FIJ7NJOD67ZAC
NBEO3TPNOUG7MRFYRSDDFB5TQKTEDL6GHHFQVOB5MXVPIBKFNZKAC
RCUBQKTURAMSYYFNNI4JPXDBZDGF6ZGWVGQYTDEKA6EOMG4QUZOAC
UW27LKXM2BJ77FQLTY4WPKDSSWI2RFNFRJ7CB4U3TS7KYVIV72LQC
5OVGZFP3HMFSJ7EETA6SPCIVV4PENITMC2ZK3EMPBFCZGZYWF7XQC
A2JAXDJWT2FAKADYOY6QOQ7LQRMTTCDIOYT7STSESVHLZQEQJBMAC
O6PFGAUDYCMK6SC6V5RB5ELXZ7W54OB7XPYCMECCA4BSBUVLFAPAC
K3OVRFE3Y23DN47XNAISH6XM5JGSCNRR6TOEO5KAKBNB54MFO27AC
MPN7OJSZD5CS5N7WWS3ZSOYE7ZRCABIBHZDMHVS6IT25EO2INK7AC
GW4AAYNF7I66D72G5PMFTQRK7B4KZVYKAHKRPC2IY7IX37JKEHJQC
6XHALMLUA5B5BBYFSWIFHSJ2BXCL6RSAW5TCKRGJEI2LURH2TQ4AC
lisp_eval_should_be '(toupper "Title Case")' '"TITLE CASE"' 'toupper'
lisp_eval_should_be '(substr "Foo" 2)' '"oo"' 'substr 2'
lisp_eval_should_be '(substr "Foo" 1 2)' '"Fo"' 'substr 3'
lisp_eval_should_be '(list-length '\''(1 2 3 4 5))' '5' 'list-length'
lisp_eval_should_be '(string-length "1234567890")' '10' 'string-length'
lisp_eval_should_be '(split "a b c d e" " ")' '("a" "b" "c" "d" "e")' 'split'
lisp_eval_should_be '(sprintf "foo %d bar %d baz %s" 3 5 "bletch")' \
'"foo 3 bar 5 baz bletch"' 'sprintf'
lisp_eval_should_be '(strcat "foo" "bar" "baz")' '"foobarbaz"' 'strcat'
lisp_eval_should_be '(sprintf "%03d%%03d%s" 5 "foo")' \
'"005%03dfoo"' 'sprintf % escape'
lisp_eval_should_be '(sub "o" "e" "foo quux blotch")' \
'"feo quux blotch"' 'sub'
lisp_eval_should_be '(gsub "o" "e" "foo quux blotch")' \
'"fee quux bletch"' 'gsub'
function _eval3_other_special_forms(form, env, d, car, a) {
car = _car(form)
if(car == _symbol("system"))
return _system(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("tolower"))
return _tolower(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("toupper"))
return _toupper(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("substr"))
# trusting the user here to provide either two or three args
if(_is_null(_cdddr(form)))
return _substr2(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else
return _substr3(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1),
_eval3(_car(_cdddr(form)), env, env, d+1))
else if(car == _symbol("index"))
return _index(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("match"))
return _match(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("split"))
# for now you must provide fs
return _split2(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
# it would be easy to make non-destructive sub and gsub.
else if(car == _symbol("sub"))
# for now you must provide s
return _sub3(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1),
_eval3(_car(_cdddr(form)), env, env, d+1))
else if(car == _symbol("gsub"))
return _gsub3(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1),
_eval3(_car(_cdddr(form)), env, env, d+1))
else if(car == _symbol("sprintf"))
# oo tricky, varargs. note we are sending the cddr in unevaluated.
return _sprintf(_eval3(_cadr(form), env, env, d+1),
_cddr(form))
else if(car == _symbol("string-length"))
return _string_length(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("strcat"))
# same, varargs.
return _strcat(_cdr(form))
else if(car == _symbol("gc"))
return _gc(_cons(env, _cons(outer_env, _cons(_GLOBALS, _nil()))))
else if(car == _symbol("dump"))
# the first argument is a filename
return _dump(_STRING[_cadr(form)])
else _builtin_mischaracterization("_eval3_other_special_forms", car)
}
function _tolower(s, tv) {
if(_TYPE[s] == "s") {
return _string(tolower(_STRING[s]))
} else {
logg_err("_tolower", "non-string operand " _repr(s))
return _nil()
}
}
function _toupper(s, tv) {
if(_TYPE[s] == "s") {
return _string(toupper(_STRING[s]))
} else {
logg_err("_toupper", "non-string operand " _repr(s))
return _nil()
}
}
function _substr2(s, a, tv) {
if(_TYPE[s] == "s") {
split(a, tv)
if(tv[1] == "#") {
return _string(substr(_STRING[s], tv[2]))
} else {
logg_err("_substr2", "non-numeric a " _repr(a))
return _nil()
}
} else {
logg_err("_substr2", "non-string s " _repr(s))
return _nil()
}
}
function _substr3(s, a, b, tv) {
if(_TYPE[s] == "s") {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _string(substr(_STRING[s], a, b))
} else {
logg_err("_substr3", "non-numeric b " _repr(b))
return _nil()
}
} else {
logg_err("_substr3", "non-numeric a " _repr(a))
return _nil()
}
} else {
logg_err("_substr3", "non-string s " _repr(s))
return _nil()
}
}
function _index(s, t) {
if(_TYPE[s] == "s") {
if(_TYPE[t] == "s") {
return _number(index(_STRING[s], _STRING[t]))
} else {
logg_err("_index", "non-string t " _repr(t))
return _nil()
}
} else {
logg_err("_index", "non-string s " _repr(s))
return _nil()
}
}
function _match(s, r) {
if(_TYPE[s] == "s") {
if(_TYPE[t] == "s") {
match(_STRING[s], _STRING[r])
# if no match, RSTART will be 0 and RLENGTH -1
return _cons(_number(RSTART),
_cons(_number(RLENGTH), _nil()))
} else {
logg_err("_match", "non-string r " _repr(r))
return _nil()
}
} else {
logg_err("_match", "non-string s " _repr(s))
return _nil()
}
}
function _split2(s, fs, a) {
if(_TYPE[s] == "s") {
if(_TYPE[fs] == "s") {
split(_STRING[s], a, _STRING[fs])
return _awk_array_of_strings_to_list(a)
} else {
logg_err("_split", "non-string fs " _repr(fs))
}
} else {
logg_err("_split", "non-string s " _repr(s))
return _nil()
}
}
function _string_length(s, tv) {
if(_TYPE[s] == "s") {
return _number(length(_STRING[s]))
} else {
logg_err("_string_length", "non-string " _repr(s))
return _nil()
}
}
function _strcat(unevald, env, d, s, here, val) {
s = ""
for(here=unevald; !_is_null(here); here=_cdr(here)) {
val = _eval3(_car(here), env, env, d+1)
if(_TYPE[val] == "s") {
s = s _STRING[val]
} else {
logg_err("_strcat", "non-string param " _repr(val))
return _nil()
}
}
return _string(s)
}
function _sprintf(fmt, unevald, env, d, dlave, evald, s, a, i, p) {
n = 1
dlave = _nil()
# even if there are extra arguments, they should all be evaluated
for(; !_is_null(unevald); unevald=_cdr(unevald)) {
dlave = _cons(_eval3(_car(unevald), env, env, d+1), dlave)
}
evald = _nreverse(dlave)
_list_to_flat_awk_array_of_any(evald, a)
i = 1
s = ""
fmt = _STRING[fmt]
# here we fill in just one format specifier at a time, because awk
# has no splatting: we can't say a[1] = 5; a[2] = 7;
# sprintf("%d%d", *a). so there is no way to produce a variadic
# call to sprintf. to be less simple and perhaps faster, we might
# count format specifiers (skipping %%'s!) and do special cases
# for 1 to 5 parameters; but this while loop should cover all
# cases.
while(fmt != "") {
# logg_dbg("_sprintf", " fmt is " fmt " and s is " s)
# find a format specification
if(match(fmt, /%/)) {
# just copy whatever is before the %
s = s substr(fmt, 1, RSTART-1)
fmt = substr(fmt, RSTART)
# logg_dbg("_sprintf", "now fmt is " fmt " and s is " s)
if(match(fmt, /^%%/)) {
# this is just an escaped %. don't eat a parameter.
s = s "%"
fmt = substr(fmt, 3)
continue
}
# now the %-thing is at the beginning of fmt. how long is
# it? (grammar derived from FreeBSD printf(3); your libc
# may vary)
match(fmt,/^%[*#+ 0-9.'-]*[diouxXfFeEgGaAcsb]/);
# RLENGTH is the length of the format specifier.
if(i > length(a)) {
logg_err("_sprintf", "not enough values for sprintf!")
p = _nil()
} else {
p = a[i++]
}
# logg_dbg("_sprintf", "tiny fmt is " substr(fmt,1,RLENGTH))
s = s sprintf(substr(fmt,1,RLENGTH), p)
fmt = substr(fmt, RLENGTH+1)
} else {
s = s fmt
fmt = ""
}
}
return _string(s)
}
function _sub3(r, t, s, new_s, rv) {
if(_TYPE[r] == "s") {
if(_TYPE[t] == "s") {
if(_TYPE[s] == "s") {
new_s = _STRING[s]
sub(_STRING[r], _STRING[t], new_s)
return _string(new_s)
} else {
logg_err("_sub3", "non-string s " _repr(s))
return _nil()
}
} else {
logg_err("_sub3", "non-string t " _repr(t))
return _nil()
}
} else {
logg_err("_sub3", "non-string r " _repr(r))
return _nil()
}
}
function _gsub3(r, t, s, new_s, rv) {
if(_TYPE[r] == "s") {
if(_TYPE[t] == "s") {
if(_TYPE[s] == "s") {
# whoa nelly, destructive update.
new_s = _STRING[s]
gsub(_STRING[r], _STRING[t], new_s)
return _string(new_s)
} else {
logg_err("_gsub3", "non-string s " _repr(s))
return _nil()
}
} else {
logg_err("_gsub3", "non-string t " _repr(t))
return _nil()
}
} else {
logg_err("_gsub3", "non-string r " _repr(r))
return _nil()
}
}
function _eval3_math(form, env, d, car, a) {
car = _car(form)
if(car == _symbol("only2+"))
return _only2_add(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2*"))
return _only2_multiply(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2-"))
return _only2_subtract(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2/"))
return _only2_divide(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2//"))
return _only2_quotient( \
_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2%"))
return _only2_modulo(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2**"))
return _only2_power(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("atan2"))
return _atan2(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("cos"))
return _cos(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("sin"))
return _sin(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("exp"))
return _exp(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("log"))
return _log(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("sqrt"))
return _sqrt(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("rand"))
return _number(rand())
else if(car == _symbol("srand"))
return _srand(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("int"))
return _int(_eval3(_cadr(form), env, env, d+1))
else _builtin_mischaracterization("_eval3_math", car)
}
function _only2_add(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a+b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_add", "non-numeric operand", d)
return _nil()
}
function _only2_multiply(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a*b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_multiply", "non-numeric operand", d)
return _nil()
}
function _only2_subtract(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a-b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_subtract", "non-numeric operand", d)
return _nil()
}
function _only2_divide(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
if(b==0) {
logg_err("_only2_divide", "divide by zero", d)
return _nil()
}
return _number(a/b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_divide", "non-numeric operand", d)
return _nil()
}
function _only2_quotient(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
if(b==0) {
logg_err("_only2_quotient", "quotient by zero", d)
return _nil()
}
return _number(int(a/b))
}
}
# if either a or b was not a number, we're here
logg_err("_only2_quotient", "non-numeric operand", d)
return _nil()
}
function _only2_modulo(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
if(b==0) {
logg_err("_only2_modulo", "modulo by zero", d)
return _nil()
}
return _number(a%b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_modulo", "non-numeric operand", d)
return _nil()
}
function _only2_power(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a^b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_power", "non-numeric operand", d)
return _nil()
}
function _atan2(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(atan2(a,b))
}
}
# if either a or b was not a number, we're here
logg_err("_atan2", "non-numeric operand", d)
return _nil()
}
function _cos(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(cos(a))
} else {
logg_err("_cos", "non-numeric-operand", d)
return _nil()
}
}
function _sin(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(sin(a))
} else {
logg_err("_sin", "non-numeric-operand", d)
return _nil()
}
}
function _exp(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(exp(a))
} else {
logg_err("_exp", "non-numeric-operand", d)
return _nil()
}
}
function _log(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(log(a))
} else {
logg_err("_log", "non-numeric-operand", d)
return _nil()
}
}
function _sqrt(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(sqrt(a))
} else {
logg_err("_sqrt", "non-numeric-operand", d)
return _nil()
}
}
function _srand(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(srand(a))
} else {
logg_err("_srand", "non-numeric-operand", d)
return _nil()
}
}
function _int(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(int(a))
} else {
logg_err("_int", "non-numeric-operand", d)
return _nil()
}
}
(setq substr (lambda xs (cond ((eq (list-length xs 2)) \
(substr (car xs) (cadr xs))) \
(true (substr (car xs) (cadr xs) (caddr xs))))))\
(setq index (lambda (s t) (index s t))) \
(setq match (lambda (s r) (match s r))) \
(setq split (lambda (s fs) (split s fs))) \
(setq sub! (lambda (r t s) (sub! r t s))) \
(setq gsub! (lambda (r t s) (gsub! r t s))) \
\"no sprintf function value, varargs are too tricky\" \
(setq string-length (lambda (s) (string-length s))) \
# make sure the symbol numbers for the first symbols are the same as
# when we built the image.
@include first-symbols.awk
BEGIN {
# fix the symbol numbers of the special forms
_symbol("quote")
_symbol("atom")
_symbol("eq")
_symbol("car")
_symbol("cdr")
_symbol("cons")
_symbol("cond")
_symbol("label")
_symbol("lambda")
_symbol("not")
_symbol("null")
_symbol("equal")
_symbol("caar")
_symbol("cadr")
# ^^ above here, we have specific cases in _eval3, because these
# are expected to be the most-often-used functions.
_symbol("memq")
_symbol("member")
_symbol("assoc")
_symbol("setq")
_symbol("caaar")
_symbol("caadr")
_symbol("cadar")
_symbol("caddr")
_symbol("cdaar")
_symbol("cdadr")
_symbol("cddar")
_symbol("cdddr")
_symbol("rplaca")
_symbol("rplacd")
_symbol("nreverse")
_symbol("nconc")
_symbol("append")
_symbol("list-length")
_symbol("print")
_symbol("progn")
_symbol("macro")
_symbol("expand1")
_symbol("eval")
_symbol("%other-lispy%")
_symbol("only2+")
_symbol("only2*")
_symbol("only2-")
_symbol("only2/")
_symbol("only2//")
_symbol("only2%")
_symbol("only2**")
_symbol("atan2")
_symbol("cos")
_symbol("sin")
_symbol("exp")
_symbol("log")
_symbol("sqrt")
_symbol("rand")
_symbol("srand")
_symbol("int")
_symbol("%math%")
_symbol("system")
_symbol("tolower")
_symbol("toupper")
_symbol("substr")
_symbol("index")
_symbol("match")
_symbol("split")
_symbol("sub")
_symbol("gsub")
_symbol("sprintf")
_symbol("string-length")
_symbol("strcat")
_symbol("gc")
_symbol("dump")
_symbol("%last-special-form%")
}
function _only2_add(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a+b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_add", "non-numeric operand", d)
return _nil()
}
function _only2_multiply(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a*b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_multiply", "non-numeric operand", d)
return _nil()
}
function _only2_subtract(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a-b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_subtract", "non-numeric operand", d)
return _nil()
}
function _only2_divide(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
if(b==0) {
logg_err("_only2_divide", "divide by zero", d)
return _nil()
}
return _number(a/b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_divide", "non-numeric operand", d)
return _nil()
}
function _only2_quotient(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
if(b==0) {
logg_err("_only2_quotient", "quotient by zero", d)
return _nil()
}
return _number(int(a/b))
}
}
# if either a or b was not a number, we're here
logg_err("_only2_quotient", "non-numeric operand", d)
return _nil()
}
function _only2_modulo(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
if(b==0) {
logg_err("_only2_modulo", "modulo by zero", d)
return _nil()
}
return _number(a%b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_modulo", "non-numeric operand", d)
return _nil()
}
function _only2_power(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(a^b)
}
}
# if either a or b was not a number, we're here
logg_err("_only2_power", "non-numeric operand", d)
return _nil()
}
function _atan2(a, b, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
split(b, tv)
if(tv[1] == "#") {
b = tv[2]
return _number(atan2(a,b))
}
}
# if either a or b was not a number, we're here
logg_err("_atan2", "non-numeric operand", d)
return _nil()
}
function _cos(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(cos(a))
} else {
logg_err("_cos", "non-numeric-operand", d)
return _nil()
}
}
function _sin(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(sin(a))
} else {
logg_err("_sin", "non-numeric-operand", d)
return _nil()
}
}
function _exp(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(exp(a))
} else {
logg_err("_exp", "non-numeric-operand", d)
return _nil()
}
}
function _log(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(log(a))
} else {
logg_err("_log", "non-numeric-operand", d)
return _nil()
}
}
function _sqrt(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(sqrt(a))
} else {
logg_err("_sqrt", "non-numeric-operand", d)
return _nil()
}
}
function _srand(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(srand(a))
} else {
logg_err("_srand", "non-numeric-operand", d)
return _nil()
}
}
function _int(a, tv) {
split(a, tv)
if(tv[1] == "#") {
a = tv[2]
return _number(int(a))
} else {
logg_err("_int", "non-numeric-operand", d)
return _nil()
}
function _builtin_mischaracterization(where, what) {
_logg_err(where, "builtin mischaracterization for symbol " what)
exit(55)
function _tolower(s, tv) {
if(_TYPE[s] == "s") {
return _string(tolower(_STRING[s]))
} else {
logg_err("_tolower", "non-string operand " _repr(s))
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))
}
}
function _toupper(a, tv) {
if(_TYPE[s] == "s") {
return _string(toupper(_STRING[s]))
} 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 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("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 if(car == _symbol("only2+"))
return _only2_add(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2*"))
return _only2_multiply(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2-"))
return _only2_subtract(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2/"))
return _only2_divide(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2//"))
return _only2_quotient( \
_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2%"))
return _only2_modulo(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("only2**"))
return _only2_power(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("atan2"))
return _atan2(_eval3(_cadr(form), env, env, d+1),
_eval3(_caddr(form), env, env, d+1))
else if(car == _symbol("cos"))
return _cos(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("sin"))
return _sin(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("exp"))
return _exp(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("log"))
return _log(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("sqrt"))
return _sqrt(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("rand"))
return _number(rand())
else if(car == _symbol("srand"))
return _srand(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("int"))
return _int(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("system"))
return _system(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("tolower"))
return _tolower(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("toupper"))
return _toupper(_eval3(_cadr(form), env, env, d+1))
else if(car == _symbol("gc"))
return _gc(_cons(env, _cons(outer_env, _cons(_GLOBALS, _nil()))))
else if(car == _symbol("dump"))
# the first argument is a filename
return _dump(_STRING[_cadr(form)])
else {
# 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 {
function _cadar(cons_index) {
return _car(_cdr(_car(cons_index)))
function _cdadr(cons_index) {
return _cdr(_car(_cdr(cons_index)))
}
function _cddar(cons_index) {
return _cdr(_cdr(_car(cons_index)))
}
function _cdddr(cons_index) {
return _cdr(_cdr(_cdr(cons_index)))
function _awk_array_of_strings_to_list(a, i, lis) {
lis = _nil()
# we can save an _nreverse here. let's do it.
for(i=length(a); i>0; i--) {
lis = _cons(_string(a[i]), lis)
}
return lis
}
# compare with _repr function in printer.awk
function _list_to_flat_awk_array_of_any(lis, a, ia, c, t) {
if(ia[1] == 0) ia[1] = 1
for(; !_is_null(lis); lis=_cdr(lis)) {
c = _car(lis)
if(_is_literal(c)) {
if(c ~ /^#/) a[ia[1]++] = substr(c, 3)+0
else if(c == "t") a[ia[1]++] = "true"
else if(c == "f") a[ia[1]++] = "false"
else if(c == "nil") a[ia[1]++] = "nil"
else {
logg_err("_list_to_flat_array_of_any",
"unimplemented for literal <<" c ">>")
a[ia[1]++] = "[?]"
}
} else {
t = _TYPE[c]
if(t == "s") a[ia[1]++] = _STRING[c]
else if(t == "'") a[ia[1]++] = _SYM_NUMBERS[c]
else if(t == "(") _list_to_flat_array(c, a, ia)
else { # shouldn't happen
logg_err("_list_to_flat_array_of_any",
"unimplemented for nonliteral <<" c ">>")
}
}
}
return ia[1]
}