qse/ase/test/awk/lisp/awklisp.org

#!/usr/bin/gawk -f

BEGIN { a_number = 0 pair_ptr = a_pair = 1 symbol_ptr = a_symbol = 2

type_name[a_number] = "number" type_name[a_pair] = "pair" type_name[a_symbol] = "symbol" }

function is(type, expr) { if (expr % 4 != type) error("Expected a " type_name[type] ", not a " type_name[expr % 4]) return expr }

function is_number(expr) { return expr % 4 = 0 } function is_pair(expr) { return expr % 4 = 1 } function is_symbol(expr) { return expr % 4 = 2 } function is_atom(expr) { return expr % 4 ! 1 }

function make_number(n) { return n * 4 }

function numeric_value(expr) { if (expr % 4 != 0) error("Not a number") return expr / 4 }

function string_to_symbol(string) { if (string in intern) return intern[string] symbol_ptr += 4 intern[string] = symbol_ptr printname[symbol_ptr] = string return symbol_ptr }

function def_prim(name, nparams, sym) { sym = string_to_symbol(name) value[sym] = string_to_symbol(sprintf("#<Primitive %s>", name)) if (nparams != "") num_params[value[sym]] = nparams return value[sym] }

function cons(the_car, the_cdr) { while (pair_ptr in marks) { delete marks[pair_ptr] pair_ptr += 4 } if (pair_ptr == pair_limit) gc(the_car, the_cdr) car[pair_ptr] = the_car cdr[pair_ptr] = the_cdr pair_ptr += 4 return pair_ptr - 4 }

function protect(object) { protected[++protected_ptr] = object } function unprotect() { –protected_ptr }

function mark(object) { while (is_pair(object) && !(object in marks)) { #** speed marks[object] = 1 mark(car[object]) object = cdr[object] } }

function gc(the_car, the_cdr, p, i) { if (loud_gc) printf("\nGC…") >"/dev/stderr" mark(the_car); mark(the_cdr) for (p in protected) mark(protected[p]) for (p in stack) mark(stack[p]) for (p in value) mark(value[p]) for (p in property) { i = index(SUBSEP, p) mark(substr(p, 1, i-1)) mark(substr(p, i+1)) mark(property[p]) } pair_ptr = a_pair while (pair_ptr in marks) { delete marks[pair_ptr] pair_ptr += 4 } if (pair_ptr == pair_limit) { if (loud_gc) printf("Expanding heap…") >"/dev/stderr" pair_limit += 4 * heap_increment } }

BEGIN { srand()

frame_ptr = stack_ptr = 0

if (heap_increment == "") heap_increment = 1500 pair_limit = a_pair + 4 * heap_increment

NIL = string_to_symbol("nil") T = string_to_symbol("t") value[NIL] = NIL value[T] = T car[NIL] = cdr[NIL] = NIL # this is convenient in a couple places…

THE_EOF_OBJECT = string_to_symbol("#eof") value[string_to_symbol("the-eof-object")] = THE_EOF_OBJECT eof = "(eof)"

QUOTE = string_to_symbol("quote"); is_special[QUOTE] = 1 LAMBDA = string_to_symbol("lambda"); is_special[LAMBDA] = 1 IF = string_to_symbol("if"); is_special[IF] = 1 SETQ = string_to_symbol("set!"); is_special[SETQ] = 1 DEFINE = string_to_symbol("define"); is_special[DEFINE] = 1 PROGN = string_to_symbol("begin"); is_special[PROGN] = 1 WHILE = string_to_symbol("while"); is_special[WHILE] = 1

EQ = def_prim("eq?", 2) NULL = def_prim("null?", 1) CAR = def_prim("car", 1) CDR = def_prim("cdr", 1) CADR = def_prim("cadr", 1) CDDR = def_prim("cddr", 1) CONS = def_prim("cons", 2) LIST = def_prim("list") EVAL = def_prim("eval", 1) APPLY = def_prim("apply", 2) READ = def_prim("read", 0) WRITE = def_prim("write", 1) NEWLINE = def_prim("newline", 0) ADD = def_prim("+", 2) SUB = def_prim("-", 2) MUL = def_prim("*", 2) DIV = def_prim("quotient", 2) MOD = def_prim("remainder", 2) LT = def_prim("<", 2) GET = def_prim("get", 2) PUT = def_prim("put", 3) ATOMP = def_prim("atom?", 1) PAIRP = def_prim("pair?", 1) SYMBOLP = def_prim("symbol?", 1) NUMBERP = def_prim("number?", 1) SETCAR = def_prim("set-car!", 2) SETCDR = def_prim("set-cdr!", 2) NREV = def_prim("reverse!", 1) GENSYM = def_prim("gensym", 0) RANDOM = def_prim("random", 1) ERROR = def_prim("error")

DRIVER = string_to_symbol("top-level-driver") }

BEGIN { for (;;) { if (DRIVER in value && value[DRIVER] != NIL) apply(value[DRIVER]) else { expr = read() if (expr == THE_EOF_OBJECT) break; protect(expr) print_expr(eval(expr)) unprotect() } }

if (profiling) for (proc in call_count) { printf("%5d ", call_count[proc]) print_expr(proc) } }

function eval(expr, old_frame_ptr) { if (is_atom(expr)) #** speed if (is_symbol(expr)) { if (!(expr in value)) error("Unbound variable: " printname[expr]) return value[expr] } else return expr

op = car[expr] # op is global to save awk stack space

if (!(op in is_special)) { old_frame_ptr = frame_ptr frame_ptr = stack_ptr

eval_rands(cdr[expr]) protect(proc = eval(car[expr])) result = apply(proc) unprotect()

stack_ptr = frame_ptr frame_ptr = old_frame_ptr return result }

if (op = QUOTE) return car[cdr[expr]] if (op = LAMBDA) return expr if (op = IF) return eval(car[cdr[expr]]) ! NIL \ ? eval(car[cdr[cdr[expr]]]) \

eval(car[cdr[cdr[cdr[expr]]]])

if (op = PROGN) return progn(cdr[expr]) if (op = SETQ) { if (!(car[cdr[expr]] in value)) error("Unbound variable: " printname[car[cdr[expr]]]) return value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]) } if (op = WHILE) { while (eval(car[cdr[expr]]) ! NIL) progn(cdr[cdr[expr]]) return NIL } if (op == DEFINE) { value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]) return car[cdr[expr]] }

