qse/ase/test/awk/lisp/awklisp

#
# $Id$
#
# This program is a modified version of awklisp originally written 
# by Darius Bacon. The only modification is to append a semicolon
# onto the end of each statement to cater for the semicolon requirement
# of ASEAWK.
#

# --- Representation of Lisp data

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;
}

# Return the symbol :string names.
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;
}

# Define a primitive procedure, with :nparams parameters,
# bound to the symbol named :name.
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];
}

# --- Garbage collection

# Make a new pair.
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;
    }
}

# --- Set up

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");
}

# --- The interpreter

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);
        }
}

# All the interpretation routines have the precondition that their
# arguments are protected from garbage collection.

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");
}

# Evaluate a sequence of expressions, returning the last value.
function progn(exprs)
{
    for (; cdr[exprs] != NIL; exprs = cdr[exprs])
        eval(car[exprs]);
    return eval(car[exprs]);
}

# Evaluate the operands of a procedure, pushing the results on the stack.
function eval_rands(rands)
{
    for (; rands != NIL; rands = cdr[rands])
        stack[stack_ptr++] = eval(car[rands]);
}

# Call the procedure :proc, with args stack[frame_ptr]..stack[stack_ptr-1]
# (in that order).
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;
}

# --- The environment
# The current environment is represented by the set of values
# value[sym] where sym is a symbol.  extend_env(vars) adds a new
# set of bindings for vars, saving the old values; unwind_env(vars)
# restores those old values.  The new value for the nth member of
# vars is frame_ptr[n]; coincidentally, that's also where we 
# store away the old value, since that stack frame's not needed 
# for anything else after the extend_env() call.

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;
    }
}

# --- Output

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(")");
    }
}

# --- Input

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);
}

# --- Miscellany

# Destructively reverse :list and append :reversed_head.
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);
}