rs@uunet.UU.NET (Rich Salz) (07/30/87)
Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 75
Archive-name: ptoc/Part11
#! /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 11 (of 12)."
# Contents: ptc.p.4
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'ptc.p.4' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ptc.p.4'\"
else
echo shar: Extracting \"'ptc.p.4'\" \(54467 characters\)
sed "s/^X//" >'ptc.p.4' <<'END_OF_FILE'
X end
X until tq = nil;
X 555:
X writeln(';');
X if tp^.tt = nvarpar then
X if tp^.tbind^.tt = nconfarr then
X begin
X indent;
X etypedef(tp^.tbind^.tindtyp);
X write(tab1);
X tq := tp^.tbind^.tcindx^.thi;
X printid(tq^.tsym^.lid);
X writeln(';')
X end;
X tp := tp^.tnext
X end
X end; (* evar *)
X
X (* Emit code for a statment. *)
X procedure estmt(tp : treeptr);
X
X var tq : treeptr;
X locid1,
X locid2 : idptr;
X stusd : boolean;
X opc1,
X opc2 : char;
X
X (* Emit typename for with-variable. *)
X procedure ewithtype(tp : treeptr);
X
X var tq : treeptr;
X
X begin
X tq := typeof(tp);
X write('struct ');
X printid(tq^.tuid)
X end;
X
X (* Emit code for a case-choise. *)
X procedure echoise(tp : treeptr);
X
X var tq : treeptr;
X i : integer;
X
X begin
X while tp <> nil do
X begin
X tq := tp^.tchocon;
X i := 0;
X indent;
X while tq <> nil do
X begin
X write(' case ');
X conflag := true;
X eexpr(tq);
X conflag := false;
X write(':');
X i := i + 1;
X tq := tq^.tnext;
X if (tq = nil) or (i mod 4 = 0) then
X begin
X writeln;
X if tq <> nil then
X indent;
X i := 0
X end
X end;
X increment;
X if tp^.tchostmt^.tt = nbegin then
X estmt(tp^.tchostmt^.tbegin)
X else
X estmt(tp^.tchostmt);
X indent;
X writeln('break ;');
X decrement;
X tp := tp^.tnext;
X if tp <> nil then
X if tp^.tchocon = nil then
X tp := nil
X end
X end; (* echoise *)
X
X (* Rename all accessible record-fields to include *)
X (* pointer name. *)
X procedure cenv(ip : idptr; dp : declptr);
X
X var tp : treeptr;
X sp : symptr;
X np : idptr;
X h : hashtyp;
X
X begin
X with dp^ do
X for h := 0 to hashmax - 1 do
X begin
X sp := ddecl[h];
X while sp <> nil do
X begin
X if sp^.lt = lfield then
X begin
X np := sp^.lid;
X tp := sp^.lsymdecl^.tup^.tup;
X if (tp^.tup^.tt = nvariant) and
X (tp^.tuid <> nil) then
X np := mkconc('.',
X tp^.tuid, np);
X np := mkconc('>', ip, np);
X sp^.lid := np
X end;
X sp := sp^.lnext
X end
X end
X end; (* cenv *)
X
X (* Emit identifiers for push/pop of global ptrs. *)
X procedure eglobid(tp : treeptr);
X
X var j : toknidx;
X w : toknbuf;
X
X begin
X gettokn(tp^.tsym^.lid^.istr, w);
X j := 1;
X if w[1] = '*' then
X j := 2;
X while w[j] <> chr(null) do
X begin
X write(w[j]);
X j := j + 1
X end
X end;
X
X begin (* estmt *)
X while tp <> nil do
X begin
X case tp^.tt of
X nbegin:
X begin
X if tp^.tup^.tt in [nbegin, nrepeat,
X nproc, nfunc, npgm] then
X indent;
X writeln('{');
X increment;
X estmt(tp^.tbegin);
X decrement;
X indent;
X write('}');
X if tp^.tup^.tt <> nif then
X writeln
X end;
X nrepeat:
X begin
X indent;
X writeln('do {');
X increment;
X estmt(tp^.treptstmt);
X decrement;
X indent;
X write('} while (!(');
X eexpr(tp^.treptxp);
X writeln('));')
X end;
X nwhile:
X begin
X indent;
X write('while (');
X increment;
X eexpr(tp^.twhixp);
X stusd := setused;
X if tp^.twhistmt^.tt = nbegin then
X begin
X decrement;
X write(') ');
X estmt(tp^.twhistmt)
X end
X else begin
X writeln(')');
X estmt(tp^.twhistmt);
X decrement
X end;
X setused := stusd or setused
X end;
X nfor:
X begin
X indent;
X if tp^.tincr then
X begin
X opc1 := '+'; (* increment variable *)
X opc2 := '<' (* test for <= *)
X end
X else begin
X opc1 := '-'; (* decrement variable *)
X opc2 := '>'; (* test for >= *)
X end;
X if not lazyfor then
X begin
X locid1 := mkvariable('B');
X locid2 := mkvariable('B');
X writeln('{');
X increment;
X indent;
X tq := idup(tp^.tforid);
X etypedef(tq^.tbind);
X tq := typeof(tq^.tbind);
X write(tab1);
X printid(locid1);
X write(' = ');
X eexpr(tp^.tfrom);
X writeln(',');
X indent;
X write(tab1);
X printid(locid2);
X write(' = ');
X eexpr(tp^.tto);
X writeln(';');
X writeln;
X indent;
X write('if (');
X if tq^.tt = nscalar then
X begin
X write('(int)(');
X printid(locid1);
X write(')')
X end
X else
X printid(locid1);
X write(' ', opc2, '= ');
X if tq^.tt = nscalar then
X begin
X write('(int)(');
X printid(locid2);
X write(')')
X end
X else
X printid(locid2);
X writeln(')');
X increment;
X indent;
X tp^.tfrom := newid(locid1);
X tp^.tfrom^.tup := tp
X end;
X write('for (');
X increment;
X eexpr(tp^.tforid);
X tq := typeof(tp^.tforid);
X write(' = ');
X eexpr(tp^.tfrom);
X write('; ');
X if lazyfor then
X begin
X if tq^.tt = nscalar then
X begin
X write('(int)(');
X eexpr(tp^.tforid);
X write(')')
X end
X else
X eexpr(tp^.tforid);
X write(' ', opc2, '= ');
X if tq^.tt = nscalar then
X begin
X write('(int)(');
X eexpr(tp^.tto);
X write(')')
X end
X else
X eexpr(tp^.tto)
X end;
X write('; ');
X eexpr(tp^.tforid);
X if tq^.tt = nscalar then
X begin
X write(' = (');
X eexpr(tq^.tup^.tidl);
X write(')((int)(');
X eexpr(tp^.tforid);
X write(')', opc1, '1)')
X end
X else
X write(opc1, opc1);
X if not lazyfor then
X begin
X if tp^.tforstmt^.tt <> nbegin then
X begin
X (* create compund stmt *)
X tq := mknode(nbegin);
X tq^.tbegin := tp^.tforstmt;
X tq^.tbegin^.tup := tq;
X tp^.tforstmt := tq;
X tq^.tup := tp
X end;
X (* find end of loop *)
X tq := tp^.tforstmt^.tbegin;
X while tq^.tnext <> nil do
X tq := tq^.tnext;
X (* add break stmt *)
X tq^.tnext := mknode(nbreak);
X tq := tq^.tnext;
X tq^.tup := tp^.tforstmt;
X tq^.tbrkid := tp^.tforid;
X tq^.tbrkxp := newid(locid2);
X tq^.tbrkxp^.tup := tq
X end;
X if tp^.tforstmt^.tt = nbegin then
X begin
X decrement;
X write(') ');
X estmt(tp^.tforstmt)
X end
X else begin
X writeln(')');
X estmt(tp^.tforstmt);
X decrement
X end;
X if not lazyfor then
X begin
X decrement;
X decrement;
X indent;
X writeln('}')
X end
X end;
X nif:
X begin
X indent;
X write('if (');
X increment;
X eexpr(tp^.tifxp);
X stusd := setused;
X setused := false;
X if tp^.tthen^.tt = nbegin then
X begin
X decrement;
X write(') ');
X estmt(tp^.tthen);
X if tp^.telse <> nil then
X write(space)
X else
X writeln
X end
X else begin
X writeln(')');
X estmt(tp^.tthen);
X decrement;
X if tp^.telse <> nil then
X indent
X end;
X if tp^.telse <> nil then
X begin
X write('else');
X if tp^.telse^.tt = nbegin then
X begin
X write(space);
X estmt(tp^.telse);
X writeln
X end
X else begin
X increment;
X writeln;
X estmt(tp^.telse);
X decrement
X end;
X end;
X setused := stusd or setused
X end;
X ncase:
X begin
X indent;
X write('switch (');
X increment;
X eexpr(tp^.tcasxp);
X writeln(') {');
X decrement;
X echoise(tp^.tcaslst);
X indent;
X writeln(' default:');
X increment;
X if tp^.tcasother = nil then
X begin
X indent;
X writeln('Caseerror(Line);')
X end
X else
X estmt(tp^.tcasother);
X decrement;
X indent;
X writeln('}')
X end;
X nwith:
X begin
X indent;
X writeln('{');
X increment;
X tq := tp^.twithvar;
X while tq <> nil do
X begin
X indent;
X write(registr);
X ewithtype(tq^.texpw);
X write(' *');
X locid1 := mkvariable('W');
X printid(locid1);
X write(' = ');
X eaddr(tq^.texpw);
X writeln(';');
X cenv(locid1, tq^.tenv);
X tq := tq^.tnext
X end;
X writeln;
X if tp^.twithstmt^.tt = nbegin then
X estmt(tp^.twithstmt^.tbegin)
X else
X estmt(tp^.twithstmt);
X decrement;
X indent;
X writeln('}')
X end;
X ngoto:
X begin
X indent;
X if islocal(tp^.tlabel) then
X writeln('goto L',
X tp^.tlabel^.tsym^.lno:1, ';')
X else begin
X tq := idup(tp^.tlabel);
X writeln('longjmp(J[', (* LIB *)
X tq^.tstat:1, '].jb, ',
X tp^.tlabel^.tsym^.lno:1, ');')
X end
X end;
X nlabstmt:
X begin
X decrement;
X indent;
X writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
X increment;
X estmt(tp^.tstmt)
X end;
X nassign:
X begin
X indent;
X eexpr(tp);
X writeln(';')
X end;
X ncall:
X begin
X indent;
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 begin
X ecall(tp);
X writeln(';')
X end
X else begin
X ecall(tp);
X writeln(';')
X end
X end;
X npush:
X begin
X indent;
X eglobid(tp^.ttmp);
X write(' = ');
X eglobid(tp^.tglob);
X writeln(';');
X indent;
X eglobid(tp^.tglob);
X write(' = ');
X if tp^.tloc^.tt = nid then
X begin
X tq := idup(tp^.tloc);
X if tq^.tt in [nparproc, nparfunc] then
X printid(tp^.tloc^.tsym^.lid)
X else
X eaddr(tp^.tloc)
X end
X else
X eaddr(tp^.tloc);
X writeln(';')
X end;
X npop:
X begin
X indent;
X eglobid(tp^.tglob);
X write(' = ');
X eglobid(tp^.ttmp);
X writeln(';')
X end;
X nbreak:
X begin
X indent;
X write('if (');
X eexpr(tp^.tbrkid);
X write(' == ');
X eexpr(tp^.tbrkxp);
X writeln(') break;')
X end;
X nempty:
X if not (tp^.tup^.tt in [npgm, nproc, nfunc,
X nchoise, nbegin, nrepeat]) then
X begin
X indent;
X writeln(';')
X end
X end;(* case *)
X if setused and
X (tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
X nbegin, nchoise, nwith]) then
X begin
X indent;
X writeln('Claimset();');
X setused := false
X end;
X tp := tp^.tnext
X end
X end; (* estmt *)
X
X (* Emit initialization for non-local gotos. *)
X procedure elabel(tp : treeptr);
X
X var tq : treeptr;
X i : integer;
X
X begin
X i := 0;
X tq := tp^.tsublab;
X while tq <> nil do
X begin
X if tq^.tsym^.lgo then
X i := i + 1;
X tq := tq^.tnext
X end;
X if i =1 then
X begin
X tq := tp^.tsublab;
X while not tq^.tsym^.lgo do
X tq := tq^.tnext;
X indent;
X writeln('if (',
X 'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
X writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
X end
X else if i > 1 then
X begin
X indent;
X writeln('switch (',
X 'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
X indent;
X writeln(' case 0:');
X indent;
X writeln(tab1, 'break');
X tq := tp^.tsublab;
X while tq <> nil do
X begin
X if tq^.tsym^.lgo then
X begin
X (* label used in non-local goto *)
X indent;
X writeln(' case ',
X tq^.tsym^.lno:1, ':');
X indent;
X writeln(tab1, 'goto L',
X tq^.tsym^.lno:1, ';')
X end;
X tq := tq^.tnext
X end;
X indent;
X writeln(' default:');
X indent;
X writeln(tab1, 'Caseerror(Line)');
X indent;
X writeln('}')
X end
X end; (* elabel *)
X
X (* Emit declaration for lower bound of conformant array. *)
X procedure econf(tp : treeptr);
X
X var tq : treeptr;
X
X begin
X while tp <> nil do
X begin
X if tp^.tt = nvarpar then
X if tp^.tbind^.tt = nconfarr then
X begin
X indent;
X etypedef(tp^.tbind^.tindtyp);
X write(tab1);
X tq := tp^.tbind^.tcindx^.tlo;
X printid(tq^.tsym^.lid);
X write(' = (');
X etypedef(tp^.tbind^.tindtyp);
X writeln(')0;')
X end;
X tp := tp^.tnext
X end
X end; (* econf *)
X
X (* Emit code for subroutines. *)
X procedure esubr(tp : treeptr);
X
X label 999;
X
X var tq, ti : treeptr;
X
X begin
X while tp <> nil do
X begin
X (* emit nested subroutines *)
X if tp^.tsubsub <> nil then
X begin
X (* emit forward declaration of this subroutine
X in case of recursion *)
X etypedef(tp^.tfuntyp);
X write(space);
X printid(tp^.tsubid^.tsym^.lid);
X writeln('();');
X writeln;
X esubr(tp^.tsubsub)
X end;
X (* emit this subroutine *)
X if tp^.tsubstmt = nil then
X begin
X (* forward/external decl *)
X if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
X write(xtern);
X etypedef(tp^.tfuntyp);
X write(space);
X printid(tp^.tsubid^.tsym^.lid);
X writeln('();');
X goto 999
X end;
X write(space);
X etypedef(tp^.tfuntyp);
X writeln;
X printid(tp^.tsubid^.tsym^.lid);
X write('(');
X tq := tp^.tsubpar;
X while tq <> nil do
X begin
X case tq^.tt of
X nvarpar,
X nvalpar:
X begin
X ti := tq^.tidl;
X while ti <> nil do
X begin
X printid(ti^.tsym^.lid);
X ti := ti^.tnext;
X if ti <> nil then
X write(', ');
X end;
X if tq^.tbind^.tt = nconfarr then
X begin
X (* add upper bound parameter *)
X ti := tq^.tbind^.tcindx^.thi;
X write(', ');
X printid(ti^.tsym^.lid)
X end;
X end;
X nparproc,
X nparfunc:
X begin
X ti := tq^.tparid;
X printid(ti^.tsym^.lid)
X end
X end;(* case *)
X tq := tq^.tnext;
X if tq <> nil then
X write(', ');
X end;
X writeln(')');
X increment;
X evar(tp^.tsubpar);
X writeln('{');
X econf(tp^.tsubpar);
X econst(tp^.tsubconst);
X etype(tp^.tsubtype);
X evar(tp^.tsubvar);
X
X if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
X (tp^.tsubvar <> nil) then
X writeln;
X elabel(tp);
X estmt(tp^.tsubstmt);
X if tp^.tt = nfunc then
X begin
X (* return value in the FIRST variable,
X see renamf() above *)
X indent;
X write('return ');
X printid(tp^.tsubvar^.tidl^.tsym^.lid);
X writeln(';');
X end;
X decrement;
X writeln('}');
X 999:
X writeln;
X tp := tp^.tnext
X end
X end; (* esubr *)
X
X function use(d : predefs) : boolean;
X
X begin
X use := defnams[d]^.lused
X end;
X
X (* Emit code for main program. *)
X procedure eprogram(tp : treeptr);
X
X (* Symbol that sp refers to is renamed if it has *)
X (* been redefined in source program. *)
X procedure capital(sp : symptr);
X
X var tb : toknbuf;
X
X begin
X if sp^.lid^.inref > 1 then
X begin
X gettokn(sp^.lid^.istr, tb);
X tb[1] := uppercase(tb[1]);
X sp^.lid := saveid(tb)
X end
X end;
X
X procedure etextdef;
X
X var tq : treeptr;
X
X begin
X write('typedef ');
X tq := mknode(nfileof);
X tq^.tof := typnods[tchar];
X etypedef(tq);
X writeln(tab1, 'text;')
X end;
X
X begin (* eprogram *)
X if tp^.tsubid <> nil then
X begin
X (* program heading was seen *)
X writeln('/', '*');
X write('** Code derived from program ');
X printid(tp^.tsubid^.tsym^.lid);
X writeln;
X writeln('*', '/');
X writeln(xtern, voidtyp, tab1, 'exit();')
X end;
X if usecase or usesets or
X use(dinput) or use(doutput) or
X use(dwrite) or use(dwriteln) or use(dmessage) or
X use(deof) or use(deoln) or use(dflush) or use(dpage) or
X use(dread) or use(dreadln) or use(dclose) or
X use(dreset) or use(drewrite) or use(dget) or use(dput) then
X begin
X writeln('/', '*');
X writeln('** Definitions for i/o');
X writeln('*', '/');
X writeln(include, '<stdio.h>') (* LIB *)
X end;
X if use(dinput) or use(doutput) or use(dtext) then
X begin
X etextdef;
X if use(dinput) then
X begin
X if tp^.tsubid = nil then
X write(xtern);
X write('text', tab1);
X printid(defnams[dinput]^.lid);
X if tp^.tsubid <> nil then
X write(' = { stdin, 0, 0 }');
X writeln(';')
X end;
X if use(doutput) then
X begin
X if tp^.tsubid = nil then
X write(xtern);
X write('text', tab1);
X printid(defnams[doutput]^.lid);
X if tp^.tsubid <> nil then
X write(' = { stdout, 0, 0 }');
X writeln(';')
X end
X end;
X if use(dinput) or use(dget) or use(dread) or use(dreadln) or
X use(deof) or use(deoln) or use(dreset) or use(drewrite) then
X begin
X writeln(define, 'Fread(x, f) ',
X 'fread((char *)&x, sizeof(x), 1, f)'); (* LIB *)
X writeln(define, 'Get(f) Fread((f).buf, (f).fp)');
X writeln(define, 'Getx(f) (f).init = 1, ',
X '(f).eoln = (((f).buf = ',
X 'fgetc((f).fp)', (* LIB *)
X ') == ', nlchr, ') ? (((f).buf = ',
X spchr, '), 1) : 0');
X writeln(define, 'Getchr(f) (f).buf, Getx(f)')
X end;
X if use(dread) or use(dreadln) then
X begin
X writeln(static, 'FILE', tab1, '*Tmpfil;');
X writeln(static, 'long', tab1, 'Tmplng;');
X writeln(static, 'double', tab1, 'Tmpdbl;');
X writeln(define, 'Fscan(f) (f).init ? ',
X 'ungetc((f).buf, (f).fp)', (* LIB *)
X ' : 0, Tmpfil = (f).fp');
X writeln(define, 'Scan(p, a) ',
X 'Scanck(fscanf(Tmpfil, p, a))'); (* LIB *)
X writeln(voidtyp, tab1, 'Scanck();');
X if use(dreadln) then
X writeln(voidtyp, tab1, 'Getl();');
X end;
X if use(deoln) then
X writeln(define, 'Eoln(f) ((f).eoln ? true : false)');
X if use(deof) then
X writeln(define, 'Eof(f) ',
X '((((f).init == 0) ? (Get(f)) : 0, ',
X '((f).eof ? 1 : ',
X 'feof((f).fp))) ? ', (* LIB *)
X 'true : false)');
X if use(doutput) or use(dput) or
X use(dwrite) or use(dwriteln) or
X use(dreset) or use(drewrite) or use(dclose) then
X begin
X writeln(define, 'Fwrite(x, f) ',
X 'fwrite((char *)&x, sizeof(x), 1, f)');(* LIB *)
X writeln(define, 'Put(f) Fwrite((f).buf, (f).fp)');
X writeln(define, 'Putx(f) (f).eoln = ((f).buf == ',
X nlchr, '), ', voidcast,
X 'fputc((f).buf, (f).fp)'); (* LIB *)
X writeln(define, 'Putchr(c, f) (f).buf = (c), Putx(f)');
X writeln(define, 'Putl(f, v) (f).eoln = v')
X end;
X if use(dreset) or use(drewrite) or use(dclose) then
X writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
X '(Putchr(', nlchr, ', f), 0) : 0, ',
X 'rewind((f).fp)'); (* LIB *)
X if use(dclose) then
X begin
X writeln(define, 'Close(f) (f).init = ',
X '((f).init ? (',
X 'fclose((f).fp), ', (* LIB *)
X '0) : 0), (f).fp = NULL');
X writeln(define, 'Closex(f) (f).init = ',
X '((f).init ? ',
X '(Finish(f), ',
X 'fclose((f).fp), ', (* LIB *)
X '0) : 0), (f).fp = NULL')
X end;
X if use(dreset) then
X begin
X writeln(ifdef, 'READONLY');
X writeln(static, chartyp, tab1, 'Rmode[] = "r";');
X writeln(elsif);
X writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
X writeln(endif);
X writeln(define, 'Reset(f, n) (f).init = ',
X '(f).init ? rewind((f).fp) : ', (* LIB *)
X '(((f).fp = Fopen(n, Rmode)), 1), ',
X '(f).eof = (f).out = 0, Get(f)');
X writeln(define, 'Resetx(f, n) (f).init = ',
X '(f).init ? (Finish(f)) : ',
X '(((f).fp = Fopen(n, Rmode)), 1), ',
X '(f).eof = (f).out = 0, Getx(f)');
X usefopn := true
X end;
X if use(drewrite) then
X begin
X writeln(ifdef, 'WRITEONLY');
X writeln(static, chartyp, tab1, 'Wmode[] = "w";');
X writeln(elsif);
X writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
X writeln(endif);
X writeln(define, 'Rewrite(f, n) (f).init = ',
X '(f).init ? rewind((f).fp) : ', (* LIB *)
X '(((f).fp = Fopen(n, Wmode)), 1), ',
X '(f).out = (f).eof = 1');
X writeln(define, 'Rewritex(f, n) (f).init = ',
X '(f).init ? (Finish(f)) : ',
X '(((f).fp = Fopen(n, Wmode)), 1), ',
X '(f).out = (f).eof = (f).eoln = 1');
X usefopn := true
X end;
X if usefopn then
X begin
X writeln('FILE *Fopen();');
X writeln(define, 'MAXFILENAME 256')
X end;
X if usecase or usejmps then
X begin
X writeln('/', '*');
X writeln('** Definitions for case-statements');
X writeln('** and for non-local gotos');
X writeln('*', '/');
X writeln(define, 'Line __LINE__');
X writeln(voidtyp, tab1, 'Caseerror();')
X end;
X if usejmps then
X begin
X writeln(include, '<setjmp.h>'); (* LIB *)
X writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
X (maxlevel+1):1, '];')
X end;
X if use(dinteger) or use(dmaxint) or
X use(dboolean) or use(dfalse) or use(dtrue) or
X use(deof) or use(deoln) or use(dexp) or
X use(dln) or use(dsqr) or use(dsin) or
X use(dcos) or use(dtan) or use(darctan) or
X use(dsqrt) or use(dreal) then
X begin
X writeln('/', '*');
X writeln('** Definitions for standard types');
X writeln('*', '/')
X end;
X if usecomp then
X begin
X writeln(xtern, inttyp, ' strncmp();'); (* LIB *)
X writeln(define,
X 'Cmpstr(x, y) ',
X 'strncmp((x), (y), sizeof(x))') (* LIB *)
X end;
X if use(dboolean) or use(dfalse) or use(dtrue) or
X use(deof) or use(deoln) or usesets then
X begin
X capital(defnams[dboolean]);
X write(typdef, chartyp, tab1);
X printid(defnams[dboolean]^.lid);
X writeln(';');
X capital(defnams[dfalse]);
X write(define);
X printid(defnams[dfalse]^.lid);
X write(' (');
X printid(defnams[dboolean]^.lid);
X writeln(')0');
X capital(defnams[dtrue]);
X write(define);
X printid(defnams[dtrue]^.lid);
X write(' (');
X printid(defnams[dboolean]^.lid);
X writeln(')1');
X writeln(xtern, chartyp, tab1, '*Bools[];')
X end;
X capital(defnams[dinteger]);
X if use(dinteger) then
X begin
X write(typdef, inttyp, tab1);
X printid(defnams[dinteger]^.lid);
X writeln(';')
X end;
X if use(dmaxint) then
X writeln(define, 'maxint', tab1, maxint:1);
X capital(defnams[dreal]);
X if use(dreal) then
X begin
X write(typdef, realtyp, tab1);
X printid(defnams[dreal]^.lid);
X writeln(';')
X end;
X if use(dexp) then
X writeln(xtern, doubletyp, ' exp();'); (* LIB *)
X if use(dln) then
X writeln(xtern, doubletyp, ' log();'); (* LIB *)
X if use(dsqr) then
X writeln(xtern, doubletyp, ' pow();'); (* LIB *)
X if use(dsin) then
X writeln(xtern, doubletyp, ' sin();'); (* LIB *)
X if use(dcos) then
X writeln(xtern, doubletyp, ' cos();'); (* LIB *)
X if use(dtan) then
X writeln(xtern, doubletyp, ' tan();'); (* LIB *)
X if use(darctan) then
X writeln(xtern, doubletyp, ' atan();'); (* LIB *)
X if use(dsqrt) then
X writeln(xtern, doubletyp, ' sqrt();'); (* LIB *)
X if use(dabs) and use(dreal) then
X writeln(xtern, doubletyp, ' fabs();'); (* LIB *)
X if use(dhalt) then
X writeln(xtern, voidtyp, ' abort();'); (* LIB *)
X if use(dnew) or usenilp then
X begin
X writeln('/', '*');
X writeln('** Definitions for pointers');
X writeln('*', '/');
X end;
X if use(dnew) then
X begin
X writeln(ifndef, 'Unionoffs');
X writeln(define, 'Unionoffs(p, m) ',
X '(((long)(&(p)->m))-((long)(p)))'); (* CPU *)
X writeln(endif)
X end;
X if usenilp then
X writeln(define, 'NIL 0'); (* CPU *)
X if use(dnew) then
X writeln(xtern, chartyp, ' *malloc();'); (* LIB *)
X if use(ddispose) then
X writeln(xtern, voidtyp, ' free();'); (* LIB *)
X if usesets then
X begin
X writeln('/', '*');
X writeln('** Definitions for set-operations');
X writeln('*', '/');
X writeln(define, 'Claimset() ',
X voidcast, 'Currset(0, (', setptyp, ')0)');
X writeln(define, 'Newset() ',
X 'Currset(1, (', setptyp, ')0)');
X writeln(define, 'Saveset(s) Currset(2, s)');
X writeln(define, 'setbits ', setbits:1);
X writeln(typdef, wordtype, tab1, setwtyp, ';');
X writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
X printid(defnams[dboolean]^.lid);
X writeln(tab1, 'Member(), Le(), Ge(), Eq(), Ne();');
X writeln(setptyp, tab1, 'Union(), Diff();');
X writeln(setptyp, tab1, 'Insmem(), Mksubr();');
X writeln(setptyp, tab1, 'Currset(), Inter();');
X writeln(static, setptyp, tab1, 'Tmpset;');
X writeln(xtern, setptyp, tab1, 'Conset[];');
X writeln(voidtyp, tab1, 'Setncpy();')
X end;
X writeln(xtern, chartyp, ' *strncpy();'); (* LIB *)
X if use(dargc) or use(dargv) then
X begin
X writeln('/', '*');
X writeln('** Definitions for argv-operations');
X writeln('*', '/');
X writeln(inttyp, tab1, 'argc;'); (* OS *)
X writeln(chartyp, tab1, '**argv;');
X writeln(' void');
X writeln('Argvgt(n, cp, l)');
X writeln(inttyp, tab1, 'n;');
X writeln(registr, inttyp, tab1, 'l;');
X writeln(registr, chartyp, tab1, '*cp;');
X writeln('{');
X writeln(tab1, registr, chartyp, tab1, '*sp;');
X writeln;
X writeln(tab1, 'for (sp = argv[n]; l > 0 && *sp; l--)');
X writeln(tab2, '*cp++ = *sp++;');
X writeln(tab1, 'while (l-- > 0)');
X writeln(tab2, '*cp++ = ', spchr, ';');
X writeln('}');
X end;
X if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
X (tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
X begin
X writeln('/', '*');
X writeln('** Start of program definitions');
X writeln('*', '/');
X end;
X econst(tp^.tsubconst);
X etype(tp^.tsubtype);
X evar(tp^.tsubvar);
X if tp^.tsubsub <> nil then
X writeln;
X esubr(tp^.tsubsub);
X if tp^.tsubid <> nil then
X begin
X (* program heading was seen *)
X writeln('/', '*');
X writeln('** Start of program code');
X writeln('*', '/');
X if use(dargc) or use(dargv) then
X begin
X writeln('main(_ac, _av)'); (* OS *)
X writeln(inttyp, tab1, '_ac;');
X writeln(chartyp, tab1, '*_av[];');
X writeln('{');
X writeln;
X writeln(tab1, 'argc = _ac;');
X writeln(tab1, 'argv = _av;')
X end
X else begin
X writeln('main()');
X writeln('{')
X end;
X increment;
X elabel(tp);
X estmt(tp^.tsubstmt);
X indent;
X writeln('exit(0);');
X decrement;
X writeln('}');
X writeln('/', '*');
X writeln('** End of program code');
X writeln('*', '/')
X end
X end; (* eprogram *)
X
X (* Emit definitions for constant sets *)
X procedure econset(tp : treeptr; len : integer);
X
X var i : integer;
X
X function size(tp : treeptr) : integer;
X
X var r, x : integer;
X
X begin
X r := 0;
X while tp <> nil do
X begin
X if tp^.tt = nrange then
X x := cvalof(tp^.texpr)
X else if tp^.tt = nempty then
X x := 0
X else
X x := cvalof(tp);
X if x > r then
X r := x;
X tp := tp^.tnext
X end;
X size := csetwords(r+1)
X end;
X
X (* Emit bits in a constant set *)
X procedure ebits(tp : treeptr);
X
X type bitset = set of 0 .. setbits;
X
X var sets : array [ 0 .. maxsetrange ] of bitset;
X s, m, n : integer;
X
X procedure eword(s : bitset);
X
X const bitshex = 4; (* nr of bits in a hex-digit *)
X
X var n, i : integer;
X x : 0 .. setbits;
X
X begin
X n := 0;
X while n <= setbits do
X n := n + bitshex;
X n := n - bitshex;
X while n >= 0 do
X begin
X (* compute 1 hexdigit *)
X x := 0;
X for i := 0 to bitshex - 1 do
X if (n + i) in s then
X case i of
X 0: x := x + 1;
X 1: x := x + 2;
X 2: x := x + 4;
X 3: x := x + 8
X end;(* case *)
X (* print it *)
X write(hexdig[x]);
X n := n - bitshex
X end
X end;
X
X begin
X s := size(tp);
X for n := 0 to s - 1 do
X sets[n] := [];
X while tp <> nil do
X begin
X if tp^.tt = nrange then
X for m := cvalof(tp^.texpl) to
X cvalof(tp^.texpr) do
X begin
X n := m div (setbits+1);
X sets[n] := sets[n] +
X [m mod (setbits+1)]
X end
X else if tp^.tt <> nempty then
X begin
X m := cvalof(tp);
X n := m div (setbits+1);
X sets[n] := sets[n] +
X [m mod (setbits+1)]
X end;
X tp := tp^.tnext
X end;
X write(tab1, s:1);
X for n := 0 to s - 1 do
X begin
X write(',');
X if n mod 6 = 0 then
X writeln;
X write(tab1, '0x');
X eword(sets[n]);
X end;
X writeln
X end;
X
X begin
X i := 0;
X while tp <> nil do
X begin
X writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
X ebits(tp^.texps);
X writeln('};');
X i := i + 1;
X tp := tp^.tnext
X end;
X writeln(static, setwtyp, tab1, '*Conset[] = {');
X for i := len - 1 downto 1 do
X begin
X write(tab1, 'Q', i:1, ',');
X if i mod 6 = 5 then
X writeln
X end;
X writeln(tab1, 'Q0');
X writeln('};');
X end;
X
Xbegin (* emit *)
X indnt := 0;
X varno := 0;
X conflag := false;
X setused := false;
X dropset := false;
X doarrow := 0;
X eprogram(top);
X if usebool then
X writeln(chartyp, tab1, '*Bools[] = { "false", "true" };');
X if usescan then
X begin
X writeln;
X writeln(static, voidtyp);
X writeln('Scanck(n)');
X writeln(inttyp, tab1, 'n;');
X writeln('{');
X writeln(tab1, 'if (n != 1) {');
X writeln(tab2, voidcast, 'fprintf(stderr, "Bad input\n");');
X writeln(tab2, 'exit(1);');
X writeln(tab1, '}');
X writeln('}')
X end;
X if usegetl then
X begin
X writeln;
X writeln(static, voidtyp);
X writeln('Getl(f)');
X writeln(' text', tab1, '*f;');
X writeln('{');
X writeln(tab1, 'while (f->eoln == 0)');
X writeln(tab2, 'Getx(*f);');
X writeln(tab1, 'Getx(*f);');
X writeln('}')
X end;
X if usefopn then
X begin
X writeln;
X writeln(static, 'FILE *');
X writeln('Fopen(n, m)');
X writeln(chartyp, tab1, '*n, *m;');
X writeln('{');
X writeln(tab1, 'FILE', tab2, '*f;');
X writeln(tab1, registr, chartyp, tab1, '*s;');
X writeln(tab1, static, chartyp, tab1, 'ch = ',
X quote, 'A', quote, ';');
X writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];');
X writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *)
X writeln;
X writeln(tab1, 'if (n == NULL)');
X writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
X writeln(tab1, 'else {');
X writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
X writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
X spchr, ' || *s == ', nulchr, '; )');
X writeln(tab3, '*s-- = ', nulchr, ';');
X writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
X writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
X quote, '%s', quote, '\n", n);');
X writeln(tab3, 'exit(1);');
X writeln(tab2, '}');
X writeln(tab1, '}');
X writeln(tab1, 's = tmp;');
X writeln(tab1, 'if ((f = fopen(s, m)) == NULL) {');
X writeln(tab2, voidcast,
X 'fprintf(stderr, "Cannot open: %s\n", s);');
X writeln(tab2, 'exit(1);');
X writeln(tab1, '}');
X writeln(tab1, 'if (n == NULL)');
X writeln(tab2, 'unlink(tmp);'); (* OS *)
X writeln(tab1, 'return (f);');
X writeln('}');
X writeln(xtern, inttyp, tab1, 'rewind();')
X end;
X if setcnt > 0 then
X econset(setlst, setcnt);
X if useunion then
X begin
X writeln;
X writeln(static, setptyp);
X writeln('Union(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
X writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
X writeln(tab4, 'p3 = sp;');
X writeln;
X writeln(tab1, 'j = *p1;');
X writeln(tab1, '*p3 = j;');
X writeln(tab1, 'if (j > *p2)');
X writeln(tab2, 'j = *p2;');
X writeln(tab1, 'else');
X writeln(tab2, '*p3 = *p2;');
X writeln(tab1, 'k = *p1 - *p2;');
X writeln(tab1, 'p1++, p2++, p3++;');
X writeln(tab1, 'for (i = 0; i < j; i++)');
X writeln(tab2, '*p3++ = (*p1++ | *p2++);');
X writeln(tab1, 'while (k > 0) {');
X writeln(tab2, '*p3++ = *p1++;');
X writeln(tab2, 'k--;');
X writeln(tab1, '}');
X writeln(tab1, 'while (k < 0) {');
X writeln(tab2, '*p3++ = *p2++;');
X writeln(tab2, 'k++;');
X writeln(tab1, '}');
X writeln(tab1, 'return (Saveset(sp));');
X writeln('}')
X end;
X if usediff then
X begin
X writeln;
X writeln(static, setptyp);
X writeln('Diff(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
X writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
X writeln(tab4, 'p3 = sp;');
X writeln;
X writeln(tab1, 'j = *p1;');
X writeln(tab1, '*p3 = j;');
X writeln(tab1, 'if (j > *p2)');
X writeln(tab2, 'j = *p2;');
X writeln(tab1, 'k = *p1 - *p2;');
X writeln(tab1, 'p1++, p2++, p3++;');
X writeln(tab1, 'for (i = 0; i < j; i++)');
X writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
X writeln(tab1, 'while (k > 0) {');
X writeln(tab2, '*p3++ = *p1++;');
X writeln(tab2, 'k--;');
X writeln(tab1, '}');
X writeln(tab1, 'return (Saveset(sp));');
X writeln('}')
X end;
X if useintr then
X begin
X writeln;
X writeln(static, setptyp);
X writeln('Inter(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
X writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
X writeln(tab4, 'p3 = sp;');
X writeln;
X writeln(tab1, 'if ((j = *p1) > *p2)');
X writeln(tab2, 'j = *p2;');
X writeln(tab1, '*p3 = j;');
X writeln(tab1, 'p1++, p2++, p3++;');
X writeln(tab1, 'for (i = 0; i < j; i++)');
X writeln(tab2, '*p3++ = (*p1++ & *p2++);');
X writeln(tab1, 'return (Saveset(sp));');
X writeln('}')
X end;
X if usememb then
X begin
X writeln;
X write(static);
X printid(defnams[dboolean]^.lid);
X writeln;
X writeln('Member(m, sp)');
X writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
X writeln(tab1, registr, setptyp, tab1, 'sp;');
X writeln('{');
X writeln(tab1, registr, usigned, inttyp,
X tab1, 'i = m / (setbits+1) + 1;');
X writeln;
X writeln(tab1, 'if ((i <= *sp) &&',
X ' (sp[i] & (1 << (m % (setbits+1)))))');
X write(tab2, 'return (');
X printid(defnams[dtrue]^.lid);
X writeln(');');
X write(tab1, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln('}')
X end;
X if useseq or usesne then
X begin
X writeln;
X write(static);
X printid(defnams[dboolean]^.lid);
X writeln;
X writeln('Eq(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab1, 'i, j;');
X writeln;
X writeln(tab1, 'i = *p1++;');
X writeln(tab1, 'j = *p2++;');
X writeln(tab1, 'while (i != 0 && j != 0) {');
X writeln(tab2, 'if (*p1++ != *p2++)');
X write(tab3, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln(tab2, 'i--, j--;');
X writeln(tab1, '}');
X writeln(tab1, 'while (i != 0) {');
X writeln(tab2, 'if (*p1++ != 0)');
X write(tab3, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln(tab2, 'i--;');
X writeln(tab1, '}');
X writeln(tab1, 'while (j != 0) {');
X writeln(tab2, 'if (*p2++ != 0)');
X write(tab3, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln(tab2, 'j--;');
X writeln(tab1, '}');
X write(tab1, 'return (');
X printid(defnams[dtrue]^.lid);
X writeln(');');
X writeln('}')
X end;
X if usesne then
X begin
X writeln;
X write(static);
X printid(defnams[dboolean]^.lid);
X writeln;
X writeln('Ne(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X write(tab1, 'return (!Eq(p1, p2));');
X writeln('}')
X end;
X if usesle then
X begin
X writeln;
X write(static);
X printid(defnams[dboolean]^.lid);
X writeln;
X writeln('Le(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab1, 'i, j;');
X writeln;
X writeln(tab1, 'i = *p1++;');
X writeln(tab1, 'j = *p2++;');
X writeln(tab1, 'while (i != 0 && j != 0) {');
X writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
X write(tab3, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln(tab2, 'i--, j--;');
X writeln(tab1, '}');
X writeln(tab1, 'while (i != 0) {');
X writeln(tab2, 'if (*p1++ != 0)');
X write(tab3, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln(tab2, 'i--;');
X writeln(tab1, '}');
X write(tab1, 'return (');
X printid(defnams[dtrue]^.lid);
X writeln(');');
X writeln('}')
X end;
X if usesge then
X begin
X writeln;
X write(static);
X printid(defnams[dboolean]^.lid);
X writeln;
X writeln('Ge(p1, p2)');
X writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab1, 'i, j;');
X writeln;
X writeln(tab1, 'i = *p1++;');
X writeln(tab1, 'j = *p2++;');
X writeln(tab1, 'while (i != 0 && j != 0) {');
X writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
X writeln(tab3, 'return (false);');
X writeln(tab2, 'i--, j--;');
X writeln(tab1, '}');
X writeln(tab1, 'while (j != 0) {');
X writeln(tab2, 'if (*p2++ != 0)');
X write(tab3, 'return (');
X printid(defnams[dfalse]^.lid);
X writeln(');');
X writeln(tab2, 'j--;');
X writeln(tab1, '}');
X write(tab1, 'return (');
X printid(defnams[dtrue]^.lid);
X writeln(');');
X writeln('}')
X end;
X if usemksub then
X begin
X writeln;
X writeln(static, setptyp);
X writeln('Mksubr(lo, hi, sp)');
X writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
X writeln(tab1, registr, setptyp, tab1, 'sp;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab1, 'i, k;');
X writeln;
X writeln(tab1, 'if (hi < lo)');
X writeln(tab2, 'return (sp);');
X writeln(tab1, 'i = hi / (setbits+1) + 1;');
X writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
X writeln(tab2, 'sp[k] = 0;');
X writeln(tab1, 'if (*sp < i)');
X writeln(tab2, '*sp = i;');
X writeln(tab1, 'for (k = lo; k <= hi; k++)');
X writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
X '(1 << (k % (setbits+1)));');
X writeln(tab1, 'return (sp);');
X writeln('}')
X end;
X if useins then
X begin
X writeln;
X writeln(static, setptyp);
X writeln('Insmem(m, sp)');
X writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
X writeln(tab1, registr, setptyp, tab1, 'sp;');
X writeln('{');
X writeln(tab1, registr, inttyp, tab1, 'i,');
X writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
X writeln;
X writeln(tab1, 'if (*sp < j)');
X writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
X writeln(tab3, 'sp[i] = 0;');
X writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
X writeln(tab1, 'return (sp);');
X writeln('}')
X end;
X if usesets then
X begin
X writeln;
X writeln(ifndef, 'SETSPACE');
X writeln(define, 'SETSPACE 256');
X writeln(endif);
X writeln(static, setptyp);
X writeln('Currset(n,sp)');
X writeln(tab1, inttyp, tab1, 'n;');
X writeln(tab1, setptyp, tab1, 'sp;');
X writeln('{');
X writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
X writeln(tab1, static, setptyp, tab1, 'Top = Space;');
X writeln;
X writeln(tab1, 'switch (n) {');
X writeln(tab1, ' case 0:');
X writeln(tab2, 'Top = Space;');
X writeln(tab2, 'return (0);');
X writeln(tab1, ' case 1:');
X writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
X maxsetrange:1, ') {');
X writeln(tab3,
X voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
X writeln(tab3, 'exit(1);');
X writeln(tab2, '}');
X writeln(tab2, '*Top = 0;');
X writeln(tab2, 'return (Top);');
X writeln(tab1, ' case 2:');
X writeln(tab2, 'if (Top <= &sp[*sp])');
X writeln(tab3, 'Top = &sp[*sp + 1];');
X writeln(tab2, 'return (sp);');
X writeln(tab1, '}');
X writeln(tab1, '/', '* NOTREACHED *', '/');
X writeln('}')
X end;
X if usescpy then
X begin
X writeln;
X writeln(static, voidtyp);
X writeln('Setncpy(S1, S2, N)');
X writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
X writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
X writeln('{');
X writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
X writeln;
X writeln(tab1, 'N /= sizeof(', setwtyp, ');');
X writeln(tab1, '*S1++ = --N;');
X writeln(tab1, 'm = *S2++;');
X writeln(tab1, 'while (m != 0 && N != 0) {');
X writeln(tab2, '*S1++ = *S2++;');
X writeln(tab2, '--N;');
X writeln(tab2, '--m;');
X writeln(tab1, '}');
X writeln(tab1, 'while (N-- != 0)');
X writeln(tab2, '*S1++ = 0;');
X writeln('}')
X end;
X if usecase then
X begin
X writeln;
X writeln(static, voidtyp);
X writeln('Caseerror(n)');
X writeln(tab1, inttyp, tab1, 'n;');
X writeln('{');
X writeln(tab1, voidcast,
X 'fprintf(stderr, "Missing case limb: line %d\n", n);');
X writeln(tab1, 'exit(1);');
X writeln('}')
X end;
X if usemax then
X begin
X writeln;
X writeln(static, inttyp);
X writeln('Max(m, n)');
X writeln(tab1, inttyp, tab1, 'm, n;');
X writeln('{');
X writeln(tab1, 'if (m > n)');
X writeln(tab2, 'return (m);');
X writeln(tab1, 'return (n);');
X writeln('}')
X end;
X if use(dtrunc) then
X begin
X writeln(static, inttyp);
X writeln('Trunc(f)');
X printid(defnams[dreal]^.lid);
X writeln(tab1, 'f;');
X writeln('{');
X writeln(tab1, 'return f;');
X writeln('}')
X end;
X if use(dround) then
X begin
X writeln(static, inttyp);
X writeln('Round(f)');
X printid(defnams[dreal]^.lid);
X writeln(tab1, 'f;');
X writeln('{');
X writeln(tab1, xtern, doubletyp, ' floor();'); (* LIB *)
X writeln(tab1,
X 'return floor(', dblcast, '(0.5+f));'); (* LIB *)
X writeln('}')
X end
Xend; (* emit *)
X
X(* Initialize all global structures used in translator. *)
Xprocedure initialize;
X
Xvar s : hashtyp;
X t : pretyps;
X d : predefs;
X
X (* Define names in ctable. *)
X procedure defname(cn : cnames; str : keyword);
X
X label 999;
X
X var w : toknbuf;
X i : toknidx;
X
X begin
X unpack(str, w, 1);
X for i := 1 to keywordlen do
X if w[i] = space then
X begin
X w[i] := chr(null);
X goto 999
X end;
X w[keywordlen+1] := chr(null);
X 999:
X ctable[cn] := saveid(w)
X end;
X
X (* Define predefined identifiers. *)
X procedure defid(nt : treetyp; did : predefs; str : keyword);
X
X label 999;
X
X var w : toknbuf;
X i : toknidx;
X tp, tq,
X tv : treeptr;
X
X begin
X for i := 1 to keywordlen do
X if str[i] = space then
X begin
X w[i] := chr(null);
X goto 999
X end
X else
X w[i] := str[i];
X w[keywordlen+1] := chr(null);
X 999:
X tp := newid(saveid(w));
X defnams[did] := tp^.tsym;
X if nt in [ntype, nfunc, nproc] then
X begin
X (* predefined types, procedures and functions
X are marked with a particular node *)
X tv := mknode(npredef);
X tv^.tdef := did;
X tv^.tobtyp := tnone
X end
X else
X tv := nil; (* predefined constants and variables will
X eventually be bound to something *)
X case nt of
X nscalar:
X begin
X tv := mknode(nscalar);
X tv^.tscalid := nil;
X tq := mknode(ntype);
X tq^.tbind := tv;
X tq^.tidl := tp;
X tp := tq
X end;
X nconst,
X ntype,
X nfield,
X nvar:
X begin
X tq := mknode(nt);
X tq^.tbind := tv;
X tq^.tidl := tp;
X tq^.tattr := anone;
X tp := tq
X end;
X nfunc,
X nproc:
X begin
X tq := mknode(nt);
X tq^.tsubid := tp;
X tq^.tsubstmt := tv;
X tq^.tfuntyp := nil;
X tq^.tsubpar := nil;
X tq^.tsublab := nil;
X tq^.tsubconst := nil;
X tq^.tsubtype := nil;
X tq^.tsubvar := nil;
X tq^.tsubsub := nil;
X tq^.tscope := nil;
X tq^.tstat := 0;
X tp := tq
X end;
X nid:
X end;(* case *)
X deftab[did] := tp
X end; (* defid *)
X
X (* Define keywords. *)
X procedure defkey(s : symtyp; w : keyword);
X
X var i : 1 .. keywordlen;
X
X begin
X for i := 1 to keywordlen do
X if w[i] = space then
X w[i] := chr(null);
X (* relies on symtyp being sorted *)
X with keytab[ord(s)] do
X begin
X wrd := w;
X sym := s
X end;
X end;
X
X procedure fixinit(i : strindx);
X
X var t : toknbuf;
X
X begin
X gettokn(i, t);
X t[1] := 'i';
X puttokn(i, t);
X end;
X
X (* Add a cpu word type description. *)
X (* Parameters lo and hi gives the range of a machine- *)
X (* dependant integer type. Parameter str gives the corres- *)
X (* ponding C-language type-name. *)
X procedure defmach(lo, hi : integer; str : machdefstr);
X
X label 999;
X
X var i : toknidx;
X w : toknbuf;
X
X begin
X unpack(str, w, 1);
X if w[machdeflen] <> space then
X error(ebadmach);
X for i := machdeflen - 1 downto 1 do
X if w[i] <> space then
X begin
X w[i+1] := chr(null);
X goto 999
X end;
X error(ebadmach);
X 999:
X if nmachdefs >= maxmachdefs then
X error(emanymachs);
X nmachdefs := nmachdefs + 1;
X with machdefs[nmachdefs] do
X begin
X lolim := lo;
X hilim := hi;
X typstr := savestr(w)
X end
X end;
X
X procedure initstrstore;
X
X var i : strbcnt;
X
X begin
X for i := 1 to maxblkcnt do
X strstor[i] := nil;
X new(strstor[0]);
X strstor[0]^[0] := chr(null);
X strfree := 1;
X strleft := maxstrblk
X end;
X
Xbegin (* initialize *)
X lineno := 1;
X colno := 0;
X
X initstrstore;
X
X setlst := nil;
X setcnt := 0;
X hexdig := '0123456789ABCDEF';
X
X symtab := nil;
X statlvl := 0;
X maxlevel := -1;
X enterscope(nil);
X varno:= 0;
X
X usenilp := false;
X
X usesets := false;
X useunion := false;
X usediff := false;
X usemksub := false;
X useintr := false;
X usesge := false;
X usesle := false;
X usesne := false;
X useseq := false;
X usememb := false;
X useins := false;
X usescpy := false;
X usefopn := false;
X usescan := false;
X usegetl := false;
X
X usecase := false;
X usejmps := false;
X
X usebool := false;
X
X usecomp := false;
X usemax := false;
X
X for s := 0 to hashmax do
X idtab[s] := nil;
X for d := dabs to dztring do
X begin
X deftab[d] := nil;
X defnams[d] := nil
X end;
X
X (* Pascal keywords *)
X defkey(sand, 'and ');
X defkey(sarray, 'array ');
X defkey(sbegin, 'begin ');
X defkey(scase, 'case ');
X defkey(sconst, 'const ');
X defkey(sdiv, 'div ');
X defkey(sdo, 'do ');
X defkey(sdownto, 'downto ');
X defkey(selse, 'else ');
X defkey(send, 'end ');
X defkey(sextern, externsym); (* non-standard *)
X defkey(sfile, 'file ');
X defkey(sfor, 'for ');
X defkey(sforward,'forward ');
X defkey(sfunc, 'function ');
X defkey(sgoto, 'goto ');
X defkey(sif, 'if ');
X defkey(sinn, 'in ');
X defkey(slabel, 'label ');
X defkey(smod, 'mod ');
X defkey(snil, 'nil ');
X defkey(snot, 'not ');
X defkey(sof, 'of ');
X defkey(sor, 'or ');
X defkey(sother, othersym); (* non-standard *)
X defkey(spacked, 'packed ');
X defkey(sproc, 'procedure ');
X defkey(spgm, 'program ');
X defkey(srecord, 'record ');
X defkey(srepeat, 'repeat ');
X defkey(sset, 'set ');
X defkey(sthen, 'then ');
X defkey(sto, 'to ');
X defkey(stype, 'type ');
X defkey(suntil, 'until ');
X defkey(svar, 'var ');
X defkey(swhile, 'while ');
X defkey(swith, 'with ');
X defkey(seof, dummysym); (* dummy entry *)
X
X (* C language operator priorities *)
X cprio[nformat] := 0;
X cprio[nrange] := 0;
X cprio[nin] := 0;
X cprio[nset] := 0;
X cprio[nassign] := 0;
X cprio[nor] := 1;
X cprio[nand] := 2;
X cprio[neq] := 3;
X cprio[nne] := 3;
X cprio[nlt] := 3;
X cprio[nle] := 3;
X cprio[ngt] := 3;
X cprio[nge] := 3;
X cprio[nplus] := 4;
X cprio[nminus] := 4;
X cprio[nmul] := 5;
X cprio[ndiv] := 5;
X cprio[nmod] := 5;
X cprio[nquot] := 5;
X cprio[nnot] := 6;
X cprio[numinus] := 6;
X cprio[nuplus] := 7;
X cprio[nindex] := 7;
X cprio[nselect] := 7;
X cprio[nderef] := 7;
X cprio[ncall] := 7;
X cprio[nid] := 7;
X cprio[nchar] := 7;
X cprio[ninteger] := 7;
X cprio[nreal] := 7;
X cprio[nstring] := 7;
X cprio[nnil] := 7;
X
X (* Pascal language operator priorities *)
X pprio[nassign] := 0;
X pprio[nformat] := 0;
X pprio[nrange] := 1;
X pprio[nin] := 1;
X pprio[neq] := 1;
X pprio[nne] := 1;
X pprio[nlt] := 1;
X pprio[nle] := 1;
X pprio[ngt] := 1;
X pprio[nge] := 1;
X pprio[nor] := 2;
X pprio[nplus] := 2;
X pprio[nminus] := 2;
X pprio[nand] := 3;
X pprio[nmul] := 3;
X pprio[ndiv] := 3;
X pprio[nmod] := 3;
X pprio[nquot] := 3;
X pprio[nnot] := 4;
X pprio[numinus] := 4;
X pprio[nuplus] := 5;
X pprio[nset] := 6;
X pprio[nindex] := 6;
X pprio[nselect] := 6;
X pprio[nderef] := 6;
X pprio[ncall] := 6;
X pprio[nid] := 6;
X pprio[nchar] := 6;
X pprio[ninteger] := 6;
X pprio[nreal] := 6;
X pprio[nstring] := 6;
X pprio[nnil] := 6;
X
X (* table of C keywords/functions (which Pascal doesn't know about) *)
X defname(cabort, 'abort '); (* OS *)
X defname(cbreak, 'break ');
X defname(ccontinue, 'continue ');
X defname(cdefine, 'define ');
X defname(cdefault, 'default ');
X defname(cdouble, 'double ');
X defname(cedata, 'edata '); (* OS *)
X defname(cenum, 'enum ');
X defname(cetext, 'etext '); (* OS *)
X defname(cextern, 'extern ');
X defname(cfclose, 'fclose '); (* LIB *)
X defname(cfflush, 'fflush '); (* LIB *)
X defname(cfgetc, 'fgetc '); (* LIB *)
X defname(cfloat, 'float ');
X defname(cfloor, 'floor '); (* OS *)
X defname(cfprintf, 'fprintf '); (* LIB *)
X defname(cfputc, 'fputc '); (* LIB *)
X defname(cfread, 'fread '); (* LIB *)
X defname(cfscanf, 'fscanf '); (* LIB *)
X defname(cfwrite, 'fwrite '); (* LIB *)
X defname(cgetc, 'getc '); (* OS *)
X defname(cgetpid, 'getpid '); (* OS *)
X defname(cint, 'int ');
X defname(cinclude, 'include ');
X defname(clong, 'long ');
X defname(clog, 'log '); (* OS *)
X defname(cmain, 'main ');
X defname(cmalloc, 'malloc '); (* LIB *)
X defname(cprintf, 'printf '); (* LIB *)
X defname(cpower, 'pow '); (* OS *)
X defname(cputc, 'putc '); (* LIB *)
X defname(cread, 'read '); (* OS *)
X defname(creturn, 'return ');
X defname(cregister, 'register ');
X defname(crewind, 'rewind '); (* LIB *)
X defname(cscanf, 'scanf '); (* LIB *)
X defname(csetbits, 'setbits ');
X defname(csetword, 'setword ');
X defname(csetptr, 'setptr ');
X defname(cshort, 'short ');
X defname(csigned, 'signed ');
X defname(csizeof, 'sizeof ');
X defname(csprintf, 'sprintf '); (* LIB *)
X defname(cstatic, 'static ');
X defname(cstdin, 'stdin '); (* LIB *)
X defname(cstdout, 'stdout '); (* LIB *)
X defname(cstderr, 'stderr '); (* LIB *)
X defname(cstrncmp, 'strncmp '); (* OS *)
X defname(cstrncpy, 'strncpy '); (* OS *)
X defname(cstruct, 'struct ');
X defname(cswitch, 'switch ');
X defname(ctypedef, 'typedef ');
X defname(cundef, 'undef ');
X defname(cungetc, 'ungetc '); (* LIB *)
X defname(cunion, 'union ');
X defname(cunlink, 'unlink '); (* OS *)
X defname(cunsigned, 'unsigned ');
X defname(cwrite, 'write '); (* OS *)
X
X (* create predefined identifiers *)
X defid(nfunc, dabs, 'abs ');
X defid(nfunc, darctan, 'arctan ');
X defid(nvar, dargc, 'argc '); (* OS *)
X defid(nproc, dargv, 'argv '); (* OS *)
X defid(nscalar, dboolean, 'boolean ');
X defid(ntype, dchar, 'char ');
X defid(nfunc, dchr, 'chr ');
X defid(nproc, dclose, 'close '); (* OS *)
X defid(nfunc, dcos, 'cos ');
X defid(nproc, ddispose, 'dispose ');
X defid(nid, dfalse, 'false ');
X defid(nfunc, deof, 'eof ');
X defid(nfunc, deoln, 'eoln ');
X defid(nproc, dexit, 'exit '); (* OS *)
X defid(nfunc, dexp, 'exp ');
X defid(nproc, dflush, 'flush '); (* OS *)
X defid(nproc, dget, 'get ');
X defid(nproc, dhalt, 'halt '); (* OS *)
X defid(nvar, dinput, 'input ');
X defid(ntype, dinteger, 'integer ');
X defid(nfunc, dln, 'ln ');
X defid(nconst, dmaxint, 'maxint ');
X defid(nproc, dmessage, 'message '); (* OS *)
X defid(nproc, dnew, 'new ');
X defid(nfunc, dodd, 'odd ');
X defid(nfunc, dord, 'ord ');
X defid(nvar, doutput, 'output ');
X defid(nproc, dpack, 'pack ');
X defid(nproc, dpage, 'page ');
X defid(nfunc, dpred, 'pred ');
X defid(nproc, dput, 'put ');
X defid(nproc, dread, 'read ');
X defid(nproc, dreadln, 'readln ');
X defid(ntype, dreal, 'real ');
X defid(nproc, dreset, 'reset ');
X defid(nproc, drewrite, 'rewrite ');
X defid(nfunc, dround, 'round ');
X defid(nfunc, dsin, 'sin ');
X defid(nfunc, dsqr, 'sqr ');
X defid(nfunc, dsqrt, 'sqrt ');
X defid(nfunc, dsucc, 'succ ');
X defid(ntype, dtext, 'text ');
X defid(nid, dtrue, 'true ');
X defid(nfunc, dtrunc, 'trunc ');
X defid(nfunc, dtan, 'tan ');
X defid(nproc, dunpack, 'unpack ');
X defid(nproc, dwrite, 'write ');
X defid(nproc, dwriteln, 'writeln ');
X
X defid(nfield, dzinit, '$nit '); (* for internal use *)
X defid(ntype, dztring, '$ztring ');
X
X (* bind constants and variables *)
X deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
X deftab[dfalse]^.tnext := deftab[dtrue];
X currsym.st := sinteger;
X currsym.vint := maxint;
X deftab[dmaxint]^.tbind := mklit;
X deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
X deftab[dinput]^.tbind := deftab[dtext]^.tbind;
X deftab[doutput]^.tbind := deftab[dtext]^.tbind;
X
X for t := tnone to terror do
X begin
X (* for predefined types: set up pointers to "npredef" nodes
X describing type, fill in constant identifying type *)
X case t of
X tboolean:
X typnods[t] := deftab[dboolean]; (* scalar type *)
X tchar:
X typnods[t] := deftab[dchar]^.tbind;
X tinteger:
X typnods[t] := deftab[dinteger]^.tbind;
X treal:
X typnods[t] := deftab[dreal]^.tbind;
X ttext:
X typnods[t] := deftab[dtext]^.tbind;
X tstring:
X typnods[t] := deftab[dztring]^.tbind;
X tnil,
X tset,
X tpoly,
X tnone:
X typnods[t] := mknode(npredef);
X terror:
X (* no op *)
X end;(* case *)
X if t in [tchar, tinteger, treal, ttext, tnone, tpoly,
X tstring, tnil, tset] then
X typnods[t]^.tobtyp := t
X end;
X
X (* fix name and type of field "init" *)
X fixinit(defnams[dzinit]^.lid^.istr);
X deftab[dzinit]^.tbind := deftab[dinteger]^.tbind;
X
X for d := dabs to dztring do
X linkup(nil, deftab[d]);
X
X deftab[dchr]^.tfuntyp := typnods[tchar];
X
X deftab[deof]^.tfuntyp := typnods[tboolean];
X deftab[deoln]^.tfuntyp := typnods[tboolean];
X deftab[dodd]^.tfuntyp := typnods[tboolean];
X
X deftab[dord]^.tfuntyp := typnods[tinteger];
X deftab[dround]^.tfuntyp := typnods[tinteger];
X deftab[dtrunc]^.tfuntyp := typnods[tinteger];
X
X deftab[darctan]^.tfuntyp := typnods[treal];
X deftab[dcos]^.tfuntyp := typnods[treal];
X deftab[dsin]^.tfuntyp := typnods[treal];
X deftab[dtan]^.tfuntyp := typnods[treal];
X deftab[dsqrt]^.tfuntyp := typnods[treal];
X deftab[dexp]^.tfuntyp := typnods[treal];
X deftab[dln]^.tfuntyp := typnods[treal];
X
X deftab[dsqr]^.tfuntyp := typnods[tpoly];
X deftab[dabs]^.tfuntyp := typnods[tpoly];
X deftab[dpred]^.tfuntyp := typnods[tpoly];
X deftab[dsucc]^.tfuntyp := typnods[tpoly];
X
X deftab[dargv]^.tfuntyp := typnods[tnone];
X deftab[ddispose]^.tfuntyp := typnods[tnone];
X deftab[dexit]^.tfuntyp := typnods[tnone];
X deftab[dget]^.tfuntyp := typnods[tnone];
X deftab[dhalt]^.tfuntyp := typnods[tnone];
X deftab[dnew]^.tfuntyp := typnods[tnone];
X deftab[dpack]^.tfuntyp := typnods[tnone];
X deftab[dput]^.tfuntyp := typnods[tnone];
X deftab[dread]^.tfuntyp := typnods[tnone];
X deftab[dreadln]^.tfuntyp := typnods[tnone];
X deftab[dreset]^.tfuntyp := typnods[tnone];
X deftab[drewrite]^.tfuntyp := typnods[tnone];
X deftab[dwrite]^.tfuntyp := typnods[tnone];
X deftab[dwriteln]^.tfuntyp := typnods[tnone];
X deftab[dmessage]^.tfuntyp := typnods[tnone];
X deftab[dunpack]^.tfuntyp := typnods[tnone];
X
X (* set up definitions for integer subranges *)
X nmachdefs := 0;
X defmach(0, 255, 'unsigned char '); (* CPU *)
X defmach(-128, 127, 'char '); (* CPU *)
X defmach(0, 65535, 'unsigned short '); (* CPU *)
X defmach(-32768, 32767, 'short '); (* CPU *)
X defmach(-2147483647, 2147483647, 'long '); (* CPU *)
X{ defmach(0, 4294967295, 'unsigned long ');}(* CPU *)
Xend; (* initialize *)
X
Xprocedure exit(i : integer); external; (* OS *)
X
X(* Action to take when an error is detected. *)
Xprocedure error;
X
Xbegin
X prtmsg(m);
X exit(1); (* OS *)
X goto 9999
Xend;
X
X(* Action to take when a fatal error is detected. *)
Xprocedure fatal;
X
Xbegin
X prtmsg(m);
X halt (* OS *)
X (* goto 9999 *)
Xend;
X
X
Xbegin (* program *)
X initialize;
X if echo then
X writeln('# ifdef PASCAL');
X parse;
X if echo then
X writeln('# else');
X lineno := 0; lastline := 0;
X transform;
X emit;
X if echo then
X writeln('# endif');
X9999:
X (* the very *)
Xend.
X
END_OF_FILE
if test 54467 -ne `wc -c <'ptc.p.4'`; then
echo shar: \"'ptc.p.4'\" unpacked with wrong size!
fi
# end of 'ptc.p.4'
fi
echo shar: End of archive 11 \(of 12\).
cp /dev/null ark11isdone
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.ul de(*