Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 653 lines (581 sloc) 20.1 KB
#!/usr/bin/perl
use FileHandle;
# --- Representation of Lisp data
$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";
sub is {
local($type, $expr)=@_;
if ($expr % 4 != $type) {
error(__LINE__,"Expected a ".$type_name{$type}.", not a "
. $type_name{$expr % 4}) ;
}
$expr;
}
sub is_number { local($expr)=@_; $expr % 4 == 0; }
sub is_pair { local($expr)=@_; $expr % 4 == 1; }
sub is_symbol { local($expr)=@_; $expr % 4 == 2; }
sub is_atom { local($expr)=@_; $expr % 4 != 1; }
sub make_number { local($n)=@_; $n * 4 ;}
sub numeric_value {
local($expr)=@_;
if ($expr % 4 != 0) { error(__LINE__,"Not a number"); }
$expr / 4;
}
# Make a new pair.
sub cons {
local($the_car, $the_cdr)= @_;
if ($free_list == $NIL) { gc($the_car, $the_cdr); }
$result = $free_list;
$free_list = $cdr{$free_list};
$car{$result} = $the_car;
$cdr{$result} = $the_cdr;
$result;
}
# Return the symbol :string names.
sub string_to_symbol{
local($string)=@_;
if (defined ($intern{$string}) ) { return $intern{$string}; }
$symbol_ptr += 4;
$intern{$string} = $symbol_ptr;
$printname{$symbol_ptr} = $string;
$symbol_ptr;
}
# Define a primitive procedure, with :nparams parameters,
# bound to the symbol named :name.
sub def_prim {
local($name, $nparams)=@_;
local($sym);
$sym = string_to_symbol($name);
$value{$sym} = string_to_symbol(sprintf("#<Primitive %s>", $name));
if ($nparams ne "") {
$num_params{$value{$sym}} = $nparams; }
$value{$sym};
}
# --- Garbage collection
sub expand_heap {
local($limit);
if ($loud_gc) {
printf STDERR "Expanding heap..." ; }
$limit = $pair_ptr + 4 * ($heap_increment ? $heap_increment : 1500);
for (; $pair_ptr < $limit; $pair_ptr += 4) {
$cdr{$pair_ptr} = $free_list;
$free_list = $pair_ptr;
}
}
sub protect { local($object)=@_; $protected{++$protected_ptr} = $object; }
sub unprotect { --$protected_ptr; }
sub mark {
local($object)=@_;
while (is_pair($object) && !(defined $marks{$object})) { #** speed
$marks{$object} = 1;
mark($car{$object});
$object = $cdr{$object};
}
}
sub sweep {
$free_list = $NIL;
for ($p = $a_pair; $p < $pair_ptr; $p += 4) { # for defined($car{$p}) might be faster
if (!(defined $marks{$p})) {
$cdr{$p} = $free_list;
$free_list = $p;
} else {
delete $marks{$p};
}
}
}
sub gc {
local ($the_car, $the_cdr) = @_;
local($p, $i);
if ($loud_gc) {
printf STDERR "\nGC..." }
mark($the_car); mark($the_cdr);
for ($p = 1; $p <= $protected_ptr; ++$protected_ptr) { mark($protected{$p}); }
for (defined $stack{$p}) { mark($stack{$p}); }
for (defined $value{$p}) { mark($value{$p}); }
for (defined $property{$p}) {
$i = index($;, $p); # SUBSEP
mark(substr($p, 1, $i-1));
mark(substr($p, $i+1));
mark(property{$p});
}
sweep();
if ($free_list == $NIL) { expand_heap(); }
}
# --- Set up
# BEGIN {
$trace = 0;
$lineno = 0;
$filehandle = \*STDIN;
$filename = '<STDIN>';
$interactive = 1;
@filestack = ();
$pline = "**prev**";
$sline = "**BOF**";
$gensym_counter=0;
srand();
$token = "";
$frame_ptr = $stack_ptr = 0;
$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...;
$free_list = $NIL; expand_heap();
$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;
$QUIT = string_to_symbol("quit"); $is_special{$QUIT} = 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);
$LREAD = def_prim("read", 0);
$LWRITE = def_prim("write", 1);
$LOAD = def_prim('load', 1);
$TRACE = def_prim('trace', 0);
$LINENO = def_prim('f_lineno', 0);
$INTER = def_prim('f_interactive', 0);
$FILE = def_prim('f_file', 0);
$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");
$EXPLODE = def_prim("explode");
$IMPLODE = def_prim("implode");
$OPEN = def_prim("open");
$CLOSE = def_prim("close");
$READCHAR = def_prim("readchar");
$WRITEFI = def_prim("writefi");
$PRINTF = def_prim("printf");
$HASH = def_prim("hash");
$DRIVER = string_to_symbol("top-level-driver");
# }
# --- The interpreter
# BEGIN {
$ts = "testme";
if ( -f $ts ) { load($ts); }
$rc = "$ENV{'HOME'}/.perlisprc";
if ( -f $rc ) { load($rc); }
READLOOP: for (;;) {
eval {
for (;;) {
if (defined($value{$DRIVER}) && $value{$DRIVER} != $NIL) {
apply($value{$DRIVER});
} else {
$expr = lread();
if ($trace) {
print_expr($expr);
print "%$expr%\n"; }
if ($expr == $THE_EOF_OBJECT) { last READLOOP; }
protect($expr);
$result = l_eval($expr);
if ($interactive) { print "Interactive p e\n "; print_expr($result); }
unprotect();
}
}
};
print "\n\nRestarting\n\n";
$frame_ptr = $stack_ptr = 0;
}
if ($profiling) {
while (defined $call_count{$proc}) {
printf "%5d ", $call_count{$proc} ;
print_expr($proc);
}
}
# }
# All the interpretation routines have the precondition that their
# arguments are protected from garbage collection.
sub l_eval {
local($expr)=@_;
local($old_frame_ptr);
if (is_atom($expr)) { #** speed
if (is_symbol($expr)) {
if (!(defined $value{$expr} )) {
error(__LINE__,"Unbound variable: ".$printname{$expr}); }
return $value{$expr};
} else {
return $expr;
}
}
$op = $car{$expr}; # op is global to save awk stack space
if ($trace) { print "eval called ".$printname{$op}.
" with ". ($stack_ptr - $frame_ptr) ." args" . "\n"; }
if (!(defined $is_special{$op})) {
$old_frame_ptr = $frame_ptr;
$frame_ptr = $stack_ptr;
l_eval_rands($cdr{$expr});
protect($tmp_proc = l_eval($car{$expr}));
$result = apply($tmp_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 ( l_eval($car{$cdr{$expr}}) != $NIL )
? l_eval($car{$cdr{$cdr{$expr}}})
: l_eval($car{$cdr{$cdr{$cdr{$expr}}}}); };
if ($op == $PROGN) { return progn($cdr{$expr}); };
if ($op == $SETQ) {
if (! defined( $value{$car{$cdr{$expr}}} )) {
error(__LINE__,"Unbound variable: ".$printname{$car{$cdr{$expr}}});
}
return $value{$car{$cdr{$expr}}} = l_eval($car{$cdr{$cdr{$expr}}});
};
if ($op == $WHILE) {
while (l_eval($car{$cdr{$expr}}) != $NIL) {
progn($cdr{$cdr{$expr}});
}
return $NIL
}
if ($op == $DEFINE) {
$value{$car{$cdr{$expr}}} = l_eval($car{$cdr{$cdr{$expr}}});
return $car{$cdr{$expr}};
}
if ($op == $QUIT) { exit(); }
error(__LINE__,"BUG: Unknown special form");
}
sub progn {
local ($exprs) = @_;
for (; $cdr{$exprs} != $NIL; $exprs = $cdr{$exprs}) {
l_eval($car{$exprs});
}
return l_eval($car{$exprs});
}
sub l_eval_rands {
local ($rands) = @_;
for (; $rands != $NIL; $rands = $cdr{$rands}) {
$stack[$stack_ptr++] = l_eval($car{$rands});
}
}
sub apply {
local ($proc) = @_;
if ($profiling) {
++$call_count[$proc];
}
if (is_pair($proc) && $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 (defined($num_params{$proc}) &&
$num_params{$proc} != $stack_ptr - $frame_ptr) {
error(__LINE__,'Wrong number of arguments to '.$printname{$cdr{$proc}}); }
if ($trace) { print "Proc called ".$printname{$cdr{$proc}}.
" with ". ($stack_ptr - $frame_ptr) ." args" . "\n"; }
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}
# what does this mean? a list of args to property.
if ($proc == $GET) { return
defined( $property{$stack[$frame_ptr], $stack[$frame_ptr+1]} ) ?
$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() }
if ($proc == $EVAL) { return l_eval($stack[$frame_ptr]) }
if ($proc == $NREV) { return nreverse($stack[$frame_ptr], $NIL)}
if ($proc == $LWRITE) { lwrite_expr($stack[$frame_ptr]);
printf(" "); { return $NIL }}
if ($proc == $NEWLINE) { printf("\n"); return $NIL ; }
if ($proc == $LREAD) { return lread(); }
# source file handling functions
if ($proc == $LOAD) { $xyz = load($printname{$stack[$frame_ptr]});
return make_number($xyz); }
if ($proc == $INTER) { return($interactive ? $T : $NIL); }
if ($proc == $FILE) { return string_to_symbol($filename); }
if ($proc == $LINENO) { return make_number(($lineno)+1); }
if ($proc == $TRACE) { if ($trace) { $trace = 0;}
else { $trace = 1; } return $NIL; }
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(__LINE__,'Unknown procedure type');
}
sub load {
local($file) = @_;
local($err);
$hand = new FileHandle;
$err=open($hand,"<$file");
if ($err <= 0 ) { return $err; }
push @filestack, $filename;
push @filestack, $filehandle;
push @filestack, $lineno;
push @filestack, $sline;
push @filestack, $pline;
push @filestack, $interactive;
$lineno = 0;
$filehandle = $hand;
$filename = $file;
$interactive = 0;
$pline = "";
}
sub endfile {
$interactive = pop @filestack;
$pline = pop @filestack;
$sline = pop @filestack;
$lineno = pop @filestack;
$filehandle = pop @filestack;
$filename = pop @filestack;
}
sub do_apply {
local($old_frame_ptr, $proc, $args) = @_;
$proc = $stack[$frame_ptr];
$args = $stack[$frame_ptr+1];
$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(__LINE__,"Bad argument to APPLY: not a proper list"); }
$result = apply($proc);
$stack_ptr = $frame_ptr;
$frame_ptr = $old_frame_ptr;
return $result;
}
sub listify_args {
local($p, $result)= @_;
$result = $NIL;
for ($p = $stack_ptr - 1; $frame_ptr <= $p; --$p) {
$result = cons($stack[$p], $result);
}
return $result;
}
# --- The environment
# Clobbers the stack frame.
sub extend_env {
local( $vars ) = @_; local($p, $temp);
for ($p = $frame_ptr; $vars != $NIL; $vars = $cdr{$vars}) {
if ($p == $stack_ptr) {
error(__LINE__,"Too many arguments to procedure");
}
$temp = $value{$car{$vars}};
$value{$car{$vars}} = $stack[$p];
$stack[$p] = $temp;
++$p;
}
if ($p != $stack_ptr) {
error(__LINE__,"Not enough arguments to procedure");
}
}
sub unwind_env {
local ($vars, $p) = @_;
for ($p = $frame_ptr; $vars != $NIL; $vars = $cdr{$vars}) {
if (!defined ($stack[$p])) {
delete $value{$car{$vars}};
} else {
$value{$car{$vars}} = $stack[$p];
}
++$p;
}
}
# --- Output
sub print_expr {
local($expr)=@_;
lwrite_expr($expr);
print "\n";
}
sub lwrite_expr {
local($expr) = @_;
if (is_atom($expr)) {
if (!is_symbol($expr)) {
printf("%d", numeric_value($expr));
} else {
if (!(defined($printname{$expr}))) {
error(__LINE__,"BUG: ". $expr." has no printname");
}
printf("%s", $printname{$expr});
}
} else {
printf("(");
lwrite_expr($car{$expr});
for ($expr = $cdr{$expr}; is_pair($expr); $expr = $cdr{$expr}) {
printf(" ");
lwrite_expr($car{$expr});
}
if ($expr != $NIL) {
printf(" . ");
lwrite_expr($expr);
}
printf(")");
}
}
# --- Input
sub lread {
# my (@a);
# foreach $i (@-) {
# print '@'; lwrite_expr($i); print '@';
# }
# @a=do_lread(@_);
# foreach $i (@a) {
# print '#'; lwrite_expr($i); print '#';
# }
# return (@a);
# }
# sub do_lread {
local($committed, $result) = @_;
skip_blanks();
if ($token eq $eof) {
if ($committed) {
error(__LINE__,"Unexpected EOF");
} else {
return $THE_EOF_OBJECT;
}
}
if ($token eq "(") { # lread a list
advance();
$result = $NIL;
for (;;) {
skip_blanks();
if ($token eq ".") {
advance();
$after_dot = lread(1);
skip_blanks();
if ($token ne ")") {
error(__LINE__,"')' expected");
}
advance();
return nreverse($result, $after_dot);
} elsif ($token eq ")" ) {
advance();
return nreverse($result, $NIL);
} else {
protect($result);
$result = cons(lread(1), $result);
unprotect()
}
}
} elsif ($token eq "'") { # a quoted expression
advance();
return cons($QUOTE, cons(lread(1), $NIL));
} elsif ($token =~ /^-?[0-9]+$/) { # a number
$result = make_number($token);
advance();
return $result;
} else { # a symbol
if ($trace) { print "A symbol $token\n"; }
$result = string_to_symbol($token);
advance();
return $result;
}
}
sub skip_blanks {
while ($token =~ /^[ \t]*$/) {
advance();
}
}
#
sub advance {
if ($token eq $eof) { return $eof; }
if ($token eq "") {
RLOOP: for (;;) {
$lineno++;
if ( $interactive && ( ! defined($value{$DRIVER}) ) ) {
print "$lineno> "; }
$pline = $sline;
if ( ($line = <$filehandle> ) ne "" ) { last RLOOP; }
if (@filestack > 0) { endfile(); }
else {
$token = $eof;
return;
}
}
chop $line;
$sline = $line;
}
if ( ($line =~ /^[(\)'.]/ ) ||
($line =~/^[_A-Za-z0-9\.=!\@\$%&\*<>\?\+\\\-\/\:]+/) ||
($line =~ /^[ \t]+/)) {
$token = substr($line, length($`), length($&));
$line = substr($line, length($&));
} elsif ($line eq "" || substr($line, 0, 1) eq ";") {
$token = ""; # this kludge permits interactive use
} else {
error(__LINE__,"Lexical error starting at ".$line);
}
if ($trace) { print ":$token:"; flush STDOUT; }
}
# --- Miscellany
# Destructively reverse :list and append :reversed_head.
sub nreverse {
local($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(__LINE__,"Not a proper list - reverse!");
}
return $reversed_head;
}
sub error {
local($line,$reason)=@_;
print STDERR "Error $line \t: file-$filename line-$lineno $reason:\n";
print STDERR " \t: $pline\n";
print STDERR " near $token\t: $sline\n";
$token="";
die($reason);
}