!***********************************************************************
!*
!*                            LISP for EMAS
!*
!*                 Edinburgh Regional Computing Centre
!*
!*        Updated by R.D. Eager   University of Kent   MCMLXXXII
!*
!***********************************************************************
!
!
!***********************************************************************
!*
!*          Constants
!*
!***********************************************************************
!
%constantinteger no = 0, yes = 1
%constantinteger setup = 1,instream = 2,outstream = 3
%constantinteger ssdatafiletype = 4;    ! Subsystem file type
%constantinteger marker = m'LISP';      ! Marker at the front of LISP machine files
%constantinteger default line length = 80
                                        ! For formatting output
%constantinteger maxlevel = 15
%constantinteger long base = 256
%constantinteger long tail = 511
%constantinteger name base = 512
%constantinteger name tail = 2047
%constantinteger stack base = 1024
%constantinteger stack tail = 2047
%constantinteger short base = 2048
%constantinteger short tail = 4095
%constantinteger list base = 4096
%constantinteger list tail = x'7fff'
%constantinteger atom base = 256
%constantinteger char base = 1919
%constantinteger zero base = 3072
%constantinteger pname max = 8191
%constantinteger t = 2003
%constantinteger percent = 1956
%constantinteger nil = 512
%constantinteger quote = 513
%constantinteger label = 514
%constantinteger lambda = 515
%constantinteger apval = 516
%constantinteger subr = 517
%constantinteger fsubr = 518
%constantinteger expr = 519
%constantinteger fexpr = 520
%constantinteger exit = 521
%constantinteger evln = x'8000'!522
%constantinteger stars = 523
%constantinteger error = 0
%constantinteger error1 = 1
%constantinteger error2 = 2
%constantinteger error3 = 3
%constantinteger escape = x'88',eof = x'89'
%constantbyteintegerarray mask(apval:fexpr) =  3, 4!2, 2, 4!1, 1
%constantbyteintegerarray code(0:127) = %c
x'80', x'80', x'80', x'80', x'80', x'80', x'80', x'80',
x'80', x'80', x'80', x'80', x'80', x'80', x'80', x'80',
x'80', x'80', x'80', x'80', x'80', x'80', x'80', x'80',
x'80',   eof, x'80', x'80', x'80', x'80', x'80', x'80',
x'80', x'21', x'22', x'23',escape, x'25', x'26', x'84',
x'81', x'83', x'2a', x'2b', x'2c', x'2d', x'82',escape,
x'30', x'31', x'32', x'33', x'34', x'35', x'36', x'37',
x'38', x'39', x'3a', x'3b', x'3c', x'3d', x'3e', x'3f',
x'84', x'41', x'42', x'43', x'44', x'45', x'46', x'47',
x'48', x'49', x'4a', x'4b', x'4c', x'4d', x'4e', x'4f',
x'50', x'51', x'52', x'53', x'54', x'55', x'56', x'57',
x'58', x'59', x'5a', x'85', x'5c', x'87', x'5e', x'5f',
x'60', x'61', x'62', x'63', x'64', x'65', x'66', x'67',
x'68', x'69', x'6a', x'6b', x'6c', x'6d', x'6e', x'6f',
x'70', x'71', x'72', x'73', x'74', x'75', x'76', x'77',
x'78', x'79', x'7a', x'7b', x'7c', x'7d', x'7e', x'7f'
%constantstring(1) snl = "
"
%constantstring(1)%array charx(0:7) = %c
 " ", "(", ".", ")", "'", "[", " ", "]"
!
!
!***********************************************************************
!*
!*          Record and array formats
!*
!***********************************************************************
!
%recordformat atom cell(%halfinteger bind,prop,func,%byteinteger form,
                        %stringname pname)
%recordformat lisp cell(%halfinteger car,cdr)
%recordformat lispinfo(%integer dataend,datastart,filesize,filetype,
                       sum,datetime,format,records,marker,const,
                       long head,pname space,pname base,pname head,name,
                       name head,stack,global,list,list head,list count,
                       line length)
%recordformat rf(%integer conad,filetype,datastart,dataend)
%recordformat stack frame(%halfinteger back,bind,link)
!
%ownintegerarrayformat constf(long base:long tail)
%ownrecord(stack frame)%arrayformat stackf(stack base:stack tail)
%ownrecord(lisp cell)%arrayformat listf(0:list tail)
%ownrecord(atom cell)%arrayformat namef(name base:name tail)
%ownbyteintegerarrayformat pnamef(0:pname max)
!
!
!***********************************************************************
!*
!*          Subsystem references
!*
!***********************************************************************
!
%systemroutinespec connect(%string(31) file,%integer mode,hole,
                           prot,%record(rf)%name r,%integername flag)
%systemroutinespec define(%integer chan,%string(31) iden,
                          %integername afd,flag)
%systemstringfunctionspec failuremessage(%integer mess)
%systemstringfunctionspec itos(%integer n)
%systemroutinespec outfile(%string(31) file,%integer size,hole,
                           prot,%integername conad,flag)
%externalroutinespec prompt(%string(255) s)
%systemroutinespec setfname(%string(63) s)
%externalroutinespec set return code(%integer i)
!
!
!***********************************************************************
!*
!*          Own variables
!*
!***********************************************************************
!
%owninteger auxp;                       ! Auxiliary stack pointer
%owninteger errval,infile,outf
%owninteger char,reset,front,pname tail,progflag,local,nillist
%ownintegername list count,list head,long head,pname head,global,name head
%ownintegername line length
%ownstring(255) pmpt,plabel,line,clause,pspaces
%ownintegerarrayname const
%ownrecord(lispinfo)%name lispfile
%ownrecord(atom cell)%arrayname name
%ownrecord(lisp cell)%arrayname list
%ownrecord(stack frame)%arrayname stack
%ownintegerarray auxs(0:1023);          ! Auxiliary stack
%ownbyteintegerarray blanks(0:255) = ' '(*)
%ownstring(5) errors = "Error"
!
!
!***********************************************************************
!*
!*          Forward references
!*
!***********************************************************************
!
%integerfunctionspec eval(%integer form)
%integerfunctionspec func(%record(atom cell)%name atom,%integer args)
%routinespec loop(%string(255) pmpt,%integer term)
!
!
!***********************************************************************
!*
!*          Miscellaneous routines
!*
!***********************************************************************
!
%integerfunction push(%integer index)
! Adds  the item 'index' to the auxiliary stack, yielding 'index' as the
! result.
auxs(auxp) = index
auxp = auxp + 1
%result = index
%end;   ! of push
!
!-----------------------------------------------------------------------
!
%integerfunction pop(%integer index)
! Removes an item from the auxiliary stack, yielding that  item  as  its
! result.
auxp = auxp - 1
%result = index
%end;   ! of pop
!
!-----------------------------------------------------------------------
!
%stringfunction pname(%integer index)
! Yields the printable form of the atom described by 'index'.
%if index >= long base %then %start
   %if index >= name base %then %start
      %result = itos(index-zero base) %if index >= short base
      %result = tostring(index-char base) %if index >= char base
      %result = name(index)_p name
   %finish %else %result = itos(const(index))
