653 lines
19 KiB
Plaintext
653 lines
19 KiB
Plaintext
|
#!/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 (defined $protected{$p}) { 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);
|
||
|
|
}
|