(original) (raw)

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