%finish %else %result = errors
%end;   ! of pname
!
!-----------------------------------------------------------------------
!
%string(255)%function pack(%integer index)
%integer car
%string(255) packed
!
packed = ""
%while index >= list base %cycle;       ! cdr down the list
   car = list(index)_car
   index = list(index)_cdr
   %if car >= list base %then packed <- packed.pack(car) %else %c
      packed <- packed.pname(car)
%repeat
packed <- packed.pname(index) %unless index = nil
%result = packed
%end;   ! of pack
!
!-----------------------------------------------------------------------
!
%integerfunction numberp(%integername value)
! Performs  the  LISP  function  'numberp',  on  the  item  described by
! 'value'.
value = const(value) %and %result = t %if long base <= value <= long tail
value = value - zero base %and %result = t %if short base <= value <= short tail
%result = nil
%end;   ! of numberp
!
!-----------------------------------------------------------------------
!
%integerfunction equal(%integer arg1,arg2)
! Performs the LISP function 'equal'  on  the  two  items  described  by
! 'arg1' and 'arg2'.
%if arg1 = arg2 %or (numberp(arg1) = t = numberp(arg2) %and %c
    arg1 = arg2) %or(arg1 >= list base %and arg2 >= list base %and %c
    equal(list(arg1)_car,list(arg2)_car) = t %and %c
    equal(list(arg1)_cdr,list(arg2)_cdr) = t) %then %result = t
%result = nil
%end;   ! of equal
!
!-----------------------------------------------------------------------
!
%integerfunction mnumb(%integer value)
! Allocates storage for a number (if necessary), and yields its value as
! the result.
%integer index
!
%result = value + zero base %if -1024 <= value <= 1023
%unless long base <= long head <= long tail %then %start
   printstring(snl."Atom error:   No more room for long constants".snl)
   %result = error
%finish
index = long base
%while index # long head %cycle
   %result = index %if const(index) = value
   index = index + 1
%repeat
long head = long head + 1
const(index) = value
%result = index
%end;   ! of mnumb
!
!-----------------------------------------------------------------------
!
%integerfunction matom(%string(255) pname)
! Allocates  storage  for  the name 'pname', and yields its index as the
! result.  Uses an existing copy if it is already in the name table.
%integer index
%record(atom cell)%name atom
!
%if length(pname) = 1 %then %start
   %result = char base + (charno(pname,1) & x'7f')
%finish
%for index = name base,1,name head - 1 %cycle
   %result = index %if pname = name(index)_pname
%repeat
%unless name head < char base %and %c
   pname head + length(pname) + 1 < pname tail %then %start
   printstring(snl."Atom error:   No more space for names".snl)
   %result = error
%finish
atom == name(name head)
atom_pname == string(pname head)
pname head = pname head + length(pname) + 1
atom_pname = pname
index = name head
name head = name head + 1
%result = index
%end;   ! of matom
!
!-----------------------------------------------------------------------
!
%integerfunction ratom
! Reads and allocates space for an atom, after classifying  it.   Yields
! the index of the item read.
%integer type,sign,value,tsign
%string(255) pname
!
type = 0
value = 0
sign = +1
tsign = +1
pname = ""
%cycle
   %if char & x'80' # 0 %then %start;   ! Separator
      %if pname # "" %then %start;      ! Terminator
         %result = matom(pname) %if type < 2
                                        ! Symbolic atom
         %result = mnumb(value);        ! Numeric atom
      %finish
      value = char & x'7f'
      char = x'80' %and %result = value %if char # x'80'
                                        ! Break character
   %finish %else %start;                ! Normal character
      %if 0 <= type <= 2 %then %start;  ! Possibly numeric
         %if '0' <= char <= '9' %then %start
                                        ! Yes for now
            type = 2
            %if sign = -1 %then %start
               value = -value
               sign = +1
            %finish
            value = value*10 + (char-'0')*tsign
         %finish %else %start;          ! Possibly signed
            %if type = 0 %and (char = '+' %or char = '-') %then %start
               type = 1
               %if char = '-' %then %start
                  sign = -1
                  tsign = -1
               %finish
            %finish %else type = -1;    ! Not numeric
         %finish
      %finish
      pname <- pname.tostring(char);    ! Always symbolic
   %finish
   %cycle
      readch(char);                     ! Next symbol
      char = code(char & x'7f')
      selectinput(0) %if char = eof
   %repeat %until char # eof
   readch(char) %and type = -1 %if char = escape
%repeat
%end;   ! of ratom
!
!-----------------------------------------------------------------------
!
%routine printchars(%string(255) phrase)
%integer adjustment
!
phrase <- plabel.phrase %and plabel = "" %if plabel # ""
%if phrase = "" %then %start
   %if length(line) + length(clause) < line length %then %start
      printstring(line.clause.snl)
   %finish %else printstring(line.snl.pspaces.clause.snl)
   line = ""
   clause = ""
%finish
%if length(pspaces)+length(clause)+length(phrase) >= line length %then %start
   adjustment = length(pspaces) - length(phrase)
   %if adjustment < 0 %then %start
      printstring(line.snl) %if line # ""
      printstring(pspaces.clause.snl)
      line = ""
      clause = ""
   %finish %else length(pspaces) = adjustment