error("BUG: Unknown special form") }

function progn(exprs) { for (; cdr[exprs] != NIL; exprs = cdr[exprs]) eval(car[exprs]) return eval(car[exprs]) }

function eval_rands(rands) { for (; rands != NIL; rands = cdr[rands]) stack[stack_ptr++] = eval(car[rands]) }

function apply(proc) { if (profiling) ++call_count[proc] if (car[proc] == LAMBDA) { extend_env(car[cdr[proc]]) result = progn(cdr[cdr[proc]]) # result is global to save stack space unwind_env(car[cdr[proc]]) return result } if (proc in num_params && num_params[proc] != stack_ptr - frame_ptr) error("Wrong number of arguments to " printname[cdr[proc]])

if (proc = CAR) return car[is(a_pair, stack[frame_ptr])] if (proc = CDR) return cdr[is(a_pair, stack[frame_ptr])] if (proc = CONS) return cons(stack[frame_ptr], stack[frame_ptr+1]) if (proc = NULL) return stack[frame_ptr] = NIL ? T : NIL if (proc = EQ) return stack[frame_ptr] = stack[frame_ptr+1] ? T : NIL if (proc = ATOMP) return is_atom(stack[frame_ptr]) ? T : NIL if (proc = ADD) return is(a_number, stack[frame_ptr]) + is(a_number, stack[frame_ptr+1]) if (proc = SUB) return is(a_number, stack[frame_ptr]) - is(a_number, stack[frame_ptr+1]) if (proc = MUL) return make_number(numeric_value(stack[frame_ptr]) * numeric_value(stack[frame_ptr+1])) if (proc = DIV) return make_number(int(numeric_value(stack[frame_ptr]) / numeric_value(stack[frame_ptr+1]))) if (proc = MOD) return make_number(numeric_value(stack[frame_ptr]) % numeric_value(stack[frame_ptr+1])) if (proc = LT) return (stack[frame_ptr] + 0 < stack[frame_ptr+1] + 0) ? T : NIL if (proc = GET) return (stack[frame_ptr], stack[frame_ptr+1]) in property ? property[stack[frame_ptr], stack[frame_ptr+1]] : NIL if (proc = PUT) return property[stack[frame_ptr], stack[frame_ptr+1]] = stack[frame_ptr+2] if (proc = CADR) return car[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])] if (proc = CDDR) return cdr[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])] if (proc = LIST) return listify_args() if (proc = SYMBOLP)return is_symbol(stack[frame_ptr]) ? T : NIL if (proc = PAIRP) return is_pair(stack[frame_ptr]) ? T : NIL if (proc = NUMBERP)return is_number(stack[frame_ptr]) ? T : NIL if (proc = SETCAR) return car[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1] if (proc = SETCDR) return cdr[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1] if (proc = APPLY) return do_apply(stack[frame_ptr], stack[frame_ptr+1]) if (proc = EVAL) return eval(stack[frame_ptr]) if (proc = NREV) return nreverse(stack[frame_ptr], NIL) if (proc = WRITE) { write_expr(stack[frame_ptr]); printf(" "); return NIL } if (proc = NEWLINE){ printf("\n"); return NIL } if (proc = READ) return read() if (proc = RANDOM) return make_number(int(rand() * numeric_value(stack[frame_ptr]))) if (proc = GENSYM) return string_to_symbol("#G" ++gensym_counter) if (proc == ERROR) { printf("Error!\n"); print_expr(listify_args()); exit(1) } error("Unknown procedure type") }

