Artifact 32c96d71fe715555fd1e950524eb300fa906eb48d090995b2ce5ebac23704ef1:
- File
perq-pascal-lisp-project/pas0.save
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 53925) [annotate] [blame] [check-ins using] [more...]
#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: 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 *) (* -------------------------------------------------------- *) (* symin is input channel one--used to initialize "symbol *) (* table". input is input channel two--standard input. *) (* output is output channel one--the standard output. *) (* finput is file input channel three. *) (* foutput is file output channel four. *) (************************************************************) #a (* Apollo System include files *) #a %include '/sys/ins/base.ins.pas'; #a %include '/sys/ins/base_transition.ins.pas'; #a %include '/sys/ins/streams.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 = 3; (* number of input channels. *) #adtwpv outchns = 2; (* 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 *) 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 *) #av shift_const = 4096; #p (* no shift const *) #w (* no shift const *) (* assumed to be at least 16 bits long. low order 13 bits *) (* are the info, top 3 are the tag. *) #dt int_offset = 4096; (* small integers are stored 0..8191 *) #av int_offset = 2048; (* small integers are stored -2048..2047 *) #pw int_offset = 32767; (* PERQ and WICAT items are records *) #dt (* instead of -4096..4095 because it will pack smaller *) #dt (* under ucsd pascal. *) (* 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. *) flotag = 7; (* info points to a float number. *) (* 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 *) #adwv maxpair = 10000; (* max number of pairs allowed. *) #p maxpair = 3700; (* max number of pairs allowed. *) #t maxpair = 1000; (* max number of pairs allowed *) #t maxident = 400; (* max number of identifiers *) #adpwv maxident = 800; (* max number of identifiers *) #adpwv maxstrsp = 4500; (* size of string (literal) storage space. *) #t maxstrsp = 2000; (* size of string (literal) storage space. *) maxintsp = 200; (* max number of long integers allowed *) #t maxflosp = 2; (* max number of floating numbers allowed *) #adpwv maxflosp = 50; (* max number of floating numbers 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. *) end_flag = maxint; (* 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*) #a real= integer32; (* Kludge, no reals yet *) #p FileName= String; (* For PERQ FileName *) #atwv FileName=Packed ARRAY[0..8] of onechar; #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. *) #adtv itemref = integer; #pw itemref = RECORD #pw tag:integer; #pw info:integer; #pw END; itemtype = 0..7; (* the tags *) pair = PACKED RECORD prcar: itemref; prcdr: itemref; (* OLD markflag:boolean , but wastes space *) END; #aw ascfile = text; #dptv ascfile = PACKED FILE OF onechar; #d textfile =PACKED FILE of char; #a (* No PASCAL file I/O yet *) 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 = integer; (* Should be 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; #tw CHARCNT: INTEGER; (* input buffer & pointer *) #tw 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; (* use long int on terak *) freeint: 1..maxintsp; (* floating point number space *) flospace: ARRAY[1..maxflosp] OF real; freefloat: 1..maxflosp; (* 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; #t Procedure xeval; #t Forward; 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 #adv tag_of := item DIV shift_const; #pw 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 #adv IF item DIV shift_const = inttag THEN #adv info_of := item MOD shift_const - int_offset #adv ELSE #adv info_of := item MOD shift_const #pw 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 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 #pw BEGIN IF (info < -int_offset) OR (info > int_offset - 1) THEN mkfixint #adtv ELSE info := info + int_offset (* info was in range so add offset *) #pw 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 *) (* pack tag and info into 16-bit item. *) #adtv item := tag * shift_const + info #pw item.tag := tag; #pw 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('***** 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; (* Other primitives ?? *) (********************************************************) (* *) (* 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. *) mkerr( noidspace, loc) 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; PROCEDURE xfaststat; (* give quick summary of statistics gathered *) BEGIN writeln('CONSES:',consknt); writeln('ST :',st); #d break(output) END; (********************************************************) (* *) (* the garbage collector *) (* *) (********************************************************) 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; (* used not to have array here *) 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; (* OLD prspace[prloc].markflag := true; *) pushref(prspace[prloc].prcdr); pushref(prspace[prloc].prcar); (* trace the car first. *) END; END; BEGIN (* xgcollect *) 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; (* OLD: wasnt needed *) (* 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 (* OLD: IF prspace[i].markflag THEN *) BEGIN markedk := markedk + 1; markflag[i] := false (* OLD: prspace[i].markflag := 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); 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; (* 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: integer; 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 ID 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: integer): 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 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; #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:=' '; j:= 0; WHILE (i <= maxstrsp) AND (strspace[i] <> eos) #d AND (j <9 ) do begin j:= j + 1; s1[j] := strspace[i]; 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 #p reset(finput,s1); #d reset(finput,s1,0,0,'DSK '); mkint(3,1) end else if info_of(r[2])= Xoutput then begin #p rewrite(foutput,s1); #d rewrite(foutput,s1,0,0,'DSK '); mkint(2,1) 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: ; #d 2: break(output); #a 3: close(finput); #d 3: ; #ap 4: close(foutput); #d 4: 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; (* need to change for multiple output channels. *) BEGIN CASE outchnl OF #p 1: writeln(' '); #d 1: begin writeln(output); break(output); end; #dp 2: begin writeln(foutput,' '); break(foutput); end; #awtv 1: writeln(output); #wtv 2: writeln(foutput); END (* CASE *) END; #adv FUNCTION Int_field(I:integer):Integer; #adv Begin #adv Int_field:=2+trunc(log(abs(I))); #adv END; PROCEDURE XwriteInt(I:integer); BEGIN #adptw CASE outchnl OF #p 1: write(' ', I:0); #dv 1: If I=0 then Write('0') else write(I:Int_field(I) ); #atw 1: write(i); #p 2: write(foutput,' ', I:0); #dv 2: If I=0 then Write(foutput,'0') else write(foutput,I:Int_field(I) ); #atw 2: write(foutput, i); #adptw END (* CASE *) END (* XwriteInt *); PROCEDURE Xwritereal(R:real); BEGIN #adtpw CASE outchnl OF #p 1: write(' real Bug ', trunc(R)); #adtvw 1: write(output,R); #p 2: write(foutput,' real Bug ', trunc(R)); #dtvw 2: write(foutput,R); #adtpw END (* CASE *) END; PROCEDURE XwriteChar(C:onechar); BEGIN #adptw CASE outchnl OF #p 1: write(' ', C); #adtvw 1: write(C); #p 2: write(foutput,' ', C); #adtvw 2: 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]) = flotag THEN XwriteReal(flospace[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]) = 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; 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 #adptvw ch := symin^; (* a little strange, but avoids *) #adptvw get(symin); (* initialization problems *) #adptvw ichrbuf[inchnl] := symin^; (* Peek ahead *) END; 2: BEGIN #tw IF charcnt > Length(line) THEN #tw BEGIN #tw charcnt := 1; #tw Readln(line) #tw END; #tw ch := line[charcnt]; #tw IF Length(line) > charcnt THEN #tw ichrbuf[inchnl] := line[charcnt + 1] #tw ELSE ichrbuf[inchnl] := sp; #tw charcnt := charcnt + 1 #adpv ch := input^; #adpv get(input); #adpv ichrbuf[inchnl] := input^; END; #dp 3: begin #dp ch := finput^; #dp get(finput); #dp ichrbuf[inchnl] := finput^; #dp END; END; (* case *) END; (* rdchnl *) FUNCTION eofchnl: boolean; BEGIN #adptvw CASE inchnl OF #adptvw 1: eofchnl := eof(symin); #adptvw 2: eofchnl := eof(input); #adptvw 3: eofchnl := eof(finput); #adptvw END; END; FUNCTION eol: boolean; BEGIN CASE inchnl OF 1: eol := eoln(symin); 2: eol := eoln(input); 3: eol := eoln(finput); 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; (* reads fixnums...need to read flonums too *) 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 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 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 *) END; (* of case *) END; END; (* xrdtok *) (* for DEBUG *) (********************************************************) (* *) (* 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 #tw CHARCNT := 1; #tw LINE := ''; (* initialize top of stack *) st := 0; freefloat := 1; (* 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 (* OLD: prspace[i].MarkFlag := false; *) 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 trueref := idref; (* returns location for 't. *) END; (* init gensym id list *) FOR i := 1 TO max_gsym DO g_sym[i] := '0'; (* clear the counters *) idspace[xraise].val := trueref; gccount := 0; consknt := 0; END; (* init1 *) PROCEDURE init2; BEGIN (* load "symbol table" with identifiers, constants, and functions. *) inchnl := 1; (* select symbol input file. *) outchnl := 1; (* select symbol OUTPUT file. *) #p reset(symin,'paslsp.ini'); #p reset(input); #p rewrite(output); #w reset(symin, "paslsp.ini"); #t reset(symin,'#5:poly.data'); #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 BEGIN; #a ichrbuf[i]:=' '; #a END; 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); mkint(i1 DIV i2, 1); mkint(i1 MOD i2, 2); 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); mkint(i1 DIV i2, 1) END; PROCEDURE xremainder; VAR i1, i2: longint; BEGIN int_val(r[1], i1); int_val(r[2], i2); 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 *)