%finish
clause = clause.phrase;                 ! Append phrase
%end;   ! of printchars
!
!-----------------------------------------------------------------------
!
%routine print(%integer index)
%integer level,clevel,adjustment,i
%byteinteger r flag,c count,r count,line 1
%integerarray line pos(0:maxlevel)
!
!
%string(255)%function padding
%integer index,count
!
%if level < maxlevel + 1 %then index = level %else index = maxlevel
count = line pos(index) - length(plabel)
count = line length %if count > line length
count = 0 %if count < 0
blanks(0) = count
%result = string(addr(blanks(0)))
%end;   ! of padding
!
!
%routine lparen
%integer i
!
%if level <= maxlevel %and line pos(level) = 0 %then %start
   line pos(level) = length(line) + length(clause)
%finish
c count = 10 %if 50 < length(line) > line pos(level) %or %c
   length(clause) > 30 %or (length(clause) > 20 %and length(line) > 20)
%if r flag > 0 %or c count >= 10 %then %start
                                        ! Start of new phrase
   %if length(line) + length(clause) > line length %or %c
      length(line) - length(pspaces) > 25 %or c count >= 2 %then %start
      !
      ! Adjust the position of the left parenthesis at this level
      !
      %if level > clevel %then %start
         adjustment = length(line) - length(pspaces)
         %for i = clevel + 1,1,level %cycle
            line pos(i) = line pos(i) - adjustment
         %repeat
      %finish
      printstring(line.snl) %if line # ""
      line = pspaces.clause
      line 1 = 0
   %finish %else line = line.clause
   c count = r count
   clause = ""
   clevel = level
   pspaces = padding
%finish
level = level + 1 %if line 1 = 0
r flag = 0
r count = 0
print chars("(")
%end;   ! of lparen
!
!
%routine rparen
print chars(")")
line pos(level) = 0 %if 0 < level <= maxlevel
level = level - 1 %if level > 0
r flag = 1
rcount = rcount + 1
%end;   ! of rparen
!
!-----------------------------------------------------------------------
!
%routine print sexp(%integer index)
! Prints  out the S-expression described by 'index'.  This may be a list
! cell (and therefore something fairly complex) or it  may  just  be  an
! atom.
%integer car,cdr
%record(lisp cell)%name cell
!
%if index >= list base %then %start;    ! List cell
   cell == list(index)
   car = cell_car
   cdr = cell_cdr;                      ! Map onto cell
   lparen
   print sexp(car);                     ! Start of list
   %if cdr >= list base %then %start
      %cycle;                           ! Print tail
         index = cdr
         cell == list(index)
         car = cell_car
         cdr = cell_cdr
         print chars(" ") %if plabel = ""
                                        ! Print space
         %exit %if cdr < list base;     ! End of list
         %if car = nil %then %start;    ! Print empty list
            lparen
            print chars(" ")
            rparen
         %finish %else print sexp(car); ! Print car
      %repeat
      print sexp(car)
   %finish
   printchars(" . ") %and printchars(pname(cdr)) %and rflag = 0 %if cdr # nil
   r paren;                             ! Close list
%finish %else %start;                   ! Atom
   %if r flag = 1 %then %start
      r flag = 2
      plabel <- pname(index)." " 
   %finish %else %start
      print chars(pname(index))
      r flag = 0
   %finish
%finish
%end;   ! of print sexp
!
!
line 1 = 1
r flag = 0
c count = 0
r count = 0
pspaces = ""
level = 0
clevel = 0
line pos(0) = 4;                        ! Initial indentation
line pos(i) = 0 %for i = 1,1,maxlevel
print sexp(index)
%end;   ! of print
!
!-----------------------------------------------------------------------
!
%routine mark(%integer index)
! Marks  the  chain  of  cells headed by 'index', by adding bit x'8000'.
! Used by the garbage collector.
%halfintegername car
!
%while index >= list base %and list(index)_car >= 0 %cycle
   car == list(index)_car
   index = list(index)_cdr
   car <- car!x'8000'
   mark(car & x'7fff') %if car & x'7fff' >= list base
%repeat
%end;   ! of mark
!
!-----------------------------------------------------------------------
!
%routine garbage collect
%record(lisp cell)%name cell
%integer i
!
mark(name(i)_prop) %for i = name base,1,name head - 1
mark(name(i)_prop) %for i = char base,1,name tail
mark(stack(i)_bind) %for i = stack base,1,front
mark(stack(i)_bind) %for i = global,1,stack tail
%if auxp > 0 %then %start
   mark(auxs(i)) %for i = 0,1,auxp - 1
%finish
list count = 0
list head = 0
%for i = list base,1,list tail %cycle
   cell == list(i)
   %if cell_car < 0 %then cell_car <- cell_car & x'7fff' %else %start
      list count = list count + 1
      cell_car = list head
      list head = i
   %finish
%repeat
%end;   ! of garbage collect
!
!-----------------------------------------------------------------------
!
%integerfunction cons(%integer car,cdr)
! Performs the LISP function 'cons' on the items described by 'car'  and
! 'cdr'.  Yields the index of the cell constructed.
%integer index,dummy
%record(lisp cell)%name cell
!
%if list count <= 100 %or list head < list base %then %start
   dummy = push(car);                   ! Ensure these lists are not garbage collected
   dummy = push(cdr)
   auxp = auxp + 2
   garbage collect
   auxp = auxp - 2
   %if list count <= 1000 %then %start
      printstring(snl."Lisp  note:   Less than 1000 free cells remaining - free something".snl)
      loop("Free:",percent)
   %finish
%finish
%if list head < list base %then %start
   printstring(snl."Lisp error:   No more free space left".snl)
   %result = error
%finish
list count = list count - 1
index = list head
cell == list(index)
list head = cell_car
cell_car = car
cell_cdr = cdr
%result = index
%end;   ! of cons
!
!-----------------------------------------------------------------------
!
%integerfunction reverse(%integer curr)
%integer last
%record(lisp cell)%name cell
!
last = nil
%while curr >= list base %cycle
   cell == list(curr)
   last = cons(cell_car,last)
   curr = cell_cdr
