#padtwv (* PreProcessor Version - Run through Filter *)
#p (* PERQ version *)
#a (* Apollo Version *)
#d (* DEC-20 Version *)
#t (* Terak Version *)
#w (* Wicat Version *)
#v (* VAX version *)
(*********************************************************************
PASCAL BASED MINI-LISP
File: PAS0.PAS - PASCAL/LISP KERNEL
ChangeHistory:
3 Mar 82 RO: Apollo version finished, some changes for WICAT
16 Feb 82 RO: Implement !*ECHO
11 Feb 82 RO: Allow string as alias for identifier
8 Feb 82 RO: Fix GC bug & clean up for apollo
19 Jan 82 RO: Change I/O channel assginments
29 Dec 81 RO: File I/O for apollo & wicat
23 Dec 81 RO: More changes for Apollo & Wicat
9 Dec 81, RO: Remove apollo specific I/O.
1 Dec 81 RO: I/O fixes for wicat & fixnum bug
14 Nov 81, MLG:add some PERQ updates from Voelker
28 Oct 81, RO: GENSYM & fixnum gc
All RIGHTS RESERVED
COPYRIGHT (C) - 1981 - M. L. Griss and R. Ottenheimer
Computer Science Department
University of Utah
Do Not distribute with out written consent of M. L. Griss
********************************************************************)
#t (*$S+*) (* swapping mode *)
#t (*$G+*) (* goto is legal *)
#adtvw PROGRAM pas0 ; (* (input*,output) *)
#p PROGRAM pas0 (input,output, symin, finput,foutput);
(************************************************************)
(* support routines for a "lisp" machine. uses a register *)
(* model with a stack for holding frames. stack also used *)
(* to hold compiler generated constants. *)
(* written by: *)
(* william f. galway, martin l. griss *)
(* ralph ottenheimer *)
(* append pas1...pasn at end *)
(* -------------------------------------------------------- *)
(* I/O channel assignments:
1: symin, used to init symbol table
2: stdin,
3: stdout,
4: finput,
5: foutput.
*)
(************************************************************)
#a (* Apollo System include files *)
#a %include '/sys/ins/base.ins.pas';
#a %include '/sys/ins/pgm.ins.pas';
#p imports Stream from Stream;
#p imports system from system;
#p imports io_others from io_others;
#p imports io_unit from io_unit;
(************************************************************)
CONST
#aptv (* for terak, perq, Apollo, vax *)
#aptvw sp = ' ';
#aptvw ht = 9; (* ascii codes *)
#aptvw lf = 10;
#aptvw cr = 13;
#aptvw nul = 0;
#d eos = nul; (* terminator character for strings. *)
#t (* use eos=chr(nul) *)
#av eos=chr(nul) ;
#pw eos = chr(0); (* KLUDGE: null string *)
#adtwpv inchns = 5; (* number of input channels. *)
#adtwpv outchns = 5; (* number of output channels. *)
begin_comment = '%';
(* Initial symbols, needed in Kernel *)
xtoktype = 129; (* slot in idspace for toktype. *)
xbstack = 130; (* Bstack Pointer *)
xthrowing = 131; (* If throw mode *)
xinitform = 132; (* for restart *)
xraise = 133; (* for RAISE of lc in ids *)
Xinput = 134; (* For Open *)
Xoutput = 135; (* For Open *)
xQuote = 138; (* For quoting ids in pascal code. *)
xEcho = 136; (* raw input is echoed if not NIL. *)
chartype = 3; (* various token types *)
inttype = 1;
idtype = 2;
max_gsym = 4; (* number of digits in gen'd id. *)
#dt shift_const = 8192; (* tags and info are packed into an integer *)
#a (* no shift const *)
#p (* no shift const *)
#w (* no shift const *)
#dt (* assumed to be at least 16 bits long. low order 13 bits *)
#dt (* are the info, top 3 are the tag. *)
#dt int_offset = 4096; (* small integers are stored 0..8191 *)
#dt (* instead of -4096..4095 because it will pack smaller *)
#dt (* under ucsd pascal. *)
#apw int_offset = 32767; (* Apollo, PERQ and WICAT items are records *)
(* the various tags - can't use a defined scalar type *)
(* because of the lack of convertion functions. *)
inttag = 0; (* info is an integer *)
chartag = 1; (* info is a character code *)
pairtag = 2; (* info points to pair *)
idtag = 3; (* info points to identifier *)
codetag = 4; (* info is index into a case statement *)
(* that calls appropriate function. *)
errtag = 5; (* info is an error code - see below. *)
fixtag = 6; (* info points to a full word (or *)
(* longer) integer. *)
strtag = 7; (* info points to a string. *)
(* error codes. corresponding to tag = errtag. *)
noprspace = 1; (* no more "pair space"--can't cons. *)
notpair = 2; (* a pair operation attempted on a non-pair. *)
noidspace = 3; (* no more free identifiers *)
undefined = 4; (* used to mark undefined function cells (etc?) *)
noint = 5; (* no free integer space after garbage collection *)
notid = 6;
(* data space sizes *)
(* remember pointers to these things are inums, sometimes quite small *)
#av maxpair = 10000; (* max number of pairs allowed. *)
#dpw maxpair = 3700; (* max number of pairs allowed. *)
#t maxpair = 1000; (* max number of pairs allowed *)
#tw maxident = 400; (* max number of identifiers *)
#adpv maxident = 800; (* max number of identifiers *)
#adpv maxstrsp = 4000; (* size of string (literal) storage space. *)
(* beware - string pointers are inums. *)
#tw maxstrsp = 2000; (* size of string (literal) storage space. *)
#adpv maxintsp = 200; (* max number of long integers allowed *)
#tw maxintsp = 2; (* max number of long integers allowed *)
hidmax = 50; (* number of hash values for identifiers *)
maxgcstk = 100; (* size of garbage collection stack. *)
stksize = 500; (* stack size *)
maxreg = 15; (* number of registers in lisp machine. *)
eofcode = 26; (* magic character code for eof, ascii for *)
(* cntrl-z. kludge, see note in xrdtok. *)
choffset = 1; (* add choffset to ascii code to get address *)
(* in id space for corresponding identifier. *)
nillnk = 0; (* when integers are used as pointers. *)
#dptw end_flag = maxint; (* marks end of fixnum space *)
#a end_flag = -2147483648; (* marks end of fixnum space *)
(************************************************************)
TYPE
#w regblk_type = array[0..16] of longint;
#d onechar = ascii; (* for DEC *)
#aptvw onechar = char; (* for terak,perq,Apollo,Wicat*)
#awv FileName=Packed ARRAY[0..59] of onechar;
#p FileName: string;
#t FileName: string[60];
#d FileName=Packed ARRAY[1..9] of onechar;
(* note we allow zero for id_ptr, allowing a "nil" link. *)
stringp = 1..maxstrsp; (* pointer into string space. *)
id_ptr = 0..maxident; (* pointer into id space. *)
#dtv itemref = integer;
#apw itemref = RECORD
#apw tag:integer;
#apw info:integer;
#apw END;
itemtype = 0..7; (* the tags *)
pair = PACKED RECORD
prcar: itemref;
prcdr: itemref;
END;
#aw ascfile = text;
#dptv ascfile = PACKED FILE OF onechar;
#d textfile =PACKED FILE of char;
ident = PACKED RECORD (* identifier *)
idname: stringp;
val: itemref; (* value *)
plist: itemref; (* property list *)
funcell: itemref; (* function cell *)
idhlink: id_ptr; (* hash link *)
END;
#dptvw longint = integer;
#a longint = integer32;
(************************************************************)
VAR
(* global information *)
nilref, trueref, tmpref: itemref;
(* refers to identifiers "nil", "t", and a temp to get around bug in. *)
(* apollo & wicat pascal *)
initphase: integer; (* Start up *)
#adpvw r: ARRAY[1..maxreg] OF itemref;
#t r: ARRAY[0..maxreg] OF itemref; (* cuts code size down *)
rxx,ryy: itemref;
#t CHARCNT: INTEGER; (* input buffer & pointer *)
#t LINE: STRING;
(* "st" is the stack pointer into "stk". it counts the number of *)
(* items on the stack, so it runs from zero while the stack starts *)
(* at one. *)
st: 0..stksize;
stk: ARRAY[1..stksize] OF itemref;
(* pair space *)
prspace: PACKED ARRAY[1..maxpair] OF pair; (* all pairs stored here. *)
freepair: integer; (* pointer to next free pair in prspace. *)
(* identifier space *)
idhead: ARRAY[0..hidmax] OF id_ptr;
idspace: PACKED ARRAY[1..maxident] OF ident;
freeident: integer;
g_sym: ARRAY[1..max_gsym] OF onechar;
(* string space *)
strspace: PACKED ARRAY[1..maxstrsp] OF onechar;
freestr: stringp;
(* large integer space *)
intspace: ARRAY[1..maxintsp] OF longint;
freeint: 1..maxintsp;
(* i/o channels *)
#p (* files declared on header *)
#adptvw symin: ascfile;
#adptvw finput : ascfile;
#aptvw foutput: ascfile;
#d foutput: textfile;
#d input: ascfile;
#a IoStatus:Integer32;
inchnl: 1..inchns; (* current input channel number *)
outchnl: 1..outchns; (* current output channel number *)
(* "current character" for each input channel. *)
(* may want to include more than one character at some later date *)
(* (for more lookahead). *)
ichrbuf: ARRAY[1..inchns] OF onechar;
(* for collecting statistics. *)
gccount: integer; (* counts garbage collections *)
(* counts from last garbage collection. *)
consknt: integer; (* number of times "cons" called *)
(* ........ Everything nested inside CATCH *)
#w procedure _setjmp(var regblk:regblk_type);external;
#w procedure _long_jump(var regblk:regblk_type);external;
Procedure Xcatch; (* ----------- Outermost Procedure ----------- *)
#adv LABEL 9999;
#w (* need to use special ASM68 procedures for Wicat *)
var catch_stk:0..stksize;
catch_Bstk:itemref;
#w Catch_regs:regblk_type;
PROCEDURE xread;
FORWARD;
PROCEDURE xprint;
FORWARD;
PROCEDURE xunbindto;
FORWARD;
PROCEDURE xeval;
FORWARD;
Procedure Xthrow;
begin (* throw value *)
idspace[Xthrowing].val := trueref;
#dav goto 9999
#w _long_jump(Catch_regs);
#tp exit(xeval)
end (* throw *);
#p (* Special handlers *)
#p Handler CtlC; (* ------- handle runaway aborts ------- *)
#p begin
#p write('^C');
#p IOKeyClear;
#p IObeep;
#p if initphase > 1 then Xthrow;
#p end;
(********************************************************)
(* *)
(* item selectors & constructors *)
(* *)
(********************************************************)
#a (* use some SHIFTS ? *)
FUNCTION tag_of(item: itemref): itemtype;
#t VAR gettag: PACKED RECORD
#t CASE boolean OF
#t TRUE: (i: itemref);
#t FALSE: (info: 0..8191;
#t tag: 0..7)
#t END;
BEGIN (* tag_of *)
#t gettag.i := item;
#t tag_of := gettag.tag
#dv tag_of := item DIV shift_const;
#apw tag_of := item.tag;
END;
(* tag_of *)
FUNCTION info_of(item: itemref): integer;
#t VAR getinfo: PACKED RECORD
#t CASE boolean OF
#t TRUE: (i: itemref);
#t FALSE: (info: 0..8191;
#t tag: 0..7)
#t END;
BEGIN (* info_of *)
#t getinfo.i := item;
#t if getinfo.tag = inttag then
#t info_of := getinfo.info - int_offset
#t else info_of := getinfo.info
#dv IF item DIV shift_const = inttag THEN
#dv info_of := item MOD shift_const - int_offset
#dv ELSE
#dv info_of := item MOD shift_const
#apw info_of := item.info
END;
(* info_of *)
FUNCTION xnull(item: itemref): boolean;
BEGIN
xnull := (tag_of(item) = tag_of(nilref)) AND
(info_of(item) = info_of(nilref))
END;
PROCEDURE mkitem(tag: itemtype; info: longint; VAR item: itemref);
(* do range checking on info. ints run from -4096 to +4095 *)
(* everything else runs from 0 to 8191. ints & chars *)
(* contain their info, all others points into an *)
(* appropriate space. *)
PROCEDURE mkfixint;
VAR nextfree: integer;
PROCEDURE gc_int;
VAR i: integer;
mark_flag: PACKED ARRAY[1..maxintsp] OF boolean;
PROCEDURE mark(u: itemref);
BEGIN (* Mark *)
IF tag_of(u) = pairtag THEN
BEGIN
mark(prspace[info_of(u)].prcar);
mark(prspace[info_of(u)].prcdr)
END
ELSE IF tag_of(u) = fixtag THEN
mark_flag[info_of(u)] := true
END (* Mark *);
BEGIN (* Gc_int *)
writeln('*** Gc int');
FOR i := 1 TO maxintsp do (* clear mark flags *)
mark_flag[i] := false;
FOR i := 1 TO st DO (* mark from the stack *)
Mark(stk[i]);
FOR i := 1 TO maxident DO (* mark from the symbol table *)
BEGIN
Mark(idspace[i].val);
Mark(idspace[i].plist);
Mark(idspace[i].funcell) (* probably NOT necessary *)
END;
(* reconstruct free list *)
FOR i := 1 TO maxintsp - 1 DO
IF NOT mark_flag[i] THEN
BEGIN
intspace[i] := freeint;
freeint := i
END
END (* Gc_int *);
BEGIN (* mkfixint *)
IF info = end_flag THEN (* user can't use magic number *)
BEGIN info := 0;
writeln('*****Mkfixint: Info too large')
END;
IF intspace[freeint] = end_flag THEN
gc_int; (* garbage collect intspace *)
IF intspace[freeint] <> end_flag THEN
BEGIN (* convert to fixnum *)
tag := fixtag;
nextfree := intspace[freeint];
intspace[freeint] := info;
info := freeint; (* since we want the pointer *)
freeint := nextfree
END
ELSE
BEGIN mkitem(errtag, noint, r[1]);
writeln('***** Integer space exhausted')
END
END;
(* mkfixint *)
BEGIN (* mkitem *)
IF tag = inttag THEN
#apw BEGIN
IF (info < -int_offset) OR (info > int_offset - 1) THEN mkfixint
#dtv ELSE info := info + int_offset (* info was in range so add offset *)
#apw END
ELSE IF tag = fixtag THEN mkfixint
ELSE IF info < 0 THEN
BEGIN
writeln('*****Mkitem: bad neg');
#d break(output);
#dtv halt;
#p exit(pas0);
#a pgm_$exit;
END;
(* nothing special to do for other types *)
#dtv (* pack tag and info into 16-bit item. *)
#dtv item := tag * shift_const + info
#apw item.tag := tag;
#apw item.info := info
END;
(* mkitem *)
PROCEDURE mkerr(info: longint; VAR item: itemref);
Begin
mkitem(errtag,info,item);
End;
PROCEDURE set_info(VAR item: itemref; newinfo: longint);
BEGIN (* set_info *)
mkitem(tag_of(item), newinfo, item)
END;
(* set_info *)
PROCEDURE set_tag(VAR item: itemref; newtag: itemtype);
BEGIN (* set_tag *)
mkitem(newtag, info_of(item), item)
END;
(* set_tag *)
PROCEDURE mkident(id: integer; reg: integer);
(* make identifier "id" in register "reg" *)
BEGIN (* mkident *)
mkitem(idtag, id, r[reg]);
END;
(* mkident *)
PROCEDURE mkint(int: longint; reg: integer);
BEGIN (* mkint *)
mkitem(inttag, int, r[reg]);
END;
(* mkint *)
PROCEDURE mkpair(pr: integer; reg: integer);
BEGIN (* mkpair *)
mkitem(pairtag, pr, r[reg])
END;
(* mkpair *)
PROCEDURE int_val(item: itemref; VAR number: longint);
(* returns integer value of item (int or fixnum). *)
(* must return 'number' in var parameter instead *)
(* of function value since long integers are not *)
(* a legal function type in ucsd pascal. *)
BEGIN (* int_val *)
IF tag_of(item) = inttag THEN
number := info_of(item)
ELSE IF tag_of(item) = fixtag THEN
number := intspace[info_of(item)]
ELSE writeln(tag_of(item), ' *****Illegal data type for numeric operation')
(* halt or fatal error *)
END;
(* int_val *)
(********************************************************)
(* *)
(* stack allocation *)
(* *)
(********************************************************)
PROCEDURE alloc(n: integer);
BEGIN
IF n + st <= stksize THEN
st := n+st
ELSE
BEGIN
writeln('*****LISP stack overflow');
writeln(' tried to allocate ',n);
writeln(' current stack top is ',st);
#d break(output);
END;
END;
PROCEDURE dealloc(n: integer);
BEGIN
IF st - n >= 0 THEN
st := st - n
ELSE
writeln('*****Lisp stack underflow');
END;
(* optimized allocs *)
PROCEDURE alloc1;
BEGIN alloc(1) END;
PROCEDURE dealloc1;
BEGIN dealloc(1) END;
PROCEDURE alloc2;
BEGIN alloc(2) END;
PROCEDURE dealloc2;
BEGIN dealloc(2) END;
PROCEDURE alloc3;
BEGIN alloc(3) END;
PROCEDURE dealloc3;
BEGIN dealloc(3) END;
(********************************************************)
(* *)
(* support for register model *)
(* *)
(********************************************************)
PROCEDURE load(reg: integer; sloc: integer);
BEGIN
IF sloc < 0 THEN r[reg] := r[-sloc]
ELSE r[reg] := stk[st-sloc];
(* will, fix for load (pos,pos) *)
END;
PROCEDURE store(reg: integer; sloc: integer);
BEGIN
stk[st-sloc] := r[reg];
END;
(* optimized load/store. *)
PROCEDURE load10;
BEGIN
load(1,0);
END;
PROCEDURE store10;
BEGIN
store(1,0);
END;
PROCEDURE storenil(sloc: integer);
BEGIN
stk[st-sloc] := nilref;
END;
(********************************************************)
(* *)
(* identifier lookup & entry *)
(* *)
(********************************************************)
function nmhash(nm: stringp): integer;
CONST
hashc = 256;
VAR
i,tmp: integer;
BEGIN
tmp := 0;
i := 1; (* get hash code from first three chars of string. *)
WHILE (i <= 3) AND (strspace[nm+i] <> eos) DO
BEGIN
tmp := ord(strspace[nm+i]) + hashc*tmp;
i := i + 1;
END;
nmhash := abs(tmp) MOD hidmax; (* abs because mod is screwy. *)
END;
FUNCTION eqstr(s1,s2: stringp): boolean;
BEGIN
WHILE (strspace[s1] = strspace[s2]) AND (strspace[s1] <> eos) DO
BEGIN
s1 := s1 + 1;
s2 := s2 + 1;
END;
eqstr := (strspace[s1] = strspace[s2]);
END;
PROCEDURE nmlookup(nm: stringp; VAR found: boolean; VAR hash: integer;
VAR loc: itemref);
(* lookup a name in "identifier space". *)
(* "hash" returns the hash value for the name. *)
(* "loc" returns the location in the space for the (possibly new) *)
(* identifier. *)
BEGIN
hash := nmhash(nm);
mkitem(idtag, idhead[hash], loc);
(* default is identifier, but may be "error". *)
(* start at appropriate hash chain. *)
found := false;
WHILE (info_of(loc) <> nillnk) AND (NOT found) DO
BEGIN
found := eqstr(nm, idspace[info_of(loc)].idname);
IF NOT found THEN
set_info(loc, idspace[info_of(loc)].idhlink);
(* next id in chain *)
END;
IF NOT found THEN (* find spot for new identifier *)
BEGIN
IF freeident=nillnk THEN (* no more free identifiers. *)
BEGIN
mkerr(noidspace, loc);
writeln('*****Identifer space exhausted')
END
ELSE
BEGIN
set_info(loc, freeident);
freeident := idspace[freeident].idhlink;
END;
END;
END;
PROCEDURE putnm(nm: stringp; VAR z: itemref; VAR found: boolean);
(* put a new name into identifier space, or return old location *)
(* if it's already there. *)
VAR
tmp: ident;
hash: integer;
BEGIN
nmlookup(nm, found, hash, z);
IF (NOT found) AND (tag_of(z) = idtag) THEN
BEGIN
tmp.idname := nm;
tmp.idhlink := idhead[hash]; (* put new ident at head of chain *)
tmp.val := nilref; (* initialize value and property list *)
tmp.plist := nilref;
tmp.funcell := nilref; (* also, the function cell *)
idhead[hash] := info_of(z);
idspace[info_of(z)] := tmp;
END;
END;
(********************************************************)
(* *)
(* the garbage collector *)
(* *)
(********************************************************)
PROCEDURE xfaststat;
(* give quick summary of statistics gathered *)
BEGIN
#dw writeln('Next free pair: ', freepair, ' out of ', maxpair);
#dw writeln('Next free fixnum: ', freeint, ' out of ', maxintsp);
#dw writeln('Next free string: ', freestr, ' out of ', maxstrsp);
writeln('Next free id loc: ', freeident, ' out of ', maxident);
writeln('Pair space reclaimed ', gccount, ' times');
writeln('Conses since last reclaim:',consknt);
writeln('Stack top is:',st);
#d break(output)
END;
PROCEDURE xgcollect;
VAR
i: integer;
markedk: integer; (* counts the number of pairs marked *)
freedk: integer; (* counts the number of pairs freed. *)
gcstkp: 0..maxgcstk; (* note the garbage collection stack *)
mxgcstk: 0..maxgcstk; (* is local to this procedure. *)
gcstk: ARRAY[1..maxgcstk] OF integer;
markflag: PACKED ARRAY[1..maxpair] OF boolean;
PROCEDURE pushref(pr: itemref);
(* push the address of an unmarked pair, if that's what it is. *)
BEGIN
IF tag_of(pr) = pairtag THEN
IF NOT markflag[info_of(pr)] THEN (* was .markflag *)
BEGIN
IF gcstkp < maxgcstk THEN
BEGIN
gcstkp := gcstkp + 1;
gcstk[gcstkp] := info_of(pr);
IF gcstkp > mxgcstk THEN
mxgcstk := gcstkp;
END
ELSE
BEGIN
writeln('*****Garbage stack overflow');
#dtv halt;
#p exit(pas0);
#a pgm_$exit;
END;
END;
END;
PROCEDURE mark;
(* "recursively" mark pairs referred to from gcstk. gcstk is used to *)
(* simulate recursion. *)
VAR
prloc: integer;
BEGIN
WHILE gcstkp > 0 DO
BEGIN
prloc := gcstk[gcstkp];
gcstkp := gcstkp - 1;
markflag[prloc] := true;
pushref(prspace[prloc].prcdr);
pushref(prspace[prloc].prcar); (* trace the car first. *)
END;
END;
BEGIN (* xgcollect *)
writeln;
writeln('***Garbage collector called');
#d break(output);
gccount := gccount + 1; (* count garbage collections. *)
xfaststat; (* give summary of statistics collected *)
consknt := 0; (* clear out the cons counter *)
gcstkp := 0; (* initialize the garbage stack pointer. *)
mxgcstk := 0; (* keeps track of max stack depth. *)
(* clear markflags *)
FOR i := 1 TO maxpair DO markflag[i] := false;
(* mark things from the "computation" stack. *)
FOR i := 1 TO st DO
BEGIN
pushref(stk[i]);
mark;
END;
(* mark things from identifier space. *)
FOR i := 1 TO maxident DO
BEGIN
pushref(idspace[i].val);
mark;
pushref(idspace[i].plist);
mark;
pushref(idspace[i].funcell);
mark;
END;
(* reconstruct free list by adding things to the head. *)
freedk := 0;
markedk := 0;
FOR i:= 1 TO maxpair - 1 DO
BEGIN
IF markflag[i] THEN
BEGIN
markedk := markedk + 1;
markflag[i] := false
END
ELSE
BEGIN
prspace[i].prcar := nilref;
mkitem(pairtag, freepair, prspace[i].prcdr);
freepair := i;
freedk := freedk + 1
END
END;
writeln(freedk,' pairs freed.');
writeln(markedk,' pairs in use.');
writeln('Max gc stack was ',mxgcstk);
#d break(output);
mkint(gccount, 1) (* return number of garbage collections *)
END;
(* xgcollect *)
(********************************************************)
(* *)
(* lisp primitives *)
(* *)
(********************************************************)
(* return r[1].r[2] in r[1] *)
PROCEDURE xcons;
VAR p: integer;
BEGIN
(* push args onto stack, in case we need to garbage collect the *)
(* references will be detected. *)
alloc(2);
stk[st] := r[1];
stk[st-1] := r[2];
IF xNull(prspace[freepair].prcdr) THEN xgcollect;
p := freepair;
freepair := info_of(prspace[p].prcdr);
prspace[p].prcar := stk[st];
prspace[p].prcdr := stk[st - 1];
mkpair(p, 1); (* leave r[1] pointing at new pair. *)
consknt := consknt + 1;
dealloc(2);
END;
PROCEDURE xncons;
BEGIN r[2] := nilref;
xcons;
END;
PROCEDURE xxcons;
BEGIN rxx := r[1];
r[1] := r[2];
r[2] := rxx;
xcons;
END;
(* Makes things too big for Apollo ...
PROCEDURE xWrtok; FORWARD;
PROCEDURE err_not_pair(VAR u: itemref);
BEGIN
write('*****Pair operation attempted on '); xwrtok; writeln;
mkerr(notpair, u);
END;
*)
(* return car of r[1] in r[1] *)
PROCEDURE xcar;
BEGIN
IF tag_of(r[1]) = pairtag THEN
r[1] := prspace[info_of(r[1])].prcar
ELSE
mkerr(notpair, r[1]);
END;
PROCEDURE xcdr;
BEGIN
IF tag_of(r[1]) = pairtag THEN
r[1] := prspace[info_of(r[1])].prcdr
ELSE
mkerr(notpair, r[1]);
END;
PROCEDURE xrplaca;
BEGIN
IF tag_of(r[1]) = pairtag THEN
prspace[info_of(r[1])].prcar:=r[2]
ELSE
mkerr(notpair, r[1]);
END;
PROCEDURE xrplacd;
BEGIN
IF tag_of(r[1]) = pairtag THEN
prspace[info_of(r[1])].prcdr :=r[2]
ELSE
mkerr(notpair, r[1]);
END;
(* anyreg car and cdr *)
PROCEDURE anycar(a: itemref; VAR b: itemref);
BEGIN
IF tag_of(a) = pairtag THEN
b := prspace[info_of(a)].prcar
ELSE
mkerr(notpair, b);
END;
PROCEDURE anycdr(a: itemref; VAR b: itemref);
BEGIN
IF tag_of(a) = pairtag THEN
b := prspace[info_of(a)].prcdr
ELSE
mkerr(notpair, b);
END;
(********************************************************)
(* *)
(* compress & explode *)
(* *)
(********************************************************)
PROCEDURE compress; (* returns new id from list of chars *)
VAR i: stringp;
clist, c: itemref;
found: boolean;
int: longint;
FUNCTION is_int(i: stringp; VAR int: longint): boolean;
VAR negative, could_be: boolean;
BEGIN (* is_int *)
int := 0;
could_be := true;
negative := strspace[i] = '-';
IF negative OR (strspace[i] = '+') THEN i := i + 1;
WHILE could_be AND (strspace[i] <> eos) DO
BEGIN
IF (strspace[i] >= '0') AND (strspace[i] <= '9') THEN
int := int * 10 + (ord(strspace[i]) - ord('0'))
ELSE could_be := false;
i := i + 1
END;
IF negative THEN int := -int;
is_int := could_be
END (* is_int *);
BEGIN (* compress *)
clist := r[1]; (* list of chars *)
i := freestr; (* point to possible new string *)
WHILE (i < maxstrsp) AND NOT xNull(clist) DO
BEGIN
IF tag_of(clist) = PAIRTAG THEN
BEGIN
c := prspace[info_of(clist)].prcar;
clist := prspace[info_of(clist)].prcdr;
IF tag_of(c) = IDTAG THEN
IF (info_of(c) > choffset) AND
(info_of(c) < choffset + 128) THEN
BEGIN
strspace[i] := chr(info_of(c) - choffset);
i := i + 1
END
ELSE
writeln('*****Compress: list item not single char')
ELSE
writeln('*****Compress: list item not ID');
END
ELSE
writeln('*****Compress: item not list')
END (* WHILE *);
strspace[i] := eos; (* terminate string *)
IF (i >= maxstrsp) THEN
writeln('*****String space exhausted')
ELSE IF is_int(freestr, int) THEN
mkint(int, 1)
ELSE (* look the name up, return itemref for it *)
BEGIN
putnm(freestr, r[1], found);
IF NOT found THEN
freestr := i + 1;
END
END (* compress *);
PROCEDURE explode; (* returns list of chars from id or int *)
FUNCTION id_explode(i: stringp): itemref;
BEGIN (* id_explode *)
IF strspace[i] = eos THEN id_explode := nilref
ELSE
BEGIN
r[2] := id_explode(i + 1);
mkident(ord(strspace[i]) + choffset, 1);
xcons;
id_explode := r[1]
END
END (* id_explode *);
FUNCTION int_explode(i: longint): itemref;
VAR negative: boolean;
BEGIN (* int_explode *)
r[1] := nilref;
IF i < 0 THEN
BEGIN negative := true;
i := -i
END
ELSE negative := false;
WHILE i > 0 DO
BEGIN
r[2] := r[1];
mkident(i MOD 10 + ord('0') + choffset, 1);
xcons;
i := i DIV 10
END;
IF negative THEN
BEGIN
r[2] := r[1];
mkident(ord('-') + choffset, 1);
xcons
END;
int_explode := r[1]
END (* int_explode *);
BEGIN (* explode *)
IF tag_of(r[1]) = IDTAG THEN
r[1] := id_explode(idspace[info_of(r[1])].idname)
ELSE IF tag_of(r[1]) = INTTAG THEN
r[1] := int_explode(info_of(r[1]))
ELSE IF tag_of(r[1]) = FIXTAG THEN
r[1] := int_explode(intspace[info_of(r[1])])
ELSE IF tag_of(r[1]) = CODETAG THEN
r[1] := int_explode(info_of(r[1]))
ELSE
writeln('***** EXPLODE: Arg bad type')
END (* explode *);
PROCEDURE gensym;
VAR i: integer;
PROCEDURE kick(i: integer); (* increments gsym digit *)
BEGIN (* Kick *)
IF (g_sym[i] = '9') THEN
BEGIN
g_sym[i] := '0';
IF (i < max_gsym) THEN kick(i + 1) (* otherwise wrap around *)
END
ELSE g_sym[i] := succ(g_sym[i])
END (* Kick *);
BEGIN (* gensym *)
r[1] := nilref;
FOR i := 1 TO max_gsym DO
BEGIN
r[2] := r[1];
mkident(ord(g_sym[i]) + choffset, 1);
xcons
END;
r[2] := r[1];
mkident(ord('G') + choffset, 1);
xcons;
compress;
Kick(1);
END; (* gensym *)
(********************************************************)
(* *)
(* i/o primitives *)
(* *)
(********************************************************)
PROCEDURE xopen; (* Simple OPEN, but see NPAS0 *)
var s1: FileName;
i,j : integer;
#a io_status: integer32;
#p (* catch some I/O errors *)
#p handler ResetError(name: PathName);
#p begin
#p writeln('**** Could not open file - ',name,' for read');
#p exit(xopen);
#p end;
#p handler RewriteError(name: PathName);
#p begin
#p writeln('**** Could not open file - ',name,' for write');
#p exit(xopen);
#p end;
begin
IF tag_of(r[1]) = IDTAG THEN
begin
i := idspace[info_of(r[1])].idname;
#p s1[0] := chr(255); (* set length *)
#d s1:=' ';
#w s1:=" ";
#aptv s1:=' ';
#adpvw j:= 0;
#t j := 1;
WHILE (i <= maxstrsp) AND (strspace[i] <> eos)
#d AND (j <9 )
do
begin
#d IF strspace[i] <> '.' THEN (* ignore dots in 20 file names. *)
#d BEGIN
#d j:= j + 1;
s1[j] := strspace[i];
#d END;
#aptvw j:= j + 1;
i:= i + 1;
end;
#p s1[0]:= chr(j); (* set Actual Length *)
IF tag_of(r[2]) = IDTAG THEN
BEGIN
If info_of(r[2])= Xinput then
begin
#t close(finput);
#twp reset(finput, s1);
#d reset(finput,s1,0,0,'DSK ');
#a close(finput);
#a open(finput, s1, 'old', io_status);
#a IF io_status = 0 THEN
#a BEGIN
#a reset(finput);
mkint(4,1)
#a END
#a ELSE BEGIN writeln('***** OPEN: Could not open ', s1);
#a r[1] := nilref END
end
else if info_of(r[2])= Xoutput then
begin
#t close(foutput);
#twp rewrite(foutput, s1);
#d rewrite(foutput,s1,0,0,'DSK ');
#a close(foutput);
#a open(foutput, s1, 'new', io_status);
#a IF io_status = 0 THEN
#a BEGIN
#a rewrite(foutput);
mkint(5,1)
#a END
#a ELSE BEGIN writeln('***** OPEN: Could not open ', s1);
#a r[1] := nilref
#a END
END
ELSE
BEGIN writeln('***** Open: arg2 not INPUT/OUTPUT');
mkerr(notid,r[1])
END
END ELSE writeln('***** Open: arg2 bad type')
END ELSE writeln('***** Open: arg1 bad type');
END;
PROCEDURE xclose;
begin
case info_of(r[1]) of
1: ;
2: ;
3: ;
#w 4: ;
#w 5: ;
#apt 4: close(finput);
#apt 5: close(foutput);
#d 4: break(finput);
#d 5: break(foutput);
end;
end;
PROCEDURE xrds;
(* Select channel for input *)
VAR tmp: longint;
BEGIN
tmp:=inchnl;
inchnl := info_of(r[1]);
mkint(tmp,1)
END;
PROCEDURE Xwrs;
(* Select channel for output *)
VAR tmp:longint;
BEGIN
tmp:=outchnl;
outchnl := info_of(r[1]);
mkint(tmp,1)
END;
PROCEDURE xterpri;
BEGIN
CASE outchnl OF
#p 3: writeln(' ');
#d 3: begin writeln(output); break(output); end;
#dp 5: begin writeln(foutput,' '); break(foutput); end;
#atw 3: writeln(output);
#atw 5: writeln(foutput);
END (* CASE *)
END;
FUNCTION Int_field(I: longint): Integer;
VAR width: integer;
n: longint;
BEGIN
width := 1;
n := 10;
IF i < 0 THEN width := width + 1; (* For minus sign *)
i := abs(i);
WHILE (i >= n) AND (width < 10) DO
BEGIN width := width + 1;
n := n * 10
END;
int_field := width
END;
PROCEDURE XwriteInt(I:integer);
BEGIN
CASE outchnl OF
3: write(i: int_field(i));
5: write(foutput, i: int_field(i));
END (* CASE *)
END (* XwriteInt *);
PROCEDURE XwriteChar(C:onechar);
BEGIN
#adptw CASE outchnl OF
#p 3: write(' ', C);
#adtvw 3: write(C);
#p 5: write(foutput,' ', C);
#adtvw 5: write(foutput,C);
#adptw END (* CASE *)
END;
PROCEDURE xwrtok;
(* doesn't expand escaped characters in identifier names *)
VAR i: integer;
BEGIN
IF tag_of(r[1]) = inttag THEN XwriteInt(info_of(R[1]))
ELSE IF tag_of(r[1]) = fixtag THEN XwriteInt(intspace[info_of(R[1])])
ELSE IF tag_of(r[1]) = idtag THEN
BEGIN
i := idspace[info_of(r[1])].idname;
WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
BEGIN
XwriteChar(strspace[i]);
i:= i + 1;
END;
END
(*
ELSE IF tag_of(r[1]) = strtag THEN
BEGIN xWriteChar('"');
i := info_of(r[1]);
WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
BEGIN
XwriteChar(strspace[i]);
i := i + 1;
END;
xWriteChar('"')
END
*)
ELSE IF tag_of(r[1]) = chartag THEN
XwriteChar(chr(info_of(r[1]) - choffset))
ELSE IF tag_of(r[1]) = errtag THEN
Begin XwriteChar(' ');
XwriteChar('*'); XwriteChar('*'); XwriteChar('*');
XwriteChar(' '); XwriteChar('#'); XwriteChar(' ');
XwriteInt(info_of(r[1])); Xterpri;
End
ELSE IF tag_of(r[1]) = codetag THEN
Begin XwriteChar(' '); XwriteChar('#'); XwriteChar('#');
XwriteInt(info_of(r[1]));
End
ELSE
Begin
XwriteChar(' '); XwriteChar('?'); XwriteChar(' ');
XwriteInt(tag_of(r[1]));
XwriteChar(' '); XwriteChar('/'); XwriteChar(' ');
XwriteInt(info_of(r[1]));
XwriteChar(' '); XwriteChar('?'); XwriteChar(' ');
End;
#d break(output);
END;
#aptvw FUNCTION eol: boolean;
#aptvw BEGIN
#aptvw CASE inchnl OF
#aptvw 1: eol := eoln(symin);
#aptvw 2: eol := eoln(input);
#aptvw 4: eol := eoln(finput);
#aptvw END;
#aptvw END;
PROCEDURE rdchnl(chnlnum: integer; VAR ch: onechar);
BEGIN
IF (chnlnum < 1) OR (chnlnum > inchns) THEN
writeln('*****Bad input channel for RDCHNL', chnlnum)
ELSE
CASE chnlnum OF
1: BEGIN
ch := symin^; (* a little strange, but avoids *)
get(symin); (* initialization problems *)
ichrbuf[inchnl] := symin^; (* Peek ahead *)
END;
2: BEGIN
#t IF charcnt > Length(line) THEN
#t BEGIN
#t charcnt := 1;
#t Readln(line)
#t END;
#t ch := line[charcnt];
#t IF Length(line) > charcnt THEN
#t ichrbuf[inchnl] := line[charcnt + 1]
#t ELSE ichrbuf[inchnl] := sp;
#t charcnt := charcnt + 1
#adpvw ch := input^;
#adpvw get(input);
#adpvw ichrbuf[inchnl] := input^;
END;
4: begin
ch := finput^;
get(finput);
ichrbuf[inchnl] := finput^;
END;
END;
(* case *)
IF idspace[xEcho].val <> nilref THEN
#aptvw IF eol THEN BEGIN xWriteChar(ch); xTerpri END ELSE xWriteChar(ch);
#d xWriteChar(ch);
END;
(* rdchnl *)
FUNCTION eofchnl: boolean;
BEGIN
#adptvw CASE inchnl OF
#adptvw 1: eofchnl := eof(symin);
#adptvw 2: eofchnl := eof(input);
#adptvw 4: eofchnl := eof(finput);
#adptvw END;
END;
(********************************************************)
(* *)
(* token scanner *)
(* *)
(********************************************************)
PROCEDURE xrdtok;
LABEL 1;
VAR
ch,ch1,ChangedCh: onechar;
i: integer;
anint: longint;
moreid: boolean;
found: boolean;
negflag: integer;
FUNCTION digit(ch: onechar): boolean;
BEGIN
digit := ( '0' <= ch ) AND ( ch <= '9');
END;
FUNCTION escalpha(VAR ch: onechar): boolean;
(* test for alphabetic or escaped character. *)
(* note side effect in ChangedCh. *)
BEGIN
ChangedCh := Ch;
IF ( 'A' <= ch ) AND ( ch <= 'Z') THEN
escalpha := true
ELSE IF ( ord('A')+32 <= ord(ch)) AND ( ord(ch) <= ord('Z')+32) THEN
BEGIN
IF NOT xNull(idspace[xraise].val) THEN
Changedch := chr(ord(ch)-32);
escalpha := true; (* lower case alphabetics *)
END
ELSE IF ch='!' THEN
BEGIN
rdchnl(inchnl,ch);
ChangedCh:=Ch;
escalpha := true;
END
ELSE
escalpha := false;
END;
FUNCTION alphanum(VAR ch: onechar): boolean;
(* test if escalfa or digit *)
VAR b: boolean;
BEGIN
ChangedCh:=Ch;
b := digit(ch);
IF NOT b THEN b := escalpha(ch);
alphanum := b;
END;
FUNCTION whitesp(ch: onechar): boolean;
#d BEGIN
#d (* may want a faster test *)
#d whitesp := (ch = sp) OR (ch = cr) OR (ch = lf) OR (ch = ht)
#d OR (ch = nul); (* null?? *)
#aptvw VAR ascode:integer;
#aptvw BEGIN
#aptvw ascode:=ord(ch);
#aptvw WHITESP := (CH = SP) OR (ascode = CR) OR (ascode = LF)
#aptvw OR (ascode = ht) or (ascode = nul); (* null?? *)
END;
BEGIN (* xrdtok *)
1:
IF NOT eofchnl THEN
REPEAT (* skip leading white space. *)
rdchnl(inchnl,ch)
UNTIL (NOT whitesp(ch)) OR eofchnl;
IF eofchnl THEN
mkitem(chartag, eofcode + choffset, r[1])
(* should really return !$eof!$ *)
ELSE
BEGIN
IF digit(ch) or (ch = '-') THEN
set_tag(r[1], inttag)
ELSE IF ch = '"' THEN set_tag(r[1], strtag)
ELSE IF escalpha(ch) THEN
set_tag(r[1], idtag)
ELSE
set_tag(r[1], chartag);
CASE tag_of(r[1]) OF
chartag: BEGIN
if ch = begin_comment then
BEGIN
#d While (ch <> cr) do rdchnl(inchnl,ch);
#aptvw While not eol do rdchnl(inchnl,ch);
rdchnl(inchnl, ch);
GOTO 1
END;
set_tag(r[1], idtag);
mkitem(inttag, chartype, tmpref);
idspace[xtoktype].val := tmpref;
set_info(r[1], ord(ch) + choffset);
END;
inttag: BEGIN
mkitem(inttag, inttype, tmpref);
idspace[xtoktype].val :=tmpref;
negflag := 1;
if ch = '-' then
begin anint := 0; negflag :=-1 end
else anint := ord(ch) - ord('0');
WHILE digit(ichrbuf[inchnl]) DO
BEGIN
rdchnl(inchnl,ch);
anint := 10 * anint + (ord(ch) - ord('0'))
END;
anint := negflag * anint;
set_info(r[1], anint)
END;
idtag: BEGIN
mkitem(inttag, idtype, tmpref);
idspace[xtoktype].val:=tmpref;
i := freestr; (* point to possible new string *)
moreid := true;
WHILE (i < maxstrsp) AND moreid DO
BEGIN
strspace[i] := ChangedCh;
(* May have Case Change, etc *)
i:= i + 1;
moreid :=alphanum(ichrbuf[inchnl]); (* PEEK ahead char *)
IF moreid THEN rdchnl(inchnl,ch) (* Advance readch *)
END;
strspace[i] := eos; (* terminate string *)
IF (i >= maxstrsp) THEN
writeln('*****String space exhausted')
ELSE (* look the name up, return itemref for it *)
BEGIN
putnm(freestr, r[1], found);
IF NOT found THEN
freestr := i + 1;
END;
END (* of case idtag *);
strtag: BEGIN
(* an alias for quoted identifier - special *)
(* characters need not be escaped. *)
mkitem(inttag, idtype, tmpref);
idspace[xtoktype].val:=tmpref;
i := freestr;
rdchnl(inchnl, ch); (* scan past " *)
WHILE (ch <> '"') AND (i < maxstrsp) DO
BEGIN
strspace[i] := ch;
i := i + 1;
rdchnl(inchnl, ch);
END;
#adw strspace[i] := eos;
#ptv strspace[i] := chr(eos);
i := i + 1;
IF ch <> '"' THEN
writeln('***** String space exhausted')
ELSE (* look the name up, return itemref for it *)
BEGIN
putnm(freestr, r[1], found);
set_tag(r[1], idtag);
(* must have the form ('QUOTE . id . NIL) *)
(* to give the effect of a quoted id. *)
r[2] := nilref;
xcons;
r[2] := r[1];
mkident(xQuote, 1);
xcons;
IF NOT found THEN
freestr := i;
END;
END (* OF CASE strtag *);
END (* of case *);
END;
END (* xrdtok *);
(********************************************************)
(* *)
(* initialization *)
(* *)
(********************************************************)
PROCEDURE init;
(* initialization procedure depends on *)
(* ability to load stack with constants *)
(* from a file. *)
VAR
strptr: stringp;
#dptvw nam: PACKED ARRAY[1..3] OF onechar;
#a nam: PACKED ARRAY[1..4] OF onechar; (* SPL bug for Apollo *)
(* holds 'nil', other strings? *)
i, n: integer;
idref: itemref;
found: boolean;
#aptv (* init is divided into two parts so it can compile on terak *)
PROCEDURE init1;
BEGIN
#t CHARCNT := 1;
#t LINE := '';
#t eos := chr(nul);
(* initialize top of stack *)
st := 0;
(* initialize fixnum free list *)
FOR freeint := 1 TO maxintsp - 1 DO
intspace[freeint] := freeint + 1;
intspace[maxintsp] := end_flag;
freeint := 1;
(* define nilref - the id, nil, is defined a little later. *)
freeident := 1;
mkitem(idtag, freeident, nilref);
(* initialize pair space. *)
FOR i := 1 TO maxpair - 1 DO (* initialize free list. *)
BEGIN
prspace[i].prcar := nilref; (* just for fun *)
mkitem(pairtag, i + 1, prspace[i].prcdr);
END;
prspace[maxpair].prcar := nilref;
prspace[maxpair].prcdr := nilref; (* end flag *)
freepair := 1; (* point to first free pair *)
(* initialize identifier space and string space. *)
freestr := 1;
FOR i := 0 TO hidmax - 1 DO
idhead[i] := nillnk;
FOR i := 1 TO maxident DO
BEGIN
IF i < maxident THEN
idspace[i].idhlink := i + 1
ELSE (* nil to mark the final identifier in the table. *)
idspace[i].idhlink := nillnk;
(* set function cells to undefined *)
mkerr(undefined, tmpref);
idspace[i].funcell :=tmpref;
idspace[i].val :=tmpref;
idspace[i].plist :=tmpref;
END;
(* nil must be the first identifier in the table--id #1 *)
(* must fill in fields by hand for nilref.*)
(* putnm can handle any later additions. *)
nam := 'NIL';
strptr := freestr;
FOR i := 1 TO 3 DO
BEGIN
strspace[strptr] := nam[i];
strptr:= strptr + 1;
END;
strspace[strptr] := eos;
putnm(freestr, nilref, found);
IF NOT found THEN
freestr := strptr + 1;
(* make the single character ascii identifiers, except nul(=eos). *)
FOR i := 1 TO 127 DO
BEGIN
strspace[freestr] := chr(i);
strspace[freestr + 1] := eos;
putnm(freestr, idref, found);
IF NOT found THEN
freestr := freestr + 2;
IF i = ord('T') THEN
BEGIN
trueref := idref; (* returns location for 't. *)
idspace[info_of(idref)].val := trueref (* Set T to T *)
END
END;
(* init gensym id list *)
FOR i := 1 TO max_gsym DO g_sym[i] := '0';
(* clear the counters *)
idspace[xraise].val := trueref; (* gets undone when !*RAISE is read *)
idspace[xEcho].val := nilref; (* prevent echo until !*ECHO is read *)
gccount := 0;
consknt := 0;
END;
(* init1 *)
PROCEDURE init2;
BEGIN
(* load "symbol table" with identifiers, constants, and functions. *)
inchnl := 1; (* select symbol input file. *)
outchnl := 3; (* select output file. *)
#p reset(symin,'paslsp.ini');
#p reset(input);
#p rewrite(output);
#w reset(symin, "paslsp.ini");
#t reset(symin,'#5:lspini.text');
#d reset(symin,'paslspini',0,0,'DSK ');
#d reset(input,'tty ',0,0,'TTY ');
#d rewrite(output,'tty ',0,0,'TTY ');
#a open(symin,'paslsp.ini','old',iostatus);
#a reset(symin);
#a for i:=1 to inchns do
#a ichrbuf[i]:=' ';
xrdtok; (* get count of identifiers. *)
IF tag_of(r[1]) <> inttag THEN
writeln('*****Bad symbol table, integer expected at start');
n := info_of(r[1]);
FOR i := 1 TO n DO
xrdtok;
(* reading token magically loads it into id space. *)
xrdtok; (* look for zero terminator. *)
IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
writeln('*****Bad symbol table, zero expected after identifiers');
xrdtok; (* count of constants *)
IF tag_of(r[1]) <> inttag THEN
writeln('*****Bad symbol table, integer expected before constants');
n := info_of(r[1]);
alloc(n); (* space for constants on the stack *)
FOR i := 1 TO n DO
BEGIN
xread;
stk[i] := r[1];
END;
xrdtok;
IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
writeln('*****Bad symbol table, zero expected after constants');
xrdtok; (* count of functions. *)
IF tag_of(r[1]) <> inttag THEN
writeln('*****Bad symbol table, integer expected before functions');
n := info_of(r[1]);
FOR i := 1 TO n DO
(* for each function *)
(* store associated code *)
BEGIN
xrdtok;
mkitem(codetag, i, tmpref);
idspace[info_of(r[1])].funcell :=tmpref;
END;
xrdtok;
IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
writeln('*****Bad symbol table, zero expected after functions');
END;
(* init2 *)
(*
PROCEDURE dumpids;
VAR i, p: integer;
BEGIN
FOR i := 1 TO freeident - 1 DO
BEGIN
p := idspace[i].idname;
write('id #', i:5, ' at', p:5, ': ');
WHILE strspace[p] <> eos DO
BEGIN
write(strspace[p]);
p := p + 1
END;
write('. Function code: ');
writeln(INFO_OF(idspace[i].funcell));
END
END;
*)
BEGIN (* init *)
init1;
init2;
END;
(* init *)
(********************************************************)
(* *)
(* arithmetic functions *)
(* *)
(********************************************************)
PROCEDURE xadd1;
VAR i: longint;
BEGIN
int_val(r[1], i);
mkint(i + 1, 1)
END;
PROCEDURE xdifference;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
mkint(i1 - i2, 1)
END;
PROCEDURE xdivide; (* returns dotted pair (quotient . remainder). *)
VAR quot, rem: integer;
i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
IF i2 = 0 THEN writeln('*****Attempt to divide by 0 in DIVIDE')
ELSE BEGIN mkint(i1 DIV i2, 1);
mkint(i1 MOD i2, 2);
END;
xcons
END;
PROCEDURE xgreaterp;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
IF i1 > i2 THEN
r[1] := trueref
ELSE
r[1] := nilref;
END;
PROCEDURE xlessp;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
IF i1 < i2 THEN
r[1] := trueref
ELSE
r[1] := nilref;
END;
PROCEDURE xminus;
VAR i: longint;
BEGIN
int_val(r[1], i);
mkint(-i, 1)
END;
PROCEDURE xplus2;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
mkint(i1 + i2, 1)
END;
PROCEDURE xquotient;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
IF i2 = 0 THEN writeln('*****Attempt to divide by 0 in QUOTIENT')
ELSE mkint(i1 DIV i2, 1)
END;
PROCEDURE xremainder;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
IF i2 = 0 THEN writeln('*****Attempt to divide by 0 in REMAINDER')
ELSE mkint(i1 MOD i2, 1)
END;
PROCEDURE xtimes2;
VAR i1, i2: longint;
BEGIN
int_val(r[1], i1);
int_val(r[2], i2);
mkint(i1 * i2, 1)
END;
(* xtimes2 *)
(********************************************************)
(* *)
(* support for eval *)
(* *)
(********************************************************)
PROCEDURE execute(code: integer);
FORWARD;
(* Xapply(fn,arglist)-- "fn" is an operation code. *)
PROCEDURE xxapply;
VAR
i: integer;
code: integer;
tmp: itemref;
tmpreg: ARRAY[1..maxreg] OF itemref;
BEGIN
code := info_of(r[1]);
r[1] := r[2];
i := 1;
(* spread the arguments *)
WHILE NOT xNull(r[1]) AND (i <= maxreg) DO
BEGIN
tmp := r[1];
xcar;
tmpreg[i] := r[1];
i := i + 1;
r[1] := tmp;
xcdr;
END;
WHILE i > 1 DO
BEGIN
i := i - 1;
r[i] := tmpreg[i];
END;
execute(code);
END;
(* rest of pas1...pasn follow , pasn Closes definition of Catch *)