function do_apply(proc, args, old_frame_ptr) { old_frame_ptr = frame_ptr frame_ptr = stack_ptr

for (; is_pair(args); args = cdr[args]) stack[stack_ptr++] = car[args] if (args != NIL) error("Bad argument to APPLY: not a proper list") result = apply(proc)

stack_ptr = frame_ptr frame_ptr = old_frame_ptr return result }

function listify_args( p, result) { result = NIL for (p = stack_ptr - 1; frame_ptr <= p; –p) result = cons(stack[p], result) return result }

function extend_env(vars, p, temp) { for (p = frame_ptr; vars != NIL; vars = cdr[vars]) { if (p == stack_ptr) error("Too many arguments to procedure") temp = value[car[vars]] value[car[vars]] = stack[p] stack[p] = temp ++p } if (p != stack_ptr) error("Not enough arguments to procedure") }

function unwind_env(vars, p) { for (p = frame_ptr; vars != NIL; vars = cdr[vars]) { if (stack[p] == "") delete value[car[vars]] else value[car[vars]] = stack[p] ++p } }

function print_expr(expr) { write_expr(expr) print "" }

function write_expr(expr) { if (is_atom(expr)) { if (!is_symbol(expr)) printf("%d", numeric_value(expr)) else { if (!(expr in printname)) error("BUG: " expr " has no printname") printf("%s", printname[expr]) } } else { printf("(") write_expr(car[expr]) for (expr = cdr[expr]; is_pair(expr); expr = cdr[expr]) { printf(" ") write_expr(car[expr]) } if (expr != NIL) { printf(" . ") write_expr(expr) } printf(")") } }

function read( committed, result) { skip_blanks() if (token == eof) if (committed) error("Unexpected EOF") else return THE_EOF_OBJECT if (token == "(") { # read a list advance() result = NIL for (;;) { skip_blanks() if (token == ".") { advance() after_dot = read(1) skip_blanks() if (token != ")") error("')' expected") advance() return nreverse(result, after_dot) } else if (token == ")") { advance() return nreverse(result, NIL) } else { protect(result) result = cons(read(1), result) unprotect() } } } else if (token == "'") { # a quoted expression advance() return cons(QUOTE, cons(read(1), NIL)) } else if (token ~ ^-?[0-9]+$) { # a number result = make_number(token) advance() return result } else { # a symbol result = string_to_symbol(token) advance() return result } }

function skip_blanks() { while (token ~ ^[ \t]*$) advance() }

function advance() { if (token = eof) return eof if (token = "") { if (getline line <= 0) { token = eof return } } if (match(line, "^[()'.]") || match(line, "^[_A-Za-z0-9=!@$%&*<>?+\\-*/:]+") || match(line, "^[ \\t]+")) { token = substr(line, RSTART, RLENGTH) line = substr(line, RLENGTH+1) } else if (line = "" || substr(line, 1, 1) = ";") token = "" # this kludge permits interactive use else error("Lexical error starting at " line) }

function nreverse(list, reversed_head, tail) { while (is_pair(list)) { #** speed? tail = cdr[list] cdr[list] = reversed_head reversed_head = list list = tail } if (list != NIL) error("Not a proper list - reverse!") return reversed_head }

function error(reason) { print "ERROR: " reason >"/dev/stderr" exit(1) }