%repeat
%result = last
%end;   ! of reverse
!
!-----------------------------------------------------------------------
!
%integerfunction read sexp(%string(255) pmpt)
%integerfunctionspec cell(%integer car)
%integerfunctionspec head
%integerfunctionspec tail
%integer colapse
!
!
%integerfunction cell(%integer car)
%integer cdr
!
%if car >= atom base %then %start;      ! Head not in error
   auxs(auxp) = car
   auxp = auxp + 1
   cdr = tail
   auxp = auxp - 1
   %result = cons(car,cdr) %if cdr >= atom base
                                        ! Tail not in error
%finish
%result = error
%end;   ! of cell
!
!
%integerfunction head
%integer temp,res
%switch sw(0:3)
!
temp = ratom
%result = temp %if temp >= atom base;   ! Atom
-> sw(temp & 3);                        ! Handle by case
!
sw(0):                                  ! ""
%result = cons(quote,cons(head,nil))
!
sw(1):                                  ! '(' or '['
res = tail
colapse = no %if temp >= 4;             ! '['
%result = res
!
sw(2):
sw(3):                                  ! '.' or ')'
printstring(snl."Read error:   S-expression begins with a ".charx(temp).snl)
%result = error
%end;   ! of head
!
!
%integerfunction tail
%integer temp,res
%switch sw(0:3)
!
%result = nil %if colapse = yes;        ! Collapse back to '['
temp = ratom;                           ! Separator
%result = cell(temp) %if temp >= atom base
                                        ! Atom
-> sw(temp & 3);                        ! Handle by case
!
sw(0):
%result = cell(cons(quote,cons(head,nil)))
!
sw(1):                                  ! '(' or '['
res = tail
colapse = no %if temp >= 4;             ! '['
%result = cell(res)
!
sw(2):                                  ! '.'
temp = head
%result = temp %if tail = nil
printstring(snl."Read error:   Dotted pair not enclosed in brackets".snl)
%result = error
!
sw(3):                                  ! ')' or ']'
colapse = yes %if temp >= 4
%result = nil
%end;   ! of tail
!
!
colapse = no
prompt(pmpt)
%result = head
%end;   ! of read sexp
!
!-----------------------------------------------------------------------
!
%routine loop(%string(255) pmpt,%integer term)
%integer value
!
%cycle
   reset = 0
   value = eval(read sexp(pmpt))
   %exit %if value = term
   print(value) %and print chars("") %unless reset # 0
%repeat
%end;   ! of loop
!
!-----------------------------------------------------------------------
!
%integerfunction pcons(%integer car,cdr)
auxp = auxp - 1
%result = cons(car,cdr)
%end;   ! of pcons
!
!-----------------------------------------------------------------------
!
%routine xprint(%string(255) mess,%integer form)
%string(255) save
!
save = line
line = mess
print(form)
print chars("")
line = save
%end;   ! of xprint
!
!-----------------------------------------------------------------------
!
%routine bind(%integer symb,entry,bind)
%record(atom cell)%name atom
%record(stack frame)%name frame
!
%unless name base <= symb < list base %then %start
   printstring(snl."Bind error:   Element of name list not an atom, element = ")
   xprint("",symb)
   %return
%finish
%if name(symb)_form = 3 %then %start
   xprint(snl."Bind error:   Name list entry has constant binding, name=",symb)
   %return
%finish
%unless global > front %then %start
   printstring(snl."Bind error:  Stack overflow".snl)
   %return
%finish
frame == stack(entry)
atom == name(symb)
%unless bind >= atom base %then %start
   printstring(snl."Bind error:   Unassigned argument ")
   xprint("",symb)
   bind = error
%finish
frame_bind = bind
frame_back = symb
frame_link = atom_bind
atom_bind = entry
%end;   ! of bind
!
!-----------------------------------------------------------------------
!
%routine bindlist(%integername names,args)
%record(lisp cell)%name cell,argc
!
stack(front)_link = local
stack(front)_back = 0
local = front
front = front + 1
%while names >= list base %cycle
   cell == list(names)
   argc == list(args)
   bind(cell_car,front,argc_car)
   front = front + 1
   names = cell_cdr
   args = argc_cdr
%repeat
%end;   ! of bindlist
!
!-----------------------------------------------------------------------
!
%integerfunction unbind(%integer result)
%record(stack frame)%name frame
!
%while front > local %cycle
   front = front - 1
   frame == stack(front)
   name(frame_back)_bind = frame_link %if frame_back > 0
%repeat
front = local
local = stack(front)_link
%result = result
%end;   ! of unbind
!
!-----------------------------------------------------------------------
!
%integerfunction prog(%integer names,body)
%integer proglist,result
%record(lisp cell)%name cell
!
bindlist(names,nillist)
progflag = progflag + 4;                ! In prog
proglist = body
%while body >= list base %cycle;        ! Evaluate body
   cell == list(body)
   %if cell_car >= list base %then %start
                                        ! Not a plabel
      result = eval(cell_car);          ! So evaluate
      %if progflag & 3 # 0 %then %start;! Return or go
         %if progflag & 1 # 0 %then %start
                                        ! Return
            progflag = progflag & (\3) - 4
            %result = unbind(result)
         %finish
         cell == list(proglist)
         progflag = progflag & (\3)
         %while cell_car # result %cycle; ! Scan for label
            %if cell_cdr < list base %then %start
               progflag = progflag - 4
               %result = unbind(error); ! Not found
            %finish
            cell == list(cell_cdr)
         %repeat
      %finish
   %finish
   body = cell_cdr
%repeat
progflag = progflag - 4
%result = unbind(result);               ! Fell through
%end;   ! of prog
!
!-----------------------------------------------------------------------
!
%integerfunction evlist(%integer args)
%record(lisp cell)%name cell
!
%result = args %unless args >= list base
cell == list(args)
%result = pcons(push(eval(cell_car)),evlist(cell_cdr))
%end;   ! of evlist
!
!-----------------------------------------------------------------------
!
%integerfunction apply(%integer function,args)
%integer car,cadr,caddr
%record(lisp cell)%name cell
!
%if function >= list base %then %start
   cell == list(function)
   car = cell_car
   cell == list(cell_cdr)
   cadr = cell_car
   cell == list(cell_cdr)
   caddr = cell_car
   %if car = label %then %start
      bind(cadr,front,caddr)
      front = front + 1
      %result = apply(caddr,args)
   %finish
   %if car = lambda %then %start
      bindlist(cadr,args)
      bind(cadr,front,args) %and front = front + 1 %if cadr # nil
      %result = unbind(eval(caddr))
   %finish
   %result = apply(eval(function),args)
