IMD 1.17: 14/03/2012 8:48:09 COMP2: B3466A 3.5" DS      €COMP2  M”HPARAMLISTTéK -”35€,–SCANNERT__éK9˘”4€ˇHSCHEMAT___éKŰ”4 €USTRMT_____éKę”4!€STRUCTST__éKë”4$€-SYMDEFT___éK”4%€SYMTREET__éK ”4'€ rSTATEMENTTéK†”43€…•SYMTABLET_éKž!”45€ [TREESRCHT_éKż”4W€»TYPT______éKÎT”5€S0UTILITIESTéK"J”5€I ˙˙ {file PARAMLIST} implement procedure routinetype(fsys: setofsys; var fsp: stp; fsy: symbols); forward; PROCEDURE PARAMETERLIST (fsys,FSY: SETOFSYS; VAR FPAR: CTP; var flc: addrrange; forw: boolean; fmarkstacksize: addrrange); { Process a parameter list. Returns FPAR = ptr to first parameter, FLC = # of address units needed for parameters. The global variable LC is used to allocate copied value parms. } VAR LCP,LCP1,LCP2,LCP3,dope_parameter: CTP; LSP: STP; ltype: vartype;  t,plc,iplc: ADDRRANGE; TEST: BOOLEAN; lsy: symbols; lsys: setofsys; procedure conformant_array(fsys: setofsys; var fsp: stp); var lsize : integer; lcp : ctp; lsp, lsp1, lsp2 : stp; test, packit, packing : boolean; numbits : shortint; BEGIN if sy = packedsy then begin packing := true; insymbol; end else packing := false; if sy <> arraysy then begin error(6); skip(fsys + [semicolon,rparent]);       begin error(2); lcp := NIL; skip(fsys+[ident,semicolon,rbrack,ofsy]); end else searchid([types],lcp); IF lcp <> NIL THEN begin if lcp^.idtype <> NIL then IF lcp^.idtype^.FORM <= SUBRANGE THEN LSP^.INX UNTIL LSP1 = NIL; end else error(2); FSP := LSP; if stdpasc then error(606); END; (* conformant_array *) BEGIN IF NOT (SY IN FSY + [LPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END; IF SY = LPARENT THEN TYPE := lcp^.idtype ELSE ERROR(113); if loboundid <> NIL then loboundid^.idtype := lcp^.idtype; if hiboundid <> NIL then hiboundid^.idtype := lcp^.idtype; end; end; END; LSP1 := LSP; insymbol; TEST := SY <> semic BEGIN INSYMBOL; IF NOT (SY IN [IDENT,VARSY,anyvarsy,procsy,funcsy]) THEN BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END; LCP1 := NIL; LCP3 := NIL; WHILE SY IN [IDENT,VARSY,anyvarsy,procsy,funcsy] DO begin if (sy = procsy) o end else INSYMBOL; IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11); LSP1 := fsp; REPEAT NEW(LSP,cnfarrays); WITH LSP^ DO BEGIN AELTYPE := LSP1; INXTYPE := NIL; ispackable := false; sizeoflo := false; unpacksize := 0; align :=olon; IF NOT TEST THEN begin if packing then error(142); INSYMBOL; end; UNTIL TEST; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); if (sy = arraysy) or (sy = packedsy) then begin  wordalign; AISPACKD := FALSE; aelsize := wordsize; FORM := cnfarrays; info := sysinfo; aisstrng := false; strucwaspackd := packing; { look for .. : typeident } new(cnf_index); with cnf_index^ do begin if sy <> ident then begin  if packing then error(142); conformant_array(fsys,lsp); end else if sy = ident then begin searchid([types],lcp); lsp := lcp^.idtype; REPEAT WITH LSP1^ DO BEGIN LSP2 := AELTYPE; AELTYPE := LSP; IF LSP <> NIL error(2); loboundid := NIL; end else begin new(loboundid,vars); with loboundid^ do begin newident(namep,id); idtype := NIL; next := NIL; klass := vars; vlev := level; globalptr := NIL; vtype := boundparm; infoTHEN info := sysinfo + (lsp^.info * [mustinitialize,cantassign]); IF (INXTYPE <> NIL) and (AELTYPE <> NIL) THEN BEGIN {***** Compute array element size *****} packit := PACKING and aeltype^.ispackable; IF packit THEN BEGIN := sysinfo + [cantassign]; end; if not forw then enterid(loboundid); insymbol; end; if sy = rangesy then insymbol else begin error(22); skip(fsys+[ident,semicolon,rbrack,ofsy]); end; if sy <> ident then b {packable array} numbits := aeltype^.bitsize; if numbits+numbits > BITSPERWORD then packit := false else begin {*** 1,2,4,8,16 bit arrays only ***} if numbits > 8 then numbits := 16 else if numbits > 4 then numbits := egin error(2); hiboundid := NIL; end else begin new(hiboundid,vars); with hiboundid^ do begin newident(namep,id); idtype := NIL; next := NIL; klass := vars; vlev := level; globalptr := NIL; vtype := boundparm; 8 else if numbits = 3 then numbits := 4; end END; if packit then begin AISPACKD := TRUE; AISSTRNG := FALSE; aelbitsize := numbits; align := wordalign; end else begin AISPACKD := FALSE; info := sysinfo + [cantassign]; end; if not forw then enterid(hiboundid); insymbol; end; if sy <> colon then begin error(5); skip(fsys+[ident,semicolon,rbrack,ofsy]); end else insymbol; if sy <> ident then with aeltype^ do begin if sizeoflo then error(675); lsize := ((unpacksize + align-1) div align) * align; end; aelsize := lsize; align := wordalign; end; unpacksize := 0; END END; LSP := LSP1; LSP1 := LSP2      r (sy = funcsy) then begin lsy := sy; insymbol; if sy <> ident then error(2) else begin new(lcp,routineparm,procparm); with lcp^ do begin newident(namep,id); idtype := nil; info := sysinfo; klass := routineparm; vlev := level; globalptr := LCP^.IDTYPE; if ltype = valparm then {check for copied value parameter} IF LSP <> NIL THEN begin IF cantassign in lsp^.info THEN ERROR(121); IF lsp = strgptr THEN ERROR(733); if lsp^.sizeoflo then error(653); if lsp <> nil then := nil; if lsy = funcsy then vtype := funcparm else vtype := procparm; next := lcp1; lcp1 := lcp; {i.e., push} end; if not forw then enterid(lcp); insymbol; if lsy = procsy then lsys := [lparent,rparent,semicolon] else lsys with lsp^ do IF ((unpacksize > wordsize) and (form <> prok)) OR strgtype(lsp) THEN ltype := cvalparm; {pass copied value} end; { Fill in IDTYPE, record value pass choice in current parms } LCP3 := LCP2;  := [lparent,rparent,semicolon,colon]; if not (sy in lsys) then begin error(7); skip(lsys+fsys+fsy) end; routinetype(fsys+[rparent],lcp^.proktype,lsy); if lsy = funcsy then begin lcp^.proktype^.form := funk; if sy <> colon then erro if (ltype=refparm) and (lsp=strgptr) then ltype := strparm; if (ltype = anyvarparm) and (lsp = strgptr) then error(733); WHILE LCP2 <> NIL DO BEGIN LCP := LCP2; WITH LCP2^ DO BEGIN IDTYPE := LSP; vtype := ltype; r(123) else begin insymbol; if sy <> ident then error(2) else begin searchid([types],lcp2); lcp^.idtype := lcp2^.idtype; if lcp2^.idtype=strgptr then error(733); end; insymbol; end; {colon} end; end;  LCP2 := NEXT END END; LCP^.NEXT := LCP1; LCP1 := LCP3; INSYMBOL END (* sy=ident *) ELSE if (sy = arraysy) or (sy = packedsy) then begin lsp := NIL; conformant_array(fsys,lsp); lcp3 := lcp2; while lcp2 {routine name ident} end {proc,func} else {var, anyvar, ident} BEGIN IF SY = VARSY THEN BEGIN ltype := refparm; INSYMBOL; END else if sy = anyvarsy then begin ltype := anyvarparm; insymbol; end ELSE ltype := valparm; LCP2 := NIL;<> NIL do begin lcp := lcp2; with lcp2^ do begin idtype := lsp; if ltype = valparm then begin vtype := cvalparm; if cantassign in lsp^.info then error(121); end else if ltype = anyvarparm then error(733) else  REPEAT IF SY <> IDENT THEN ERROR(2) ELSE BEGIN if (ltype = refparm) or (ltype = anyvarparm) then new(lcp,vars,refparm) else new(lcp,vars,cvalparm (*worst case*)); WITH LCP^ DO BEGIN newident(namep,ID); IDTYPvtype := refparm; lcp2 := next; end end; lcp^.next := lcp1; lcp1 := lcp3; insymbol; { add a parameter to corespond to all boundparms } new(dope_parameter,vars,dopeparm); with dope_parameter^ do begin namep E := NIL; NEXT := LCP2; KLASS := VARS; VLEV := LEVEL; globalptr := NIL; vtype := ltype; info := sysinfo; END; if not forw then ENTERID(LCP); LCP2 := LCP; INSYMBOL; END; IF NOT (SY IN FSYS + [COMMA,COLON]) THEN := nil; {copy idtype} new(idtype); idtype^ := lsp^; vtype := dopeparm; next := lcp^.next; klass := vars; firstparm := lcp1; end; lcp^.next := dope_parameter; end ELSE ERROR(2); IF NOT (SY IN [SEMICOLON,RPA BEGIN ERROR(7); SKIP(FSYS + [COMMA,SEMICOLON,RPARENT,COLON]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP RENT]) THEN BEGIN ERROR(7); SKIP(FSYS + [SEMICOLON,RPARENT]) END; END (* sy=colon *) ELSE ERROR(5); end; {ident,var} IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT,VARSY,anyvarsy,funcsy,procsy]) THEN BEGIN ERROR(7);      if loboundid <> NIL then { Allocate space to maintain a size } t := allocate(plc, idtype, true, parmalign); end; {with hiboundid^} end; { with lsp^.cnf_index^ } lsp := lsp^.aeltype; end; {while (lsp <> NIL) aPACKED ON$ MOVELEFT(SYMBUF[ERRSTART],A,SYMCURSOR-ERRSTART); $ALLOW_PACKED OFF$ if a[0] = chr(16{DLE}) then begin a[0] := ' '; a[1] := ' '; end; line2 := linestart-errstart; if a[line2] = chr(16{DLE}) then begin a[line2] := ' '; a[lind (lsp^.form = cnfarrays)} $IF NOT partialevaling$ $PARTIAL_EVAL OFF$ $END$ end; end; {case} LCP3 := LCP1; LCP1 := LCP2 END; FPAR := LCP3; plc := abs(plc-iplc); t := plc mod parmalign; if t <> 0 then plc := ne2+1] := ' '; end; for i := 0 to SYMCURSOR-ERRSTART-1 do if a[i] = chr(13) then writeln(output) else WRITE(OUTPUT,A[i]); WRITELN(OUTPUT,' <<<<'); WRITELN(OUTPUT,'Line ',linenumber+1:1,', error ',ERRORNUM:1); reset(message_index, SKIP(FSYS + [IDENT,RPARENT]) END END; END; (*WHILE*) IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSY + FSYS) THEN BEGIN ERROR(6); SKIP(FSY + FSYS) END END ELSE ERROR(4); {Reverse order of parameter list, allocate addrplc + (parmalign-t); flc := plc; END (* IF SY=LPARENT *) ELSE BEGIN FPAR := NIL; FLC := 0 END; {no parameters} END; (*PARAMETERLIST*) esses} plc := lcaftermarkstack + fmarkstacksize; LCP3 := NIL; iplc := plc; WHILE LCP1 <> NIL DO WITH LCP1^ DO BEGIN LCP2 := NEXT; NEXT := LCP3; case vtype of valparm: vaddr := allocate(plc, idtype, true, parmalign); funcparm,  {file SCANNER} implement var inoption,skipping,ccinif: boolean; effectivelinestart,sentinel: shortint; chsave: char; linecount,linespp: integer; pagecount: shortint; ch: char; ok: boolean; curerr: shortint; errarray: array[1..maxerrorsprocparm: vaddr := allocate(plc, proktype, true, parmalign); anyvarparm, refparm: vaddr := allocate(plc, anyptrptr, true, parmalign); strparm: vaddr := allocate(plc, strgptr, true, parmalign); cvalparm: begin {Copied value parameter, VADD] of record errnum: shortint; errloc: cursrange end; esckey: string[6]; const bufsize = 110; eol = chr(13); procedure IDSEARCH(var id: alpha; var symbuf: symbufarray); external; procedure bcd_real $ALIAS 'ASM_BCD_REAL'$ R=addr of copy} vptraddr := allocate(plc, anyptrptr, true, parmalign); if idtype <> NIL then if idtype^.form <> cnfarrays then vaddr := allocate(LC, idtype, false, 1) else {value conformant array parameter} vaddr := vptrad (var bcd_str: bcd_strtype; var rval: real); external; function uniquenumber: shortint; begin uniquenum := uniquenum + 1; uniquenumber := uniquenum; end; PROCEDURE ERROR (ERRORNUM: SHORTINT); VAR CH: CHAR; i,ERRSTART,line2:dr; end; dopeparm: { Allocate space for the conformant array "dope vector" } begin lsp := idtype; $PARTIAL_EVAL$ while (lsp <> NIL) and (lsp^.form = cnfarrays) do begin with lsp^.cnf_index^ do begin if INTEGER; A: PACKED ARRAY [0..bufsize*2] OF CHAR; message_index: file of shortint; message_file: file of char; file_index: shortint; message: string[100]; const messages = '*MESSAGES'; BEGIN totalerrors:=totalerrors+1; synt (loboundid<>NIL) and (loboundid^.idtype<>NIL) then with loboundid^ do vaddr := allocate(plc, idtype, true, parmalign); if hiboundid <> NIL then with hiboundid^ do begin vaddr := allocate(plc, idtype, true, parmalign); xerr := true; WRITELN(OUTPUT); IF LINESTART < 2 THEN errstart := linestart ELSE ERRSTART := SCAN(-(LINESTART-1),=EOL,SYMBUF[LINESTART-2])+LINESTART-1; if (symcursor-errstart) > (bufsize*2) then errstart := symcursor - bufsize*2; $ALLOW_     messages); if ioresult = ord(inoerror) then begin open(message_index); seek(message_index,errornum); read(message_index,file_index); close(message_index); if file_index <> 0 then { bad error number } begin open(messagecrlinecount; writeln(lp,'***WARNING: (line',linenum:5,'): ',infostring); end; end; end; function opensource (fname: fid; srclevel: shortint; must: boolean) : boolean; {Open file "SOURCE" to access given name; returns TRUE if successful} _file,messages); seek(message_file,file_index); read(message_file,ch); setstrlen(message,ord(ch)); for i := 1 to ord(ch) do read(message_file,message[i]); writeln(output,message); end; end; if initlistmode=listno {Puts fname into sourceinfoptr^[srclevel].filename} {If MUST = true, wait for file to be inserted} var ok,done: boolean; ch: char; begin sourceinfoptr^[srclevel].filename := fname; done := true; {no prompt first time thru} repeat ne then begin if streaming then escape(-1); if ftype = norml then begin if kbdtype=itfkbd then esckey:='esc' else esckey:='sh-exc'; write(output,'=continue, <'+esckey+'>=terminate, E=edit ',chr(7)); read(keyb if not done then {Prompt for file if not first try} if streaming then begin error(401); escape(-1); end else begin writeln(output); write(output,'Mount ',fname,' and press ',chr(7)); read(keyboard,ch); writeln(output)oard,ch); writeln(output); if (ch = 'E') or (ch = 'e') then with userinfo^ do begin errnum := errornum; errblk := symblk; if errornum = 99 then errsym := gsymcursor-1 else errsym := symcursor; errfid := sourceinfoptr^[srcindex; if ch = chr(27) then escape(0); end; close(source); {Ensure source is closed} reset(source, fname,'SHARED'); if IORESULT = ord(inofile) then {Try appending .TEXT} if strlen(fname) + ].filename; end; if ch in ['e','E',chr(27)] then escape(0); end else { ftype = specil } begin write(output,'Error in interface text: =continue',chr(7)); read(keyboard,ch); writeln(output); if ch = chr(27) then5 <= strmax(fname) then begin reset(source,fname + '.TEXT','SHARED'); sourceinfoptr^[srclevel].filename := fname + '.TEXT'; end; ok := (IORESULT = ord(inoerror)); if ok then done := true else if must then done := false {Always retr escape(0); end; end; if listopen and (curerr < maxerrors) then begin curerr:=curerr+1; errarray[curerr].errnum:=errornum; errarray[curerr].errloc:=symcursor-linestart; end; END (*ERROR*) ; procedure errorwithinfo(*errorny if MUST} else done := not (IORESULT in [ord(ibadunit),ord(ilostunit),ord(inounit)]); {else, only retry NO-VOL errs} until done; opensource := ok; if ok then with fibp(addr(source))^ do if (fkind = textfile) or (fkind = codefum: shortint; infostring: string80*); {emit error with a line of additional information} begin writeln(output); write(output,infostring); if list <> listnone then begin incrlinecount; writeln(lp,infostring) end; error(errornum); end; pile) then begin am := amtable^[untypedfile]; fleof := fleof + (-fleof) mod pagesize; end; end; {opensource} procedure setlinewidth; { insert end-of-line sentinel based on width option } begin effectivelinestart := linestart; while symbuf[syrocedure warning(linenum: integer; infostring: string80); begin totalwarnings := totalwarnings + 1; if warn then begin writeln(output); write(output,'***WARNING (line',linenum:5,'): ',infostring); if list <> listnone then begin inmcursor] = CHR(16(*DLE*)) do begin { strip off blank compression } effectivelinestart := effectivelinestart + 2 - (ord(symbuf[symcursor+1])-ord(' ')); symcursor := symcursor+2; end; { set marker at effective end-of-line } sentin      with fibp(addr(source))^ do begin fpos := filepos; end; symblk := oldsymblk-2; relinum := oldrelinum; SYMCURSOR := OLDSYMCURSOR; LINESTART := OLDLINESTART; ftype := oldftype; end; until false; 1:setlinewidth; symblken WRITE(lp,'D',lc:6,levelatstart+linlevatstart:3,' ') else WRITE(lp,'D','':6,levelatstart+linlevatstart:3,' ') else WRITE(lp,'C','':6,levelatstart+linlevatstart:3,' ') ; LENG := SYMCURSOR-LINESTART; { NB: LENG includes the  := symblk + 2; symbolstart := symcursor; END (*GETNEXTPAGE*) ; procedure incrlinecount; begin linecount:=linecount+1; if (linecount>linespp) or (linecount=maxint) then begin if pagecount>0 then page(lp); pagecount:=pagecount+1; trailing EOL char, therefore LENG>=1 } IF LENG > bufsize THEN LENG := bufsize; $ALLOW_PACKED ON$ MOVELEFT(SYMBUF[LINESTART],A,LENG); $ALLOW_PACKED OFF$ IF A[0] = CHR(16(*DLE*)) THEN BEGIN offset := ORD(A[1])-ORD(' '); IF offset>0 THEN el := effectivelinestart+width; if sentinel > maxcursor then sentinel := maxcursor; chsave := symbuf[sentinel]; symbuf[sentinel] := eol; { remove leading blanks } symcursor := symcursor+scan(80,<>' ',symbuf[symcursor]) end; procedure fixupend;writeln(lp,compilername,' [Rev ',crevno,' ', crevid.month:2,'/',crevid.day:2,'/', crevid.year:2,'] ',fibp(addr(source))^.ftid, ' ':24-strlen(fibp(addr(source))^.ftid), todaysdate,' ',timestring,' Page ',pagecount:1); writeln(lp) { erase effect of SETLINEWIDTH before printing line. Advance cursor to actual end of line } begin symbuf[sentinel] := chsave; while symbuf[symcursor] <> eol do symcursor := symcursor+1; end; PROCEDURE GETNEXTPAGE; label 1; BEGIN gsymcur; linecount:=1 end; end; PROCEDURE PRINTLINE; { Print just-completed source line on listing } const prefixwidth = 19; { width of line prefix + 1} VAR DORC,STARORC: CHAR; LENG,offset,i,posonpage,curleng: INTEGER; A: PACKED Asor := symcursor; SYMCURSOR := 0; LINESTART := 0; repeat with fibp(addr(source))^ do begin filepos := fpos; if fkind in [textfile,codefile] then begin if fpos < fleof then begin freadbytes(source,symbuf, min(pagesRRAY [0..bufsize] OF CHAR; procedure printexcessA; {print string A[0..pagewidth-1] on listing while length(A) exceeds pagewidth} begin posonpage := prefixwidth+offset; if posonpage>pagewidth then begin writeln; error(601); ize,fleof-fpos)); if ioresult = ord(inoerror) then goto 1 else escape(-10); end; end else if not eof(source) then begin any_to_UCSD(source,symbuf); if ioresult = ord(inoerror) then goto 1 else escape(-10); end; end;  incrlinecount; posonpage := 1; end; while posonpage+leng-1 > pagewidth do begin curleng := pagewidth-posonpage+1; writeln(lp,a:curleng); leng := leng-curleng; $ALLOW_PACKED ON$ moveleft(a[curleng],a,leng); $ALLOW_PACKED {End of file reached} if srcindex <= 1 then {end of original source file} begin symbuf[0] := eol; if not endofprog then begin printlastline := true; ERROR(99); end else printlastline := false; escape(0);  OFF$ posonpage := 1; incrlinecount; end; end; function blankline : boolean; var leng: shortint; begin leng := symcursor - linestart - 1; if symbuf[linestart] = chr(16(*DLE*)) then leng := leng - 2;  end; srcindex := srcindex-1; {end of include file} with sourceinfoptr^[srcindex] do {restore state of previous file} begin if not opensource(filename,srcindex,true) then escape(0); filepos := oldfilepos; blankline := leng = 0; end; BEGIN { printline } IF BPTONLINE THEN STARORC := '*' else STARORC := ':'; incrlinecount; WRITE(lp,linenumber:6,STARORC); if skipping or blankline then WRITE(lp,'S','':10) else IF oldDP THEN if lc <> 0 th      WRITE(lp,' ':offset); LENG := LENG-2; $ALLOW_PACKED ON$ MOVELEFT(A[2],A,LENG) $ALLOW_PACKED OFF$ END else offset:=2; {adjusts for linestart not pointing at DLE} printexcessA; WRITELN(lp,A:LENG-1); {-1 to remove EOL} IF  then begin if (mantissa_digit <= 16) then mantissa[mantissa_digit] := ord(inputstr[i]) - ord('0'); mantissa_digit := mantissa_digit + 1; end; end else if inputstr[i] = '+' then if inexponent then exponentsign := 1 curerr>0 then begin fillchar(a,bufsize+1,' '); leng := 0; for i:=1 to curerr do with errarray[i] do begin a[errloc]:='^'; if errloc >= leng then leng := errloc+1; end; leng := leng-3; $ALLOW_PACKED ON$ moveleft(A[3],A,leng else signbit := pls else if inputstr[i] = '-' then if inexponent then exponentsign := -1 else signbit := mnus else if inputstr[i] = '.' then begin extraexponent := mantissa_digit-1; decpnt := true; end else if inputstr[i] = 'E' then ); $ALLOW_PACKED OFF$ incrlinecount; write(lp,' ':prefixwidth+offset-1); printexcessA; writeln(lp,a:leng); incrlinecount; WRITE(lp,'>>>>>> Error at ',fibp(addr(source))^.ftid,'/',relinum:1, ': ',errarray[1].errnum:1); for i:=2 to begin if not decpnt then extraexponent := mantissa_digit-1; inexponent := true; end; end; exponent := exponent * exponentsign + extraexponent; try bcd_real(bcd_str,realval); recover if escapecode = -19 then error(50) e curerr do write(lp,', ',errarray[i].errnum:1); if lasterrln <> 0 then write(lp,' (see also ',lasterrln:1,')'); writeln(lp); if list = listerronly then begin incrlinecount; writeln(lp) end; curerr:=0; lasterrln := linenumber; lse escape(escapecode); end; end; { buildreal } procedure newident(*var namep: alphaptr; newid: alpha*); {Put identifier string in heap, return ptr to it} begin newwords(namep, (strlen(newid)+2) div 2); namep^ := newid; end; procedure u end; if ioresult <> ord(inoerror) then begin listabort := true; list := listnone; listopen := false; warning(linenumber,'Listing aborted'); end; END (*PRINTLINE*); procedure buildreal(*inputstr: string80; var realval: real*pc(var s: string); var i: shortint; begin for i := 1 to strlen(s) do if (s[i] >= 'a') and (s[i] <= 'z') then s[i] := chr(ord(s[i])-32); end; PROCEDURE INSYMBOL; { Fetch next source token. Also produces listing when an EOL is crosse); var bcd_str: bcd_strtype; i,mantissa_digit,extraexponent,exponentsign: shortint; inexponent,decpnt: boolean; begin with bcd_str do begin decpnt := false; exponent := 0; extraexponent := 0; inexponent := d. } { Handles all 'control comments'. } LABEL 1; const tab = 9; var btemp: boolean; PROCEDURE CHECKEND; var blocks_read : integer; BEGIN (* CHECKS FOR THE END OF THE PAGE *) fixupend; try $ovflcheck on$ SCREENDOTS := SCREENfalse; exponentsign := 1; mantissa_digit := 1; for i := 1 to 16 do mantissa[i] := 0; for i := 1 to strlen(inputstr) do begin if (inputstr[i] >= '0') and (inputstr[i] <= '9') then if inexponent then exponent := exponent*10 + DOTS+1 $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 then screendots := 1 else escape(escapecode); linenumber := linenumber+1; if linenumber > 65534 then linenumber := 0; relinum := relinum+1; SY (ord(inputstr[i]) - ord('0')) else begin if decpnt then begin if (mantissa_digit = 1) and (inputstr[i] = '0') then extraexponent := extraexponent-1; end; if (mantissa_digit > 1) or (inputstr[i] <> '0')MCURSOR := SYMCURSOR + 1; IF ((SCREENDOTS-STARTDOTS) MOD 5 = 0) and not beforefirsttoken THEN WRITE(OUTPUT,'.'); IF (LIST=listfull) or listopen and (curerr>0) THEN PRINTLINE; BPTONLINE := FALSE; levelatstart := level; linlevatstart := li     etermine if it is 'ON' or OFF' } begin {sw} sw := true; if sy = ident then begin upc(id); if id = 'OFF' then sw := false else if id <> 'ON' then error(6); insymbol; { advance past the symbol } end; end; function getintegfiles THEN ERROR(608); fixname(ltitle,textfile); if opensource(LTITLE,srcindex+1,false) then begin with sourceinfoptr^[srcindex] do {save current file info} begin OLDSYMCURSOR := SYMCURSOR; OLDLINESTART := LINESTART; oldfer: integer; var lsp: stp; lvalu: valu; oldexp: exptr; begin oldexp := curexp; constant([dollarsy,comma,semicolon],lsp,lvalu); curexp := oldexp; if lsp <> intptr then begin error(50); getinteger := 0 end else getinilepos := filepos; oldsymblk := symblk; oldrelinum := relinum; oldftype := ftype; end; with fibp(addr(source))^ do if fkind = textfile then begin filepos := pagesize; fpos := filepos; end else filepos := 0; symnelevel; IF (symcursor > maxcursor) or (SYMBUF[SYMCURSOR]=CHR(0)) THEN GETNEXTPAGE ELSE if (symbuf[symcursor] = chr(3)) and (ftype = specil) then begin srcindex := srcindex - 1; with sourceinfoptr^[srcindex] do begin if teger := lvalu.ival; end; procedure gettitle(var s: string); { convert pa of char constant val.valp^ to string } begin s[0] := chr(0); if sy <> stringconst then error(648) else if val.intval then begin s[0] := chr(not opensource(filename,srcindex,true) then escape(0); filepos := oldfilepos; symblk := oldsymblk; relinum := oldrelinum; ftype := oldftype; with fibp(addr(source))^ do begin fpos := filepos; if fkind in [textfile,codefil1); s[1] := chr(val.ival); end else with val.valp^ do begin if slgth > strmax(s) then error(648) else begin s[0] := chr(slgth); moveleft(sval,s[1],slgth); end; end; insymbol; end; procedure getoptionname; e] then if fpos < fleof then freadbytes(source,symbuf,pagesize) else escape(-8) else if eof(source) then escape(-8) else any_to_UCSD(source,symbuf); end; if ioresult <> ord(inoerror) then escape(-10); symcursor := oldsymcurso var loptionname: optionlist; svskip,found: boolean; begin svskip := skipping; skipping := false; insymbol; if sy = ifsy then (*** kLuGe ***) begin sy := ident; id := 'IF' end else if sy = endsy then begin sy := ident; idr; symbolstart := symcursor; linestart := oldlinestart; if ftype = norml then begin list := gtemplist; linenumber := gtemplinenumber; width := gtempwidth; if putcode = false then putcode := temp_put; end; setlinewidth; e := 'END' end; if sy <> ident then begin loptionname := emptyop; if not(sy in [semicolon,comma]) then begin error(6); skip([dollarsy,semicolon,comma]); end; end else begin {search in option array} loptionname := aliasop; found:=fand; end else begin LINESTART := SYMCURSOR; setlinewidth end; oldDP := DP; END; (*CHECKEND*) procedure option; var optionname: optionlist; ltitle: fid; lid: alpha; btemp,done: boolean; lvid: vid; ltidlse; while (loptionname < illegal) and (not found) do if id = optionarray[loptionname] then found:=true else loptionname:=succ(loptionname); insymbol; end; skipping := svskip; optionname := loptionname; end; {getoptionname} : fid; i,lsegs,ior: integer; lkind: filekind; s: string[10]; procedure eatspaces; begin while symbuf[symcursor]=' ' do symcursor:=symcursor+1; end; function sw: boolean; { look for identifier in input, dprocedure doinclude; {Process a $INCLUDE command} var tfpos : integer; begin tfpos := fibp(addr(source))^.fpos; gettitle(ltitle); if sy <> dollarsy then begin error(24); skip([dollarsy]) end; IF srcindex >= maxin     blk := 0; IF (LIST=listfull) or listopen and (curerr>0) then begin {First listing of include line} fixupend; symcursor := symcursor+1; printline; end; srcindex := srcindex+1; relinum := 0; ftype := norml; GETNEXTPAGE; end ror(605); skipping := false; if optionname in [searchop,overlayop] then skip([dollarsy]) else skip([dollarsy,comma,semicolon]); skipping := true; end; end else case optionname of emptyop: ; aliasop: begin ifELSE begin {Couldn't open include file} ERROR(609); if not opensource(sourceinfoptr^[srcindex].filename,srcindex,true) then escape(0) else {restore SOURCE to old file} fibp(addr(source))^.fpos := tfpos; end; end; {doinclude}  not aliasok then error(621); if indefinesection then error(646); aliasok := false; gettitle(lid); upc(lid); newident(aliasptr,lid); end; allowpacked: allow_packed := sw; ansiop: begin if not before procedure doccif; {Process $IF boolean expression - changed 5/80 to call CONSTANT} var lsp: stp; lvalu: valu; oldexp: exptr; oldinbody: boolean; begin if ccinif then error(605); {nested $IF} ccinif := true; oldexp firsttoken then error(600); stdpasc := sw; end; callabsop: if sw then gcallmode := abscall else gcallmode := relcall; ccifop: doccif; ccendop: if ccinif then ccinif := false {end of successful $IF} else error(60:= curexp; oldinbody := inbody; inbody := true; {allow all op's to be folded} $IF fulldump$ new(lastexp); {scratch place for exp list} $END$ constant([dollarsy,comma,semicolon],lsp,lvalu); inbody := oldinbody; cu5); {not in $IF} codeop: begin if inbody then error(602); putcode := sw; end; copyrightop: gettitle(gcopyright); debugop: begin if inbody then error(602); DEBUGGING := SW; end; defop: rexp := oldexp; if lsp <> boolptr then error(135) else skipping := not odd(lvalu.ival); end; {doccif} procedure refdefop(var fsize: integer; defaultsize: integer; var fvolname: string); var tvolname: string255; begin if refdefop(defilesize, defiledefault,defvolname); floatop: begin if inbody then error(602); float := flt_on; if sy = ident then begin upc(id); if id = 'OFF' then float := flt_off $IF not MC68020$ not beforefirsttoken then error(600); if sy=intconst then begin fsize := getinteger; if (fsize<0) or (fsize>32767) then begin error(648); fsize := defaultsize; end; end else begin gettitle(tvolname); if tvolname[strlen(tvolname else if id = 'TEST' then float := flt_test $END$ else if id <> 'ON' then error(6); insymbol; end; end; heapdisposeop: begin if not beforefirsttoken then error(600); heapdispose := sw; end; inclo)] <> ':' then tvolname := tvolname + ':'; if strlen(tvolname) > strmax(fvolname) then error(648) else fvolname := tvolname; end; end; {refdefop} begin {option} if stdpasc then error(606); inoption := true; REPEAT p: doinclude; iochkop: giocheck := sw; linesop: begin linespp := getinteger; if linespp < 20 then begin error(648); linespp := 20 end; end; listop : if sy = stringconst then begin { LIST 'filename' }  {Process a control item} getoptionname; if skipping then begin {Ignore all options except $END} if optionname = ccendop then begin skipping := false; ccinif := false end else begin if optionname = ccifop then er gettitle(ltitle); if (initlistmode <> listnone) and not list_option_L then begin fixname(ltitle,textfile); close(lp,'lock'); if ioresult <> ord(inoerror) then begin setstrlen(s,0); ior := ioresult; strwrite(s,1,i,io     rue else begin error(6); skip([dollarsy,stringconst]); end; until done; end; overlaysizeop: begin if not beforefirsttoken then error(600); i := getinteger; if (i < 0) or (i > 32767) then error(6d; end else error(647); if (sy=comma) or (sy=semicolon) then insymbol else if sy = dollarsy then done := true else begin error(6); skip([dollarsy,stringconst]); end; until done; searchfilestop := searchfi48) else if maxoverlays = 0 then maxoverlays := i else error(649); if maxoverlays <> 0 then newbytes(overlaylistptr,16*maxoverlays); end; ovlfchkop: govflcheck := sw; pageop: if list = listfull then lestop+1; searchlistptr^[searchfilestop]:=syslibrary; end; stackchkop: begin if inbody then error(602); gstackcheck := sw; end; strposop: begin switch_strpos := sw; if not beforefirsttoken then error:1); warning(linenumber,'Error closing listing file, ioresult('+s+')'); end; rewrite(lp,LTITLE); listopen := (IORESULT = ord(inoerror)); if listopen then begin if initlistmode = listfull then LIST := LISTFULL; end else er begin {force a new page} linecount:=linespp; incrlinecount; linecount:=linecount-1 {not really printing a line} end; pagewidthop: begin i:= getinteger; if i < 80 then begin pagewidth := 80; error(648ror(400); end; end else {LIST ON/OFF} begin btemp := sw; if initlistmode = listfull then if btemp then LIST := listfull else LIST := listnone; end; modcalop: $IF allowmodcal$ begin modcal := sw;) end else if i > 132 then begin pagewidth := 132; error(648) end else pagewidth := i; end; partevalop: gshortcircuit := sw; PCop: begin if inbody then error(602); listPC := sw; end; rangeop: gra if not beforefirsttoken then error(600); end; $END$ $IF not allowmodcal$ begin error(649); btemp := sw; end; $END$ numop: begin linenumber := getinteger-1; if (linenumber < -1) or ngecheck := sw; refop: refdefop(refilesize, refiledefault,refvolname); saveop: saveconst := sw; searchsizeop: begin if not beforefirsttoken then error(600); i := getinteger; if (i < 0) or (i > 32766) the (linenumber > 65534) then begin error(614); linenumber := 0; end; end; overlayop: begin if maxoverlays = 0 then begin maxoverlays := overlaydefault; newbytes(overlaylistptr,16*maxoverlays)n error(648) else if maxsearchfiles = 0 then maxsearchfiles:= i+1 else error(649); if maxsearchfiles <> 0 then newbytes(searchlistptr,122*maxsearchfiles); searchfilestop := 1; searchlistptr^[searchfilest; end; overlaytop := 0; done := false; repeat if sy = stringconst then begin gettitle(ltitle); if strlen(ltitle) > 15 then error(648) else begin if overlaytop>=maxoverlays then error(604) else op]:=syslibrary; end; searchop: begin if maxsearchfiles = 0 then begin maxsearchfiles := searchdefault; newbytes(searchlistptr,122*maxsearchfiles); end; searchfilestop := 0; done := false; repeat begin upc(ltitle); overlaytop := overlaytop+1; overlaylistptr^[overlaytop] := ltitle; end; end; end else error(648); if (sy=comma) or (sy=semicolon) then insymbol else if sy = dollarsy then done := t if sy = stringconst then begin gettitle(ltitle); fixname(ltitle,codefile); if searchfilestop>=maxsearchfiles-1 then error(604) else begin searchfilestop := searchfilestop+1; searchlistptr^[searchfilestop] := ltitle; en     r(600); strpos_warn := false; end; sysprogop: begin sysprog := sw; if not beforefirsttoken then error(600); end; tablesop: begin if inbody then error(602); tables := sw; end; ucsdop: be if escapecode = -4 {overflow} then cval := 256 { insure syntax error } else escape(escapecode); $IF not ovflchecking$ $OVFLCHECK off$ $END$ symcursor := symcursor+1; end; TP := TP+1; if cval > 255 then errogin ucsd := sw; if not beforefirsttoken then error(600); end; warnop: warn := sw; otherwise error(649) END; (*CASES*) UNTIL (sy <> semicolon) and (sy <> comma); if sy <> dollarsy then begin error(24); skip([dollarsy]) end;r(708); T[TP] := chr(cval mod 256); end else if (symbuf[symcursor] in ['@'..'z']) and (symbuf[symcursor] <> '`'{grave}) then begin {#control char} TP := TP+1; T[TP] := chr(ord(symbuf[symcursor]) mod 32); symcursor := symcursor inoption := false; end; {option} PROCEDURE COMMENTER; var svskip,done: boolean; BEGIN SYMCURSOR := SYMCURSOR+1; (* POINT TO THE FIRST CHAR PAST "(*" OR "{" *) svskip := skipping; skipping := true; {Mark commented lines as ig+1; end else {# followed by something weird} begin symcursor := symcursor+1; error(709); end; if inoption then error(6); end {#} else begin {char is '} REPEAT REPEAT SYMCURSOR := SYMCURSOR+1; TP := TP+1; T[TP] := nored} SYMCURSOR := SYMCURSOR-1; (* ADJUST FOR FIRST +1 IN LOOP *) done := false; REPEAT SYMCURSOR := SYMCURSOR+1; WHILE SYMBUF[SYMCURSOR] = EOL DO begin if importexportext then begin symbolstart := symcursor; symcursor :SYMBUF[SYMCURSOR]; IF SYMBUF[SYMCURSOR] = EOL THEN BEGIN ERROR(660); GOTO 1 END; UNTIL SYMBUF[SYMCURSOR]=''''; SYMCURSOR := SYMCURSOR+1; UNTIL SYMBUF[SYMCURSOR]<>''''; 1:TP := TP-1; (* Take out ending ' *) end end; {while #= symcursor + 1; outputsymbol; symcursor := symcursor - 1; end; CHECKEND; end; if symbuf[symcursor] = '}' then begin done := true; symcursor := symcursor+1 end else if symbuf[symcursor] = '*' then if symbuf[symcursor+1] = ')' then  or '} SYMCURSOR := SYMCURSOR-1; (* adjust for INSYMBOL's incrementing *) SY := STRINGCONST; LGTH := TP; IF TP=1 THEN (* SINGLE CHARACTER CONSTANT *) with val do begin intval := true; IVAL := ORD(T[1]) end ELSE begi begin done := true; symcursor := symcursor+2 end; UNTIL done; skipping := svskip; END; (*COMMENTER*) PROCEDURE ASTRING; LABEL 1; VAR TP,cval: INTEGER; lvp: csp; T: PACKED ARRAY [1..110] OF CHAR; BEGIN TP := 0; n newwords(lvp,(sizeof(constrec,true,paofch)-(strglgth-lgth)+1) div 2); WITH lvp^ DO BEGIN CCLASS := paofch; SLGTH := TP; $ALLOW_PACKED ON$ MOVELEFT(T[1],SVAL[1],TP); $ALLOW_PACKED OFF$ END; with val do begin intval := false; VALP := l (* # of characters accumulated *) while (symbuf[symcursor]='#') or (symbuf[symcursor]='''') do begin if symbuf[symcursor]='#' then begin symcursor := symcursor+1; if stdpasc then error(606); if symbuf[symcursor] in ['0'..'9'] then bvp end end; END; (*ASTRING*) PROCEDURE NUMBER; label 1; VAR numstart,expoffset,ISUM,J: INTEGER; TIPE: (inttipe,realtipe); dummybool: boolean; LVP: CSP; realtemp: string80; BEGIN TIPE := inttipe; numstart := SYMCURSOR; egin {#number} cval := ord(symbuf[symcursor]) - ord('0'); symcursor := symcursor+1; while symbuf[symcursor] in ['0'..'9'] do begin $OVFLCHECK on$ try cval := cval*10 + ord(symbuf[symcursor]) - ord('0'); recover  expoffset := 0; REPEAT {scan over integer part} SYMCURSOR := SYMCURSOR+1 UNTIL (SYMBUF[SYMCURSOR]<'0') OR (SYMBUF[SYMCURSOR]>'9'); IF SYMBUF[SYMCURSOR]='.' THEN { Following line modified 8/12/89 JWH } {     t ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 then { integer ovfl } error(661) else escape(escapecode); 1: with val do begin intval := true; if uminus then ival := isum else if isum > MININT then ival := -isum d; end; '{': BEGIN COMMENTER; GOTO 1 END; '(': IF SYMBUF[SYMCURSOR+1]='*' THEN BEGIN SYMCURSOR := SYMCURSOR+1; COMMENTER; GOTO 1; END else if symbuf[symcursor+1] = '.' then begin symcursor := symcursor+1; sy := lbrack end ELSEelse begin ival := 0; error(661) end; end; END ELSE BEGIN (* REAL NUMBER HERE *) SY := REALCONST; NEW(LVP,true,REEL); with LVP^ do begin CCLASS := REEL; j := symcursor-numstart; {length of number} if j > strmax(re SY := LPARENT; ')': SY := RPARENT; ',': SY := COMMA; ' ',chr(tab): BEGIN SYMCURSOR := SYMCURSOR+1; if importexportext then outputsymbol; GOTO 1; END; '.': IF SYMBUF[SYMCURSOR+1]='.' THEN BEGIN SYMCURSOR := SYMC IF SYMBUF[SYMCURSOR+1]<>'.' THEN } (* WATCH OUT FOR '..' *) IF ((SYMBUF[SYMCURSOR+1]<>'.') AND (SYMBUF[SYMCURSOR+1] <> ')')) THEN BEGIN TIPE := REALTIPE; SYMCURSOR := SYMCURSOR+1; WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') Daltemp) then begin error(680); j := strmax(realtemp); end; realtemp[0] := chr(j+1); if uminus then realtemp[1] := '-' else realtemp[1] := '+'; $ALLOW_PACKED ON$ moveleft(symbuf[numstart], realtemp[2], j); $ALLOW_PACKED OFF$ if expoffset>0 O SYMCURSOR := SYMCURSOR+1; {scan fractional part} END; IF SYMBUF[SYMCURSOR] IN ['e','E','l','L'] THEN BEGIN tipe := realtipe; expoffset := symcursor-numstart+1; SYMCURSOR := SYMCURSOR+1; if stdpasc and (symbuf[sthen realtemp[expoffset+1] := 'E'; if realtemp[strlen(realtemp)] = '.' then error(18); buildreal(realtemp,RVAL); end; with VAL do begin intval := false; VALP := LVP end; END; {type real} SYMCURSOR := SYMCURSOR-1; (* adjust for INSYMymcursor-1] in ['l','L']) then error(606); IF SYMBUF[SYMCURSOR] IN ['+','-'] THEN SYMCURSOR := SYMCURSOR+1; if (symbuf[symcursor] < '0') OR (symbuf[symcursor] > '9') then warning(linenumber, 'chars other than 0-9,+,-,E,L in exponent are ambigBOL's incrementing *) END; (*NUMBER*) BEGIN (* INSYMBOL *) 1:symbolstart := symcursor; SY := OTHERSY; (* IF NO CASES EXERCISED BLOW UP *) OP := NOOP; CASE SYMBUF[SYMCURSOR] OF '''','#': ASTRING; '0'..'9': NUMBER; 'A'..'Zuous / do not conform to ANSI'); WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') DO SYMCURSOR := SYMCURSOR+1; END; (* NOW CONVERT TO INTERNAL FORM *) IF TIPE=INTTIPE THEN BEGIN {**********************************','a'..'z': begin idsearch(id,symbuf); if not modcal then if sy >= forwardsy then case sy of forwardsy: begin sy := ident; id := 'FORWARD'; end; externlsy: begin sy := ident; id := 'EXTERNA*********************************** CONVERT TO RETURN A NEGATIVE REPRESENTATION IF UMINUS IS TRUE. IF UMINUS IS FALSE AND THE NUMBER DOESN'T HAVE A POSITIVE REPRESENTATION ON THE HARDWARE, GIVE AN ERROR (e.g, 32768 in 16 bits); OTHERWISE, RETURL'; end; trysy: if not sysprog then begin sy := ident; id := 'TRY'; end; recoversy: if not sysprog then begin sy := ident; id := 'RECOVER'; end; anyvarsy: if not sysprog then begin sy := ident; id N THE POSITIVE NUMBER. *********************************************************************} SY := INTCONST; ISUM := 0; try $ovflcheck on$ FOR J := numstart TO symcursor-1 DO ISUM := ISUM*10-(ORD(SYMBUF[J])-ORD('0')); $if no:= 'ANYVAR'; end; end; end; '$': begin sy := dollarsy; if not inoption then begin symcursor := symcursor+1; btemp := importexportext; importexportext := false; option; importexportext := btemp; goto 1; en     URSOR+1; SY := rangesy; END else if symbuf[symcursor+1] = ')' then begin symcursor := symcursor+1; sy := rbrack end ELSE SY := PERIOD; ':': IF SYMBUF[SYMCURSOR+1]='=' THEN BEGIN SYMCURSOR := SYMCURSOR+1; SY := BECOMES; END = 0; relinum := relinum + 1; IF (LIST=listfull) or listopen and (curerr>0) THEN BEGIN {print last line} fixupend; symcursor := symcursor+1; if printlastline then PRINTLINE; END; IF listopen THEN begin {Report error ELSE SY := COLON; ';': SY := SEMICOLON; '^','@': SY := ARROW; '[': SY := LBRACK; ']': SY := RBRACK; '*': BEGIN SY := MULOP; OP := MUL END; '+': BEGIN SY := ADDOP; OP := PLUS END; '-': BEGIN SY := ADDOP; OP := MINUS END;  count} if (totalerrors>0) or (pagecount > 0) or (totalwarnings>0) then begin if term = abort then begin incrlinecount; writeln(lp); incrlinecount; writeln(lp,'COMPILATION ABORTED'); end; incrlinecount; writeln(lp); i '/': BEGIN SY := MULOP; OP := RDIV END; '<': BEGIN SY := RELOP; CASE SYMBUF[SYMCURSOR+1] OF '>': BEGIN OP := NEOP; SYMCURSOR := SYMCURSOR+1 END; '=': BEGIN OP := LEOP; SYMCURSOR := SYMCURSOR+1 END; otherwise op := ltop END; { case } ncrlinecount; if totalerrors > 0 then begin write(lp,totalerrors:1); if totalerrors = 1 then write(lp,' error. ') else write(lp,' errors. '); if lasterrln <> 0 then write(lp,'See line ',lasterrln:1,'. '); end else write(lp,'No',' END; '=': BEGIN SY := RELOP; OP := EQOP END; '>': BEGIN SY := RELOP; IF SYMBUF[SYMCURSOR+1]='=' THEN BEGIN OP := GEOP; SYMCURSOR := SYMCURSOR+1; END ELSE OP := GTOP; END; otherwise begin IF SYMBUF[SYMCURSOR] = EOL THEN  errors. '); if totalwarnings > 0 then begin write(lp,totalwarnings:1); if totalerrors = 1 then write(lp,' warning.') else write(lp,' warnings.'); end else write(lp,'No',' warnings.'); writeln(lp); if modcal or ucsd or sy begin if importexportext then begin symcursor := symcursor + 1; outputsymbol; symcursor := symcursor - 1; end; CHECKEND; symbolstart := symcursor; end ELSE begin symcursor:=symcursor+1; if not sprog then writeln(lp,'':15,'***** Nonstandard language features enabled *****'); page(lp); end; end; WRITELN(OUTPUT); if term = abort then begin writeln(output,'COMPILATION ABORTED'); writeln(output,'in ':8, fibp(addr(sskipping then ERROR(98); end; GOTO 1 {try again} end END; (* CASE SYMBUF[SYMCURSOR] OF *) SYMCURSOR := SYMCURSOR+1; (* NEXT CALL TALKS ABOUT NEXT TOKEN *) if skipping then goto 1; (* Ignore token found if skipping=true *) if impoource))^.ftid, ' at offset ',relinum:1); end; writeln(output); if not printlastline then screendots := screendots - 1; WRITE(OUTPUT,SCREENDOTS:1,' lines, '); if totalerrors=0 then write(output,'No') else write(output,totalerrors:1); rtexportext and not (sy = implmtsy) then outputsymbol; END; (*INSYMBOL*) PROCEDURE SKIP (*FSYS: SETOFSYS*); BEGIN WHILE NOT (SY IN FSYS) DO INSYMBOL END; procedure iowrapup(*term: termtype*); begin close(source,'normal'); try $ovflc if totalerrors=1 then write(output,' error. ') else write(output,' errors. '); if totalwarnings=0 then write(output,'No') else write(output,totalwarnings:1); if totalwarnings=1 then writeln(output,' warning.') else writeln(output,' warnings.')heck on$ SCREENDOTS := SCREENDOTS+1 $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 then screendots := 1 else escape(escapecode); linenumber := linenumber+1; if linenumber > 65534 then linenumber :; if modcal or ucsd or sysprog then writeln(output,'***** Nonstandard language features enabled *****'); if listabort then writeln(output,'Listing aborted'); end; (*iowrapup*) function getfid(anyvar s: fid) : fid; var i: shortint; b     h in ['y','Y','n','N','e','E','l','L']; writeln(output,ch); if ch >= 'a' then ch := chr(ord(ch)-32); {uppercase it} list_option_L := false; if ch = 'N' then begin list := listnone; listopen := false; end else if ch = 'L' then bt, lexical analysis} $INCLUDE 'IODEF'$ $INCLUDE 'SCANNER'$ end; {compio} $LINENUM 3000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compdebug; {compiler debugging utilities - all empty routines in production copies} $INCLUDE egin list_option_L := true; list := listfull; listopen := false; writeln(output); repeat write(output,'What listing file? '); readln(listfile); fixname(listfile,textfile); rewrite(lp,listfile); if ioresult 'DEBGDEF'$ $INCLUDE 'DUMPTREE'$ end; {compdebug} $LINENUM 4000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module symtable; {symbol table entry/lookup, structure manipulation} $INCLUDE 'SYMDEF'$ $INCLUDE 'SYMTABLE'$ $INCLUDE 'STegin if suffix(s) <> datafile then begin i := strlen(s); while (s[i] <> '.') do i := i - 1; getfid := str(s,1,i-1); end else { no suffix } getfid := s; end; procedure compioinit; var listfile: fid; begin {compio= ord(inoerror) then listopen := true else if streaming then escape(-10) else writeln('Error opening file'); until listopen; end else begin if ch = 'Y' then list := listfull else list := listerronly; $ALLOW_PACKED ON$ rew initialization body} new(sourceinfoptr); if userinfo^.gotsym then sourcefilename := userinfo^.symfid else begin write(output,'Compile what text? '); readln(input,sourcefilename); fixname(sourcefilename,textfile); if sourcefilrite(lp,'PRINTER:' + getfid(fibp(addr(source))^.ftid) + '.ASC'); $ALLOW_PACKED OFF$ listopen := ioresult = ord(inoerror); end; linespp := linesperpage; linecount := maxint-1; initlistmode := LIST; pagewidth := 120; pagecountename='' then if streaming then escape(-1) else escape(0); end; repeat ok := opensource(sourcefilename,1,false); if not ok then if streaming then begin error(401); escape(-1); end else begin if userinfo^.gotsym th := 0; curerr := 0; relinum := 0; lasterrln := 0; end; {compioinit} en write(output,sourcefilename,' '); write(output,'not found. file ? '); readln(input,sourcefilename); fixname(sourcefilename,textfile); if sourcefilename='' then escape(-1); end; until ok; writeln(output); srcindex := 1; ftype := norml; {Schema file: DEV- compile entire compiler} $REF 200$ $SEARCH 'CONVERT'$ $IOCHECK OFF,CALLABS OFF$ $UCSD,MODCAL$ program Compiler (input,output); $INCLUDE 'CHEADING'$ {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module globals; $Iskipping := false; ccinif := false; inoption := false; endofprog := false; width := 110; with fibp(addr(source))^ do if fkind = textfile then begin filepos := pagesize; fpos := filepos; end else filepos := 0; syNCLUDE 'CCONSTS'$ $INCLUDE 'GLOBALS'$ const { Conditional compilation constants } ovflchecking = false; $OVFLCHECK OFF$ rangechecking = false; $RANGE OFF$ partialevaling = false; $PARTIAL_EVAL OFF$ implement end; {- - - - mblk := 0; getnextpage; {fill source buffer} listPC := false; write(output,'Printer listing (l/y/n/e)? '); repeat read(keyboard,ch); if not (ch in ['y','Y','n','N','e','E','l','L']) and streaming then escape(-1); until c- - - - - - - - - - - - - - - - - - - - - - - - - - -} $INCLUDE 'FORWINIT'$ {abstract module COMPINIT} $INCLUDE 'FORWUTILS'$ $LINENUM 1000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compio; {source input, listing outpu     RUCTS'$ end; {symtable} {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} forward module codegen; {Code generation for the target machine} $INCLUDE 'GENDEF'$ end; forward module genutils; $INCLUDE 'GENUTLDEF'$ end; forward modulnitialization plus general purpose utilities} $INCLUDE 'INITDEF'$ $INCLUDE 'INIT'$ $INCLUDE 'UTILITIES'$ end; {compinit} $LINENUM 26000${- - - - - - - - - - - - - - - - - - - - - - - - - -} import globals,compinit,compio,symtable, declanale genmove; $INCLUDE 'GENMOVDEF'$ end; forward module float_hdw; $INCLUDE 'FLOATDEF'$ end; $LINENUM 5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module assemble; $INCLUDE 'ASSMDEF'$ $INCLUDE 'ASSEMBLE'$ end; {assemble} $LIyzer,codegen,genutils; begin {Modcal_Cross_Compiler} $INCLUDE 'MAINBODY'$ end. NENUM 6000${- - - - - - - - - - - - - - - - - - - - - - - - - -} module genutils; {utilities for code generation} $INCLUDE 'GENUTIL'$ end; {genutils} $LINENUM 9000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module genexprmod; {code gxDEVDR DEVR n rDEVDR n sSTRM eneration for expressions} $INCLUDE 'GENEXPDEF'$ $INCLUDE 'GENEXPR'$ end; {genexprmod} $LINENUM 12000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module float_hdw; {code generation for float card} $INCLUDE 'FLOAT'$ end; {float_hdw}  {file STRUCTS} FUNCTION PAOFCHAR (*FSP: STP): BOOLEAN*); var lsp: stp; BEGIN PAOFCHAR := FALSE; IF FSP <> NIL THEN IF FSP^.FORM = ARRAYS THEN if FSP^.AISPACKD then begin lsp := fsp^.aeltype; PAOFCHAR := (lsp = CHAR_PTR)  $LINENUM 13000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module genmove; {expression utilities, packing} $INCLUDE 'GENMOVE'$ end; {genmove} $LINENUM 15000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module code end; END (*PAOFCHAR*) ; FUNCTION STRGTYPE(*FSP: STP) : BOOLEAN*); BEGIN STRGTYPE := FALSE; IF PAOFCHAR(FSP) THEN STRGTYPE := FSP^.AISSTRNG END (*STRGTYPE*) ; function enumtype(*fsp: stp): boolean *); var b: boolean; beggen; {module codegen: implement section} $INCLUDE 'GENCODE'$ end; {codegen} $LINENUM 18000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} $CALLABS ON$ module bodyanalyzer; {Syntax analysis for executable statements; tree building} in enumtype := false; if fsp <> nil then if fsp^.form = scalar then begin b := (fsp^.scalkind = declared) and (fsp <> boolptr); enumtype := b; if stdpasc and b then error(606); end; end; function makepaofchartype (* lgth $INCLUDE 'BODYDEF'$ $INCLUDE 'BODYHEAD'$ $INCLUDE 'EXPRESSN'$ $INCLUDE 'STATEMENT'$ $INCLUDE 'BODY'$ end; {bodyanalyzer} $CALLABS OFF$ $LINENUM 21000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module declanalyzer; {Syntax anal: shortint) : stp *) ; (* Create type for a string constant of length lgth *) var lsp: stp; begin new(lsp,arrays,true,true); with lsp^ do begin ispackable := false; sizeoflo := false; {***** Machine dependent size & align of a pacysis for declarations; symbol table building} $INCLUDE 'DECLDEF'$ $INCLUDE 'PARAMLIST'$ $INCLUDE 'TYP'$ $INCLUDE 'BLOCK'$ end; {declanalyzer} $LINENUM 24000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compinit; {compiler iked array of char *****} unpacksize := lgth; align := 2; info := sysinfo; form := arrays; aeltype := char_ptr; aispackd := true; aelbitsize := bitsperchar; aisstrng := false; new(inxtype,subrange); with inxtype^ do begin ispackable:=false; u      var lmin1,lmin2,lmax1,lmax2: integer; begin if (fsp1=nil) or (fsp2=nil) then comppacs := true else if isPAC(fsp1) and isPAC(fsp2) then comppacs := (fsp1^.max - fsp1^.min) = (fsp2^.max - fsp2^.min) else comppacs := falseFSP1^.FORM = FSP2^.FORM THEN CASE FSP1^.FORM OF SCALAR: comptypes := ( (fsp1 = intptr) or (fsp1 = shortintptr) ) and ( (fsp2 = intptr) or (fsp2 = shortintptr) ); reals,RECORDS: COMPTYPES := FALSE; FILES: comptypes := (fsp1 = anyfilept; end; (*comppacs*) function compparmlists(fcp1,fcp2: ctp; checkids,fixingfwd: boolean): boolean; label 1; function compcnfparm(fstp1,fstp2: stp): boolean; begin compcnfparm := true; if fstp1^.aispackd <> fstp2^.aispackd tr) or (fsp2 = anyfileptr); SUBRANGE: COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE); POINTER: comptypes := (fsp1=anyptrptr) or (fsp2=anyptrptr); POWER: COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET); substring: comptypes := npacksize := intsize; align := intalign; info := sysinfo; form := subrange; rangetype := intptr; min := 1; max := lgth end end; makepaofchartype := lsp end (*makepaofchartype*); procedure stretchpaofchar(var fsp: stp; var fvalu: valuhen goto 1; if fstp1^.form <> fstp2^.form then goto 1 else if not fstp1^.aispackd then if fstp1^.strucwaspackd <> fstp2^.strucwaspackd then goto 1; if (fstp1^.inxtype <> NIL) and (fstp2^.inxtype <> NIL) then if fstp1^.inxtype <> fstp2^.; lgth: integer); { create packed array of char of length lgth, coercing single char to pa of char and padding with blanks as necessary } var lvp: csp; k: shortint; begin if lgth > 255 then begin error(659); lgth := inxtype then goto 1; if (fstp1^.aeltype <> NIL) and (fstp2^.aeltype <> NIL) then if fstp1^.aeltype^.form = cnfarrays then begin if not compcnfparm(fstp1^.aeltype,fstp2^.aeltype) then goto 1; end else if fstp1^.aeltype <> fstp2^.aeltype 255; end; fsp := makepaofchartype(lgth); newwords(lvp,(sizeof(constrec,true,paofch)-(strglgth-lgth)+1) div 2); with lvp^ do begin cclass := paofch; if fvalu.intval then begin slgth := 1; sval[1] := chr(fvalu.ival) end ethen goto 1; end; begin compparmlists := false; while (fcp1 <> nil) and (fcp2 <> nil) do begin if fcp1^.vtype <> fcp2^.vtype then goto 1; if fcp1^.vtype <> dopeparm then { dopeparms will not match, thats OK } if fcp1^.idtylse begin slgth := fvalu.valp^.slgth; for k := 1 to slgth do sval[k] := fvalu.valp^.sval[k]; end; for k := slgth+1 to lgth do sval[k] := ' '; if (slgth <> lgth) and stdpasc then error(606); slgth := lgth; end; with fvalu do pe <> fcp2^.idtype then if fcp1^.idtype^.form = cnfarrays then begin if not compcnfparm(fcp1^.idtype,fcp2^.idtype) then goto 1; end else if fixingfwd or (fcp1^.vtype <> anyvarparm) then goto 1; if fcp1^.klass = routineparm tbegin intval := false; valp := lvp end; end; {stretchpaofchar} function isPAC (fsp: stp): boolean; { fsp is an index type for a type for which PAOFCHAR yields true } begin isPAC := false; if fsp <> nil then with fsp^ do hen if not compparmlists(fcp1^.proktype^.params, fcp2^.proktype^.params,false,fixingfwd) then goto 1; if checkids then if fcp1^.namep^ <> fcp2^.namep^ then goto 1; fcp1 := fcp1^.next; fcp2 := fcp2^.next; end; compparmlists := fif form = subrange then if (min = 1) or UCSD then isPAC := (rangetype = intptr) or (rangetype = shortintptr); end; {isPAC} function comppacs(fsp1,fsp2: stp): boolean; {fsp1 & fsp2 must be index types of packed arrays of char}cp1=fcp2; { if not both nil, then wrong # of parms } 1: end; FUNCTION COMPTYPES (*FSP1,FSP2: STP) : BOOLEAN*); BEGIN if fsp1 = fsp2 then comptypes := true else if (fsp1 = nil) or (fsp2 = nil) then comptypes := true else IF      false; ARRAYS: if not (fsp1^.aispackd and fsp2^.aispackd) then comptypes := false else if FSP1^.AISSTRNG and FSP2^.AISSTRNG then comptypes := true else if paofchar(fsp1) and paofchar(fsp2) then comptypes := comppacs(fsp1^.inxtype,far fcp: ctp); function checkdefineconflicts(fcp: ctp): boolean; function paofchar (fsp: stp): boolean; function isPAC (fsp: stp): boolean; function strgtype (fsp: stp): boolean; function enumtype (fsp: stp): boolean; function makepaofcsp2^.inxtype) else comptypes := false; cnfarrays: comptypes := false; prok: comptypes := compparmlists(fsp1^.params,fsp2^.params,false,false); END (*CASE*) ELSE (*FSP1^.FORM <> FSP2^.FORM*) IF FSP1^.FORM = SUBRANGE THEN COMPTYPES :hartype (lgth: shortint): stp; procedure stretchpaofchar (var fsp: stp; var fvalu: valu; lgth: integer); function compparmlists(fcp1,fcp2: ctp; checkids,fixingfwd: boolean): boolean; function comptypes (fsp1,fsp2: stp): boolean; procedure getboun= COMPTYPES(FSP1^.RANGETYPE,FSP2) ELSE IF FSP2^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE) ELSE COMPTYPES := FALSE END; (*COMPTYPES*) PROCEDURE GETBOUNDS (*FSP: STP; VAR FMIN,FMAX: integer*); BEGIN WITH FSds (fsp: stp; var fmin,fmax: integer); procedure makefileident(var idptr: ctp; name: string10; offset: shortint); P^ DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN; FMAX := MAX; END ELSE if fsp = shortintptr then begin fmin := -32768; fmax := 32767 end else if (fsp=intptr) or (form<>scalar) then begin fmin := minint; fmax := maxint end else BN0 EQU 0 S1 DC.B 3,'AND' N1 DC.L S1,N0,N0 DC.B 38,2 S2 DC.B 6,'ANYVAR' N2 DC.L S2,N1,N3 DC.B 58,0 S3 DC.B 5,'ARRAY' N3 DC.L S3,N0,N4 DC.B 43,0 S4 DC.B 5,'BEGIN' N4 EGIN FMIN := 0; IF FSP = CHAR_PTR THEN FMAX := 255 ELSE IF FSP^.FCONST <> NIL THEN FMAX := FSP^.FCONST^.VALUES.IVAL ELSE FMAX := 0 END; END; (*GETBOUNDS*) procedure makefileident(var idptr: ctp; name: string10; offset: shorti DC.L S4,N0,N0 DC.B 19,0 S5 DC.B 4,'CASE' N5 DC.L S5,N2,N8 DC.B 21,0 S6 DC.B 5,'CONST' N6 DC.L S6,N0,N7 DC.B 28,0 S7 DC.B 3,'DIV' N7 DC.L S7,N0,N0 DC.B 38,3 S8 DC.nt); begin new(idptr,vars); with idptr^ do begin newident(namep,name); idtype := textptr; next := NIL; klass := vars; info := sysinfo; globalptr := sysglobalptr; vlev := 1; vaddr := offset; B 2,'DO' N8 DC.L S8,N6,N9 DC.B 6,0 S9 DC.B 6,'DOWNTO' N9 DC.L S9,N0,N10 DC.B 8,0 S10 DC.B 4,'ELSE' N10 DC.L S10,N0,N0 DC.B 13,0 S11 DC.B 3,'END' N11 DC.L S11,N5,N16 DC. vtype := refparm; end; end; B 9,0 S12 DC.B 6,'EXPORT' N12 DC.L S12,N0,N0 DC.B 48,0 S13 DC.B 8,'EXTERNAL' N13 DC.L S13,N12,N14 DC.B 55,0 S14 DC.B 4,'FILE' N14 DC.L S14,N0,N15 DC.B 45,0 S15 DC.B 3,'FOR' N15  {file SYMDEFINE} import globals,compinit,compio,sysglobals; export procedure searchsection (fcp: ctp; var fcp1: ctp); procedure searchid (fidcls: setofids; var fcp: ctp); procedure enterid (fcp: ctp); procedure searchavailablemodules(v DC.L S15,N0,N0 DC.B 24,0 S16 DC.B 7,'FORWARD' N16 DC.L S16,N13,N19 DC.B 54,0 S17 DC.B 8,'FUNCTION' N17 DC.L S17,N0,N18 DC.B 32,0 S18 DC.B 4,'GOTO' N18 DC.L S18,N0,N0 DC.B      4,'TYPE' N40 DC.L S40,N0,N41 DC.B 29,0 S41 DC.B 5,'UNTIL' N41 DC.L S41,N0,N0 DC.B 10,0 S42 DC.B 3,'VAR' N42 DC.L S42,N40,N43 DC.B 30,0 S43 DC.B 5,'WHILE' N43 DC.L S43,N0,N44 var lstmt: stptr; lquit: boolean; begin lhead := nil; repeat repeat lstmt := statement(fsys); if lhead=nil then lhead:=lstmt else llast^.next := lstmt; llast := lstmt; until not (sy in statbegsys); lquit := sy <> semicolon; DC.B 23,0 S44 DC.B 4,'WITH' N44 DC.L S44,N0,N0 DC.B 25,0 DEF SYMTREE END  if sy = semicolon then insymbol until lquit; end (*stmtlist*); function STATEMENT (*FSYS: SETOFSYS): stptr*); label 1; var lcp: ctp; ttop: disprange; llp: labelp; curstmt: stptr; procedure assignment (fcp: ctp); procedure reptypech26,0 S19 DC.B 2,'IF' N19 DC.L S19,N17,N20 DC.B 20,0 S20 DC.B 9,'IMPLEMENT' N20 DC.L S20,N0,N21 DC.B 49,0 S21 DC.B 6,'IMPORT' N21 DC.L S21,N0,N0 DC.B 47,14 S22 DC.B 2,'IN' SYMTREE  {file STATEMENT} function STATEMENT (FSYS: SETOFSYS): stptr; forward; function newstmt (scls: stmts; bkptable: boolean): stptr; (* allocate a 'stmt' record of given class, do standard initialization *) (* 'bkptable' is true if stmt requires a b DC.L S22,N11,N33 DC.B 40,14 S23 DC.B 5,'LABEL' N23 DC.L S23,N0,N0 DC.B 27,0 S24 DC.B 3,'MOD' N24 DC.L S24,N23,N25 DC.B 38,4 S25 DC.B 6,'MODULE' N25 DC.L S25,N0,N26 DC.B 46,kpt at its beginning *) var ls: stptr; begin case scls of {get only needed amount of space} becomest: new(ls,becomest); pcallst: new(ls,pcallst); casest: new(ls,casest); compndst: new(ls,compndst); 0 S26 DC.B 3,'NOT' N26 DC.L S26,N0,N0 DC.B 37,0 S27 DC.B 2,'OF' N27 DC.L S27,N24,N30 DC.B 11,0 S28 DC.B 2,'OR' N28 DC.L S28,N0,N29 DC.B 39,7 S29 DC.B 9,'OTHERWISE' N29 DC.L S forst: new(ls,forst); gotost: new(ls,gotost); ifst: new(ls,ifst); repst: new(ls,repst); tryst: new(ls,tryst); whilest: new(ls,whilest); withst: new(ls,withst); emptyst: new(ls,emptyst); 29,N0,N0 DC.B 50,0 S30 DC.B 6,'PACKED' N30 DC.L S30,N28,N31 DC.B 42,0 S31 DC.B 9,'PROCEDURE' N31 DC.L S31,N0,N32 DC.B 31,0 S32 DC.B 7,'PROGRAM' N32 DC.L S32,N0,N0 DC.B 33,0 S33 endofbodyst: new(ls,endofbodyst); end; with ls^ do begin sclass := scls; next := nil; try lineno := linenumber+1 recover lineno := 1; with sflags do begin rangecheck := grangecheck; iocheck := giocheck; shortci DC.B 6,'RECORD' N33 DC.L S33,N27,N39 DC.B 44,0 S34 DC.B 7,'RECOVER' N34 DC.L S34,N0,N35 DC.B 57,0 S35 DC.B 6,'REPEAT' N35 DC.L S35,N0,N0 DC.B 22,0 S36 DC.B 3,'SET' N36 DC.L Srcuit := gshortcircuit; callmode := gcallmode; ovflcheck := govflcheck; end; if debugging and bkptable then bptonline := true; $IF FULLDUMP$ snum := sctr; sctr := sctr+1; $END$ labp := nil; end; newstmt := ls end36,N34,N37 DC.B 41,0 S37 DC.B 4,'THEN' N37 DC.L S37,N0,N38 DC.B 12,0 S38 DC.B 2,'TO' N38 DC.L S38,N0,N0 DC.B 7,0 S39 DC.B 3,'TRY' N39 DC.L S39,N36,N42 DC.B 56,0 S40 DC.B  (*newstmt*); procedure stmtlist (var lhead,llast: stptr; fsys: setofsys); (* Parse statement list in procedure body, or compound, repeat, or try statements. lhead,llast: pointers to head, tail of list. fsys: error recovery symbols *)       eck; (* type check for := operation *) var lltype,lrtype: stp; begin {reptypecheck} with curstmt^ do begin lltype := lhs^.etyptr; lrtype := rhs^.etyptr; if (lltype <> nil) and (lrtype <> nil) then begin if cantassign in lltination,length) fillchar (destination,length,char) *) var lexp: elistptr; begin lexp := anyparm(fsys,lkey=spfillchar); curstmt^.actualp := lexp; if sy = comma then insymbol else error(20); if lkey=spfillchar ttype^.info then error(702); if comptypes(lltype,lrtype) then begin if (rhs^.eclass = litnode) then checkconst(lltype,rhs); end else {incompatible types} if arithtype(lltype) and arithtype(lrtype) then begin if not trytowihen lexp^.nextptr := integerparm(fsys) else lexp^.nextptr := anyparm(fsys,true); lexp := lexp^.nextptr; if sy = comma then insymbol else error(20); if lkey=spfillchar then lexp^.nextptr := charparm(fsys) else lexp^.nextptr := den(rhs,lltype) then error(129) end else if not paofcharcomp(rhs,lltype) then error(129); end; (*types <> nil*) end; end; (*reptypecheck*) begin (*assignment*) curstmt := newstmt(becomest,true); with curstmt^ do beginintegerparm(fsys); end (*move*); procedure unitio; (* parse calls to unitread, unitwrite (unitnumber, buffer, length[, blocknum[, async]]) *) var lexp: elistptr; begin lexp := integerparm(fsys); curstmt^.actualp := lexp assignableid(fsys + [becomes],fcp); lhs := curexp; if curexp^.ekind <> vrbl then error(56); if sy <> becomes then error(51) else begin insymbol; expression(fsys); rhs := curexp; reptypecheck end (*sy=becomes*) end (*wit; if sy = comma then insymbol else error(20); lexp^.nextptr := anyparm(fsys,lkey=spunitread); lexp := lexp^.nextptr; if sy = comma then insymbol else error(20); lexp^.nextptr := integerparm(fsys); lexp := lexp^.nextptr; h curstmt^*) end (*assignment*); procedure proccall (fsys: setofsys; fcp: ctp); var lkey: spkeys; waslparent: boolean; procedure pcall(isvar: boolean); { call(procedure variable [,parameters]) or procedure parameter[(parameters)] }if sy <> comma then lexp^.nextptr := makeintparm(-1) else begin insymbol; lexp^.nextptr := integerparm(fsys) end; lexp := lexp^.nextptr; if sy <> comma then lexp^.nextptr := makeintparm(0) else begin insymbol; lexp^.nextptr := integ var ltype: stp; begin curstmt^.actualp := newexplist; with curstmt^.actualp^ do begin if isvar then expression(fsys+[comma,rparent]) else identproc(fsys+[lparent,semicolon]); expptr := curexp; ltype := curexp^.etyptr; if ltype <> nierparm(fsys) end; end; {unitio} $PARTIAL_EVAL ON$ procedure makestringlit; { if parameter is a paoc literal or a char literal turn it into a string literal. } var lmin,lmax: integer; begin with curexp^ do begin if notl then if (ltype^.form <> prok) or (curexp^.ekind = cnst) then error(718) else if (sy = comma) and isvar then actparmlist(fsys,nextptr,ltype^.params) else if (sy = lparent) and not isvar then begin actparmlist(fsys,nextptr,lty (paofchar(etyptr) and (isPAC(etyptr^.inxtype) or etyptr^.aisstrng)) and ((etyptr <> char_ptr) or (eclass <> litnode)) then { if not paofchar(etyptr) and ((etyptr <> char_ptr) or (eclass <> litnode)) then } { Replaced 8/12/89 pe^.params); if sy=rparent then insymbol else error(4); end else if ltype^.params <> nil then error(126); end; end; {pcall} procedure move; (* parse calls to moveleft,moveright, or fillchar move (left|right) (source,desJWH } error(125) else if (eclass = litnode) and (litval.intval or (litval.valp^.cclass <> strctconst)) then { and (litval.intval or (litval.valp^.cclass <> strctconst)) added 8/12/89 JWH } begin if etyptr = char_ptr then stretchpaofchar(       with nextptr^.expptr^ do begin etyptr := strgptr; ekind := cnst; eclass := litnode; litval.intval := false; new(litval.valp); with litval.valp^ do begin cclass := strng; slgth := 0; end; { with procedure geta(mustbevar: boolean); var lexp: exptr; begin a := anyparm(fsys,mustbevar); lexp := newexpr; with lexp^ do begin eclass := subscrnode; arayp := a^.expptr; a^.expptr := lexp; ekind := arayp^.ekind; etyptr := nil; atype := arayp^litval.valp^ } end; { with nextptr^.expptr } end; { with nextptr^ } end; { make null string } end; { of second and third params } end; procedure seekit; begin curstmt^.actualp := fileparm(fsys,directfile); if sy.etyptr; if atype <> nil then if atype^.form <> arrays then begin error(125); atype := nil end else etyptr := atype^.aeltype; if sy = comma then insymbol else error(20); expression(fsys+[comma,rparent]); indxp := curexp; if etyptr,litval,1) else stretchpaofchar(etyptr,litval,litval.valp^.slgth); etyptr^.aisstrng := true; etyptr^.unpacksize := etyptr^.unpacksize+1; litval.valp^.cclass := strng; end; end; end; $PARTIAL_EVAL OFF$ procedure closefi <> comma then error(20); insymbol; curstmt^.actualp^.nextptr := integerparm(fsys); end; procedure newdispose; { parse calls to new and dispose } { new|dispose (pointer variable [,variant tags] ) } var lsp: stp; lsize: adle; { parse calls to close(file [,option]) option = (normal, lock, purge, crunch) } begin curstmt^.actualp := fileparm(fsys,any); with curstmt^.actualp^ do if sy <> comma then nextptr := makestrparm('NORMAL') else begdrrange; lcp: ctp; begin lsp := nil; lsize := 0; if sy = ident then begin searchid([vars,field],lcp); assignableid(fsys+[comma,rparent],lcp); if curexp^.etyptr <> nil then with curexp^.etyptr^ do if form = pointer then in insymbol; expression(fsys+[rparent]); nextptr := newexplist; nextptr^.expptr := curexp; makestringlit; end; end; procedure openfile; (* parse calls to append,reset, rewrite,open (file [, filenamestring]) *) begibegin if eltype <> nil then with eltype^ do begin lsize := unpacksize; if sizeoflo then error(672); if form = records then lsp := recvar; end end else error(125); end else error(2); with curstmt^ do ben if lkey = spopen then curstmt^.actualp := fileparm(fsys,directfile) else curstmt^.actualp := fileparm(fsys,any); if sy = comma then begin if (lkey in [spreset,sprewrite,spappend]) and stdpasc then error(606); insymbol; expressgin new(actualp,false); with actualp^ do begin expptr := curexp; {first parm is pointer var} getvariantsize(fsys,lsp,lsize); nextptr := makeintparm(lsize); {second parm is size to allocate} end end end; {newdion(fsys+[rparent,comma]); with curstmt^.actualp^ do begin nextptr := newexplist; nextptr^.expptr := curexp; end; makestringlit; if sy = comma then begin insymbol; expression(fsys+[rparent]); with curstmt^.actualp^.nextptr^ do ispose} procedure packem; { analyze pack(a,i,z) and unpack(a,i,z) } var a,i,z: elistptr; atype,ztype: stp; amin,amax,zmin,zmax: integer; procedure getz(mustbevar: boolean); begin z := anyparm(fsys,mustbevar); ztype := z^.exppt begin nextptr := newexplist; nextptr^.expptr := curexp; end; makestringlit; end else { make null string param } begin with curstmt^.actualp^.nextptr^ do begin nextptr := newexplist; nextptr^.expptr := newexpr; r^.etyptr; if ztype <> nil then if ztype^.form <> arrays then begin error(125); ztype := nil end else if not ztype^.aispackd then error(696) else if ztype^.aisstrng then begin error(125); ztype := nil; end; end;       atype <> nil then if not comptypes(atype^.inxtype,curexp^.etyptr) then begin error(139); atype := nil end else if indxp^.eclass = litnode then if not indxp^.litval.intval then begin error(302); atype := nil end; end; end; {get ptr^.expptr := curexp; if curexp^.etyptr <> textptr then error(184); if sy=comma then insymbol else error(20); expression(fsys+[comma,rparent]); end else { 1st parm not a file } { outputptr will not be NIL } ptr^.expptr :a} begin {packem} if lkey = sppack then geta(true) else getz(false); if sy = comma then insymbol else error(20); if lkey = spunpack then geta(false) else getz(true); curstmt^.actualp := a; a^.nextptr := z; if (aty= makefileexp(outputptr); if curexp^.etyptr <> NIL then begin new(ptr^.nextptr,false); ptr := ptr^.nextptr; ptr^.expptr := curexp; lsp := curexp^.etyptr; if lsp <> nil then if lsp^.form = subrange then lsp := lsp^.rangetype; if (lsp<>ipe <> nil) and (ztype <> nil) then if atype^.aeltype <> ztype^.aeltype then error(129) else if (atype^.inxtype <> nil) and (ztype^.inxtype <> nil) then begin getbounds(atype^.inxtype,amin,amax); getbounds(ztype^.inxtype,zmin,zmax); with a^.expptntptr) and (lsp<>shortintptr) then error(125); if sy=comma then insymbol else error(20); ptr^.nextptr := integerparm(fsys+[rparent]); end; end; procedure readwrite; {analyze write,writeln,read,readln, writedir,readdirr^.indxp^ do if (eclass = litnode) and litval.intval then if litval.ival < amin then error(134) else amin := litval.ival; if (amax-amin) < (zmax-zmin) then error(134); end; end; {packem} procedure strsetlen; ,strwrite,strread,prompt} var oldvarparm,continue: boolean; ptr: elistptr; j,k: integer; stringmax: shortint; lsp,filetype: stp; begin ptr := NIL; if not (lkey = spstrread) then begin new(ptr); curstmt^.actualp := ptr;  var destmax: integer; begin curstmt^.actualp := stringparm(fsys); destmax := 255; if curexp^.ekind <> vrbl then error(125) else if curexp^.etyptr <> nil then destmax := curexp^.etyptr^.maxleng; if sy = comma then insymbol end; if not waslparent then begin if lkey=spreadln then if inputptr <> nil then ptr^.expptr := makefileexp(inputptr) else begin error(185); ptr^.expptr := nil; end else if lkey in [spwriteln,spprompt,spoverprint] the else error(20); curstmt^.actualp^.nextptr:=integerparm(fsys); with curexp^ do if (eclass = litnode) and (litval.intval) then if (litval.ival > destmax) or (litval.ival < 0) then error(303); end; procedure pageit; n if outputptr <> nil then ptr^.expptr := makefileexp(outputptr) else begin error(185); ptr^.expptr := nil; end; end else begin varparm := (lkey = spread) or (lkey = spreadln); if lkey = spstrread then begin p {analyze page std proc} begin with curstmt^ do begin if waslparent then actualp := fileparm(fsys,textphile) else begin actualp := newexplist; actualp^.expptr := makefileexp(outputptr); end; end; end; procedure gottr := stringparm(fsys+[comma]); curstmt^.actualp := ptr; end else expression(fsys+[colon,comma,rparent]); if curexp^.etyptr<>nil then if curexp^.etyptr^.form = files then begin ptr^.expptr := curexp; if (lkey = spreaddir) or (lkeyoxy; {analyze gotoxy std proc} var ptr: elistptr; lsp: stp; begin new(ptr); curstmt^.actualp := ptr; expression(fsys+[comma,rparent]); if curexp^.etyptr <> NIL then if curexp^.etyptr^.form = files then begin  = spwritedir) then begin if (curexp^.etyptr = textptr) or (curexp^.etyptr^.filtype = nil) then error(125); if sy <> comma then error(20) else begin insymbol; ptr^.nextptr := integerparm(fsys); ptr := ptr^.nextptr; v      begin if (eclass=litnode) and litval.intval then if (litval.ival <= 0) or (litval.ival > stringmax) then error(302); end else begin if (etyptr <> nil) and (etyptr <> intptr) then error(125); if e685); if stdpasc then if paofchar(lsp) and (lkey in [spread,spreadln,spstrread]) then error(606); end; if (lkey=spread) or (lkey=spreadln) or (lkey=spreaddir) or (lkey=spstrread) then begin if curexp^.ekind<>vrbl thkind <> vrbl then error(103); end; end; varparm := lkey = spstrread; continue := sy=comma; if continue then begin insymbol; expression(fsys+[colon,comma,rparent]); end else error(20); end else ifen error(125) else { Check for FOR loop varible } if curexp^.eclass = idnode then if cantassign in curexp^.symptr^.info then error(702); end else if filetype = textptr then begin oldvarparm := varparm; varparm := false;arparm := lkey = spreaddir; end; end else if (lkey=spstrread) or (lkey=spstrwrite) then error(125) else if (curexp^.etyptr<>textptr) and (lkey in [spwriteln,spreadln, spoverprint,spprompt]) then error(184) else if  outputptr <> nil then ptr^.expptr := makefileexp(outputptr) else begin error(185); ptr^.expptr := nil; end; end else begin error(185); ptr^.expptr := nil end; if (lkey=spstrread) or (lkey=spstrwrite) then filetype := textptr elscurexp^.etyptr^.filtype = nil then error(125); continue := sy=comma; if continue then begin insymbol; expression(fsys+[colon,comma,rparent]) end else if not (lkey in [spreadln, spwriteln,spprompt,spoverprint]) then error(20)e if curstmt^.actualp^.expptr <> nil then filetype := curstmt^.actualp^.expptr^.etyptr else filetype := nil; while continue do begin new(ptr^.nextptr,false); ptr := ptr^.nextptr; ptr^.expptr:=curexp; if filetype <> nil then with curex; end else {1st param not a file} begin continue := true; if (lkey=spread) or (lkey=spreadln) then if inputptr <> nil then ptr^.expptr := makefileexp(inputptr) else begin error(185); ptr^.expptr := nil; end elp^ do if filetype <> textptr then if comptypes(etyptr,filetype^.filtype) then begin if eclass=litnode then checkconst(filetype^.filtype,curexp); end else if (lkey=spwrite) or (lkey=spwritedir) then begin { Following se if (lkey=spreaddir) or (lkey=spwritedir) then begin error(125); ptr^.expptr := nil; end else if (lkey=spstrread) or (lkey=spstrwrite) then begin ptr^.expptr := curexp; if not strgtype(curexp^.etyptr) then enhancement made 8/12/89 JWH } { if not trytowiden(curexp,filetype^.filtype) then if not paofcharcomp(curexp,filetype^.filtype) then error(134); } if not trytowiden(curexp,filetype^.filtype) then begin if not paofcharcom begin error(125); stringmax := 255; end else with curexp^ do begin if (lkey=spstrwrite) and (ekind<>vrbl) then error(103); if strgtype(etyptr) then stringmax := etyptr^.maxleng else begin getbop(curexp,filetype^.filtype) then error(134); end else ptr^.expptr := curexp; end else error(134) else begin lsp := etyptr; if lsp <> nil then if lsp^.form = subrange then lsp := lsp^.rangetype; if (lunds(etyptr^.inxtype,j,k); stringmax := k; end; end; for k := 1 to 2 do begin if sy=comma then insymbol else error(20); ptr^.nextptr := integerparm(fsys); ptr := ptr^.nextptr; with ptr^.expptr^ do if k = 1 then sp<>intptr) and (lsp<>shortintptr) and (lsp<>char_ptr) and (lsp<>boolptr) and (lsp<>realptr) and not enumtype(lsp) and not paofchar(lsp) then error(125); if paofchar(lsp) then if lsp^.unpacksize > 32767 then error(       for k := 1 to 1+ord(curexp^.etyptr = realptr) do begin if sy = colon then begin insymbol; with ptr^ do begin nextptr := integerparm(fsys+[colon]); with nextptr^.expptr^ do if (eclass = litnode) and litval.intval thend; {movestr} begin (*proccall*) curstmt := newstmt(pcallst,true); with curstmt^ do begin psymptr := fcp; actualp := nil end; if fcp^.klass = routineparm then pcall(false) else {klass = prox} begin if fcp^.pfdeckind en if (litval.ival < 0) or (litval.ival > 255) then error(686); end; end else ptr^.nextptr := newexplist; ptr := ptr^.nextptr; end; varparm := oldvarparm; end; continue := sy=comma; if continue then= special then begin lkey := fcp^.spkey; insymbol; if sy = lparent then begin insymbol; waslparent := true end else begin waslparent := false; if not (lkey in [spreadln,spwriteln, sphalt,spprompt,sppage,spoverprint]) then error(9);  begin insymbol; expression(fsys+[colon,comma,rparent]); end end; {while continue}; varparm := false; end; {if waslparent} if ptr <> NIL then ptr^.nextptr := nil; end {readwrite}; procedure movestr; procedure checkpaoc(is end; case lkey of spsetstrlen: strsetlen; spstrmove: movestr; spcall: pcall(true); spmoveleft,spmoveright,spfillchar: move; spnew,spdispose: newdispose; sppage: pageit; spgotoxy: gotoxy; spoverprint,spwrite,spwriteln, spread,spsource: boolean); var lmin,lmax: integer; begin with curexp^ do begin if not paofchar(etyptr) then if issource and (etyptr=char_ptr) and (eclass=litnode) then stretchpaofchar(etyptr,litval,1) else error(125) else if not etyptreadln,spreaddir,spwritedir, spprompt,spstrread,spstrwrite: readwrite; spunitread,spunitwrite: unitio; spclose: closefile; spreset,sprewrite,spopen,spappend: openfile; spseek: seekit; sppack,spunpack: packem; sphalt: if r^.aisstrng then begin getbounds(etyptr^.inxtype,lmin,lmax); if lmin <> 1 then error(125); end; if not issource and (ekind<>vrbl) then error(125); end; end; {checkpaoc} begin {movestr} curstmt := newstmt(becomeswaslparent then begin curstmt^.actualp := integerparm(fsys); with curstmt^.actualp^.expptr^ do if (eclass = litnode) and (litval.intval) then if (litval.ival < -32768) or (litval.ival > 32767) then error(125); t,true); with curstmt^ do begin rhs := newexpr; with rhs^ do begin etyptr := strgptr; eclass := substrnode; expression(fsys+[comma]); lengthp := curexp; checkint; if sy=comma then insymbol else error(20); expression(fsys+[co end; otherwise error(651) end; if waslparent then if sy = rparent then insymbol else error(4) end else (* standard or declared proc *) begin insymbol; with curstmt^.psymptr^ do if pfdeckind = declared then if ismodulebody themma]); arayp := curexp; checkpaoc(true); if sy=comma then insymbol else error(20); expression(fsys+[comma]); indxp := curexp; checkint; if sy=comma then insymbol else error(20); end; lhs := newexpr; with lhs^ do begin etyptrn error(704) else { trying to call main prog ? } if curstmt^.psymptr = outerblock then error(103); if sy=lparent then begin actparmlist(fsys,curstmt^.actualp,fcp^.next); if sy = rparent then insymbol else error(4) end else i := strgptr; lengthp := nil; eclass := substrnode; expression(fsys+[comma]); arayp := curexp; checkpaoc(false); if sy=comma then insymbol else error(20); expression(fsys+[rparent]); indxp := curexp; checkint; end; end; f fcp^.next <> nil then error(126); end; end; end (*proccall*); PROCEDURE GOTOSTATEMENT; VAR LLP: LABELP; FOUND: BOOLEAN; TTOP: DISPRANGE; BEGIN curstmt := newstmt(gotost,true); insymbol; with curstmt^ do begin target := nil;        := statement(fsys+[elsesy]); if sy = elsesy then begin insymbol; fals := statement(fsys) end else fals := nil end end (*ifstatement*) ; procedure casestatement; var lstp,lstp1,lstp2: stp; lcurrlab,ltemp: clabptr; ldonelabs, ldonecase: b begin inbody := false; { used to detect non standard use } repeat (* for each case label *) new(lcurrlab); with lcurrlab^ do begin constant(fsys+[rangesy,comma,colon],lstp1,lvalu); if not comptypes(lstp,lstp1) then error(oolean; lcurrstmt,lastmt,dummy: stptr; lvalu: valu; procedure insortcaselabel (flabp: clabptr); (* insert case label into case label list ordered by ascending lowval. flabp - pointer to label to be inserted curstmt^.minlab - po147); lowval := lvalu.ival; if sy=rangesy then begin (* label is subrange *) insymbol; if stdpasc then error(606); constant(fsys+[comma,colon],lstp2,lvalu); if not comptypes(lstp1,lstp2) then error(107); hival := lvalu.ival;  IF SY <> INTCONST THEN ERROR(15) else BEGIN FOUND := FALSE; TTOP := TOP; WHILE DISPLAY[TTOP].OCCUR in [RECORDscope,WITHscope] DO TTOP := TTOP - 1; LLP := DISPLAY[TTOP].FLABEL; WHILE (LLP <> nil) AND NOT FOUND DO WITHinter to first entry in list, or nil if list is empty curstmt^.maxlab - pointer to last entry, or nil *) label 1; var lcurr,lprev: clabptr; lval: integer; begin with curstmt^ do if minlab=nil then {first label} b LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN FOUND := TRUE; isrefed := true; target := llp; END ELSE LLP := NEXTLAB; if not found and (ttop > 0) then repeat repeat ttop := ttop - 1; until not (display[ttop].occur in [RECOegin minlab := flabp; maxlab := flabp; flabp^.clabp := nil end else {sort it in} begin lval := flabp^.lowval; lprev := nil; lcurr := minlab; while lcurr <> nil do if lcurr^.lowval < lval then begin lprev := lcurRDscope,WITHscope]); llp := display[ttop].flabel; if not (display[ttop].occur=modulescope) then while (llp <> nil) and not found do with llp^ do if labval = val.ival then begin nonlocalref := true; found := true; target := lr; lcurr := lcurr^.clabp end else goto 1; 1: if lprev = nil then minlab := flabp else begin lprev^.clabp := flabp; if lprev^.hival >= lval then error(156); end; flabp^.clabp := lcurr; if lcurr = nil then maxlab lp; end else llp := nextlab; until found or (ttop = 0) or (display[ttop].occur = modulescope); IF NOT FOUND THEN error(167); INSYMBOL END; end; END (*GOTOSTATEMENT*) ; procedure compoundstatement; var dummy: stp:= flabp else if lcurr^.lowval <= flabp^.hival then error(156); end; end (*insortcaselabel*); begin (*casestatement*) curstmt := newstmt(casest,true); insymbol; with curstmt^ do begin expression(fsys+[ofsy,comma,colon,rtr; begin curstmt := newstmt(compndst,false); insymbol; stmtlist(curstmt^.cbody,dummy,fsys + [semicolon,endsy]); if sy = endsy then insymbol else error(13); end (*compoundstatement*) ; procedure ifstatement; begin angesy]); selecter := curexp; lstp := selecter^.etyptr; if lstp <> nil then if lstp^.form > subrange then error(144); if sy = ofsy then insymbol else begin error(8); skip(fsys+[rangesy,comma,colon]) end; maxlab := nil; minlab := nil; nrlabs := 0; curstmt := newstmt(ifst,true); insymbol; with curstmt^ do begin expression(fsys+[thensy]); ifcond := curexp; with curexp^ do if (etyptr <> nil) and (etyptr <> boolptr) then error(135); if sy = thensy then insymbol else error(52); tru nrstmts := 0; firstmt := nil; otherwyse := nil; repeat (* for each case list element *) ltemp := nil; (* pts to unordered list of labels of current case, linked by 'temptr' fields *) if not (sy in [semicolon,othrwisesy,endsy]) then        if lowval > hival then begin error(102); hival := lowval end; end else begin (* label not a subrange *) hival := lowval; end; temptr := ltemp; ltemp := lcurrlab end (*with lcurrlab^*); insortcaselabel(lcurrlab);  then insymbol else error(54); rbody := statement(fsys) end end (*whilestatement*); procedure forstatement; var lcp: ctp; begin curstmt := newstmt(forst,true); insymbol; with curstmt^ do begin if sy <> ident t nrlabs := nrlabs+1; ldonelabs := sy <> comma; if sy = comma then insymbol until ldonelabs; inbody := true; if sy = colon then insymbol else error(5); lcurrstmt := statement(fsys+[semicolon,endsy,othrwisesy]); nrstmtshen begin error(2); skip(fsys+[becomes,tosy,downtosy,dosy]); lcp := NIL; end else begin searchid([vars],lcp); ctrl := newexpr; with lcp^,ctrl^ do begin eclass := idnode; etyptr := idtype; ekind := vrbl; symptr := lcp; if ( := nrstmts+1; (* link statement into statement list *) if firstmt = nil then firstmt := lcurrstmt else lastmt^.next := lcurrstmt; lastmt := lcurrstmt; (* make all current lbls point to current statement *) while ltemp <> nil vtype <> localvar) or (vlev <> level) then error(657); if etyptr <> nil then begin if etyptr^.form > subrange then error(143) else if cantassign in info then error(702) else info := info + [cantassign]; end; do with ltemp^ do begin cstmt := lcurrstmt; ltemp := temptr end; end (* if not (sy in [semicolon,othrwisesy,endsy]) *); ldonecase := sy <> semicolon; if sy = semicolon then insymbol until ldonecase; if sy = othrwisesy then be end; insymbol; end (*sy=ident*); if sy <> becomes then begin error(51); skip(fsys+[tosy,downtosy,dosy]) end else begin insymbol; expression(fsys+[tosy,downtosy,dosy]); init := curexp; if not comptypes(init^.etyptr,ctrl^.etyptr) then gin if stdpasc then error(606); insymbol; stmtlist(otherwyse,dummy,fsys); end; if sy = endsy then insymbol else error(13); if nrlabs = 0 then error(665); end (* with curstmt^ *) end (*casestatement*); procedure repeatstatement; va error(145) else if init^.eclass = litnode then checkconst(ctrl^.etyptr,init); end; if not(sy in [tosy,downtosy]) then begin error(55); skip(fsys+[dosy]) end else begin if sy = tosy then incr := 1 else incr := -1; insymbol; expression(fr dummy: stptr; begin curstmt := newstmt(repst,false); insymbol; with curstmt^ do begin stmtlist(rbody,dummy,fsys+[semicolon,untilsy]); if sy = untilsy then begin lineno := linenumber+1; {save line # of UNTIL symsys+[dosy]); limit := curexp; if not comptypes(limit^.etyptr,ctrl^.etyptr) then error(145) else if (limit^.eclass = litnode) then checkconst(ctrl^.etyptr,limit); end; if sy = dosy then insymbol else error(54); fbody := statement(fsys);bol} if debugging then bptonline:=true; insymbol; expression(fsys); rcond := curexp; with curexp^ do if (etyptr <> nil) and (etyptr <> boolptr) then error(135) end else error(53) end end (*repeatstatement*); procedure whilestate end; (*with curstmt^*) if lcp <> NIL then lcp^.info := lcp^.info - [cantassign]; end; (*forstatement*) procedure withstatement; var oldtop: disprange; lquit: boolean; lstmt: stptr; lrectype: stp; lcp: ctp; begin curstmt :=ment; begin curstmt := newstmt(whilest,true); insymbol; with curstmt^ do begin expression(fsys+[dosy]); rcond := curexp; with curexp^ do if (etyptr <> nil) and (etyptr <> boolptr) then error(135); if sy = dosy newstmt(withst,true); insymbol; oldtop := top; lstmt := curstmt; repeat if sy <> ident then begin error(2); skip(fsys+[comma,dosy]) end else begin searchid([types,vars,field,konst,func,routineparm],lcp); identproc(fsys+[comma,do       DO WITH LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN IF DEFINED THEN begin ERROR(165); LLP := nil end ELSE begin DEFINED := TRUE; if (linelevel <> 0) and nonlocalref then error(164); try_level := parsing_try_level; { JWH 9/2 {file SYMTABLE} implement function treesearch(p: ctp; var q: ctp; s: alpha): integer; external; PROCEDURE SEARCHSECTION (*FCP: CTP; VAR FCP1: CTP*); BEGIN IF FCP <> NIL THEN IF TREESEARCH(FCP,FCP1,ID) = 0 THEN {found} ELSE FCP1 :6/91 } end; GOTO 1 END ELSE LLP := NEXTLAB; ERROR(167); (* undeclared label *) 1:INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5) END; (*label*) IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS) END; if s= NIL ELSE FCP1 := NIL END (*SEARCHSECTION*) ; function searchschema (fstate: modstateptr; var fcp: ctp; var fid: alpha) : boolean; {Search all defined IDs in module list for fid} {If found, return TRUE with gstate & fcp set} label 1;sy]); lrectype := curexp^.etyptr; if lrectype <> nil then if lrectype^.form <> records then error(140) else if top >= displimit then error(662) else begin {open scope containing field names} top := top+1; with display[top] do y=period then {kluge} insymbol; IF SY IN STATBEGSYS + [IDENT] THEN BEGIN CASE SY OF IDENT: BEGIN SEARCHID([types,VARS,FIELD,FUNC,PROX,routineparm],LCP); with lcp^ do IF (KLASS = prox) or (klass = routineparm) and (vtype = procpbegin fname := lrectype^.fstfld; occur := WITHscope; wnodeptr := lstmt; end; lstmt^.refexpr := curexp; end; {open scope} end; (* sy=ident *) lquit := sy <> comma; if not lquit then begin insymbol; arm) THEN proccall(FSYS,LCP) ELSE ASSIGNMENT(lcp); END; BEGINSY: COMPOUNDSTATEMENT; CASESY: begin linelevel := linelevel + 1; CASESTATEMENT; linelevel := linelevel - 1; end; FORSY: begin linelevel := linelevlstmt^.wbody := newstmt(withst,false); lstmt := lstmt^.wbody; end; until lquit; if sy = dosy then insymbol else error(54); lstmt^.wbody := statement(fsys); top := oldtop; end (*withstatement*); procedure trystatement; var dummyel + 1; FORSTATEMENT; linelevel := linelevel - 1; end; GOTOSY: GOTOSTATEMENT; IFSY: begin linelevel := linelevel + 1; IFSTATEMENT; linelevel := linelevel - 1; end; REPEATSY: begin linelevel := linelevel + 1; REP: stptr; begin curstmt := newstmt(tryst,true); insymbol; with curstmt^ do begin parsing_try_level := parsing_try_level + 1; { JWH 9/26/91 } stmtlist(tbody,dummy,fsys+[semicolon,recoversy]); parsing_try_level := parsinEATSTATEMENT; linelevel := linelevel - 1; end; trysy: begin linelevel := linelevel + 1; trystatement; linelevel := linelevel - 1; end; WHILESY: begin linelevel := linelevel + 1; WHILESTATEMENT; linelevel := linelevg_try_level - 1; { JWH 9/26/91 } if sy = recoversy then begin insymbol; recov := statement(fsys) end else error(712); (* 'recover' expected *) end; { with } end; (*trystatement*) BEGIN (*STATEMENT*) LLP := nil; {mark no lel - 1; end; WITHSY: begin linelevel := linelevel + 1; WITHSTATEMENT; linelevel := linelevel - 1; end; END; {case} IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY,recoversy,othrwisesy]) THEN BEGIN ERROR(6); SKIP(FSYS) END Eabel for this stmt} IF SY = INTCONST THEN (*LABEL*) BEGIN if val.ival > 9999 then error(163); TTOP := TOP; WHILE DISPLAY[TTOP].OCCUR in [RECORDscope,WITHscope] DO TTOP := TTOP-1; LLP := DISPLAY[TTOP].FLABEL; WHILE LLP <> NILND else curstmt := newstmt(emptyst,false); curstmt^.labp := LLP; {mark it with saved label} statement := curstmt END (*STATEMENT*);        begin searchschema := true; while fstate <> nil do {scan list} with fstate^ do begin if defineids <> nil then {search defined IDs} if treesearch(defineids,fcp,fid) = 0 then begin gstate := fstate; goto 1 es} if fmodule <> nil then if searchschema(fmodule,lcp,id) then goto 1; end else if occur = MODULEscope then begin {Module: try defined & imported IDs} if searchmodule(fmodule,lcp,id) then goto 1; disx := 1;nd; fstate := nextmodule; {not here, try next module} end; searchschema := false; {report failure} 1:end; {searchschema} function searchmodule (fstate: modstateptr; var fcp: ctp; var fid: alpha) : boolean; {Else must be a predefined ID} end end; disx := disx - 1; {Try next name scope} end; LCP := NIL; {ID not found anywhere} IF PRTERR THEN ERROR(104); 1:if lcp <> nil then  {Search defined & imported names in specified module for fid} {If found, return TRUE with gstate & fcp set} label 1; begin searchmodule := true; if fstate <> nil then {First try items in inforec} with fstate^.modinfo^ do  {Check ID is of appropriate class} if not (lcp^.klass in fidcls) then begin lcp := nil; if prterr then error(103) end; IF PRTERR and (lcp = nil) THEN {Substitute an 'undefined' ID node} BEGIN disx := 0; gstate := nil;  begin if useids <> nil then {try USEd IDs} if treesearch(useids,fcp,fid) = 0 then begin gstate := fstate; goto 1 end; if usemodule <> nil then {try USEd modules} if searchschema(usemodule,fcp,fid) then goto 1;  IF VARS IN FIDCLS THEN LCP := UVARPTR ELSE IF TYPES IN FIDCLS THEN LCP := UTYPPTR ELSE IF KONST IN FIDCLS THEN LCP := UCSTPTR ELSE IF FIELD IN FIDCLS THEN LCP := UFLDPTR ELSE IF prox IN FIDCLS THEN LCP := UPRCPTR else lcp if impmodule <> nil then if searchschema(impmodule,fcp,fid) then goto 1; end; while fstate <> nil do {scan instance chain for defined ID} with fstate^ do begin if defineids <> nil then {try my defined IDs} := ufctptr; END; FCP := LCP; if lcp <> NIL then if nonstandard in lcp^.info then if sysprogreq in lcp^.info then begin if not sysprog and not modcal then if not (ucsdreq in lcp^.info) then error(612) else if not ucsd then e if treesearch(defineids,fcp,fid) = 0 then begin gstate := fstate; goto 1 end; fstate := contmodule; {not here, try previous instance} end; searchmodule := false; {report failure} 1:end; {searchmodule} PROCEDURrror(612); end else if modcalreq in lcp^.info then begin if not modcal then if not (ucsdreq in lcp^.info) then error(612) else if not ucsd then error(612);; end else if ucsdreq in lcp^.info then begin if not ucsd then error(607E SEARCHID (FIDCLS: SETOFIDS; VAR FCP: CTP); {Look up 'ID' in symbol table} LABEL 1; VAR LCP: CTP; BEGIN disx := top; gstate := nil; while disx >= 0 do begin with display[disx] do if occur <> RECORDscope then {Never search a REC) end else if stdpasc then error(606); END (*SEARCHID*) ; PROCEDURE ENTERID (FCP: CTP); {Enter a new node in the symbol table} label 1; VAR LCP,LCP1: CTP; I: INTEGER; quit: boolean; procedure entererror; begin errorwithinfo(101,f being constructed} begin if fname <> nil then {Try primary symbol tree} if treesearch(fname,lcp,id) = 0 then goto 1; if occur = BLOCKscope then {Try subsidiary trees} begin {Block: try defined IDs of modulecp^.namep^ + ' already defined in ' + gstate^.modinfo^.modinitbody^.namep^) end; BEGIN if fcp^.namep^ = 'NIL' then if not beforefirsttoken then error(108); with display[top] do begin {First test for duplicate name in subsidia       if searchschema(available_module,fcp,id) then if foundmodule then goto 1; lstate1 := fmodule; while lstate1 <> nil do with lstate1^ do begin if searchschema(defmodule,fcp,id) then if foundmodule then goto 1; lstate1 := contmo(fcp^.rlink); end; checkdefineconflicts := errors; end; {checkdefineconflicts } dule; end; lstate1 := fmodule^.modinfo^.usemodule; while lstate1 <> nil do begin lstate2 := lstate1; while lstate2 <> nil do with lstate2^ do begin if searchschema(defmodule,fcp,id) then if foundmodule then goto 1;  * FUNCTION TREESEARCH(ROOTP: ^NODE; VAR FOUNDP: ^NODE; * VAR TARGET: STRING): INTEGER; * * NODE = RECORD * KEY: ^STRING; * LLINK, RLINK: ^NODE; * SY, OP: 0..255; * ry trees} if occur = BLOCKscope then begin if fmodule <> nil then if searchschema(fmodule,lcp,fcp^.namep^) then begin entererror; goto 1; end; end else if occur = MODULEscope then if searchmodule(fmodule,lcp,fcp lstate2 := contmodule; end; lstate1 := lstate1^.nextmodule; end; lstate1 := fmodule^.modinfo^.impmodule; while lstate1 <> nil do begin lstate2 := lstate1; while lstate2 <> nil do with lstate2^ do begin if searc^.namep^) then begin entererror; goto 1; end; LCP := FNAME; IF LCP = NIL THEN FNAME := FCP ELSE BEGIN I := TREESEARCH(LCP,LCP1,FCP^.NAMEP^); if I = 0 then errorwithinfo(101,fcp^.namep^ + ' already defined') ELSE IF hschema(defmodule,fcp,id) then if foundmodule then goto 1; lstate2 := contmodule; end; lstate1 := lstate1^.nextmodule; end; end; disx := disx - 1; end; fcp := nil; 1:end; { searchavailablemodules } function checkdefineconfI = 1 THEN LCP1^.RLINK := FCP ELSE LCP1^.LLINK := FCP END; FCP^.LLINK := NIL; FCP^.RLINK := NIL end; {with} 1: END (*ENTERID*) ; procedure searchavailablemodules(var fcp: ctp); label 1; var lstate1,lstate2: modstateptr; funlicts(fcp: ctp): boolean; var i: integer; errors: boolean; lcp,lcp1: ctp; procedure enterror; begin errorwithinfo(101,fcp^.namep^ + ' already defined in ' + gstate^.modinfo^.modinitbody^.namep^) end; begin { checkdefction foundmodule: boolean; begin foundmodule := true; if fcp <> gstate^.modinfo^.modinitbody then if (fcp^.klass = prox) and (fcp^.ismodulebody) then foundmodule := false; end; begin {searchavailablemodules} disx := top; gsineconflicts } errors := false; if fcp <> nil then begin errors := checkdefineconflicts(fcp^.llink); if (fcp^.klass <> prox) or not fcp^.ismodulebody then with display[top] do begin case occur of BLOCKscope: if searchtate := nil; while disx >= 0 do begin with display[disx] do if (occur = BLOCKscope) then begin if searchschema(available_module,fcp,id) then if foundmodule then goto 1; lstate2 := fmodule; while lstate2 <> nil do begin lstate1 schema(fmodule,lcp,fcp^.namep^) then begin enterror; errors := true; end; MODULEscope: if searchmodule(fmodule,lcp,fcp^.namep^) then begin enterror; errors := true; end; end; { case } lcp :=:= lstate2; with lstate1^ do begin if searchschema(defmodule,fcp,id) then if foundmodule then goto 1; lstate1 := contmodule; end; lstate2 := lstate2^.nextmodule; end; end else if (occur = MODULEscope) then begin  fname; if lcp <> nil then begin i := treesearch(lcp,lcp1,fcp^.namep^); if (i = 0) then begin errorwithinfo(101,fcp^.namep^ + ' already defined'); errors := true; end; end; end; errors := errors or checkdefineconflicts      END; NOSYMS KEY EQU 0 LLINK EQU 4 RLINK EQU 8 ROOTP EQU A4 FOUNDP EQU A3 TARGETP EQU A2 RETURN EQU A1 KEYP EQU A0 COUNT EQU D7 TARGET EQU D6 ROOT(TARGETP)+ COMPARE DBNE COUNT,L7 LOOP TILL NOT EQUAL OR COUNT = 0 L8 BCS.S L12 IF GREATER (OR COUNT IS 0) THEN L9 MOVE.L RLINK(ROOTP),ROOT IF RLINK = NIL THEN BNE L1  EQU D5 TLEN EQU D4 KLEN EQU D3 CHAR EQU D2 TREESEARCH EQU * MOVEM.L (SP)+,RETURN/TARGETP/FOUNDP/ROOTP GET PARAMETERS CLR TLEN MOVE.B (TARGETP)+,TLEN GET LENGTH OF TARGET BEQ.S L1ROOTP := RLINK; GOTO 1 MOVE.L ROOTP,(FOUNDP) ELSE FOUNDP := ROOTP MOVE.L #1,(SP) TREESEARCH := 1 JMP (RETURN) END L10 MOVE TLEN,COUNT LENGTH OF TARGET STRING (SHORTER) SUBQ #5 SPECIAL CASE IF NULL MOVE.B (TARGETP)+,CHAR GET FIRST CHARACTER OF TARGET MOVE.L TARGETP,TARGET SAVE ADDRESS OF REMAINDER OF TARGET BRA.S L2 ENTER LOOP L1 MOVEA.L ROOT,ROOTP 2,COUNT BLT.S L12 DONE IF SINGLE CHARACTER L11 CMPM.B (KEYP)+,(TARGETP)+ COMPARE DBNE COUNT,L11 LOOP TILL NOT EQUAL OR COUNT = 0 BHI.S L9 IF LESS (OR COUNT IS 0) THEN L12 MOVE.L WITH ROOTP^ DO L2 MOVEA.L (ROOTP),KEYP ADDRESS OF KEY STRING MOVE.B (KEYP)+,KLEN GET LENGTH OF KEY STRING BEQ.S L9 TARGET IS LARGER IF KEY IS NULL CMP.B (KEYP)+,CHAR COMPARE FIRST CHARA LLINK(ROOTP),ROOT ELSE IF LLINK <> NIL THEN BNE L1 ROOTP := RLINK; GOTO 1 L13 MOVE.L ROOTP,(FOUNDP) ELSE FOUNDP := ROOTP MOVE.L #-1,(SP) TREESEARCH := -1 JMP (RETURN) CTERS BHI.S L9 TARGET IS LARGER BCS.S L12 TARGET IS SMALLER MOVEA.L TARGET,TARGETP INDEX INTO TARGET STRING CMP.B KLEN,TLEN COMPARE LENGTHS BHI.S L6 TARGET I END * SPECIAL CASE IF TARGET IS NULL: FOLLOW LEFT LINKS L14 MOVEA.L ROOT,ROOTP L15 MOVEA.L (ROOTP),KEYP WITH ROOTP^ TST.B (KEYP) IF LENGTH OF KEY IS ZERO BEQ L5 THEN FOUND MOVS LONGER BCS.S L10 TARGET IS SHORTER L3 MOVE TLEN,COUNT LENGTH OF TARGET STRING (SAME AS KEY) SUBQ #2,COUNT BLT.S L5 DONE IF SINGLE CHARACTER L4 CMPM.B (KEYP)+,(TARGETP)+ CE.L LLINK(ROOTP),ROOT ELSE GET LEFT LINK BNE.S L14 REPEAT UNTIL NIL BRA.S L13 IN WHICH CASE TARGET IS LESS DEF TREESEARCH END OMPARE DBNE COUNT,L4 LOOP TILL NOT EQUAL OR COUNT = 0 BNE.S L8 IF EQUAL (i.e. COUNT IS 0) THEN L5 MOVE.L ROOTP,(FOUNDP) FOUNDP := ROOTP CLR.L (SP) TREESEARCH := {file TYP} procedure routinetype(*fsys: setofsys; var fsp: stp; fsy: symbol*); var lsp: stp; llc: addrrange; oldtop: disprange; begin new(lsp,prok); with lsp^ do begin form := prok; params := nil; info := sysinfo; ispackable := false; s 0 JMP (RETURN) END L6 CLR COUNT MOVE.B KLEN,COUNT LENGTH OF KEY STRING (SHORTER) SUBQ #2,COUNT IF COUNT > 0 BLT.S L9 DONE IF SINGLE CHARACTER L7 CMPM.B (KEYP)+,izeoflo := false; unpacksize := PROKSIZE; align := PROKALIGN; parmlc := 0; if sy = lparent then begin llc := lc; lc := lcaftermarkstack; oldtop := top; if top < displimit then begin top := top + 1; with display[top] do      KLASS := KONST; info := linfo; values.intval := true; values.IVAL := LCNT; END; ENTERID(LCP); LCNT := LCNT + 1; LCP1 := LCP; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN BEGIN ERRORPE := LSP1; END; IF SY = rangesy THEN INSYMBOL ELSE ERROR(22); CONSTANT(FSYS,LSP1,LVALU); WITH LSP^ DO begin if lsp1 <> NIL then begin MAX := LVALU.ival; if (rangetype <> NIL) and (RANGETYPE <> LSP1) THEN ERR(6); SKIP(FSYS + [COMMA,RPARENT]) END UNTIL SY <> COMMA; LSP^.FCONST := LCP1; countbits(lcnt-1,lcnt,maxsign); LSP^.bitsize := lcnt; TOP := TTOP; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*SY=LPARENT*) ELSE BEGIN IF SY = IDENT THEN OR(107); end else max := min; IF MIN > MAX THEN BEGIN ERROR(102); MAX := MIN END; countbits(min,minbits,minsign); {Size it} countbits(max,maxbits,maxsign); if minbits>maxbits then maxbits:=minbits;  begin fname := nil; occur := BLOCKscope; fmodule := nil; ffile := nil; flabel := nil; available_module := nil; end; end else error(662); if fsy = procsy then parameterlist(fsys,[semicolon],params,parmlc,false,0) else par{Is it type name or subrange declaration?} { Added FUNC as a class to search 8/12/89 JWH } begin SEARCHID([TYPES,KONST,FUNC],LCP); test:=(LCP^.KLASS = TYPES); end else test:=false; if test then BEGIN {Type namameterlist(fsys,[semicolon,colon],params,parmlc,false,0); lc := llc; top := oldtop; end; end; fsp := lsp; end; PROCEDURE TYP (FSYS: SETOFSYS; VAR FSP: STP); VAR LSP,LSP1: STP; OLDTOP: DISPRANGE; llc: addrrange; DISPL: ADDe} if disx = disdef.level then if lcp^.namep^ = disdef.id^ then error(190); INSYMBOL; LSP := LCP^.IDTYPE; IF LSP = STRGPTR then if SY <> LBRACK THEN error(732) else BEGIN INSYMBOL; CONSTANT(FSYS + [RBRACK],LSRRANGE; NEXTBIT,maxfldalign: shortint; PACKING: BOOLEAN; LMIN,LMAX: integer; linfo: infobits; lcproot: ctp; PROCEDURE SIMPLETYPE (FSYS: SETOFSYS; VAR FSP: STP); VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE; LVALU: VALU; LCNT,minP1,LVALU); IF LSP1 = INTPTR THEN BEGIN IF (LVALU.IVAL <= 0) OR (LVALU.IVAL > STRGLGTH) THEN BEGIN ERROR(678); LVALU.IVAL := STRGLGTH END; NEW(LSP); LSP^ := STRGPTR^; WITH LSP^ DO BEGIN MAXLENG := LVALU.IVAL; info := linfo;bits,maxbits: shortint; minsign,maxsign,test: boolean; BEGIN IF NOT (SY IN SIMPTYPEBEGSYS) THEN BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END; IF SY IN SIMPTYPEBEGSYS THEN BEGIN IF SY = LPARENT THEN BEGIN  unpacksize := LVALU.IVAL+1 {*********} END; END ELSE ERROR(15); IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12); END; (*string length*) END (*if test*) ELSE BEGIN {Subrange}  {Enumerated type} TTOP := TOP; WHILE DISPLAY[TOP].OCCUR in [RECORDscope,WITHscope] DO TOP := TOP - 1; NEW(LSP,SCALAR,DECLARED); WITH LSP^ DO BEGIN FORM := SCALAR; unpacksize := SCALARSIZE; align := SCALARALIGN; sizeoflo := false;  CONSTANT(FSYS + [rangesy],LSP1,LVALU); if lsp1 <> nil then if lsp1^.form <> scalar then BEGIN ERROR(107); LSP1 := NIL END; NEW(LSP,SUBRANGE); WITH LSP^ DO BEGIN FORM := SUBRANGE; info := linfo; sizeoflo:=false;  ispackable := true; signbit := false; SCALKIND := DECLARED; info := linfo END; LCP1 := NIL; LCNT := 0; REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,KONST); WITH LCP^ DO BEGIN newident(namep,ID); IDTYPE := LSP; NEXT := LCP1;  if lsp1<>nil then begin unpacksize := lsp1^.unpacksize; align:=lsp1^.align; min := lvalu.ival; end else begin unpacksize:=wordsize; align:=wordalign; min := 0; end; RANGETY     {*** For machines without sign extension, change next line to ... then maxbits:=bitsperword; ***} if minsign or maxsign then maxbits:=maxbits+1; if maxbits BITSPERWORD do {** B.R. 4/80 **} BEGIN DISPL true; bitsize := maxbits; signbit := (minsign or maxsign); if (maxbits+ord(not signbit) <= bitsperaddr*shortintsize) and (rangetype = intptr) then begin unpacksize := shortintsize; rangetype := shortintptr end; end else  := DISPL + 2; NEXTBIT := nextbit-16; if nextbit < 0 then nextbit := 0; END; $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 { integer ovfl } then begin error(672); displ := ispackable := false; {not packable} end; END; (*subrange*) END; FSP := LSP; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END (*SY IN SIMPTYPEBEGSYS*) ELSE FSP := NIL END (*SIMPLETYPE*) ; procedure 0; nextbit := 0; end else escape(escapecode); FLDADDR := DISPL; FISPACKD := TRUE; FLDFBIT := NEXTBIT; NEXTBIT := NEXTBIT + idtype^.bitsize; if ((fldfbit = 0) or (fldfbit = 16)) and (idtype^.bitsize = 16) and idtype^.si setrecordsize (fsp: stp); { set the size fields in a record or variant node } { Uses DISPL, MAXFLDALIGN, and NEXTBIT variables } begin with fsp^ do begin if nextbit>0 then unpacksize := displ + (nextbit+bitsperaddr-1) div bitsgnbit then begin fldaddr := fldaddr + fldfbit DIV 8; fispackd := false; strucwaspackd := true; end; if maxfldalign < wordalign then maxfldalign := wordalign; END ELSE BEGIN {Allocate unpacked fiperaddr else unpacksize := displ; sizeoflo := false; if (unpacksize = 1) and (maxfldalign = 1) then align := 1 else align := wordalign; if (displ=0) and (nextbit0 then begin try $ovflcheck on$ DISPL := DISPL + (nextbit+bitsperaddr-1) div bitsperaddr; $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 { integer ovfl } then ignbit := false; bitsize := nextbit; end else ispackable := false; end end; PROCEDURE FIELDLIST (FSYS: SETOFSYS; VAR FRECVAR: STP; var finfo: infobits; var lcproot: ctp); VAR lcproot1,LCP,LCP1,PREVLCP: CTP; LSP: STP; TESTbegin error(672); displ := 0; end else escape(escapecode); NEXTBIT := 0; end; FISPACKD := FALSE; strucwaspackd := packing; FLDADDR := allocate(DISPL, idtype, true,1); if maxfldalign < idtype^.align then maxfldalign := idtype^.a: BOOLEAN; foundfixedpart: boolean; PROCEDURE FLDALLOC (FCP: CTP); { allocate the given field in current record } VAR t: shortint; BEGIN WITH FCP^ DO if idtype = nil then {punt} begin fldaddr:=0; fispackd:=false elign; END END (*FLDALLOC*) ; PROCEDURE VARIANTLIST; label 1,2; VAR GOTTAGNAME,TEST: BOOLEAN; linfo: infobits; LCP,LCP1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,lspt: STP; MINSIZE,MAXSIZE: ADDRRANGE; testval: varlab; LVALU: nd ELSE IF PACKING AND (idtype^.ispackable) THEN BEGIN {Allocate packed field} if nextbit=0 then begin {ensure DISPL is word aligned} t := DISPL mod wordalign; if t<>0 then begin DISPL VALU; MAXBIT,MINBIT: BITRANGE; t1, t2 : addrrange; BEGIN NEW(LSP,TAGFLD); linfo := sysinfo; WITH LSP^ DO BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM := TAGFLD; info := linfo; END; FRECVAR := LSP; INSYMBOL; IF SY =       := LSP2; vflds := nil; VARVAL.lo := LVALU.ival; FORM := VARIANT; info := linfo; END; if sy = rangesy then begin if stdpasc then error(606); insymbol; CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP2,LVALU); if lsp^.tagfieif ((testval.lo >= lo) and (testval.lo <= hi)) or ((testval.hi >= lo) and (testval.hi <= hi)) or ((testval.lo < lo) and (testval.hi > hi)) then begin error(156); goto 1 end else lsp2 := lsp2^.nxtvar; lsp1 := lsp1^.nxtvar; enldp <> NIL then if not comptypes(lsp^.tagfieldp^.idtype,lsp2) then error(111); end; lsp3^.varval.hi := lvalu.ival; if lsp3^.varval.lo > lvalu.ival then error(102); LSP1 := LSP3; LSP2 := LSP3; TEST := SY <> COMMA; IF NOT TEd; 1: END (*VARIANTLIST*) ; BEGIN (*FIELDLIST*) foundfixedpart := false; prevlcp := nil; IF NOT (SY IN [IDENT,CASESY,endsy]) THEN BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END; WHILE SY = IDENT DO BEGIN foundfixedparIDENT THEN BEGIN IF PACKING THEN NEW(LCP,FIELD,TRUE) ELSE NEW(LCP,FIELD,FALSE); WITH LCP^ DO BEGIN namep := nil; IDTYPE := NIL; KLASS:=FIELD; NEXT := NIL; FISPACKD := FALSE; info := linfo END; GOTTAGNAME := FALSE; PRTERR := FALSE; SEARCHIDST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); IF SY = RPARENT THEN LSP2 := NIL ELSE { link a particular variant with its associated fields. The fields are linked together t([TYPES],LCP1); PRTERR := TRUE; INSYMBOL; IF (LCP1 = NIL) or (sy = colon) THEN BEGIN GOTTAGNAME := TRUE; foundfixedpart := true; if prevlcp <> nil then prevlcp^.next := lcp; prevlcp := lcp; if lcproot = nil then lcproot := lcp; newidenthrough their NEXT field } begin lcproot1 := nil; linfo := sysinfo; FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,linfo,lcproot1); lspt := lsp1; while lspt <> nil do if lspt^.vflds = nil then begin lspt^.vflds := lcproot1; lspt := lsp(LCP^.NAMEP,ID); ENTERID(LCP); IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP1); INSYMBOL; END ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END END; if lcp1 <> NIL then LSP1 t^.nxtvar end else goto 2; 2: if mustinitialize in linfo then error(707); finfo := finfo + (linfo * [cantassign]); end; t1 := displ + (nextbit div bitsperaddr); t2 := maxsize + (maxbit div bitsperaddr); if (t1 > t2) or ((t1 = t2) and:= LCP1^.IDTYPE else lsp1 := NIL; IF LSP1 <> NIL THEN IF LSP1^.FORM <= SUBRANGE THEN BEGIN LCP^.IDTYPE := LSP1; LSP^.TAGFIELDP := LCP; IF GOTTAGNAME THEN FLDALLOC(LCP) END ELSE ERROR(110); END ELSE BEGIN ERROR(2); SKIP ( (nextbit mod bitsperaddr) > (maxbit mod bitsperaddr) ) ) then begin maxsize := displ; maxbit := nextbit; end; WHILE LSP3 <> NIL DO BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; setrecordsize(LSP3); LSP3 := LSP4 (FSYS + [OFSY,LPARENT]) END; lsp^.hasfixedpart := foundfixedpart; setrecordsize(LSP); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBIT := NEXTBIT; MAXBIT := NEXTBIT; REPEAT LSP2 END; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END END ELSE ERROR(4); TEST := SY <> SEMICOLON; IF NOT TEST THEN BEGIN INSYMBOL; DISPL := MINSIZE; NEXT := NIL; REPEAT CONSTANT(FSYS + [COMMA,rangesy,COLON,LPARENT],LSP3,LVALU); IF LSP^.TAGFIELDP <> NIL THEN IF NOT COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP3) THEN ERROR(111); NEW(LSP3,VARIANT); WITH LSP3^ DO BEGIN NXTVAR := LSP1; SUBVARBIT := MINBIT END UNTIL TEST OR (SY=ENDSY); DISPL := MAXSIZE; NEXTBIT := MAXBIT; LSP^.FSTVAR := LSP1; while lsp1 <> nil do begin testval := lsp1^.varval; lsp2 := lsp1^.nxtvar; while lsp2 <> nil do with lsp2^.varval do      t := true; lcp1 := nil; REPEAT IF SY = IDENT THEN BEGIN IF PACKING THEN NEW(LCP,FIELD,TRUE) ELSE NEW(LCP,FIELD,FALSE); WITH LCP^ DO BEGIN newident(namep,ID); IDTYPE := NIL; NEXT := NIL; KLASS := FIELD; FISPACKD := FALSEw} var dummy: integer; begin try $ovflcheck on$ dummy := lmin*aelsize; $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 {integer overflow} then begin error(697); if inxtype <> nil the; info := linfo END; if lcproot = nil then lcproot := lcp; if prevlcp <> nil then prevlcp^.next:=lcp; prevlcp := lcp; if lcp1=nil then lcp1 := lcp; ENTERID(LCP); INSYMBOL END ELSE ERROR(2); IF NOT (SY n if inxtype^.form = subrange then inxtype^.min := 0; end; end; {checkarray} BEGIN INSYMBOL; IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11); LSP1 := NIL; REPEAT NEW(LSP,ARRAYS); WITH LSP^ DO BEGIN AELTYPE := IN [COMMA,COLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS + [CASESY,SEMICOLON],LSP); IF LSP <> NIL TLSP1; INXTYPE := NIL; strucwaspackd := packing; ispackable := false; sizeoflo := false; unpacksize := wordsize; align := wordalign; AISPACKD := FALSE; aelsize := wordsize; FORM := ARRAYS; info := linfo; aisstrng := false; END; LSP1 :=HEN finfo := finfo + (lsp^.info * [mustinitialize,cantassign]); WHILE LCP1 <> NIL DO {attach type ptr & allocate space} WITH LCP1^ DO BEGIN IDTYPE := LSP; FLDALLOC(LCP1); LCP1 := NEXT END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF LSP; SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2); IF LSP2 <> NIL THEN IF LSP2^.FORM <= SUBRANGE THEN IF LSP2 = INTPTR THEN ERROR(149) ELSE LSP^.INXTYPE := LSP2 ELSE ERROR(113); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL NOT (SY IN [IDENT,ENDSY,CASESY,rparent]) THEN BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END END END (*WHILE*); IF SY = CASESY THEN VARIANTLIST ELSE FRECVAR := NIL END (*FIELDLIST*) ; PROCEDURE POINTERTYPE; VAR LSP: ST UNTIL TEST; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); TYP(FSYS,LSP); REPEAT WITH LSP1^ DO BEGIN LSP2 := AELTYPE; AELTYPE := LSP; IF LSP <> NIL THEN info := linfo + (lsp^.info * [mP; LCP: CTP; BEGIN NEW(LSP,POINTER); FSP := LSP; WITH LSP^ DO BEGIN ELTYPE := NIL; FORM := POINTER; ispackable := false; sizeoflo := false; unpacksize := PTRSIZE; align := PTRALIGN; info := linfo; END; INSYMBOL; ustinitialize,cantassign]); IF (INXTYPE <> NIL) and (AELTYPE <> NIL) THEN BEGIN {***** Compute array element size *****} packit := PACKING and aeltype^.ispackable; IF packit THEN BEGIN {packable array} numbits := aeltype^.bitsiz IF SY = IDENT THEN BEGIN NEW(LCP,TYPES); WITH LCP^ DO BEGIN newident(namep,ID); IDTYPE := LSP; NEXT := FWPTR; KLASS := TYPES; END; FWPTR := LCP; INSYMBOL; END ELSE ERROR(2) END (*POINTERTYPE*) ; procedure arraye; if numbits+numbits > BITSPERWORD then packit := false else begin {*** 1,2,4,8,16 bit arrays only ***} if numbits > 8 then numbits := 16 else if numbits > 4 then numbits := 8 else if numbits = 3 then numbits :type; var LSP,LSP1,LSP2: STP; LSIZE: addrrange; TEST,packit,itfits: BOOLEAN; numbits,elsperbyte: shortint; numelements,lmin,lmax: integer; procedure checkarray(aelsize: addrrange; inxtype: stp); { check if aelsize*lowerbound will overflo= 4; end END; if packit then begin AISPACKD := TRUE; AISSTRNG := FALSE; aelbitsize := numbits; align := wordalign; end else begin AISPACKD := FALSE; with aeltype^ do begin if sizeoflo      YS THEN SIMPLETYPE(FSYS,FSP) { ^ } ELSE IF SY = ARROW THEN POINTERTYPE ELSE BEGIN IF SY = PACKEDSY THEN BEGIN INSYMBOL; PACKING := TRUE; IF NOT (SY IN TYPEDELS) THEN BEGIN ERROR(10); SKIP(FSYS+TYPEDELS) END END; {ARRAY} IFustinitialize, cantassign]; IF SY = OFSY THEN BEGIN INSYMBOL; TYP(FSYS,FILTYPE); if filtype <> NIL then if (filtype^.unpacksize <= 0) or (filtype^.unpacksize > 32766) then error(673) else if mustinitialize in filtype^.in SY = ARRAYSY THEN arraytype {RECORD} ELSE IF SY = RECORDSY THEN BEGIN INSYMBOL; OLDTOP := TOP; IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; WITH DISPLAY[TOP] DO BEGIN FNAME := NIL; OCCUR := RECORDscope END END ELSfo then error(183); END ELSE begin if not ucsd then error(607); FILTYPE := NIL; end; if filtype = nil then unpacksize := nilfilesize else unpacksize := filesize + filtype^.unpacksize; END; FSP := LSP; Ethen error(675); lsize := ((unpacksize + align-1) div align) * align; end; aelsize := lsize; align := wordalign; end; {***** Compute size of whole array *****} sizeoflo := true; {assume the worst} GETBOUNDS(INXTYPE,LE ERROR(662); DISPL := 0; NEXTBIT := 0; maxfldalign := 1; lcproot := nil; FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,linfo,lcproot); NEW(LSP,RECORDS); WITH LSP^ DO BEGIN FSTFLD := DISPLAY[TOP].FNAME; RECVAR := LSP1; seMIN,LMAX); if lmax < 0 then itfits := (lmax NIL THEN IF LSP1^.FORM > SUBRANGE THEN BEGIN ERROR(115); LSP1 := NIL END ELSE IF LSP1=INTPTR THEN BEGIN ERROR(169); LSP1 := NIL END; NEW(LSP,POWER); WITH LSP^ DO BEGIN ELSEitsperaddr DIV aelbitsize; lsize := (numelements + (elsperbyte-1)) DIV elsperbyte; end; end else begin {unpacked array} if aeltype^.sizeoflo then itfits := false else itfits := (aelsize <= (maxint div numelementsT := LSP1; FORM := POWER; info := linfo; ispackable := false; sizeoflo := false; unpacksize := 0 {SETSIZE}; align := SETALIGN; setmin := SETLOW; setmax := SETHIGH; IF LSP1 <> NIL THEN BEGIN GETBOUNDS(LSP1,LMIN,LMAX); if (lminSETHIGH) then error(658) else begin {Compute set size} setmax := LMAX; setmin := LMIN; unpacksize := setlensize + SETELEMSIZE * ((LMAX + SETELEMBITS) DIV SETELEMBITS) end; END L; FSP := LSP; END; (* arraytype *) BEGIN (*TYP*) PACKING := FALSE; linfo := sysinfo; IF NOT (SY IN TYPEBEGSYS) THEN BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END; IF SY IN TYPEBEGSYS THEN BEGIN IF SY IN SIMPTYPEBEGS END; FSP := LSP END {FILE} ELSE IF SY = FILESY THEN BEGIN INSYMBOL; NEW(LSP,FILES); WITH LSP^ DO BEGIN ispackable := false; sizeoflo := false; align := wordalign; FORM := FILES; info := linfo + [m     ND {PROC} else if sy = procsy then begin if not (modcal or sysprog) then error(612); insymbol; routinetype(fsys,fsp,procsy); end; END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END (* sy in type); lvalu.intval := false; new(lvalu.valp,true,pset); moveleft(tmpconst,lvalu.valp^,sizeof(constrec,true,pset)); $end$ end; end; end; procedure structure; var lform: structform; i: integer; done,firsttime, begsys *) ELSE FSP := NIL; END; (*TYP*)  paoc_or_strg,isstring: boolean; curval: vcref; constmark: anyptr; procedure addcel; {add array element at end of list} begin new(vcptr,false); vcptr^.vcval := fvalu; if scstr^.scvcp = nil then scstr^.scvcp : {file UTILITIES} PROCEDURE CONSTANT (FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU); VAR LSP: STP; LCP,rcp: CTP; LVALU: VALU; LVP: CSP; lmin,lmax,i,numelems,elemcount,repcount: integer; scstr: scstref; vcptr,vcpbk: vcref; bads= vcptr else vcpbk^.vcnxt := vcptr; vcptr^.vcnxt := nil; vcpbk := vcptr; end; procedure addpaoccell(repcount: integer; firsttime: boolean); var tmpconst: constrec; tmptr: anyptr; curspace,newchars,i,j: integer; truct: boolean; expmark: ^integer; procedure setconst(fsp: stp); var tmpconst: constrec; $if bigsets$ (* setcrunch - moves the entire set constant list back up the stack, using recursion to get copies of each list item (chunk) out of t begin tmpconst := fvalu.valp^; release(constmark); if firsttime then addcel; with vcpbk^ do begin if firsttime then begin new(vcval.valp); vcval.valp^.cclass := bigpaoc; vcval.valp^.paoclgth := 0; end; with vcvhe heap before releasing *) procedure setcrunch( var s : setrecptr ); var tmp : setrec; (* copy of current set chunk*) begin if s = NIL then begin (* move constant record itself *) release( curexp ); lval.valp^ do begin { Compute size to extend bigpaoc structure } curspace := (2+256-4) - paoclgth; if curspace < 0 then curspace := 0; if tmpconst.cclass = paofch then newchars := tmpconst.slgth * repcount else newchars := tmpconalu.intval := false; new( lvalu.valp, true, pset ); moveleft( tmpconst, lvalu.valp^, sizeof( constrec, true, pset ) ); end else begin (* move list items *) tmp := s^; setcrunch( tmp.nxt ); new( s ); moveleftst.paoclgth * repcount; if newchars > curspace then newbytes(tmptr,newchars - curspace); for i := 1 to repcount do if tmpconst.cclass = paofch then for j := 1 to tmpconst.slgth do begin paoclgth := paoclgth + 1; $RANGE OFF$ ( tmp, s^, sizeof( setrec ) ); end; end; (* setcrunch *) $end$ begin (* setconst *) setdeno(fsys,fsp); with curexp^ do if etyptr <> nil then if ekind <> cnst then begin error(50); lsp := NIL; end else if eclass = paocval[paoclgth] := tmpconst.sval[j]; $IF rangechecking$ $RANGE ON$ $END$ end else if tmpconst.cclass = bigpaoc then for j := 1 to tmpconst.paoclgth do begin paoclgth := paoclgth + 1; $RANGE OFF$ paocval[paoclgth] := fvalu.vasetdenonode then begin lsp := etyptr; if inbody then lvalu := setcstpart else begin tmpconst := setcstpart.valp^; $if bigsets$ setcrunch( tmpconst.pval ); lvalu.valp^.pval := tmpconst.pval; $end$ $if not bigsets$ release(curexplp^.paocval[j]; $IF rangechecking$ $RANGE ON$ $END$ end; end; { with valp^ } end; { with scstr^ } end; procedure stripsc(var fvalu: valu); begin fvalu := fvalu.valp^.kstruc^.scvcp^.vcval; end; procedure creat     n begin if rcp^.idtype^.aisstrng then begin lmin := 1; lmax := rcp^.idtype^.maxleng end else with rcp^.idtype^ do begin getbounds(inxtype,lmin,lmax); end; if fvalu.valp^.cclass = bigpaoc then begin if fvalu.velse {more values follow} with vrnt^ do begin lcp := curval^.vid; curval := curval^.vcnxt; if subvar = nil then runfields(lcp^.next) else begin if subvar^.hasfixedpart then runfields(lcp^.next); runvariants(subvar^.falp^.paoclgth > lmax-lmin+1 then begin error(303); badstruct := true end; end else if fvalu.valp^.slgth > lmax-lmin+1 then begin error(303); badstruct := true end; end else if comptypes(fsp,rcp^.idtype) then with rcp^.stvar); end; end; {with vrnt^} end; end; {runvariants} begin {structure} lform := lsp^.form; if lform in [arrays,records,power] then begin if lform <> power then begin new(lvp,false,strctconst); if curglobalname valucel; {create and insert record field} procedure insort(cur: vcref); {insert field 'vcptr' in list by ascending address} label 1; var p,prev: vcref; function lt(f1,f2: ctp): boolean; {f1 & f2 are field id's.} {LT <=> f1^.'offset'idtype^ do begin if form = subrange then if (fvalu.ival < min) or (fvalu.ival > max) then error(303); end else if not widenconst(fsp,fvalu,rcp^.idtype) then begin error(129); badstruct := true end; vcptr^.vcval := fvalu; en < f2^.'offset' } begin if f1^.fldaddr < f2^.fldaddr then lt := true else if f1^.fldaddr > f2^.fldaddr then lt := false else if f1^.fispackd and f2^.fispackd then lt := f1^.fldfbit < f2^.fldfbit else lt := f2^.fispackd; end; begin d; {fsp<>nil} insort(vcptr); end; procedure runfields (lcp: ctp); begin while (lcp <> nil) and (curval <> nil) do if lcp <> curval^.vid then begin error(674); badstruct := true; lcp := nil end else begin lcp := lcp^.next; cu{insort} p := scstr^.scvcp; if p = nil then scstr^.scvcp := vcptr else if lt(cur^.vid,p^.vid) then begin scstr^.scvcp := cur; cur^.vcnxt := p end else begin prev := p; p := p^.vcnxt; while p<>nil do if lt(cur^.vid,p^.vid) then goto 1 rval := curval^.vcnxt end; if lcp <> nil then begin error(674); badstruct := true end; END; procedure runvariants(varp: stp); var vrnt: stp; lcp: ctp; procedure findvariant(varpt: stp); {tries to find a symbol equal to rcp th else begin prev := p; p := p^.vcnxt end; 1: prev^.vcnxt := cur; cur^.vcnxt := p; end; end; {insort} begin {creatvalucel} new(vcptr,true); vcptr^.vid := rcp; vcptr^.vcnxt := nil; insymbol; if sy = colon then insymbol else begin erat begins a variant. This is complicated by the fact that a variant could begin the variant (ad nauseum), so the search must be recursive} begin while (varpt <> nil) and (vrnt = nil) do with varpt^ do begin if vflds = curval^.vid then vrror(5); badstruct := true end; constant(fsys+[comma,rbrack],fsp,fvalu); if fsp=nil then badstruct := true else begin if fsp^.form in [arrays,records,power] then with fvalu.valp^ do if cclass = strctconst then if kstruc = nil then nt := varpt; if subvar <> nil then with subvar^ do if not hasfixedpart then findvariant(fstvar); varpt := nxtvar; end; end; {findvariant} begin {runvariants} if (curval <> nil) and not badstruct then begin vrnt := nil begin error(676); badstruct := true end else if paofchar(fsp) then stripsc(fvalu); if paofchar(rcp^.idtype) and (fsp = char_ptr) then stretchpaofchar(fsp,fvalu,1); if rcp^.idtype <> nil then if paofchar(fsp) and paofchar(rcp^.idtype) the; findvariant(varp); if vrnt = nil then begin error(674); badstruct := true end else {vrnt<>nil} if curval^.vcnxt = nil then begin {last value} if curval^.vid^.next<> nil then begin error(674); badstruct := true end; end      <> nil then newident(lvp^.namep, curglobalname^ + '_' + gnamep^) else lvp^.namep := gnamep; new(scstr); scstr^.scstp := lsp; scstr^.scvcp := nil; end; with lsp^ do case form of arrays: begin insymbol; if aispackd an,lmax); if fvalu.valp^.cclass = bigpaoc then begin if fvalu.valp^.paoclgth > lmax-lmin+1 then begin error(303); badstruct := true end end else if fvalu.valp^.slgth > lmax-lmin+1 then begin error(303); badstruct := trued (aeltype = char_ptr) then {string or PAOC} begin paoc_or_strg := true; if strgtype(lsp) then begin isstring := true; numelems := lsp^.maxleng; end else begin isstring := false; if inxtype <> NIL then begin  end; end else begin error(129); badstruct := true end; end { paofchar(aeltype) } else if comptypes(fsp,aeltype) then begin if aeltype <> NIL then with aeltype^ do begin if form = subrange then if (fva getbounds(inxtype,lmin,lmax); numelems := lmax - lmin + 1; end else numelems := 0; end; end else begin paoc_or_strg := false; if inxtype <> NIL then begin getbounds(inxtype,lmin,lmax); numelems := lmlu.ivalmax) then error(303); end; end else if not widenconst(fsp,fvalu,aeltype) then begin error(129); badstruct := true end; end; end; {fsp <> nil} if paoc_or_strg then begin if notax - lmin + 1; end else numelems := 0; end; firsttime := true; elemcount := 0; REPEAT mark(constmark); constant(fsys+[ofsy,rbrack,comma],fsp,fvalu); if sy = ofsy then {have repeat factor} if fsp <> in badstruct then begin if fvalu.valp^.cclass = bigpaoc then elemcount := elemcount + repcount*fvalu.valp^.paoclgth else elemcount := elemcount + repcount*fvalu.valp^.slgth; addpaoccell(repcount,firsttime); end; end etptr then begin error(15); badstruct := true; repcount:=0 end else BEGIN repcount := fvalu.ival; insymbol; constant(fsys+[comma,rbrack],fsp,fvalu); END else repcount := 1; if fsp = nil then badstruct := true else begin for i := 1 to repcount do addcel; elemcount := elemcount + repcount; end; if elemcount < numelems then if sy = rbrack then BEGIN elemcount := numelems; if not paoc_or_strg then begin error(731); badstruct :=lse begin if fsp^.form in [arrays,records,power] then with fvalu.valp^ do if cclass = strctconst then if kstruc = nil then begin error(676); badstruct := true end else if paofchar(fsp) then stripsc(fvalu); if paoc_or_str true; end; END else if sy = comma then insymbol else begin error(6); elemcount := numelems; badstruct := true; skip(fsys+[comma]); END; firsttime := false; UNTIL elemcount >= numelems; if elemcount > numelemsg then begin if fsp = char_ptr then stretchpaofchar(fsp,fvalu,1); if not paofchar(fsp) then begin error(129); badstruct := true; end; end else begin if paofchar(aeltype) then begin {treat array of pao then begin error(731); badstruct := true end; if sy = rbrack then insymbol else begin error(12); badstruct := true end; end; {arrays} records: begin insymbol; done := false; repeat {build value structure} if sfchar specially} if fsp = char_ptr then stretchpaofchar(fsp,fvalu,1); if paofchar(fsp) then begin if aeltype^.aisstrng then begin lmin := 1; lmax := aeltype^.maxleng end else getbounds(aeltype^.inxtype,lminy <> ident then begin error(2); badstruct := true; skip(fsys+[ident,rbrack]-[comma]); if sy = rbrack then done := true; end else begin searchsection(lsp^.fstfld,rcp); if rcp = nil then begin error(104); badstruct := true end else     lu := litval; lsp := etyptr; if not inbody then begin if not lvalu.intval then tmpconst := litval.valp^; release(expmark); if not lvalu.intval then begin case tmpconst.cclass of reel: begin new(lvalu.valp,true,reel); lsiz := true end; end; {lcp<>nil} END (* sy=ident *) otherwise error(106); skip(fsys); end; {case sy} IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END; if not badstruct then begin fsp := lsp; fvalu := lvalu end else e := sizeof(constrec,true,reel); end; otherwise {gave error 750} end; {case} moveleft(tmpconst,lvalu.valp^,lsize); end; {not lvalu.intval} end; {not inbody} end; {with} end {copyconstant}; procedure constexpression;  with fvalu do begin fsp := nil; intval := true; ival := 0 end; END; (*CONSTANT*) function compvalus (*v1,v2: valu): shortint*); { Returns -1,0,+1 as v1v2 } { This implementation assumes that big integers can never equal small ones creatvalucel; if sy=comma then insymbol else if sy=rbrack then begin insymbol; done := true end else begin error(6); badstruct := true; skip(fsys+[comma,rbrack]); done := true; end; end; until done; if not b begin mark(expmark); expression(fsys); with curexp^ do if etyptr <> nil then begin if (ekind <> cnst) or (eclass <> litnode) then begin error(50); lsp := nil; end else if not litval.intval and (etyptr<>realptr) adstruct then begin {check value vs. type} curval := scstr^.scvcp; if recvar = nil then runfields(fstfld) else begin if recvar^.hasfixedpart then runfields(fstfld); runvariants(recvar^.fstvar); end; end; then begin error(750); lsp := nil; end else copyconstant; end else { etyptr = nil } lsp := nil; end; BEGIN {constant} LSP := NIL; lvalu.intval:=true; LVALU.IVAL := 0; badstruct := false; IF NOT (SY IN CONSTBE end; power: setconst(lsp); END; {case} if lform <> power then begin lvalu.intval := false; lvalu.valp := lvp; lvp^.cclass := strctconst; lvp^.kstruc := scstr; lsp := scstr^.scstp; {in case it got clobbered} lvp^.hasbeenoutput := falGSYS) THEN BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END; case sy of lbrack: setconst(nil); stringconst: BEGIN IF LGTH = 1 THEN LSP := CHAR_PTR ELSE lsp := makepaofchartype(lgth); LVALU := VAL; INSYMBOL; END; realconst: begise; end; END; {arrays,records,power} end; {structure} procedure copyconstant; {This procedure exists to permit the creation of large structured constants: The calls to expression generate garbage that is not needed during the generan lvalu := val; lsp := realptr; insymbol end; addop,intconst,notsy,lparent: constexpression; ident: BEGIN SEARCHID([KONST,types,func],LCP); if lcp = nil then begin insymbol; error(6); skip(fsys) end else begin LSP := lcp^.IDTYPE; tion of the s.c. but consumes memory. A mark is made before the call to expression, and this procedure does whatever is needed so that a release can be done, and the final value preserved. The pointer expmark is the mark for the call to the pif lcp^.klass = func then constexpression else if (lcp^.klass = konst) and (lsp <> NIL) then if (lsp^.form = scalar) and (lsp <> realptr) then constexpression else begin LVALU := lcp^.VALUES; insymbol; erocedure. Note that if CONSTANT is called from bodyanalyzer (inbody = true) then we don't want to release} var tmpconst: constrec; {temporary storage for the constant, if needed} lsize: addrrange; begin with curexp^ do begin lvand else if (lcp^.klass = types) and (lsp <> nil) then begin if lsp=strgptr then error(732); insymbol; if sy = lbrack then structure else begin error(11); badstruct := true end; end {types} else begin error(50); badstruct     } var v: shortint; begin if v1.ival = v2.ival then v := 0 else if v1.ival < v2.ival then v := -1 else v := +1; compvalus := v end; {compvalus} procedure countbits (v: integer; var nbits: shortint; var needsignbit: boolean); { Count FLC mod al; {Decrement FLC to a multiple of AL} if t<>0 then FLC := FLC - t; allocate := FLC; {Return current FLC} end; $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 (*ins bits needed to represent an integer value } var numbits: shortint; power2: integer; done,minus,negative: boolean; begin minus := (v<0); if v = minint then numbits := 31 else begin if minus then v := -v; teger overflow *) then begin error(672); flc := 0; allocate := 0 end else escape(escapecode); end; {allocate} procedure wrapup(*term: termtype*); {Compiler termination} var s: string[10]; i,ior: integer; begin codewrapup(term);{get abs value} if v > 1073741824 then numbits := 31 {avoid overflow in loop} else begin numbits := 1; power2 := 2; {find least power of 2 >= v} while power2 < v do begin power2 := power2+power2; numbits := numbits+1 iowrapup(term); if initlistmode <> listnone then begin if (initlistmode = listerronly) and (totalerrors = 0) and (totalwarnings = 0) then close(lp,'purge') else close(lp,'lock'); if ioresult <> ord(inoerror) then  end; if power2 = v then {Handle exact power of 2} if not minus then numbits := numbits+1; end; end; nbits := numbits; needsignbit := minus; end; {countbits} function allocate (*var flc: addrrange; fsp: stp; incrlc:  begin setstrlen(s,0); ior := ioresult; strwrite(s,1,i,ior:1); warning(linenumber,'Error closing listing file, ioresult('+s+')'); end; end; end; {wrapup} boolean; minalign: shortint): addrrange*); {Allocate an instance of the given type, returning its address. FLC is the location counter, and INCRLC indicates whether FLC is to be incremented or decremented. If INCRLC=true, FLC is the first free address, whereas if INCRLC=false, FLC is the last used address. The allocated address has alignment max(fsp^.align,minalign). } var t,al: shortint; siz: integer; begin if fsp=nil then begin siz:=wordsize; al:=wordalign end else begin  siz := fsp^.unpacksize; al := fsp^.align; if fsp^.sizeoflo then error(672); end; if al < minalign then al := minalign; try $ovflcheck on$ if incrlc then begin t := FLC mod al; {Increment FLC to a multiple of AL} if t<>0 then FLC := FLC + (al-t); allocate := FLC; {Return current FLC} FLC := FLC + siz; {Reserve space} end else begin {decrementing FLC} FLC := FLC - siz; {Reserve space} t :=                                                                                                                                         !     !     "     "     #     #     $     $     %     %     &     &     '     '     (     (     )     )     *     *     +     +     ,     ,     -     -     .     .     /     /     0     0     1     1     2     2     3     3     4     4     5     5     6     6     7     7     8     8     9     9     :     :     ;     ;     <     <     =     =     >     >     ?     ?     @     @     A     A     B     B     C     C     D     D     E     E     F     F     G     G     H     H     I     I     J     J     K     K     L     L