!***********************************************************************
!*
!* 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