%finish
%if name base <= function <= name tail %then %start
   %result = func(name(function),args)
%finish
%result = error
%end;   ! of apply
!
!-----------------------------------------------------------------------
!
%integerfunction put(%integer atom,bind,prop)
%integer id
%halfintegername hole
%record(lisp cell)%name prop cell,bind cell
!
%unless name base <= atom <= name tail %and name base <= prop <= name tail %then %start
   %result = error3
%finish
hole == name(atom)_prop
%cycle;                                 ! Search property list
   hole = cons(prop,cons(bind,nil)) %and %exit %if hole < list base
                                        ! Not on list
   prop cell == list(hole)
   bind cell == list(prop cell_cdr)
   bind cell_car = bind %and %exit %if prop cell_car = prop
                                        ! Property found
   hole == bind cell_cdr;               ! Try next entry
%repeat
%if apval <= prop <= fexpr %then %start;! Function definition
   name(atom)_form = mask(prop)
   %if subr <= prop <= fsubr %then %start
      id = bind
      %result = error3 %unless numberp(id) = t
      name(atom)_func = id
   %finish %else name(atom)_func = bind
%finish
%result = bind
%end;   ! of put
!
!-----------------------------------------------------------------------
!
%integerfunction func(%record(atom cell)%name atom,%integer args)
! Interprets  a  function  call.   EXPRs  and  FEXPRs are interpreted by
! calling 'apply'.  SUBRs and FSUBRs are  interpreted  in  the  'func()'
! switch below.
%integer arg1,arg2,arg3,symb,afd,flag
%string(80) line
%halfintegername hole
%record(lisp cell)%name cell
%record(stack frame)%name frame
%switch type(0:3)
%switch func(0:86)
!
-> type(atom_form & 3)
!
type(3):                                ! Apval
type(0):                                ! No function definition on property list
%result = error2 %unless atom_bind < global
                                        ! Nor on alist
front = front + 1
args = evlist(args)
front = front - 1
%result = apply(stack(atom_bind)_bind,args)
!
type(1):                                ! Expr or Fexpr
%result = apply(atom_func,args)
!
type(2):                                ! Subr or Fsubr
cell == list(args);     arg1 = cell_car
cell == list(cell_cdr); arg2 = cell_car
cell == list(cell_cdr); arg3 = cell_car
!
-> func(atom_func)
!
func(0):                                ! Quote
%result = arg1
!
func(1):                                ! Car
%result = list(arg1)_car
!
func(2):                                ! Cdr
%result = list(arg1)_cdr
!
func(3):                                ! Caar
%result = list(list(arg1)_car)_car
!
func(4):                                ! Cadr
%result = list(list(arg1)_cdr)_car
!
func(5):                                ! Cdar
%result = list(list(arg1)_car)_cdr
!
func(6):                                ! Cddr
%result = list(list(arg1)_cdr)_cdr
!
func(7):                                ! Cons
%result = cons(arg1,arg2)
!
func(8):                                ! List
%result = args
!
func(9):                                ! Cond
%while args >= list base %cycle
   cell == list(list(args)_car)
   arg1 = eval(cell_car)
   %if arg1 # nil %then %start
      %while cell_cdr >= list base %cycle
         cell == list(cell_cdr)
         arg1 = eval(cell_car)
      %repeat
      %result = arg1
   %finish
   args = list(args)_cdr
%repeat
%result = nil
!
func(10):                               ! And
%while args >= list base %cycle
   cell == list(args)
   %result = nil %unless eval(cell_car) # nil
   args = cell_cdr
%repeat
%result = t
!
func(11):                               ! Or
%while args >= list base %cycle
   cell == list(args)
   %result = t %if eval(cell_car) # nil
   args = cell_cdr
%repeat
%result = nil
!
func(12):                               ! Null
%if arg1 = nil %then %result = t %else %result = nil
!
func(13):                               ! Atom
%if atom base <= arg1 < list base %then %result = t %else %result = nil
!
func(14):                               ! Numberp
%result = numberp(arg1)
!
func(56):                               ! Evenp
%if numberp(arg1) = t %and (arg1 & 1) = 0 %then %result = t 
%result = nil
!
func(55):                               ! Onep
arg1 = arg1 - 1
!
func(15):                               ! Zerop
%if arg1 = zero base %then %result = t %else %result = nil
!
func(16):                               ! Eq
%if arg1 = arg2 %then %result = t %else %result = nil
!
func(17):                               ! Equal
%result = equal(arg1,arg2)
!
func(18):                               ! Lessp
%if numberp(arg1) = t = numberp(arg2) %and arg1 < arg2 %then %result = t %else %c
   %result = nil
!
func(19):                               ! Greaterp
%if numberp(arg1) = t = numberp(arg2) %and arg1 > arg2 %then %result = t %else %c
   %result = nil
!
func(20):                               ! Memb/Memq
%while arg2 >= list base %cycle
   cell == list(arg2)
   %result = t %if arg1 = cell_car
   arg2 = cell_cdr
%repeat
%result = nil
!
func(21):                               ! Member
%while arg2 >= list base %cycle
   cell == list(arg2)
   %result = t %if equal(arg1,cell_car) = t
   arg2 = cell_cdr
%repeat
%result = nil
!
func(22):                               ! Assoc
%while arg2 >= list base %cycle
   cell == list(arg2)
   %result = cell_car %if equal(arg1,list(cell_car)_car) = t
   arg2 = cell_cdr
%repeat
%result = nil
!
func(23):                               ! Plus
arg1 = 0
%while args >= list base %cycle
   cell == list(args)
   arg2 = cell_car
   %if numberp(arg2) = t %then arg1 = arg1 + arg2 %else %result = error3
   args = cell_cdr
