Shareware Grab Bag/Shareware Grab Bag.iso/050/lisp.pas

Pascal/Delphi Source File | 1985-05-27 | 22.9 KB | 831 lines

program LISP;

{
  The essence of a LISP Interpreter.
  written by W. Taylor and L. Cox
  First date started : 10/29/76
  Last date modified : 12/10/76
  Modified for TURBO by R. Stearns, M. Covington
  Date started       : 05/21/85
  Date finished      : 05/21/85
  Modified for readability by R. Stearns
  Date started       : 05/22/85
  Date finished      :
}

const
     maxnode = 1000;

type
     longstr       = string[255];
     inputsymbol   = (atom, period, lparen, rparen);
     reservedwords =
         (replacehsym, replacetsym, headsym, tailsym, eqsym, quotesym,
          atomsym, condsym, labelsym, lambdasym, copysym, appendsym, concsym,
          conssym);
     statustype    = (unmarked, left, right, marked);
     symbexpptr    = ^symbolicexpression;
     alfa          = array [1 .. 10] of char;
     symbolicexpression = record
          status : statustype;
          next   : symbexpptr;
          case anatom  : boolean of
                 true  : (name : alfa;
                          case isareservedword : boolean of
                               true : (ressym : reservedwords));
                 false : (head, tail : symbexpptr)
          end;
{
  Symbolicexpression is the record structure used
  to implement a LISP list.  This record has a tag
  field 'anatom' which tells which kind of node
  a particular node represents (i.e. an atom or
  a pair of pointers 'head' and 'tail').
  'Anatom' is always checked before accessing
  either the name field or the head and tail
  fields of a node.  Two pages ahead there are
  three diagrams which should clarify the data
  structure.
}

{            T h e  g l o b a l  v a r i a b l e s                           }

var

{  Variables which pass information from the scanner to the read routine.    }

  lookaheadsym,                {  used to save a symbol when we back up      }
  sym           : inputsymbol; {  the symbol that was last scanned           }
  id            : alfa;        {  name of atom that was last read            }
  alreadypeeked : boolean;     {  tells 'nextsym' whether we haved peeked    }
  ch            : char;        {  the last character read from input         }
  curline       : longstr;     {  the current input line                     }
  ptr           : symbexpptr;  {  the pointer to expression being evaluated  }

         {  the global lists of LISP nodes  }
  freelist,                    {  pointer to the linear list of free nodes   }
  nodelist,                    {  pointer used to make a linear scan of all  }
                               {  the nodes during garbage collection        }
  alist         : symbexpptr;  {                                             }

{  two nodes which have constant values                                      }

  nilnode,
  tnode         : symbolicexpression;

{  variables used to identify atoms with pre-defined meanings                }

  resword       : reservedwords;
  reserved      : boolean;
  reswords      : array [reservedwords] of alfa;
  freenodes     : integer;     {  number of currently free nodes known      }
  numberofgcs   : integer;     {  number of garbage collections made        }

{  The function trim and procedure getch provided to circumvent some of the }
{  peculiarities of TURBO Pascal terminal I/O                               }

{  This function returns its argument with all trailing blanks removed      }

function trim(s: longstr) : longstr;

var
     i     : integer;

begin
     i := length(s);
     while((i>0) and (s[i]=' ')) do i := i-1;
     trim := copy(s,1,i);
end;

{  This procedure returns, in ch, the next character of input from the kbd  }

procedure getch(var ch : char);

begin
     while (curline='') do begin
          write('? ');
          readln(curline);
          curline := trim(curline)+' ';
     end;
     ch := upcase(curline[1]);
     curline := copy(curline,2,length(curline)-1);
end;

