(*$c+,t-,d-,l-*) (*********************************************** * * * Portable Pascal compiler * * ************************ * * * * Pascal P4 * * * * Authors: * * Urs Ammann * * Kesav Nori * * Christian Jacobi * * Address: * * Institut Fuer Informatik * * Eidg. Technische Hochschule * * CH-8096 Zuerich * * * * This code is fully documented in the book * * "Pascal Implementation" * * by Steven Pemberton and Martin Daniels * * published by Ellis Horwood, Chichester, UK * * ISBN: 0-13-653-0311 * * (also available in Japanese) * * * * Steven Pemberton, CWI/AA, * * Kruislaan 413, 1098 SJ Amsterdam, NL * * Steven.Pemberton@cwi.nl * * * ***********************************************) (*********************************************** * * * Adaption comments * * * * Scott A. Moore samiam@moorecad.com * * * * The purpose of my changes is to upgrade the * * code to ISO 7185, and to make the * * non-portable features more generic (see * * below). * * * * Note: you will find my comments with ISO * * 7185 brackets. See my mark [sam]. * * * * - I detabbed it, at 8th tabs. Not everyone * * uses the same tab stops. Use spaces please. * * * * - In procedure "printtables", the author * * uses "ord" to convert pointers to * * so they can be printed as part of tables. * * "ord" used this way is nonstandard, but * * any such printout of pointers is bound to * * be. Converted it to tagless record * * convertion, which is going to work on * * more processors than the "ord" trick * * (including mine). * * * * - Increased the size of strglgth from 16 * * to 100. This limits the size of string * * constants that can be accepted, and 16 * * is just not practical. * * * * - Eliminated the specific set of maxint. * * this means that maxint gets native * * sizing. * * * * - Changed the source input to "source" * * * * - Changed the size of set to 0..255. * * * * - Added ISO 7185 required header file * * declarations. * * * * - Added "disxl" local "for" index to * * searchid, as ISO 7185 requires. * * * * - In printtables, P4 was using "ord" to * * convert pointers to integers and vice * * versa. While this is a dirty trick on any * * Pascal, I converted it to untagged * * variant records, which works on most * * Pascal compilers. * * * * - In body, cstoccmax was increased so we * * could compile bigger test programs. * * * * - In assemble, removed unused variables. * * This is not required, but nice for * * compilers that check this. * * * * - Increased the number of digits in gen2t. * * * * Other notes: * * * * The control statement at the top of the * * program should probally be removed for use * * on a third party compiler. The p4 system * * itself uses them, so they are usefull when * * self compiling, but your compiler may have * * conflicting definitions. * * * * On my compiler, the "prr" output file is * * a command line parameter. You may have to * * make other arrangements. * * * * Under Unix and DOS/Windows, using IP * * Pascal,the command line is: * * * * pcom program.pas program.p4 * * * * Where "program" is the name of the program, * * program.pas is the Pascal source, and * * program.p4 is the portable intermediate. * * * **********************************************) program pascalcompiler(input,output,prr); const displimit = 20; maxlevel = 10; intsize = 1; intal = 1; realsize = 1; realal = 1; charsize = 1; charal = 1; charmax = 1; boolsize = 1; boolal = 1; ptrsize = 1; adral = 1; setsize = 1; setal = 1; stackal = 1; stackelsize = 1; strglgth = 200(*16*); (* This was not a very practical limit [sam] *) sethigh = 255(*47*); (* changed to byte from the old CDC limit [sam] *) setlow = 0; ordmaxchar = 255(*63*); (* standard 8 bit ASCII limits [sam] *) ordminchar = 0; maxint = 2147483647(*32767*); (* Use 32 bit limit [sam] *) lcaftermarkstack = 5; fileal = charal; (* stackelsize = minimum size for 1 stackelement = k*stackal stackal = scm(all other al-constants) charmax = scm(charsize,charal) scm = smallest common multiple lcaftermarkstack >= 4*ptrsize+max(x-size) = k1*stackelsize *) maxstack = 1; parmal = stackal; parmsize = stackelsize; recal = stackal; filebuffer = 4; maxaddr = maxint; type (*describing:*) (*************) marktype= ^integer; (*basic symbols*) (***************) symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop, lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow, colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy, procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy, beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy, gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy, thensy,othersy); operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop, neop,eqop,inop,noop); setofsys = set of symbol; chtp = (letter,number,special,illegal, chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace); (*constants*) (***********) setty = set of setlow..sethigh; cstclass = (reel,pset,strg); csp = ^ constant; constant = record case cclass: cstclass of reel: (rval: packed array [1..strglgth] of char); pset: (pval: setty); strg: (slgth: 0..strglgth; sval: packed array [1..strglgth] of char) end; valu = record case intval: boolean of (*intval never set nor tested*) true: (ival: integer); false: (valp: csp) end; (*data structures*) (*****************) levrange = 0..maxlevel; addrrange = 0..maxaddr; structform = (scalar,subrange,pointer,power,arrays,records,files, tagfld,variant); declkind = (standard,declared); stp = ^ structure; ctp = ^ identifier; structure = packed record marked: boolean; (*for test phase only*) size: addrrange; case form: structform of scalar: (case scalkind: declkind of declared: (fconst: ctp); standard: ()); subrange: (rangetype: stp; min,max: valu); pointer: (eltype: stp); power: (elset: stp); arrays: (aeltype,inxtype: stp); records: (fstfld: ctp; recvar: stp); files: (filtype: stp); tagfld: (tagfieldp: ctp; fstvar: stp); variant: (nxtvar,subvar: stp; varval: valu) end; (*names*) (*******) idclass = (types,konst,vars,field,proc,func); setofids = set of idclass; idkind = (actual,formal); alpha = packed array [1..8] of char; identifier = packed record name: alpha; llink, rlink: ctp; idtype: stp; next: ctp; case klass: idclass of types: (); konst: (values: valu); vars: (vkind: idkind; vlev: levrange; vaddr: addrrange); field: (fldaddr: addrrange); proc, func: (case pfdeckind: declkind of standard: (key: 1..15); declared: (pflev: levrange; pfname: integer; case pfkind: idkind of actual: (forwdecl, externl: boolean); formal: ())) end; disprange = 0..displimit; where = (blck,crec,vrec,rec); (*expressions*) (*************) attrkind = (cst,varbl,expr); vaccess = (drct,indrct,inxd); attr = record typtr: stp; case kind: attrkind of cst: (cval: valu); varbl: (case access: vaccess of drct: (vlevel: levrange; dplmt: addrrange); indrct: (idplmt: addrrange); inxd: ()); expr: () end; testp = ^ testpointer; testpointer = packed record elt1,elt2 : stp; lasttestp : testp end; (*labels*) (********) lbp = ^ labl; labl = record nextlab: lbp; defined: boolean; labval, labname: integer end; extfilep = ^filerec; filerec = record filename:alpha; nextfile:extfilep end; (*-------------------------------------------------------------------------*) var prr: text; (*returned by source program scanner insymbol: **********) sy: symbol; (*last symbol*) op: operator; (*classification of last symbol*) val: valu; (*value of last constant*) lgth: integer; (*length of last string constant*) id: alpha; (*last identifier (possibly truncated)*) kk: 1..8; (*nr of chars in last identifier*) ch: char; (*last character*) eol: boolean; (*end of line flag*) (*counters:*) (***********) chcnt: integer; (*character counter*) lc,ic: addrrange; (*data location and instruction counter*) linecount: integer; (*switches:*) (***********) dp, (*declaration part*) prterr, (*to allow forward references in pointer type declaration by suppressing error message*) list,prcode,prtables: boolean; (*output options for -- source program listing -- printing symbolic code -- displaying ident and struct tables --> procedure option*) debug: boolean; (*pointers:*) (***********) parmptr, intptr,realptr,charptr, boolptr,nilptr,textptr: stp; (*pointers to entries of standard ids*) utypptr,ucstptr,uvarptr, ufldptr,uprcptr,ufctptr, (*pointers to entries for undeclared ids*) fwptr: ctp; (*head of chain of forw decl type ids*) fextfilep: extfilep; (*head of chain of external files*) globtestp: testp; (*last testpointer*) (*bookkeeping of declaration levels:*) (************************************) level: levrange; (*current static level*) disx, (*level of last id searched by searchid*) top: disprange; (*top of display*) display: (*where: means:*) array [disprange] of packed record (*=blck: id is variable id*) fname: ctp; flabel: lbp; (*=crec: id is field id in record with*) case occur: where of (* constant address*) crec: (clev: levrange; (*=vrec: id is field id in record with*) cdspl: addrrange);(* variable address*) vrec: (vdspl: addrrange); blck: (); rec: () end; (* --> procedure withstatement*) (*error messages:*) (*****************) errinx: 0..10; (*nr of errors in current source line*) errlist: array [1..10] of packed record pos: integer; nmr: 1..400 end; (*expression compilation:*) (*************************) gattr: attr; (*describes the expr currently compiled*) (*structured constants:*) (***********************) constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys, statbegsys,typedels: setofsys; chartp : array[char] of chtp; rw: array [1..35(*nr. of res. words*)] of alpha; frw: array [1..9] of 1..36(*nr. of res. words + 1*); rsy: array [1..35(*nr. of res. words*)] of symbol; ssy: array [char] of symbol; rop: array [1..35(*nr. of res. words*)] of operator; sop: array [char] of operator; na: array [1..35] of alpha; mn: array [0..60] of packed array [1..4] of char; sna: array [1..23] of packed array [1..4] of char; cdx: array [0..60] of -4..+4; pdx: array [1..23] of -7..+7; ordint: array [char] of integer; intlabel,mxint10,digmax: integer; (*-------------------------------------------------------------------------*) procedure mark(var p: marktype); begin p := p (* shut up *) end; procedure release(p: marktype); begin p := p (* shut up *) end; procedure endofline; var lastpos,freepos,currpos,currnmr,f,k: integer; begin if errinx > 0 then (*output error messages*) begin write(output,linecount:6,' **** ':9); lastpos := 0; freepos := 1; for k := 1 to errinx do begin with errlist[k] do begin currpos := pos; currnmr := nmr end; if currpos = lastpos then write(output,',') else begin while freepos < currpos do begin write(output,' '); freepos := freepos + 1 end; write(output,'^'); lastpos := currpos end; if currnmr < 10 then f := 1 else if currnmr < 100 then f := 2 else f := 3; write(output,currnmr:f); freepos := freepos + f + 1 end; writeln(output); errinx := 0 end; linecount := linecount + 1; if list and (not eof(input)) then begin write(output,linecount:6,' ':2); if dp then write(output,lc:7) else write(output,ic:7); write(output,' ') end; chcnt := 0 end (*endofline*) ; procedure error(ferrnr: integer); begin if errinx >= 9 then begin errlist[10].nmr := 255; errinx := 10 end else begin errinx := errinx + 1; errlist[errinx].nmr := ferrnr end; errlist[errinx].pos := chcnt end (*error*) ; procedure insymbol; (*read next basic symbol of source program and return its description in the global variables sy, op, id, val and lgth*) label 1,2(*,3*); var i,k: integer; digit: packed array [1..strglgth] of char; string: packed array [1..strglgth] of char; lvp: csp; test: boolean; procedure nextch; begin if eol then begin if list then writeln(output); endofline end; if not eof(input) then begin eol := eoln(input); read(input,ch); if list then write(output,ch); chcnt := chcnt + 1 end else begin writeln(output,' *** eof ','encountered'); test := false end end; procedure options; begin repeat nextch; if ch <> '*' then begin if ch = 't' then begin nextch; prtables := ch = '+' end else if ch = 'l' then begin nextch; list := ch = '+'; if not list then writeln(output) end else if ch = 'd' then begin nextch; debug := ch = '+' end else if ch = 'c' then begin nextch; prcode := ch = '+' end; nextch end until ch <> ',' end (*options*) ; begin (*insymbol*) 1: repeat while ((ch = ' ') or (ch = ' ')) and not eol do nextch; test := eol; if test then nextch until not test; if chartp[ch] = illegal then begin sy := othersy; op := noop; error(399); nextch end else case chartp[ch] of letter: begin k := 0; repeat if k < 8 then begin k := k + 1; id[k] := ch end ; nextch until chartp[ch] in [special,illegal,chstrquo,chcolon, chperiod,chlt,chgt,chlparen,chspace]; if k >= kk then kk := k else repeat id[kk] := ' '; kk := kk - 1 until kk = k; for i := frw[k] to frw[k+1] - 1 do if rw[i] = id then begin sy := rsy[i]; op := rop[i]; goto 2 end; sy := ident; op := noop; 2: end; number: begin op := noop; i := 0; repeat i := i+1; if i<= digmax then digit[i] := ch; nextch until chartp[ch] <> number; if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then begin k := i; if ch = '.' then begin k := k+1; if k <= digmax then digit[k] := ch; nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*) if chartp[ch] <> number then error(201) else repeat k := k + 1; if k <= digmax then digit[k] := ch; nextch until chartp[ch] <> number end; if ch = 'e' then begin k := k+1; if k <= digmax then digit[k] := ch; nextch; if (ch = '+') or (ch ='-') then begin k := k+1; if k <= digmax then digit[k] := ch; nextch end; if chartp[ch] <> number then error(201) else repeat k := k+1; if k <= digmax then digit[k] := ch; nextch until chartp[ch] <> number end; new(lvp,reel); sy:= realconst; lvp^.cclass := reel; with lvp^ do begin for i := 1 to strglgth do rval[i] := ' '; if k <= digmax then for i := 2 to k + 1 do rval[i] := digit[i-1] else begin error(203); rval[2] := '0'; rval[3] := '.'; rval[4] := '0' end end; val.valp := lvp end else (* 3: *) begin if i > digmax then begin error(203); val.ival := 0 end else with val do begin ival := 0; for k := 1 to i do begin if ival <= mxint10 then ival := ival*10+ordint[digit[k]] else begin error(203); ival := 0 end end; sy := intconst end end end; chstrquo: begin lgth := 0; sy := stringconst; op := noop; repeat repeat nextch; lgth := lgth + 1; if lgth <= strglgth then string[lgth] := ch until (eol) or (ch = ''''); if eol then error(202) else nextch until ch <> ''''; lgth := lgth - 1; (*now lgth = nr of chars in string*) if lgth = 0 then error(205) else if lgth = 1 then val.ival := ord(string[1]) else begin new(lvp,strg); lvp^.cclass:=strg; if lgth > strglgth then begin error(399); lgth := strglgth end; with lvp^ do begin slgth := lgth; for i := 1 to lgth do sval[i] := string[i] end; val.valp := lvp end end; chcolon: begin op := noop; nextch; if ch = '=' then begin sy := becomes; nextch end else sy := colon end; chperiod: begin op := noop; nextch; if ch = '.' then begin sy := colon; nextch end else sy := period end; chlt: begin nextch; sy := relop; if ch = '=' then begin op := leop; nextch end else if ch = '>' then begin op := neop; nextch end else op := ltop end; chgt: begin nextch; sy := relop; if ch = '=' then begin op := geop; nextch end else op := gtop end; chlparen: begin nextch; if ch = '*' then begin nextch; if ch = '$' then options; repeat while (ch <> '*') and not eof(input) do nextch; nextch until (ch = ')') or eof(input); nextch; goto 1 end; sy := lparent; op := noop end; special: begin sy := ssy[ch]; op := sop[ch]; nextch end; chspace: sy := othersy end (*case*) end (*insymbol*) ; procedure enterid(fcp: ctp); (*enter id pointed at by fcp into the name-table, which on each declaration level is organised as an unbalanced binary tree*) var nam: alpha; lcp, lcp1: ctp; lleft: boolean; begin nam := fcp^.name; lcp := display[top].fname; if lcp = nil then display[top].fname := fcp else begin repeat lcp1 := lcp; if lcp^.name = nam then (*name conflict, follow right link*) begin error(101); lcp := lcp^.rlink; lleft := false end else if lcp^.name < nam then begin lcp := lcp^.rlink; lleft := false end else begin lcp := lcp^.llink; lleft := true end until lcp = nil; if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp end; fcp^.llink := nil; fcp^.rlink := nil end (*enterid*) ; procedure searchsection(fcp: ctp; var fcp1: ctp); (*to find record fields and forward declared procedure id's --> procedure proceduredeclaration --> procedure selector*) label 1; begin while fcp <> nil do if fcp^.name = id then goto 1 else if fcp^.name < id then fcp := fcp^.rlink else fcp := fcp^.llink; 1: fcp1 := fcp end (*searchsection*) ; (* Added to search id, disxl is now used for a local "for" index, which matches ISO 7185. Also, depending on the index keeping its contents after the containing statement is a violation, so the behavior of setting disx to last search id was emulated [sam] *) procedure searchid(fidcls: setofids; var fcp: ctp); label 1; var lcp: ctp; disxl: disprange; begin for disxl := top downto 0 do begin lcp := display[disxl].fname; while lcp <> nil do if lcp^.name = id then if lcp^.klass in fidcls then begin disx := disxl; goto 1 end else begin if prterr then error(103); lcp := lcp^.rlink end else if lcp^.name < id then lcp := lcp^.rlink else lcp := lcp^.llink end; disx := 0; (*search not successful; suppress error message in case of forward referenced type id in pointer type definition --> procedure simpletype*) if prterr then begin error(104); (*to avoid returning nil, reference an entry for an undeclared id of appropriate class --> procedure enterundecl*) if types in fidcls then lcp := utypptr else if vars in fidcls then lcp := uvarptr else if field in fidcls then lcp := ufldptr else if konst in fidcls then lcp := ucstptr else if proc in fidcls then lcp := uprcptr else lcp := ufctptr; end; 1: fcp := lcp end (*searchid*) ; procedure getbounds(fsp: stp; var fmin,fmax: integer); (*get internal bounds of subrange or scalar type*) (*assume fsp<>intptr and fsp<>realptr*) begin fmin := 0; fmax := 0; if fsp <> nil then with fsp^ do if form = subrange then begin fmin := min.ival; fmax := max.ival end else if fsp = charptr then begin fmin := ordminchar; fmax := ordmaxchar end else if fconst <> nil then fmax := fconst^.values.ival end (*getbounds*) ; function alignquot(fsp: stp): integer; begin alignquot := 1; if fsp <> nil then with fsp^ do case form of scalar: if fsp=intptr then alignquot := intal else if fsp=boolptr then alignquot := boolal else if scalkind=declared then alignquot := intal else if fsp=charptr then alignquot := charal else if fsp=realptr then alignquot := realal else (*parmptr*) alignquot := parmal; subrange: alignquot := alignquot(rangetype); pointer: alignquot := adral; power: alignquot := setal; files: alignquot := fileal; arrays: alignquot := alignquot(aeltype); records: alignquot := recal; variant,tagfld: error(501) end end (*alignquot*); procedure align(fsp: stp; var flc: addrrange); var k,l: integer; begin k := alignquot(fsp); l := flc-1; flc := l + k - (k+l) mod k end (*align*); procedure printtables(fb: boolean); (*print data structure and name table*) (* Added these functions to convert pointers to integers. Works on any machine where pointers and integers are the same format. The original code was for a processor where "ord" would do this, a very nonstandard feature [sam] *) const intsize = 11; (* size of printed integer *) var i, lim: disprange; function stptoint(p: stp): integer; var r: record case boolean of false: (p: stp); true: (i: integer) end; begin r.p := p; stptoint := r.i end; function ctptoint(p: ctp): integer; var r: record case boolean of false: (p: ctp); true: (i: integer) end; begin r.p := p; ctptoint := r.i end; procedure marker; (*mark data structure entries to avoid multiple printout*) var i: integer; procedure markctp(fp: ctp); forward; procedure markstp(fp: stp); (*mark data structures, prevent cycles*) begin if fp <> nil then with fp^ do begin marked := true; case form of scalar: ; subrange: markstp(rangetype); pointer: (*don't mark eltype: cycle possible; will be marked anyway, if fp = true*) ; power: markstp(elset) ; arrays: begin markstp(aeltype); markstp(inxtype) end; records: begin markctp(fstfld); markstp(recvar) end; files: markstp(filtype); tagfld: markstp(fstvar); variant: begin markstp(nxtvar); markstp(subvar) end end (*case*) end (*with*) end (*markstp*); procedure markctp; begin if fp <> nil then with fp^ do begin markctp(llink); markctp(rlink); markstp(idtype) end end (*markctp*); begin (*marker*) for i := top downto lim do markctp(display[i].fname) end (*marker*); procedure followctp(fp: ctp); forward; procedure followstp(fp: stp); begin if fp <> nil then with fp^ do if marked then begin marked := false; write(output,' ':4,stptoint(*ord*)(fp):intsize(*6*),size:10); case form of scalar: begin write(output,'scalar':10); if scalkind = standard then write(output,'standard':10) else write(output,'declared':10,' ':4,ctptoint(*ord*)(fconst):intsize(*6*)); writeln(output) end; subrange: begin write(output,'subrange':10,' ':4,stptoint(*ord*)(rangetype):6); if rangetype <> realptr then write(output,min.ival,max.ival) else if (min.valp <> nil) and (max.valp <> nil) then write(output,' ',min.valp^.rval:9, ' ',max.valp^.rval:9); writeln(output); followstp(rangetype); end; pointer: writeln(output,'pointer':10,' ':4,stptoint(*ord*)(eltype):intsize(*6*)); power: begin writeln(output,'set':10,' ':4,stptoint(*ord*)(elset):intsize(*6*)); followstp(elset) end; arrays: begin writeln(output,'array':10,' ':4,stptoint(*ord*)(aeltype):intsize(*6*),' ':4, stptoint(*ord*)(inxtype):6); followstp(aeltype); followstp(inxtype) end; records: begin writeln(output,'record':10,' ':4,ctptoint(*ord*)(fstfld):intsize(*6*),' ':4, stptoint(*ord*)(recvar):intsize(*6*)); followctp(fstfld); followstp(recvar) end; files: begin write(output,'file':10,' ':4,stptoint(*ord*)(filtype):intsize(*6*)); followstp(filtype) end; tagfld: begin writeln(output,'tagfld':10,' ':4,ctptoint(*ord*)(tagfieldp):intsize(*6*), ' ':4,stptoint(*ord*)(fstvar):intsize(*6*)); followstp(fstvar) end; variant: begin writeln(output,'variant':10,' ':4,stptoint(*ord*)(nxtvar):intsize(*6*), ' ':4,stptoint(*ord*)(subvar):intsize(*6*),varval.ival); followstp(nxtvar); followstp(subvar) end end (*case*) end (*if marked*) end (*followstp*); procedure followctp; var i: integer; begin if fp <> nil then with fp^ do begin write(output,' ':4,ctptoint(*ord*)(fp):intsize(*6*),' ',name:9,' ':4,ctptoint(*ord*)(llink):intsize(*6*), ' ':4,ctptoint(*ord*)(rlink):intsize(*6*),' ':4,stptoint(*ord*)(idtype):intsize(*6*)); case klass of types: write(output,'type':10); konst: begin write(output,'constant':10,' ':4,ctptoint(*ord*)(next):intsize(*6*)); if idtype <> nil then if idtype = realptr then begin if values.valp <> nil then write(output,' ',values.valp^.rval:9) end else if idtype^.form = arrays then (*stringconst*) begin if values.valp <> nil then begin write(output,' '); with values.valp^ do for i := 1 to slgth do write(output,sval[i]) end end else write(output,values.ival) end; vars: begin write(output,'variable':10); if vkind = actual then write(output,'actual':10) else write(output,'formal':10); write(output,' ':4,ctptoint(*ord*)(next):intsize(*6*),vlev,' ':4,vaddr:6 ); end; field: write(output,'field':10,' ':4,ctptoint(*ord*)(next):intsize(*6*),' ':4,fldaddr:6); proc, func: begin if klass = proc then write(output,'procedure':10) else write(output,'function':10); if pfdeckind = standard then write(output,'standard':10, key:10) else begin write(output,'declared':10,' ':4,ctptoint(*ord*)(next):intsize(*6*)); write(output,pflev,' ':4,pfname:6); if pfkind = actual then begin write(output,'actual':10); if forwdecl then write(output,'forward':10) else write(output,'notforward':10); if externl then write(output,'extern':10) else write(output,'not extern':10); end else write(output,'formal':10) end end end (*case*); writeln(output); followctp(llink); followctp(rlink); followstp(idtype) end (*with*) end (*followctp*); begin (*printtables*) writeln(output); writeln(output); writeln(output); if fb then lim := 0 else begin lim := top; write(output,' local') end; writeln(output,' tables '); writeln(output); marker; for i := top downto lim do followctp(display[i].fname); writeln(output); if not eol then write(output,' ':chcnt+16) end (*printtables*); procedure genlabel(var nxtlab: integer); begin intlabel := intlabel + 1; nxtlab := intlabel end (*genlabel*); procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp); var lsy: symbol; test: boolean; procedure skip(fsys: setofsys); (*skip input string until relevant symbol found*) begin if not eof(input) then begin while not(sy in fsys) and (not eof(input)) do insymbol; if not (sy in fsys) then insymbol end end (*skip*) ; procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu); var lsp: stp; lcp: ctp; sign: (none,pos,neg); lvp: csp; i: 2..strglgth; begin lsp := nil; fvalu.ival := 0; if not(sy in constbegsys) then begin error(50); skip(fsys+constbegsys) end; if sy in constbegsys then begin if sy = stringconst then begin if lgth = 1 then lsp := charptr else begin new(lsp,arrays); with lsp^ do begin aeltype := charptr; inxtype := nil; size := lgth*charsize; form := arrays end end; fvalu := val; insymbol end else begin sign := none; if (sy = addop) and (op in [plus,minus]) then begin if op = plus then sign := pos else sign := neg; insymbol end; if sy = ident then begin searchid([konst],lcp); with lcp^ do begin lsp := idtype; fvalu := values end; if sign <> none then if lsp = intptr then begin if sign = neg then fvalu.ival := -fvalu.ival end else if lsp = realptr then begin if sign = neg then begin new(lvp,reel); if fvalu.valp^.rval[1] = '-' then lvp^.rval[1] := '+' else lvp^.rval[1] := '-'; for i := 2 to strglgth do lvp^.rval[i] := fvalu.valp^.rval[i]; fvalu.valp := lvp; end end else error(105); insymbol; end else if sy = intconst then begin if sign = neg then val.ival := -val.ival; lsp := intptr; fvalu := val; insymbol end else if sy = realconst then begin if sign = neg then val.valp^.rval[1] := '-'; lsp := realptr; fvalu := val; insymbol end else begin error(106); skip(fsys) end end; if not (sy in fsys) then begin error(6); skip(fsys) end end; fsp := lsp end (*constant*) ; function equalbounds(fsp1,fsp2: stp): boolean; var lmin1,lmin2,lmax1,lmax2: integer; begin if (fsp1=nil) or (fsp2=nil) then equalbounds := true else begin getbounds(fsp1,lmin1,lmax1); getbounds(fsp2,lmin2,lmax2); equalbounds := (lmin1=lmin2) and (lmax1=lmax2) end end (*equalbounds*) ; function comptypes(fsp1,fsp2: stp) : boolean; (*decide whether structures pointed at by fsp1 and fsp2 are compatible*) var nxt1,nxt2: ctp; comp: boolean; ltestp1,ltestp2 : testp; begin if fsp1 = fsp2 then comptypes := true else if (fsp1 <> nil) and (fsp2 <> nil) then if fsp1^.form = fsp2^.form then case fsp1^.form of scalar: comptypes := false; (* identical scalars declared on different levels are not recognized to be compatible*) subrange: comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype); pointer: begin comp := false; ltestp1 := globtestp; ltestp2 := globtestp; while ltestp1 <> nil do with ltestp1^ do begin if (elt1 = fsp1^.eltype) and (elt2 = fsp2^.eltype) then comp := true; ltestp1 := lasttestp end; if not comp then begin new(ltestp1); with ltestp1^ do begin elt1 := fsp1^.eltype; elt2 := fsp2^.eltype; lasttestp := globtestp end; globtestp := ltestp1; comp := comptypes(fsp1^.eltype,fsp2^.eltype) end; comptypes := comp; globtestp := ltestp2 end; power: comptypes := comptypes(fsp1^.elset,fsp2^.elset); arrays: begin comp := comptypes(fsp1^.aeltype,fsp2^.aeltype) and comptypes(fsp1^.inxtype,fsp2^.inxtype); comptypes := comp and (fsp1^.size = fsp2^.size) and equalbounds(fsp1^.inxtype,fsp2^.inxtype) end; records: begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true; while (nxt1 <> nil) and (nxt2 <> nil) do begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype); nxt1 := nxt1^.next; nxt2 := nxt2^.next end; comptypes := comp and (nxt1 = nil) and (nxt2 = nil) and(fsp1^.recvar = nil)and(fsp2^.recvar = nil) end; (*identical records are recognized to be compatible iff no variants occur*) files: comptypes := comptypes(fsp1^.filtype,fsp2^.filtype) end (*case*) else (*fsp1^.form <> fsp2^.form*) if fsp1^.form = subrange then comptypes := comptypes(fsp1^.rangetype,fsp2) else if fsp2^.form = subrange then comptypes := comptypes(fsp1,fsp2^.rangetype) else comptypes := false else comptypes := true end (*comptypes*) ; function string(fsp: stp) : boolean; begin string := false; if fsp <> nil then if fsp^.form = arrays then if comptypes(fsp^.aeltype,charptr) then string := true end (*string*) ; procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange); var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp; lsize,displ: addrrange; lmin,lmax: integer; procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange); var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange; lcnt: integer; lvalu: valu; begin fsize := 1; if not (sy in simptypebegsys) then begin error(1); skip(fsys + simptypebegsys) end; if sy in simptypebegsys then begin if sy = lparent then begin ttop := top; (*decl. consts local to innermost block*) while display[top].occur <> blck do top := top - 1; new(lsp,scalar,declared); with lsp^ do begin size := intsize; form := scalar; scalkind := declared end; lcp1 := nil; lcnt := 0; repeat insymbol; if sy = ident then begin new(lcp,konst); with lcp^ do begin name := id; idtype := lsp; next := lcp1; values.ival := lcnt; klass := konst end; enterid(lcp); lcnt := lcnt + 1; lcp1 := lcp; insymbol end else error(2); if not (sy in fsys + [comma,rparent]) then begin error(6); skip(fsys + [comma,rparent]) end until sy <> comma; lsp^.fconst := lcp1; top := ttop; if sy = rparent then insymbol else error(4) end else begin if sy = ident then begin searchid([types,konst],lcp); insymbol; if lcp^.klass = konst then begin new(lsp,subrange); with lsp^, lcp^ do begin rangetype := idtype; form := subrange; if string(rangetype) then begin error(148); rangetype := nil end; min := values; size := intsize end; if sy = colon then insymbol else error(5); constant(fsys,lsp1,lvalu); lsp^.max := lvalu; if lsp^.rangetype <> lsp1 then error(107) end else begin lsp := lcp^.idtype; if lsp <> nil then fsize := lsp^.size end end (*sy = ident*) else begin new(lsp,subrange); lsp^.form := subrange; constant(fsys + [colon],lsp1,lvalu); if string(lsp1) then begin error(148); lsp1 := nil end; with lsp^ do begin rangetype:=lsp1; min:=lvalu; size:=intsize end; if sy = colon then insymbol else error(5); constant(fsys,lsp1,lvalu); lsp^.max := lvalu; if lsp^.rangetype <> lsp1 then error(107) end; if lsp <> nil then with lsp^ do if form = subrange then if rangetype <> nil then if rangetype = realptr then error(399) else if min.ival > max.ival then error(102) end; fsp := lsp; if not (sy in fsys) then begin error(6); skip(fsys) end end else fsp := nil end (*simpletype*) ; procedure fieldlist(fsys: setofsys; var frecvar: stp); var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp; minsize,maxsize,lsize: addrrange; lvalu: valu; begin nxt1 := nil; lsp := nil; if not (sy in (fsys+[ident,casesy])) then begin error(19); skip(fsys + [ident,casesy]) end; while sy = ident do begin nxt := nxt1; repeat if sy = ident then begin new(lcp,field); with lcp^ do begin name := id; idtype := nil; next := nxt; klass := field end; nxt := lcp; enterid(lcp); insymbol end else error(2); if not (sy 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,lsize); while nxt <> nxt1 do with nxt^ do begin align(lsp,displ); idtype := lsp; fldaddr := displ; nxt := next; displ := displ + lsize end; nxt1 := lcp; while sy = semicolon do begin insymbol; if not (sy in fsys + [ident,casesy,semicolon]) then begin error(19); skip(fsys + [ident,casesy]) end end end (*while*); nxt := nil; while nxt1 <> nil do with nxt1^ do begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end; if sy = casesy then begin new(lsp,tagfld); with lsp^ do begin tagfieldp := nil; fstvar := nil; form:=tagfld end; frecvar := lsp; insymbol; if sy = ident then begin new(lcp,field); with lcp^ do begin name := id; idtype := nil; klass:=field; next := nil; fldaddr := displ end; enterid(lcp); insymbol; if sy = colon then insymbol else error(5); if sy = ident then begin searchid([types],lcp1); lsp1 := lcp1^.idtype; if lsp1 <> nil then begin align(lsp1,displ); lcp^.fldaddr := displ; displ := displ+lsp1^.size; if (lsp1^.form <= subrange) or string(lsp1) then begin if comptypes(realptr,lsp1) then error(109) else if string(lsp1) then error(399); lcp^.idtype := lsp1; lsp^.tagfieldp := lcp; end else error(110); end; insymbol; end else begin error(2); skip(fsys + [ofsy,lparent]) end end else begin error(2); skip(fsys + [ofsy,lparent]) end; lsp^.size := displ; if sy = ofsy then insymbol else error(8); lsp1 := nil; minsize := displ; maxsize := displ; repeat lsp2 := nil; if not (sy in fsys + [semicolon]) then begin repeat constant(fsys + [comma,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; subvar := lsp2; varval := lvalu; form := variant end; lsp4 := lsp1; while lsp4 <> nil do with lsp4^ do begin if varval.ival = lvalu.ival then error(178); lsp4 := nxtvar end; lsp1 := lsp3; lsp2 := lsp3; test := sy <> comma; if not test then insymbol until test; if sy = colon then insymbol else error(5); if sy = lparent then insymbol else error(9); fieldlist(fsys + [rparent,semicolon],lsp2); if displ > maxsize then maxsize := displ; while lsp3 <> nil do begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2; lsp3^.size := displ; lsp3 := lsp4 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); end; test := sy <> semicolon; if not test then begin displ := minsize; insymbol end until test; displ := maxsize; lsp^.fstvar := lsp1; end else frecvar := nil end (*fieldlist*) ; begin (*typ*) if not (sy in typebegsys) then begin error(10); skip(fsys + typebegsys) end; if sy in typebegsys then begin if sy in simptypebegsys then simpletype(fsys,fsp,fsize) else (*^*) if sy = arrow then begin new(lsp,pointer); fsp := lsp; with lsp^ do begin eltype := nil; size := ptrsize; form:=pointer end; insymbol; if sy = ident then begin prterr := false; (*no error if search not successful*) searchid([types],lcp); prterr := true; if lcp = nil then (*forward referenced type id*) begin new(lcp,types); with lcp^ do begin name := id; idtype := lsp; next := fwptr; klass := types end; fwptr := lcp end else begin if lcp^.idtype <> nil then if lcp^.idtype^.form = files then error(108) else lsp^.eltype := lcp^.idtype end; insymbol; end else error(2); end else begin if sy = packedsy then begin insymbol; if not (sy in typedels) then begin error(10); skip(fsys + typedels) end end; (*array*) if sy = arraysy then begin insymbol; if sy = lbrack then insymbol else error(11); lsp1 := nil; repeat new(lsp,arrays); with lsp^ do begin aeltype := lsp1; inxtype := nil; form:=arrays end; lsp1 := lsp; simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize); lsp1^.size := lsize; if lsp2 <> nil then if lsp2^.form <= subrange then begin if lsp2 = realptr then begin error(109); lsp2 := nil end else if lsp2 = intptr then begin error(149); lsp2 := nil end; lsp^.inxtype := lsp2 end else begin error(113); lsp2 := nil end; test := sy <> comma; if not test then insymbol until test; if sy = rbrack then insymbol else error(12); if sy = ofsy then insymbol else error(8); typ(fsys,lsp,lsize); repeat with lsp1^ do begin lsp2 := aeltype; aeltype := lsp; if inxtype <> nil then begin getbounds(inxtype,lmin,lmax); align(lsp,lsize); lsize := lsize*(lmax - lmin + 1); size := lsize end end; lsp := lsp1; lsp1 := lsp2 until lsp1 = nil end else (*record*) if sy = recordsy then begin insymbol; oldtop := top; if top < displimit then begin top := top + 1; with display[top] do begin fname := nil; flabel := nil; occur := rec end end else error(250); displ := 0; fieldlist(fsys-[semicolon]+[endsy],lsp1); new(lsp,records); with lsp^ do begin fstfld := display[top].fname; recvar := lsp1; size := displ; form := records end; top := oldtop; if sy = endsy then insymbol else error(13) end else (*set*) if sy = setsy then begin insymbol; if sy = ofsy then insymbol else error(8); simpletype(fsys,lsp1,lsize); if lsp1 <> nil then if lsp1^.form > subrange then begin error(115); lsp1 := nil end else if lsp1 = realptr then begin error(114); lsp1 := nil end else if lsp1 = intptr then begin error(169); lsp1 := nil end else begin getbounds(lsp1,lmin,lmax); if (lmin < setlow) or (lmax > sethigh) then error(169); end; new(lsp,power); with lsp^ do begin elset:=lsp1; size:=setsize; form:=power end; end else (*file*) if sy = filesy then begin insymbol; error(399); skip(fsys); lsp := nil end; fsp := lsp end; if not (sy in fsys) then begin error(6); skip(fsys) end end else fsp := nil; if fsp = nil then fsize := 1 else fsize := fsp^.size end (*typ*) ; procedure labeldeclaration; var llp: lbp; redef: boolean; lbname: integer; begin repeat if sy = intconst then with display[top] do begin llp := flabel; redef := false; while (llp <> nil) and not redef do if llp^.labval <> val.ival then llp := llp^.nextlab else begin redef := true; error(166) end; if not redef then begin new(llp); with llp^ do begin labval := val.ival; genlabel(lbname); defined := false; nextlab := flabel; labname := lbname end; flabel := llp end; insymbol end else error(15); if not ( sy in fsys + [comma, semicolon] ) then begin error(6); skip(fsys+[comma,semicolon]) end; test := sy <> comma; if not test then insymbol until test; if sy = semicolon then insymbol else error(14) end (* labeldeclaration *) ; procedure constdeclaration; var lcp: ctp; lsp: stp; lvalu: valu; begin if sy <> ident then begin error(2); skip(fsys + [ident]) end; while sy = ident do begin new(lcp,konst); with lcp^ do begin name := id; idtype := nil; next := nil; klass:=konst end; insymbol; if (sy = relop) and (op = eqop) then insymbol else error(16); constant(fsys + [semicolon],lsp,lvalu); enterid(lcp); lcp^.idtype := lsp; lcp^.values := lvalu; if sy = semicolon then begin insymbol; if not (sy in fsys + [ident]) then begin error(6); skip(fsys + [ident]) end end else error(14) end end (*constdeclaration*) ; procedure typedeclaration; var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange; begin if sy <> ident then begin error(2); skip(fsys + [ident]) end; while sy = ident do begin new(lcp,types); with lcp^ do begin name := id; idtype := nil; klass := types end; insymbol; if (sy = relop) and (op = eqop) then insymbol else error(16); typ(fsys + [semicolon],lsp,lsize); enterid(lcp); lcp^.idtype := lsp; (*has any forward reference been satisfied:*) lcp1 := fwptr; while lcp1 <> nil do begin if lcp1^.name = lcp^.name then begin lcp1^.idtype^.eltype := lcp^.idtype; if lcp1 <> fwptr then lcp2^.next := lcp1^.next else fwptr := lcp1^.next; end else lcp2 := lcp1; lcp1 := lcp1^.next end; if sy = semicolon then begin insymbol; if not (sy in fsys + [ident]) then begin error(6); skip(fsys + [ident]) end end else error(14) end; if fwptr <> nil then begin error(117); writeln(output); repeat writeln(output,' type-id ',fwptr^.name); fwptr := fwptr^.next until fwptr = nil; if not eol then write(output,' ': chcnt+16) end end (*typedeclaration*) ; procedure vardeclaration; var lcp,nxt: ctp; lsp: stp; lsize: addrrange; begin nxt := nil; repeat repeat if sy = ident then begin new(lcp,vars); with lcp^ do begin name := id; next := nxt; klass := vars; idtype := nil; vkind := actual; vlev := level end; enterid(lcp); nxt := lcp; insymbol; end else error(2); if not (sy in fsys + [comma,colon] + typedels) then begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end; test := sy <> comma; if not test then insymbol until test; if sy = colon then insymbol else error(5); typ(fsys + [semicolon] + typedels,lsp,lsize); while nxt <> nil do with nxt^ do begin align(lsp,lc); idtype := lsp; vaddr := lc; lc := lc + lsize; nxt := next end; if sy = semicolon then begin insymbol; if not (sy in fsys + [ident]) then begin error(6); skip(fsys + [ident]) end end else error(14) until (sy <> ident) and not (sy in typedels); if fwptr <> nil then begin error(117); writeln(output); repeat writeln(output,' type-id ',fwptr^.name); fwptr := fwptr^.next until fwptr = nil; if not eol then write(output,' ': chcnt+16) end end (*vardeclaration*) ; procedure procdeclaration(fsy: symbol); var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp; forw: boolean; oldtop: disprange; llc,lcm: addrrange; lbname: integer; markp: marktype; procedure parameterlist(fsy: setofsys; var fpar: ctp); var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind; llc,lsize: addrrange; count: integer; begin lcp1 := nil; if not (sy in fsy + [lparent]) then begin error(7); skip(fsys + fsy + [lparent]) end; if sy = lparent then begin if forw then error(119); insymbol; if not (sy in [ident,varsy,procsy,funcsy]) then begin error(7); skip(fsys + [ident,rparent]) end; while sy in [ident,varsy,procsy,funcsy] do begin if sy = procsy then begin error(399); repeat insymbol; if sy = ident then begin new(lcp,proc,declared,formal); with lcp^ do begin name := id; idtype := nil; next := lcp1; pflev := level (*beware of parameter procedures*); klass:=proc;pfdeckind:=declared;pfkind:=formal end; enterid(lcp); lcp1 := lcp; align(parmptr,lc); (*lc := lc + some size *) insymbol end else error(2); if not (sy in fsys + [comma,semicolon,rparent]) then begin error(7);skip(fsys+[comma,semicolon,rparent])end until sy <> comma end else begin if sy = funcsy then begin error(399); lcp2 := nil; repeat insymbol; if sy = ident then begin new(lcp,func,declared,formal); with lcp^ do begin name := id; idtype := nil; next := lcp2; pflev := level (*beware param funcs*); klass:=func;pfdeckind:=declared; pfkind:=formal end; enterid(lcp); lcp2 := lcp; align(parmptr,lc); (*lc := lc + some size*) insymbol; end; if not (sy in [comma,colon] + fsys) then begin error(7);skip(fsys+[comma,semicolon,rparent]) end until sy <> comma; if sy = colon then begin insymbol; if sy = ident then begin searchid([types],lcp); lsp := lcp^.idtype; if lsp <> nil then if not(lsp^.form in[scalar,subrange,pointer]) then begin error(120); lsp := nil end; lcp3 := lcp2; while lcp2 <> nil do begin lcp2^.idtype := lsp; lcp := lcp2; lcp2 := lcp2^.next end; lcp^.next := lcp1; lcp1 := lcp3; insymbol end else error(2); if not (sy in fsys + [semicolon,rparent]) then begin error(7);skip(fsys+[semicolon,rparent])end end else error(5) end else begin if sy = varsy then begin lkind := formal; insymbol end else lkind := actual; lcp2 := nil; count := 0; repeat if sy = ident then begin new(lcp,vars); with lcp^ do begin name:=id; idtype:=nil; klass:=vars; vkind := lkind; next := lcp2; vlev := level; end; enterid(lcp); lcp2 := lcp; count := count+1; insymbol; end; if not (sy in [comma,colon] + fsys) then begin error(7);skip(fsys+[comma,semicolon,rparent]) 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 := lcp^.idtype; lsize := ptrsize; if lsp <> nil then if lkind=actual then if lsp^.form<=power then lsize := lsp^.size else if lsp^.form=files then error(121); align(parmptr,lsize); lcp3 := lcp2; align(parmptr,lc); lc := lc+count*lsize; llc := lc; while lcp2 <> nil do begin lcp := lcp2; with lcp2^ do begin idtype := lsp; llc := llc-lsize; vaddr := llc; end; lcp2 := lcp2^.next end; lcp^.next := lcp1; lcp1 := lcp3; insymbol end else error(2); if not (sy in fsys + [semicolon,rparent]) then begin error(7);skip(fsys+[semicolon,rparent])end end else error(5); end; end; if sy = semicolon then begin insymbol; if not (sy in fsys + [ident,varsy,procsy,funcsy]) then begin error(7); 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); lcp3 := nil; (*reverse pointers and reserve local cells for copies of multiple values*) while lcp1 <> nil do with lcp1^ do begin lcp2 := next; next := lcp3; if klass = vars then if idtype <> nil then if (vkind=actual)and(idtype^.form>power) then begin align(idtype,lc); vaddr := lc; lc := lc+idtype^.size; end; lcp3 := lcp1; lcp1 := lcp2 end; fpar := lcp3 end else fpar := nil end (*parameterlist*) ; begin (*procdeclaration*) llc := lc; lc := lcaftermarkstack; forw := false; if sy = ident then begin searchsection(display[top].fname,lcp); (*decide whether forw.*) if lcp <> nil then begin if lcp^.klass = proc then forw := lcp^.forwdecl and(fsy=procsy)and(lcp^.pfkind=actual) else if lcp^.klass = func then forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual) else forw := false; if not forw then error(160) end; if not forw then begin if fsy = procsy then new(lcp,proc,declared,actual) else new(lcp,func,declared,actual); with lcp^ do begin name := id; idtype := nil; externl := false; pflev := level; genlabel(lbname); pfdeckind := declared; pfkind := actual; pfname := lbname; if fsy = procsy then klass := proc else klass := func end; enterid(lcp) end else begin lcp1 := lcp^.next; while lcp1 <> nil do begin with lcp1^ do if klass = vars then if idtype <> nil then begin lcm := vaddr + idtype^.size; if lcm > lc then lc := lcm end; lcp1 := lcp1^.next end end; insymbol end else begin error(2); lcp := ufctptr end; oldlev := level; oldtop := top; if level < maxlevel then level := level + 1 else error(251); if top < displimit then begin top := top + 1; with display[top] do begin if forw then fname := lcp^.next else fname := nil; flabel := nil; occur := blck end end else error(250); if fsy = procsy then begin parameterlist([semicolon],lcp1); if not forw then lcp^.next := lcp1 end else begin parameterlist([semicolon,colon],lcp1); if not forw then lcp^.next := lcp1; if sy = colon then begin insymbol; if sy = ident then begin if forw then error(122); searchid([types],lcp1); lsp := lcp1^.idtype; lcp^.idtype := lsp; if lsp <> nil then if not (lsp^.form in [scalar,subrange,pointer]) then begin error(120); lcp^.idtype := nil end; insymbol end else begin error(2); skip(fsys + [semicolon]) end end else if not forw then error(123) end; if sy = semicolon then insymbol else error(14); if sy = forwardsy then begin if forw then error(161) else lcp^.forwdecl := true; insymbol; if sy = semicolon then insymbol else error(14); if not (sy in fsys) then begin error(6); skip(fsys) end end else begin lcp^.forwdecl := false; mark(markp); repeat block(fsys,semicolon,lcp); if sy = semicolon then begin if prtables then printtables(false); insymbol; if not (sy in [beginsy,procsy,funcsy]) then begin error(6); skip(fsys) end end else error(14) until (sy in [beginsy,procsy,funcsy]) or eof(input); release(markp); (* return local entries on runtime heap *) end; level := oldlev; top := oldtop; lc := llc; end (*procdeclaration*) ; procedure body(fsys: setofsys); const cstoccmax=4000(*65*); cixmax=1000; (* cstoccmax was too small [sam] *) type oprange = 0..63; var llcp:ctp; saveid:alpha; cstptr: array [1..cstoccmax] of csp; cstptrix: 0..cstoccmax; (*allows referencing of noninteger constants by an index (instead of a pointer), which can be stored in the p2-field of the instruction record until writeout. --> procedure load, procedure writeout*) entname, segsize: integer; stacktop, topnew, topmax: integer; lcmax,llc1: addrrange; lcp: ctp; llp: lbp; procedure mes(i: integer); begin topnew := topnew + cdx[i]*maxstack; if topnew > topmax then topmax := topnew end; procedure putic; begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end; procedure gen0(fop: oprange); begin if prcode then begin putic; writeln(prr,mn[fop]:4) end; ic := ic + 1; mes(fop) end (*gen0*) ; procedure gen1(fop: oprange; fp2: integer); var k: integer; begin if prcode then begin putic; write(prr,mn[fop]:4); if fop = 30 then begin writeln(prr,sna[fp2]:12); topnew := topnew + pdx[fp2]*maxstack; if topnew > topmax then topmax := topnew end else begin if fop = 38 then begin write(prr,''''); with cstptr[fp2]^ do begin for k := 1 to slgth do write(prr,sval[k]:1); for k := slgth+1 to strglgth do write(prr,' '); end; writeln(prr,'''') end else if fop = 42 then writeln(prr,chr(fp2)) else writeln(prr,fp2:12); mes(fop) end end; ic := ic + 1 end (*gen1*) ; procedure gen2(fop: oprange; fp1,fp2: integer); var k : integer; begin if prcode then begin putic; write(prr,mn[fop]:4); case fop of 45,50,54,56: writeln(prr,' ',fp1:3,fp2:8); 47,48,49,52,53,55: begin write(prr,chr(fp1)); if chr(fp1) = 'm' then write(prr,fp2:11); writeln(prr) end; 51: case fp1 of 1: writeln(prr,'i ',fp2); 2: begin write(prr,'r '); with cstptr[fp2]^ do for k := 1 to strglgth do write(prr,rval[k]); writeln(prr) end; 3: writeln(prr,'b ',fp2); 4: writeln(prr,'n'); 6: writeln(prr,'c ''':3,chr(fp2),''''); 5: begin write(prr,'('); with cstptr[fp2]^ do for k := setlow to sethigh do (* increased for testing [sam] *) if k in pval then write(prr,k:7(*3*)); writeln(prr,')') end end end; end; ic := ic + 1; mes(fop) end (*gen2*) ; procedure gentypindicator(fsp: stp); begin if fsp<>nil then with fsp^ do case form of scalar: if fsp=intptr then write(prr,'i') else if fsp=boolptr then write(prr,'b') else if fsp=charptr then write(prr,'c') else if scalkind = declared then write(prr,'i') else write(prr,'r'); subrange: gentypindicator(rangetype); pointer: write(prr,'a'); power: write(prr,'s'); records,arrays: write(prr,'m'); files,tagfld,variant: error(500) end end (*typindicator*); procedure gen0t(fop: oprange; fsp: stp); begin if prcode then begin putic; write(prr,mn[fop]:4); gentypindicator(fsp); writeln(prr); end; ic := ic + 1; mes(fop) end (*gen0t*); procedure gen1t(fop: oprange; fp2: integer; fsp: stp); begin if prcode then begin putic; write(prr,mn[fop]:4); gentypindicator(fsp); writeln(prr,fp2:11) end; ic := ic + 1; mes(fop) end (*gen1t*); procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp); begin if prcode then begin putic; write(prr,mn[fop]: 4); gentypindicator(fsp); (* needed to increase the range of digits here. [sam] *) writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:11(*8*)); end; ic := ic + 1; mes(fop) end (*gen2t*); procedure load; begin with gattr do if typtr <> nil then begin case kind of cst: if (typtr^.form = scalar) and (typtr <> realptr) then if typtr = boolptr then gen2(51(*ldc*),3,cval.ival) else if typtr=charptr then gen2(51(*ldc*),6,cval.ival) else gen2(51(*ldc*),1,cval.ival) else if typtr = nilptr then gen2(51(*ldc*),4,0) else if cstptrix >= cstoccmax then error(254) else begin cstptrix := cstptrix + 1; cstptr[cstptrix] := cval.valp; if typtr = realptr then gen2(51(*ldc*),2,cstptrix) else gen2(51(*ldc*),5,cstptrix) end; varbl: case access of drct: if vlevel<=1 then gen1t(39(*ldo*),dplmt,typtr) else gen2t(54(*lod*),level-vlevel,dplmt,typtr); indrct: gen1t(35(*ind*),idplmt,typtr); inxd: error(400) end; expr: end; kind := expr end end (*load*) ; procedure store(var fattr: attr); begin with fattr do if typtr <> nil then case access of drct: if vlevel <= 1 then gen1t(43(*sro*),dplmt,typtr) else gen2t(56(*str*),level-vlevel,dplmt,typtr); indrct: if idplmt <> 0 then error(400) else gen0t(26(*sto*),typtr); inxd: error(400) end end (*store*) ; procedure loadaddress; begin with gattr do if typtr <> nil then begin case kind of cst: if string(typtr) then if cstptrix >= cstoccmax then error(254) else begin cstptrix := cstptrix + 1; cstptr[cstptrix] := cval.valp; gen1(38(*lca*),cstptrix) end else error(400); varbl: case access of drct: if vlevel <= 1 then gen1(37(*lao*),dplmt) else gen2(50(*lda*),level-vlevel,dplmt); indrct: if idplmt <> 0 then gen1t(34(*inc*),idplmt,nilptr); inxd: error(400) end; expr: error(400) end; kind := varbl; access := indrct; idplmt := 0 end end (*loadaddress*) ; procedure genfjp(faddr: integer); begin load; if gattr.typtr <> nil then if gattr.typtr <> boolptr then error(144); if prcode then begin putic; writeln(prr,mn[33]:4,' l':8,faddr:4) end; ic := ic + 1; mes(33) end (*genfjp*) ; procedure genujpxjp(fop: oprange; fp2: integer); begin if prcode then begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end; ic := ic + 1; mes(fop) end (*genujpxjp*); procedure gencupent(fop: oprange; fp1,fp2: integer); begin if prcode then begin putic; writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4) end; ic := ic + 1; mes(fop) end; procedure checkbnds(fsp: stp); var lmin,lmax: integer; begin if fsp <> nil then if fsp <> intptr then if fsp <> realptr then if fsp^.form <= subrange then begin getbounds(fsp,lmin,lmax); gen2t(45(*chk*),lmin,lmax,fsp) end end (*checkbnds*); procedure putlabel(labname: integer); begin if prcode then writeln(prr, 'l', labname:4) end (*putlabel*); procedure statement(fsys: setofsys); label 1; var lcp: ctp; llp: lbp; procedure expression(fsys: setofsys); forward; procedure selector(fsys: setofsys; fcp: ctp); var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer; begin with fcp^, gattr do begin typtr := idtype; kind := varbl; case klass of vars: if vkind = actual then begin access := drct; vlevel := vlev; dplmt := vaddr end else begin gen2t(54(*lod*),level-vlev,vaddr,nilptr); access := indrct; idplmt := 0 end; field: with display[disx] do if occur = crec then begin access := drct; vlevel := clev; dplmt := cdspl + fldaddr end else begin if level = 1 then gen1t(39(*ldo*),vdspl,nilptr) else gen2t(54(*lod*),0,vdspl,nilptr); access := indrct; idplmt := fldaddr end; func: if pfdeckind = standard then begin error(150); typtr := nil end else begin if pfkind = formal then error(151) else if (pflev+1<>level)or(fprocp<>fcp) then error(177); begin access := drct; vlevel := pflev + 1; dplmt := 0 (*impl. relat. addr. of fct. result*) end end end (*case*) end (*with*); if not (sy in selectsys + fsys) then begin error(59); skip(selectsys + fsys) end; while sy in selectsys do begin (*[*) if sy = lbrack then begin repeat lattr := gattr; with lattr do if typtr <> nil then if typtr^.form <> arrays then begin error(138); typtr := nil end; loadaddress; insymbol; expression(fsys + [comma,rbrack]); load; if gattr.typtr <> nil then if gattr.typtr^.form<>scalar then error(113) else if not comptypes(gattr.typtr,intptr) then gen0t(58(*ord*),gattr.typtr); if lattr.typtr <> nil then with lattr.typtr^ do begin if comptypes(inxtype,gattr.typtr) then begin if inxtype <> nil then begin getbounds(inxtype,lmin,lmax); if debug then gen2t(45(*chk*),lmin,lmax,intptr); if lmin>0 then gen1t(31(*dec*),lmin,intptr) else if lmin<0 then gen1t(34(*inc*),-lmin,intptr); (*or simply gen1(31,lmin)*) end end else error(139); with gattr do begin typtr := aeltype; kind := varbl; access := indrct; idplmt := 0 end; if gattr.typtr <> nil then begin lsize := gattr.typtr^.size; align(gattr.typtr,lsize); gen1(36(*ixa*),lsize) end end until sy <> comma; if sy = rbrack then insymbol else error(12) end (*if sy = lbrack*) else (*.*) if sy = period then begin with gattr do begin if typtr <> nil then if typtr^.form <> records then begin error(140); typtr := nil end; insymbol; if sy = ident then begin if typtr <> nil then begin searchsection(typtr^.fstfld,lcp); if lcp = nil then begin error(152); typtr := nil end else with lcp^ do begin typtr := idtype; case access of drct: dplmt := dplmt + fldaddr; indrct: idplmt := idplmt + fldaddr; inxd: error(400) end end end; insymbol end (*sy = ident*) else error(2) end (*with gattr*) end (*if sy = period*) else (*^*) begin if gattr.typtr <> nil then with gattr,typtr^ do if form = pointer then begin load; typtr := eltype; if debug then gen2t(45(*chk*),1,maxaddr,nilptr); with gattr do begin kind := varbl; access := indrct; idplmt := 0 end end else if form = files then typtr := filtype else error(141); insymbol end; if not (sy in fsys + selectsys) then begin error(6); skip(fsys + selectsys) end end (*while*) end (*selector*) ; procedure call(fsys: setofsys; fcp: ctp); var lkey: 1..15; procedure variable(fsys: setofsys); var lcp: ctp; begin if sy = ident then begin searchid([vars,field],lcp); insymbol end else begin error(2); lcp := uvarptr end; selector(fsys,lcp) end (*variable*) ; procedure getputresetrewrite; begin variable(fsys + [rparent]); loadaddress; if gattr.typtr <> nil then if gattr.typtr^.form <> files then error(116); if lkey <= 2 then gen1(30(*csp*),lkey(*get,put*)) else error(399) end (*getputresetrewrite*) ; procedure read; var llev:levrange; laddr:addrrange; lsp : stp; begin llev := 1; laddr := lcaftermarkstack; if sy = lparent then begin insymbol; variable(fsys + [comma,rparent]); lsp := gattr.typtr; test := false; if lsp <> nil then if lsp^.form = files then with gattr, lsp^ do begin if filtype = charptr then begin llev := vlevel; laddr := dplmt end else error(399); if sy = rparent then begin if lkey = 5 then error(116); test := true end else if sy <> comma then begin error(116); skip(fsys + [comma,rparent]) end; if sy = comma then begin insymbol; variable(fsys + [comma,rparent]) end else test := true end; if not test then repeat loadaddress; gen2(50(*lda*),level-llev,laddr); if gattr.typtr <> nil then if gattr.typtr^.form <= subrange then if comptypes(intptr,gattr.typtr) then gen1(30(*csp*),3(*rdi*)) else if comptypes(realptr,gattr.typtr) then gen1(30(*csp*),4(*rdr*)) else if comptypes(charptr,gattr.typtr) then gen1(30(*csp*),5(*rdc*)) else error(399) else error(116); test := sy <> comma; if not test then begin insymbol; variable(fsys + [comma,rparent]) end until test; if sy = rparent then insymbol else error(4) end else if lkey = 5 then error(116); if lkey = 11 then begin gen2(50(*lda*),level-llev,laddr); gen1(30(*csp*),21(*rln*)) end end (*read*) ; procedure write; var lsp: stp; default : boolean; llkey: 1..15; llev:levrange; laddr,len:addrrange; begin llkey := lkey; llev := 1; laddr := lcaftermarkstack + charmax; if sy = lparent then begin insymbol; expression(fsys + [comma,colon,rparent]); lsp := gattr.typtr; test := false; if lsp <> nil then if lsp^.form = files then with gattr, lsp^ do begin if filtype = charptr then begin llev := vlevel; laddr := dplmt end else error(399); if sy = rparent then begin if llkey = 6 then error(116); test := true end else if sy <> comma then begin error(116); skip(fsys+[comma,rparent]) end; if sy = comma then begin insymbol; expression(fsys+[comma,colon,rparent]) end else test := true end; if not test then repeat lsp := gattr.typtr; if lsp <> nil then if lsp^.form <= subrange then load else loadaddress; if sy = colon then begin insymbol; expression(fsys + [comma,colon,rparent]); if gattr.typtr <> nil then if gattr.typtr <> intptr then error(116); load; default := false end else default := true; if sy = colon then begin insymbol; expression(fsys + [comma,rparent]); if gattr.typtr <> nil then if gattr.typtr <> intptr then error(116); if lsp <> realptr then error(124); load; error(399); end else if lsp = intptr then begin if default then gen2(51(*ldc*),1,10); gen2(50(*lda*),level-llev,laddr); gen1(30(*csp*),6(*wri*)) end else if lsp = realptr then begin if default then gen2(51(*ldc*),1,20); gen2(50(*lda*),level-llev,laddr); gen1(30(*csp*),8(*wrr*)) end else if lsp = charptr then begin if default then gen2(51(*ldc*),1,1); gen2(50(*lda*),level-llev,laddr); gen1(30(*csp*),9(*wrc*)) end else if lsp <> nil then begin if lsp^.form = scalar then error(399) else if string(lsp) then begin len := lsp^.size div charmax; if default then gen2(51(*ldc*),1,len); gen2(51(*ldc*),1,len); gen2(50(*lda*),level-llev,laddr); gen1(30(*csp*),10(*wrs*)) end else error(116) end; test := sy <> comma; if not test then begin insymbol; expression(fsys + [comma,colon,rparent]) end until test; if sy = rparent then insymbol else error(4) end else if lkey = 6 then error(116); if llkey = 12 then (*writeln*) begin gen2(50(*lda*),level-llev,laddr); gen1(30(*csp*),22(*wln*)) end end (*write*) ; procedure pack; var lsp,lsp1: stp; begin error(399); variable(fsys + [comma,rparent]); lsp := nil; lsp1 := nil; if gattr.typtr <> nil then with gattr.typtr^ do if form = arrays then begin lsp := inxtype; lsp1 := aeltype end else error(116); if sy = comma then insymbol else error(20); expression(fsys + [comma,rparent]); if gattr.typtr <> nil then if gattr.typtr^.form <> scalar then error(116) else if not comptypes(lsp,gattr.typtr) then error(116); if sy = comma then insymbol else error(20); variable(fsys + [rparent]); if gattr.typtr <> nil then with gattr.typtr^ do if form = arrays then begin if not comptypes(aeltype,lsp1) or not comptypes(inxtype,lsp) then error(116) end else error(116) end (*pack*) ; procedure unpack; var lsp,lsp1: stp; begin error(399); variable(fsys + [comma,rparent]); lsp := nil; lsp1 := nil; if gattr.typtr <> nil then with gattr.typtr^ do if form = arrays then begin lsp := inxtype; lsp1 := aeltype end else error(116); if sy = comma then insymbol else error(20); variable(fsys + [comma,rparent]); if gattr.typtr <> nil then with gattr.typtr^ do if form = arrays then begin if not comptypes(aeltype,lsp1) or not comptypes(inxtype,lsp) then error(116) end else error(116); if sy = comma then insymbol else error(20); expression(fsys + [rparent]); if gattr.typtr <> nil then if gattr.typtr^.form <> scalar then error(116) else if not comptypes(lsp,gattr.typtr) then error(116); end (*unpack*) ; procedure new; label 1; var lsp,lsp1: stp; varts: integer; lsize: addrrange; lval: valu; begin variable(fsys + [comma,rparent]); loadaddress; lsp := nil; varts := 0; lsize := 0; if gattr.typtr <> nil then with gattr.typtr^ do if form = pointer then begin if eltype <> nil then begin lsize := eltype^.size; if eltype^.form = records then lsp := eltype^.recvar end end else error(116); while sy = comma do begin insymbol;constant(fsys + [comma,rparent],lsp1,lval); varts := varts + 1; (*check to insert here: is constant in tagfieldtype range*) if lsp = nil then error(158) else if lsp^.form <> tagfld then error(162) else if lsp^.tagfieldp <> nil then if string(lsp1) or (lsp1 = realptr) then error(159) else if comptypes(lsp^.tagfieldp^.idtype,lsp1) then begin lsp1 := lsp^.fstvar; while lsp1 <> nil do with lsp1^ do if varval.ival = lval.ival then begin lsize := size; lsp := subvar; goto 1 end else lsp1 := nxtvar; lsize := lsp^.size; lsp := nil; end else error(116); 1: end (*while*) ; gen2(51(*ldc*),1,lsize); gen1(30(*csp*),12(*new*)); end (*new*) ; procedure mark; begin variable(fsys+[rparent]); if gattr.typtr <> nil then if gattr.typtr^.form = pointer then begin loadaddress; gen1(30(*csp*),23(*sav*)) end else error(116) end(*mark*); procedure release; begin variable(fsys+[rparent]); if gattr.typtr <> nil then if gattr.typtr^.form = pointer then begin load; gen1(30(*csp*),13(*rst*)) end else error(116) end (*release*); procedure abs; begin if gattr.typtr <> nil then if gattr.typtr = intptr then gen0(0(*abi*)) else if gattr.typtr = realptr then gen0(1(*abr*)) else begin error(125); gattr.typtr := intptr end end (*abs*) ; procedure sqr; begin if gattr.typtr <> nil then if gattr.typtr = intptr then gen0(24(*sqi*)) else if gattr.typtr = realptr then gen0(25(*sqr*)) else begin error(125); gattr.typtr := intptr end end (*sqr*) ; procedure trunc; begin if gattr.typtr <> nil then if gattr.typtr <> realptr then error(125); gen0(27(*trc*)); gattr.typtr := intptr end (*trunc*) ; procedure odd; begin if gattr.typtr <> nil then if gattr.typtr <> intptr then error(125); gen0(20(*odd*)); gattr.typtr := boolptr end (*odd*) ; procedure ord; begin if gattr.typtr <> nil then if gattr.typtr^.form >= power then error(125); gen0t(58(*ord*),gattr.typtr); gattr.typtr := intptr end (*ord*) ; procedure chr; begin if gattr.typtr <> nil then if gattr.typtr <> intptr then error(125); gen0(59(*chr*)); gattr.typtr := charptr end (*chr*) ; procedure predsucc; begin if gattr.typtr <> nil then if gattr.typtr^.form <> scalar then error(125); if lkey = 7 then gen1t(31(*dec*),1,gattr.typtr) else gen1t(34(*inc*),1,gattr.typtr) end (*predsucc*) ; procedure eof; begin if sy = lparent then begin insymbol; variable(fsys + [rparent]); if sy = rparent then insymbol else error(4) end else with gattr do begin typtr := textptr; kind := varbl; access := drct; vlevel := 1; dplmt := lcaftermarkstack end; loadaddress; if gattr.typtr <> nil then if gattr.typtr^.form <> files then error(125); if lkey = 9 then gen0(8(*eof*)) else gen1(30(*csp*),14(*eln*)); gattr.typtr := boolptr end (*eof*) ; procedure callnonstandard; var nxt,lcp: ctp; lsp: stp; lkind: idkind; lb: boolean; locpar, llc: addrrange; begin locpar := 0; with fcp^ do begin nxt := next; lkind := pfkind; if not externl then gen1(41(*mst*),level-pflev) end; if sy = lparent then begin llc := lc; repeat lb := false; (*decide whether proc/func must be passed*) if lkind = actual then begin if nxt = nil then error(126) else lb := nxt^.klass in [proc,func] end else error(399); (*For formal proc/func, lb is false and expression will be called, which will always interpret a proc/func id at its beginning as a call rather than a parameter passing. In this implementation, parameter procedures/functions are therefore not allowed to have procedure/function parameters*) insymbol; if lb then (*pass function or procedure*) begin error(399); if sy <> ident then begin error(2); skip(fsys + [comma,rparent]) end else begin if nxt^.klass = proc then searchid([proc],lcp) else begin searchid([func],lcp); if not comptypes(lcp^.idtype,nxt^.idtype) then error(128) end; insymbol; if not (sy in fsys + [comma,rparent]) then begin error(6); skip(fsys + [comma,rparent]) end end end (*if lb*) else begin expression(fsys + [comma,rparent]); if gattr.typtr <> nil then if lkind = actual then begin if nxt <> nil then begin lsp := nxt^.idtype; if lsp <> nil then begin if (nxt^.vkind = actual) then if lsp^.form <= power then begin load; if debug then checkbnds(lsp); if comptypes(realptr,lsp) and (gattr.typtr = intptr) then begin gen0(10(*flt*)); gattr.typtr := realptr end; locpar := locpar+lsp^.size; align(parmptr,locpar); end else begin loadaddress; locpar := locpar+ptrsize; align(parmptr,locpar) end else if gattr.kind = varbl then begin loadaddress; locpar := locpar+ptrsize; align(parmptr,locpar); end else error(154); if not comptypes(lsp,gattr.typtr) then error(142) end end end else (*lkind = formal*) begin (*pass formal param*) end end; if (lkind = actual) and (nxt <> nil) then nxt := nxt^.next until sy <> comma; lc := llc; if sy = rparent then insymbol else error(4) end (*if lparent*); if lkind = actual then begin if nxt <> nil then error(126); with fcp^ do begin if externl then gen1(30(*csp*),pfname) else gencupent(46(*cup*),locpar,pfname); end end; gattr.typtr := fcp^.idtype end (*callnonstandard*) ; begin (*call*) if fcp^.pfdeckind = standard then begin lkey := fcp^.key; if fcp^.klass = proc then begin if not(lkey in [5,6,11,12]) then if sy = lparent then insymbol else error(9); case lkey of 1,2, 3,4: getputresetrewrite; 5,11: read; 6,12: write; 7: pack; 8: unpack; 9: new; 10: release; 13: mark end; if not(lkey in [5,6,11,12]) then if sy = rparent then insymbol else error(4) end else begin if lkey <= 8 then begin if sy = lparent then insymbol else error(9); expression(fsys+[rparent]); load end; case lkey of 1: abs; 2: sqr; 3: trunc; 4: odd; 5: ord; 6: chr; 7,8: predsucc; 9,10: eof end; if lkey <= 8 then if sy = rparent then insymbol else error(4) end; end (*standard procedures and functions*) else callnonstandard end (*call*) ; procedure expression; var lattr: attr; lop: operator; typind: char; lsize: addrrange; procedure simpleexpression(fsys: setofsys); var lattr: attr; lop: operator; signed: boolean; procedure term(fsys: setofsys); var lattr: attr; lop: operator; procedure factor(fsys: setofsys); var lcp: ctp; lvp: csp; varpart: boolean; cstpart: setty; lsp: stp; begin if not (sy in facbegsys) then begin error(58); skip(fsys + facbegsys); gattr.typtr := nil end; while sy in facbegsys do begin case sy of (*id*) ident: begin searchid([konst,vars,field,func],lcp); insymbol; if lcp^.klass = func then begin call(fsys,lcp); with gattr do begin kind := expr; if typtr <> nil then if typtr^.form=subrange then typtr := typtr^.rangetype end end else if lcp^.klass = konst then with gattr, lcp^ do begin typtr := idtype; kind := cst; cval := values end else begin selector(fsys,lcp); if gattr.typtr<>nil then(*elim.subr.types to*) with gattr,typtr^ do(*simplify later tests*) if form = subrange then typtr := rangetype end end; (*cst*) intconst: begin with gattr do begin typtr := intptr; kind := cst; cval := val end; insymbol end; realconst: begin with gattr do begin typtr := realptr; kind := cst; cval := val end; insymbol end; stringconst: begin with gattr do begin if lgth = 1 then typtr := charptr else begin new(lsp,arrays); with lsp^ do begin aeltype := charptr; form:=arrays; inxtype := nil; size := lgth*charsize end; typtr := lsp end; kind := cst; cval := val end; insymbol end; (* ( *) lparent: begin insymbol; expression(fsys + [rparent]); if sy = rparent then insymbol else error(4) end; (*not*) notsy: begin insymbol; factor(fsys); load; gen0(19(*not*)); if gattr.typtr <> nil then if gattr.typtr <> boolptr then begin error(135); gattr.typtr := nil end; end; (*[*) lbrack: begin insymbol; cstpart := [ ]; varpart := false; new(lsp,power); with lsp^ do begin elset:=nil;size:=setsize;form:=power end; if sy = rbrack then begin with gattr do begin typtr := lsp; kind := cst end; insymbol end else begin repeat expression(fsys + [comma,rbrack]); if gattr.typtr <> nil then if gattr.typtr^.form <> scalar then begin error(136); gattr.typtr := nil end else if comptypes(lsp^.elset,gattr.typtr) then begin if gattr.kind = cst then if (gattr.cval.ival < setlow) or (gattr.cval.ival > sethigh) then error(304) else cstpart := cstpart+[gattr.cval.ival] else begin load; if not comptypes(gattr.typtr,intptr) then gen0t(58(*ord*),gattr.typtr); gen0(23(*sgs*)); if varpart then gen0(28(*uni*)) else varpart := true end; lsp^.elset := gattr.typtr; gattr.typtr := lsp end else error(137); test := sy <> comma; if not test then insymbol until test; if sy = rbrack then insymbol else error(12) end; if varpart then begin if cstpart <> [ ] then begin new(lvp,pset); lvp^.pval := cstpart; lvp^.cclass := pset; if cstptrix = cstoccmax then error(254) else begin cstptrix := cstptrix + 1; cstptr[cstptrix] := lvp; gen2(51(*ldc*),5,cstptrix); gen0(28(*uni*)); gattr.kind := expr end end end else begin new(lvp,pset); lvp^.pval := cstpart; lvp^.cclass := pset; gattr.cval.valp := lvp end end end (*case*) ; if not (sy in fsys) then begin error(6); skip(fsys + facbegsys) end end (*while*) end (*factor*) ; begin (*term*) factor(fsys + [mulop]); while sy = mulop do begin load; lattr := gattr; lop := op; insymbol; factor(fsys + [mulop]); load; if (lattr.typtr <> nil) and (gattr.typtr <> nil) then case lop of (***) mul: if (lattr.typtr=intptr)and(gattr.typtr=intptr) then gen0(15(*mpi*)) else begin if lattr.typtr = intptr then begin gen0(9(*flo*)); lattr.typtr := realptr end else if gattr.typtr = intptr then begin gen0(10(*flt*)); gattr.typtr := realptr end; if (lattr.typtr = realptr) and(gattr.typtr=realptr)then gen0(16(*mpr*)) else if(lattr.typtr^.form=power) and comptypes(lattr.typtr,gattr.typtr)then gen0(12(*int*)) else begin error(134); gattr.typtr:=nil end end; (* / *) rdiv: begin if gattr.typtr = intptr then begin gen0(10(*flt*)); gattr.typtr := realptr end; if lattr.typtr = intptr then begin gen0(9(*flo*)); lattr.typtr := realptr end; if (lattr.typtr = realptr) and (gattr.typtr=realptr)then gen0(7(*dvr*)) else begin error(134); gattr.typtr := nil end end; (*div*) idiv: if (lattr.typtr = intptr) and (gattr.typtr = intptr) then gen0(6(*dvi*)) else begin error(134); gattr.typtr := nil end; (*mod*) imod: if (lattr.typtr = intptr) and (gattr.typtr = intptr) then gen0(14(*mod*)) else begin error(134); gattr.typtr := nil end; (*and*) andop:if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then gen0(4(*and*)) else begin error(134); gattr.typtr := nil end end (*case*) else gattr.typtr := nil end (*while*) end (*term*) ; begin (*simpleexpression*) signed := false; if (sy = addop) and (op in [plus,minus]) then begin signed := op = minus; insymbol end; term(fsys + [addop]); if signed then begin load; if gattr.typtr = intptr then gen0(17(*ngi*)) else if gattr.typtr = realptr then gen0(18(*ngr*)) else begin error(134); gattr.typtr := nil end end; while sy = addop do begin load; lattr := gattr; lop := op; insymbol; term(fsys + [addop]); load; if (lattr.typtr <> nil) and (gattr.typtr <> nil) then case lop of (*+*) plus: if (lattr.typtr = intptr)and(gattr.typtr = intptr) then gen0(2(*adi*)) else begin if lattr.typtr = intptr then begin gen0(9(*flo*)); lattr.typtr := realptr end else if gattr.typtr = intptr then begin gen0(10(*flt*)); gattr.typtr := realptr end; if (lattr.typtr = realptr)and(gattr.typtr = realptr) then gen0(3(*adr*)) else if(lattr.typtr^.form=power) and comptypes(lattr.typtr,gattr.typtr) then gen0(28(*uni*)) else begin error(134); gattr.typtr:=nil end end; (*-*) minus: if (lattr.typtr = intptr)and(gattr.typtr = intptr) then gen0(21(*sbi*)) else begin if lattr.typtr = intptr then begin gen0(9(*flo*)); lattr.typtr := realptr end else if gattr.typtr = intptr then begin gen0(10(*flt*)); gattr.typtr := realptr end; if (lattr.typtr = realptr)and(gattr.typtr = realptr) then gen0(22(*sbr*)) else if (lattr.typtr^.form = power) and comptypes(lattr.typtr,gattr.typtr) then gen0(5(*dif*)) else begin error(134); gattr.typtr := nil end end; (*or*) orop: if(lattr.typtr=boolptr)and(gattr.typtr=boolptr)then gen0(13(*ior*)) else begin error(134); gattr.typtr := nil end end (*case*) else gattr.typtr := nil end (*while*) end (*simpleexpression*) ; begin (*expression*) simpleexpression(fsys + [relop]); if sy = relop then begin if gattr.typtr <> nil then if gattr.typtr^.form <= power then load else loadaddress; lattr := gattr; lop := op; if lop = inop then if not comptypes(gattr.typtr,intptr) then gen0t(58(*ord*),gattr.typtr); insymbol; simpleexpression(fsys); if gattr.typtr <> nil then if gattr.typtr^.form <= power then load else loadaddress; if (lattr.typtr <> nil) and (gattr.typtr <> nil) then if lop = inop then if gattr.typtr^.form = power then if comptypes(lattr.typtr,gattr.typtr^.elset) then gen0(11(*inn*)) else begin error(129); gattr.typtr := nil end else begin error(130); gatt