%repeat
%result = mnumb(arg1)
!
func(24):                               ! Difference
%unless numberp(arg1) = t %then %result = error3
%while args >= list base %cycle
   cell == list(args)
   arg2 = cell_car
   %if numberp(arg2) = t %then arg1 = arg1 - arg2 %else %result = error3
   args = cell_cdr
%repeat
%result = mnumb(arg1)
!
func(25):                               ! Times
arg1 = 1
%while args >= list base %cycle
   cell == list(args)
   arg2 = cell_car
   %if numberp(arg2) = t %then arg1 = arg1 * arg2 %else %result = error3
   args = cell_cdr
%repeat
%result = mnumb(arg1)
!
func(26):                               ! Quotient
%unless numberp(arg1) = t %then %result = error3
%while args >= list base %cycle
   cell == list(args)
   arg2 = cell_cdr
   %if numberp(arg2) = t %then arg1 = arg1//arg2 %else %result = error3
   args = cell_cdr
%repeat
%result = mnumb(arg1)
!
func(27):                               ! Add1
%if numberp(arg1) = t %then %result = mnumb(arg1 + 1)
%result = error3
!
func(28):                               ! Sub1
%if numberp(arg1) = t %then %result = mnumb(arg1 - 1)
%result = error3
!
func(29):                               ! Abs
%if numberp(arg1) = t %then %result = mnumb(imod(arg1))
%result = error3
!
func(30):                               ! Selectq
arg1 = eval(arg1)
args = list(args)_cdr
%cycle
   arg3 = args
   args = list(arg3)_cdr
   %exit %if args < list base
   cell == list(list(arg3)_car)
   arg2 = cell_car
   arg3 = cell_cdr
   %while arg2 >= list base %cycle
      cell == list(arg2)
      -> exit %if cell_car = arg1
      arg2 = cell_cdr
   %repeat
   %exit %if arg2 = arg1
%repeat
!
exit:
%while arg3 >= list base %cycle
   cell == list(arg3)
   arg1 = eval(cell_car)
   arg3 = cell_cdr
%repeat
%result = arg1
!
func(31):                               ! Put
%result = put(arg1,arg3,arg2)
!
func(32):                               ! Prop
%result = error3 %unless name base <= arg1 <= name tail
%result = name(arg1)_prop
!
func(33):                               ! Rem/Remprop
%result = error3 %unless %c
   name base <= arg1 <= name tail %and name base <= arg2 <= name tail
atom == name(arg1)
hole == atom_prop
%while hole >= list base %cycle
   cell == list(hole)
   %if cell_car = arg2 %then %start
      cell == list(cell_cdr)
      atom_form = 0 %if cell_car = atom_func
      hole = cell_cdr
      %result = t
   %finish
   hole == list(cell_cdr)_cdr
%repeat
%result = nil
!
func(34):                               ! Get
%result = error3 %unless %c
   name base <= arg1 <= name tail %and name base <= arg2 <= name tail
args = name(arg1)_prop
%while args >= list base %cycle
   cell == list(args)
   %result = list(cell_cdr)_car %if cell_car = arg2
   args = list(cell_cdr)_cdr
%repeat
%result = nil
!
func(35):                               ! Put/Putprop/Defprop
%result = put(arg1,arg2,arg3)
!
func(36):                               ! Eval
%result = eval(arg1)
!
func(37):                               ! Evlis
%result = evlist(args)
!
func(38):                               ! Apply
%result = apply(arg1,arg2)
!
func(39):                               ! Errset
arg1 = cons(eval(arg1),nil)
arg1 = errval %and reset = 0 %if reset = 2
%result = arg1
!
func(40):                               ! Rplaca
%result = error3 %if arg1 < list base
list(arg1)_car = arg2
%result = arg2
!
func(41):                               ! Rplacd
%result = error3 %if arg1 < list base
list(arg1)_cdr = arg2
%result = arg2
!
func(42):                               ! Nconc
%result = arg2 %if arg1 = nil
%result = error3 %unless arg1 >= list base
args = arg1;                            ! Remember 'a'
arg1 = list(arg1)_cdr %while list(arg1)_cdr >= list base
                                        ! Cdr down 'a'
list(arg1)_cdr = arg2
%result = args
!
func(43):                               ! Minusp
%if numberp(arg1) = t %and arg1 < 0 %then %result = t
%result = nil
!
func(44):                               ! Setq
arg2 = eval(arg2)
!
func(45):                               ! Set
%result = error3 %unless name base <= arg1 <= name tail
arg3 = name(arg1)_bind
%if arg3 < stack tail %then %start
   stack(arg3)_bind = arg2
%finish %else %start
   global = global - 1
   bind(arg1,global,arg2)
%finish
%result = arg2
!
func(46):                               ! Explode
%result = error3 %unless atom base <= arg1 < list base
line = pname(arg1)
arg2 = nil
%for arg1 = addr(line) + length(line),-1,addr(line) + 1 %cycle
   symb = byteinteger(arg1)
   %if '0' <= symb <= '9' %then symb = zero base + symb - '0' %else %c
      symb = char base + symb
   arg2 = cons(symb,arg2)
%repeat
%result = arg2
!
func(47):                               ! Implode
%result = matom(pack(arg1))
!
func(48):                               ! Prog2
%result = arg2
!
func(49):                               ! Progn
%while args >= list base %cycle
   cell == list(args)
   arg1 = eval(cell_car)
   args = cell_cdr
%repeat
%result = arg1
!
func(50):                               ! Prog
%result = prog(arg1,list(args)_cdr)
!
func(51):                               ! Minus
%if numberp(arg1) = t %then %result = mnumb(-arg1)
%result = error3
!
func(52):                               ! Return
progflag = progflag!1
%result = arg1
!
func(53):                               ! Go
progflag = progflag!2
%result = arg1
!
func(54):                               ! Reverse
%result = reverse(arg1)
!
func(60):                               ! Prompt
%result = error3 %unless name base <= arg1 <= name tail
pmpt = pname(arg1)
%result = arg1
!
func(61):                               ! Readch
%if atom base <= arg1 < list base %then prompt(pname(arg1)) %else prompt(pmpt)
readch(symb)
%if '0' <= symb <= '9' %then %result = mnumb(symb - '0') %else %c
   %result = matom(tostring(symb))