procedure garbageman;

  procedure mark(list : symbexpptr);

    var
      father, son, current : symbexpptr;

    begin
      father := nil;
      current := list;
      son := current;
      while current <> nil do
        with current^ do
          case status of
            unmarked:
              if anatom  then  status := marked
              else
                if (head^.status <> unmarked) or (head = current)
                then
                  if (tail^.status <> unmarked) or (tail = current)
                  then status := marked
                  else
                    begin
                      status := right;
                      son := tail;
                      tail := father;
                      father := current;
                      current := son
                    end
                else
                  begin
                    status := left;
                    son := head;
                    head := father;
                    father := current;
                    current := son
                  end;
            left:
              if tail^.status <> unmarked
              then
                begin
                  status := marked;
                  father := head;
                  head := son;
                  son := current
                end
              else
                begin
                  status := right;
                  current := tail;
                  tail := head;
                  head := son;
                  son := current
                end;
            right:
              begin
                status := marked;
                father := tail;
                tail := son;
                son := current
              end;
            marked:  current := father
          end { case }
        end; { mark }

        procedure collectfreenodes;

          var
            temp : symbexpptr;

          begin
            writeln(' Number of nodes before collection = ', freenodes:1,'.');
            freelist := nil;
            freenodes := 0;
            temp := nodelist;
            while temp <> nil do
              begin
                if temp^.status <> unmarked then temp^.status := unmarked
                else
                  begin
                    freenodes := freenodes + 1;
                    temp^.head := freelist;
                    freelist := temp
                  end;
                temp := temp^.next
              end;
            writeln(' Number of nodes after collection = ', freenodes:1,'.');
          end;  { collectfreenodes  }

  begin  { garbageman }
    numberofgcs := numberofgcs + 1;
    writeln;
    writeln(' Garbage collection. ');
    writeln;
    mark(alist);
    if ptr <> nil then mark(ptr);
    collectfreenodes
  end;  { grabageman }

procedure pop(var sptr : symbexpptr);

  begin
    if freelist = nil then
      begin
        writeln(' Not enough space to evaluate the expression.');
      end;
    freenodes := freenodes - 1;
    sptr := freelist;
    freelist := freelist^.head
  end; { pop }


{  i n p u t  /  o u t p u t  u t i l i t y  r o u t i n e s   }

procedure error(numbers : integer);

  begin
    writeln;
    write(' Error   ',numbers:1,',');
    case numbers of
      1 : writeln(' atom or lparen expected in the s-expr.');
      2 : writeln(' atom, lparen, or rparen expected in the s-expr.');
      3 : writeln(' label and lambda are not names of functions.');
      4 : writeln(' rparen expected in the s-expr.');
      5 : writeln(' 1st argument of replaceh is an atom.');
      6 : writeln(' 1st argument of replacet is an atom.');
      7 : writeln(' argument of head is an atom.');
      8 : writeln(' argument of tail is an atom.');
      9 : writeln(' 1st argument of append is not a list.');
     10 : writeln(' comma or rparen expected in concatenate.');
     11 : writeln(' end of file encountered before a "fin" card.');
     12 : writeln(' lambda or label expected.')
    end;  { case }
    halt;
  end;  { error }

{
  procedure backupinput puts a left parenthesis
  into the stream of input symbols.  this makes
  procedure readexpr easier than it otherwise
  would be.
}

procedure backupinput;

  begin
    alreadypeeked := true;
    lookaheadsym := sym;
    sym := lparen
  end;  { backupinput }

procedure nextsym;

  var
    i : integer;

  begin
    if alreadypeeked then
      begin
         sym := lookaheadsym;
         alreadypeeked := false
      end
    else
      begin
        while ch = ' ' do getch(ch);
        if ch in ['(','.',')'] then
          begin
            case ch of
               '(' : sym := lparen;
               '.' : sym := period;
               ')' : sym := rparen
            end; { case }
            getch(ch);
          end
        else
          begin
            sym := atom;
            id := '          ';
            i := 0;
            repeat
              i := i + 1;
              if i < 11 then id[i] := ch;
              getch(ch);
            until ch in [' ', '(', '.', ')'];
            resword := replacehsym;
            while (id <> reswords[resword]) and (resword <> conssym) do
              resword := succ(resword);
            reserved := (id = reswords[resword])
          end
        end
  end;  { nextsym }

procedure readexpr(var sptr : symbexpptr);

  var
    nxt : symbexpptr;

  begin
    pop(sptr);
    nxt := sptr^.next;
    case sym of
      rparen,
      period  : error(1);
      atom    : with sptr^ do
          begin  { <atom> }
            anatom := true;
            name := id;
            isareservedword := reserved;
            if reserved then ressym := resword
          end;
      lparen : with sptr^ do
          begin
            nextsym;
            if sym = period then error(2)
            else
              if sym = rparen then sptr^ := nilnode  {  () = nil }
              else
                begin
                  anatom := false;
                  readexpr(head);
                  nextsym;
                  if sym = period then
                    begin
                      nextsym;
                      readexpr(tail);
                      nextsym;
                      if sym <> rparen then error(4)
                    end
                  else
                    begin  {  (<s-expr> <s-expr> ... <s-expr> )  }
                      backupinput;
                      readexpr(tail)
                    end
                 end
          end { with }
       end;  { case }
       sptr^.next := nxt
  end; { readexpr }

