rs@uunet.UU.NET (Rich Salz) (07/28/87)
Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 73
Archive-name: ptoc/Part09
#! /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 9 (of 12)."
# Contents: ptc.p.3
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'ptc.p.3' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ptc.p.3'\"
else
echo shar: Extracting \"'ptc.p.3'\" \(50280 characters\)
sed "s/^X//" >'ptc.p.3' <<'END_OF_FILE'
X tx^.tto := ty^.thi
X end
X else if ty^.tt = nscalar then
X begin
X ty := ty^.tscalid;
X tx^.tfrom := ty;
X while ty^.tnext <> nil do
X ty := ty^.tnext;
X tx^.tto := ty
X end
X else if ty = typnods[tchar] then
X begin
X currsym.st := schar;
X currsym.vchr := chr(minchar);
X tx^.tfrom := mklit;
X currsym.st := schar;
X currsym.vchr := chr(maxchar);
X tx^.tto := mklit
X end
X else if ty = typnods[tinteger] then
X begin
X currsym.st := sinteger;
X currsym.vint := -maxint;
X tx^.tfrom := mklit;
X currsym.st := sinteger;
X currsym.vint := maxint;
X tx^.tto := mklit
X end
X else
X fatal(etree);
X tx^.tforstmt := tz;
X tx^.tincr := true
X end;
X npredef,
X nfileof:
X if opn then
X begin
X (* create file-struct initialization *)
X ty := mknode(nselect);
X ty^.trecord := ti;
X ty^.tfield :=
X oldid(defnams[dzinit]^.lid,
X lforward);
X tx := mknode(nassign);
X tx^.tlhs := ty;
X currsym.st := sinteger;
X currsym.vint := 0;
X tx^.trhs := mklit
X end
X else begin
X (* create file-struct wrapup *)
X tx := mknode(ncall);
X tx^.tcall :=
X oldid(defnams[dclose]^.lid,
X lidentifier);
X tx^.taparm := ti
X end;
X nrecord:
X begin
X ty := nil;
X tq := tq^.tflist;
X while tq <> nil do
X begin
X if filevar(typeof(tq^.tbind)) then
X begin
X tz := tq^.tidl;
X while tz <> nil do
X begin
X tx := mknode(nselect);
X tx^.trecord := ti;
X tx^.tfield := tz;
X tx := fileinit(tx,
X typeof(tq^.tbind),
X opn);
X tx^.tnext := ty;
X ty := tx;
X tz := tz^.tnext
X end
X end;
X tq := tq^.tnext
X end;
X tx := mknode(nbegin);
X tx^.tbegin := ty
X end;
X end;(* case *)
X fileinit := tx
X end;
X
X begin (* initcode *)
X while tp <> nil do
X begin
X initcode(tp^.tsubsub);
X tv := tp^.tsubvar;
X while tv <> nil do
X begin
X tq := typeof(tv^.tbind);
X if filevar(tq) then
X begin
X ti := tv^.tidl;
X while ti <> nil do
X begin
X tu := fileinit(ti, tq, true);
X linkup(tp, tu);
X tu^.tnext := tp^.tsubstmt;
X tp^.tsubstmt := tu;
X while tu^.tnext <> nil do
X tu := tu^.tnext;
X tu^.tnext := fileinit(ti, tq,
X false);
X linkup(tp, tu^.tnext);
X ti := ti^.tnext
X end
X end;
X tv := tv^.tnext;
X end;
X tp := tp^.tnext
X end
X end; (* initcode *)
X
Xbegin (* transform *)
X renamc;
X renamp(top^.tsubsub, false);
X extract(top);
X renamf(top);
X initcode(top^.tsubsub);
X global(top, top, false)
Xend; (* transform *)
X
X(* Emit C-code for program or module. *)
Xprocedure emit;
X
Xconst include = '# include ';
X define = '# define ';
X ifdef = '# ifdef ';
X ifndef = '# ifndef ';
X elsif = '# else';
X endif = '# endif';
X static = 'static ';
X xtern = 'extern ';
X typdef = 'typedef ';
X registr = 'register ';
X usigned = 'unsigned ';
X indstep = 8;
X
Xvar conflag,
X setused,
X dropset,
X donearr : boolean;
X doarrow,
X indnt : integer;
X
X procedure increment;
X begin
X indnt := indnt + indstep
X end;
X
X procedure decrement;
X begin
X indnt := indnt - indstep
X end;
X
X (* Write tabs/blanks to properly (?) indent C-code. *)
X procedure indent;
X
X var i : integer;
X
X begin
X i := indnt;
X (* limit indent to an integral number of tabs *)
X if i > 60 then
X i := i div tabwidth * tabwidth;
X while i >= tabwidth do
X begin
X write(tab1);
X i := i - tabwidth
X end;
X while i > 0 do
X begin
X write(space);
X i := i - 1
X end;
X end;
X
X (* Determine if tp must be cast to an integer before being *)
X (* used in an arithmetic expression. *)
X function arithexpr(tp : treeptr) : boolean;
X
X begin
X tp := typeof(tp);
X if tp^.tt = nsubrange then
X if tp^.tup^.tt = nconfarr then
X tp := typeof(tp^.tup^.tindtyp)
X else
X tp := typeof(tp^.tlo);
X arithexpr := (tp = typnods[tinteger]) or
X (tp = typnods[tchar]) or
X (tp = typnods[treal])
X end;
X
X procedure eexpr(tp : treeptr); forward;
X procedure etypedef(tp : treeptr); forward;
X
X (* Emit code to select a record member. *)
X procedure eselect(tp : treeptr);
X
X begin
X doarrow := doarrow + 1;
X eexpr(tp);
X doarrow := doarrow - 1;
X if donearr then
X donearr := false
X else
X write('.')
X end;
X
X (* Emit code for call to a predefined function/procedure. *)
X procedure epredef(ts, tp : treeptr);
X
X label 444, 555;
X
X var tq,
X tv, tx : treeptr;
X td : predefs;
X nelems : integer;
X ch : char;
X txtfile : boolean;
X
X (* Determine a format-code for fprintf. *)
X (* Update nelems as a sideeffect. *)
X function typeletter(tp : treeptr) : char;
X
X label 999;
X
X var tq : treeptr;
X
X begin
X tq := tp;
X if tq^.tt = nformat then
X begin
X if tq^.texpl^.tt = nformat then
X begin
X typeletter := 'f';
X goto 999
X end;
X tq := tp^.texpl
X end;
X tq := typeof(tq);
X if tq^.tt = nsubrange then
X tq := typeof(tq^.tlo);
X if tq = typnods[tstring] then
X typeletter := 's'
X else if tq = typnods[tinteger] then
X typeletter := 'd'
X else if tq = typnods[tchar] then
X typeletter := 'c'
X else if tq = typnods[treal] then
X if tp^.tt = nformat then
X typeletter := 'e'
X else
X typeletter := 'g'
X else if tq = typnods[tboolean] then
X begin
X typeletter := 'b';
X nelems := 6
X end
X else if tq^.tt = narray then
X begin
X typeletter := 'a';
X nelems := crange(tq^.taindx)
X end
X else if tq^.tt = nconfarr then
X begin
X typeletter := 'v';
X nelems := 0
X end
X else
X fatal(etree);
X 999:
X end; (* typeletter *)
X
X procedure etxt(tp : treeptr);
X
X var w : toknbuf;
X c : char;
X i : toknidx;
X
X begin
X case tp^.tt of
X nid:
X begin
X tp := idup(tp);
X if tp^.tt = nconst then
X etxt(tp^.tbind)
X else
X fatal(etree)
X end;
X nstring:
X begin
X (* printf format string *)
X gettokn(tp^.tsym^.lstr, w);
X i := 1;
X while w[i] <> chr(null) do
X begin
X c := w[i];
X if (c = cite) or (c = bslash) then
X write(bslash)
X else if c = percent then
X write(percent);
X write(c);
X i := i + 1
X end
X end;
X nchar:
X begin
X (* single character in printf format *)
X c := tp^.tsym^.lchar;
X if (c = cite) or (c = bslash) then
X write(bslash)
X else if c = percent then
X write(percent);
X write(c)
X end;
X end;(* case *)
X end; (* etxt *)
X
X (* Emit format for fprintf. *)
X procedure eformat(tq : treeptr);
X
X var tx : treeptr;
X i : integer;
X
X begin
X case typeletter(tq) of
X 'a':
X begin
X write(percent);
X if tq^.tt = nformat then
X if tq^.texpr^.tt = ninteger then
X eexpr(tq^.texpr)
X else
X write('*');
X write('.', nelems:1, 's')
X end;
X 'b':
X begin
X write(percent);
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt = ninteger then
X eexpr(tq^.texpr)
X else
X write('*')
X end;
X write('s')
X end;
X 'c':
X if tq^.tt = nchar then
X etxt(tq)
X else begin
X write(percent);
X if tq^.tt = nformat then
X if tq^.texpr^.tt = ninteger then
X eexpr(tq^.texpr)
X else
X write('*');
X write('c')
X end;
X 'd':
X begin
X write(percent);
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt = ninteger then
X eexpr(tq^.texpr)
X else
X write('*')
X end
X else
X write(intlen:1);
X write('d')
X end;
X 'e':
X begin
X write(percent, space);
X tx := tq^.texpr;
X if tx^.tt = ninteger then
X begin
X i := cvalof(tx);
X write(i:1, '.');
X i := i - 7;
X if i < 1 then
X write('1')
X else
X write(i:1)
X end
X else
X write('*.*');
X write('e')
X end;
X 'f':
X begin
X write(percent);
X tx := tq^.texpl;
X if tx^.texpr^.tt = ninteger then
X begin
X eexpr(tx^.texpr);
X write('.');
X tx := tq^.texpr;
X if tx^.tt = ninteger then
X begin
X i := cvalof(tx);
X tx := tq^.texpl^.texpr;
X if i > cvalof(tx) - 1 then
X write('1')
X else
X write(i:1)
X end
X else
X write('*');
X end
X else
X write('*.*');
X write('f')
X end;
X 'g':
X write(percent, fixlen:1, 'e');
X 's':
X if tq^.tt = nstring then
X etxt(tq)
X else begin
X write(percent);
X if tq^.tt = nformat then
X if tq^.texpr^.tt = ninteger then
X eexpr(tq^.texpr)
X else
X write('*.*');
X write('s')
X end
X end (* case *)
X end; (* eformat *)
X
X (* Emit parameters to fprintf except format. *)
X procedure ewrite(tq : treeptr);
X
X var tx : treeptr;
X
X begin
X case typeletter(tq) of
X 'a':
X begin
X write(', ');
X tx := tq;
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt <> ninteger then
X begin
X eexpr(tq^.texpr);
X write(', ')
X end;
X tx := tq^.texpl
X end;
X eexpr(tx);
X write('.A')
X end;
X 'b':
X begin
X write(', ');
X tx := tq;
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt <> ninteger then
X begin
X eexpr(tq^.texpr);
X write(', ')
X end;
X tx := tq^.texpl
X end;
X usebool := true;
X write('Bools[(int)(');
X eexpr(tx);
X write(')]')
X end;
X 'c':
X begin
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt <> ninteger then
X begin
X write(', ');
X eexpr(tq^.texpr)
X end;
X write(', ');
X eexpr(tq^.texpl)
X end
X else if tq^.tt <> nchar then
X begin
X write(', ');
X eexpr(tq)
X end
X end;
X 'd':
X begin
X write(', ');
X tx := tq;
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt <> ninteger then
X begin
X eexpr(tq^.texpr);
X write(', ')
X end;
X tx := tq^.texpl
X end;
X eexpr(tx)
X end;
X 'e':
X begin
X write(', ');
X tx := tq^.texpr;
X if tx^.tt <> ninteger then
X begin
X usemax := true;
X eexpr(tx);
X write(', Max(');
X eexpr(tx);
X write(' - 7, 1), ')
X end;
X eexpr(tq^.texpl)
X end;
X 'f':
X begin
X write(', ');
X tx := tq^.texpl;
X if tx^.texpr^.tt <> ninteger then
X begin
X eexpr(tx^.texpr);
X write(', ')
X end;
X if (tx^.texpr^.tt <> ninteger) or
X (tq^.texpr^.tt <> ninteger) then
X begin
X usemax := true;
X write('Max((');
X eexpr(tx^.texpr);
X write(') - (');
X eexpr(tq^.texpr);
X write(') - 1, 1), ')
X end;
X eexpr(tq^.texpl^.texpl)
X end;
X 'g':
X begin
X write(', ');
X eexpr(tq)
X end;
X 's':
X begin
X if tq^.tt = nformat then
X begin
X if tq^.texpr^.tt <> ninteger then
X begin
X write(', ');
X eexpr(tq^.texpr);
X write(', ');
X eexpr(tq^.texpr)
X end;
X write(', ');
X eexpr(tq^.texpl)
X end
X else if tq^.tt <> nstring then
X begin
X write(', ');
X eexpr(tq)
X end
X end
X end (* case *)
X end; (* ewrite *)
X
X (* Emit size of *tp for call to malloc. CPU *)
X (* There is no safe way to compute the size of a *)
X (* particular variant of a C-union, we assume that *)
X (* the size can be computed by taking the address *)
X (* of the first member and subracting the address *)
X (* of the record and then adding the size of the *)
X (* variant containing the record. *)
X procedure enewsize(tp : treeptr);
X
X label 555;
X
X var tq, tx, ty : treeptr;
X v : integer;
X
X (* Emit size of union member tq. *)
X procedure esubsize(tp, tq : treeptr);
X
X label 555, 666;
X
X var tx, ty : treeptr;
X addsize : boolean;
X
X begin
X tx := tq^.tvrnt;
X ty := tx^.tflist;
X if ty = nil then
X begin
X ty := tx^.tvlist;
X while ty <> nil do
X begin
X if ty^.tvrnt^.tflist <> nil then
X begin
X ty := ty^.tvrnt^.tflist;
X goto 555
X end;
X ty := ty^.tnext
X end;
X 555:
X end;
X addsize := true;
X if ty = nil then
X begin
X (* empty variant, try using another *)
X addsize := false;
X ty := tx^.tup^.tup^.tvlist;
X while ty <> nil do
X begin
X if ty^.tvrnt^.tflist <> nil then
X begin
X ty := ty^.tvrnt^.tflist;
X goto 666
X end;
X ty := ty^.tnext
X end;
X 666:
X end;
X if ty = nil then
X begin
X (* its getting too complicated,
X ignore tag value *)
X write('sizeof(*');
X eexpr(tp);
X write(')')
X end
X else begin
X (* compute offset to first member of
X the selected union variant *)
X write('Unionoffs(');
X eexpr(tp);
X write(', ');
X printid(ty^.tidl^.tsym^.lid);
X if addsize then
X begin
X (* add the size of the selected
X union variant *)
X write(') + sizeof(');
X eexpr(tp);
X write('->');
X printid(tx^.tuid)
X end;
X write(')')
X end
X end;
X
X begin (* newsize *)
X if (tp^.tnext <> nil) and unionnew then
X begin
X (* tnext points to a tag-value, evaluate it *)
X v := cvalof(tp^.tnext);
X (* find union type *)
X tq := typeof(tp);
X tq := typeof(tq^.tptrid);
X if tq^.tt <> nrecord then
X fatal(etree);
X (* find corresponding variant *)
X tx := tq^.tvlist;
X while tx <> nil do
X begin
X ty := tx^.tselct;
X while ty <> nil do
X begin
X if v = cvalof(ty) then
X goto 555;
X ty := ty^.tnext
X end;
X tx := tx^.tnext
X end;
X fatal(etag);
X 555:
X (* emit size for that variant *)
X esubsize(tp, tx)
X end
X else begin
X write('sizeof(*');
X eexpr(tp);
X write(')')
X end
X end; (* newsize *)
X
X begin (* epredef *)
X td := ts^.tsubstmt^.tdef;
X case td of
X dabs:
X begin
X tq := typeof(tp^.taparm);
X if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
X write('abs(') (* LIB *)
X else
X write('fabs('); (* LIB *)
X eexpr(tp^.taparm);
X write(')')
X end;
X dargv:
X begin
X write('Argvgt(');
X eexpr(tp^.taparm);
X write(', ');
X eexpr(tp^.taparm^.tnext);
X write('.A, sizeof(');
X eexpr(tp^.taparm^.tnext);
X writeln('.A));')
X end;
X dchr:
X begin
X tq := typeof(tp^.taparm);
X if tq^.tt = nsubrange then
X if tq^.tup^.tt = nconfarr then
X tq := typeof(tq^.tup^.tindtyp)
X else
X tq := typeof(tq^.tlo);
X if (tq = typnods[tinteger]) or
X (tq = typnods[tchar]) then
X eexpr(tp^.taparm)
X else begin
X write('(char)(');
X eexpr(tp^.taparm);
X write(')')
X end
X end;
X ddispose:
X begin
X write('free('); (* LIB *)
X eexpr(tp^.taparm);
X writeln(');')
X end;
X deof:
X begin
X write('Eof(');
X if tp^.taparm = nil then
X begin
X defnams[dinput]^.lused := true;
X printid(defnams[dinput]^.lid)
X end
X else
X eexpr(tp^.taparm);
X write(')')
X end;
X deoln:
X begin
X write('Eoln(');
X if tp^.taparm = nil then
X begin
X defnams[dinput]^.lused := true;
X printid(defnams[dinput]^.lid)
X end
X else
X eexpr(tp^.taparm);
X write(')');
X end;
X dexit:
X begin
X write('exit('); (* OS *)
X if tp^.taparm = nil then
X write('0')
X else
X eexpr(tp^.taparm);
X writeln(');');
X end;
X dflush:
X begin
X write('fflush('); (* LIB *)
X if tp^.taparm = nil then
X begin
X defnams[doutput]^.lused := true;
X printid(defnams[doutput]^.lid)
X end
X else
X eexpr(tp^.taparm);
X writeln('.fp);')
X end;
X dpage:
X begin
X (* write form-feed character *)
X write('Putchr(', ffchr, ', '); (* CHAR *)
X if tp^.taparm = nil then
X begin
X defnams[doutput]^.lused := true;
X printid(defnams[doutput]^.lid)
X end
X else
X eexpr(tp^.taparm);
X writeln(');');
X end;
X dput,
X dget:
X begin
X if typeof(tp^.taparm) = typnods[ttext] then
X if td = dget then
X write('Getx')
X else
X write('Putx')
X else begin
X write(voidcast);
X if td = dget then
X write('Get')
X else
X write('Put')
X end;
X write('(');
X eexpr(tp^.taparm);
X writeln(');')
X end;
X dhalt:
X writeln('abort();'); (* OS *)
X dnew:
X begin
X eexpr(tp^.taparm);
X write(' = (');
X etypedef(typeof(tp^.taparm));
X write(')malloc((unsigned)('); (* LIB *)
X enewsize(tp^.taparm);
X writeln('));')
X end;
X dord:
X begin
X write('(unsigned)(');
X eexpr(tp^.taparm);
X write(')')
X end;
X dread,
X dreadln:
X begin
X txtfile := false;
X tq := tp^.taparm;
X if tq <> nil then
X begin
X tv := typeof(tq);
X if tv = typnods[ttext] then
X begin
X (* reading from textfile *)
X txtfile := true;
X tv := tq;
X tq := tq^.tnext
X end
X else if tv^.tt = nfileof then
X begin
X (* reading from other file *)
X txtfile := typeof(tv^.tof) =
X typnods[tchar];
X tv := tq;
X tq := tq^.tnext
X end
X else begin
X (* reading from std-input *)
X txtfile := true;
X tv := nil
X end
X end
X else begin
X tv := nil;
X txtfile := true
X end;
X if txtfile then
X begin
X (* check for special case *)
X if tq = nil then
X goto 444;
X if (tq^.tt <> nformat) and
X (tq^.tnext = nil) and
X (typeletter(tq) = 'c') then
X begin
X (* read single char *)
X eexpr(tq);
X write(' = ');
X write('Getchr(');
X if tv = nil then
X printid(defnams[dinput]^.lid)
X else
X eexpr(tv);
X write(')');
X if td = dreadln then
X write(',');
X goto 444
X end;
X usescan := true;
X write('Fscan(');
X if tv = nil then
X printid(defnams[dinput]^.lid)
X else
X eexpr(tv);
X write('), ');
X (* first pass, emit format string *)
X while tq <> nil do
X begin
X write('Scan(', cite);
X ch := typeletter(tq);
X case ch of
X 'a':
X write(percent, 's');
X 'c':
X write(percent, 'c');
X 'd':
X write(percent, 'ld');
X 'g':
X write(percent, 'le')
X end;(* case *)
X write(cite, ', ');
X case ch of
X 'a':
X begin
X eexpr(tq);
X write('.A')
X end;
X 'c':
X begin
X write('&');
X eexpr(tq)
X end;
X 'd':
X write('&Tmplng');
X 'g':
X write('&Tmpdbl')
X end;(* case *)
X write(')');
X case ch of
X 'd':
X begin
X write(', ');
X eexpr(tq);
X write(' = Tmplng')
X end;
X 'g':
X begin
X write(', ');
X eexpr(tq);
X write(' = Tmpdbl')
X end;
X 'a',
X 'c':
X (* no op *)
X end;(* case *)
X tq := tq^.tnext;
X if tq <> nil then
X begin
X writeln(',');
X indent;
X write(tab1)
X end
X end;
X write(', Getx(');
X if tv = nil then
X printid(defnams[dinput]^.lid)
X else
X eexpr(tv);
X write(')');
X if td = dreadln then
X write(',');
X 444:
X if td = dreadln then
X begin
X usegetl := true;
X write('Getl(&');
X if tv = nil then
X printid(defnams[dinput]^.lid)
X else
X eexpr(tv);
X write(')')
X end
X end
X else begin
X increment;
X while tq <> nil do
X begin
X write(voidcast, 'Fread(');
X eexpr(tq);
X write(', ');
X eexpr(tv);
X write('.fp)');
X tq := tq^.tnext;
X if tq <> nil then
X begin
X writeln(',');
X indent
X end
X end;
X decrement
X end;
X writeln(';')
X end;
X dwrite,
X dwriteln,
X dmessage:
X begin
X txtfile := false;
X tq := tp^.taparm;
X if tq <> nil then
X begin
X tv := typeof(tq);
X if tv = typnods[ttext] then
X begin
X (* writing to textfile *)
X txtfile := true;
X tv := tq;
X tq := tq^.tnext
X end
X else if tv^.tt = nfileof then
X begin
X (* writing to other file *)
X txtfile := typeof(tv^.tof) =
X typnods[tchar];
X tv := tq;
X tq := tq^.tnext
X end
X else begin
X (* writing to std-output *)
X txtfile := true;
X tv := nil
X end
X end
X else begin
X tv := nil;
X txtfile := true
X end;
X if txtfile then
X begin
X (* check for special case *)
X if tq = nil then
X begin
X (* writeln whithout parameters *)
X if td in [dwriteln, dmessage] then
X begin
X write('Putchr(', nlchr, ', ');
X if tv = nil then
X printid(
X defnams[doutput]^.lid)
X else
X eexpr(tv);
X write(')')
X end;
X writeln(';');
X goto 555
X end
X else if (tq^.tt <> nformat) and
X (tq^.tnext = nil) then
X if typeletter(tq) = 'c' then
X begin
X (* print single char *)
X write('Putchr(');
X eexpr(tq);
X write(', ');
X if tv = nil then
X printid(
X defnams[doutput]^.lid)
X else
X eexpr(tv);
X write(')');
X if td = dwriteln then
X begin
X write(',Putchr(',
X nlchr, ', ');
X if tv = nil then
X printid(
X defnams[doutput]^.lid)
X else
X eexpr(tv);
X write(')');
X end;
X writeln(';');
X goto 555
X end;
X tx := nil;
X write(voidcast, 'fprintf('); (* LIB *)
X if td = dmessage then
X write('stderr, ')
X else begin
X if tv = nil then
X printid(defnams[doutput]^.lid)
X else
X eexpr(tv);
X write('.fp, ')
X end;
X write(cite);
X tx := tq; (* remember 1:st parm *)
X (* first pass, emit format string *)
X while tq <> nil do
X begin
X eformat(tq);
X tq := tq^.tnext
X end;
X if (td = dmessage) or (td = dwriteln) then
X write('\n');
X write(cite);
X (* second pass, add parameters *)
X tq := tx;
X while tq <> nil do
X begin
X ewrite(tq);
X tq := tq^.tnext
X end;
X write('), Putl(');
X if tv = nil then
X printid(defnams[doutput]^.lid)
X else
X eexpr(tv);
X if td = dwrite then
X write(', 0)')
X else
X write(', 1)')
X end
X else begin
X increment;
X tx := typeof(tv);
X if tx = typnods[ttext] then
X tx := typnods[tchar]
X else if tx^.tt = nfileof then
X tx := typeof(tx^.tof)
X else
X fatal(etree);
X while tq <> nil do
X begin
X if (tq^.tt in [nid, nindex, nselect,
X nderef]) and
X (tx = typeof(tq)) then
X begin
X write(voidcast, 'Fwrite(');
X eexpr(tq)
X end
X else begin
X if tx^.tt = nsetof then
X begin
X usescpy := true;
X write('Setncpy(');
X eselect(tv);
X write('buf.S, ');
X eexpr(tq);
X if typeof(tp^.trhs) =
X typnods[tset] then
X eexpr(tq)
X else begin
X eselect(tq);
X write('S')
X end;
X write(', sizeof(');
X eexpr(tv);
X write('.buf))');
X end
X else begin
X eexpr(tv);
X write('.buf = ');
X eexpr(tq)
X end;
X write(', Fwrite(');
X eexpr(tv);
X write('.buf');
X end;
X write(', ');
X eexpr(tv);
X write('.fp)');
X tq := tq^.tnext;
X if tq <> nil then
X begin
X writeln(',');
X indent
X end
X end;
X decrement
X end;
X writeln(';');
X 555:
X end;
X dclose:
X begin
X tq := typeof(tp^.taparm);
X txtfile := tq = typnods[ttext];
X if (not txtfile) and (tq^.tt = nfileof) then
X if typeof(tq^.tof) = typnods[tchar] then
X txtfile := true;
X if txtfile then
X write('Closex(')
X else
X write('Close(');
X eexpr(tp^.taparm);
X writeln(');');
X end;
X dreset,
X drewrite:
X begin
X tq := typeof(tp^.taparm);
X txtfile := tq = typnods[ttext];
X if (not txtfile) and (tq^.tt = nfileof) then
X if typeof(tq^.tof) = typnods[tchar] then
X txtfile := true;
X if txtfile then
X if td = dreset then
X write('Resetx(')
X else
X write('Rewritex(')
X else
X if td = dreset then
X write('Reset(')
X else
X write('Rewrite(');
X eexpr(tp^.taparm);
X write(', ');
X tq := tp^.taparm^.tnext;
X if tq = nil then
X write('NULL')
X else begin
X tq := typeof(tq);
X if tq = typnods[tchar] then
X begin
X write(cite);
X ch := chr(cvalof(tp^.taparm^.tnext));
X if (ch = bslash) or (ch = cite) then
X write(bslash);
X write(ch, cite)
X end
X else if tq = typnods[tstring] then
X eexpr(tp^.taparm^.tnext)
X else if tq^.tt in [narray, nconfarr] then
X begin
X eexpr(tp^.taparm^.tnext);
X write('.A')
X end
X else
X fatal(etree)
X end;
X writeln(');')
X end;
X darctan:
X begin
X write('atan('); (* LIB *)
X if typeof(tp^.taparm) <> typnods[treal] then
X write(dblcast);
X eexpr(tp^.taparm);
X write(')')
X end;
X dln:
X begin
X write('log('); (* LIB *)
X if typeof(tp^.taparm) <> typnods[treal] then
X write(dblcast);
X eexpr(tp^.taparm);
X write(')')
X end;
X dexp:
X begin
X write('exp('); (* LIB *)
X if typeof(tp^.taparm) <> typnods[treal] then
X write(dblcast);
X eexpr(tp^.taparm);
X write(')')
X end;
X dcos,
X dsin,
X dsqrt:
X begin
X eexpr(tp^.tcall); (* LIB *)
X write('(');
X if typeof(tp^.taparm) <> typnods[treal] then
X write(dblcast);
X eexpr(tp^.taparm);
X write(')')
X end;
X dtan:
X begin
X write('atan('); (* LIB *)
X if typeof(tp^.taparm) <> typnods[treal] then
X write(dblcast);
X eexpr(tp^.taparm);
X write(')')
X end;
X dsucc,
X dpred:
X begin
X tq := typeof(tp^.taparm);
X if tq^.tt = nsubrange then
X if tq^.tup^.tt = nconfarr then
X tq := typeof(tq^.tup^.tindtyp)
X else
X tq := typeof(tq^.tlo);
X if (tq = typnods[tinteger]) or
X (tq = typnods[tchar]) then
X begin
X write('((');
X eexpr(tp^.taparm);
X if td = dpred then
X write(')-1)')
X else
X write(')+1)')
X end
X else begin
X (* some sort of scalar type, casting needed *)
X write('(');
X tq := tq^.tup;
X if tq^.tt = ntype then
X begin
X (* cast only if it is a named type *)
X write('(');
X printid(tq^.tidl^.tsym^.lid);
X write(')')
X end;
X write('((int)(');
X eexpr(tp^.taparm);
X if td = dpred then
X write(')-1))')
X else
X write(')+1))')
X end
X end;
X dodd:
X begin
X write('(');
X printid(defnams[dboolean]^.lid);
X write(')((');
X eexpr(tp^.taparm);
X write(') & 1)')
X end;
X dsqr:
X begin
X tq := typeof(tp^.taparm);
X if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
X begin
X write('((');
X eexpr(tp^.taparm);
X write(') * (');
X eexpr(tp^.taparm);
X write('))')
X end
X else begin
X write('pow('); (* LIB *)
X if typeof(tp^.taparm) <> typnods[treal] then
X write(dblcast);
X eexpr(tp^.taparm);
X write(', 2.0)')
X end
X end;
X dround:
X begin
X write('Round(');
X eexpr(tp^.taparm);
X write(')')
X end;
X dtrunc:
X begin
X write('Trunc(');
X eexpr(tp^.taparm);
X write(')')
X end;
X dpack:
X begin
X tq := typeof(tp^.taparm);
X tx := typeof(tp^.taparm^.tnext^.tnext);
X write('{ ', registr, inttyp, tab1, '_j, _i = ');
X if not arithexpr(tp^.taparm^.tnext) then
X write('(int)');
X eexpr(tp^.taparm^.tnext);
X if tx^.tt = narray then
X write(' - ', clower(tq^.taindx):1);
X writeln(';');
X indent;
X write(' for (_j = 0; _j < ');
X if tq^.tt = nconfarr then
X begin
X write('(int)(');
X printid(tx^.tcindx^.thi^.tsym^.lid);
X write(')')
X end
X else
X write(crange(tx^.taindx):1);
X writeln('; )');
X indent;
X write(tab1);
X eexpr(tp^.taparm^.tnext^.tnext);
X write('.A[_j++] = ');
X eexpr(tp^.taparm);
X writeln('.A[_i++];');
X indent;
X writeln('}')
X end;
X dunpack:
X begin
X tq := typeof(tp^.taparm);
X tx := typeof(tp^.taparm^.tnext);
X write('{ ', registr, inttyp, tab1, '_j, _i = ');
X if not arithexpr(tp^.taparm^.tnext^.tnext) then
X write('(int)');
X eexpr(tp^.taparm^.tnext^.tnext);
X if tx^.tt <> nconfarr then
X write(' - ', clower(tx^.taindx):1);
X writeln(';');
X indent;
X write(' for (_j = 0; _j < ');
X if tq^.tt = nconfarr then
X begin
X write('(int)(');
X printid(tq^.tcindx^.thi^.tsym^.lid);
X write(')')
X end
X else
X write(crange(tq^.taindx):1);
X writeln('; )');
X indent;
X write(tab1);
X eexpr(tp^.taparm^.tnext);
X write('.A[_i++] = ');
X eexpr(tp^.taparm);
X writeln('.A[_j++];');
X indent;
X writeln('}')
X end;
X end (* case *)
X end; (* epredef *)
X
X procedure eaddr(tp : treeptr);
X
X begin
X write('&');
X if not(tp^.tt in [nid, nselect, nindex, nderef]) then
X error(evarpar);
X eexpr(tp)
X end;
X
X (* Emit code for a subroutine call. *)
X procedure ecall(tp : treeptr);
X
X var tf, tq, tx : treeptr;
X
X begin
X (* find first formal parameter id *)
X tf := idup(tp^.tcall);
X case tf^.tt of
X nproc,
X nfunc:
X tf := tf^.tsubpar;
X nparproc,
X nparfunc:
X tf := tf^.tparparm
X end;(* case *)
X if tf <> nil then
X begin
X case tf^.tt of
X nvalpar,
X nvarpar:
X tf := tf^.tidl;
X nparproc,
X nparfunc:
X tf := tf^.tparid
X end (* case *)
X end;
X (* emit called function name *)
X eexpr(tp^.tcall);
X write('(');
X (* emit actual parameters *)
X tq := tp^.taparm;
X while tq <> nil do
X begin
X if tf^.tup^.tt in [nparfunc, nparproc] then
X begin
X (* single subroutine-nid converted to ncall *)
X if tq^.tt = ncall then
X printid(tq^.tcall^.tsym^.lid)
X else
X printid(tq^.tsym^.lid)
X end
X else begin
X tx := typeof(tq);
X if tx = typnods[tboolean] then
X begin
X tx := tq;
X while tx^.tt = nuplus do
X tx := tx^.texps;
X if tx^.tt in [nin .. nor, nand, nnot]
X then
X begin
X write('(');
X printid(defnams[dboolean]^.lid);
X write(')(');
X eexpr(tq);
X write(')')
X end
X else
X eexpr(tq);
X end
X else if (tx = typnods[tstring]) or
X (tx = typnods[tset]) then
X begin
X (* cast literal to proper type *)
X write('*((');
X etypedef(tf^.tup^.tbind);
X write(' *)');
X if tx = typnods[tset] then
X begin
X dropset := true;
X eexpr(tq);
X dropset := false
X end
X else
X eexpr(tq);
X write(')')
X end
X else if tx = typnods[tnil] then
X begin
X write('(');
X etypedef(tf^.tup^.tbind);
X write(')NIL')
X end
X else if tf^.tup^.tbind^.tt = nconfarr then
X begin
X write('(struct ');
X printid(tf^.tup^.tbind^.tcuid);
X write(' *)&');
X eexpr(tq);
X (* add upper bound of actual value *)
X if tq^.tnext = nil then
X write(', ',
X crange(tx^.taindx):1)
X end
X else begin
X if tf^.tup^.tt = nvarpar then
X eaddr(tq)
X else
X eexpr(tq)
X end
X end;
X tq := tq^.tnext;
X if tq <> nil then
X begin
X write(', ');
X (* next formal parameter *)
X if tf^.tnext = nil then
X begin
X tf := tf^.tup^.tnext;
X case tf^.tt of
X nvalpar,
X nvarpar:
X tf := tf^.tidl;
X nparproc,
X nparfunc:
X tf := tf^.tparid
X end (* case *)
X end
X else
X tf := tf^.tnext;
X end;
X end;
X write(')')
X end; (* ecall *)
X
X (* Emit code for a general expression. *)
X procedure eexpr;
X
X label 999;
X
X var tq : treeptr;
X flag : boolean;
X
X function constset(tp : treeptr) : boolean;
X
X function constxps(tp : treeptr) : boolean;
X begin
X case tp^.tt of
X nrange:
X if constxps(tp^.texpr) then
X constxps := constxps(tp^.texpl)
X else
X constxps := false;
X nempty,
X ninteger,
X nchar:
X constxps := true;
X nid:
X begin
X tp := idup(tp);
X constxps := (tp^.tt = nconst)
X or (tp^.tt = nscalar)
X end;
X nin, neq, nne, nlt, nle, ngt, nge, nor,
X nplus, nminus, nand, nmul, ndiv, nmod,
X nquot, nnot, numinus, nuplus, nset,
X nindex, nselect, nderef, ncall,
X nreal, nstring, nnil:
X constxps := false
X end (* case *)
X end;
X
X begin
X constset := true;
X while tp <> nil do
X if constxps(tp) then
X tp := tp^.tnext
X else begin
X constset := false;
X tp := nil
X end
X end;
X
X begin (* eexpr *)
X donearr := false;
X if tp^.tt in [nplus, nminus, nmul, nle, nge, neq, nne] then
X begin
X tq := typeof(tp^.texpl);
X if (tq^.tt in [nset, nsetof]) or
X (tq = typnods[tset]) then
X begin
X (* set operations *)
X case tp^.tt of
X nplus:
X begin
X setused := true;
X useunion := true;
X write('Union')
X end;
X nminus:
X begin
X setused := true;
X usediff := true;
X write('Diff')
X end;
X nmul:
X begin
X setused := true;
X useintr := true;
X write('Inter')
X end;
X neq:
X begin
X useseq := true;
X write('Eq')
X end;
X nne:
X begin
X usesne := true;
X write('Ne')
X end;
X nge:
X begin
X usesge := true;
X write('Ge')
X end;
X nle:
X begin
X usesle := true;
X write('Le')
X end
X end;(* case *)
X if tp^.tt in [nplus, nminus, nmul] then
X dropset := false;
X write('(');
X eexpr(tp^.texpl);
X if tq^.tt = nsetof then
X write('.S');
X write(', ');
X eexpr(tp^.texpr);
X tq := typeof(tp^.texpr);
X if tq^.tt = nsetof then
X write('.S');
X write(')');
X goto 999
X end
X end;
X if tp^.tt in [neq, nne, ngt, nlt, nge, nle] then
X begin
X tq := typeof(tp^.texpl);
X if tq^.tt = nconfarr then
X fatal(ecmpconf);
X if (tq^.tt in [nstring, narray]) or
X (tq = typnods[tstring]) then
X begin
X write('Cmpstr(');
X eexpr(tp^.texpl);
X if tq^.tt = narray then
X write('.A');
X write(', ');
X tq := typeof(tp^.texpr);
X if tq^.tt = nconfarr then
X fatal(ecmpconf);
X eexpr(tp^.texpr);
X if tq^.tt = narray then
X write('.A');
X write(')');
X case tp^.tt of
X neq:
X write(' == ');
X nne:
X write(' != ');
X ngt:
X write(' > ');
X nlt:
X write(' < ');
X nge:
X write(' >= ');
X nle:
X write(' <= ');
X end;(* case *)
X write('0');
X goto 999
X end
X end;
X case tp^.tt of
X neq, nne, nlt, nle,
X ngt, nge, nor, nand, nplus, nminus,
X nmul, ndiv, nmod, nquot:
X begin
X flag := cprio[tp^.tt] > cprio[tp^.texpl^.tt];
X if (tp^.tt in [nlt, nle, ngt, nge]) and
X not arithexpr(tp^.texpl) then
X begin
X write('(int)');
X flag := true
X end;
X if flag then
X write('(');
X eexpr(tp^.texpl);
X if flag then
X write(')');
X case tp^.tt of
X neq:
X write(' == ');
X nne:
X write(' != ');
X nlt:
X write(' < ');
X nle:
X write(' <= ');
X ngt:
X write(' > ');
X nge:
X write(' >= ');
X nor:
X write(' || ');
X nand:
X write(' && ');
X nplus:
X write(' + ');
X nminus:
X write(' - ');
X nmul:
X write(' * ');
X ndiv:
X write(' / ');
X nmod:
X write(' % ');
X nquot:
X begin
X write(' / ((');
X printid(defnams[dreal]^.lid);
X write(')')
X end
X end;(* case *)
X flag := cprio[tp^.tt] > cprio[tp^.texpr^.tt];
X if (tp^.tt in [nlt, nle, ngt, nge]) and
X not arithexpr(tp^.texpr) then
X begin
X write('(int)');
X flag := true
X end;
X if flag then
X write('(');
X eexpr(tp^.texpr);
X if flag then
X write(')');
X if tp^.tt = nquot then
X write(')')
X end;
X
X nuplus, numinus, nnot:
X begin
X case tp^.tt of
X numinus:
X write('-');
X nnot:
X write('!');
X nuplus:
X end;(* case *)
X flag := cprio[tp^.tt] >= cprio[tp^.texps^.tt];
X if flag then
X write('(');
X eexpr(tp^.texps);
X if flag then
X write(')');
X end;
X
X nin:
X begin
X usememb := true;
X write('Member((unsigned)(');
X eexpr(tp^.texpl);
X write('), ');
X dropset := true; (* no need to save set-expr *)
X eexpr(tp^.texpr);
X dropset := false;
X tq := typeof(tp^.texpr);
X if tq^.tt = nsetof then
X write('.S');
X write(')')
X end;
X
X nassign:
X begin
X tq := typeof(tp^.trhs);
X if tq = typnods[tstring] then
X begin
X write(voidcast, 'strncpy(');
X eexpr(tp^.tlhs);
X write('.A, ');
X eexpr(tp^.trhs);
X write(', sizeof(');
X eexpr(tp^.tlhs);
X write('.A))')
X end
X else if tq = typnods[tboolean] then
X begin
X eexpr(tp^.tlhs);
X write(' = ');
X tq := tp^.trhs;
X while tq^.tt = nuplus do
X tq := tq^.texps;
X if tq^.tt in [nin .. nor, nand, nnot] then
X begin
X write('(');
X printid(defnams[dboolean]^.lid);
X write(')(');
X eexpr(tq);
X write(')')
X end
X else
X eexpr(tq)
X end
X else if tq = typnods[tnil] then
X begin
X eexpr(tp^.tlhs);
X write(' = (');
X etypedef(typeof(tp^.tlhs));
X write(')NIL')
X end
X else begin
X tq := typeof(tp^.tlhs);
X if tq^.tt = nsetof then
X begin
X usescpy := true;
X write('Setncpy(');
X eselect(tp^.tlhs);
X write('S, ');
X dropset := true;
X tq := typeof(tp^.trhs);
X if tq = typnods[tset] then
X eexpr(tp^.trhs)
X else begin
X eselect(tp^.trhs);
X write('S')
X end;
X dropset := false;
X write(', sizeof(');
X eselect(tp^.tlhs);
X write('S))')
X end
X else begin
X eexpr(tp^.tlhs);
X write(' = ');
X eexpr(tp^.trhs)
X end
X end
X end;
X
X ncall:
X begin
X tq := idup(tp^.tcall);
X if (tq^.tt in [nfunc, nproc]) and
X (tq^.tsubstmt <> nil) then
X if tq^.tsubstmt^.tt = npredef then
X epredef(tq, tp)
X else
X ecall(tp)
X else
X ecall(tp)
X end;
X
X nselect:
X begin
X eselect(tp^.trecord);
X eexpr(tp^.tfield)
X end;
X nindex:
X begin
X eselect(tp^.tvariable);
X write('A[');
X tq := tp^.toffset;
X if arithexpr(tq) then
X eexpr(tq)
X else begin
X write('(int)(');
X eexpr(tq);
X write(')')
X end;
X tq := typeof(tp^.tvariable);
X if tq^.tt = narray then
X if clower(tq^.taindx) <> 0 then
X begin
X write(' - ');
X tq := typeof(tq^.taindx);
X if tq^.tt = nsubrange then
X if arithexpr(tq^.tlo) then
X eexpr(tq^.tlo)
X else begin
X write('(int)(');
X eexpr(tq^.tlo);
X write(')')
X end
X else
X fatal(etree)
X end;
X write(']')
X end;
X nderef:
X begin
X tq := typeof(tp^.texps);
X if (tq^.tt = nfileof) or
X ((tq^.tt = npredef) and (tq^.tdef = dtext)) then
X begin
X (* using a file-variable as pointer *)
X eexpr(tp^.texps);
X write('.buf')
X end
X else if doarrow = 0 then
X begin
X write('*');
X eexpr(tp^.texps)
X end
X else begin
X eexpr(tp^.texps);
X write('->');
X donearr := true
X end
X end;
X nid:
X begin
X (* add pointer-dereference if this id is declared as a
X var-parameter or as a procedure-parameter *)
X tq := idup(tp);
X if tq^.tt = nvarpar then
X begin
X if (doarrow = 0) or
X (tq^.tattr = areference) then
X begin
X write('(*');
X printid(tp^.tsym^.lid);
X write(')')
X end
X else begin
X printid(tp^.tsym^.lid);
X write('->');
X donearr := true
X end
X end
X else if (tq^.tt = nconst) and conflag then
X write(cvalof(tp):1)
X else if tq^.tt in [nparproc, nparfunc] then
X begin
X write('(*');
X printid(tp^.tsym^.lid);
X write(')')
X end
X else
X printid(tp^.tsym^.lid);
X end;
X nchar:
X printchr(tp^.tsym^.lchar);
X ninteger:
X write(tp^.tsym^.linum:1);
X nreal:
X printtok(tp^.tsym^.lfloat);
X nstring:
X printstr(tp^.tsym^.lstr);
X nset:
X if constset(tp^.texps) then
X begin
X (* save set expression for initialization *)
X write('Conset[', setcnt:1, ']');
X setcnt := setcnt + 1;
X tq := mknode(nset);
X tq^.tnext := setlst;
X setlst := tq;
X tq^.texps := tp^.texps
X end
X else begin
X increment;
X flag := dropset;
X (* if a set-constructor is used in an
X expression involving + - * it will need to
X be saved temporarily (by Saveset) but often
X we can simply forget the set-value when we
X have finished using it *)
X if dropset then
X dropset := false
X else
X write('Saveset(');
X write('(Tmpset = Newset(), ');
X tq := tp^.texps;
X while tq <> nil do
X begin
X case tq^.tt of
X nrange:
X begin
X usemksub := true;
X write(voidcast, 'Mksubr(');
X write('(unsigned)(');
X eexpr(tq^.texpl);
X write('), ');
X write('(unsigned)(');
X eexpr(tq^.texpr);
X write('), Tmpset)')
X end;
X nin, neq, nne, nlt, nle, ngt, nge,
X nor, nand, nmul, ndiv, nmod, nquot,
X nplus, nminus, nnot, numinus, nuplus,
X nindex, nselect, nderef, ncall,
X ninteger, nchar, nid:
X begin
X useins := true;
X write(voidcast, 'Insmem(');
X write('(unsigned)(');
X eexpr(tq);
X write('), Tmpset)')
X end
X end;(* case *)
X tq := tq^.tnext;
X if tq <> nil then
X begin
X writeln(',');
X indent
X end
X end;
X write(', Tmpset)');
X if not flag then
X begin
X write(')');
X setused := true
X end;
X decrement
X end;
X nnil:
X begin
X tq := tp;
X repeat
X tq := tq^.tup
X until tq^.tt in [neq, nne, ncall, nassign, npgm];
X if tq^.tt in [neq, nne] then
X begin
X if typeof(tq^.texpl) = typnods[tnil] then
X tq := typeof(tq^.texpr)
X else
X tq := typeof(tq^.texpl);
X if tq^.tt = nptr then
X begin
X write('(');
X etypedef(tq);
X write(')')
X end
X end;
X write('NIL')
X end;
X end;(* case *)
X 999:
X end; (* eexpr *)
X
X (* Emit constant definitions. *)
X procedure econst(tp : treeptr);
X
X var sp : symptr;
X
X begin
X while tp <> nil do
X begin
X sp := tp^.tidl^.tsym;
X if sp^.lid^.inref > 1 then
X sp^.lid := mkrename('X', sp^.lid);
X if tp^.tbind^.tt = nstring then
X begin
X (* string constants emitted as
X static local variables *)
X indent;
X write(static, chartyp, tab1);
X printid(sp^.lid);
X write('[] = ');
X eexpr(tp^.tbind);
X writeln(';')
X end
X else begin
X (* all other constants emitted as
X preprocessor # defines *)
X write(define);
X printid(sp^.lid);
X write(space);
X eexpr(tp^.tbind);
X writeln
X end;
X tp := tp^.tnext
X end
X end; (* econst *)
X
X (* Emit a typedef. *)
X procedure etypedef;
X
X (* Workhorse for etypedef, this procedure also *)
X (* renames all fields in record-unions when *)
X (* necessary. *)
X procedure etdef(uid : idptr; tp : treeptr);
X
X var i : integer;
X tq : treeptr;
X
X (* Emit definition for an integer subrange *)
X (* using data from worddefs set up during *)
X (* initialization. *)
X procedure etrange(tp : treeptr);
X
X label 999;
X
X var lo, hi : integer;
X i : 1 .. maxmachdefs;
X
X begin
X lo := clower(tp);
X hi := cupper(tp);
X (* scan CPU word definitions for a type
X enclosing wanted range *)
X for i := 1 to nmachdefs do
X with machdefs[i] do
X if (lo >= lolim) and (hi <= hilim) then
X begin
X (* found it, print type name *)
X printtok(typstr);
X goto 999
X end;
X fatal(erange);
X 999:
X end;
X
X (* Print last component of identifier. *)
X procedure printsuf(ip : idptr);
X
X var w : toknbuf;
X i, j : toknidx;
X
X begin
X gettokn(ip^.istr, w);
X i := 1;
X j := i;
X while w[i] <> chr(null) do
X begin
X if w[i] = '.' then
X j := i;
X i := i + 1
X end;
X if w[j] = '.' then
X j := j + 1;
X while w[j] <> chr(null) do
X begin
X write(w[j]);
X j := j + 1
X end
X end;
X
X begin (* etdef *)
X case tp^.tt of
X nid:
X printid(tp^.tsym^.lid);
X nptr:
X begin
X tq := typeof(tp^.tptrid);
X if tq^.tt = nrecord then
X begin
X write('struct ');
X printid(tq^.tuid)
X end
X else
X printid(tp^.tptrid^.tsym^.lid);
X write(' *');
X end;
X nscalar:
X begin
X write('enum { ');
X increment;
X tp := tp^.tscalid;
X
X (* avoid bug in C-compiler:
X enums are mixed in same namespace *)
X if tp^.tsym^.lid^.inref > 1 then
X tp^.tsym^.lid :=
X mkrename('E', tp^.tsym^.lid);
X printid(tp^.tsym^.lid);
X i := 1;
X while tp^.tnext <> nil do
X begin
X if i >= 4 then
X begin
X writeln(',');
X indent;
X i := 1
X end
X else begin
X write(', ');
X i := i + 1
X end;
X tp := tp^.tnext;
X if tp^.tsym^.lid^.inref > 1 then
X tp^.tsym^.lid :=
X mkrename('E', tp^.tsym^.lid);
X printid(tp^.tsym^.lid)
X end;
X decrement;
X write(' } ')
X end;
X nsubrange:
X begin
X tq := typeof(tp^.tlo);
X if tq = typnods[tinteger] then
X etrange(tp)
X else begin
X if tq^.tup^.tt = ntype then
X tq := tq^.tup^.tidl;
X etdef(nil, tq)
X end
X end;
X nfield:
X begin
X etdef(nil, tp^.tbind);
X write(tab1);
X tp := tp^.tidl;
X if uid <> nil then
X tp^.tsym^.lid :=
X mkconc('.', uid, tp^.tsym^.lid);
X printsuf(tp^.tsym^.lid);
X i := 1;
X while tp^.tnext <> nil do
X begin
X if i >= 4 then
X begin
X writeln(',');
X indent;
X write(tab1);
X i := 1
X end
X else begin
X write(', ');
X i := i + 1
X end;
X tp := tp^.tnext;
X if uid <> nil then
X tp^.tsym^.lid :=
X mkconc('.', uid, tp^.tsym^.lid);
X printsuf(tp^.tsym^.lid);
X end;
X writeln(';');
X end;
X nrecord:
X begin
X write('struct ');
X if tp^.tuid = nil then
X tp^.tuid := uid
X else if uid = nil then
X printid(tp^.tuid);
X writeln(' {');
X increment;
X if (tp^.tflist = nil) and
X (tp^.tvlist = nil) then
X begin
X (* C doesn't allow empty structures *)
X indent;
X writeln(inttyp, tab1, 'dummy;')
X end;
X tq := tp^.tflist;
X while tq <> nil do
X begin
X indent;
X etdef(uid, tq);
X tq := tq^.tnext
X end;
X if tp^.tvlist <> nil then
X begin
X indent;
X writeln('union {');
X increment;
X tq := tp^.tvlist;
X while tq <> nil do
X begin
X if (tq^.tvrnt^.tflist <> nil) or
X (tq^.tvrnt^.tvlist <> nil) then
X begin
X indent;
X if uid = nil then
X etdef(mkvrnt,
X tq^.tvrnt)
X else
X etdef(mkconc('.',
X uid, mkvrnt),
X tq^.tvrnt);
X writeln(';')
X end;
X tq := tq^.tnext
X end;
X decrement;
X indent;
X writeln('} U;');
X end;
X decrement;
X indent;
X if tp^.tup^.tt = nvariant then
X begin
X write('} ');
X printsuf(tp^.tuid)
X end
X else
X write('}');
X end;
X nconfarr:
X begin
X write('struct ');
X printid(tp^.tcuid);
X write(' { ');
X etdef(nil, tp^.tcelem);
X write(tab1, 'A[]; }')
X end;
X narray:
X begin
X write('struct { ');
X etdef(nil, tp^.taelem);
X write(tab1, 'A[');
X tq := typeof(tp^.taindx);
X if tq^.tt = nsubrange then
X begin
X if arithexpr(tq^.thi) then
X begin
X eexpr(tq^.thi);
X if cvalof(tq^.tlo) <> 0 then
X begin
X write(' - ');
X eexpr(tq^.tlo)
X end
X end
X else begin
X write('(int)(');
X eexpr(tq^.thi);
X if cvalof(tq^.tlo) <> 0 then
X begin
X write(') - (int)(');
X eexpr(tq^.tlo)
X end;
X write(')')
X end;
X write(' + 1')
X end
X else
X write(crange(tp^.taindx):1);
X write(']; }')
X end;
X nfileof:
X begin
X writeln('struct {');
X indent;
X writeln(tab1, 'FILE', tab1, '*fp;');
X indent;
X writeln(tab1, filebits, tab1, 'eoln:1,');
X indent;
X writeln(tab3, 'eof:1,');
X indent;
X writeln(tab3, 'out:1,');
X indent;
X writeln(tab3, 'init:1,');
X indent;
X writeln(tab3, ':', filefill:1, ';');
X indent;
X write(tab1);
X etdef(nil, tp^.tof);
X writeln(tab1, 'buf;');
X indent;
X write('} ')
X end;
X nsetof:
X write('struct { ', setwtyp, tab1, 'S[',
X csetsize(tp):1, ']; }');
X npredef:
X begin
X case tp^.tobtyp of
X tboolean:
X printid(defnams[dboolean]^.lid);
X tchar:
X write(chartyp);
X tinteger:
X printid(defnams[dinteger]^.lid);
X treal:
X printid(defnams[dreal]^.lid);
X tstring:
X write(chartyp, ' *');
X ttext:
X write('text');
X tnil,
X tset,
X terror:
X fatal(etree);
X tnone:
X write(voidtyp);
X end (* case *)
X end;
X nempty:
X write(voidtyp);
X end;(* case *)
X end; (* etdef *)
X begin
X etdef(nil, tp)
X end; (* etypedef *)
X
X (* Emit code for type declarations. *)
X procedure etype(tp : treeptr);
X
X var sp : symptr;
X
X begin
X while tp <> nil do
X begin
X (* if identifier used more than once we rename the type
X to avoid typedef'ing an identifier twice *)
X sp := tp^.tidl^.tsym;
X if sp^.lid^.inref > 1 then
X sp^.lid := mkrename('Y', sp^.lid);
X indent;
X write(typdef);
X etypedef(tp^.tbind);
X write(tab1);
X printid(sp^.lid);
X writeln(';');
X tp := tp^.tnext
X end
X end;
X
X (* Emit code for variable declarations. *)
X procedure evar(tp : treeptr);
X
X label 555;
X
X var tq : treeptr;
X i : integer;
X
X begin
X while tp <> nil do
X begin
X indent;
X case tp^.tt of
X nvar,
X nvalpar,
X nvarpar:
X begin
X if tp^.tattr = aregister then
X write(registr);
X etypedef(tp^.tbind)
X end;
X nparproc,
X nparfunc:
X begin
X if tp^.tt = nparproc then
X write(voidtyp)
X else
X etypedef(tp^.tpartyp);
X tq := tp^.tparid;
X write(tab1, '(*');
X printid(tq^.tsym^.lid);
X write(')()');
X goto 555
X end
X end;(* case *)
X write(tab1);
X tq := tp^.tidl;
X i := 1;
X repeat
X if tp^.tt = nvarpar then
X write('*');
X printid(tq^.tsym^.lid);
X tq := tq^.tnext;
X if tq <> nil then
X begin
X if i >= 6 then
X begin
X i := 1;
X writeln(',');
X indent;
X write(tab1)
X end
X else begin
X i := i + 1;
X write(', ')
X end
X
END_OF_FILE
if test 50280 -ne `wc -c <'ptc.p.3'`; then
echo shar: \"'ptc.p.3'\" unpacked with wrong size!
fi
# end of 'ptc.p.3'
fi
echo shar: End of archive 9 \(of 12\).
cp /dev/null ark9isdone
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