rs@uunet.UU.NET (Rich Salz) (07/30/87)
Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 74
Archive-name: ptoc/Part10
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 10 (of 12)."
# Contents: ptc.p.2
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'ptc.p.2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ptc.p.2'\"
else
echo shar: Extracting \"'ptc.p.2'\" \(52771 characters\)
sed "s/^X//" >'ptc.p.2' <<'END_OF_FILE'
X if sp^.lt = lforwlab then
X sp^.lt := llabel
X else
X error(emuldeflab);
X end;
X oldlbl := tp
X end;
X
X (* Parse declaration and statement-body for prog/subs. *)
X procedure pbody(tp : treeptr);
X
X var tq : treeptr;
X
X begin
X statlvl := statlvl + 1;
X if currsym.st = slabel then
X begin
X tp^.tsublab := plabel;
X linkup(tp, tp^.tsublab)
X end
X else
X tp^.tsublab := nil;
X if currsym.st = sconst then
X begin
X tp^.tsubconst := pconst;
X linkup(tp, tp^.tsubconst)
X end
X else
X tp^.tsubconst := nil;
X if currsym.st = stype then
X begin
X tp^.tsubtype := ptype;
X linkup(tp, tp^.tsubtype)
X end
X else
X tp^.tsubtype := nil;
X if currsym.st = svar then
X begin
X tp^.tsubvar := pvar;
X linkup(tp, tp^.tsubvar)
X end
X else
X tp^.tsubvar := nil;
X tp^.tsubsub := nil;
X tq := nil;
X while (currsym.st = sproc) or (currsym.st = sfunc) do
X begin
X if tq = nil then
X begin
X tq := psubs;
X tp^.tsubsub := tq
X end
X else begin
X tq^.tnext := psubs;
X tq := tq^.tnext
X end
X end;
X linkup(tp, tp^.tsubsub);
X checksymbol([sbegin, seof]);
X if currsym.st = sbegin then
X begin
X tp^.tsubstmt := pbegin(false);
X linkup(tp, tp^.tsubstmt)
X end;
X statlvl := statlvl - 1
X end;
X
X (* Parse program-declaration. *)
X function pprogram : treeptr;
X
X var tp : treeptr;
X
X (* Parse a program parameter id-list. *)
X function pprmlist : treeptr;
X
X label 999;
X
X var tp,
X tq : treeptr;
X din,
X dut : idptr;
X
X begin
X tp := nil;
X din := deftab[dinput]^.tidl^.tsym^.lid;
X dut := deftab[doutput]^.tidl^.tsym^.lid;
X while (currsym.vid = din) or (currsym.vid = dut) do
X begin
X (* ignore input/output as parameters so that
X they will be bound to stdin/stdout unless
X declared as variables *)
X if currsym.vid = din then
X defnams[dinput]^.lused := true
X else
X defnams[doutput]^.lused := true;
X nextsymbol([scomma, srpar]);
X if currsym.st = srpar then
X goto 999;
X nextsymbol([sid])
X end;
X tq := newid(currsym.vid);
X tq^.tsym^.lt := lpointer;
X tp := tq;
X nextsymbol([scomma, srpar]);
X while currsym.st = scomma do
X begin
X nextsymbol([sid]);
X if currsym.vid = din then
X defnams[dinput]^.lused := true
X else if currsym.vid = dut then
X defnams[doutput]^.lused := true
X else begin
X tq^.tnext := newid(currsym.vid);
X tq := tq^.tnext;
X tq^.tsym^.lt := lpointer;
X end;
X nextsymbol([scomma, srpar])
X end;
X 999:
X pprmlist := tp
X end;
X
X begin (* pprogram *)
X enterscope(nil);
X tp := mknode(npgm);
X nextsymbol([sid]);
X tp^.tstat := statlvl;
X tp^.tsubid := mknode(nid);
X tp^.tsubid^.tup := tp;
X tp^.tsubid^.tsym := mksym(lidentifier);
X tp^.tsubid^.tsym^.lid := currsym.vid;
X tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid;
X linkup(tp, tp^.tsubid);
X nextsymbol([slpar, ssemic]);
X if currsym.st = slpar then
X begin
X nextsymbol([sid]);
X tp^.tsubpar := pprmlist;
X linkup(tp, tp^.tsubpar);
X nextsymbol([ssemic])
X end
X else
X tp^.tsubpar := nil;
X nextsymbol([slabel, sconst, stype, svar,
X sproc, sfunc, sbegin]);
X pbody(tp);
X checksymbol([sdot]);
X tp^.tscope := currscope;
X leavescope;
X pprogram := tp
X end; (* pprogram *)
X
X (* Parse a module. *)
X function pmodule : treeptr;
X
X var tp : treeptr;
X
X begin (* pmodule *)
X enterscope(nil);
X tp := mknode(npgm);
X tp^.tstat := statlvl;
X tp^.tsubid := nil;
X tp^.tsubpar := nil;
X pbody(tp);
X checksymbol([ssemic]);
X tp^.tscope := currscope;
X leavescope;
X pmodule := tp
X end; (* pmodule *)
X
X
X (* Parse label-clause. *)
X function plabel;
X
X var tp,
X tq : treeptr;
X
X begin
X tq := nil;
X repeat
X nextsymbol([sinteger]);
X if tq = nil then
X begin
X tq := newlbl;
X tp := tq
X end
X else begin
X tq^.tnext := newlbl;
X tq := tq^.tnext;
X end;
X nextsymbol([scomma, ssemic])
X until currsym.st = ssemic;
X nextsymbol([sconst, stype, svar, sbegin, sproc, sfunc]);
X plabel := tp
X end;
X
X (* Parse an id-list. *)
X function pidlist;
X
X var tp,
X tq : treeptr;
X
X begin
X tq := newid(currsym.vid);
X tq^.tsym^.lt := l;
X tp := tq;
X nextsymbol([scomma, scolon, seq, srpar]);
X while currsym.st = scomma do
X begin
X nextsymbol([sid]);
X tq^.tnext := newid(currsym.vid);
X tq := tq^.tnext;
X tq^.tsym^.lt := l;
X nextsymbol([scomma, scolon, seq, srpar])
X end;
X pidlist := tp
X end;
X
X (* Parse const-clause. *)
X function pconst;
X
X var tp,
X tq : treeptr;
X
X begin
X tq := nil;
X nextsymbol([sid]);
X repeat
X if tq = nil then
X begin
X tq := mknode(nconst);
X tq^.tattr := anone;
X tp := tq
X end
X else begin
X tq^.tnext := mknode(nconst);
X tq := tq^.tnext;
X tq^.tattr := anone
X end;
X tq^.tidl := pidlist(lidentifier);
X checksymbol([seq]);
X nextsymbol([sid, schar, sstring, sinteger, sreal,
X splus, sminus]);
X tq^.tbind := pconstant(true);
X nextsymbol([ssemic]);
X nextsymbol([sid, stype, svar, sbegin,
X sfunc, sproc, seof])
X until currsym.st <> sid;
X pconst := tp
X end;
X
X (* Parse a declared constant or a case-statment const. *)
X function pconstant;
X
X var tp,
X tq : treeptr;
X neg : boolean;
X
X begin
X neg := currsym.st = sminus;
X if currsym.st in [splus, sminus] then
X if realok then
X nextsymbol([sid, sinteger, sreal])
X else
X nextsymbol([sid, sinteger]);
X if currsym.st = sid then
X tp := oldid(currsym.vid, lidentifier)
X else
X tp := mklit;
X if neg then
X begin
X tq := mknode(numinus);
X tq^.texps := tp;
X tp := tq
X end;
X pconstant := tp
X end;
X
X (* Parse a record (or record-variant) declaration. *)
X (* Cs is the expected closing symbol, dp the scope. *)
X function precord;
X
X label 999;
X
X var tp,
X tq,
X tl,
X tv : treeptr;
X tsym : lexsym;
X
X begin
X tp := mknode(nrecord);
X tp^.tflist := nil;
X tp^.tvlist := nil;
X tp^.tuid := nil;
X tp^.trscope := nil;
X if cs = send then
X begin
X enterscope(dp);
X dp := currscope
X end;
X nextsymbol([sid, scase] + [cs]);
X tq := nil;
X while currsym.st = sid do
X begin
X if tq = nil then
X begin
X tq := mknode(nfield);
X tq^.tattr := anone;
X tp^.tflist := tq
X end
X else begin
X tq^.tnext := mknode(nfield);
X tq := tq^.tnext;
X tq^.tattr := anone
X end;
X tq^.tidl := pidlist(lfield);
X checksymbol([scolon]);
X leavescope;
X tq^.tbind := ptypedef;
X enterscope(dp);
X if currsym.st = ssemic then
X nextsymbol([sid, scase] + [cs])
X end;
X if currsym.st = scase then
X begin
X nextsymbol([sid]);
X tsym := currsym;
X nextsymbol([scolon, sof]);
X if currsym.st = scolon then
X begin
X tv := newid(tsym.vid);
X if tq = nil then
X begin
X tq := mknode(nfield);
X tp^.tflist := tq
X end
X else begin
X tq^.tnext := mknode(nfield);
X tq := tq^.tnext
X end;
X tq^.tidl := tv;
X tv^.tsym^.lt := lfield;
X nextsymbol([sid]);
X leavescope;
X tq^.tbind := oldid(currsym.vid, lidentifier);
X enterscope(dp);
X nextsymbol([sof])
X end;
X tq := nil;
X repeat
X tv := nil;
X repeat
X nextsymbol([sid, sinteger, schar, splus,
X sminus] + [cs]);
X if currsym.st = cs then
X goto 999;
X if tv = nil then
X begin
X tv := pconstant(false);
X tl := tv
X end
X else begin
X tv^.tnext := pconstant(false);
X tv := tv^.tnext
X end;
X nextsymbol([scolon, scomma])
X until currsym.st = scolon;
X nextsymbol([slpar]);
X if tq = nil then
X begin
X tq := mknode(nvariant);
X tp^.tvlist := tq;
X end
X else begin
X tq^.tnext := mknode(nvariant);
X tq := tq^.tnext;
X end;
X tq^.tselct := tl;
X tq^.tvrnt := precord(srpar, dp)
X until currsym.st = cs
X end;
X 999:
X if cs = send then
X begin
X tp^.trscope := dp;
X leavescope
X end;
X nextsymbol([ssemic, send, srpar]);
X (* currsym is the symbol following record end/rpar,
X (usually semicolon, sometimes enclosing end/rpar) *)
X precord := tp
X end;
X
X function ptypedef;
X
X var tp,
X tq : treeptr;
X st : symtyp;
X ss : symset;
X
X begin
X nextsymbol([sid, slpar, sarrow, sinteger, schar, splus, sminus,
X spacked, sarray, srecord, sfile, sset]);
X
X (* the "packed" keyword is completely ignored *)
X if currsym.st = spacked then
X nextsymbol([sarray, srecord, sfile, sset]);
X
X ss := [ssemic, send, srpar, scomma, srbrack];
X case currsym.st of
X splus,
X sminus,
X schar,
X sinteger,
X sid:
X begin
X st := currsym.st;
X tp := pconstant(false);
X if st = sid then
X nextsymbol([sdotdot] + ss)
X else
X nextsymbol([sdotdot]);
X if currsym.st = sdotdot then
X begin
X nextsymbol([sid, sinteger, schar,
X splus, sminus]);
X tq := mknode(nsubrange);
X tq^.tlo := tp;
X tq^.thi := pconstant(false);
X tp := tq;
X nextsymbol(ss)
X end
X end;
X slpar:
X begin
X tp := mknode(nscalar);
X nextsymbol([sid]);
X tp^.tscalid := pidlist(lidentifier);
X checksymbol([srpar]);
X nextsymbol(ss)
X end;
X sarrow:
X begin
X tp := mknode(nptr);
X nextsymbol([sid]);
X tp^.tptrid := oldid(currsym.vid, lpointer);
X tp^.tptrflag := false;
X nextsymbol([ssemic, send, srpar])
X end;
X sarray:
X begin
X nextsymbol([slbrack]);
X tp := mknode(narray);
X tp^.taindx := ptypedef; (* parse subrange ... *)
X tq := tp;
X while currsym.st = scomma do
X begin
X (* expand: array [ A , B ] of X
X to: array [ A ] of array [ B ] of X *)
X tq^.taelem := mknode(narray);
X tq := tq^.taelem;
X tq^.taindx := ptypedef (* ... again *)
X end;
X checksymbol([srbrack]);
X nextsymbol([sof]);
X tq^.taelem := ptypedef
X end;
X srecord:
X tp := precord(send, nil);
X sfile,
X sset:
X begin
X if currsym.st = sfile then
X tp := mknode(nfileof)
X else begin
X tp := mknode(nsetof);
X usesets := true
X end;
X nextsymbol([sof]);
X tp^.tof := ptypedef
X end
X end;
X (* at this point "currsym" holds the symbol following the type
X (usually semicolon, sometimes the following end/rpar) *)
X ptypedef := tp
X end;
X
X (* Parse type-clause. *)
X function ptype;
X
X var tp,
X tq : treeptr;
X
X begin
X tq := nil;
X nextsymbol([sid]);
X repeat
X if tq = nil then
X begin
X tq := mknode(ntype);
X tq^.tattr := anone;
X tp := tq
X end
X else begin
X tq^.tnext := mknode(ntype);
X tq := tq^.tnext;
X tq^.tattr := anone
X end;
X tq^.tidl := pidlist(lidentifier);
X checksymbol([seq]);
X tq^.tbind := ptypedef;
X nextsymbol([sid, svar, sbegin, sfunc, sproc, seof])
X until currsym.st <> sid;
X ptype := tp;
X end;
X
X (* Parse var-clause. *)
X function pvar;
X
X var ti,
X tp,
X tq : treeptr;
X
X begin
X tq := nil;
X nextsymbol([sid]);
X repeat
X if tq = nil then
X begin
X tq := mknode(nvar);
X tq^.tattr := anone;
X tp := tq
X end
X else begin
X tq^.tnext := mknode(nvar);
X tq := tq^.tnext;
X tq^.tattr := anone
X end;
X
X ti := newid(currsym.vid);
X tq^.tidl := ti;
X nextsymbol([scomma, scolon]);
X while currsym.st = scomma do
X begin
X nextsymbol([sid]);
X ti^.tnext := newid(currsym.vid);
X ti := ti^.tnext;
X nextsymbol([scomma, scolon])
X end;
X
X tq^.tbind := ptypedef;
X nextsymbol([sid, sbegin, sfunc, sproc, seof])
X until currsym.st <> sid;
X pvar := tp
X end;
X
X (* Parse subroutine-declaration. *)
X function psubs;
X
X var tp, (* return value *)
X tv, tq : treeptr; (* temporary *)
X func : boolean; (* true for functions *)
X colsem : symtyp; (* colon/semicolon *)
X
X begin
X (* parsing function or procedure *)
X func := currsym.st = sfunc;
X if func then
X colsem := scolon
X else
X colsem := ssemic;
X
X (* parse id, it may already be forward declared *)
X nextsymbol([sid]);
X tq := newid(currsym.vid);
X if tq^.tup = nil then
X begin
X enterscope(nil);
X (* id wasn't previously declared, params possible *)
X if func then
X tp := mknode(nfunc)
X else
X tp := mknode(nproc);
X tp^.tstat := statlvl;
X tp^.tsubid := tq;
X linkup(tp, tq);
X nextsymbol([slpar, colsem]);
X if currsym.st = slpar then
X begin
X tp^.tsubpar := psubpar;
X linkup(tp, tp^.tsubpar);
X nextsymbol([colsem])
X end
X else
X tp^.tsubpar := nil;
X if func then
X begin
X (* parse function type *)
X nextsymbol([sid]);
X tp^.tfuntyp := oldid(currsym.vid, lidentifier);
X nextsymbol([ssemic])
X end
X else
X tp^.tfuntyp := mknode(nempty);
X linkup(tp, tp^.tfuntyp);
X nextsymbol([sextern, sforward,
X slabel, sconst, stype, svar,
X sproc, sfunc, sbegin]);
X end
X else begin
X (* id was forward declared =>
X pick up declarations from parameterlist *)
X enterscope(tq^.tup^.tscope);
X if func then
X tp := mknode(nfunc)
X else
X tp := mknode(nproc);
X tp^.tfuntyp := tq^.tup^.tfuntyp;
X (* steal id and params from forward decl *)
X tv := tq^.tup^.tsubpar;
X tp^.tsubpar := tv;
X while tv <> nil do
X begin
X tv^.tup := tp;
X tv := tv^.tnext
X end;
X tp^.tsubid := tq;
X tq^.tup := tp;
X (* id was forward declared =>
X no params, no function type, no forward *)
X nextsymbol([ssemic]);
X nextsymbol([slabel, sconst, stype, svar,
X sproc, sfunc, sbegin]);
X end;
X if currsym.st in [sforward, sextern] then
X begin
X tp^.tsubid^.tsym^.lt := lforward;
X nextsymbol([ssemic]);
X tp^.tsublab := nil;
X tp^.tsubconst := nil;
X tp^.tsubtype := nil;
X tp^.tsubvar := nil;
X tp^.tsubsub := nil;
X tp^.tsubstmt := nil
X end
X else
X pbody(tp);
X nextsymbol([sproc, sfunc, sbegin, seof]);
X tp^.tscope := currscope;
X leavescope;
X psubs := tp
X end;
X
X (* Parse a conformant array index type. *)
X function pconfsub : treeptr;
X
X var tp : treeptr;
X
X begin
X tp := mknode(nsubrange);
X nextsymbol([sid]);
X tp^.tlo := newid(currsym.vid);
X nextsymbol([sdotdot]);
X nextsymbol([sid]);
X tp^.thi := newid(currsym.vid);
X nextsymbol([scolon]);
X pconfsub := tp
X end;
X
X (* Parse a conformant array-declaration. *)
X function pconform : treeptr;
X
X var tp, tq : treeptr;
X
X begin
X nextsymbol([slbrack]);
X tp := mknode(nconfarr);
X tp^.tcuid := mkvariable('S');
X tp^.tcindx := pconfsub; (* parse subrange ... *)
X nextsymbol([sid]);
X tp^.tindtyp := oldid(currsym.vid, lidentifier);
X nextsymbol([ssemic, srbrack]);
X tq := tp;
X while currsym.st = ssemic do
X begin
X error(econfconf); (* what size does tp have *)
X
X (* expand: array [ A ; B ] of X
X to: array [ A ] of array [ B ] of X *)
X tq^.tcelem := mknode(nconfarr);
X tq := tq^.tcelem;
X tq^.tcindx := pconfsub; (* ... again *)
X nextsymbol([sid]);
X tq^.tindtyp := oldid(currsym.vid, lidentifier);
X nextsymbol([ssemic, srbrack])
X end;
X nextsymbol([sof]);
X nextsymbol([sid, sarray]);
X case currsym.st of
X sid:
X tq^.tcelem := oldid(currsym.vid, lidentifier);
X sarray:
X begin
X error(econfconf); (* what size does tp have *)
X
X tq^.tcelem := pconform
X end;
X end;(* case *)
X pconform := tp
X end;
X
X (* Parse subroutine parameter list. *)
X function psubpar;
X
X var tp,
X tq : treeptr;
X nt : treetyp;
X
X begin
X tq := nil;
X repeat
X nextsymbol([sid, svar, sfunc, sproc]);
X case currsym.st of
X sid:
X nt := nvalpar;
X svar:
X nt := nvarpar;
X sfunc:
X nt := nparfunc;
X sproc:
X nt := nparproc;
X end;
X if nt <> nvalpar then
X nextsymbol([sid]);
X if tq = nil then
X begin
X tq := mknode(nt);
X tp := tq
X end
X else begin
X tq^.tnext := mknode(nt);
X tq := tq^.tnext
X end;
X case nt of
X nvarpar,
X nvalpar:
X begin
X tq^.tidl := pidlist(lidentifier);
X tq^.tattr := anone;
X checksymbol([scolon]);
X if nt = nvalpar then
X nextsymbol([sid])
X else
X nextsymbol([sid, sarray]);
X case currsym.st of
X sid:
X tq^.tbind :=
X oldid(currsym.vid, lidentifier);
X sarray:
X tq^.tbind := pconform
X end;(* case *)
X nextsymbol([srpar, ssemic])
X end;
X nparproc:
X begin
X tq^.tparid := newid(currsym.vid);
X nextsymbol([ssemic, slpar, srpar]);
X if currsym.st = slpar then
X begin
X enterscope(nil);
X tq^.tparparm := psubpar;
X nextsymbol([ssemic, srpar]);
X leavescope
X end
X else
X tq^.tparparm := nil;
X tq^.tpartyp := nil
X end;
X nparfunc:
X begin
X tq^.tparid := newid(currsym.vid);
X nextsymbol([scolon, slpar]);
X if currsym.st = slpar then
X begin
X enterscope(nil);
X tq^.tparparm := psubpar;
X nextsymbol([scolon]);
X leavescope
X end
X else
X tq^.tparparm := nil;
X nextsymbol([sid]);
X tq^.tpartyp := oldid(currsym.vid, lidentifier);
X nextsymbol([srpar, ssemic])
X end
X end (* case *)
X until currsym.st = srpar;
X psubpar := tp
X end;
X
X (* Parse a (possibly labeled) statement. *)
X function plabstmt;
X
X var tp : treeptr;
X
X begin
X nextsymbol([sid, sinteger, sif, swhile, srepeat, sfor, scase,
X swith, sbegin, sgoto,
X selse, ssemic, send, suntil]);
X if currsym.st = sinteger then
X begin
X tp := mknode(nlabstmt);
X tp^.tlabno := oldlbl(true);
X nextsymbol([scolon]);
X nextsymbol([sid, sif, swhile, srepeat, sfor, scase,
X swith, sbegin, sgoto,
X selse, ssemic, send, suntil]);
X tp^.tstmt := pstmt
X end
X else
X tp := pstmt;
X plabstmt := tp
X end;
X
X (* Parse an unlabeled statement. *)
X function pstmt;
X
X var tp : treeptr;
X
X begin
X case currsym.st of
X sid:
X tp := psimple;
X sif:
X tp := pif;
X swhile:
X tp := pwhile;
X srepeat:
X tp := prepeat;
X sfor:
X tp := pfor;
X scase:
X tp := pcase;
X swith:
X tp := pwith;
X sbegin:
X tp := pbegin(true);
X sgoto:
X tp := pgoto;
X send,
X selse,
X suntil,
X ssemic:
X tp := mknode(nempty);
X end;
X pstmt := tp
X end;
X
X (* Parse an assignment or a procedure call. *)
X function psimple;
X
X var tq,
X tp : treeptr;
X
X begin
X tp := pvariable(oldid(currsym.vid, lidentifier));
X if currsym.st = sassign then
X begin
X tq := mknode(nassign);
X tq^.tlhs := tp;
X tq^.trhs := pexpr(nil);
X tp := tq
X end;
X psimple := tp
X end;
X
X (* Parse a varable-reference (or a subroutine-call). *)
X function pvariable;
X
X var tp,
X tq : treeptr;
X
X begin
X nextsymbol([slpar, slbrack, sdot, sarrow,
X sassign, ssemic, scomma, scolon, sdotdot,
X splus, sminus, smul, sdiv, smod, squot,
X sand, sor, sinn, srpar, srbrack,
X sle, slt, seq, sge, sgt, sne,
X send, suntil, sthen, selse, sdo, sdownto, sto, sof]);
X if currsym.st in [slpar, slbrack, sdot, sarrow] then
X begin
X case currsym.st of
X slpar:
X begin
X tp := mknode(ncall);
X tp^.tcall := varptr;
X tq := nil;
X repeat
X if tq = nil then
X begin
X tq := pexpr(nil);
X tp^.taparm := tq
X end
X else begin
X tq^.tnext := pexpr(nil);
X tq := tq^.tnext
X end;
X until currsym.st = srpar
X end;
X slbrack:
X begin
X tq := varptr;
X repeat
X tp := mknode(nindex);
X tp^.tvariable := tq;
X tp^.toffset := pexpr(nil);
X tq := tp
X until currsym.st = srbrack
X end;
X sdot:
X begin
X tp := mknode(nselect);
X tp^.trecord := varptr;
X nextsymbol([sid]);
X tq := typeof(varptr);
X enterscope(tq^.trscope);
X tp^.tfield := oldid(currsym.vid, lfield);
X leavescope
X end;
X sarrow:
X begin
X tp := mknode(nderef);
X tp^.texps := varptr
X end
X end;(* case *)
X tp := pvariable(tp)
X end
X else begin
X tp := varptr;
X if tp^.tt = nid then
X begin
X tq := idup(tp);
X if tq <> nil then
X if tq^.tt in [nfunc, nproc,
X nparproc, nparfunc] then
X begin
X (* subroutine-call without
X parameters *)
X tp := mknode(ncall);
X tp^.tcall := varptr;
X tp^.taparm := nil
X end
X end
X end;
X pvariable := tp
X end;
X
X (* Parse an expression. *)
X function pexpr;
X
X var tp,
X tq : treeptr;
X nt : treetyp;
X next : boolean;
X
X function padjust(tu, tr : treeptr) : treeptr;
X begin
X if pprio[tu^.tt] >= pprio[tr^.tt] then
X begin
X if tr^.tt in [nnot, numinus, nuplus,
X nset, nderef] then
X tr^.texps := padjust(tu, tr^.texps)
X else
X tr^.texpl := padjust(tu, tr^.texpl);
X padjust := tr
X end
X else begin
X if tu^.tt in [nnot, numinus, nuplus,
X nset, nderef] then
X tu^.texps := tr
X else
X tu^.texpr := tr;
X padjust := tu
X end
X end;
X
X begin
X nextsymbol([sid, schar, sinteger, sreal, sstring, snil,
X splus, sminus, snot, slpar, slbrack, srbrack]);
X next := true;
X case currsym.st of
X splus:
X begin
X tp := mknode(nuplus);
X tp^.texps := nil;
X tp := pexpr(tp);
X next := false
X end;
X sminus:
X begin
X tp := mknode(numinus);
X tp^.texps := nil;
X tp := pexpr(tp);
X next := false
X end;
X snot:
X begin
X tp := mknode(nnot);
X tp^.texps := nil;
X tp := pexpr(tp);
X next := false
X end;
X schar,
X sinteger,
X sreal,
X sstring:
X tp := mklit;
X snil:
X begin
X usenilp := true;
X tp := mknode(nnil);
X end;
X sid:
X begin
X tp := pvariable(oldid(currsym.vid, lidentifier));
X next := false
X end;
X slpar:
X begin
X tp := mknode(nuplus);
X tp^.texps := pexpr(nil)
X end;
X slbrack:
X begin
X usesets := true;
X tp := mknode(nset);
X tp^.texps := nil;
X tq := nil;
X repeat
X if tq = nil then
X begin
X tq := pexpr(nil);
X tp^.texps := tq
X end
X else begin
X tq^.tnext := pexpr(nil);
X tq := tq^.tnext
X end
X until currsym.st = srbrack;
X end;
X srbrack:
X begin
X tp := mknode(nempty);
X next := false
X end
X end;
X if next then
X nextsymbol([
X scolon, ssemic, scomma, sdotdot, srpar, srbrack,
X sle, slt, seq, sge, sgt, sne,
X splus, sminus, smul, sdiv, smod, squot,
X sand, sor, sinn,
X send, suntil, sthen, selse, sdo, sdownto, sto,
X sof, slpar, slbrack]);
X case currsym.st of
X sdotdot:
X nt := nrange;
X splus:
X nt := nplus;
X sminus:
X nt := nminus;
X smul:
X nt := nmul;
X sdiv:
X nt := ndiv;
X smod:
X nt := nmod;
X squot:
X begin
X defnams[dreal]^.lused := true;
X nt := nquot;
X end;
X sand:
X nt := nand;
X sor:
X nt := nor;
X sinn:
X begin
X nt := nin;
X usesets := true
X end;
X sle:
X nt := nle;
X slt:
X nt := nlt;
X seq:
X nt := neq;
X sge:
X nt := nge;
X sgt:
X nt := ngt;
X sne:
X nt := nne;
X scolon:
X nt := nformat;
X sid, schar, sinteger, sreal, sstring, snil,
X ssemic, scomma, slpar, slbrack, srpar, srbrack,
X send, suntil, sthen, selse, sdo, sdownto, sto, sof:
X nt := nnil
X end;(* case *)
X if nt in [nin .. nor, nand, nnot] then
X defnams[dboolean]^.lused := true;
X if nt <> nnil then
X begin
X (* binary operator *)
X tq := mknode(nt);
X tq^.texpl := tp;
X tq^.texpr := nil;
X tp := pexpr(tq)
X end;
X
X (* this statement yilds proper operator precedence *)
X if tnp <> nil then
X tp := padjust(tnp, tp);
X pexpr := tp
X end;
X
X (* Parse a case-statement. *)
X function pcase;
X
X label 999;
X
X var tp,
X tq,
X tv : treeptr;
X
X begin
X tp := mknode(ncase);
X tp^.tcasxp := pexpr(nil);
X checksymbol([sof]);
X tq := nil;
X repeat
X if tq = nil then
X begin
X tq := mknode(nchoise);
X tp^.tcaslst := tq
X end
X else begin
X tq^.tnext := mknode(nchoise);
X tq := tq^.tnext
X end;
X tv := nil;
X repeat
X nextsymbol([sid, sinteger, schar,
X splus, sminus, send, sother]);
X if currsym.st in [send, sother] then
X goto 999;
X if tv = nil then
X begin
X tv := pconstant(false);
X tq^.tchocon := tv
X end
X else begin
X tv^.tnext := pconstant(false);
X tv := tv^.tnext
X end;
X nextsymbol([scomma, scolon])
X until currsym.st = scolon;
X tq^.tchostmt := plabstmt
X until currsym.st = send;
X 999:
X if currsym.st = sother then
X begin
X nextsymbol([scolon, sid, sif, swhile, srepeat, sfor,
X scase, swith, sbegin, sgoto,
X selse, ssemic, send, suntil]);
X if currsym.st = scolon then
X nextsymbol([sid, sif, swhile, srepeat, sfor,
X scase, swith, sbegin, sgoto,
X selse, ssemic, send, suntil]);
X tp^.tcasother := pstmt
X end
X else begin
X tp^.tcasother := nil;
X usecase := true
X end;
X nextsymbol([ssemic, send, selse, suntil]);
X pcase := tp
X end;
X
X (* Parse an if-statement. *)
X function pif;
X
X var tp : treeptr;
X
X begin
X tp := mknode(nif);
X tp^.tifxp := pexpr(nil);
X checksymbol([sthen]);
X tp^.tthen := plabstmt;
X if currsym.st = selse then
X tp^.telse := plabstmt
X else
X tp^.telse := nil;
X pif := tp;
X end;
X
X (* Parse a while-statement. *)
X function pwhile;
X
X var tp : treeptr;
X
X begin
X tp := mknode(nwhile);
X tp^.twhixp := pexpr(nil);
X checksymbol([sdo]);
X tp^.twhistmt := plabstmt;
X pwhile := tp;
X end;
X
X (* Parse a repeat-statement. *)
X function prepeat;
X
X var tp,
X tq : treeptr;
X
X begin
X tp := mknode(nrepeat);
X tq := nil;
X repeat
X if tq = nil then
X begin
X tq := plabstmt;
X tp^.treptstmt := tq
X end
X else begin
X tq^.tnext := plabstmt;
X tq := tq^.tnext
X end;
X checksymbol([ssemic, suntil])
X until currsym.st = suntil;
X tp^.treptxp := pexpr(nil);
X prepeat := tp
X end;
X
X (* Parse a for-statement. *)
X function pfor;
X
X var tp : treeptr;
X
X begin
X tp := mknode(nfor);
X nextsymbol([sid]);
X tp^.tforid := oldid(currsym.vid, lidentifier);
X nextsymbol([sassign]);
X tp^.tfrom := pexpr(nil);
X checksymbol([sdownto, sto]);
X tp^.tincr := currsym.st = sto;
X tp^.tto := pexpr(nil);
X checksymbol([sdo]);
X tp^.tforstmt := plabstmt;
X pfor := tp
X end;
X
X (* Parse a with-statement. *)
X function pwith;
X
X var tp,
X tq : treeptr;
X
X begin
X tp := mknode(nwith);
X tq := nil;
X repeat
X if tq = nil then
X begin
X tq := mknode(nwithvar);
X tp^.twithvar := tq
X end
X else begin
X tq^.tnext := mknode(nwithvar);
X tq := tq^.tnext
X end;
X enterscope(nil);
X tq^.tenv := currscope;
X tq^.texpw := pexpr(nil);
X scopeup(tq^.texpw);
X checksymbol([scomma, sdo])
X until currsym.st = sdo;
X tp^.twithstmt := plabstmt;
X tq := tp^.twithvar;
X while tq <> nil do
X begin
X leavescope;
X tq := tq^.tnext
X end;
X pwith := tp
X end;
X
X (* Parse a goto-statement. *)
X function pgoto;
X
X var tp : treeptr;
X
X begin
X nextsymbol([sinteger]);
X tp := mknode(ngoto);
X tp^.tlabel := oldlbl(false);
X nextsymbol([ssemic, send, suntil, selse]);
X pgoto := tp
X end;
X
X (* Parse a begin-statement. *)
X function pbegin;
X
X var tp,
X tq : treeptr;
X
X begin
X tq := nil;
X repeat
X if tq = nil then
X begin
X tq := plabstmt;
X tp := tq
X end
X else begin
X tq^.tnext := plabstmt;
X tq := tq^.tnext
X end
X until currsym.st = send;
X if retain then
X begin
X tq := mknode(nbegin);
X tq^.tbegin := tp;
X tp := tq
X end;
X nextsymbol([send, selse, suntil, sdot, ssemic]);
X pbegin := tp
X end;
X
Xbegin (* parse *)
X nextsymbol([spgm, sconst, stype, svar, sproc, sfunc]);
X if currsym.st = spgm then
X top := pprogram
X else
X top := pmodule;
X nextsymbol([seof]);
Xend; (* parse *)
X
X(* Compute value for a node (which must be some kind of constant). *)
Xfunction cvalof(tp : treeptr) : integer;
X
Xvar v : integer;
X tq : treeptr;
X
Xbegin
X case tp^.tt of
X nuplus:
X cvalof := cvalof(tp^.texps);
X numinus:
X cvalof := - cvalof(tp^.texps);
X nnot:
X cvalof := 1 - cvalof(tp^.texps);
X nid:
X begin
X tq := idup(tp);
X if tq = nil then
X fatal(etree);
X tp := tp^.tsym^.lsymdecl;
X case tq^.tt of
X nscalar:
X begin
X v := 0;
X tq := tq^.tscalid;
X while tq <> nil do
X if tq = tp then
X tq := nil
X else begin
X v := v + 1;
X tq := tq^.tnext
X end;
X cvalof := v
X end;
X nconst:
X cvalof := cvalof(tq^.tbind);
X end;(* case *)
X end;
X ninteger:
X cvalof := tp^.tsym^.linum;
X nchar:
X cvalof := ord(tp^.tsym^.lchar);
X end (* case *)
Xend; (* cvalof *)
X
X(* Compute lower value of subrange or scalar type. *)
Xfunction clower(tp : treeptr) : integer;
X
Xvar tq : treeptr;
X
Xbegin
X tq := typeof(tp);
X if tq^.tt = nscalar then
X clower := scalbase
X else if tq^.tt = nsubrange then
X if tq^.tup^.tt = nconfarr then
X clower := 0
X else
X clower := cvalof(tq^.tlo)
X else if tq = typnods[tchar] then
X clower := 0
X else if tq = typnods[tinteger] then
X clower := -maxint
X else
X fatal(etree)
Xend; (* clower *)
X
X(* Compute upper value of subrange or scalar type. *)
Xfunction cupper(tp : treeptr) : integer;
X
Xvar tq : treeptr;
X i : integer;
X
Xbegin
X tq := typeof(tp);
X if tq^.tt = nscalar then
X begin
X tq := tq^.tscalid;
X i := scalbase;
X while tq^.tnext <> nil do
X begin
X i := i + 1;
X tq := tq^.tnext
X end;
X cupper := i
X end
X else if tq^.tt = nsubrange then
X if tq^.tup^.tt = nconfarr then
X fatal(euprconf)
X else
X cupper := cvalof(tq^.thi)
X else if tq = typnods[tchar] then
X cupper := maxchar
X else if tq = typnods[tinteger] then
X cupper := maxint
X else
X fatal(etree)
Xend; (* cupper *)
X
X(* Compute the number of elements in a subrange. *)
Xfunction crange(tp : treeptr) : integer;
X
Xbegin
X crange := cupper(tp) - clower(tp) + 1
Xend;
X
X(* Return number of words uset to store a set. *)
Xfunction csetwords(i : integer) : integer;
X
Xbegin
X i := (i+(setbits)) div (setbits+1);
X if i > maxsetrange then
X error(esetsize);
X csetwords := i
Xend;
X
X(* Return number of words uset to store a set. *)
Xfunction csetsize(tp : treeptr) : integer;
X
Xvar tq : treeptr;
X i : integer;
X
Xbegin
X tq := typeof(tp^.tof);
X i := clower(tq);
X (* bits in sets are always numbered from 0, so we (arbitrarily)
X decide that the base must be in the first 6 words to avoid
X unnecessary waste of space *)
X if (i < 0) or (i >= 6 * (setbits+1)) then
X error(esetbase);
X csetsize := csetwords(crange(tq)) + 1
Xend;
X
X(* Determine if tp is declared in the procedure it is used in. *)
Xfunction islocal(tp : treeptr) : boolean;
X
Xvar tq : treeptr;
X
Xbegin
X tq := tp^.tsym^.lsymdecl;
X while not (tq^.tt in [nproc, nfunc, npgm]) do
X tq := tq^.tup;
X while not (tp^.tt in [nproc, nfunc, npgm]) do
X tp := tp^.tup;
X islocal := tp = tq
Xend;
X
X(* Perform necessary transformations on tree and identifiers *)
X(* before generating code. *)
Xprocedure transform;
X
X
X (* Rename function when used as a variable. *)
X procedure renamf(tp : treeptr);
X
X var ip, iq : symptr;
X tq, tv : treeptr;
X
X (* This procedure recursively descends the tree *)
X (* and replaces function-assignments with variable *)
X (* assignments. *)
X procedure crtnvar(tp : treeptr);
X
X begin
X while tp <> nil do
X begin
X case tp^.tt of
X npgm:
X crtnvar(tp^.tsubsub);
X nfunc,
X nproc:
X begin
X crtnvar(tp^.tsubsub);
X crtnvar(tp^.tsubstmt)
X end;
X nbegin:
X crtnvar(tp^.tbegin);
X nif:
X begin
X crtnvar(tp^.tthen);
X crtnvar(tp^.telse)
X end;
X nwhile:
X crtnvar(tp^.twhistmt);
X nrepeat:
X crtnvar(tp^.treptstmt);
X nfor:
X crtnvar(tp^.tforstmt);
X ncase:
X begin
X crtnvar(tp^.tcaslst);
X crtnvar(tp^.tcasother)
X end;
X nchoise:
X crtnvar(tp^.tchostmt);
X nwith:
X crtnvar(tp^.twithstmt);
X nlabstmt:
X crtnvar(tp^.tstmt);
X nassign:
X begin
X (* revoke calls in assignment lhs, (mis-
X parsed due to ambiguous syntax) *)
X if tp^.tlhs^.tt = ncall then
X begin
X tp^.tlhs := tp^.tlhs^.tcall;
X tp^.tlhs^.tup := tp
X end;
X (* function name -> variable name *)
X tv := tp^.tlhs;
X if tv^.tt = nid then
X if tv^.tsym = ip then
X tv^.tsym := iq
X end;
X nbreak,
X npush,
X npop,
X ngoto,
X nempty,
X ncall:
X (* no op *)
X end;(* case *)
X tp := tp^.tnext
X end
X end;
X
X begin (* renamf *)
X while tp <> nil do
X begin
X case tp^.tt of
X npgm,
X nproc:
X renamf(tp^.tsubsub);
X nfunc:
X begin
X (* create a variable to hold return value *)
X tq := mknode(nvar);
X tq^.tattr := aregister;
X tq^.tup := tp;
X tq^.tidl := newid(mkvariable('R'));
X tq^.tidl^.tup := tq;
X tq^.tbind := tp^.tfuntyp;
X (* put it FIRST among variables, see esubr() *)
X tq^.tnext := tp^.tsubvar;
X tp^.tsubvar := tq;
X
X iq := tq^.tidl^.tsym;
X ip := tp^.tsubid^.tsym;
X crtnvar(tp^.tsubsub);
X crtnvar(tp^.tsubstmt);
X (* process inner functions *)
X renamf(tp^.tsubsub)
X end;
X end;(* case *)
X tp := tp^.tnext
X end
X end; (* renamf *)
X
X (* This procedure rearranges the tree such that multiple *)
X (* vardeclarations don't have (structured) types attached *)
X (* to them. If such a declararation is found, a new name *)
X (* is created and the type is moved to the type section. *)
X procedure extract(tp : treeptr);
X
X var vp : treeptr;
X
X (* Create a declaration for tp, enter in pp type- *)
X (* list and return an identifier referencing it. *)
X function xtrit(tp, pp : treeptr; last : boolean) : treeptr;
X
X var np, rp : treeptr;
X ip : idptr;
X
X begin
X (* create new declaration *)
X np := mknode(ntype);
X ip := mkvariable('T');
X np^.tidl := newid(ip);
X np^.tidl^.tup := np;
X
X (* create substitute id *)
X rp := oldid(ip, lidentifier);
X rp^.tup := tp^.tup;
X rp^.tnext := tp^.tnext;
X
X (* steal type description *)
X np^.tbind := tp;
X tp^.tup := np;
X tp^.tnext := nil;
X
X (* add new declaration to tree *)
X np^.tup := pp;
X if last and (pp^.tsubtype <> nil) then
X begin
X pp := pp^.tsubtype;
X while pp^.tnext <> nil do
X pp := pp^.tnext;
X pp^.tnext := np
X end
X else begin
X np^.tnext := pp^.tsubtype;
X pp^.tsubtype := np;
X end;
X
X xtrit := rp;
X end;
X
X (* Extract anonymous enumeration types. *)
X function xtrenum(tp, pp : treeptr) : treeptr;
X
X (* Name record-types referenced by ptrs. *)
X procedure nametype(tp : treeptr);
X
X begin
X tp := typeof(tp);
X if tp^.tt = nrecord then
X if tp^.tuid = nil then
X tp^.tuid := mkvariable('S');
X end;
X
X begin
X if tp <> nil then
X begin
X case tp^.tt of
X nfield,
X ntype,
X nvar:
X tp^.tbind :=
X xtrenum(tp^.tbind, pp);
X
X nscalar:
X if tp^.tup^.tt <> ntype then
X tp := xtrit(tp, pp, false);
X
X narray:
X begin
X tp^.taindx := xtrenum(tp^.taindx, pp);
X tp^.taelem := xtrenum(tp^.taelem, pp);
X end;
X nrecord:
X begin
X tp^.tflist := xtrenum(tp^.tflist, pp);
X tp^.tvlist := xtrenum(tp^.tvlist, pp);
X end;
X nvariant:
X tp^.tvrnt := xtrenum(tp^.tvrnt, pp);
X nfileof:
X tp^.tof := xtrenum(tp^.tof, pp);
X
X nptr:
X nametype(tp^.tptrid);
X
X nid,
X nsubrange,
X npredef,
X nempty,
X nsetof:
X (* no op *)
X end;(* case *)
X tp^.tnext := xtrenum(tp^.tnext, pp)
X end;
X xtrenum := tp
X end;
X
X begin (* extract *)
X while tp <> nil do
X begin
X (* tp points to a program/procedure/function node *)
X tp^.tsubtype := xtrenum(tp^.tsubtype, tp);
X tp^.tsubvar := xtrenum(tp^.tsubvar, tp);
X vp := tp^.tsubvar;
X while vp <> nil do
X begin
X (* variables of structured unnamed types *)
X if vp^.tbind^.tt in [nscalar, narray,
X nrecord, nfileof] then
X vp^.tbind := xtrit(vp^.tbind, tp, true);
X vp := vp^.tnext
X end;
X extract(tp^.tsubsub);
X tp := tp^.tnext
X end
X end; (* extract *)
X
X (* This procedure moves all local constants and types *)
X (* used in nested procedures to the outermost declaration *)
X (* level so that nested procedures may be extracted. *)
X procedure global(tp, dp : treeptr; depend : boolean);
X
X label 555;
X
X var ip : treeptr;
X dep : boolean;
X
X (* Mark all declared identifiers as unused. *)
X procedure markdecl(xp : treeptr);
X
X begin
X while xp <> nil do
X begin
X case xp^.tt of
X nid:
X xp^.tsym^.lused := false;
X nconst:
X markdecl(xp^.tidl);
X ntype,
X nvar,
X nvalpar,
X nvarpar,
X nfield:
X begin
X markdecl(xp^.tidl);
X if xp^.tbind^.tt <> nid then
X markdecl(xp^.tbind)
X end;
X nscalar:
X markdecl(xp^.tscalid);
X nrecord:
X begin
X markdecl(xp^.tflist);
X markdecl(xp^.tvlist)
X end;
X nvariant:
X markdecl(xp^.tvrnt);
X nconfarr:
X if xp^.tcelem^.tt <> nid then
X markdecl(xp^.tcelem);
X narray:
X if xp^.taelem^.tt <> nid then
X markdecl(xp^.taelem);
X nsetof,
X nfileof:
X if xp^.tof^.tt <> nid then
X markdecl(xp^.tof);
X nparproc,
X nparfunc:
X markdecl(xp^.tparid);
X nptr,
X nsubrange:
X (* no op *)
X end;(* case *)
X xp := xp^.tnext
X end
X end; (* markdecl *)
X
X (* Move all marked declarations to global scope. *)
X function movedecl(tp : treeptr) : treeptr;
X
X var ip, np : treeptr;
X sp : symptr;
X move : boolean;
X
X begin
X if tp <> nil then
X begin
X move := false;
X case tp^.tt of
X nconst,
X ntype:
X ip := tp^.tidl
X end;(* case *)
X while ip <> nil do
X begin
X if ip^.tsym^.lused then
X begin
X move := true;
X sp := ip^.tsym;
X if sp^.lid^.inref > 1 then
X begin
X sp^.lid :=
X mkrename( 'M', sp^.lid);
X sp^.lid^.inref :=
X sp^.lid^.inref - 1
X end;
X ip := nil
X end
X else
X ip := ip^.tnext
X end;
X if move then
X begin
X np := tp^.tnext;
X tp^.tnext := nil;
X ip := tp;
X while ip^.tt <> npgm do
X ip := ip^.tup;
X tp^.tup := ip;
X case tp^.tt of
X nconst:
X begin
X if ip^.tsubconst = nil then
X ip^.tsubconst := tp
X else begin
X ip := ip^.tsubconst;
X while ip^.tnext <> nil
X do ip := ip^.tnext;
X ip^.tnext := tp
X end
X end;
X ntype:
X begin
X if ip^.tsubtype = nil then
X ip^.tsubtype := tp
X else begin
X ip := ip^.tsubtype;
X while ip^.tnext <> nil
X do ip := ip^.tnext;
X ip^.tnext := tp
X end
X end
X end;(* case *)
X (* tp is moved, drop it and process
X remainder of declarationlist *)
X tp := movedecl(np)
X end
X else
X tp^.tnext := movedecl(tp^.tnext)
X end;
X movedecl := tp
X end; (* movedecl *)
X
X (* This procedure lifts out variables/parameters *)
X (* used in nested procedures/functions. *)
X procedure movevars(tp, vp : treeptr);
X
X label 555;
X
X var ep, dp, np : treeptr;
X ip : idptr;
X sp : symptr;
X
X (* Move a variable declaration to global *)
X (* var declaration lists. *)
X procedure moveglob(tp, dp : treeptr);
X
X begin
X while tp^.tt <> npgm do
X tp := tp^.tup;
X dp^.tup := tp;
X dp^.tnext := tp^.tsubvar;
X tp^.tsubvar := dp
X end;
X
X (* Create nodes for saving a global *)
X (* pointer variable. *)
X function stackop(decl, glob, loc : treeptr) : treeptr;
X
X var op, ip, dp, tp : treeptr;
X
X begin
X (* create a new variable to hold old value
X of the global variable during a call *)
X ip := newid(mkvariable('F'));
X case vp^.tt of
X nvarpar,
X nvalpar,
X nvar:
X begin
X dp := mknode(nvarpar);
X dp^.tattr := areference;
X dp^.tidl := ip;
X (* use same type as the global var *)
X dp^.tbind := decl^.tbind
X end;
X nparproc,
X nparfunc:
X begin
X dp := mknode(vp^.tt);
X dp^.tparid := ip;
X dp^.tparparm := nil;
X dp^.tpartyp := vp^.tpartyp
X end
X end;(* case *)
X ip^.tup := dp;
X
X (* add variable to declarationlists *)
X tp := decl;
X while not (tp^.tt in [nproc, nfunc, npgm]) do
X tp := tp^.tup;
X dp^.tup := tp;
X if tp^.tsubvar = nil then
X tp^.tsubvar := dp
X else begin
X tp := tp^.tsubvar;
X while tp^.tnext <> nil do
X tp := tp^.tnext;
X tp^.tnext := dp
X end;
X dp^.tnext := nil;
X
X (* create an assignment saving value *)
X op := mknode(npush);
X op^.tglob := glob;
X op^.tloc := loc;
X op^.ttmp := ip;
X stackop := op
X end;
X
X (* Take a "push" node, create "pop" node *)
X (* and add both to tree. *)
X procedure addcode(tp, push : treeptr);
X
X var pop : treeptr;
X
X begin
X pop := mknode(npop);
X (* share variables with "push"-node *)
X pop^.tglob := push^.tglob;
X pop^.ttmp := push^.ttmp;
X pop^.tloc := nil;
X
X (* add npush to head of statement list *)
X push^.tnext := tp^.tsubstmt;
X tp^.tsubstmt := push;
X push^.tup := tp;
X
X (* add npop to end of statement list *)
X while push^.tnext <> nil do
X push := push^.tnext;
X push^.tnext := pop;
X pop^.tup := tp
X end;
X
X begin (* movevars *)
X while vp <> nil do
X begin
X case vp^.tt of
X nvar,
X nvalpar,
X nvarpar:
X dp := vp^.tidl;
X nparproc,
X nparfunc:
X begin
X dp := vp^.tparid;
X if dp^.tsym^.lused then
X begin
X (* create a var declaration *)
X ep := mknode(vp^.tt);
X ep^.tparparm := nil;
X ep^.tpartyp := vp^.tpartyp;
X np := newid(mkrename('G',
X dp^.tsym^.lid));
X ep^.tparid := np;
X np^.tup := ep;
X (* swap id's and symbols *)
X sp := np^.tsym;
X ip := sp^.lid;
X np^.tsym^.lid := dp^.tsym^.lid;
X dp^.tsym^.lid := ip;
X np^.tsym := dp^.tsym;
X dp^.tsym := sp;
X np^.tsym^.lsymdecl := np;
X dp^.tsym^.lsymdecl := dp;
X (* make declaration global *)
X moveglob(tp, ep);
X (* add save/restore-code *)
X addcode(tp, stackop(vp, np, dp))
X end;
X goto 555
X end
X end;(* case *)
X while dp <> nil do
X begin
X if dp^.tsym^.lused then
X begin
X (* create a varpar declaration,
X (nvarpar will cause emit to
X treat the new identifier
X as a pointer) *)
X ep := mknode(nvarpar);
X ep^.tattr := areference;
X np := newid(mkrename('G',
X dp^.tsym^.lid));
X ep^.tidl := np;
X np^.tup := ep;
X ep^.tbind := vp^.tbind;
X if ep^.tbind^.tt = nid then
X ep^.tbind^.tsym^.lused
X := true;
X (* swap id's and symbols *)
X sp := np^.tsym;
X ip := sp^.lid;
X np^.tsym^.lid := dp^.tsym^.lid;
X dp^.tsym^.lid := ip;
X np^.tsym := dp^.tsym;
X dp^.tsym := sp;
X np^.tsym^.lsymdecl := np;
X dp^.tsym^.lsymdecl := dp;
X (* note that dp is referenced *)
X dp^.tup^.tattr := aextern;
X (* make declaration global *)
X moveglob(tp, ep);
X (* add save/restore-code *)
X addcode(tp, stackop(vp, np, dp))
X end;
X dp := dp^.tnext
X end;
X 555:
X vp := vp^.tnext
X end
X end; (* movevars *)
X
X (* Break out a local variable and set the register *)
X (* attribute. *)
X procedure registervar(tp : treeptr);
X
X var vp, xp : treeptr;
X
X begin
X vp := idup(tp);
X tp := tp^.tsym^.lsymdecl;
X (* vp points to nvar node *)
X if (vp^.tidl <> tp) or (tp^.tnext <> nil) then
X begin
X (* tp is not alone in list of identifiers,
X create a new nvar-node and hook up tp *)
X xp := mknode(nvar);
X xp^.tattr := anone;
X xp^.tidl := tp;
X tp^.tup := xp;
X (* enter new nvar node among declarations *)
X xp^.tup := vp^.tup;
X xp^.tbind := vp^.tbind; (* borrow type *)
X xp^.tnext := vp^.tnext;
X vp^.tnext := xp;
X (* break tp out of list of identifiers *)
X if vp^.tidl = tp then
X vp^.tidl := tp^.tnext
X else begin
X vp := vp^.tidl;
X while vp^.tnext <> tp do
X vp := vp^.tnext;
X vp^.tnext := tp^.tnext
X end;
X tp^.tnext := nil
X end;
X (* tp is alone in this declaration, set attribute *)
X if tp^.tup^.tattr = anone then
X tp^.tup^.tattr := aregister
X end; (* registervar *)
X
X (* Check static declarationlevel for a label *)
X (* used in a non-local goto. *)
X procedure cklevel(tp : treeptr);
X
X begin
X tp := tp^.tsym^.lsymdecl;
X while not(tp^.tt in [npgm, nproc, nfunc]) do
X tp := tp^.tup;
X if tp^.tstat > maxlevel then
X maxlevel := tp^.tstat
X end;
X
X begin (* global *)
X while tp <> nil do
X begin
X case tp^.tt of
X nproc,
X nfunc:
X begin
X (* procid/parameters/const/type/var not used *)
X markdecl(tp^.tsubid);
X markdecl(tp^.tsubpar);
X markdecl(tp^.tsubconst);
X markdecl(tp^.tsubtype);
X markdecl(tp^.tsubvar);
X
X (* mark those used in nested subroutines *)
X global(tp^.tsubsub, tp, false);
X
X (* move out variables used in inner scope *)
X movevars(tp, tp^.tsubpar);
X movevars(tp, tp^.tsubvar);
X (* move out const/type used in inner scope *)
X tp^.tsubtype := movedecl(tp^.tsubtype);
X tp^.tsubconst := movedecl(tp^.tsubconst);
X
X (* mark identifiers used in this subroutine *)
X global(tp^.tsubstmt, tp, true);
X global(tp^.tsubpar, tp, false);
X global(tp^.tsubvar, tp, false);
X global(tp^.tsubtype, tp, false);
X global(tp^.tfuntyp, tp, false);
X end;
X
X npgm:
X begin
X markdecl(tp^.tsubconst);
X markdecl(tp^.tsubtype);
X markdecl(tp^.tsubvar);
X global(tp^.tsubsub, tp, false);
X global(tp^.tsubstmt, tp, true)
X end;
X
X nconst,
X ntype,
X nvar,
X nfield,
X nvalpar,
X nvarpar:
X begin
X ip := tp^.tidl;
X dep := depend;
X while (ip <> nil) and not dep do
X begin
X (* for all used identifiers, propagate
X the use to their bindings *)
X if ip^.tsym^.lused then
X dep := true;
X ip := ip^.tnext
X end;
X global(tp^.tbind, dp, dep);
X end;
X nparproc,
X nparfunc:
X begin
X global(tp^.tparparm, dp, depend);
X global(tp^.tpartyp, dp, depend)
X end;
X nsubrange:
X begin
X global(tp^.tlo, dp, depend);
X global(tp^.thi, dp, depend)
X end;
X nvariant:
X begin
X global(tp^.tselct, dp, depend);
X global(tp^.tvrnt, dp, depend)
X end;
X nrecord:
X begin
X global(tp^.tflist, dp, depend);
X global(tp^.tvlist, dp, depend)
X end;
X nconfarr:
X begin
X global(tp^.tcindx, dp, depend);
X global(tp^.tcelem, dp, depend)
X end;
X narray:
X begin
X global(tp^.taindx, dp, depend);
X global(tp^.taelem, dp, depend)
X end;
X nfileof,
X nsetof:
X global(tp^.tof, dp, depend);
X nptr:
X global(tp^.tptrid, dp, depend);
X nscalar:
X global(tp^.tscalid, dp, depend);
X nbegin:
X global(tp^.tbegin, dp, depend);
X nif:
X begin
X global(tp^.tifxp, dp, depend);
X global(tp^.tthen, dp, depend);
X global(tp^.telse, dp, depend)
X end;
X nwhile:
X begin
X global(tp^.twhixp, dp, depend);
X global(tp^.twhistmt, dp, depend)
X end;
X nrepeat:
X begin
X global(tp^.treptstmt, dp, depend);
X global(tp^.treptxp, dp, depend)
X end;
X nfor:
X begin
X ip := idup(tp^.tforid);
X if ip^.tup^.tt in [nproc, nfunc] then
X registervar(tp^.tforid);
X global(tp^.tforid, dp, depend);
X global(tp^.tfrom, dp, depend);
X global(tp^.tto, dp, depend);
X global(tp^.tforstmt, dp, depend)
X end;
X ncase:
X begin
X global(tp^.tcasxp, dp, depend);
X global(tp^.tcaslst, dp, depend);
X global(tp^.tcasother, dp, depend)
X end;
X nchoise:
X begin
X global(tp^.tchocon, dp, depend);
X global(tp^.tchostmt, dp, depend);
X end;
X nwith:
X begin
X global(tp^.twithvar, dp, depend);
X global(tp^.twithstmt, dp, depend)
X end;
X nwithvar:
X begin
X ip := typeof(tp^.texpw);
X if ip^.tuid = nil then
X ip^.tuid := mkvariable('S');
X global(tp^.texpw, dp, depend);
X end;
X nlabstmt:
X global(tp^.tstmt, dp, depend);
X neq, nne, nlt, nle, ngt, nge:
X begin
X global(tp^.texpl, dp, depend);
X global(tp^.texpr, dp, depend);
X ip := typeof(tp^.texpl);
X if (ip = typnods[tstring]) or
X (ip^.tt = narray) then
X usecomp := true;
X ip := typeof(tp^.texpr);
X if (ip = typnods[tstring]) or
X (ip^.tt = narray) then
X usecomp := true
X end;
X nin, nor, nplus, nminus,
X nand, nmul, ndiv, nmod, nquot,
X nformat, nrange:
X begin
X global(tp^.texpl, dp, depend);
X global(tp^.texpr, dp, depend)
X end;
X
X nassign:
X begin
X global(tp^.tlhs, dp, depend);
X global(tp^.trhs, dp, depend)
X end;
X
X nnot,
X numinus,
X nuplus,
X nderef:
X global(tp^.texps, dp, depend);
X nset:
X global(tp^.texps, dp, depend);
X nindex:
X begin
X global(tp^.tvariable, dp, depend);
X global(tp^.toffset, dp, depend)
X end;
X nselect:
X global(tp^.trecord, dp, depend);
X ncall:
X begin
X global(tp^.tcall, dp, depend);
X global(tp^.taparm, dp, depend)
X end;
X nid:
X begin
X (* find declaration point *)
X ip := idup(tp);
X if ip = nil then
X goto 555;
X (* ip points to nconst/ntype/nvar/nproc/nfunc/
X nvalpar/nvarpar/nparproc or nparfunc node,
X move to beginning of enclosing scope *)
X repeat
X ip := ip^.tup;
X if ip = nil then
X goto 555
X (* stop only for locally declared items,
X for global or predefined identifiers
X we will have gone to label 555 *)
X until ip^.tt in [npgm, nproc, nfunc];
X if dp = ip then
X begin
X (* identifier used here, mark it used *)
X if depend then
X tp^.tsym^.lused := true
X end
X else begin
X (* identifier declared in enclosing
X scope, mark it used *)
X tp^.tsym^.lused := true
X end;
X 555:
X end;
X ngoto:
X if not islocal(tp^.tlabel) then
X begin
X tp^.tlabel^.tsym^.lgo := true;
X usejmps := true;
X cklevel(tp^.tlabel)
X end;
X
X nbreak,
X npush,
X npop,
X npredef,
X nempty,
X nchar,
X ninteger,
X nreal,
X nstring,
X nnil:
X end;(* case *)
X tp := tp^.tnext
X end
X end; (* global *)
X
X (* Rename identifiers identical to C keywords. *)
X procedure renamc;
X
X var ip : idptr;
X cn : cnames;
X
X begin
X (* rename identifiers that mustn't be redefined
X if C and Pascal semantix are to be preserved *)
X for cn := cabort to cwrite do
X begin
X ip := mkrename('C', ctable[cn]);
X ctable[cn]^.istr := ip^.istr
X end
X end;
X
X (* Rename subroutines declared in other subroutines such *)
X (* that they can be moved to a global scope without name- *)
X (* clashes. *)
X procedure renamp(tp : treeptr; on : boolean);
X
X var sp : symptr;
X
X begin
X (* tp points to subroutine-list *)
X while tp <> nil do
X begin
X renamp(tp^.tsubsub, true);
X if on and (tp^.tsubstmt <> nil) then
X begin
X (* change name of subroutine by prefixing
X a unique name *)
X sp := tp^.tsubid^.tsym;
X if sp^.lid^.inref > 1 then
X begin
X sp^.lid := mkrename('P', sp^.lid);
X sp^.lid^.inref := sp^.lid^.inref - 1
X end
X end;
X tp := tp^.tnext
X end
X end;
X
X (* Add initialization-code for file-variables. *)
X procedure initcode(tp : treeptr);
X
X var ti, tq, tu, tv : treeptr;
X
X (* Determine if a type contains a file. *)
X function filevar(tp : treeptr) : boolean;
X
X var fv : boolean;
X tq : treeptr;
X
X begin
X case tp^.tt of
X npredef:
X fv := tp = typnods[ttext];
X nfileof:
X fv := true;
X nconfarr:
X fv := filevar(typeof(tp^.tcelem));
X narray:
X fv := filevar(typeof(tp^.taelem));
X nrecord:
X begin
X fv := false;
X tq := tp^.tvlist;
X while tq <> nil do
X begin
X if filevar(tq^.tvrnt) then
X error(evrntfile);
X tq := tq^.tnext
X end;
X tq := tp^.tflist;
X while tq <> nil do
X begin
X if filevar(typeof(tq^.tbind)) then
X begin
X fv := true;
X tq := nil
X end
X else
X tq := tq^.tnext
X end
X end;
X nptr:
X begin
X fv := false;
X if not tp^.tptrflag then
X begin
X tp^.tptrflag := true;
X if filevar(typeof(tp^.tptrid)) then
X error(evarfile);
X tp^.tptrflag := false
X end
X end;
X nsubrange,
X nscalar,
X nsetof:
X fv := false
X end;
X filevar := fv
X end;
X
X (* Create code for initialization of files. *)
X function fileinit(ti, tq : treeptr; opn : boolean) : treeptr;
X
X var tx, ty, tz : treeptr;
X
X begin
X (* create 1 statement initializing "ti" *)
X case tq^.tt of
X narray:
X begin
X (* create declaration for a loopvariable *)
X tz := newid(mkvariable('I'));
X ty := mknode(nvar);
X ty^.tattr := aregister;
X ty^.tidl := tz;
X ty^.tbind := typeof(tq^.taindx);
X tz := tq;
X while not(tz^.tt in [nproc, nfunc, npgm]) do
X tz := tz^.tup;
X linkup(tz, ty);
X if tz^.tsubvar = nil then
X tz^.tsubvar := ty
X else begin
X tz := tz^.tsubvar;
X while tz^.tnext <> nil do
X tz := tz^.tnext;
X tz^.tnext := ty
X end;
X ty := ty^.tidl;
X (* create a loop initializing tq *)
X tz := mknode(nindex);
X tz^.tvariable := ti;
X tz^.toffset := ty;
X tz := fileinit(tz, tq^.taelem, opn);
X tx := mknode(nfor);
X tx^.tforid := ty;
X ty := typeof(tq^.taindx);
X if ty^.tt = nsubrange then
X begin
X tx^.tfrom := ty^.tlo;
X
END_OF_FILE
if test 52771 -ne `wc -c <'ptc.p.2'`; then
echo shar: \"'ptc.p.2'\" unpacked with wrong size!
fi
# end of 'ptc.p.2'
fi
echo shar: End of archive 10 \(of 12\).
cp /dev/null ark10isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 12 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Rich $alz "Anger is an energy"
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uu.net