!
func(62):                               ! Read
%result = read sexp(pname(arg1)) %if atom base <= arg1 < list base
%result = read sexp(pmpt)
!
func(63):                               ! Princ
print(arg1)
%result = arg1
!
func(64):                               ! Print
print(arg1)
print chars("")
%result = arg1
!
func(65):                               ! Terpri
print chars("")
arg1 = nil %unless arg1 >= atom base
%result = arg1
!
func(66):                               ! Inunit
selectinput(arg1) %and %result = mnumb(arg1) %if numberp(arg1) = t
%result = error3
!
func(67):                               ! Outunit
selectoutput(arg1) %and %result = mnumb(arg1) %if numberp(arg1) = t
%result = error3
!
func(68):                               ! Input
%result = error3 %unless name base <= arg1 <= name tail
selectinput(0)
closestream(instream)
arg2 = infile
infile = arg1
define(instream,name(infile)_pname,afd,flag)
selectinput(instream)
%result = arg2
!
func(69):                               ! Output
%result = error3 %unless name base <= arg1 <= name tail
selectoutput(0)
closestream(outstream)
arg2 = outf
outf = arg1
define(outstream,name(outf)_pname,afd,flag)
selectoutput(outstream)
%result = arg2
!
func(70):                               ! Trace
%result = error3 %unless name base <= arg1 <= name tail
atom == name(arg1)
atom_form = atom_form!8
%result = arg1
!
func(71):                               ! Untrace
%result = error3 %unless name base <= arg1 <= name tail
atom == name(arg1)
atom_form = atom_form & (\8)
%result = arg1
!
func(72):                               ! Break
%result = error3 %unless name base <= arg1 <= name tail
name(arg1)_form = name(arg1)_form!16
%result = arg1
!
func(73):                               ! Unbreak
%result = error3 %unless name base <= arg1 <= name tail
name(arg1)_form = name(arg1)_form & (\16)
%result = arg1
!
func(74):                               ! $Delete
%result = error3 %unless name base <= arg1 <= name tail
atom == name(arg1)
atom_bind = stack tail
atom_prop = nil
atom_func = 0
atom_form = 0
%result = arg1
!
func(75):                               ! Peek
%if numberp(arg1) = t %and front - arg1 > stack base %then %c
   arg1 = front - arg1 %else arg1 = stack base
%if front # arg1 %then %start
   %for arg1 = front - 1,-1,arg1 %cycle
      frame == stack(arg1)
      line <- pname(frame_back & x'fff')."         "
      length(line) = 9
      %if frame_back & x'8000' # 0 %then line = line."* " %else line = line."= "
      xprint(line,frame_bind)
   %repeat
%finish
%result = stars
!
func(76):                               ! Linelength
%result = error3 %unless zerobase + 40 <= arg1 <= zerobase + 255
line length = arg1 - zerobase
%result = arg1
!
func(77):                               ! Garb
garbage collect
%result = mnumb(list count)
!
func(78):                               ! Reset
pmpt = "Read:"
reset = 1
errval = nil
%result = percent
!
func(79):                               ! Err
errval = arg1
reset = 2
%result = percent
!
func(80):                               ! Oblist
arg2 = nil
%for arg1 = name head - 1,-1,name base %cycle
   arg2 = cons(arg1,arg2)
%repeat
%result = arg2
!
func(81):                               ! Alist
arg2 = nil
arg3 = nil
%for arg1 = stack base,1,front - 1 %cycle
   frame == stack(arg1)
   arg2 = cons(cons(frame_back,frame_bind),arg2) %if %c
      name base <= frame_back <= name tail
%repeat
%for arg1 = stack tail - 1,-1,global %cycle
   frame == stack(arg1)
   arg3 = cons(cons(frame_back,frame_bind),arg3)
%repeat
%result = cons(arg2,arg3)
!
func(82):                               ! Ascii
%result = error3 %unless numberp(arg1) = t %and 0 <= arg1 <= 127
%result = matom(tostring(arg1))
!
func(83):                               ! Max
%unless numberp(arg1) = t %then %result = error3
%while args >= list base %cycle
   cell == list(args)
   arg2 = cell_car
   %unless numberp(arg2) = t %then %result = error3
   arg1 = arg2 %if arg1 < arg2
   args = cell_cdr
%repeat
%result = mnumb(arg1)
!
func(84):                               ! Min
%unless numberp(arg1) = t %then %result = error3
%while args >= list base %cycle
   cell == list(args)
   arg2 = cell_car
   %unless numberp(arg2) = t %then %result = error3
   arg1 = arg2 %if arg2 < arg1
   args = cell_cdr