procedure printname(name : alfa);
{
  procedure printname prints the name of
  an atom with one trailing blank.
}

var
  i : integer;

begin
  i := 1;
  repeat
    write(name[i]);
    i := i + 1;
  until (name[i] = ' ') or (i = 11);
  write(' ')
end; { printname }

procedure printexpr(sptr : symbexpptr);
{
  The algorithm for this procedure was provided by
  Weissman's LISP 1.5 primer, p 125.  This procedure
  prints the symbolic expression pointed to by the
  argument 'sptr' in the LISP list notation.
}

label
  1;

begin
  if sptr^.anatom then printname(sptr^.name)
  else
    begin
      write('(');
    1: with sptr^ do
         begin
           printexpr(head);
           if tail^.anatom and (tail^.name = 'NIL       ')
           then write(')')
           else
             if tail^.anatom then
               begin
                  write('.');
                  printexpr(tail);
                  write(')')
               end
             else
               begin
                  sptr := tail;
                  goto 1
               end
         end
     end
end; { printexpr }

{         e n d  o f  i / o  u t i l i t y  r o u t i n e s        }

{      T h e  e x p r e s s i o n  e v a l u a t e r  e v a l      }

function eval(e, alist : symbexpptr) : symbexpptr;
{
     evaluate 'e' using the association list 'alist'

     (lambda (e alist)
       cond
         ((atom e) (lookup e alist))
         ((atom (car e))
            (cond ((eq (car e) (quote quote))
                (cadr e))
              ((eq (car e) (quote atom))
                (atom (eval (cadr e) alist)
              ((eq (car e) (quote eq))
                (eq (eval (cadr e) alist)))
              ((eq (car e) (quote car))
                (car (eval (cadr e) alist)))
              ((eq (car e) (quote cdr))
                (cdr (eval (cadr e) alist)))
              ((eq (car e) (quote cons)
                (cons (eval (cadr e) alist)
                  (eval (caddr e) alist)
              ((eq (car e) (quote cond)
                (evcon (cdr e))
              (t (eval (cons (lookup (car e) alist)
                (cdr e)) alist)))
              ((eq (caar e) (quote label))
                (eval (cons (caddar e)
                (cdr e)
                (cons (cons (cadar e) (car e))
                  alist) ))
             ((eq (caar e) (quote lambda))
               (eval (caddr e)
                 (bindargs (cadar e) (cdr e) )))))

      The resulting Pascal code follows:
}

var
  temp,
  carofe,
  caarofe      : symbexpptr;

{
  The first ten of the following local functions implement
  ten LISP primitives.  The last three are used by eval.
}

  function replaceh(sptr1, sptr2 : symbexpptr) : symbexpptr;

    begin
      if sptr1^.anatom then error(5)  else sptr1^.head := sptr2;
      replaceh := sptr1
    end;  { replaceh }

  function replacet(sptr1, sptr2 : symbexpptr) : symbexpptr;

    begin
      if sptr1^.anatom then error(6)  else sptr1^.tail := sptr2;
      replacet := sptr1
    end;  { replacet }

  function head(sptr : symbexpptr) : symbexpptr;

    begin
      if sptr^.anatom  then error(7)  else head := sptr^.head
    end;  { head }

  function tail(sptr : symbexpptr) : symbexpptr;

    begin
      if sptr^.anatom then error(8)  else  tail := sptr^.tail
    end;  { tail }

  function cons(sptr1, sptr2 : symbexpptr) : symbexpptr;

    var
      temp : symbexpptr;

    begin
      pop(temp);
      temp^.anatom := false;
      temp^.head := sptr1;
      temp^.tail := sptr2;
      cons := temp
    end;  { cons }

  function copy(sptr : symbexpptr) : symbexpptr;

  {
     This function creates a copy of the structure
     pointed to by the parameter 'sptr'
  }

  var
    temp,
    nxt          : symbexpptr;

  begin
    if sptr^.anatom then
      begin
        pop(temp);
        nxt := temp^.next;
        temp^ := sptr^;
        temp^.next := nxt;
        copy := temp
      end
    else  copy := cons(copy(sptr^.head), copy(sptr^.tail))
  end;  { copy }

  function append(sptr1, sptr2 : symbexpptr) : symbexpptr;

  {
      The recursive algorithym is from Weissman, p. 97.
  }

  begin
    if sptr1^.anatom then
      if sptr1^.name <> 'NIL       ' then error(9)
      else  append := sptr2
    else
      append := cons(copy(sptr1^.head), append(sptr1^.tail, sptr2))
  end; { append }

  function conc(sptr1 : symbexpptr) : symbexpptr;

  var
    sptr2,
    nilptr        : symbexpptr;

  begin
    if sym <> rparen then
      begin
        nextsym;
        readexpr(sptr2);
        nextsym;
        conc := cons(sptr1, conc(sptr2));
      end
    else
      if sym = rparen then
          begin
            new(nilptr);
            with nilptr^ do begin
               anatom := true;
               name := 'NIL       '
               end;
            conc := cons(sptr1, nilptr);
          end
      else error(10)
  end;  { conc }

  function eqq(sptr1, sptr2 : symbexpptr) : symbexpptr;

  var
    temp,
    nxt         : symbexpptr;

  begin
    pop(temp);
    nxt := temp^.next;
    if sptr1^.anatom and sptr2^.anatom then
      if sptr1^.name = sptr2^.name  then temp^ := tnode
      else temp^ := nilnode
    else
      if sptr1 = sptr2  then temp^ := tnode
      else temp^ := nilnode;
    temp^.next := nxt;
    eqq := temp
  end; { eqq }

  function atom(sptr : symbexpptr) : symbexpptr;

  var
    temp,
    nxt       : symbexpptr;

  begin
    pop(temp);
    nxt := temp^.next;
    if sptr^.anatom  then temp^ := tnode  else temp^ := nilnode;
    temp^.next := nxt;
    atom := temp
  end; { atom }

  function lookup(key, alist : symbexpptr) : symbexpptr;

  var
    temp : symbexpptr;

  begin
    temp := eqq(head(head(alist)), key);
    if temp^.name = 'T         ' then lookup := tail(head(alist))
    else lookup := lookup(key, tail(alist))
  end;  { lookup }

  function bindargs(names, values : symbexpptr) : symbexpptr;

  var
    temp, temp2 : symbexpptr;

  begin
    if names^.anatom and (names^.name = 'NIL       ')
    then bindargs := alist
    else
      begin
        temp := cons(head(names), eval(head(values), alist));
        temp2 := bindargs(tail(names), tail(values));
        bindargs := cons(temp, temp2)
      end
  end; { bindargs }

  function evcon(condpairs : symbexpptr) : symbexpptr;

  var
    temp : symbexpptr;

  begin
    temp := eval(head(head(condpairs)), alist);
    if temp^.anatom and (temp^.name = 'NIL       ')
       then evcon := evcon(tail(condpairs))
       else evcon := eval(head(tail(head(condpairs))), alist)
  end; { evcon }

begin {        e v a l        }
  if e^.anatom then eval := lookup(e, alist)
  else begin
     carofe := head(e);
     if carofe^.anatom then
        if not carofe^.isareservedword then
          eval := eval(cons(lookup(carofe, alist), tail(e)), alist)
        else
          case carofe^.ressym of
            labelsym,
            lambdasym   : error(3);
            quotesym    : eval := head(    tail(e)                         );
            atomsym     : eval := atom(    eval(head(tail(e)),       alist));
            eqsym       : eval := eqq(     eval(head(tail(e)),       alist),
                                           eval(head(tail(tail(e))), alist));
            headsym     : eval := head(    eval(head(tail(e)),       alist));
            tailsym     : eval := tail(    eval(head(tail(e)),       alist));
            conssym     : eval := cons(    eval(head(tail(e)),       alist),
                                           eval(head(tail(tail(e))), alist));
            condsym     : eval := evcon(   tail(e)                         );
            appendsym   : eval := append(  eval(head(tail(e)),       alist),
                                           eval(head(tail(tail(e))), alist));
            replacehsym : eval := replaceh(eval(head(tail(e)),       alist),
                                           eval(head(tail(tail(e))), alist));
            replacetsym : eval := replacet(eval(head(tail(e)),       alist),
                                           eval(head(tail(tail(e))), alist));
         end  { case }
       else
         begin
           caarofe := head(carofe);
           if caarofe^.anatom and caarofe^.isareservedword then
             if not (caarofe^.ressym in [labelsym, lambdasym]) then error(12)
             else
               case caarofe^.ressym of
                 labelsym :
                   begin
                     temp := cons(cons(head(tail(carofe)),
                                       head(tail(tail(carofe)))), alist);
                     eval := eval(cons(head(tail(tail(carofe))), tail(e)),temp)
                    end;
                 lambdasym :
                   begin
                     temp := bindargs(head(tail(carofe)), tail(e));
                     eval := eval(head(tail(tail(carofe))), temp)
                   end
                end  { case }
              else
                eval := eval(cons(eval(carofe, alist), tail(e)), alist)
            end
          end
  end; { e v a l }

procedure initialize;

var
  i            : integer;
  temp,
  nxt          : symbexpptr;

begin
  alreadypeeked := false;
  curline := '';
  getch(ch);
  numberofgcs := 0;
  freenodes := maxnode;
  with nilnode do begin
      anatom := true;
      next := nil;
      name := 'NIL       ';
      status := unmarked;
      isareservedword := false
  end;
  with tnode do begin
      anatom := true;
      next := nil;
      name := 'T         ';
      status := unmarked;
      isareservedword := false
  end;

{ - - - - allocate storage and mark it free  }

  freelist := nil;
  for i := 1 to maxnode do begin
      new(nodelist);
      nodelist^.next := freelist;
      nodelist^.head := freelist;
      nodelist^.status := unmarked;
      freelist := nodelist;
  end;

{ - - - -  initialize reserved word table }

  reswords[replacehsym] := 'REPLACEH  ';
  reswords[replacetsym] := 'REPLACET  ';
  reswords[headsym]     := 'CAR       ';
  reswords[tailsym]     := 'CDR       ';
  reswords[copysym]     := 'COPY      ';
  reswords[appendsym]   := 'APPEND    ';
  reswords[concsym]     := 'CONC      ';
  reswords[conssym]     := 'CONS      ';
  reswords[eqsym]       := 'EQ        ';
  reswords[quotesym]    := 'QUOTE     ';
  reswords[atomsym]     := 'ATOM      ';
  reswords[condsym]     := 'COND      ';
  reswords[labelsym]    := 'LABEL     ';
  reswords[lambdasym]   := 'LAMBDA    ';

{ - - - -  initialize the a-list with t and nil  }

  pop(alist);
  alist^.anatom := false;
  alist^.status := unmarked;
  pop(alist^.tail);
  nxt := alist^.tail^.next;
  alist^.tail^ := nilnode;
  alist^.tail^.next := nxt;
  pop(alist^.head);

{ - - - -  bind nil to the atom nil  }

  with alist^.head^ do begin
      anatom := false;
      status := unmarked;
      pop(head);
      nxt := head^.next;
      head^ := nilnode;
      head^.next := nxt;
      pop(tail);
      nxt := tail^.next;
      tail^ := nilnode;
      tail^.next := nxt
  end;
  pop(temp);
  temp^.anatom := false;
  temp^.status := unmarked;
  temp^.tail := alist;
  alist := temp;
  pop(alist^.head);

{ - - - - bind t to the atom t }

  with alist^.head^ do begin
      anatom := false;
      status := unmarked;
      pop(head);
      nxt := head^.next;
      head^ := tnode;
      head^.next := nxt;
      pop(tail);
      nxt := tail^.next;
      tail^ := tnode;
      tail^.next := nxt
  end;
end; { initialize }

{ >>>>>>>>>>>>>>>  l i s p  <<<<<<<<<<<<<<<< }

begin
  writeln(' * EVAL * ');
  initialize;
  nextsym;
  readexpr(ptr);
  while not ptr^.anatom or (ptr^.name <> 'FIN       ') do begin
      writeln;
      writeln(' * Value * ');
      printexpr(eval(ptr, alist));
      writeln;
      writeln;
      ptr := nil;
      garbageman;
      writeln;
      writeln;
      writeln(' * EVAL * ');
      nextsym;
      readexpr(ptr);
      writeln;
  end;
  writeln;
  writeln;
  writeln(' Total number of garbage collections = ', numberofgcs:1,'.');
  writeln;
  writeln(' Free nodes left upon exit = ', freenodes:1,'.');
  writeln;
end. { lisp }









'.');
  writeln;
  writeln(' Free nodes left upon exit = ', freenodes:1,'.');
  write