(*$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); gattr.typtr := nil end else begin if lattr.typtr <> gattr.typtr then 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 comptypes(lattr.typtr,gattr.typtr) then begin lsize := lattr.typtr^.size; case lattr.typtr^.form of scalar: if lattr.typtr = realptr then typind := 'r' else if lattr.typtr = boolptr then typind := 'b' else if lattr.typtr = charptr then typind := 'c' else typind := 'i'; pointer: begin if lop in [ltop,leop,gtop,geop] then error(131); typind := 'a' end; power: begin if lop in [ltop,gtop] then error(132); typind := 's' end; arrays: begin if not string(lattr.typtr) then error(134); typind := 'm' end; records: begin error(134); typind := 'm' end; files: begin error(133); typind := 'f' end end; case lop of ltop: gen2(53(*les*),ord(typind),lsize); leop: gen2(52(*leq*),ord(typind),lsize); gtop: gen2(49(*grt*),ord(typind),lsize); geop: gen2(48(*geq*),ord(typind),lsize); neop: gen2(55(*neq*),ord(typind),lsize); eqop: gen2(47(*equ*),ord(typind),lsize) end end else error(129) end; gattr.typtr := boolptr; gattr.kind := expr end (*sy = relop*) end (*expression*) ; procedure assignment(fcp: ctp); var lattr: attr; begin selector(fsys + [becomes],fcp); if sy = becomes then begin if gattr.typtr <> nil then if (gattr.access<>drct) or (gattr.typtr^.form>power) then loadaddress; lattr := gattr; insymbol; expression(fsys); if gattr.typtr <> nil then if gattr.typtr^.form <= power then load else loadaddress; if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then begin gen0(10(*flt*)); gattr.typtr := realptr end; if comptypes(lattr.typtr,gattr.typtr) then case lattr.typtr^.form of scalar, subrange: begin if debug then checkbnds(lattr.typtr); store(lattr) end; pointer: begin if debug then gen2t(45(*chk*),0,maxaddr,nilptr); store(lattr) end; power: store(lattr); arrays, records: gen1(40(*mov*),lattr.typtr^.size); files: error(146) end else error(129) end end (*sy = becomes*) else error(51) end (*assignment*) ; procedure gotostatement; var llp: lbp; found: boolean; ttop,ttop1: disprange; begin if sy = intconst then begin found := false; ttop := top; while display[ttop].occur <> blck do ttop := ttop - 1; ttop1 := ttop; repeat llp := display[ttop].flabel; while (llp <> nil) and not found do with llp^ do if labval = val.ival then begin found := true; if ttop = ttop1 then genujpxjp(57(*ujp*),labname) else (*goto leads out of procedure*) error(399) end else llp := nextlab; ttop := ttop - 1 until found or (ttop = 0); if not found then error(167); insymbol end else error(15) end (*gotostatement*) ; procedure compoundstatement; begin repeat repeat statement(fsys + [semicolon,endsy]) until not (sy in statbegsys); test := sy <> semicolon; if not test then insymbol until test; if sy = endsy then insymbol else error(13) end (*compoundstatemenet*) ; procedure ifstatement; var lcix1,lcix2: integer; begin expression(fsys + [thensy]); genlabel(lcix1); genfjp(lcix1); if sy = thensy then insymbol else error(52); statement(fsys + [elsesy]); if sy = elsesy then begin genlabel(lcix2); genujpxjp(57(*ujp*),lcix2); putlabel(lcix1); insymbol; statement(fsys); putlabel(lcix2) end else putlabel(lcix1) end (*ifstatement*) ; procedure casestatement; label 1; type cip = ^caseinfo; caseinfo = packed record next: cip; csstart: integer; cslab: integer end; var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu; laddr, lcix, lcix1, lmin, lmax: integer; begin expression(fsys + [ofsy,comma,colon]); load; genlabel(lcix); lsp := gattr.typtr; if lsp <> nil then if (lsp^.form <> scalar) or (lsp = realptr) then begin error(144); lsp := nil end else if not comptypes(lsp,intptr) then gen0t(58(*ord*),lsp); genujpxjp(57(*ujp*),lcix); if sy = ofsy then insymbol else error(8); fstptr := nil; genlabel(laddr); repeat lpt3 := nil; genlabel(lcix1); if not(sy in [semicolon,endsy]) then begin repeat constant(fsys + [comma,colon],lsp1,lval); if lsp <> nil then if comptypes(lsp,lsp1) then begin lpt1 := fstptr; lpt2 := nil; while lpt1 <> nil do with lpt1^ do begin if cslab <= lval.ival then begin if cslab = lval.ival then error(156); goto 1 end; lpt2 := lpt1; lpt1 := next end; 1: new(lpt3); with lpt3^ do begin next := lpt1; cslab := lval.ival; csstart := lcix1 end; if lpt2 = nil then fstptr := lpt3 else lpt2^.next := lpt3 end else error(147); test := sy <> comma; if not test then insymbol until test; if sy = colon then insymbol else error(5); putlabel(lcix1); repeat statement(fsys + [semicolon]) until not (sy in statbegsys); if lpt3 <> nil then genujpxjp(57(*ujp*),laddr); end; test := sy <> semicolon; if not test then insymbol until test; putlabel(lcix); if fstptr <> nil then begin lmax := fstptr^.cslab; (*reverse pointers*) lpt1 := fstptr; fstptr := nil; repeat lpt2 := lpt1^.next; lpt1^.next := fstptr; fstptr := lpt1; lpt1 := lpt2 until lpt1 = nil; lmin := fstptr^.cslab; if lmax - lmin < cixmax then begin gen2t(45(*chk*),lmin,lmax,intptr); gen2(51(*ldc*),1,lmin); gen0(21(*sbi*)); genlabel(lcix); genujpxjp(44(*xjp*),lcix); putlabel(lcix); repeat with fstptr^ do begin while cslab > lmin do begin gen0(60(*ujc error*)); lmin := lmin+1 end; genujpxjp(57(*ujp*),csstart); fstptr := next; lmin := lmin + 1 end until fstptr = nil; putlabel(laddr) end else error(157) end; if sy = endsy then insymbol else error(13) end (*casestatement*) ; procedure repeatstatement; var laddr: integer; begin genlabel(laddr); putlabel(laddr); repeat statement(fsys + [semicolon,untilsy]); if sy in statbegsys then error(14) until not(sy in statbegsys); while sy = semicolon do begin insymbol; repeat statement(fsys + [semicolon,untilsy]); if sy in statbegsys then error(14) until not (sy in statbegsys); end; if sy = untilsy then begin insymbol; expression(fsys); genfjp(laddr) end else error(53) end (*repeatstatement*) ; procedure whilestatement; var laddr, lcix: integer; begin genlabel(laddr); putlabel(laddr); expression(fsys + [dosy]); genlabel(lcix); genfjp(lcix); if sy = dosy then insymbol else error(54); statement(fsys); genujpxjp(57(*ujp*),laddr); putlabel(lcix) end (*whilestatement*) ; procedure forstatement; var lattr: attr; lsy: symbol; lcix, laddr: integer; llc: addrrange; typind: char; (* added for typing [sam] *) begin llc := lc; with lattr do begin typtr := nil; kind := varbl; access := drct; vlevel := level; dplmt := 0 end; typind := 'i'; (* default to integer [sam] *) if sy = ident then begin searchid([vars],lcp); with lcp^, lattr do begin typtr := idtype; kind := varbl; if vkind = actual then begin access := drct; vlevel := vlev; dplmt := vaddr end else begin error(155); typtr := nil end end; (* determine type of control variable [sam] *) if lattr.typtr = boolptr then typind := 'b' else if lattr.typtr = charptr then typind := 'c'; if lattr.typtr <> nil then if (lattr.typtr^.form > subrange) or comptypes(realptr,lattr.typtr) then begin error(143); lattr.typtr := nil end; insymbol end else begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end; if sy = becomes then begin insymbol; expression(fsys + [tosy,downtosy,dosy]); if gattr.typtr <> nil then if gattr.typtr^.form <> scalar then error(144) else if comptypes(lattr.typtr,gattr.typtr) then begin load; store(lattr) end else error(145) end else begin error(51); skip(fsys + [tosy,downtosy,dosy]) end; if sy in [tosy,downtosy] then begin lsy := sy; insymbol; expression(fsys + [dosy]); if gattr.typtr <> nil then if gattr.typtr^.form <> scalar then error(144) else if comptypes(lattr.typtr,gattr.typtr) then begin load; if not comptypes(lattr.typtr,intptr) then gen0t(58(*ord*),gattr.typtr); align(intptr,lc); gen2t(56(*str*),0,lc,intptr); genlabel(laddr); putlabel(laddr); gattr := lattr; load; if not comptypes(gattr.typtr,intptr) then gen0t(58(*ord*),gattr.typtr); gen2t(54(*lod*),0,lc,intptr); lc := lc + intsize; if lc > lcmax then lcmax := lc; if lsy = tosy then gen2(52(*leq*),ord(typind),1) else gen2(48(*geq*),ord(typind),1); end else error(145) end else begin error(55); skip(fsys + [dosy]) end; genlabel(lcix); genujpxjp(33(*fjp*),lcix); if sy = dosy then insymbol else error(54); statement(fsys); gattr := lattr; load; if lsy=tosy then gen1t(34(*inc*),1,gattr.typtr) else gen1t(31(*dec*),1,gattr.typtr); store(lattr); genujpxjp(57(*ujp*),laddr); putlabel(lcix); lc := llc; end (*forstatement*) ; procedure withstatement; var lcp: ctp; lcnt1: disprange; llc: addrrange; begin lcnt1 := 0; llc := lc; repeat if sy = ident then begin searchid([vars,field],lcp); insymbol end else begin error(2); lcp := uvarptr end; selector(fsys + [comma,dosy],lcp); if gattr.typtr <> nil then if gattr.typtr^.form = records then if top < displimit then begin top := top + 1; lcnt1 := lcnt1 + 1; with display[top] do begin fname := gattr.typtr^.fstfld; flabel := nil end; if gattr.access = drct then with display[top] do begin occur := crec; clev := gattr.vlevel; cdspl := gattr.dplmt end else begin loadaddress; align(nilptr,lc); gen2t(56(*str*),0,lc,nilptr); with display[top] do begin occur := vrec; vdspl := lc end; lc := lc+ptrsize; if lc > lcmax then lcmax := lc end end else error(250) else error(140); test := sy <> comma; if not test then insymbol until test; if sy = dosy then insymbol else error(54); statement(fsys); top := top-lcnt1; lc := llc; end (*withstatement*) ; begin (*statement*) if sy = intconst then (*label*) begin llp := display[level].flabel; while llp <> nil do with llp^ do if labval = val.ival then begin if defined then error(165); putlabel(labname); defined := true; goto 1 end else llp := nextlab; error(167); 1: insymbol; if sy = colon then insymbol else error(5) end; if not (sy in fsys + [ident]) then begin error(6); skip(fsys) end; if sy in statbegsys + [ident] then begin case sy of ident: begin searchid([vars,field,func,proc],lcp); insymbol; if lcp^.klass = proc then call(fsys,lcp) else assignment(lcp) end; beginsy: begin insymbol; compoundstatement end; gotosy: begin insymbol; gotostatement end; ifsy: begin insymbol; ifstatement end; casesy: begin insymbol; casestatement end; whilesy: begin insymbol; whilestatement end; repeatsy: begin insymbol; repeatstatement end; forsy: begin insymbol; forstatement end; withsy: begin insymbol; withstatement end end; if not (sy in [semicolon,endsy,elsesy,untilsy]) then begin error(6); skip(fsys) end end end (*statement*) ; begin (*body*) if fprocp <> nil then entname := fprocp^.pfname else genlabel(entname); cstptrix := 0; topnew := lcaftermarkstack; topmax := lcaftermarkstack; putlabel(entname); genlabel(segsize); genlabel(stacktop); gencupent(32(*ent1*),1,segsize); gencupent(32(*ent2*),2,stacktop); if fprocp <> nil then (*copy multiple values into local cells*) begin llc1 := lcaftermarkstack; lcp := fprocp^.next; while lcp <> nil do with lcp^ do begin align(parmptr,llc1); if klass = vars then if idtype <> nil then if idtype^.form > power then begin if vkind = actual then begin gen2(50(*lda*),0,vaddr); gen2t(54(*lod*),0,llc1,nilptr); gen1(40(*mov*),idtype^.size); end; llc1 := llc1 + ptrsize end else llc1 := llc1 + idtype^.size; lcp := lcp^.next; end; end; lcmax := lc; repeat repeat statement(fsys + [semicolon,endsy]) until not (sy in statbegsys); test := sy <> semicolon; if not test then insymbol until test; if sy = endsy then insymbol else error(13); llp := display[top].flabel; (*test for undefined labels*) while llp <> nil do with llp^ do begin if not defined then begin error(168); writeln(output); writeln(output,' label ',labval); write(output,' ':chcnt+16) end; llp := nextlab end; if fprocp <> nil then begin if fprocp^.idtype = nil then gen1(42(*ret*),ord('p')) else gen0t(42(*ret*),fprocp^.idtype); align(parmptr,lcmax); if prcode then begin writeln(prr,'l',segsize:4,'=',lcmax); writeln(prr,'l',stacktop:4,'=',topmax) end end else begin gen1(42(*ret*),ord('p')); align(parmptr,lcmax); if prcode then begin writeln(prr,'l',segsize:4,'=',lcmax); writeln(prr,'l',stacktop:4,'=',topmax); writeln(prr,'q') end; ic := 0; (*generate call of main program; note that this call must be loaded at absolute address zero*) gen1(41(*mst*),0); gencupent(46(*cup*),0,entname); gen0(29(*stp*)); if prcode then writeln(prr,'q'); saveid := id; while fextfilep <> nil do begin with fextfilep^ do if not ((filename = 'input ') or (filename = 'output ') or (filename = 'prd ') or (filename = 'prr ')) then begin id := filename; searchid([vars],llcp); if llcp^.idtype<>nil then if llcp^.idtype^.form<>files then begin writeln(output); writeln(output,' ':8,'undeclared ','external ', 'file',fextfilep^.filename:8); write(output,' ':chcnt+16) end end; fextfilep := fextfilep^.nextfile end; id := saveid; if prtables then begin writeln(output); printtables(true) end end; end (*body*) ; begin (*block*) dp := true; repeat if sy = labelsy then begin insymbol; labeldeclaration end; if sy = constsy then begin insymbol; constdeclaration end; if sy = typesy then begin insymbol; typedeclaration end; if sy = varsy then begin insymbol; vardeclaration end; while sy in [procsy,funcsy] do begin lsy := sy; insymbol; procdeclaration(lsy) end; if sy <> beginsy then begin error(18); skip(fsys) end until (sy in statbegsys) or eof(input); dp := false; if sy = beginsy then insymbol else error(17); repeat body(fsys + [casesy]); if sy <> fsy then begin error(6); skip(fsys) end until ((sy = fsy) or (sy in blockbegsys)) or eof(input); end (*block*) ; procedure programme(fsys:setofsys); var extfp:extfilep; begin if sy = progsy then begin insymbol; if sy <> ident then error(2); insymbol; if not (sy in [lparent,semicolon]) then error(14); if sy = lparent then begin repeat insymbol; if sy = ident then begin new(extfp); with extfp^ do begin filename := id; nextfile := fextfilep end; fextfilep := extfp; insymbol; if not ( sy in [comma,rparent] ) then error(20) end else error(2) until sy <> comma; if sy <> rparent then error(4); insymbol end; if sy <> semicolon then error(14) else insymbol; end; repeat block(fsys,period,nil); if sy <> period then error(21) until (sy = period) or eof(input); if list then writeln(output); if errinx <> 0 then begin list := false; endofline end end (*programme*) ; procedure stdnames; begin na[ 1] := 'false '; na[ 2] := 'true '; na[ 3] := 'input '; na[ 4] := 'output '; na[ 5] := 'get '; na[ 6] := 'put '; na[ 7] := 'reset '; na[ 8] := 'rewrite '; na[ 9] := 'read '; na[10] := 'write '; na[11] := 'pack '; na[12] := 'unpack '; na[13] := 'new '; na[14] := 'release '; na[15] := 'readln '; na[16] := 'writeln '; na[17] := 'abs '; na[18] := 'sqr '; na[19] := 'trunc '; na[20] := 'odd '; na[21] := 'ord '; na[22] := 'chr '; na[23] := 'pred '; na[24] := 'succ '; na[25] := 'eof '; na[26] := 'eoln '; na[27] := 'sin '; na[28] := 'cos '; na[29] := 'exp '; na[30] := 'sqrt '; na[31] := 'ln '; na[32] := 'arctan '; na[33] := 'prd '; na[34] := 'prr '; na[35] := 'mark '; end (*stdnames*) ; procedure enterstdtypes; begin (*type underlying:*) (******************) new(intptr,scalar,standard); (*integer*) with intptr^ do begin size := intsize; form := scalar; scalkind := standard end; new(realptr,scalar,standard); (*real*) with realptr^ do begin size := realsize; form := scalar; scalkind := standard end; new(charptr,scalar,standard); (*char*) with charptr^ do begin size := charsize; form := scalar; scalkind := standard end; new(boolptr,scalar,declared); (*boolean*) with boolptr^ do begin size := boolsize; form := scalar; scalkind := declared end; new(nilptr,pointer); (*nil*) with nilptr^ do begin eltype := nil; size := ptrsize; form := pointer end; new(parmptr,scalar,standard); (*for alignment of parameters*) with parmptr^ do begin size := parmsize; form := scalar; scalkind := standard end ; new(textptr,files); (*text*) with textptr^ do begin filtype := charptr; size := charsize; form := files end end (*enterstdtypes*) ; procedure entstdnames; var cp,cp1: ctp; i: integer; begin (*name:*) (*******) new(cp,types); (*integer*) with cp^ do begin name := 'integer '; idtype := intptr; klass := types end; enterid(cp); new(cp,types); (*real*) with cp^ do begin name := 'real '; idtype := realptr; klass := types end; enterid(cp); new(cp,types); (*char*) with cp^ do begin name := 'char '; idtype := charptr; klass := types end; enterid(cp); new(cp,types); (*boolean*) with cp^ do begin name := 'boolean '; idtype := boolptr; klass := types end; enterid(cp); cp1 := nil; for i := 1 to 2 do begin new(cp,konst); (*false,true*) with cp^ do begin name := na[i]; idtype := boolptr; next := cp1; values.ival := i - 1; klass := konst end; enterid(cp); cp1 := cp end; boolptr^.fconst := cp; new(cp,konst); (*nil*) with cp^ do begin name := 'nil '; idtype := nilptr; next := nil; values.ival := 0; klass := konst end; enterid(cp); for i := 3 to 4 do begin new(cp,vars); (*input,output*) with cp^ do begin name := na[i]; idtype := textptr; klass := vars; vkind := actual; next := nil; vlev := 1; vaddr := lcaftermarkstack+(i-3)*charmax; end; enterid(cp) end; for i:=33 to 34 do begin new(cp,vars); (*prd,prr files*) with cp^ do begin name := na[i]; idtype := textptr; klass := vars; vkind := actual; next := nil; vlev := 1; vaddr := lcaftermarkstack+(i-31)*charmax; end; enterid(cp) end; for i := 5 to 16 do begin new(cp,proc,standard); (*get,put,reset*) with cp^ do (*rewrite,read*) begin name := na[i]; idtype := nil; (*write,pack*) next := nil; key := i - 4; (*unpack,pack*) klass := proc; pfdeckind := standard end; enterid(cp) end; new(cp,proc,standard); with cp^ do begin name:=na[35]; idtype:=nil; next:= nil; key:=13; klass:=proc; pfdeckind:= standard end; enterid(cp); for i := 17 to 26 do begin new(cp,func,standard); (*abs,sqr,trunc*) with cp^ do (*odd,ord,chr*) begin name := na[i]; idtype := nil; (*pred,succ,eof*) next := nil; key := i - 16; klass := func; pfdeckind := standard end; enterid(cp) end; new(cp,vars); (*parameter of predeclared functions*) with cp^ do begin name := ' '; idtype := realptr; klass := vars; vkind := actual; next := nil; vlev := 1; vaddr := 0 end; for i := 27 to 32 do begin new(cp1,func,declared,actual); (*sin,cos,exp*) with cp1^ do (*sqrt,ln,arctan*) begin name := na[i]; idtype := realptr; next := cp; forwdecl := false; externl := true; pflev := 0; pfname := i - 12; klass := func; pfdeckind := declared; pfkind := actual end; enterid(cp1) end end (*entstdnames*) ; procedure enterundecl; begin new(utypptr,types); with utypptr^ do begin name := ' '; idtype := nil; klass := types end; new(ucstptr,konst); with ucstptr^ do begin name := ' '; idtype := nil; next := nil; values.ival := 0; klass := konst end; new(uvarptr,vars); with uvarptr^ do begin name := ' '; idtype := nil; vkind := actual; next := nil; vlev := 0; vaddr := 0; klass := vars end; new(ufldptr,field); with ufldptr^ do begin name := ' '; idtype := nil; next := nil; fldaddr := 0; klass := field end; new(uprcptr,proc,declared,actual); with uprcptr^ do begin name := ' '; idtype := nil; forwdecl := false; next := nil; externl := false; pflev := 0; genlabel(pfname); klass := proc; pfdeckind := declared; pfkind := actual end; new(ufctptr,func,declared,actual); with ufctptr^ do begin name := ' '; idtype := nil; next := nil; forwdecl := false; externl := false; pflev := 0; genlabel(pfname); klass := func; pfdeckind := declared; pfkind := actual end end (*enterundecl*) ; procedure initscalars; begin fwptr := nil; prtables := false; list := true; prcode := true; debug := true; dp := true; prterr := true; errinx := 0; intlabel := 0; kk := 8; fextfilep := nil; lc := lcaftermarkstack+filebuffer*charmax; (* note in the above reservation of buffer store for 2 text files *) ic := 3; eol := true; linecount := 0; ch := ' '; chcnt := 0; globtestp := nil; mxint10 := maxint div 10; digmax := strglgth - 1; end (*initscalars*) ; procedure initsets; begin constbegsys := [addop,intconst,realconst,stringconst,ident]; simptypebegsys := [lparent] + constbegsys; typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys; typedels := [arraysy,recordsy,setsy,filesy]; blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy]; selectsys := [arrow,period,lbrack]; facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy]; statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy]; end (*initsets*) ; procedure inittables; procedure reswords; begin rw[ 1] := 'if '; rw[ 2] := 'do '; rw[ 3] := 'of '; rw[ 4] := 'to '; rw[ 5] := 'in '; rw[ 6] := 'or '; rw[ 7] := 'end '; rw[ 8] := 'for '; rw[ 9] := 'var '; rw[10] := 'div '; rw[11] := 'mod '; rw[12] := 'set '; rw[13] := 'and '; rw[14] := 'not '; rw[15] := 'then '; rw[16] := 'else '; rw[17] := 'with '; rw[18] := 'goto '; rw[19] := 'case '; rw[20] := 'type '; rw[21] := 'file '; rw[22] := 'begin '; rw[23] := 'until '; rw[24] := 'while '; rw[25] := 'array '; rw[26] := 'const '; rw[27] := 'label '; rw[28] := 'repeat '; rw[29] := 'record '; rw[30] := 'downto '; rw[31] := 'packed '; rw[32] := 'forward '; rw[33] := 'program '; rw[34] := 'function'; rw[35] := 'procedur'; frw[1] := 1; frw[2] := 1; frw[3] := 7; frw[4] := 15; frw[5] := 22; frw[6] := 28; frw[7] := 32; frw[8] := 34; frw[9] := 36; end (*reswords*) ; procedure symbols; begin rsy[ 1] := ifsy; rsy[ 2] := dosy; rsy[ 3] := ofsy; rsy[ 4] := tosy; rsy[ 5] := relop; rsy[ 6] := addop; rsy[ 7] := endsy; rsy[ 8] := forsy; rsy[ 9] := varsy; rsy[10] := mulop; rsy[11] := mulop; rsy[12] := setsy; rsy[13] := mulop; rsy[14] := notsy; rsy[15] := thensy; rsy[16] := elsesy; rsy[17] := withsy; rsy[18] := gotosy; rsy[19] := casesy; rsy[20] := typesy; rsy[21] := filesy; rsy[22] := beginsy; rsy[23] := untilsy; rsy[24] := whilesy; rsy[25] := arraysy; rsy[26] := constsy; rsy[27] := labelsy; rsy[28] := repeatsy; rsy[29] := recordsy; rsy[30] := downtosy; rsy[31] := packedsy; rsy[32] := forwardsy; rsy[33] := progsy; rsy[34] := funcsy; rsy[35] := procsy; ssy['+'] := addop ; ssy['-'] := addop; ssy['*'] := mulop; ssy['/'] := mulop ; ssy['('] := lparent; ssy[')'] := rparent; ssy['$'] := othersy ; ssy['='] := relop; ssy[' '] := othersy; ssy[','] := comma ; ssy['.'] := period; ssy['''']:= othersy; ssy['['] := lbrack ; ssy[']'] := rbrack; ssy[':'] := colon; ssy['^'] := arrow ; ssy['<'] := relop; ssy['>'] := relop; ssy[';'] := semicolon; end (*symbols*) ; procedure rators; var i: integer; begin for i := 1 to 35 (*nr of res words*) do rop[i] := noop; rop[5] := inop; rop[10] := idiv; rop[11] := imod; rop[6] := orop; rop[13] := andop; for i := ordminchar to ordmaxchar do sop[chr(i)] := noop; sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv; sop['='] := eqop; sop['<'] := ltop; sop['>'] := gtop; end (*rators*) ; procedure procmnemonics; begin sna[ 1] :=' get'; sna[ 2] :=' put'; sna[ 3] :=' rdi'; sna[ 4] :=' rdr'; sna[ 5] :=' rdc'; sna[ 6] :=' wri'; sna[ 7] :=' wro'; sna[ 8] :=' wrr'; sna[ 9] :=' wrc'; sna[10] :=' wrs'; sna[11] :=' pak'; sna[12] :=' new'; sna[13] :=' rst'; sna[14] :=' eln'; sna[15] :=' sin'; sna[16] :=' cos'; sna[17] :=' exp'; sna[18] :=' sqt'; sna[19] :=' log'; sna[20] :=' atn'; sna[21] :=' rln'; sna[22] :=' wln'; sna[23] :=' sav'; end (*procmnemonics*) ; procedure instrmnemonics; begin mn[ 0] :=' abi'; mn[ 1] :=' abr'; mn[ 2] :=' adi'; mn[ 3] :=' adr'; mn[ 4] :=' and'; mn[ 5] :=' dif'; mn[ 6] :=' dvi'; mn[ 7] :=' dvr'; mn[ 8] :=' eof'; mn[ 9] :=' flo'; mn[10] :=' flt'; mn[11] :=' inn'; mn[12] :=' int'; mn[13] :=' ior'; mn[14] :=' mod'; mn[15] :=' mpi'; mn[16] :=' mpr'; mn[17] :=' ngi'; mn[18] :=' ngr'; mn[19] :=' not'; mn[20] :=' odd'; mn[21] :=' sbi'; mn[22] :=' sbr'; mn[23] :=' sgs'; mn[24] :=' sqi'; mn[25] :=' sqr'; mn[26] :=' sto'; mn[27] :=' trc'; mn[28] :=' uni'; mn[29] :=' stp'; mn[30] :=' csp'; mn[31] :=' dec'; mn[32] :=' ent'; mn[33] :=' fjp'; mn[34] :=' inc'; mn[35] :=' ind'; mn[36] :=' ixa'; mn[37] :=' lao'; mn[38] :=' lca'; mn[39] :=' ldo'; mn[40] :=' mov'; mn[41] :=' mst'; mn[42] :=' ret'; mn[43] :=' sro'; mn[44] :=' xjp'; mn[45] :=' chk'; mn[46] :=' cup'; mn[47] :=' equ'; mn[48] :=' geq'; mn[49] :=' grt'; mn[50] :=' lda'; mn[51] :=' ldc'; mn[52] :=' leq'; mn[53] :=' les'; mn[54] :=' lod'; mn[55] :=' neq'; mn[56] :=' str'; mn[57] :=' ujp'; mn[58] :=' ord'; mn[59] :=' chr'; mn[60] :=' ujc'; end (*instrmnemonics*) ; procedure chartypes; var i : integer; begin for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal; chartp['a'] := letter ; chartp['b'] := letter ; chartp['c'] := letter ; chartp['d'] := letter ; chartp['e'] := letter ; chartp['f'] := letter ; chartp['g'] := letter ; chartp['h'] := letter ; chartp['i'] := letter ; chartp['j'] := letter ; chartp['k'] := letter ; chartp['l'] := letter ; chartp['m'] := letter ; chartp['n'] := letter ; chartp['o'] := letter ; chartp['p'] := letter ; chartp['q'] := letter ; chartp['r'] := letter ; chartp['s'] := letter ; chartp['t'] := letter ; chartp['u'] := letter ; chartp['v'] := letter ; chartp['w'] := letter ; chartp['x'] := letter ; chartp['y'] := letter ; chartp['z'] := letter ; chartp['0'] := number ; chartp['1'] := number ; chartp['2'] := number ; chartp['3'] := number ; chartp['4'] := number ; chartp['5'] := number ; chartp['6'] := number ; chartp['7'] := number ; chartp['8'] := number ; chartp['9'] := number ; chartp['+'] := special ; chartp['-'] := special ; chartp['*'] := special ; chartp['/'] := special ; chartp['('] := chlparen; chartp[')'] := special ; chartp['$'] := special ; chartp['='] := special ; chartp[' '] := chspace ; chartp[','] := special ; chartp['.'] := chperiod; chartp['''']:= chstrquo; chartp['['] := special ; chartp[']'] := special ; chartp[':'] := chcolon ; chartp['^'] := special ; chartp[';'] := special ; chartp['<'] := chlt ; chartp['>'] := chgt ; ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2; ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5; ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8; ordint['9'] := 9; end; procedure initdx; begin cdx[ 0] := 0; cdx[ 1] := 0; cdx[ 2] := -1; cdx[ 3] := -1; cdx[ 4] := -1; cdx[ 5] := -1; cdx[ 6] := -1; cdx[ 7] := -1; cdx[ 8] := 0; cdx[ 9] := 0; cdx[10] := 0; cdx[11] := -1; cdx[12] := -1; cdx[13] := -1; cdx[14] := -1; cdx[15] := -1; cdx[16] := -1; cdx[17] := 0; cdx[18] := 0; cdx[19] := 0; cdx[20] := 0; cdx[21] := -1; cdx[22] := -1; cdx[23] := 0; cdx[24] := 0; cdx[25] := 0; cdx[26] := -2; cdx[27] := 0; cdx[28] := -1; cdx[29] := 0; cdx[30] := 0; cdx[31] := 0; cdx[32] := 0; cdx[33] := -1; cdx[34] := 0; cdx[35] := 0; cdx[36] := -1; cdx[37] := +1; cdx[38] := +1; cdx[39] := +1; cdx[40] := -2; cdx[41] := 0; cdx[42] := 0; cdx[43] := -1; cdx[44] := -1; cdx[45] := 0; cdx[46] := 0; cdx[47] := -1; cdx[48] := -1; cdx[49] := -1; cdx[50] := +1; cdx[51] := +1; cdx[52] := -1; cdx[53] := -1; cdx[54] := +1; cdx[55] := -1; cdx[56] := -1; cdx[57] := 0; cdx[58] := 0; cdx[59] := 0; cdx[60] := 0; pdx[ 1] := -1; pdx[ 2] := -1; pdx[ 3] := -2; pdx[ 4] := -2; pdx[ 5] := -2; pdx[ 6] := -3; pdx[ 7] := -3; pdx[ 8] := -3; pdx[ 9] := -3; pdx[10] := -4; pdx[11] := 0; pdx[12] := -2; pdx[13] := -1; pdx[14] := 0; pdx[15] := 0; pdx[16] := 0; pdx[17] := 0; pdx[18] := 0; pdx[19] := 0; pdx[20] := 0; pdx[21] := -1; pdx[22] := -1; pdx[23] := -1; end; begin (*inittables*) reswords; symbols; rators; instrmnemonics; procmnemonics; chartypes; initdx; end (*inittables*) ; begin (*initialize*) (************) initscalars; initsets; inittables; (*enter standard names and standard types:*) (******************************************) level := 0; top := 0; with display[0] do begin fname := nil; flabel := nil; occur := blck end; enterstdtypes; stdnames; entstdnames; enterundecl; top := 1; level := 1; with display[1] do begin fname := nil; flabel := nil; occur := blck end; (*compile:*) (**********) rewrite(prr); (* Required for ISO 7185 [sam] *) insymbol; programme(blockbegsys+statbegsys-[casesy]); end.