%repeat
%result = mnumb(arg1)
!
func(85):                               ! Sqrt
%unless numberp(arg1) = t %then %result = error3
%result = int(sqrt(arg1))
!
func(86):                               ! Expt
%unless numberp(arg1) = t = numberp(arg2) %then %result = error3
%result = mnumb(arg1****arg2)
%end;   ! of func
!
!-----------------------------------------------------------------------
!
%integerfunction trace(%string(255) mess,%integer form)
xprint(mess,form)
%result = form
%end;   ! of trace
!
!-----------------------------------------------------------------------
!
%integerfunction eval(%integer form)
%integer car,cdr
%record(lisp cell)%name cell
%record(atom cell)%name atom
%record(stack frame)%name frame
!
!
%integerfunction break(%integer result)
%integer sexp
%switch error(0:3)
!
%result = result %if result >= atom base %or reset # 0
selectinput(0)
selectoutput(0)
xprint("Eval error:   ",form)
!
-> error(result)
!
error(1):
printstring("    Atom is not bound to a value".snl)
-> error(0)
!
error(2):
xprint("    Function not defined: ",car)
-> error(0)
!
error(3):
xprint("    Argument not of the correct form in ",cdr)
!
error(0):
loop("   %:",percent)
%result = percent %if reset # 0
sexp = read sexp("Eval:")
sexp = form %if sexp = percent
%result = eval(sexp)
%end;   ! of break
!
! ** Body of eval **
!
%result = percent %if reset # 0
frame == stack(front)
frame_back <- evln
frame_bind = form
%if form >= list base %then %start;     ! Form is a list
   cell == list(form)
   car = cell_car
   cdr = cell_cdr
   %if name base <= car <= name tail %then %start
      atom == name(car)
      %if atom_form & 4 # 0 %then %start
                                        ! Evaluate tail if EXPR or SUBR
         front = front + 1
         cdr = evlist(cdr)
         front = front - 1
      %finish
      form = push(form)
      frame_back <- car!x'8000'
      frame_bind = cdr
      %if atom_form & 16 # 0 %then %start
         selectinput(0)
         selectoutput(0)
         xprint("Lisp Break:   ",form)
         front = front + 1
         loop("   %:",percent)
         front = front - 1
      %finish
      %if atom_form & 8 # 0 %then %start
                                        ! Name being traced
         %result = pop(break(trace("<--- ".pname(car)." ",func(atom,
            trace("---> ".pname(car)." ",cdr)))))
      %finish
      %result = pop(break(func(atom,cdr)))
                                        ! Form of Apply
   %finish
   front = front + 1
   cdr = evlist(cdr)
   front = front - 1
   %result = break(apply(car,cdr));     ! Function is a list
%finish
%if name base <= form <= name tail %then %start
   atom == name(form)
   %result = atom_func %if atom_form & x'7' = 3
                                        ! Apval
   %result = break(stack(atom_bind)_bind)
                                        ! Return binding
%finish
%result = form;                         ! Constant
%end;   ! of eval
!
!-----------------------------------------------------------------------
!
%routine initlisp
%integer i,sexp
%record(atom cell)%name atom
%record(lisp cell)%name cell
%record(stack frame)%name frame
!
%for i = name base,1,name tail %cycle
   atom == name(i)
   atom_bind = stack tail
   atom_prop = nil
   atom_func = 0
   atom_form = 0
   atom_pname == errors
%repeat
selectinput(setup)
reset = 0
sexp = ratom %for i = nil,1,stars;      ! Read in known atoms
%for i = 0,1,list base - 1 %cycle
   cell == list(i)
   cell_car = error3
   cell_cdr = error3
%repeat
list head = list base
list count = list tail - list head
list(i)_car = i + 1 %for i = list base,1,list tail - 1
list(list tail) = 0
sexp = put(ratom,ratom,ratom) %until sexp = nil
                                        ! Initialise from INITLISP
stack(front)_bind = error
frame == stack(global)
frame_link = global
frame_bind = error1
auxs(auxp) = error
sexp = eval(read sexp("")) %until sexp = nil
selectinput(0)
%end;   ! of initlisp
!
!
!***********************************************************************
!*
!*          L I S P
!*
!***********************************************************************
!
%externalroutine lisp(%string(255) parms)
%integer flag,conad,initmode,i,fixup
%string(255) work
%record(rf) rr
%byteintegerarrayname pname space
%record(atom cell)%name atom
!
local = stack base
front = stack base
auxp = 0
pmpt = "Read:"
char = x'80';                           ! Arbitrary separator to start
!
%if parms -> work.("/").parms %and work = "" %then %start
   %if parms = "" %then parms = "T#LSPMACH"
   outfile(parms,196608,0,0,conad,flag)
   -> err %if flag # 0
   initmode = yes
%finish %else %start
   initmode = no
   connect(parms,3,0,0,rr,flag)
   -> err %if flag # 0
   conad = rr_conad
%finish
! <define channels 2 and 3???>
!
lispfile == record(conad);              ! LISP machine store
!
%if initmode = yes %then %start
   lispfile_dataend = lispfile_filesize
   lispfile_filetype = ssdatafiletype
   lispfile_format = 3;                 ! Un-structured
   lispfile_marker = marker
   lispfile_const = x'1000'
   lispfile_long head = long base
   lispfile_pname space = lispfile_const + 4*(long tail-long base+1)
   lispfile_pname base = lispfile_pname space
   lispfile_pname head = lispfile_pname base
   lispfile_name = x'4000'
   lispfile_name head = name base
   lispfile_stack = x'A000'
   lispfile_global = stack tail
   lispfile_list = x'10000'
   lispfile_line length = default line length
%finish %else %start
   %if lispfile_marker # marker %then %start
                                        ! Not a LISP machine file
      flag = 311;                       ! Corrupt file
      setfname(parms)
      -> err
   %finish
%finish
!
! Map variables onto machine file
!
const == array(conad+lispfile_const,constf)
long head == lispfile_long head
pname space == array(conad+lispfile_pname space,pnamef)
pname head == lispfile_pname head
pname tail = addr(pname space(pname max))
name == array(conad+lispfile_name,namef)
name head == lispfile_name head
global == lispfile_global
line length == lispfile_line length
!
! Relocate 'pname' addresses.
!
fixup = addr(pname space(0)) - lispfile_pname base
lispfile_pname base = lispfile_pname base + fixup
lispfile_pname head = lispfile_pname head + fixup
%for i = name base,1,name head - 1 %cycle
   atom == name(i)
   atom_pname == string(addr(atom_pname)+fixup)
   atom_bind = stack tail %unless global <= atom_bind <= stack tail
%repeat
!
%for i = char base,1,name tail %cycle
   atom == name(i)
   atom_bind = stack tail %unless global <= atom_bind <= stack tail
%repeat
!
list == array(conad+lispfile_list,listf)
list head == lispfile_list head
list count == lispfile_list count
stack == array(conad + lispfile_stack,stackf)
!
pspaces = ""
plabel = ""
line = ""
clause = ""
progflag = 0
flag = 0
%if initmode = yes %then initlisp
nillist = cons(nil,nil)
list(nillist)_cdr = push(nillist)
infile = matom(".IN")
outf = matom(".OUT")
!
loop("Lisp:",exit)
set return code(0)
%stop
!
err:
selectoutput(0)
printstring(snl."LISP fails -".failuremessage(flag))
set return code(flag)
%stop
%end;   ! of lisp
%endoffile