hyung-hwan/qse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
d32f95442e
qse/ase/test/awk/lisp.awk

785 lines
27 KiB
Awk
Raw Blame History

#
# $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.
#
# <<README>>
#
# See the Manual file for documentation.
#
# This release also has a Perl version, perlisp, contributed by the Perl
# Avenger, who writes:
#
# It has new primitives: a reentrant "load", a "trace" command, and more
# error reporting. Perlisp will attempt to load a program called
# "testme" before anything else, when it runs. After that, it will load
# $HOME/.perlisprc if that file exists, before reverting to the
# interactive read/eval/print loop.
#
# The awk code is still essentially the code posted to alt.sources (May
# 31, 1994), but with a garbage collector added.
#
#
# Copyright (c) 1994, 2001 by Darius Bacon.
#
# Permission is granted to anyone to use this software for any
# purpose on any computer system, and to redistribute it freely,
# subject to the following restrictions:
#
# 1. The author is not responsible for the consequences of use of
# this software, no matter how awful, even if they arise from
# defects in it.
#
# 2. The origin of this software must not be misrepresented, either
# by explicit claim or by omission.
#
# 3. Altered versions must be plainly marked as such, and must not
# be misrepresented as being the original software.
# <<Manual>>
#
# awklisp: a Lisp interpreter in awk
# version 1.2
#
# Darius Bacon
# darius@accesscom.com
# http://www.accesscom.com/~darius/
#
#
# 1. Usage
#
# mawk [-v profiling=1] -f awklisp <optional-Lisp-source-files>
#
# The -v profiling=1 option turns call-count profiling on.
#
# If you want to use it interactively, be sure to include '-' (for the standard
# input) among the source files. For example:
#
# mawk -f awklisp startup -
#
# It should work with nawk and gawk, too, but even less quickly.
#
#
# 2. Overview
#
# This program arose out of one-upmanship. At my previous job I had to
# use MapBasic, an interpreter so astoundingly slow (around 100 times
# slower than GWBASIC) that one must wonder if it itself is implemented
# in an interpreted language. I still wonder, but it clearly could be:
# a bare-bones Lisp in awk, hacked up in a few hours, ran substantially
# faster. Since then I've added features and polish, in the hope of
# taking over the burgeoning market for stately language
# implementations.
#
# This version tries to deal with as many of the essential issues in
# interpreter implementation as is reasonable in awk (though most would
# call this program utterly unreasonable from start to finish, perhaps...).
# Awk's impoverished control structures put error recovery and tail-call
# optimization out of reach, in that I can't see a non-painful way to code
# them. The scope of variables is dynamic because that was easier to
# implement efficiently. Subject to all those constraints, the language
# is as Schemely as I could make it: it has a single namespace with
# uniform evaluation of expressions in the function and argument positions,
# and the Scheme names for primitives and special forms.
#
# The rest of this file is a reference manual. My favorite tutorial would be
# _The Little LISPer_ (see section 5, References); don't let the cute name
# and the cartoons turn you off, because it's a really excellent book with
# some mind-stretching material towards the end. All of its code will work
# with awklisp, except for the last two chapters. (You'd be better off
# learning with a serious Lisp implementation, of course.)
#
# The file Impl-notes in this distribution gives an overview of the
# implementation.
#
#
# 3. Expressions and their evaluation
#
# Lisp evaluates expressions, which can be simple (atoms) or compound (lists).
#
# An atom is a string of characters, which can be letters, digits, and most
# punctuation; the characters may -not- include spaces, quotes, parentheses,
# brackets, '.', '#', or ';' (the comment character). In this Lisp, case is
# significant ( X is different from x ).
#
# Atoms: atom 42 1/137 + ok? hey:names-with-dashes-are-easy-to-read
# Not atoms: don't-include-quotes (or spaces or parentheses)
#
# A list is a '(', followed by zero or more objects (each of which is an atom
# or a list), followed by a ')'.
#
# Lists: () (a list of atoms) ((a list) of atoms (and lists))
# Not lists: ) ((()) (two) (lists)
#
# The special object nil is both an atom and the empty list. That is,
# nil = (). A non-nil list is called a -pair-, because it is represented by a
# pair of pointers, one to the first element of the list (its -car-), and one to
# the rest of the list (its -cdr-). For example, the car of ((a list) of stuff)
# is (a list), and the cdr is (of stuff). It's also possible to have a pair
# whose cdr is not a list; the pair with car A and cdr B is printed as (A . B).
#
# That's the syntax of programs and data. Now let's consider their meaning. You
# can use Lisp like a calculator: type in an expression, and Lisp prints its
# value. If you type 25, it prints 25. If you type (+ 2 2), it prints 4. In
# general, Lisp evaluates a particular expression in a particular environment
# (set of variable bindings) by following this algorithm:
#
# If the expression is a number, return that number.
#
# If the expression is a non-numeric atom (a -symbol-), return the value of that
# symbol in the current environment. If the symbol is currently unbound, that's
# an error.
#
# Otherwise the expression is a list. If its car is one of the symbols: quote,
# lambda, if, begin, while, set!, or define, then the expression is a -special-
# -form-, handled by special rules. Otherwise it's just a procedure call,
# handled like this: evaluate each element of the list in the current environment,
# and then apply the operator (the value of the car) to the operands (the values
# of the rest of the list's elements). For example, to evaluate (+ 2 3), we
# first evaluate each of its subexpressions: the value of + is (at least in the
# initial environment) the primitive procedure that adds, the value of 2 is 2,
# and the value of 3 is 3. Then we call the addition procedure with 2 and 3 as
# arguments, yielding 5. For another example, take (- (+ 2 3) 1). Evaluating
# each subexpression gives the subtraction procedure, 5, and 1. Applying the
# procedure to the arguments gives 4.
#
# We'll see all the primitive procedures in the next section. A user-defined
# procedure is represented as a list of the form (lambda <parameters> <body>),
# such as (lambda (x) (+ x 1)). To apply such a procedure, evaluate its body
# in the environment obtained by extending the current environment so that the
# parameters are bound to the corresponding arguments. Thus, to apply the above
# procedure to the argument 41, evaluate (+ x 1) in the same environment as the
# current one except that x is bound to 41.
#
# If the procedure's body has more than one expression -- e.g.,
# (lambda () (write 'Hello) (write 'world!)) -- evaluate them each in turn, and
# return the value of the last one.
#
# We still need the rules for special forms. They are:
#
# The value of (quote <x>) is <x>. There's a shorthand for this form: '<x>.
# E.g., the value of '(+ 2 2) is (+ 2 2), -not- 4.
#
# (lambda <parameters> <body>) returns itself: e.g., the value of (lambda (x) x)
# is (lambda (x) x).
#
# To evaluate (if <test-expr> <then-exp> <else-exp>), first evaluate <test-expr>.
# If the value is true (non-nil), then return the value of <then-exp>, otherwise
# return the value of <else-exp>. (<else-exp> is optional; if it's left out,
# pretend there's a nil there.) Example: (if nil 'yes 'no) returns no.
#
# To evaluate (begin <expr-1> <expr-2>...), evaluate each of the subexpressions
# in order, returning the value of the last one.
#
# To evaluate (while <test> <expr-1> <expr-2>...), first evaluate <test>. If
# it's nil, return nil. Otherwise, evaluate <expr-1>, <expr-2>,... in order,
# and then repeat.
#
# To evaluate (set! <variable> <expr>), evaluate <expr>, and then set the value
# of <variable> in the current environment to the result. If the variable is
# currently unbound, that's an error. The value of the whole set! expression
# is the value of <expr>.
#
# (define <variable> <expr>) is like set!, except it's used to introduce new
# bindings, and the value returned is <variable>.
#
# It's possible to define new special forms using the macro facility provided in
# the startup file. The macros defined there are:
#
# (let ((<var> <expr>)...)
# <body>...)
#
# Bind each <var> to its corresponding <expr> (evaluated in the current
# environment), and evaluate <body> in the resulting environment.
#
# (cond (<test-expr> <result-expr>...)... (else <result-expr>...))
#
# where the final else clause is optional. Evaluate each <test-expr> in
# turn, and for the first non-nil result, evaluate its <result-expr>. If
# none are non-nil, and there's no else clause, return nil.
#
# (and <expr>...)
#
# Evaluate each <expr> in order, until one returns nil; then return nil.
# If none are nil, return the value of the last <expr>.
#
# (or <expr>...)
#
# Evaluate each <expr> in order, until one returns non-nil; return that value.
# If all are nil, return nil.
#
#
# 4. Built-in procedures
#
# List operations:
# (null? <x>) returns true (non-nil) when <x> is nil.
# (atom? <x>) returns true when <x> is an atom.
# (pair? <x>) returns true when <x> is a pair.
# (car <pair>) returns the car of <pair>.
# (cdr <pair>) returns the cdr of <pair>.
# (cadr <pair>) returns the car of the cdr of <pair>. (i.e., the second element.)
# (cddr <pair>) returns the cdr of the cdr of <pair>.
# (cons <x> <y>) returns a new pair whose car is <x> and whose cdr is <y>.
# (list <x>...) returns a list of its arguments.
# (set-car! <pair> <x>) changes the car of <pair> to <x>.
# (set-cdr! <pair> <x>) changes the cdr of <pair> to <x>.
# (reverse! <list>) reverses <list> in place, returning the result.
#
# Numbers:
# (number? <x>) returns true when <x> is a number.
# (+ <n> <n>) returns the sum of its arguments.
# (- <n> <n>) returns the difference of its arguments.
# (* <n> <n>) returns the product of its arguments.
# (quotient <n> <n>) returns the quotient. Rounding is towards zero.
# (remainder <n> <n>) returns the remainder.
# (< <n1> <n2>) returns true when <n1> is less than <n2>.
#
# I/O:
# (write <x>) writes <x> followed by a space.
# (newline) writes the newline character.
# (read) reads the next expression from standard input and returns it.
#
# Meta-operations:
# (eval <x>) evaluates <x> in the current environment, returning the result.
# (apply <proc> <list>) calls <proc> with arguments <list>, returning the result.
#
# Miscellany:
# (eq? <x> <y>) returns true when <x> and <y> are the same object. Be careful
# using eq? with lists, because (eq? (cons <x> <y>) (cons <x> <y>)) is false.
# (put <x> <y> <z>)
# (get <x> <y>) returns the last value <z> that was put for <x> and <y>, or nil
# if there is no such value.
# (symbol? <x>) returns true when <x> is a symbol.
# (gensym) returns a new symbol distinct from all symbols that can be read.
# (random <n>) returns a random integer between 0 and <n>-1 (if <n> is positive).
# (error <x>...) writes its arguments and aborts with error code 1.
#
#
# 5. References
#
# Harold Abelson and Gerald J. Sussman, with Julie Sussman.
# Structure and Interpretation of Computer Programs. MIT Press, 1985.
#
# John Allen. Anatomy of Lisp. McGraw-Hill, 1978.
#
# Daniel P. Friedman and Matthias Felleisen. The Little LISPer. Macmillan, 1989.
#
# Roger Rohrbach wrote a Lisp interpreter, in old awk (which has no
# procedures!), called walk . It can't do as much as this Lisp, but it
# certainly has greater hack value. Cooler name, too. It's available at
# http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/impl/awk/0.html
#
#
# 6. Bugs
#
# Eval doesn't check the syntax of expressions. This is a probably-misguided
# attempt to bump up the speed a bit, that also simplifies some of the code.
# The macroexpander in the startup file would be the best place to add syntax-
# checking.
# --- 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);
}
Reference in New Issue View Git Blame Copy Permalink