perlisp

#!/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);
}