rs@uunet.UU.NET (Rich Salz) (07/28/87)
Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 67
Archive-name: ptoc/Part03
#! /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 3 (of 12)."
# Contents: ptc.c.1
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'ptc.c.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ptc.c.1'\"
else
echo shar: Extracting \"'ptc.c.1'\" \(33774 characters\)
sed "s/^X//" >'ptc.c.1' <<'END_OF_FILE'
X/***************************************************************************/
X/***************************************************************************/
X/** **/
X/** Copyright (C) 1987 by Per Bergsten, Gothenburg, Sweden **/
X/** **/
X/** No part of this program, or parts derived from this program, **/
X/** may be sold, hired or otherwise exploited without the author's **/
X/** written consent. **/
X/** **/
X/** The program may be freely redistributed provided that: **/
X/** **/
X/** 1) the original program text, including this notice, **/
X/** is reproduced unaltered, **/
X/** 2) no charge (other than a nominal media cost) is **/
X/** demanded for the copy. **/
X/** **/
X/** The program may be included in a package only on the condition **/
X/** that the package as a whole is distributed at media cost. **/
X/** **/
X/***************************************************************************/
X/***************************************************************************/
X/** **/
X/** The program is a Pascal-to-C translator. **/
X/** It accepts a correct Pascal program and creates a C program **/
X/** with the same behaviour. It is not a complete compiler in the **/
X/** sense that it does NOT do complete typechecking or error- **/
X/** reporting. Only a minimal typecheck is done so that the meaning **/
X/** of each construct can be determined. Therefore, an incorrect **/
X/** Pascal program can easily cause the translator to malfunction. **/
X/** **/
X/***************************************************************************/
X/***************************************************************************/
X/** **/
X/** Things which are known to be dependent on the underlying cha- **/
X/** racterset are marked with a comment containing the word CHAR. **/
X/** Things that are known to be dependent on the host operating **/
X/** system are marked with a comment containing the word OS. **/
X/** Things known to be dependent on the cpu and/or the target C- **/
X/** implementation are marked with the word CPU. **/
X/** Things dependent on the target C-library are marked with LIB. **/
X/** **/
X/** The code generated by the translator assumes that there is a **/
X/** C-implementation with at least a reasonable <stdio> library **/
X/** since all input/output is implemented in terms of C functions **/
X/** like fprintf(), getc(), fopen(), rewind() etc. **/
X/** If the source-program uses Pascal functions like sin(), sqrt() **/
X/** etc, there must also exist such functions in the C-library. **/
X/** **/
X/***************************************************************************/
X/***************************************************************************/
X/*
X** Code derived from program ptc
X*/
Xextern void exit();
X/*
X** Definitions for i/o
X*/
X# include <stdio.h>
Xtypedef struct {
X FILE *fp;
X unsigned short eoln:1,
X eof:1,
X out:1,
X init:1,
X :12;
X char buf;
X} text;
Xtext input = { stdin, 0, 0 };
Xtext output = { stdout, 0, 0 };
X# define Fread(x, f) fread((char *)&x, sizeof(x), 1, f)
X# define Get(f) Fread((f).buf, (f).fp)
X# define Getx(f) (f).init = 1, (f).eoln = (((f).buf = fgetc((f).fp)) == '\n') ? (((f).buf = ' '), 1) : 0
X# define Getchr(f) (f).buf, Getx(f)
Xstatic FILE *Tmpfil;
Xstatic long Tmplng;
Xstatic double Tmpdbl;
X# define Fscan(f) (f).init ? ungetc((f).buf, (f).fp) : 0, Tmpfil = (f).fp
X# define Scan(p, a) Scanck(fscanf(Tmpfil, p, a))
Xvoid Scanck();
X# define Eoln(f) ((f).eoln ? true : false)
X# define Eof(f) ((((f).init == 0) ? (Get(f)) : 0, ((f).eof ? 1 : feof((f).fp))) ? true : false)
X# define Fwrite(x, f) fwrite((char *)&x, sizeof(x), 1, f)
X# define Put(f) Fwrite((f).buf, (f).fp)
X# define Putx(f) (f).eoln = ((f).buf == '\n'), (void)fputc((f).buf, (f).fp)
X# define Putchr(c, f) (f).buf = (c), Putx(f)
X# define Putl(f, v) (f).eoln = v
X/*
X** Definitions for case-statements
X** and for non-local gotos
X*/
X# define Line __LINE__
Xvoid Caseerror();
X# include <setjmp.h>
Xstatic struct Jb { jmp_buf jb; } J[1];
X/*
X** Definitions for standard types
X*/
Xextern int strncmp();
X# define Cmpstr(x, y) strncmp((x), (y), sizeof(x))
Xtypedef char boolean;
X# define false (boolean)0
X# define true (boolean)1
Xextern char *Bools[];
Xtypedef int integer;
X# define maxint 2147483647
Xextern void abort();
X/*
X** Definitions for pointers
X*/
X# ifndef Unionoffs
X# define Unionoffs(p, m) (((long)(&(p)->m))-((long)(p)))
X# endif
X# define NIL 0
Xextern char *malloc();
X/*
X** Definitions for set-operations
X*/
X# define Claimset() (void)Currset(0, (setptr)0)
X# define Newset() Currset(1, (setptr)0)
X# define Saveset(s) Currset(2, s)
X# define setbits 15
Xtypedef unsigned short setword;
Xtypedef setword * setptr;
Xboolean Member(), Le(), Ge(), Eq(), Ne();
Xsetptr Union(), Diff();
Xsetptr Insmem(), Mksubr();
Xsetptr Currset(), Inter();
Xstatic setptr Tmpset;
Xextern setptr Conset[];
Xvoid Setncpy();
Xextern char *strncpy();
X/*
X** Start of program definitions
X*/
Xstatic char version[] = "From: @(#)ptc.p 1.5 Date 87/05/01";
Xstatic char sccsid[] = "@(#)ptc.c 1.2 Date 87/05/09";
X# define keytablen 38
X# define keywordlen 10
Xstatic char othersym[] = "otherwise ";
Xstatic char externsym[] = "external ";
Xstatic char dummysym[] = " ";
Xstatic char wordtype[] = "unsigned short";
X# define C37_setbits 15
Xstatic char filebits[] = "unsigned short";
X# define filefill 12
X# define maxsetrange 15
X# define scalbase 0
X# define maxprio 7
X# define maxmachdefs 8
X# define machdeflen 16
X# define maxstrblk 1023
X# define maxblkcnt 63
X# define maxstrstor 65535
X# define maxtoknlen 127
X# define hashmax 64
X# define null 0
X# define minchar null
X# define maxchar 127
Xstatic char tmpfilename[] = "\"/tmp/ptc%d%c\", getpid(), ";
X# define space ' '
X# define tab1 ' '
Xstatic char tab2[] = " ";
Xstatic char tab3[] = " ";
Xstatic char tab4[] = " ";
X# define bslash '\\'
Xstatic char nlchr[] = "'\\n'";
Xstatic char ffchr[] = "'\\f'";
Xstatic char nulchr[] = "'\\0'";
Xstatic char spchr[] = "' '";
X# define quote '\''
X# define cite '"'
X# define xpnent 'e'
X# define percent '%'
X# define uscore '_'
X# define badchr '?'
X# define okchr quote
X# define tabwidth 8
X# define echo false
X# define diffcomm false
X# define lazyfor false
X# define unionnew true
Xstatic char inttyp[] = "int";
Xstatic char chartyp[] = "char";
Xstatic char setwtyp[] = "setword";
Xstatic char setptyp[] = "setptr";
Xstatic char floattyp[] = "float";
Xstatic char doubletyp[] = "double";
Xstatic char dblcast[] = "(double)";
X# define realtyp doubletyp
Xstatic char voidtyp[] = "void";
Xstatic char voidcast[] = "(void)";
X# define intlen 10
X# define fixlen 20
Xstatic char C24_include[] = "# include ";
Xstatic char C4_define[] = "# define ";
Xstatic char ifdef[] = "# ifdef ";
Xstatic char ifndef[] = "# ifndef ";
Xstatic char elsif[] = "# else";
Xstatic char endif[] = "# endif";
Xstatic char C50_static[] = "static ";
Xstatic char xtern[] = "extern ";
Xstatic char typdef[] = "typedef ";
Xstatic char registr[] = "register ";
X# define indstep 8
Xtypedef unsigned char hashtyp;
Xtypedef unsigned short strindx;
Xtypedef unsigned short strbidx;
Xtypedef struct { char A[maxstrblk + 1]; } strblk;
Xtypedef strblk * strptr;
Xtypedef unsigned char strbcnt;
Xtypedef struct S59 * idptr;
Xtypedef struct S59 {
X idptr inext;
X unsigned char inref;
X hashtyp ihash;
X strindx istr;
X} idnode;
Xtypedef unsigned char toknidx;
Xtypedef struct { char A[maxtoknlen - 1 + 1]; } toknbuf;
Xtypedef struct { char A[keywordlen - 1 + 1]; } keyword;
Xtypedef enum { dabs, darctan, dargc, dargv,
X dboolean, dchar, dchr, dclose,
X dcos, ddispose, deof, deoln,
X dexit, dexp, dfalse, dflush,
X dget, dhalt, dinput, dinteger,
X dln, dmaxint, dmessage, dnew,
X dodd, dord, doutput, dpage,
X dpack, dpred, dput, dread,
X dreadln, dreal, dreset, drewrite,
X dround, dsin, dsqr, dsqrt,
X dsucc, dtext, dtrue, dtrunc,
X dtan, dwrite, dwriteln, dunpack,
X dzinit, dztring } predefs;
Xtypedef enum { sand, sarray, sbegin, scase,
X sconst, sdiv, sdo, sdownto,
X selse, send, sextern, sfile,
X sfor, sforward, sfunc, sgoto,
X sif, sinn, slabel, smod,
X snil, snot, sof, sor,
X sother, spacked, sproc, spgm,
X srecord, srepeat, sset, sthen,
X sto, stype, suntil, svar,
X swhile, swith, seof, sinteger,
X sreal, sstring, schar, sid,
X splus, sminus, smul, squot,
X sarrow, slpar, srpar, slbrack,
X srbrack, seq, sne, slt,
X sle, sgt, sge, scomma,
X scolon, ssemic, sassign, sdotdot,
X sdot } symtyp;
Xtypedef struct { setword S[6]; } symset;
Xtypedef struct S180 {
X symtyp st;
X union {
X struct {
X idptr vid;
X } V1;
X struct {
X char vchr;
X } V2;
X struct {
X integer vint;
X } V3;
X struct {
X strindx vflt;
X } V4;
X struct {
X strindx vstr;
X } V5;
X } U;
X} lexsym;
Xtypedef enum { lpredef, lidentifier, lfield, lforward,
X lpointer, lstring, llabel, lforwlab,
X linteger, lreal, lcharacter } ltypes;
Xtypedef struct S60 * declptr;
Xtypedef struct S61 * treeptr;
Xtypedef struct S62 * symptr;
Xtypedef struct S62 {
X treeptr lsymdecl;
X symptr lnext;
X declptr ldecl;
X ltypes lt;
X union {
X struct {
X idptr lid;
X boolean lused;
X } V6;
X struct {
X strindx lstr;
X } V7;
X struct {
X strindx lfloat;
X } V8;
X struct {
X integer lno;
X boolean lgo;
X } V9;
X struct {
X integer linum;
X } V10;
X struct {
X char lchar;
X } V11;
X } U;
X} symnode;
Xtypedef struct S60 {
X declptr dprev;
X struct { symptr A[hashmax + 1]; } ddecl;
X} declnode;
Xtypedef enum { npredef, npgm, nfunc, nproc,
X nlabel, nconst, ntype, nvar,
X nvalpar, nvarpar, nparproc, nparfunc,
X nsubrange, nvariant, nfield, nrecord,
X narray, nconfarr, nfileof, nsetof,
X nbegin, nptr, nscalar, nif,
X nwhile, nrepeat, nfor, ncase,
X nchoise, ngoto, nwith, nwithvar,
X nempty, nlabstmt, nassign, nformat,
X nin, neq, nne, nlt,
X nle, ngt, nge, nor,
X nplus, nminus, nand, nmul,
X ndiv, nmod, nquot, nnot,
X numinus, nuplus, nset, nrange,
X nindex, nselect, nderef, ncall,
X nid, nchar, ninteger, nreal,
X nstring, nnil, npush, npop,
X nbreak } treetyp;
Xtypedef enum { tnone, tboolean, tchar, tinteger,
X treal, tstring, tnil, tset,
X ttext, tpoly, terror } pretyps;
Xtypedef enum { anone, aregister, aextern, areference } attributes;
Xtypedef struct S61 {
X treeptr tnext, ttype, tup;
X treetyp tt;
X union {
X struct {
X predefs tdef;
X pretyps tobtyp;
X } V12;
X struct {
X treeptr tsubid, tsubpar, tfuntyp, tsublab,
X tsubconst, tsubtype, tsubvar, tsubsub,
X tsubstmt;
X integer tstat;
X declptr tscope;
X } V13;
X struct {
X treeptr tidl, tbind;
X attributes tattr;
X } V14;
X struct {
X treeptr tparid, tparparm, tpartyp;
X } V15;
X struct {
X treeptr tptrid;
X boolean tptrflag;
X } V16;
X struct {
X treeptr tscalid;
X } V17;
X struct {
X treeptr tof;
X } V18;
X struct {
X treeptr tlo, thi;
X } V19;
X struct {
X treeptr tselct, tvrnt;
X } V20;
X struct {
X treeptr tflist, tvlist;
X idptr tuid;
X declptr trscope;
X } V21;
X struct {
X treeptr tcindx, tindtyp, tcelem;
X idptr tcuid;
X } V22;
X struct {
X treeptr taindx, taelem;
X } V23;
X struct {
X treeptr tbegin;
X } V24;
X struct {
X treeptr tlabno, tstmt;
X } V25;
X struct {
X treeptr tlabel;
X } V26;
X struct {
X treeptr tlhs, trhs;
X } V27;
X struct {
X treeptr tglob, tloc, ttmp;
X } V28;
X struct {
X treeptr tbrkid, tbrkxp;
X } V29;
X struct {
X treeptr tcall, taparm;
X } V30;
X struct {
X treeptr tifxp, tthen, telse;
X } V31;
X struct {
X treeptr twhixp, twhistmt;
X } V32;
X struct {
X treeptr treptstmt, treptxp;
X } V33;
X struct {
X treeptr tforid, tfrom, tto, tforstmt;
X boolean tincr;
X } V34;
X struct {
X treeptr tcasxp, tcaslst, tcasother;
X } V35;
X struct {
X treeptr tchocon, tchostmt;
X } V36;
X struct {
X treeptr twithvar, twithstmt;
X } V37;
X struct {
X treeptr texpw;
X declptr tenv;
X } V38;
X struct {
X treeptr tvariable, toffset;
X } V39;
X struct {
X treeptr trecord, tfield;
X } V40;
X struct {
X treeptr texpl, texpr;
X } V41;
X struct {
X treeptr texps;
X } V42;
X struct {
X symptr tsym;
X } V43;
X } U;
X} treenode;
Xtypedef enum { cabort, cbreak, ccontinue, cdefine,
X cdefault, cdouble, cedata, cenum,
X cetext, cextern, cfgetc, cfclose,
X cfflush, cfloat, cfloor, cfprintf,
X cfputc, cfread, cfscanf, cfwrite,
X cgetc, cgetpid, cint, cinclude,
X clong, clog, cmain, cmalloc,
X cprintf, cpower, cputc, cread,
X creturn, cregister, crewind, cscanf,
X csetbits, csetword, csetptr, cshort,
X csigned, csizeof, csprintf, cstdin,
X cstdout, cstderr, cstrncmp, cstrncpy,
X cstruct, cstatic, cswitch, ctypedef,
X cundef, cungetc, cunion, cunlink,
X cunsigned, cwrite } cnames;
Xtypedef enum { ebadsymbol, elongstring, elongtokn, erange,
X emanytokn, enotdeclid, emultdeclid, enotdecllab,
X emultdecllab, emuldeflab, ebadstring, enulchr,
X ebadchar, eeofcmnt, eeofstr, evarpar,
X enew, esetbase, esetsize, eoverflow,
X etree, etag, euprconf, easgnconf,
X ecmpconf, econfconf, evrntfile, evarfile,
X emanymachs, ebadmach } errors;
Xtypedef struct { char A[machdeflen - 1 + 1]; } machdefstr;
Xtypedef struct { struct S206 {
X keyword wrd;
X symtyp sym;
X} A[keytablen + 1]; } T63;
Xtypedef struct { strptr A[maxblkcnt + 1]; } T64;
Xtypedef struct { idptr A[hashmax + 1]; } T65;
Xtypedef struct { treeptr A[50]; } T66;
Xtypedef struct { symptr A[50]; } T67;
Xtypedef struct { treeptr A[11]; } T68;
Xtypedef struct { unsigned char A[(int)(nnil) - (int)(nassign) + 1]; } T69;
Xtypedef struct { idptr A[58]; } T70;
Xtypedef struct { struct S193 {
X integer lolim, hilim;
X strindx typstr;
X} A[maxmachdefs - 1 + 1]; } T71;
Xtypedef struct { char A[15 + 1]; } T72;
Xtypedef struct { setword S[2]; } bitset;
Xinteger *G204_indnt;
Xinteger *G202_doarrow;
Xboolean *G200_donearr;
Xboolean *G198_dropset;
Xboolean *G196_setused;
Xboolean *G194_conflag;
Xinteger *G191_nelems;
Xtreeptr *G189_vp;
Xtreeptr *G187_tv;
Xsymptr *G185_iq;
Xsymptr *G183_ip;
Xunsigned char *G181_lastchr;
Xtoknidx *G178_i;
Xtoknbuf *G176_t;
Xboolean usemax, usejmps, usecase, usesets, useunion, usediff,
X usemksub, useintr, usesge, usesle, useseq, usesne,
X usememb, useins, usescpy, usecomp, usefopn, usescan,
X usegetl, usenilp, usebool;
Xtreeptr top;
Xtreeptr setlst;
Xinteger setcnt;
Xlexsym currsym;
XT63 keytab;
XT64 strstor;
Xstrindx strfree;
Xstrbidx strleft;
XT65 idtab;
Xdeclptr symtab;
Xinteger statlvl, maxlevel;
XT66 deftab;
XT67 defnams;
XT68 typnods;
XT69 pprio, cprio;
XT70 ctable;
Xunsigned char nmachdefs;
XT71 machdefs;
Xinteger lineno, colno, lastcol, lastline;
Xtoknbuf lasttok;
Xinteger varno;
XT72 hexdig;
X
X void
Xprtmsg(m)
X errors m;
X{
X static char user[] = "Error: ";
X static char restr[] = "Implementation restriction: ";
X static char inter[] = "* Internal error * ";
X# define xtoklen 64
X typedef struct { char A[xtoklen - 1 + 1]; } T73;
X toknidx i;
X T73 xtok;
X
X switch (m) {
X case ebadsymbol:
X (void)fprintf(stderr, "%sUnexpected symbol\n", user), Putl(output, 1);
X break ;
X case ebadchar:
X (void)fprintf(stderr, "%sBad character\n", user), Putl(output, 1);
X break ;
X case elongstring:
X (void)fprintf(stderr, "%sToo long string\n", restr), Putl(output, 1);
X break ;
X case ebadstring:
X (void)fprintf(stderr, "%sNewline in string or character\n", user), Putl(output, 1);
X break ;
X case eeofstr:
X (void)fprintf(stderr, "%sEnd of file in string or character\n", user), Putl(output, 1);
X break ;
X case eeofcmnt:
X (void)fprintf(stderr, "%sEnd of file in comment\n", user), Putl(output, 1);
X break ;
X case elongtokn:
X (void)fprintf(stderr, "%sToo long identfier\n", restr), Putl(output, 1);
X break ;
X case emanytokn:
X (void)fprintf(stderr, "%sToo many strings, identifiers or real numbers\n", restr), Putl(output, 1);
X break ;
X case enotdeclid:
X (void)fprintf(stderr, "%sIdentifier not declared\n", user), Putl(output, 1);
X break ;
X case emultdeclid:
X (void)fprintf(stderr, "%sIdentifier declared twice\n", user), Putl(output, 1);
X break ;
X case enotdecllab:
X (void)fprintf(stderr, "%sLabel not declared\n", user), Putl(output, 1);
X break ;
X case emultdecllab:
X (void)fprintf(stderr, "%sLabel declared twice\n", user), Putl(output, 1);
X break ;
X case emuldeflab:
X (void)fprintf(stderr, "%sLabel defined twice\n", user), Putl(output, 1);
X break ;
X case evarpar:
X (void)fprintf(stderr, "%sActual parameter not a variable\n", user), Putl(output, 1);
X break ;
X case enulchr:
X (void)fprintf(stderr, "%sCannot handle nul-character in strings\n", restr), Putl(output, 1);
X break ;
X case enew:
X (void)fprintf(stderr, "%sNew returned a nil-pointer\n", restr), Putl(output, 1);
X break ;
X case eoverflow:
X (void)fprintf(stderr, "%sToken buffer overflowed\n", restr), Putl(output, 1);
X break ;
X case esetbase:
X (void)fprintf(stderr, "%sCannot handle sets with base >> 0\n", restr), Putl(output, 1);
X break ;
X case esetsize:
X (void)fprintf(stderr, "%sCannot handle sets with very large range\n", restr), Putl(output, 1);
X break ;
X case etree:
X (void)fprintf(stderr, "%sBad tree structure\n", inter), Putl(output, 1);
X break ;
X case etag:
X (void)fprintf(stderr, "%sCannot find tag\n", inter), Putl(output, 1);
X break ;
X case evrntfile:
X (void)fprintf(stderr, "%sCannot initialize files in record variants\n", restr), Putl(output, 1);
X break ;
X case evarfile:
X (void)fprintf(stderr, "%sCannot handle files in structured variables\n", restr), Putl(output, 1);
X break ;
X case euprconf:
X (void)fprintf(stderr, "%sNo upper bound on conformant arrays\n", inter), Putl(output, 1);
X break ;
X case easgnconf:
X (void)fprintf(stderr, "%sCannot assign conformant arrays\n", inter), Putl(output, 1);
X break ;
X case ecmpconf:
X (void)fprintf(stderr, "%sCannot compare conformant arrays\n", inter), Putl(output, 1);
X break ;
X case econfconf:
X (void)fprintf(stderr, "%sCannot handle nested conformat arrays\n", restr), Putl(output, 1);
X break ;
X case erange:
X (void)fprintf(stderr, "%sCannot find C-type for integer-subrange\n", inter), Putl(output, 1);
X break ;
X case emanymachs:
X (void)fprintf(stderr, "%sToo many machine integer types\n", restr), Putl(output, 1);
X break ;
X case ebadmach:
X (void)fprintf(stderr, "%sBad name for machine integer type\n", inter), Putl(output, 1);
X break ;
X default:
X Caseerror(Line);
X }
X if (lastline != 0) {
X (void)fprintf(stderr, "Line %1d, col %1d:\n", lastline, lastcol), Putl(output, 1);
X if (Member((unsigned)(m), Conset[0])) {
X i = 1;
X while ((i < xtoklen) && (lasttok.A[i - 1] != null)) {
X xtok.A[i - 1] = lasttok.A[i - 1];
X i = i + 1;
X }
X while (i < xtoklen) {
X xtok.A[i - 1] = ' ';
X i = i + 1;
X }
X xtok.A[xtoklen - 1] = ' ';
X (void)fprintf(stderr, "Current symbol: %.64s\n", xtok.A), Putl(output, 1);
X }
X }
X}
X
Xvoid fatal();
X
Xvoid error();
X
X char
Xuppercase(c)
X char c;
X{
X register char R75;
X
X if ((c >= 'a') && (c <= 'z'))
X R75 = (unsigned)(c) + (unsigned)('A') - (unsigned)('a');
X else
X R75 = c;
X return R75;
X}
X
X char
Xlowercase(c)
X char c;
X{
X register char R76;
X
X if ((c >= 'A') && (c <= 'Z'))
X R76 = (unsigned)(c) - (unsigned)('A') + (unsigned)('a');
X else
X R76 = c;
X return R76;
X}
X
X void
Xgettokn(i, t)
X strindx i;
X toknbuf *t;
X{
X char c;
X toknidx k;
X strbidx j;
X strptr p;
X
X k = 1;
X p = strstor.A[i / (maxstrblk + 1)];
X j = i % (maxstrblk + 1);
X do {
X c = p->A[j];
X t->A[k - 1] = c;
X j = j + 1;
X k = k + 1;
X if (k == maxtoknlen) {
X c = null;
X t->A[maxtoknlen - 1] = null;
X prtmsg(eoverflow);
X }
X } while (!(c == null));
X}
X
X void
Xputtokn(i, t)
X strindx i;
X toknbuf *t;
X{
X char c;
X toknidx k;
X strbidx j;
X strptr p;
X
X k = 1;
X p = strstor.A[i / (maxstrblk + 1)];
X j = i % (maxstrblk + 1);
X do {
X c = t->A[k - 1];
X p->A[j] = c;
X k = k + 1;
X j = j + 1;
X } while (!(c == null));
X}
X
X void
Xwritetok(w)
X toknbuf *w;
X{
X toknidx j;
X
X j = 1;
X while (w->A[j - 1] != null) {
X Putchr(w->A[j - 1], output);
X j = j + 1;
X }
X}
X
X void
Xprinttok(i)
X strindx i;
X{
X toknbuf w;
X
X gettokn(i, &w);
X writetok(&w);
X}
X
X void
Xprintid(ip)
X idptr ip;
X{
X printtok(ip->istr);
X}
X
X void
Xprintchr(c)
X char c;
X{
X if ((c == quote) || (c == bslash))
X (void)fprintf(output.fp, "%c%c%c%c", quote, bslash, c, quote), Putl(output, 0);
X else
X (void)fprintf(output.fp, "%c%c%c", quote, c, quote), Putl(output, 0);
X}
X
X void
Xprintstr(i)
X strindx i;
X{
X toknidx k;
X char c;
X toknbuf w;
X
X gettokn(i, &w);
X Putchr(cite, output);
X k = 1;
X while (w.A[k - 1] != null) {
X c = w.A[k - 1];
X k = k + 1;
X if ((c == cite) || (c == bslash))
X Putchr(bslash, output);
X Putchr(c, output);
X }
X Putchr(cite, output);
X}
X
X treeptr
Xidup(ip)
X treeptr ip;
X{
X register treeptr R77;
X
X R77 = ip->U.V43.tsym->lsymdecl->tup;
X return R77;
X}
X
X hashtyp
Xhashtokn(id)
X toknbuf *id;
X{
X register hashtyp R78;
X integer h;
X toknidx i;
X
X i = 1;
X h = 0;
X while (id->A[i - 1] != null) {
X h = h + (unsigned)(id->A[i - 1]);
X i = i + 1;
X }
X R78 = h % hashmax;
X return R78;
X}
X
X strindx
Xsavestr(t)
X toknbuf *t;
X{
X register strindx R79;
X toknidx k;
X strindx i;
X strbcnt j;
X
X k = 1;
X while (t->A[k - 1] != null)
X k = k + 1;
X if (k > strleft) {
X if (strstor.A[maxblkcnt] != (strblk *)NIL)
X error(emanytokn);
X j = (strfree + maxstrblk) / (maxstrblk + 1);
X strstor.A[j] = (strblk *)malloc((unsigned)(sizeof(*strstor.A[j])));
X if (strstor.A[j] == (strblk *)NIL)
X error(enew);
X strfree = j * (maxstrblk + 1);
X strleft = maxstrblk;
X }
X i = strfree;
X strfree = strfree + k;
X strleft = strleft - k;
X puttokn(i, &(*t));
X R79 = i;
X return R79;
X}
X
X idptr
Xsaveid(id)
X toknbuf *id;
X{
X register idptr R80;
X toknidx k;
X idptr ip;
X hashtyp h;
X toknbuf t;
X
X h = hashtokn(&(*id));
X ip = idtab.A[h];
X while (ip != (struct S59 *)NIL) {
X gettokn(ip->istr, &t);
X k = 1;
X while (id->A[k - 1] == t.A[k - 1])
X if (id->A[k - 1] == null)
X goto L999;
X else
X k = k + 1;
X ip = ip->inext;
X }
X ip = (struct S59 *)malloc((unsigned)(sizeof(*ip)));
X if (ip == (struct S59 *)NIL)
X error(enew);
X ip->inref = 0;
X ip->istr = savestr(&(*id));
X ip->ihash = h;
X ip->inext = idtab.A[h];
X idtab.A[h] = ip;
XL999:
X R80 = ip;
X return R80;
X}
X
X idptr
Xmkconc(sep, p, q)
X char sep;
X idptr p, q;
X{
X register idptr R81;
X toknbuf w, x;
X toknidx i, j;
X
X gettokn(q->istr, &x);
X j = 1;
X while (x.A[j - 1] != null)
X j = j + 1;
X w.A[1 - 1] = null;
X if (p != (struct S59 *)NIL)
X gettokn(p->istr, &w);
X i = 1;
X while (w.A[i - 1] != null)
X i = i + 1;
X if (i + j + 2 >= maxtoknlen)
X error(eoverflow);
X if (sep == '>') {
X w.A[i - 1] = '-';
X i = i + 1;
X }
X if (sep != space) {
X w.A[i - 1] = sep;
X i = i + 1;
X }
X j = 1;
X do {
X w.A[i - 1] = x.A[j - 1];
X i = i + 1;
X j = j + 1;
X } while (!(w.A[i - 1 - 1] == null));
X R81 = saveid(&w);
X return R81;
X}
X
Xidptr mkuniqname();
X
X void
Xdig(n)
X integer n;
X{
X if (n > 0) {
X dig(n / 10);
X if ((*G178_i) == maxtoknlen)
X error(eoverflow);
X (*G176_t).A[(*G178_i) - 1] = n % 10 + (unsigned)('0');
X (*G178_i) = (*G178_i) + 1;
X }
X}
X
X idptr
Xmkuniqname(t)
X toknbuf *t;
X{
X register idptr R82;
X toknidx i;
X toknbuf *F177;
X toknidx *F179;
X
X F179 = G178_i;
X G178_i = &i;
X F177 = G176_t;
X G176_t = &(*t);
X (*G178_i) = 1;
X while ((*G176_t).A[(*G178_i) - 1] != null)
X (*G178_i) = (*G178_i) + 1;
X varno = varno + 1;
X dig(varno);
X (*G176_t).A[(*G178_i) - 1] = null;
X R82 = saveid(&(*G176_t));
X G176_t = F177;
X G178_i = F179;
X return R82;
X}
X
X idptr
Xmkvariable(c)
X char c;
X{
X register idptr R83;
X toknbuf t;
X
X t.A[1 - 1] = c;
X t.A[2 - 1] = null;
X R83 = mkuniqname(&t);
X return R83;
X}
X
X idptr
Xmkrename(c, ip)
X char c;
X idptr ip;
X{
X register idptr R84;
X
X R84 = mkconc(uscore, mkvariable(c), ip);
X return R84;
X}
X
X idptr
Xmkvrnt()
X{
X register idptr R85;
X toknbuf t;
X
X t.A[1 - 1] = 'U';
X t.A[2 - 1] = '.';
X t.A[3 - 1] = 'V';
X t.A[4 - 1] = null;
X R85 = mkuniqname(&t);
X return R85;
X}
X
X void
Xchecksymbol(ss)
X symset ss;
X{
X if (!(Member((unsigned)(currsym.st), ss.S)))
X error(ebadsymbol);
X}
X
Xvoid nextsymbol();
X
X char
Xnextchar()
X{
X register char R86;
X char c;
X
X if (Eof(input))
X c = null;
X else {
X colno = colno + 1;
X if (Eoln(input)) {
X lineno = lineno + 1;
X colno = 0;
X }
X c = Getchr(input);
X if (echo)
X if (colno == 0)
X Putchr('\n', output);
X else
X Putchr(c, output);
X if (c == tab1)
X colno = ((colno / tabwidth) + 1) * tabwidth;
X }
X if ((*G181_lastchr) > 0) {
X lasttok.A[(*G181_lastchr) - 1] = c;
X (*G181_lastchr) = (*G181_lastchr) + 1;
X }
X R86 = c;
X return R86;
X}
X
X char
Xpeekchar()
X{
X register char R87;
X
X if (Eof(input))
X R87 = null;
X else
X R87 = input.buf;
X return R87;
X}
X
Xvoid nexttoken();
X
X boolean
Xidchar(c)
X char c;
X{
X register boolean R88;
X
X R88 = (boolean)((c >= 'a') && (c <= 'z') || (c >= '0') && (c <= '9') || (c >= 'A') && (c <= 'Z') || (c == uscore));
X return R88;
X}
X
X boolean
Xnumchar(c)
X char c;
X{
X register boolean R89;
X
X R89 = (boolean)((c >= '0') && (c <= '9'));
X return R89;
X}
X
X integer
Xnumval(c)
X char c;
X{
X register integer R90;
X
X R90 = (unsigned)(c) - (unsigned)('0');
X return R90;
X}
X
X symtyp
Xkeywordcheck(w, l)
X toknbuf *w;
X toknidx l;
X{
X register symtyp R91;
X register unsigned char n;
X unsigned char i, j, k;
X keyword wrd;
X symtyp kwc;
X
X if ((l > 1) && (l < keywordlen)) {
X wrd = keytab.A[keytablen].wrd;
X {
X unsigned char B44 = 1,
X B45 = l;
X
X if (B44 <= B45)
X for (n = B44; ; n++) {
X wrd.A[n - 1] = w->A[n - 1];
X if (n == B45) break;
X }
X }
X i = 0;
X j = keytablen;
X while (j > i) {
X k = (i + j) / 2;
X if (Cmpstr(keytab.A[k].wrd.A, wrd.A) >= 0)
X j = k;
X else
X i = k + 1;
X }
X if (Cmpstr(keytab.A[j].wrd.A, wrd.A) == 0)
X kwc = keytab.A[j].sym;
X else
X kwc = sid;
X } else
X kwc = sid;
X R91 = kwc;
X return R91;
X}
X
X void
Xnexttoken(realok)
X boolean realok;
X{
X char c;
X integer n;
X boolean ready;
X toknidx wl;
X toknbuf wb;
X
X (*G181_lastchr) = 0;
X do {
X c = nextchar();
X if (c == '{') {
X do {
X c = nextchar();
X if (diffcomm)
X ready = (boolean)(c == '}');
X else
X ready = (boolean)(((c == '*') && (peekchar() == ')')) || (c == '}'));
X } while (!(ready || Eof(input)));
X if (Eof(input) && !ready)
X error(eeofcmnt);
X if ((c == '*') && !Eof(input))
X c = nextchar();
X c = space;
X } else
X if ((c == '(') && (peekchar() == '*')) {
X c = nextchar();
X do {
X c = nextchar();
X if (diffcomm)
X ready = (boolean)((c == '*') && (peekchar() == ')'));
X else
X ready = (boolean)(((c == '*') && (peekchar() == ')')) || (c == '}'));
X } while (!(ready || Eof(input)));
X if (Eof(input) && !ready)
X error(eeofcmnt);
X if ((c == '*') && !Eof(input))
X c = nextchar();
X c = space;
X }
X } while (!((c != space) && (c != tab1)));
X lasttok.A[1 - 1] = c;
X (*G181_lastchr) = 2;
X lastcol = colno;
X lastline = lineno;
X if (c < okchr)
X c = badchr;
X {
X register struct S180 *W46 = &currsym;
X
X if (Eof(input)) {
X lasttok.A[1 - 1] = '*';
X lasttok.A[2 - 1] = 'E';
X lasttok.A[3 - 1] = 'O';
X lasttok.A[4 - 1] = 'F';
X lasttok.A[5 - 1] = '*';
X (*G181_lastchr) = 6;
X W46->st = seof;
X } else
X switch (c) {
X case '|': case '`': case '~': case '}':
X case 92: case 95: case 63:
X error(ebadchar);
X break ;
X case 'a': case 'b': case 'c': case 'd':
X case 'e': case 'f': case 'g': case 'h':
X case 'i': case 'j': case 'k': case 'l':
X case 'm': case 'n': case 'o': case 'p':
X case 'q': case 'r': case 's': case 't':
X case 'u': case 'v': case 'w': case 'x':
X case 'y': case 'z': case 'A': case 'B':
X case 'C': case 'D': case 'E': case 'F':
X case 'G': case 'H': case 'I': case 'J':
X case 'K': case 'L': case 'M': case 'N':
X case 'O': case 'P': case 'Q': case 'R':
X case 'S': case 'T': case 'U': case 'V':
X case 'W': case 'X': case 'Y': case 'Z':
X wb.A[1 - 1] = lowercase(c);
X wl = 2;
X while ((wl < maxtoknlen) && idchar(peekchar())) {
X wb.A[wl - 1] = lowercase(nextchar());
X wl = wl + 1;
X }
X if (wl >= maxtoknlen) {
X lasttok.A[(*G181_lastchr) - 1] = null;
X error(elongtokn);
X }
X wb.A[wl - 1] = null;
X W46->st = keywordcheck(&wb, wl - 1);
X if (W46->st == sid)
X W46->U.V1.vid = saveid(&wb);
X break ;
X case '0': case '1': case '2': case '3':
X case '4': case '5': case '6': case '7':
X case '8': case '9':
X wb.A[1 - 1] = c;
X wl = 2;
X n = numval(c);
X while (numchar(peekchar())) {
X c = nextchar();
X n = n * 10 + numval(c);
X wb.A[wl - 1] = c;
X wl = wl + 1;
X }
X W46->st = sinteger;
X W46->U.V3.vint = n;
X if (realok) {
X if (peekchar() == '.') {
X W46->st = sreal;
X wb.A[wl - 1] = nextchar();
X wl = wl + 1;
X while (numchar(peekchar())) {
X wb.A[wl - 1] = nextchar();
X wl = wl + 1;
X }
X }
X c = peekchar();
X if ((c == 'e') || (c == 'E')) {
X W46->st = sreal;
X c = nextchar();
X wb.A[wl - 1] = xpnent;
X wl = wl + 1;
X c = peekchar();
X if ((c == '-') || (c == '+')) {
X wb.A[wl - 1] = nextchar();
X wl = wl + 1;
X }
X while (numchar(peekchar())) {
X wb.A[wl - 1] = nextchar();
X wl = wl + 1;
X }
X }
X if (W46->st == sreal) {
X wb.A[wl - 1] = null;
X W46->U.V4.vflt = savestr(&wb);
X }
X }
X break ;
X case '(':
X if (peekchar() == '.') {
X c = nextchar();
X W46->st = slbrack;
X } else
X W46->st = slpar;
X break ;
X case ')':
X W46->st = srpar;
X break ;
X case '[':
X W46->st = slbrack;
X break ;
X case ']':
X W46->st = srbrack;
X break ;
X case '.':
X if (peekchar() == '.') {
X c = nextchar();
X W46->st = sdotdot;
X } else
X if (peekchar() == ')') {
X c = nextchar();
X W46->st = srbrack;
X } else
X W46->st = sdot;
X break ;
X case ';':
X W46->st = ssemic;
X break ;
X case ':':
X if (peekchar() == '=') {
X c = nextchar();
X W46->st = sassign;
X } else
X W46->st = scolon;
X break ;
X case ',':
X W46->st = scomma;
X break ;
X case '@': case '^':
X W46->st = sarrow;
X break ;
X case '=':
X W46->st = seq;
X break ;
X case '<':
X if (peekchar() == '=') {
X c = nextchar();
X W46->st = sle;
X } else
X if (peekchar() == '>') {
X c = nextchar();
X W46->st = sne;
X } else
X W46->st = slt;
X break ;
X case '>':
X if (peekchar() == '=') {
X c = nextchar();
X W46->st = sge;
X } else
X W46->st = sgt;
X break ;
X case '+':
X W46->st = splus;
X break ;
X case '-':
X W46->st = sminus;
X break ;
X case '*':
X W46->st = smul;
X break ;
X case '/':
X W46->st = squot;
X break ;
X case 39:
X wl = 0;
X ready = false;
X do {
X if (Eoln(input)) {
X lasttok.A[(*G181_lastchr) - 1] = null;
X error(ebadstring);
X }
X c = nextchar();
X if (c == quote)
X if (peekchar() == quote)
X c = nextchar();
X else
X ready = true;
X if (c == null) {
X if (Eof(input))
X error(eeofstr);
X lasttok.A[(*G181_lastchr) - 1] = null;
X error(enulchr);
X }
X if (!ready) {
X wl = wl + 1;
X if (wl >= maxtoknlen) {
X lasttok.A[(*G181_lastchr) - 1] = null;
X error(elongstring);
X }
X wb.A[wl - 1] = c;
X }
X } while (!(ready));
X if (wl == 1) {
X W46->st = schar;
X W46->U.V2.vchr = wb.A[1 - 1];
X } else {
X wl = wl + 1;
X if (wl >= maxtoknlen) {
X lasttok.A[(*G181_lastchr) - 1] = null;
X error(elongstring);
X }
X wb.A[wl - 1] = null;
X W46->st = sstring;
X W46->U.V5.vstr = savestr(&wb);
X }
X break ;
X default:
X Caseerror(Line);
X }
X }
X if ((*G181_lastchr) == 0)
X (*G181_lastchr) = 1;
X lasttok.A[(*G181_lastchr) - 1] = null;
X}
X
X void
Xnextsymbol(ss)
X symset ss;
X{
X unsigned char lastchr;
X unsigned char *F182;
X
X F182 = G181_lastchr;
X G181_lastchr = &lastchr;
X nexttoken((boolean)(Member((unsigned)(sreal), ss.S)));
X checksymbol(ss);
X G181_lastchr = F182;
X}
X
X treeptr
Xtypeof(tp)
X treeptr tp;
X{
X register treeptr R92;
X treeptr tf, tq;
X
X tq = tp;
X tf = tq->ttype;
X while (tf == (struct S61 *)NIL) {
X switch (tq->tt) {
X case nchar:
X tf = typnods.A[(int)(tchar)];
X break ;
X case ninteger:
X tf = typnods.A[(int)(tinteger)];
X break ;
X case nreal:
X tf = typnods.A[(int)(treal)];
X break ;
X case nstring:
X tf = typnods.A[(int)(tstring)];
X break ;
X case nnil:
X tf = typnods.A[(int)(tnil)];
X break ;
X case nid:
X tq = idup(tq);
X if (tq == (struct S61 *)NIL)
X fatal(etree);
X break ;
X case ntype: case nvar: case nconst: case nfield:
X case nvalpar: case nvarpar:
X tq = tq->U.V14.tbind;
X break ;
X case npredef: case nptr: case nscalar: case nrecord:
X case nconfarr: case narray: case nfileof: case nsetof:
X tf = tq;
X break ;
X case nsubrange:
X if (tq->tup->tt == nconfarr)
X tf = tq->tup->U.V22.tindtyp;
X else
X tf = tq;
X break ;
X case ncall:
X tf = typeof(tq->U.V30.tcall);
X if (tf == typnods.A[(int)(tpoly)])
X tf = typeof(tq->U.V30.taparm);
X break ;
X case nfunc:
X tq = tq->U.V13.tfuntyp;
X break ;
X case nparfunc:
X tq = tq->U.V15.tpartyp;
X break ;
X case nproc: case nparproc:
X tf = typnods.A[(int)(tnone)];
X break ;
X case nvariant: case nlabel: case npgm: case nempty:
X case nbegin: case nlabstmt: case nassign: case npush:
X case npop: case nif: case nwhile: case nrepeat:
X case nfor: case ncase: case nchoise: case ngoto:
X case nwith: case nwithvar:
X fatal(etree);
X break ;
X case nformat: case nrange:
X tq = tq->U.V41.texpl;
X break ;
X case nplus: case nminus: case nmul:
X tf = typeof(tq->U.V41.texpl);
X if (tf == typnods.A[(int)(tinteger)])
X tf = typeof(tq->U.V41.texpr);
X else
X if (tf->tt == nsetof)
X tf = typnods.A[(int)(tset)];
X break ;
X case numinus: case nuplus:
X tq = tq->U.V42.texps;
X break ;
X case nmod: case ndiv:
X tf = typnods.A[(int)(tinteger)];
X break ;
X case nquot:
X tf = typnods.A[(int)(treal)];
X break ;
X case neq: case nne: case nlt: case nle:
X case ngt: case nge: case nin: case nor:
X case nand: case nnot:
X tf = typnods.A[(int)(tboolean)];
X break ;
X case nset:
END_OF_FILE
if test 33774 -ne `wc -c <'ptc.c.1'`; then
echo shar: \"'ptc.c.1'\" unpacked with wrong size!
fi
# end of 'ptc.c.1'
fi
echo shar: End of archive 3 \(of 12\).
cp /dev/null ark3isdone
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