rs@uunet.UU.NET (Rich Salz) (07/30/87)
Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 76
Archive-name: ptoc/Part12
#! /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 12 (of 12)."
# Contents: ptc.p.1
if test -f 'ptc.p.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ptc.p.1'\"
else
echo shar: Extracting \"'ptc.p.1'\" \(59347 characters\)
sed "s/^X//" >'ptc.p.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 ptc 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
Xprogram ptc(input, output);
X
Xlabel 9999; (* end of program *)
X
Xconst version = '@(#)ptc.p 1.5 Date 87/05/01';
X
X keytablen = 38; (* nr of keywords *)
X keywordlen = 10; (* length of a keyword *)
X othersym = 'otherwise '; (* keyword for others *)
X externsym = 'external '; (* keyword for external *)
X dummysym = ' '; (* dummy keyword *)
X
X (* a Pascal set is implemented as an array of "wordtype" where *)
X (* each element contains bits numbered from 0 to "setbits" *)
X wordtype = 'unsigned short'; (* CPU *)
X setbits = 15; (* CPU *)
X
X (* a Pascal file is implemented as a struct which (among other *)
X (* things) contain a flag-field, currently 3 bits are used *)
X filebits = 'unsigned short'; (* flags for files *)
X filefill = 12; (* 16 less used 3 bits *)
X
X maxsetrange = 15; (* nr of words in a set *)
X scalbase = 0; (* ordinal value of first scalar member *)
X
X maxprio = 7;
X
X maxmachdefs = 8; (* max nr of machine integer types *)
X machdeflen = 16; (* max length of machine int type name *)
X
X (* limit of identifier table, identifiers and strings are saved *)
X (* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char *)
X maxstrblk = 1023;
X maxblkcnt = 63;
X maxstrstor = 65535; (* maxstrstor should be ==
X (maxblkcnt+1) * (maxstrblk+1) - 1 *)
X
X maxtoknlen = 127; (* max size of token (i.e. identifier,
X string or number); must be > keywordlen
X and should be <= 256, see hashtokn() *)
X
X hashmax = 64; (* size of hashtable - 1 *)
X
X null = 0; (* "impossible" character value, CHAR;
X a char with this value is used as delimiter
X of strings in "strstor" and in toknbuffers;
X it is also used as end-of-input marker by
X the input procedures in lexical analysis *)
X
X minchar = null;
X maxchar = 127; (* greatest possible character, CHAR; limits
X the number of elements in type "char" *)
X
X (* tmpfilename is used in the generated code to obtain names of
X temporary files for reset/rewrite, the last character is supplied
X by the reset/rewrite routine *)
X tmpfilename = '"/tmp/ptc%d%c", getpid(), '; (* OS *)
X
X (* some frequently used characters *)
X space = ' ';
X tab1 = ' ';
X tab2 = ' ';
X tab3 = ' ';
X tab4 = ' ';
X bslash = '\';
X nlchr = '''\n''';
X ffchr = '''\f''';
X nulchr = '''\0''';
X spchr = ''' ''';
X quote = '''';
X cite = '"';
X xpnent = 'e'; (* exponent char in output. CPU *)
X percent = '%';
X uscore = '_';
X badchr = '?'; (* CHAR *)
X okchr = quote; (* CHAR *)
X
X tabwidth = 8; (* width of a tab-stop. OS *)
X
X echo = false; (* echo input as read *)
X diffcomm = false; (* comment delimiters different *)
X lazyfor = false; (* compile for-stmts a la C *)
X unionnew = true; (* malloc unions for variants *)
X
X inttyp = 'int'; (* for predefined functions *)
X chartyp = 'char';
X setwtyp = 'setword';
X setptyp = 'setptr';
X floattyp = 'float';
X doubletyp = 'double';
X dblcast = '(double)'; (* for predefined functions *)
X
X realtyp = doubletyp; (* user real-vars and functions *)
X
X voidtyp = 'void'; (* for procedures *)
X voidcast = '(void)';
X
X intlen = 10; (* length of written integer *)
X fixlen = 20; (* length of written real *)
X
Xtype
X hashtyp = 0 .. hashmax; (* index to hash-tables *)
X
X strindx = 0 .. maxstrstor; (* index to "strstor" *)
X
X (* string-table "strstor" is implemented as an array that is grown
X dynamically by adding blocks when needed *)
X strbidx = 0 .. maxstrblk;
X strblk = array [ strbidx ] of char;
X strptr = ^ strblk;
X strbcnt = 0 .. maxblkcnt;
X
X (* table for stored identifiers *)
X (* an identifier in any scope is represented by an idnode which is
X hooked to a slot in "idtab" as determined by a hash-function.
X whenever the input procedures find an identifier its idnode is
X immediately located, or created, if none was found; the identifier
X is then always handled though a pointer to the idnode. the actual
X text of the identifier is stored in "strstor". *)
X idptr = ^ idnode;
X idnode = record
X inext : idptr; (* chain of idnode's *)
X inref : 0 .. 127; (* # of refs to this id *)
X ihash : hashtyp; (* its hash value *)
X istr : strindx; (* index to "strstor" *)
X end;
X
X (* toknbuf is used to handle identifiers and strings in those situations
X where the actual text is of intrest *)
X toknidx = 1 .. maxtoknlen;
X toknbuf = array [ toknidx ] of char;
X
X (* a type to hold Pascal keywords *)
X keyword = packed array [ 1 .. keywordlen ] of char;
X
X (* predefined identifier enumeration *)
X predefs = (
X 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
X );
X
X (* lexical symbol enumeration *)
X symtyp = (
X (* keywords and eof are sorted alphabetically ...... *)
X 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,
X (* ...... sorted *)
X 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
X );
X symset = set of symtyp;
X
X (* lexical symbol definition *)
X (* the lexical symbol holds a descriptor and the value of a symbol
X read by the input procedures; note that real values are represented
X as strings saved in "strstor" like ordinary strings to avoid using
X float-variables and float-arithmetic in the translator *)
X lexsym =
X record
X case st : symtyp of
X sid: (vid : idptr);
X schar: (vchr : char);
X sinteger: (vint : integer);
X sreal: (vflt : strindx);
X sstring: (vstr : strindx);
X end;
X
X (* enumeration of symnode variants *)
X ltypes = (
X lpredef, lidentifier, lfield, lforward,
X lpointer, lstring, llabel, lforwlab,
X linteger, lreal, lcharacter
X );
X
X declptr = ^ declnode;
X treeptr = ^ treenode;
X symptr = ^ symnode;
X (* identifier/literal symbol definition *)
X (* in a given scope an identifier or a label is uniquely represented
X by a "symnode"; in order to have a uniform treatment of all objects
X occurring in the same syntactical positions (and hence in the parse-
X tree) the literal constants are represented in a similar manner *)
X symnode =
X record
X lsymdecl : treeptr; (* symbol decl. point *)
X lnext : symptr; (* symtab chain pointer *)
X ldecl : declptr; (* backptr to symtab *)
X case lt : ltypes of
X lpredef, (* a predefined id *)
X lfield, (* a record field *)
X lpointer, (* a pointer id *)
X lidentifier, (* an identifier *)
X lforward:
X (
X lid : idptr; (* ptr to its idnode *)
X lused : boolean (* true if symbol used *)
X );
X lstring: (* a string literal *)
X (
X lstr : strindx (* index to "strstor" *)
X );
X lreal: (* a real literal *)
X (
X lfloat : strindx (* index to "strstor" *)
X );
X lforwlab, (* a declared label *)
X llabel: (* label decl & defined *)
X (
X lno : integer; (* label number *)
X lgo : boolean (* non-local usage *)
X );
X linteger: (* an integer literal *)
X (
X linum : integer (* its value *)
X );
X lcharacter: (* a character literal *)
X (
X lchar : char (* its value *)
X )
X end;
X
X (* symbol table definition *)
X (* the symbol table consists of symnodes chained along the lnext
X field; the nodes are connected in reverse order of occurence (last
X declared, first in chain) in the slot in the declnode determined
X by the hashfunction; when a new scope is entered a new declnode is
X manufactured and the previous one is hooked to the dprev field, thus
X nested scopes are represented by a list of declnodes *)
X declnode = record
X dprev : declptr;
X ddecl : array [ hashtyp ] of symptr
X end;
X
X (* enumeration of nodes in parse tree *)
X (* NOTE: the subrange [ assignment .. nil ] have priorities *)
X treetyp = (
X 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
X );
X
X (* enumeration of predefined types *)
X pretyps = (
X tnone, tboolean, tchar, tinteger,
X treal, tstring, tnil, tset,
X ttext, tpoly, terror
X );
X
X (* enumeration of some special attributes *)
X attributes = (
X anone, aregister, aextern, areference
X );
X
X (* parse tree definition *)
X (* the sourceprogram is represented by a treestructure built from
X treenodes where each node corresponds to one syntactic form from
X the pascal program *)
X treenode =
X record
X tnext, (* ptr to next node in a list *)
X ttype, (* pointer to nodes type *)
X tup : treeptr; (* ptr to parent node *)
X case tt : treetyp of
X npredef: (* predefined object decl *)
X (
X tdef: (* predefined object descr. *)
X predefs;
X tobtyp: (* object type *)
X pretyps
X );
X npgm, (* program declaration *)
X nproc, (* procedure declaration *)
X nfunc: (* function declaration *)
X (
X tsubid, (* subr. identifier (nid) *)
X tsubpar, (* parameter list *)
X tfuntyp, (* function type (nid) *)
X tsublab, (* label decl list (nlabel) *)
X tsubconst, (* const decl list (nconst) *)
X tsubtype, (* type decl list (ntype) *)
X tsubvar, (* var decl list (nvar) *)
X tsubsub, (* subr. decl (nproc/nfunc) *)
X tsubstmt: (* stmt. list (NOT nbegin) *)
X treeptr;
X tstat: (* static declaration level *)
X integer;
X tscope: (* symbol table for local id's *)
X declptr
X );
X nvalpar, (* value parameter declaration *)
X nvarpar, (* var parameter declaration *)
X nconst, (* constant declaration *)
X ntype, (* type declaration *)
X nfield, (* record field declaration *)
X nvar: (* var declaration declaration *)
X (
X tidl, (* list of declared id's (nid) *)
X tbind: (* var/type-type, const-value *)
X treeptr;
X tattr: (* special attributes for vars *)
X attributes
X );
X nparproc, (* parameter procedure *)
X nparfunc: (* parameter function *)
X (
X tparid, (* parm proc/func id (nid) *)
X tparparm, (* parm proc/func parm decl *)
X tpartyp: (* parm func type (nid) *)
X treeptr
X );
X nptr: (* pointer constructor *)
X (
X tptrid: (* referenced type (nid) *)
X treeptr;
X tptrflag: (* have seen node before *)
X boolean
X );
X nscalar: (* scalar type constructor *)
X (
X tscalid: (* list of scalar ids (nid) *)
X treeptr
X );
X nfileof, (* file type constructor *)
X nsetof: (* set type constructor *)
X (
X tof: (* set/file component type *)
X treeptr
X );
X nsubrange: (* subrange type constructor *)
X (
X tlo, thi: (* subrange limits *)
X treeptr
X );
X nvariant: (* record variant constructor *)
X (
X tselct, (* selector list (constants) *)
X tvrnt: (* variant field decl (nrecord) *)
X treeptr
X );
X
X (* the tuid field is used to attach a name to variants since
X C requires all union members to have names *)
X nrecord: (* record/variant constructor *)
X (
X tflist, (* fixed field list (nfield) *)
X tvlist: (* variant list (nvariant) *)
X treeptr;
X tuid: (* variant name *)
X idptr;
X trscope: (* symbol table for local id's *)
X declptr
X );
X nconfarr: (* conformant array constructor *)
X (
X tcindx, (* index declaration *)
X tindtyp, (* conf. arr. index type (nid) *)
X tcelem: (* array element type decl *)
X treeptr;
X tcuid: (* variant name *)
X idptr
X );
X narray: (* array type constructor *)
X (
X taindx, (* index declaration *)
X taelem: (* array element type decl *)
X treeptr
X );
X nbegin: (* begin statement *)
X (
X tbegin: (* statement list *)
X treeptr
X );
X nlabstmt: (* labeled statement *)
X (
X tlabno, (* label number (nlabel) *)
X tstmt: (* statement *)
X treeptr
X );
X ngoto: (* goto statement *)
X (
X tlabel: (* label to go to (nlabel) *)
X treeptr
X );
X
X nassign: (* assignment statement *)
X (
X tlhs, (* variable *)
X trhs: (* value *)
X treeptr
X );
X
X (* npush/npop is used in proc/func which have local variables
X used in local proc/funcs; those variables are converted to
X global ptrs initialized to reference the local variable *)
X npush, (* init code for proc/func *)
X npop: (* exit code for proc/func *)
X (
X tglob, (* global identifier (nid) *)
X tloc, (* local identifier (nid) *)
X ttmp: (* temp store for global (nid) *)
X treeptr
X );
X
X nbreak:
X (
X tbrkid, (* for-variable *)
X tbrkxp: (* value for break *)
X treeptr
X );
X
X ncall: (* procedure/function call *)
X (
X tcall, (* called identifier *)
X taparm: (* actual paramters *)
X treeptr
X );
X nif: (* if statement *)
X (
X tifxp, (* conditional expression *)
X tthen, (* stmt execd if true condition *)
X telse: (* stmt execd if true condition *)
X treeptr
X );
X nwhile: (* while statemnet *)
X (
X twhixp, (* conditional expression *)
X twhistmt: (* stmt execd if true condition *)
X treeptr
X );
X nrepeat: (* repeat statement *)
X (
X treptstmt, (* statement list *)
X treptxp: (* conditional expression *)
X treeptr
X );
X nfor: (* for statement *)
X (
X tforid, (* loop control variable (nid) *)
X tfrom, (* initial value *)
X tto, (* final value *)
X tforstmt: (* stmt execd in loop *)
X treeptr;
X tincr: (* to/downto flag true <==> to *)
X boolean
X );
X ncase: (* case statement *)
X (
X tcasxp, (* selecting expression *)
X tcaslst, (* list of choises *)
X tcasother: (* default action *)
X treeptr
X );
X nchoise: (* a choise in a case-stmt *)
X (
X tchocon, (* list of constants *)
X tchostmt: (* execd statement *)
X treeptr
X );
X nwith: (* with statment *)
X (
X twithvar, (* list of variables (nwithvar) *)
X twithstmt: (* statement execd in new scope *)
X treeptr
X );
X
X (* the local symbol table holds identifiers, picked from
X the record fields, temporarily declared during parsing
X of remainder of with-statement; these identifiers are
X later converted into fields referenced through a ptr *)
X nwithvar: (* variable in with statement *)
X (
X texpw: (* record variable *)
X treeptr;
X tenv: (* symbol table for local scope *)
X declptr
X );
X
X nindex: (* array indexing expression *)
X (
X tvariable, (* indexed variable *)
X toffset: (* index expression *)
X treeptr
X );
X nselect: (* record field selection expr *)
X (
X trecord, (* record variable *)
X tfield: (* selected field (nid) *)
X treeptr
X );
X
X (* binary operators or constructors *)
X nrange, (* .. (set range) *)
X nformat, (* : (write format) *)
X nin, (* in *)
X neq, (* = *)
X nne, (* <> *)
X nlt, (* < *)
X nle, (* <= *)
X ngt, (* > *)
X nge, (* >= *)
X nor, (* or *)
X nplus, (* + *)
X nminus, (* - *)
X nand, (* and *)
X nmul, (* * *)
X ndiv, (* div *)
X nmod, (* mod *)
X nquot: (* / *)
X (
X texpl, (* left operand expr *)
X texpr: (* right operand expr *)
X treeptr
X );
X
X (* unary operators or constructors; note that uplus is
X used to represent any parenthesized expression *)
X nderef, (* ^ (ptr dereference) *)
X nnot, (* not *)
X nset, (* [ ] (set constr) *)
X nuplus, (* + *)
X numinus: (* - *)
X (
X texps: (* operand expression *)
X treeptr
X );
X
X nid, (* identifier in decl or stmt *)
X nreal, (* literal real (decl or stmt) *)
X ninteger, (* literal int ( - " - ) *)
X nchar, (* literal char ( - " - ) *)
X nstring, (* literal string ( - " - ) *)
X nlabel: (* label (decl, defpt or use) *)
X (
X tsym:
X symptr
X );
X
X nnil, (* nil (pointer constant) *)
X nempty: (* empty statement *)
X ( );
X end;
X
X (* "reserved" words and standard identifiers from C, C LIB and
X OS environment excluding those reserved in Pascal *)
X cnames = (
X 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
X );
X
X (* these are the detected errors. some are user-errors,
X some are internal problems and some are host system errors *)
X errors = (
X 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
X );
X
X machdefstr = packed array [ 1 .. machdeflen ] of char;
X
Xvar
X usemax, (* program needs max-function *)
X usejmps, (* source program uses non-local gotos *)
X usecase, (* source program has case-statement *)
X usesets, (* source program uses set-operations *)
X useunion,
X usediff,
X usemksub,
X useintr,
X usesge,
X usesle,
X useseq,
X usesne,
X usememb,
X useins,
X usescpy,
X usecomp, (* source program uses string-compare *)
X usefopn, (* source program uses reset/rewrite *)
X usescan,
X usegetl,
X usenilp, (* source program uses nil-pointer *)
X usebool : boolean; (* source program writes boolean-values *)
X
X top : treeptr; (* top of parsetree, result from parse *)
X
X setlst : treeptr; (* list of set-initializations *)
X setcnt : integer; (* counter for setlst length *)
X
X currsym : lexsym; (* current lexical symbol *)
X
X keytab : array [ 0 .. keytablen ] of (* table of keywords *)
X record
X wrd : keyword; (* keyword text *)
X sym : symtyp (* corresponding symbol *)
X end;
X
X strstor : array [ strbcnt ] of strptr; (* store for strings *)
X strfree : strindx; (* first free position *)
X strleft : strbidx; (* room in last blk *)
X
X idtab : array [ hashtyp ] of idptr; (* hashed table of id's *)
X
X symtab : declptr; (* table of symbols *)
X
X statlvl, (* static decl. level *)
X maxlevel : integer; (* - " - maximum value *)
X
X deftab : array [ predefs ] of treeptr; (* predefined idents. *)
X defnams : array [ predefs ] of symptr; (* - " - *)
X typnods : array [ pretyps ] of treeptr; (* predef. types. *)
X
X pprio,
X cprio : array [ nassign .. nnil ] of 0 .. maxprio;
X
X ctable : array [ cnames ] of idptr; (* table of C-keywords *)
X
X nmachdefs : 0 .. maxmachdefs;
X machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types *)
X record
X lolim, hilim : integer;
X typstr : strindx
X end;
X
X lineno, (* input line number *)
X colno, (* input column number *)
X lastcol, (* last OK input column *)
X lastline : integer; (* last OK input line *)
X
X lasttok : toknbuf; (* last input token *)
X
X varno : integer; (* counter for unique id's *)
X
X hexdig : packed array [ 0 .. 15 ] of char;
X
X(* Prtmsg produces an error message. It asssumes that procedure *)
X(* "message" (predefined) will "writeln" to user tty. OS *)
Xprocedure prtmsg(m : errors);
X
Xconst user = 'Error: ';
X restr = 'Implementation restriction: ';
X inter = '* Internal error * ';
X xtoklen = 64; (* should be <= maxtoklen *)
X
Xvar i : toknidx;
X xtok : packed array [ 1 .. xtoklen ] of char;
X
Xbegin
X case m of
X ebadsymbol:
X message(user, 'Unexpected symbol');
X ebadchar:
X message(user, 'Bad character');
X elongstring:
X message(restr, 'Too long string');
X ebadstring:
X message(user, 'Newline in string or character');
X eeofstr:
X message(user, 'End of file in string or character');
X eeofcmnt:
X message(user, 'End of file in comment');
X elongtokn:
X message(restr, 'Too long identfier');
X emanytokn:
X message(restr, 'Too many strings, identifiers or real numbers');
X enotdeclid:
X message(user, 'Identifier not declared');
X emultdeclid:
X message(user, 'Identifier declared twice');
X enotdecllab:
X message(user, 'Label not declared');
X emultdecllab:
X message(user, 'Label declared twice');
X emuldeflab:
X message(user, 'Label defined twice');
X evarpar:
X message(user, 'Actual parameter not a variable');
X enulchr:
X message(restr, 'Cannot handle nul-character in strings');
X enew:
X message(restr, 'New returned a nil-pointer');
X eoverflow:
X message(restr, 'Token buffer overflowed');
X esetbase:
X message(restr, 'Cannot handle sets with base >> 0');
X esetsize:
X message(restr, 'Cannot handle sets with very large range');
X etree:
X message(inter, 'Bad tree structure');
X etag:
X message(inter, 'Cannot find tag');
X evrntfile:
X message(restr, 'Cannot initialize files in record variants');
X evarfile:
X message(restr, 'Cannot handle files in structured variables');
X euprconf:
X message(inter, 'No upper bound on conformant arrays');
X easgnconf:
X message(inter, 'Cannot assign conformant arrays');
X ecmpconf:
X message(inter, 'Cannot compare conformant arrays');
X econfconf:
X message(restr, 'Cannot handle nested conformat arrays');
X erange:
X message(inter, 'Cannot find C-type for integer-subrange');
X emanymachs:
X message(restr, 'Too many machine integer types');
X ebadmach:
X message(inter, 'Bad name for machine integer type');
X end;(* case *)
X if lastline <> 0 then
X begin
X (* error detected during parsing,
X report line/column and print the offending symbol *)
X message('Line ', lastline:1, ', col ', lastcol:1, ':');
X if m in [enulchr, ebadchar, ebadstring, ebadsymbol,
X emuldeflab, emultdecllab, enotdecllab, emultdeclid,
X enotdeclid, elongtokn, elongstring] then
X begin
X i := 1;
X while (i < xtoklen) and (lasttok[i] <> chr(null)) do
X begin
X xtok[i] := lasttok[i];
X i := i + 1
X end;
X while i < xtoklen do
X begin
X xtok[i] := ' ';
X i := i + 1
X end;
X xtok[xtoklen] := ' ';
X message('Current symbol: ', xtok)
X end
X end
Xend;
X
Xprocedure fatal(m : errors); forward;
Xprocedure error(m : errors); forward;
X
X(* Map letters to upper-case. *)
X(* This function assumes a machine collating sequence where the *)
X(* letters of either case form a contigous sequence, CHAR. *)
Xfunction uppercase(c : char) : char;
X
Xbegin
X if (c >= 'a') and (c <= 'z') then
X uppercase := chr(ord(c) + ord('A') - ord('a'))
X else
X uppercase := c
Xend;
X
X
X(* Map letters to lower-case. *)
X(* This function assumes a machine collating sequence where the *)
X(* letters of either case form a contigous sequence, CHAR. *)
Xfunction lowercase(c : char) : char;
X
Xbegin
X if (c >= 'A') and (c <= 'Z') then
X lowercase := chr(ord(c) - ord('A') + ord('a'))
X else
X lowercase := c
Xend;
X
X(* Retrieve a string from strstor. *)
Xprocedure gettokn(i : strindx; var t : toknbuf);
X
Xvar c : char;
X k : toknidx;
X j : strbidx;
X p : strptr;
X
Xbegin
X k := 1;
X (* compute block and offset in block *)
X p := strstor[i div (maxstrblk + 1)];
X j := i mod (maxstrblk + 1);
X (* retrieve text up to null *)
X repeat
X c := p^[j];
X t[k] := c;
X j := j + 1;
X k := k + 1;
X if k = maxtoknlen then
X begin
X c := chr(null);
X t[maxtoknlen] := chr(null);
X prtmsg(eoverflow)
X end
X until c = chr(null)
Xend;
X
X(* Deposit a string into strstor at a given start-position. *)
Xprocedure puttokn(i : strindx; var t : toknbuf);
X
Xvar c : char;
X k : toknidx;
X j : strbidx;
X p : strptr;
X
Xbegin
X k := 1;
X p := strstor[i div (maxstrblk + 1)];
X j := i mod (maxstrblk + 1);
X repeat
X c := t[k];
X p^[j] := c;
X k := k + 1;
X j := j + 1
X until c = chr(null)
Xend;
X
X(* Write a token on standard output. *)
Xprocedure writetok(var w : toknbuf);
X
Xvar j : toknidx;
X
Xbegin
X j := 1;
X while w[j] <> chr(null) do
X begin
X write(w[j]);
X j := j + 1
X end
Xend;
X
X(* Print a float number on standard output. *)
Xprocedure printtok(i : strindx);
X
Xvar w : toknbuf;
X
Xbegin
X gettokn(i, w);
X writetok(w)
Xend;
X
X(* Print an identifier on standard output. *)
Xprocedure printid(ip : idptr);
X
Xbegin
X printtok(ip^.istr)
Xend;
X
X(* Print a character on standard output with proper C-quoting. *)
Xprocedure printchr(c : char);
X
Xbegin
X if (c = quote) or (c = bslash) then
X write(quote, bslash, c, quote)
X else
X write(quote, c, quote)
Xend;
X
X(* Print a string on standard output with proper C-quoting. *)
Xprocedure printstr(i : strindx);
X
Xvar k : toknidx;
X c : char;
X w : toknbuf;
X
Xbegin
X gettokn(i, w);
X write(cite);
X k := 1;
X while w[k] <> chr(null) do
X begin
X c := w[k];
X k := k + 1;
X if (c = cite) or (c = bslash) then
X write(bslash);
X write(c)
X end;
X write(cite)
Xend;
X
X(* Return a pointer to the declarationpoint of an identifier. *)
Xfunction idup(ip : treeptr) : treeptr;
X
Xbegin
X idup := ip^.tsym^.lsymdecl^.tup
Xend;
X
X(* Compute a hashvalue for an identifier or a string. *)
Xfunction hashtokn(var id : toknbuf) : hashtyp;
X
Xvar h : integer;
X i : toknidx;
X
Xbegin
X i := 1;
X h := 0;
X while id[i] <> chr(null) do
X begin
X (* if ord() of a character ranges from 0 to 127 then we can loop
X 256 times without causing h to exceed 32767, this is safe as
X both strings and identifiers are limited in length *)
X h := h + ord(id[i]); (* CHAR, CPU *)
X i := i + 1
X end;
X hashtokn := h mod hashmax
Xend;
X
X(* Global string table update. *)
X(* This function accepts a string and stores it in strstor. *)
X(* It returns the id-number for the new string. *)
Xfunction savestr(var t : toknbuf) : strindx;
X
Xvar k : toknidx;
X i : strindx;
X j : strbcnt;
X
Xbegin
X (* find length of new string including null-char *)
X k := 1;
X while t[k] <> chr(null) do
X k := k + 1;
X if k > strleft then
X begin
X (* out of space in strstore *)
X if strstor[maxblkcnt] <> nil then (* last slot used *)
X error(emanytokn);
X (* allocate a new block *)
X j := (strfree + maxstrblk) div (maxstrblk + 1);
X new(strstor[j]);
X if strstor[j] = nil then
X error(enew);
X strfree := j * (maxstrblk + 1);
X strleft := maxstrblk
X end;
X (* copy new str, update location of last used cell,
X return starting location for new str *)
X i := strfree;
X strfree := strfree + k;
X strleft := strleft - k;
X puttokn(i, t);
X savestr := i
Xend;
X
X(* Global id table lookup. *)
X(* This procedure accepts an identifier and determines if it has *)
X(* been seen before. If that is the case a pointer to its idnode *)
X(* is returned, otherwise the identifier is saved and a pointer to *)
X(* a new node is returned. *)
Xfunction saveid(var id : toknbuf) : idptr;
X
Xlabel 999;
X
Xvar k : toknidx;
X ip : idptr;
X h : hashtyp;
X t : toknbuf;
X
Xbegin
X h := hashtokn(id);
X ip := idtab[h]; (* scan hashlist for id *)
X while ip <> nil do
X begin
X gettokn(ip^.istr, t); (* look at saved token *)
X k := 1;
X while id[k] = t[k] do
X if id[k] = chr(null) then
X goto 999 (* found it! *)
X else
X k := k + 1; (* look at next char *)
X ip := ip^.inext
X end;
X
X (* identifier wasn't previously seen, manufacture a new idnode,
X save index to strstor and hashvalue, insert idnode in idtab *)
X new(ip);
X if ip = nil then
X error(enew);
X ip^.inref := 0;
X ip^.istr := savestr(id);
X ip^.ihash := h;
X ip^.inext := idtab[h];
X idtab[h] := ip;
X
X999:
X (* return the idnode *)
X saveid := ip
Xend;
X
X(* This function creates a new variable by concatenating one name *)
X(* with another injecting a given separator. *)
Xfunction mkconc(sep : char; p, q : idptr) : idptr;
X
Xvar w, x : toknbuf;
X i, j : toknidx;
X
Xbegin
X (* fetch second part and determine its length *)
X gettokn(q^.istr, x);
X j := 1;
X while x[j] <> chr(null) do
X j := j + 1;
X (* fetch first part and locate its end *)
X w[1] := chr(null);
X if p <> nil then
X gettokn(p^.istr, w);
X i := 1;
X while w[i] <> chr(null) do
X i := i + 1;
X (* check total length *)
X if i + j + 2 >= maxtoknlen then
X error(eoverflow);
X
X (* add separators *)
X if sep = '>' then
X begin
X (* special case 1: > gives arrow: a->b *)
X w[i] := '-';
X i := i + 1
X end;
X if sep <> space then
X begin
X (* special case 2: space gives nothing: ab *)
X w[i] := sep;
X i := i + 1
X end;
X (* add second part *)
X j := 1;
X repeat
X w[i] := x[j];
X i := i + 1;
X j := j + 1
X until w[i-1] = chr(null);
X (* save new identifier *)
X mkconc := saveid(w)
Xend;
X
X(* Create a new id with name-prefix from w. *)
Xfunction mkuniqname(var t : toknbuf) : idptr;
X
Xvar i : toknidx;
X
X procedure dig(n : integer);
X begin
X if n > 0 then
X begin
X dig(n div 10);
X if i = maxtoknlen then
X error(eoverflow);
X t[i] := chr(n mod 10 + ord('0')); (* CHAR *)
X i := i + 1
X end
X end;
X
Xbegin
X i := 1;
X while t[i] <> chr(null) do
X i := i + 1;
X varno := varno + 1;
X dig(varno);
X t[i] := chr(null);
X mkuniqname := saveid(t)
Xend;
X
X(* Make a new unique variable with given char as prefix. *)
Xfunction mkvariable(c : char) : idptr;
X
Xvar t : toknbuf;
X
Xbegin
X t[1] := c;
X t[2] := chr(null);
X mkvariable := mkuniqname(t)
Xend;
X
X(* Make a new unique variable with given char as prefix and *)
X(* with a given id as tail. Commonly used for renaming id's. *)
Xfunction mkrename(c : char; ip : idptr) : idptr;
X
Xbegin
X mkrename := mkconc(uscore, mkvariable(c), ip)
Xend;
X
X(* Make a name for a variant. Variants are mapped onto C unions, *)
X(* which we always give the name "U", thus the name of the variant *)
X(* becomes "U.Vnnn" where "nnn" is a unique number. *)
Xfunction mkvrnt : idptr;
X
Xvar t : toknbuf;
X
Xbegin
X t[1] := 'U';
X t[2] := '.';
X t[3] := 'V';
X t[4] := chr(null);
X mkvrnt := mkuniqname(t)
Xend;
X
Xprocedure checksymbol(ss : symset);
Xbegin
X if not (currsym.st in ss) then
X error(ebadsymbol);
Xend;
X
X(* Lexical analysis routine. *)
X(* This procedure reads and classifies the next lexical token in *)
X(* the input stream. The token is saved in the global variable *)
X(* "currsym". The found symbol should be one of the symbols given *)
X(* in the parameter "ss" otherwise the error routine is called. *)
Xprocedure nextsymbol(ss : symset);
X
Xvar lastchr : 0 .. maxtoknlen;
X
X (* This function reads the next character from the input *)
X (* and updates "lineno" and "colno" accordingly. *)
X function nextchar : char;
X
X var c : char;
X
X begin
X if eof then
X c := chr(null)
X else begin
X colno := colno + 1;
X if eoln then
X begin
X lineno := lineno + 1;
X colno := 0
X end;
X read(c);
X if echo then
X if colno = 0 then
X writeln
X else
X write(c);
X if c = tab1 then
X colno := ((colno div tabwidth) + 1) * tabwidth
X end;
X if lastchr > 0 then
X begin
X lasttok[lastchr] := c;
X lastchr := lastchr + 1
X end;
X nextchar := c
X end;
X
X (* This function looks at the next input character. *)
X function peekchar : char;
X
X begin
X if eof then
X peekchar := chr(null)
X else
X peekchar := input^
X end;
X
X (* Read and classify the next token. *)
X procedure nexttoken(realok : boolean);
X
X var c : char;
X n : integer;
X
X ready : boolean;
X
X wl : toknidx;
X wb : toknbuf;
X
X (* Determine if c is valid in an identifier. *)
X (* This function assumes a machine collating *)
X (* sequence where letters and digits form conti- *)
X (* gous sequences, CHAR. *)
X function idchar(c : char) : boolean;
X
X begin
X idchar :=
X (c >= 'a') and (c <= 'z') or
X (c >= '0') and (c <= '9') or
X (c >= 'A') and (c <= 'Z') or
X (c = uscore)
X end;
X
X (* Determine if c is valid in a number. CHAR. *)
X function numchar(c : char) : boolean;
X
X begin
X numchar := (c >= '0') and (c <= '9')
X end;
X
X (* Convert a digit to its numeric value. CHAR *)
X function numval(c : char) : integer;
X
X begin
X numval := ord(c) - ord('0')
X end;
X
X (* Determine if the current token is a keyword. *)
X function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;
X
X var n : 1 .. keywordlen;
X i, j, k : 0 .. keytablen;
X wrd : keyword;
X kwc : symtyp;
X
X begin
X (* quick check on token length,
X pascal keywords range from 2 to 9 chars in length *)
X if (l > 1) and (l < keywordlen) then
X begin
X (* could be a keyword, initialize wrd *)
X wrd := keytab[keytablen].wrd;
X (* copy w to wrd *)
X for n := 1 to l do
X wrd[n] := w[n];
X
X (* binary search for tokn,
X relies on symtyp being sorted *)
X i := 0;
X j := keytablen;
X while j > i do
X begin
X k := (i + j) div 2;
X if keytab[k].wrd >= wrd then
X j := k
X else
X i := k + 1
X end;
X if keytab[j].wrd = wrd then
X kwc := keytab[j].sym
X else
X kwc := sid
X end
X else
X kwc := sid;
X keywordcheck := kwc
X end;
X
X begin (* nexttoken *)
X (* don't save blanks/comments *)
X lastchr := 0;
X (* read non-blank character *)
X repeat
X c := nextchar;
X (* skip comments, the two comment delimiters of pascal
X are treated as different if "diffcomm" is true *)
X if c = '{' then
X begin
X repeat
X c := nextchar;
X if diffcomm then
X ready := c = '}'
X else
X ready := ((c = '*') and
X (peekchar = ')'))
X or (c = '}')
X until ready or eof;
X if eof and not ready then
X error(eeofcmnt);
X if (c = '*') and not eof then
X c := nextchar;
X c := space
X end
X else if (c = '(') and (peekchar = '*') then
X begin
X c := nextchar;
X repeat
X c := nextchar;
X if diffcomm then
X ready := (c = '*') and
X (peekchar = ')')
X else
X ready := ((c = '*') and
X (peekchar = ')'))
X or (c = '}')
X until ready or eof;
X if eof and not ready then
X error(eeofcmnt);
X if (c = '*') and not eof then
X c := nextchar;
X c := space
X end
X until (c <> space) and (c <> tab1);
X
X (* save characters from this token and save line- and column-
X numbers for errormessages *)
X lasttok[1] := c;
X lastchr := 2;
X lastcol := colno;
X lastline := lineno;
X
X (* map all CHAR control characters onto "badchr" *)
X if c < okchr then
X c := badchr;
X
X (* decode symbol *)
X with currsym do
X if eof then
X begin
X lasttok[1] := '*';
X lasttok[2] := 'E';
X lasttok[3] := 'O';
X lasttok[4] := 'F';
X lasttok[5] := '*';
X lastchr := 6;
X st := seof
X end
X else
X case c of
X
X
X (* CHAR, chars not in Pascal *)
X '|', '`', '~', '}',
X bslash, uscore, badchr:
X error(ebadchar);
X
X (* identifiers or keywords *)
X 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
X 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
X 'u', 'v', 'w', 'x', 'y', 'z',
X 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
X 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
X 'U', 'V', 'W', 'X', 'Y', 'Z':
X begin
X (* read token into buffer *)
X wb[1] := lowercase(c);
X wl := 2;
X while (wl < maxtoknlen) and idchar(peekchar) do
X begin
X wb[wl] := lowercase(nextchar);
X wl := wl + 1
X end;
X if wl >= maxtoknlen then
X begin
X lasttok[lastchr] := chr(null);
X error(elongtokn)
X end;
X (* terminate token and match *)
X wb[wl] := chr(null);
X (* check if keyword/identifier *)
X st := keywordcheck(wb, wl-1);
X if st = sid then
X vid := saveid(wb)
X end;
X
X (* integer or real numbers *)
X '0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
X begin
X (* assume integer number, save it in buffer *)
X wb[1] := c;
X wl := 2;
X n := numval(c);
X while numchar(peekchar) do
X begin
X c := nextchar;
X n := n * 10 + numval(c);
X wb[wl] := c;
X wl := wl + 1
X end;
X st := sinteger;
X vint := n;
X if realok then
X begin
X (* accept real numbers *)
X if peekchar = '.' then
X begin
X (* this is a real number *)
X st := sreal;
X wb[wl] := nextchar;
X wl := wl + 1;
X while numchar(peekchar) do
X begin
X wb[wl] := nextchar;
X wl := wl + 1
X end
X end;
X c := peekchar;
X if (c = 'e') or (c = 'E') then
X begin
X (* this is a real number *)
X st := sreal;
X c := nextchar;
X wb[wl] := xpnent;
X wl := wl + 1;
X c := peekchar;
X if (c = '-') or (c = '+') then
X begin
X wb[wl] := nextchar;
X wl := wl + 1
X end;
X while numchar(peekchar) do
X begin
X wb[wl] := nextchar;
X wl := wl + 1
X end
X end;
X if st = sreal then
X begin
X wb[wl] := chr(null);
X vflt := savestr(wb)
X end
X end
X end;
X
X '(':
X if peekchar = '.' then
X begin
X (* some compilers on non-ascii systems
X use (. for [ and .) for ] *)
X c := nextchar;
X st := slbrack
X end
X else
X st := slpar;
X ')':
X st := srpar;
X '[':
X st := slbrack;
X ']':
X st := srbrack;
X '.':
X if peekchar = '.' then
X begin
X c := nextchar;
X st := sdotdot
X end
X else if peekchar = ')' then
X begin
X c := nextchar;
X st := srbrack
X end
X else
X st := sdot;
X ';':
X st := ssemic;
X ':':
X if peekchar = '=' then
X begin
X c := nextchar;
X st := sassign
X end
X else
X st := scolon;
X ',':
X st := scomma;
X '@',
X '^':
X st := sarrow;
X '=':
X st := seq;
X '<':
X if peekchar = '=' then
X begin
X c := nextchar;
X st := sle
X end
X else if peekchar = '>' then
X begin
X c := nextchar;
X st := sne
X end
X else
X st := slt;
X '>':
X if peekchar = '=' then
X begin
X c := nextchar;
X st := sge
X end
X else
X st := sgt;
X '+':
X st := splus;
X '-':
X st := sminus;
X '*':
X st := smul;
X '/':
X st := squot;
X quote:
X begin
X (* assume the symbol is a literal string *)
X wl := 0;
X ready := false;
X repeat
X if eoln then
X begin
X lasttok[lastchr] := chr(null);
X error(ebadstring)
X end;
X c := nextchar;
X if c = quote then
X if peekchar = quote then
X c := nextchar
X else
X ready := true;
X if c = chr(null) then
X begin
X if eof then
X error(eeofstr);
X lasttok[lastchr] := chr(null);
X error(enulchr)
X end;
X if not ready then
X begin
X wl := wl + 1;
X if wl >= maxtoknlen then
X begin
X lasttok[lastchr] :=
X chr(null);
X error(elongstring)
X end;
X wb[wl] := c
X end
X until ready;
X if wl = 1 then
X begin
X (* only 1 character => not a string *)
X st := schar;
X vchr := wb[1]
X end
X else begin
X (* > 1 character => its a string *)
X wl := wl + 1;
X if wl >= maxtoknlen then
X begin
X lasttok[lastchr] := chr(null);
X error(elongstring)
X end;
X wb[wl] := chr(null);
X st := sstring;
X vstr := savestr(wb)
X end
X end
X
X end;(* case *)
X if lastchr = 0 then
X lastchr := 1;
X lasttok[lastchr] := chr(null)
X end; (* nexttoken *)
X
Xbegin (* nextsymbol *)
X nexttoken(sreal in ss);
X checksymbol(ss)
Xend; (* nextsymbol *)
X
X(* Return a pointer to the node describing the type of tp. This *)
X(* function also stores the result in the node for future ref. *)
Xfunction typeof(tp : treeptr) : treeptr;
X
Xvar tf, tq : treeptr;
X
Xbegin
X tq := tp;
X tf := tq^.ttype;
X (* keep working until a type is found *)
X while tf = nil do
X begin
X case tq^.tt of
X nchar:
X tf := typnods[tchar];
X
X ninteger:
X tf := typnods[tinteger];
X
X nreal:
X tf := typnods[treal];
X
X nstring:
X tf := typnods[tstring];
X
X nnil:
X tf := typnods[tnil];
X
X nid:
X begin
X tq := idup(tq);
X if tq = nil then
X fatal(etree)
X end;
X
X ntype,
X nvar,
X nconst,
X nfield,
X nvalpar,
X nvarpar:
X tq := tq^.tbind;
X
X npredef,
X nptr,
X nscalar,
X nrecord,
X nconfarr,
X narray,
X nfileof,
X nsetof:
X tf := tq; (* these nodetypes represent types *)
X
X nsubrange:
X if tq^.tup^.tt = nconfarr then
X tf := tq^.tup^.tindtyp
X else
X tf := tq;
X
X ncall:
X begin
X tf := typeof(tq^.tcall);
X if tf = typnods[tpoly] then
X tf := typeof(tq^.taparm)
X end;
X
X nfunc:
X tq := tq^.tfuntyp;
X
X nparfunc:
X tq := tq^.tpartyp;
X
X nproc,
X nparproc:
X tf := typnods[tnone];
X
X nvariant,
X nlabel,
X npgm,
X nempty,
X nbegin,
X nlabstmt,
X nassign,
X npush,
X npop,
X nif,
X nwhile,
X nrepeat,
X nfor,
X ncase,
X nchoise,
X ngoto,
X nwith,
X nwithvar:
X fatal(etree);
X
X nformat,
X nrange:
X tq := tq^.texpl;
X
X nplus,
X nminus,
X nmul:
X begin
X tf := typeof(tq^.texpl);
X if tf = typnods[tinteger] then
X tf := typeof(tq^.texpr)
X else if tf^.tt = nsetof then
X tf := typnods[tset]
X end;
X
X numinus,
X nuplus:
X tq := tq^.texps;
X
X nmod,
X ndiv:
X tf := typnods[tinteger];
X
X nquot:
X tf := typnods[treal];
X
X neq,
X nne,
X nlt,
X nle,
X ngt,
X nge,
X nin,
X nor,
X nand,
X nnot:
X tf := typnods[tboolean];
X
X nset:
X tf := typnods[tset];
X
X nselect:
X tq := tq^.tfield;
X
X nderef:
X begin
X tq := typeof(tq^.texps);
X case tq^.tt of
X nptr:
X tq := tq^.tptrid;
X nfileof:
X tq := tq^.tof;
X npredef:
X tf := typnods[tchar] (* textfile *)
X end (* case *)
X end;
X
X nindex:
X begin
X tq := typeof(tq^.tvariable);
X if tq^.tt = nconfarr then
X tq := tq^.tcelem
X else if tq = typnods[tstring] then
X tf := typnods[tchar]
X else
X tq := tq^.taelem
X end;
X
X end (* case *)
X end;
X if tp^.ttype = nil then
X tp^.ttype := tf; (* remember type for future reference *)
X typeof := tf
Xend; (* typeof *)
X
X(* Connect all nodes to their fathers. *)
Xprocedure linkup(up, tp : treeptr);
X
Xbegin
X while tp <> nil do
X begin
X if tp^.tup = nil then
X begin
X tp^.tup := up;
X case tp^.tt of
X npgm,
X nfunc,
X nproc:
X begin
X linkup(tp, tp^.tsubid);
X linkup(tp, tp^.tsubpar);
X linkup(tp, tp^.tfuntyp);
X linkup(tp, tp^.tsublab);
X linkup(tp, tp^.tsubconst);
X linkup(tp, tp^.tsubtype);
X linkup(tp, tp^.tsubvar);
X linkup(tp, tp^.tsubsub);
X linkup(tp, tp^.tsubstmt)
X end;
X
X
X nvalpar,
X nvarpar,
X nconst,
X ntype,
X nfield,
X nvar:
X begin
X linkup(tp, tp^.tidl);
X linkup(tp, tp^.tbind)
X end;
X
X nparproc,
X nparfunc:
X begin
X linkup(tp, tp^.tparid);
X linkup(tp, tp^.tparparm);
X linkup(tp, tp^.tpartyp)
X end;
X
X nptr:
X linkup(tp, tp^.tptrid);
X nscalar:
X linkup(tp, tp^.tscalid);
X
X nsubrange:
X begin
X linkup(tp, tp^.tlo);
X linkup(tp, tp^.thi)
X end;
X nvariant:
X begin
X linkup(tp, tp^.tselct);
X linkup(tp, tp^.tvrnt)
X end;
X nrecord:
X begin
X linkup(tp, tp^.tflist);
X linkup(tp, tp^.tvlist)
X end;
X nconfarr:
X begin
X linkup(tp, tp^.tcindx);
X linkup(tp, tp^.tcelem);
X linkup(tp, tp^.tindtyp)
X end;
X narray:
X begin
X linkup(tp, tp^.taindx);
X linkup(tp, tp^.taelem)
X end;
X nfileof,
X nsetof:
X linkup(tp, tp^.tof);
X nbegin:
X linkup(tp, tp^.tbegin);
X nlabstmt:
X begin
X linkup(tp, tp^.tlabno);
X linkup(tp, tp^.tstmt)
X end;
X nassign:
X begin
X linkup(tp, tp^.tlhs);
X linkup(tp, tp^.trhs)
X end;
X npush,
X npop:
X begin
X linkup(tp, tp^.tglob);
X linkup(tp, tp^.tloc);
X linkup(tp, tp^.ttmp)
X end;
X ncall:
X begin
X linkup(tp, tp^.tcall);
X linkup(tp, tp^.taparm )
X end;
X nif:
X begin
X linkup(tp, tp^.tifxp);
X linkup(tp, tp^.tthen);
X linkup(tp, tp^.telse)
X end;
X nwhile:
X begin
X linkup(tp, tp^.twhixp);
X linkup(tp, tp^.twhistmt)
X end;
X nrepeat:
X begin
X linkup(tp, tp^.treptstmt);
X linkup(tp, tp^.treptxp)
X end;
X nfor:
X begin
X linkup(tp, tp^.tforid);
X linkup(tp, tp^.tfrom);
X linkup(tp, tp^.tto);
X linkup(tp, tp^.tforstmt)
X end;
X ncase:
X begin
X linkup(tp, tp^.tcasxp);
X linkup(tp, tp^.tcaslst);
X linkup(tp, tp^.tcasother)
X end;
X nchoise:
X begin
X linkup(tp, tp^.tchocon);
X linkup(tp, tp^.tchostmt)
X end;
X nwith:
X begin
X linkup(tp, tp^.twithvar);
X linkup(tp, tp^.twithstmt)
X end;
X nwithvar:
X linkup(tp, tp^.texpw);
X nindex:
X begin
X linkup(tp, tp^.tvariable);
X linkup(tp, tp^.toffset)
X end;
X nselect:
X begin
X linkup(tp, tp^.trecord);
X linkup(tp, tp^.tfield)
X end;
X
X ngoto:
X linkup(tp, tp^.tlabel);
X
X nrange, nformat,
X nin, neq,
X nne, nlt, nle,
X ngt, nge, nor,
X nplus, nminus,
X nand, nmul,
X ndiv, nmod,
X nquot:
X begin
X linkup(tp, tp^.texpl);
X linkup(tp, tp^.texpr)
X end;
X
X nderef,
X nnot, nset,
X numinus,
X nuplus:
X linkup(tp, tp^.texps);
X
X nid,
X nnil, ninteger,
X nreal, nchar,
X nstring, npredef,
X nlabel, nempty:
X (* no op *)
X end (* case *)
X end;
X tp := tp^.tnext
X end
Xend; (* linkup *)
X
X(* Allocate a new symbol node. *)
Xfunction mksym(vt : ltypes) : symptr;
X
Xvar mp : symptr;
X
Xbegin
X new(mp);
X if mp = nil then
X error(enew);
X mp^.lt := vt;
X mp^.lnext := nil;
X mp^.lsymdecl := nil;
X mp^.ldecl := nil;
X mksym := mp
Xend;
X
X(* Enter a symbol at current declarationlevel. *)
Xprocedure declsym(sp : symptr);
X
Xvar h : hashtyp;
X
Xbegin
X if sp^.lt in [lpredef, lidentifier, lfield, lforward, lpointer] then
X h := sp^.lid^.ihash
X else
X h := hashmax;
X sp^.lnext := symtab^.ddecl[h];
X symtab^.ddecl[h] := sp;
X sp^.ldecl := symtab
Xend;
X
X(* Create a node of selected type. *)
Xfunction mknode(nt : treetyp) : treeptr;
X
Xvar tp : treeptr;
X
Xbegin
X tp := nil;
X case nt of
X npredef: new(tp, npredef);
X npgm: new(tp, npgm);
X nfunc: new(tp, nfunc);
X nproc: new(tp, nproc);
X nlabel: new(tp, nlabel);
X nconst: new(tp, nconst);
X ntype: new(tp, ntype);
X nvar: new(tp, nvar);
X nvalpar: new(tp, nvalpar);
X nvarpar: new(tp, nvarpar);
X nparproc: new(tp, nparproc);
X nparfunc: new(tp, nparfunc);
X nsubrange: new(tp, nsubrange);
X nvariant: new(tp, nvariant);
X nfield: new(tp, nfield);
X nrecord: new(tp, nrecord);
X nconfarr: new(tp, nconfarr);
X narray: new(tp, narray);
X nfileof: new(tp, nfileof);
X nsetof: new(tp, nsetof);
X nbegin: new(tp, nbegin);
X nptr: new(tp, nptr);
X nscalar: new(tp, nscalar);
X nif: new(tp, nif);
X nwhile: new(tp, nwhile);
X nrepeat: new(tp, nrepeat);
X nfor: new(tp, nfor);
X ncase: new(tp, ncase);
X nchoise: new(tp, nchoise);
X ngoto: new(tp, ngoto);
X nwith: new(tp, nwith);
X nwithvar: new(tp, nwithvar);
X nempty: new(tp, nempty);
X nlabstmt: new(tp, nlabstmt);
X nassign: new(tp, nassign);
X nformat: new(tp, nformat);
X nin: new(tp, nin);
X neq: new(tp, neq);
X nne: new(tp, nne);
X nlt: new(tp, nlt);
X nle: new(tp, nle);
X ngt: new(tp, ngt);
X nge: new(tp, nge);
X nor: new(tp, nor);
X nplus: new(tp, nplus);
X nminus: new(tp, nminus);
X nand: new(tp, nand);
X nmul: new(tp, nmul);
X ndiv: new(tp, ndiv);
X nmod: new(tp, nmod);
X nquot: new(tp, nquot);
X nnot: new(tp, nnot);
X numinus: new(tp, numinus);
X nuplus: new(tp, nuplus);
X nset: new(tp, nset);
X nrange: new(tp, nrange);
X nindex: new(tp, nindex);
X nselect: new(tp, nselect);
X nderef: new(tp, nderef);
X ncall: new(tp, ncall);
X nid: new(tp, nid);
X nchar: new(tp, nchar);
X ninteger: new(tp, ninteger);
X nreal: new(tp, nreal);
X nstring: new(tp, nstring);
X nnil: new(tp, nnil);
X npush: new(tp, npush);
X npop: new(tp, npop);
X nbreak: new(tp, nbreak)
X end;(* case *)
X if tp = nil then
X error(enew);
X tp^.tt := nt;
X tp^.tnext := nil;
X tp^.tup := nil;
X tp^.ttype := nil;
X mknode := tp
Xend;
X
X(* Create a node with a literal value. *)
Xfunction mklit : treeptr;
X
Xvar sp : symptr;
X tp : treeptr;
X
Xbegin
X case currsym.st of
X sinteger:
X begin
X sp := mksym(linteger);
X sp^.linum := currsym.vint;
X tp := mknode(ninteger);
X end;
X sreal:
X begin
X sp := mksym(lreal);
X sp^.lfloat := currsym.vflt;
X tp := mknode(nreal);
X end;
X schar:
X begin
X sp := mksym(lcharacter);
X sp^.lchar := currsym.vchr;
X tp := mknode(nchar);
X end;
X sstring:
X begin
X sp := mksym(lstring);
X sp^.lstr := currsym.vstr;
X tp := mknode(nstring);
X end
X end;(* case *)
X tp^.tsym := sp;
X sp^.lsymdecl := tp;
X mklit := tp
Xend;
X
X(* Look up an identifier among declared symbols. *)
Xfunction lookupid(ip : idptr; fieldok : boolean) : symptr;
X
Xlabel 999;
X
Xvar sp : symptr;
X dp : declptr;
X vs : set of ltypes;
X
Xbegin
X lookupid := nil;
X if fieldok then
X vs := [lidentifier, lforward, lpointer, lfield]
X else
X vs := [lidentifier, lforward, lpointer];
X sp := nil;
X
X (* pick up symboltable from innermost scope *)
X dp := symtab;
X while dp <> nil do
X begin
X (* scan linked symbols with same hasvalue *)
X sp := dp^.ddecl[ip^.ihash];
X while sp <> nil do
X begin
X (* break out when proper id found *)
X if (sp^.lt in vs) and (sp^.lid = ip) then
X goto 999;
X sp := sp^.lnext
X end;
X (* proceed to enclosing scope *)
X dp := dp^.dprev
X end;
X999:
X lookupid := sp
Xend;
X
X(* Look up a label. *)
Xfunction lookuplabel(i : integer) : symptr;
X
Xlabel 999;
X
Xvar sp : symptr;
X dp : declptr;
X
Xbegin
X sp := nil;
X dp := symtab;
X while dp <> nil do
X begin
X sp := dp^.ddecl[hashmax];
X while sp <> nil do
X begin
X if (sp^.lt in [lforwlab, llabel]) and (sp^.lno = i) then
X goto 999;
X sp := sp^.lnext
X end;
X dp := dp^.dprev
X end;
X999:
X lookuplabel := sp
Xend;
X
X(* Create a new declaration level (a new scope) link declnode to *)
X(* previous node. dp is non-nil when a procedure/function body *)
X(* is encountered for which we have seen a forward declaration. *)
Xprocedure enterscope(dp : declptr);
X
Xvar h : hashtyp;
X
Xbegin
X if dp = nil then
X begin
X new(dp);
X for h := 0 to hashmax do
X dp^.ddecl[h] := nil
X end;
X dp^.dprev := symtab;
X symtab := dp
Xend;
X
X(* Return current scope (as a pointer to symbol-table). *)
Xfunction currscope : declptr;
X
Xbegin
X currscope := symtab
Xend;
X
X(* Drop innermost declaration scope. *)
Xprocedure leavescope;
X
Xbegin
X symtab := symtab^.dprev
Xend;
X
X(* Create a new identifier symbol. *)
Xfunction mkid(ip : idptr) : symptr;
X
Xvar sp : symptr;
X
Xbegin
X sp := mksym(lidentifier);
X sp^.lid := ip;
X sp^.lused := false;
X declsym(sp);
X ip^.inref := ip^.inref + 1;
X mkid := sp
Xend;
X
X(* Check that the current identifier is new then save it in the *)
X(* current scope. Create and return a new node representing this *)
X(* instance of the identifier. *)
Xfunction newid(ip : idptr) : treeptr;
X
Xvar sp : symptr;
X tp : treeptr;
X
Xbegin
X sp := lookupid(ip, false);
X if sp <> nil then
X if sp^.ldecl <> symtab then
X sp := nil;
X if sp = nil then
X begin
X (* new identifier *)
X tp := mknode(nid);
X sp := mkid(ip);
X sp^.lsymdecl := tp;
X tp^.tsym := sp
X end
X else if sp^.lt = lpointer then
X begin
X (* previously declared as a pointer type *)
X tp := mknode(nid);
X tp^.tsym := sp;
X sp^.lt := lidentifier;
X sp^.lsymdecl := tp
X end
X else if sp^.lt = lforward then
X begin
X (* previously forward declared *)
X sp^.lt := lidentifier;
X tp := sp^.lsymdecl
X end
X else
X error(emultdeclid);
X newid := tp
Xend;
X
X(* Check that the current identifier is already declared, *)
X(* we fail unless l in [lforward, lpointer]. *)
X(* Create and return a new node referencing it. *)
Xfunction oldid(ip : idptr; l : ltypes) : treeptr;
X
Xvar sp : symptr;
X tp : treeptr;
X
Xbegin
X sp := lookupid(ip, true);
X if sp = nil then
X begin
X if l in [lforward, lpointer] then
X begin
X tp := newid(ip);
X tp^.tsym^.lt := l
X end
X else
X error(enotdeclid)
X end
X else begin
X sp^.lused := true;
X tp := mknode(nid);
X tp^.tsym := sp;
X if (sp^.lt = lpointer) and (l = lidentifier) then
X begin
X sp^.lt := lidentifier;
X sp^.lsymdecl := tp
X end
X end;
X oldid := tp
Xend;
X
X(* Look up a field in a record declaration. *)
X(* Return nil if field isn't declared in "tp" or its variants. *)
Xfunction oldfield(tp : treeptr; ip : idptr) : treeptr;
X
Xlabel 999;
X
Xvar tq, ti,
X fp : treeptr;
X
Xbegin
X fp := nil;
X tq := tp^.tflist;
X while tq <> nil do
X begin
X ti := tq^.tidl;
X while ti <> nil do
X begin
X if ti^.tsym^.lid = ip then
X begin
X fp := mknode(nid);
X fp^.tsym := ti^.tsym;
X goto 999
X end;
X ti := ti^.tnext
X end;
X tq := tq^.tnext
X end;
X tq := tp^.tvlist;
X while tq <> nil do
X begin
X fp := oldfield(tq^.tvrnt, ip);
X if fp <> nil then
X tq := nil
X else
X tq := tq^.tnext
X end;
X999:
X oldfield := fp
Xend;
X
X(* This is the main parsing routine. It parses a correct pascal- *)
X(* program and builds a parsetree which is left in the global *)
X(* variable top. *)
X(* Parsing is done through recursive descent using a set of *)
X(* mutually recursive functions. *)
Xprocedure parse;
X
X function plabel : treeptr; forward;
X function pidlist(l : ltypes) : treeptr; forward;
X function pconst : treeptr; forward;
X function pconstant(realok : boolean) : treeptr; forward;
X function precord(cs : symtyp; dp : declptr) : treeptr; forward;
X function ptypedef : treeptr; forward;
X function ptype : treeptr; forward;
X function pvar : treeptr; forward;
X function psubs : treeptr; forward;
X function psubpar : treeptr; forward;
X function plabstmt : treeptr; forward;
X function pstmt : treeptr; forward;
X function psimple : treeptr; forward;
X function pvariable(varptr : treeptr) : treeptr; forward;
X function pexpr(tnp : treeptr) : treeptr; forward;
X function pcase : treeptr; forward;
X function pif : treeptr; forward;
X function pwhile : treeptr; forward;
X function prepeat : treeptr; forward;
X function pfor : treeptr; forward;
X function pwith : treeptr; forward;
X function pgoto : treeptr; forward;
X function pbegin(retain : boolean) : treeptr; forward;
X
X (* Open scope of a record variable. *)
X procedure scopeup(tp : treeptr);
X
X (* Scan a record-declaration and add all fields to *)
X (* current scope. *)
X procedure addfields(rp : treeptr);
X
X var fp, ip, vp : treeptr;
X sp : symptr;
X
X begin
X fp := rp^.tflist;
X while fp <> nil do
X begin
X ip := fp^.tidl;
X while ip <> nil do
X begin
X sp := mksym(lfield);
X sp^.lid := ip^.tsym^.lid;
X sp^.lused := false;
X sp^.lsymdecl := ip;
X declsym(sp);
X ip := ip^.tnext
X end;
X fp := fp^.tnext
X end;
X vp := rp^.tvlist;
X while vp <> nil do
X begin
X addfields(vp^.tvrnt);
X vp := vp^.tnext
X end
X end;
X begin
X addfields(typeof(tp))
X end;
X
X (* Check that the current label is new then save it in the *)
X (* current scope. Create and return a new node referencing *)
X (* the label. *)
X function newlbl : treeptr;
X
X var sp : symptr;
X tp : treeptr;
X
X begin
X tp := mknode(nlabel);
X sp := lookuplabel(currsym.vint);
X if sp <> nil then
X if sp^.ldecl <> symtab then
X sp := nil;
X if sp = nil then
X begin
X sp := mksym(lforwlab);
X sp^.lno := currsym.vint;
X sp^.lgo := false;
X sp^.lsymdecl := tp;
X declsym(sp)
X end
X else
X error(emultdecllab);
X tp^.tsym := sp;
X newlbl := tp
X end;
X
X (* Check that the current label is already declared. *)
X (* Create and return a new node referencing it. *)
X function oldlbl(defpt : boolean) : treeptr;
X
X var sp : symptr;
X tp : treeptr;
X
X begin
X sp := lookuplabel(currsym.vint);
X if sp = nil then
X begin
X prtmsg(enotdecllab);
X tp := newlbl;
X sp := tp^.tsym
X end
X else begin
X tp := mknode(nlabel);
X tp^.tsym := sp
X end;
X if defpt then
X begin
X
END_OF_FILE
if test 59347 -ne `wc -c <'ptc.p.1'`; then
echo shar: \"'ptc.p.1'\" unpacked with wrong size!
fi
# end of 'ptc.p.1'
fi
echo shar: End of archive 12 \(of 12\).
cp /dev/null ark12isdone
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