Google Git
Sign in
llvm/llvm-test-suite/refs/heads/fix_miniFE_bug/./MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p
blob: 5af0da90da43e31e9002c9c2769e16963c21f06e [file] [edit]
(***************************************************************************)
(***************************************************************************)
(** **)
(** Copyright (C) 1987 by Per Bergsten, Gothenburg, Sweden **)
(** **)
(** No part of this program, or parts derived from this program, **)
(** may be sold, hired or otherwise exploited without the author's **)
(** written consent. **)
(** **)
(** The program may be freely redistributed provided that: **)
(** **)
(** 1) the original program text, including this notice, **)
(** is reproduced unaltered, **)
(** 2) no charge (other than a nominal media cost) is **)
(** demanded for the copy. **)
(** **)
(** The program may be included in a package only on the condition **)
(** that the package as a whole is distributed at media cost. **)
(** **)
(***************************************************************************)
(***************************************************************************)
(** **)
(** The program ptc is a Pascal-to-C translator. **)
(** It accepts a correct Pascal program and creates a C program **)
(** with the same behaviour. It is not a complete compiler in the **)
(** sense that it does NOT do complete typechecking or error- **)
(** reporting. Only a minimal typecheck is done so that the meaning **)
(** of each construct can be determined. Therefore, an incorrect **)
(** Pascal program can easily cause the translator to malfunction. **)
(** **)
(***************************************************************************)
(***************************************************************************)
(** **)
(** Things which are known to be dependent on the underlying cha- **)
(** racterset are marked with a comment containing the word CHAR. **)
(** Things that are known to be dependent on the host operating **)
(** system are marked with a comment containing the word OS. **)
(** Things known to be dependent on the cpu and/or the target C- **)
(** implementation are marked with the word CPU. **)
(** Things dependent on the target C-library are marked with LIB. **)
(** **)
(** The code generated by the translator assumes that there is a **)
(** C-implementation with at least a reasonable <stdio> library **)
(** since all input/output is implemented in terms of C functions **)
(** like fprintf(), getc(), fopen(), rewind() etc. **)
(** If the source-program uses Pascal functions like sin(), sqrt() **)
(** etc, there must also exist such functions in the C-library. **)
(** **)
(***************************************************************************)
(***************************************************************************)
program ptc(input, output);
label 9999; (* end of program *)
const version = '@(#)ptc.p 1.5 Date 87/05/01';
keytablen = 38; (* nr of keywords *)
keywordlen = 10; (* length of a keyword *)
othersym = 'otherwise '; (* keyword for others *)
externsym = 'external '; (* keyword for external *)
dummysym = ' '; (* dummy keyword *)
(* a Pascal set is implemented as an array of "wordtype" where *)
(* each element contains bits numbered from 0 to "setbits" *)
wordtype = 'unsigned short'; (* CPU *)
setbits = 15; (* CPU *)
(* a Pascal file is implemented as a struct which (among other *)
(* things) contain a flag-field, currently 3 bits are used *)
filebits = 'unsigned short'; (* flags for files *)
filefill = 12; (* 16 less used 3 bits *)
maxsetrange = 15; (* nr of words in a set *)
scalbase = 0; (* ordinal value of first scalar member *)
maxprio = 7;
maxmachdefs = 8; (* max nr of machine integer types *)
machdeflen = 16; (* max length of machine int type name *)
(* limit of identifier table, identifiers and strings are saved *)
(* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char *)
maxstrblk = 1023;
maxblkcnt = 63;
maxstrstor = 65535; (* maxstrstor should be ==
(maxblkcnt+1) * (maxstrblk+1) - 1 *)
maxtoknlen = 127; (* max size of token (i.e. identifier,
string or number); must be > keywordlen
and should be <= 256, see hashtokn() *)
hashmax = 64; (* size of hashtable - 1 *)
null = 0; (* "impossible" character value, CHAR;
a char with this value is used as delimiter
of strings in "strstor" and in toknbuffers;
it is also used as end-of-input marker by
the input procedures in lexical analysis *)
minchar = null;
maxchar = 127; (* greatest possible character, CHAR; limits
the number of elements in type "char" *)
(* tmpfilename is used in the generated code to obtain names of
temporary files for reset/rewrite, the last character is supplied
by the reset/rewrite routine *)
tmpfilename = '"/tmp/ptc%d%c", getpid(), '; (* OS *)
(* some frequently used characters *)
space = ' ';
tab1 = ' ';
tab2 = ' ';
tab3 = ' ';
tab4 = ' ';
bslash = '\';
nlchr = '''\n''';
ffchr = '''\f''';
nulchr = '''\0''';
spchr = ''' ''';
quote = '''';
cite = '"';
xpnent = 'e'; (* exponent char in output. CPU *)
percent = '%';
uscore = '_';
badchr = '?'; (* CHAR *)
okchr = quote; (* CHAR *)
tabwidth = 8; (* width of a tab-stop. OS *)
echo = false; (* echo input as read *)
diffcomm = false; (* comment delimiters different *)
lazyfor = false; (* compile for-stmts a la C *)
unionnew = true; (* malloc unions for variants *)
inttyp = 'int'; (* for predefined functions *)
chartyp = 'char';
setwtyp = 'setword';
setptyp = 'setptr';
floattyp = 'float';
doubletyp = 'double';
dblcast = '(double)'; (* for predefined functions *)
realtyp = doubletyp; (* user real-vars and functions *)
voidtyp = 'void'; (* for procedures *)
voidcast = '(void)';
intlen = 10; (* length of written integer *)
fixlen = 20; (* length of written real *)
type
hashtyp = 0 .. hashmax; (* index to hash-tables *)
strindx = 0 .. maxstrstor; (* index to "strstor" *)
(* string-table "strstor" is implemented as an array that is grown
dynamically by adding blocks when needed *)
strbidx = 0 .. maxstrblk;
strblk = array [ strbidx ] of char;
strptr = ^ strblk;
strbcnt = 0 .. maxblkcnt;
(* table for stored identifiers *)
(* an identifier in any scope is represented by an idnode which is
hooked to a slot in "idtab" as determined by a hash-function.
whenever the input procedures find an identifier its idnode is
immediately located, or created, if none was found; the identifier
is then always handled though a pointer to the idnode. the actual
text of the identifier is stored in "strstor". *)
idptr = ^ idnode;
idnode = record
inext : idptr; (* chain of idnode's *)
inref : 0 .. 127; (* # of refs to this id *)
ihash : hashtyp; (* its hash value *)
istr : strindx; (* index to "strstor" *)
end;
(* toknbuf is used to handle identifiers and strings in those situations
where the actual text is of intrest *)
toknidx = 1 .. maxtoknlen;
toknbuf = array [ toknidx ] of char;
(* a type to hold Pascal keywords *)
keyword = packed array [ 1 .. keywordlen ] of char;
(* predefined identifier enumeration *)
predefs = (
dabs, darctan, dargc, dargv,
dboolean, dchar, dchr, dclose,
dcos, ddispose, deof, deoln,
dexit, dexp, dfalse, dflush,
dget, dhalt, dinput, dinteger,
dln, dmaxint, dmessage, dnew,
dodd, dord, doutput, dpage,
dpack, dpred, dput, dread,
dreadln, dreal, dreset, drewrite,
dround, dsin, dsqr, dsqrt,
dsucc, dtext, dtrue, dtrunc,
dtan, dwrite, dwriteln, dunpack,
dzinit, dztring
);
(* lexical symbol enumeration *)
symtyp = (
(* keywords and eof are sorted alphabetically ...... *)
sand, sarray, sbegin, scase,
sconst, sdiv, sdo, sdownto,
selse, send, sextern, sfile,
sfor, sforward, sfunc, sgoto,
sif, sinn, slabel, smod,
snil, snot, sof, sor,
sother, spacked, sproc, spgm,
srecord, srepeat, sset, sthen,
sto, stype, suntil, svar,
swhile, swith, seof,
(* ...... sorted *)
sinteger,
sreal, sstring, schar, sid,
splus, sminus, smul, squot,
sarrow, slpar, srpar, slbrack,
srbrack, seq, sne, slt,
sle, sgt, sge, scomma,
scolon, ssemic, sassign, sdotdot,
sdot
);
symset = set of symtyp;
(* lexical symbol definition *)
(* the lexical symbol holds a descriptor and the value of a symbol
read by the input procedures; note that real values are represented
as strings saved in "strstor" like ordinary strings to avoid using
float-variables and float-arithmetic in the translator *)
lexsym =
record
case st : symtyp of
sid: (vid : idptr);
schar: (vchr : char);
sinteger: (vint : integer);
sreal: (vflt : strindx);
sstring: (vstr : strindx);
end;
(* enumeration of symnode variants *)
ltypes = (
lpredef, lidentifier, lfield, lforward,
lpointer, lstring, llabel, lforwlab,
linteger, lreal, lcharacter
);
declptr = ^ declnode;
treeptr = ^ treenode;
symptr = ^ symnode;
(* identifier/literal symbol definition *)
(* in a given scope an identifier or a label is uniquely represented
by a "symnode"; in order to have a uniform treatment of all objects
occurring in the same syntactical positions (and hence in the parse-
tree) the literal constants are represented in a similar manner *)
symnode =
record
lsymdecl : treeptr; (* symbol decl. point *)
lnext : symptr; (* symtab chain pointer *)
ldecl : declptr; (* backptr to symtab *)
case lt : ltypes of
lpredef, (* a predefined id *)
lfield, (* a record field *)
lpointer, (* a pointer id *)
lidentifier, (* an identifier *)
lforward:
(
lid : idptr; (* ptr to its idnode *)
lused : boolean (* true if symbol used *)
);
lstring: (* a string literal *)
(
lstr : strindx (* index to "strstor" *)
);
lreal: (* a real literal *)
(
lfloat : strindx (* index to "strstor" *)
);
lforwlab, (* a declared label *)
llabel: (* label decl & defined *)
(
lno : integer; (* label number *)
lgo : boolean (* non-local usage *)
);
linteger: (* an integer literal *)
(
linum : integer (* its value *)
);
lcharacter: (* a character literal *)
(
lchar : char (* its value *)
)
end;
(* symbol table definition *)
(* the symbol table consists of symnodes chained along the lnext
field; the nodes are connected in reverse order of occurence (last
declared, first in chain) in the slot in the declnode determined
by the hashfunction; when a new scope is entered a new declnode is
manufactured and the previous one is hooked to the dprev field, thus
nested scopes are represented by a list of declnodes *)
declnode = record
dprev : declptr;
ddecl : array [ hashtyp ] of symptr
end;
(* enumeration of nodes in parse tree *)
(* NOTE: the subrange [ assignment .. nil ] have priorities *)
treetyp = (
npredef, npgm, nfunc, nproc,
nlabel, nconst, ntype, nvar,
nvalpar, nvarpar, nparproc, nparfunc,
nsubrange, nvariant, nfield, nrecord,
narray, nconfarr, nfileof, nsetof,
nbegin, nptr, nscalar, nif,
nwhile, nrepeat, nfor, ncase,
nchoise, ngoto, nwith, nwithvar,
nempty, nlabstmt, nassign, nformat,
nin, neq, nne, nlt,
nle, ngt, nge, nor,
nplus, nminus, nand, nmul,
ndiv, nmod, nquot, nnot,
numinus, nuplus, nset, nrange,
nindex, nselect, nderef, ncall,
nid, nchar, ninteger, nreal,
nstring, nnil, npush, npop,
nbreak
);
(* enumeration of predefined types *)
pretyps = (
tnone, tboolean, tchar, tinteger,
treal, tstring, tnil, tset,
ttext, tpoly, terror
);
(* enumeration of some special attributes *)
attributes = (
anone, aregister, aextern, areference
);
(* parse tree definition *)
(* the sourceprogram is represented by a treestructure built from
treenodes where each node corresponds to one syntactic form from
the pascal program *)
treenode =
record
tnext, (* ptr to next node in a list *)
ttype, (* pointer to nodes type *)
tup : treeptr; (* ptr to parent node *)
case tt : treetyp of
npredef: (* predefined object decl *)
(
tdef: (* predefined object descr. *)
predefs;
tobtyp: (* object type *)
pretyps
);
npgm, (* program declaration *)
nproc, (* procedure declaration *)
nfunc: (* function declaration *)
(
tsubid, (* subr. identifier (nid) *)
tsubpar, (* parameter list *)
tfuntyp, (* function type (nid) *)
tsublab, (* label decl list (nlabel) *)
tsubconst, (* const decl list (nconst) *)
tsubtype, (* type decl list (ntype) *)
tsubvar, (* var decl list (nvar) *)
tsubsub, (* subr. decl (nproc/nfunc) *)
tsubstmt: (* stmt. list (NOT nbegin) *)
treeptr;
tstat: (* static declaration level *)
integer;
tscope: (* symbol table for local id's *)
declptr
);
nvalpar, (* value parameter declaration *)
nvarpar, (* var parameter declaration *)
nconst, (* constant declaration *)
ntype, (* type declaration *)
nfield, (* record field declaration *)
nvar: (* var declaration declaration *)
(
tidl, (* list of declared id's (nid) *)
tbind: (* var/type-type, const-value *)
treeptr;
tattr: (* special attributes for vars *)
attributes
);
nparproc, (* parameter procedure *)
nparfunc: (* parameter function *)
(
tparid, (* parm proc/func id (nid) *)
tparparm, (* parm proc/func parm decl *)
tpartyp: (* parm func type (nid) *)
treeptr
);
nptr: (* pointer constructor *)
(
tptrid: (* referenced type (nid) *)
treeptr;
tptrflag: (* have seen node before *)
boolean
);
nscalar: (* scalar type constructor *)
(
tscalid: (* list of scalar ids (nid) *)
treeptr
);
nfileof, (* file type constructor *)
nsetof: (* set type constructor *)
(
tof: (* set/file component type *)
treeptr
);
nsubrange: (* subrange type constructor *)
(
tlo, thi: (* subrange limits *)
treeptr
);
nvariant: (* record variant constructor *)
(
tselct, (* selector list (constants) *)
tvrnt: (* variant field decl (nrecord) *)
treeptr
);
(* the tuid field is used to attach a name to variants since
C requires all union members to have names *)
nrecord: (* record/variant constructor *)
(
tflist, (* fixed field list (nfield) *)
tvlist: (* variant list (nvariant) *)
treeptr;
tuid: (* variant name *)
idptr;
trscope: (* symbol table for local id's *)
declptr
);
nconfarr: (* conformant array constructor *)
(
tcindx, (* index declaration *)
tindtyp, (* conf. arr. index type (nid) *)
tcelem: (* array element type decl *)
treeptr;
tcuid: (* variant name *)
idptr
);
narray: (* array type constructor *)
(
taindx, (* index declaration *)
taelem: (* array element type decl *)
treeptr
);
nbegin: (* begin statement *)
(
tbegin: (* statement list *)
treeptr
);
nlabstmt: (* labeled statement *)
(
tlabno, (* label number (nlabel) *)
tstmt: (* statement *)
treeptr
);
ngoto: (* goto statement *)
(
tlabel: (* label to go to (nlabel) *)
treeptr
);
nassign: (* assignment statement *)
(
tlhs, (* variable *)
trhs: (* value *)
treeptr
);
(* npush/npop is used in proc/func which have local variables
used in local proc/funcs; those variables are converted to
global ptrs initialized to reference the local variable *)
npush, (* init code for proc/func *)
npop: (* exit code for proc/func *)
(
tglob, (* global identifier (nid) *)
tloc, (* local identifier (nid) *)
ttmp: (* temp store for global (nid) *)
treeptr
);
nbreak:
(
tbrkid, (* for-variable *)
tbrkxp: (* value for break *)
treeptr
);
ncall: (* procedure/function call *)
(
tcall, (* called identifier *)
taparm: (* actual paramters *)
treeptr
);
nif: (* if statement *)
(
tifxp, (* conditional expression *)
tthen, (* stmt execd if true condition *)
telse: (* stmt execd if true condition *)
treeptr
);
nwhile: (* while statemnet *)
(
twhixp, (* conditional expression *)
twhistmt: (* stmt execd if true condition *)
treeptr
);
nrepeat: (* repeat statement *)
(
treptstmt, (* statement list *)
treptxp: (* conditional expression *)
treeptr
);
nfor: (* for statement *)
(
tforid, (* loop control variable (nid) *)
tfrom, (* initial value *)
tto, (* final value *)
tforstmt: (* stmt execd in loop *)
treeptr;
tincr: (* to/downto flag true <==> to *)
boolean
);
ncase: (* case statement *)
(
tcasxp, (* selecting expression *)
tcaslst, (* list of choises *)
tcasother: (* default action *)
treeptr
);
nchoise: (* a choise in a case-stmt *)
(
tchocon, (* list of constants *)
tchostmt: (* execd statement *)
treeptr
);
nwith: (* with statment *)
(
twithvar, (* list of variables (nwithvar) *)
twithstmt: (* statement execd in new scope *)
treeptr
);
(* the local symbol table holds identifiers, picked from
the record fields, temporarily declared during parsing
of remainder of with-statement; these identifiers are
later converted into fields referenced through a ptr *)
nwithvar: (* variable in with statement *)
(
texpw: (* record variable *)
treeptr;
tenv: (* symbol table for local scope *)
declptr
);
nindex: (* array indexing expression *)
(
tvariable, (* indexed variable *)
toffset: (* index expression *)
treeptr
);
nselect: (* record field selection expr *)
(
trecord, (* record variable *)
tfield: (* selected field (nid) *)
treeptr
);
(* binary operators or constructors *)
nrange, (* .. (set range) *)
nformat, (* : (write format) *)
nin, (* in *)
neq, (* = *)
nne, (* <> *)
nlt, (* < *)
nle, (* <= *)
ngt, (* > *)
nge, (* >= *)
nor, (* or *)
nplus, (* + *)
nminus, (* - *)
nand, (* and *)
nmul, (* * *)
ndiv, (* div *)
nmod, (* mod *)
nquot: (* / *)
(
texpl, (* left operand expr *)
texpr: (* right operand expr *)
treeptr
);
(* unary operators or constructors; note that uplus is
used to represent any parenthesized expression *)
nderef, (* ^ (ptr dereference) *)
nnot, (* not *)
nset, (* [ ] (set constr) *)
nuplus, (* + *)
numinus: (* - *)
(
texps: (* operand expression *)
treeptr
);
nid, (* identifier in decl or stmt *)
nreal, (* literal real (decl or stmt) *)
ninteger, (* literal int ( - " - ) *)
nchar, (* literal char ( - " - ) *)
nstring, (* literal string ( - " - ) *)
nlabel: (* label (decl, defpt or use) *)
(
tsym:
symptr
);
nnil, (* nil (pointer constant) *)
nempty: (* empty statement *)
( );
end;
(* "reserved" words and standard identifiers from C, C LIB and
OS environment excluding those reserved in Pascal *)
cnames = (
cabort, cbreak, ccontinue, cdefine,
cdefault, cdouble, cedata, cenum,
cetext, cextern, cfgetc, cfclose,
cfflush, cfloat, cfloor, cfprintf,
cfputc, cfread, cfscanf, cfwrite,
cgetc, cgetpid, cint, cinclude,
clong, clog, cmain, cmalloc,
cprintf, cpower, cputc, cread,
creturn, cregister, crewind, cscanf,
csetbits, csetword, csetptr, cshort,
csigned, csizeof, csprintf, cstdin,
cstdout, cstderr, cstrncmp, cstrncpy,
cstruct, cstatic, cswitch, ctypedef,
cundef, cungetc, cunion, cunlink,
cunsigned, cwrite
);
(* these are the detected errors. some are user-errors,
some are internal problems and some are host system errors *)
errors = (
ebadsymbol, elongstring, elongtokn, erange,
emanytokn, enotdeclid, emultdeclid, enotdecllab,
emultdecllab, emuldeflab, ebadstring, enulchr,
ebadchar, eeofcmnt, eeofstr, evarpar,
enew, esetbase, esetsize, eoverflow,
etree, etag, euprconf, easgnconf,
ecmpconf, econfconf, evrntfile, evarfile,
emanymachs, ebadmach
);
machdefstr = packed array [ 1 .. machdeflen ] of char;
var
usemax, (* program needs max-function *)
usejmps, (* source program uses non-local gotos *)
usecase, (* source program has case-statement *)
usesets, (* source program uses set-operations *)
useunion,
usediff,
usemksub,
useintr,
usesge,
usesle,
useseq,
usesne,
usememb,
useins,
usescpy,
usecomp, (* source program uses string-compare *)
usefopn, (* source program uses reset/rewrite *)
usescan,
usegetl,
usenilp, (* source program uses nil-pointer *)
usebool : boolean; (* source program writes boolean-values *)
top : treeptr; (* top of parsetree, result from parse *)
setlst : treeptr; (* list of set-initializations *)
setcnt : integer; (* counter for setlst length *)
currsym : lexsym; (* current lexical symbol *)
keytab : array [ 0 .. keytablen ] of (* table of keywords *)
record
wrd : keyword; (* keyword text *)
sym : symtyp (* corresponding symbol *)
end;
strstor : array [ strbcnt ] of strptr; (* store for strings *)
strfree : strindx; (* first free position *)
strleft : strbidx; (* room in last blk *)
idtab : array [ hashtyp ] of idptr; (* hashed table of id's *)
symtab : declptr; (* table of symbols *)
statlvl, (* static decl. level *)
maxlevel : integer; (* - " - maximum value *)
deftab : array [ predefs ] of treeptr; (* predefined idents. *)
defnams : array [ predefs ] of symptr; (* - " - *)
typnods : array [ pretyps ] of treeptr; (* predef. types. *)
pprio,
cprio : array [ nassign .. nnil ] of 0 .. maxprio;
ctable : array [ cnames ] of idptr; (* table of C-keywords *)
nmachdefs : 0 .. maxmachdefs;
machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types *)
record
lolim, hilim : integer;
typstr : strindx
end;
lineno, (* input line number *)
colno, (* input column number *)
lastcol, (* last OK input column *)
lastline : integer; (* last OK input line *)
lasttok : toknbuf; (* last input token *)
varno : integer; (* counter for unique id's *)
hexdig : packed array [ 0 .. 15 ] of char;
(* Prtmsg produces an error message. It asssumes that procedure *)
(* "message" (predefined) will "writeln" to user tty. OS *)
procedure prtmsg(m : errors);
const user = 'Error: ';
restr = 'Implementation restriction: ';
inter = '* Internal error * ';
xtoklen = 64; (* should be <= maxtoklen *)
var i : toknidx;
xtok : packed array [ 1 .. xtoklen ] of char;
begin
case m of
ebadsymbol:
message(user, 'Unexpected symbol');
ebadchar:
message(user, 'Bad character');
elongstring:
message(restr, 'Too long string');
ebadstring:
message(user, 'Newline in string or character');
eeofstr:
message(user, 'End of file in string or character');
eeofcmnt:
message(user, 'End of file in comment');
elongtokn:
message(restr, 'Too long identfier');
emanytokn:
message(restr, 'Too many strings, identifiers or real numbers');
enotdeclid:
message(user, 'Identifier not declared');
emultdeclid:
message(user, 'Identifier declared twice');
enotdecllab:
message(user, 'Label not declared');
emultdecllab:
message(user, 'Label declared twice');
emuldeflab:
message(user, 'Label defined twice');
evarpar:
message(user, 'Actual parameter not a variable');
enulchr:
message(restr, 'Cannot handle nul-character in strings');
enew:
message(restr, 'New returned a nil-pointer');
eoverflow:
message(restr, 'Token buffer overflowed');
esetbase:
message(restr, 'Cannot handle sets with base >> 0');
esetsize:
message(restr, 'Cannot handle sets with very large range');
etree:
message(inter, 'Bad tree structure');
etag:
message(inter, 'Cannot find tag');
evrntfile:
message(restr, 'Cannot initialize files in record variants');
evarfile:
message(restr, 'Cannot handle files in structured variables');
euprconf:
message(inter, 'No upper bound on conformant arrays');
easgnconf:
message(inter, 'Cannot assign conformant arrays');
ecmpconf:
message(inter, 'Cannot compare conformant arrays');
econfconf:
message(restr, 'Cannot handle nested conformat arrays');
erange:
message(inter, 'Cannot find C-type for integer-subrange');
emanymachs:
message(restr, 'Too many machine integer types');
ebadmach:
message(inter, 'Bad name for machine integer type');
end;(* case *)
if lastline <> 0 then
begin
(* error detected during parsing,
report line/column and print the offending symbol *)
message('Line ', lastline:1, ', col ', lastcol:1, ':');
if m in [enulchr, ebadchar, ebadstring, ebadsymbol,
emuldeflab, emultdecllab, enotdecllab, emultdeclid,
enotdeclid, elongtokn, elongstring] then
begin
i := 1;
while (i < xtoklen) and (lasttok[i] <> chr(null)) do
begin
xtok[i] := lasttok[i];
i := i + 1
end;
while i < xtoklen do
begin
xtok[i] := ' ';
i := i + 1
end;
xtok[xtoklen] := ' ';
message('Current symbol: ', xtok)
end
end
end;
procedure fatal(m : errors); forward;
procedure error(m : errors); forward;
(* Map letters to upper-case. *)
(* This function assumes a machine collating sequence where the *)
(* letters of either case form a contigous sequence, CHAR. *)
function uppercase(c : char) : char;
begin
if (c >= 'a') and (c <= 'z') then
uppercase := chr(ord(c) + ord('A') - ord('a'))
else
uppercase := c
end;
(* Map letters to lower-case. *)
(* This function assumes a machine collating sequence where the *)
(* letters of either case form a contigous sequence, CHAR. *)
function lowercase(c : char) : char;
begin
if (c >= 'A') and (c <= 'Z') then
lowercase := chr(ord(c) - ord('A') + ord('a'))
else
lowercase := c
end;
(* Retrieve a string from strstor. *)
procedure gettokn(i : strindx; var t : toknbuf);
var c : char;
k : toknidx;
j : strbidx;
p : strptr;
begin
k := 1;
(* compute block and offset in block *)
p := strstor[i div (maxstrblk + 1)];
j := i mod (maxstrblk + 1);
(* retrieve text up to null *)
repeat
c := p^[j];
t[k] := c;
j := j + 1;
k := k + 1;
if k = maxtoknlen then
begin
c := chr(null);
t[maxtoknlen] := chr(null);
prtmsg(eoverflow)
end
until c = chr(null)
end;
(* Deposit a string into strstor at a given start-position. *)
procedure puttokn(i : strindx; var t : toknbuf);
var c : char;
k : toknidx;
j : strbidx;
p : strptr;
begin
k := 1;
p := strstor[i div (maxstrblk + 1)];
j := i mod (maxstrblk + 1);
repeat
c := t[k];
p^[j] := c;
k := k + 1;
j := j + 1
until c = chr(null)
end;
(* Write a token on standard output. *)
procedure writetok(var w : toknbuf);
var j : toknidx;
begin
j := 1;
while w[j] <> chr(null) do
begin
write(w[j]);
j := j + 1
end
end;
(* Print a float number on standard output. *)
procedure printtok(i : strindx);
var w : toknbuf;
begin
gettokn(i, w);
writetok(w)
end;
(* Print an identifier on standard output. *)
procedure printid(ip : idptr);
begin
printtok(ip^.istr)
end;
(* Print a character on standard output with proper C-quoting. *)
procedure printchr(c : char);
begin
if (c = quote) or (c = bslash) then
write(quote, bslash, c, quote)
else
write(quote, c, quote)
end;
(* Print a string on standard output with proper C-quoting. *)
procedure printstr(i : strindx);
var k : toknidx;
c : char;
w : toknbuf;
begin
gettokn(i, w);
write(cite);
k := 1;
while w[k] <> chr(null) do
begin
c := w[k];
k := k + 1;
if (c = cite) or (c = bslash) then
write(bslash);
write(c)
end;
write(cite)
end;
(* Return a pointer to the declarationpoint of an identifier. *)
function idup(ip : treeptr) : treeptr;
begin
idup := ip^.tsym^.lsymdecl^.tup
end;
(* Compute a hashvalue for an identifier or a string. *)
function hashtokn(var id : toknbuf) : hashtyp;
var h : integer;
i : toknidx;
begin
i := 1;
h := 0;
while id[i] <> chr(null) do
begin
(* if ord() of a character ranges from 0 to 127 then we can loop
256 times without causing h to exceed 32767, this is safe as
both strings and identifiers are limited in length *)
h := h + ord(id[i]); (* CHAR, CPU *)
i := i + 1
end;
hashtokn := h mod hashmax
end;
(* Global string table update. *)
(* This function accepts a string and stores it in strstor. *)
(* It returns the id-number for the new string. *)
function savestr(var t : toknbuf) : strindx;
var k : toknidx;
i : strindx;
j : strbcnt;
begin
(* find length of new string including null-char *)
k := 1;
while t[k] <> chr(null) do
k := k + 1;
if k > strleft then
begin
(* out of space in strstore *)
if strstor[maxblkcnt] <> nil then (* last slot used *)
error(emanytokn);
(* allocate a new block *)
j := (strfree + maxstrblk) div (maxstrblk + 1);
new(strstor[j]);
if strstor[j] = nil then
error(enew);
strfree := j * (maxstrblk + 1);
strleft := maxstrblk
end;
(* copy new str, update location of last used cell,
return starting location for new str *)
i := strfree;
strfree := strfree + k;
strleft := strleft - k;
puttokn(i, t);
savestr := i
end;
(* Global id table lookup. *)
(* This procedure accepts an identifier and determines if it has *)
(* been seen before. If that is the case a pointer to its idnode *)
(* is returned, otherwise the identifier is saved and a pointer to *)
(* a new node is returned. *)
function saveid(var id : toknbuf) : idptr;
label 999;
var k : toknidx;
ip : idptr;
h : hashtyp;
t : toknbuf;
begin
h := hashtokn(id);
ip := idtab[h]; (* scan hashlist for id *)
while ip <> nil do
begin
gettokn(ip^.istr, t); (* look at saved token *)
k := 1;
while id[k] = t[k] do
if id[k] = chr(null) then
goto 999 (* found it! *)
else
k := k + 1; (* look at next char *)
ip := ip^.inext
end;
(* identifier wasn't previously seen, manufacture a new idnode,
save index to strstor and hashvalue, insert idnode in idtab *)
new(ip);
if ip = nil then
error(enew);
ip^.inref := 0;
ip^.istr := savestr(id);
ip^.ihash := h;
ip^.inext := idtab[h];
idtab[h] := ip;
999:
(* return the idnode *)
saveid := ip
end;
(* This function creates a new variable by concatenating one name *)
(* with another injecting a given separator. *)
function mkconc(sep : char; p, q : idptr) : idptr;
var w, x : toknbuf;
i, j : toknidx;
begin
(* fetch second part and determine its length *)
gettokn(q^.istr, x);
j := 1;
while x[j] <> chr(null) do
j := j + 1;
(* fetch first part and locate its end *)
w[1] := chr(null);
if p <> nil then
gettokn(p^.istr, w);
i := 1;
while w[i] <> chr(null) do
i := i + 1;
(* check total length *)
if i + j + 2 >= maxtoknlen then
error(eoverflow);
(* add separators *)
if sep = '>' then
begin
(* special case 1: > gives arrow: a->b *)
w[i] := '-';
i := i + 1
end;
if sep <> space then
begin
(* special case 2: space gives nothing: ab *)
w[i] := sep;
i := i + 1
end;
(* add second part *)
j := 1;
repeat
w[i] := x[j];
i := i + 1;
j := j + 1
until w[i-1] = chr(null);
(* save new identifier *)
mkconc := saveid(w)
end;
(* Create a new id with name-prefix from w. *)
function mkuniqname(var t : toknbuf) : idptr;
var i : toknidx;
procedure dig(n : integer);
begin
if n > 0 then
begin
dig(n div 10);
if i = maxtoknlen then
error(eoverflow);
t[i] := chr(n mod 10 + ord('0')); (* CHAR *)
i := i + 1
end
end;
begin
i := 1;
while t[i] <> chr(null) do
i := i + 1;
varno := varno + 1;
dig(varno);
t[i] := chr(null);
mkuniqname := saveid(t)
end;
(* Make a new unique variable with given char as prefix. *)
function mkvariable(c : char) : idptr;
var t : toknbuf;
begin
t[1] := c;
t[2] := chr(null);
mkvariable := mkuniqname(t)
end;
(* Make a new unique variable with given char as prefix and *)
(* with a given id as tail. Commonly used for renaming id's. *)
function mkrename(c : char; ip : idptr) : idptr;
begin
mkrename := mkconc(uscore, mkvariable(c), ip)
end;
(* Make a name for a variant. Variants are mapped onto C unions, *)
(* which we always give the name "U", thus the name of the variant *)
(* becomes "U.Vnnn" where "nnn" is a unique number. *)
function mkvrnt : idptr;
var t : toknbuf;
begin
t[1] := 'U';
t[2] := '.';
t[3] := 'V';
t[4] := chr(null);
mkvrnt := mkuniqname(t)
end;
procedure checksymbol(ss : symset);
begin
if not (currsym.st in ss) then
error(ebadsymbol);
end;
(* Lexical analysis routine. *)
(* This procedure reads and classifies the next lexical token in *)
(* the input stream. The token is saved in the global variable *)
(* "currsym". The found symbol should be one of the symbols given *)
(* in the parameter "ss" otherwise the error routine is called. *)
procedure nextsymbol(ss : symset);
var lastchr : 0 .. maxtoknlen;
(* This function reads the next character from the input *)
(* and updates "lineno" and "colno" accordingly. *)
function nextchar : char;
var c : char;
begin
if eof then
c := chr(null)
else begin
colno := colno + 1;
if eoln then
begin
lineno := lineno + 1;
colno := 0
end;
read(c);
if echo then
if colno = 0 then
writeln
else
write(c);
if c = tab1 then
colno := ((colno div tabwidth) + 1) * tabwidth
end;
if lastchr > 0 then
begin
lasttok[lastchr] := c;
lastchr := lastchr + 1
end;
nextchar := c
end;
(* This function looks at the next input character. *)
function peekchar : char;
begin
if eof then
peekchar := chr(null)
else
peekchar := input^
end;
(* Read and classify the next token. *)
procedure nexttoken(realok : boolean);
var c : char;
n : integer;
ready : boolean;
wl : toknidx;
wb : toknbuf;
(* Determine if c is valid in an identifier. *)
(* This function assumes a machine collating *)
(* sequence where letters and digits form conti- *)
(* gous sequences, CHAR. *)
function idchar(c : char) : boolean;
begin
idchar :=
(c >= 'a') and (c <= 'z') or
(c >= '0') and (c <= '9') or
(c >= 'A') and (c <= 'Z') or
(c = uscore)
end;
(* Determine if c is valid in a number. CHAR. *)
function numchar(c : char) : boolean;
begin
numchar := (c >= '0') and (c <= '9')
end;
(* Convert a digit to its numeric value. CHAR *)
function numval(c : char) : integer;
begin
numval := ord(c) - ord('0')
end;
(* Determine if the current token is a keyword. *)
function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;
var n : 1 .. keywordlen;
i, j, k : 0 .. keytablen;
wrd : keyword;
kwc : symtyp;
begin
(* quick check on token length,
pascal keywords range from 2 to 9 chars in length *)
if (l > 1) and (l < keywordlen) then
begin
(* could be a keyword, initialize wrd *)
wrd := keytab[keytablen].wrd;
(* copy w to wrd *)
for n := 1 to l do
wrd[n] := w[n];
(* binary search for tokn,
relies on symtyp being sorted *)
i := 0;
j := keytablen;
while j > i do
begin
k := (i + j) div 2;
if keytab[k].wrd >= wrd then
j := k
else
i := k + 1
end;
if keytab[j].wrd = wrd then
kwc := keytab[j].sym
else
kwc := sid
end
else
kwc := sid;
keywordcheck := kwc
end;
begin (* nexttoken *)
(* don't save blanks/comments *)
lastchr := 0;
(* read non-blank character *)
repeat
c := nextchar;
(* skip comments, the two comment delimiters of pascal
are treated as different if "diffcomm" is true *)
if c = '{' then
begin
repeat
c := nextchar;
if diffcomm then
ready := c = '}'
else
ready := ((c = '*') and
(peekchar = ')'))
or (c = '}')
until ready or eof;
if eof and not ready then
error(eeofcmnt);
if (c = '*') and not eof then
c := nextchar;
c := space
end
else if (c = '(') and (peekchar = '*') then
begin
c := nextchar;
repeat
c := nextchar;
if diffcomm then
ready := (c = '*') and
(peekchar = ')')
else
ready := ((c = '*') and
(peekchar = ')'))
or (c = '}')
until ready or eof;
if eof and not ready then
error(eeofcmnt);
if (c = '*') and not eof then
c := nextchar;
c := space
end
until (c <> space) and (c <> tab1);
(* save characters from this token and save line- and column-
numbers for errormessages *)
lasttok[1] := c;
lastchr := 2;
lastcol := colno;
lastline := lineno;
(* map all CHAR control characters onto "badchr" *)
if c < okchr then
c := badchr;
(* decode symbol *)
with currsym do
if eof then
begin
lasttok[1] := '*';
lasttok[2] := 'E';
lasttok[3] := 'O';
lasttok[4] := 'F';
lasttok[5] := '*';
lastchr := 6;
st := seof
end
else
case c of
(* CHAR, chars not in Pascal *)
'|', '`', '~', '}',
bslash, uscore, badchr:
error(ebadchar);
(* identifiers or keywords *)
'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
'u', 'v', 'w', 'x', 'y', 'z',
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
'U', 'V', 'W', 'X', 'Y', 'Z':
begin
(* read token into buffer *)
wb[1] := lowercase(c);
wl := 2;
while (wl < maxtoknlen) and idchar(peekchar) do
begin
wb[wl] := lowercase(nextchar);
wl := wl + 1
end;
if wl >= maxtoknlen then
begin
lasttok[lastchr] := chr(null);
error(elongtokn)
end;
(* terminate token and match *)
wb[wl] := chr(null);
(* check if keyword/identifier *)
st := keywordcheck(wb, wl-1);
if st = sid then
vid := saveid(wb)
end;
(* integer or real numbers *)
'0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
begin
(* assume integer number, save it in buffer *)
wb[1] := c;
wl := 2;
n := numval(c);
while numchar(peekchar) do
begin
c := nextchar;
n := n * 10 + numval(c);
wb[wl] := c;
wl := wl + 1
end;
st := sinteger;
vint := n;
if realok then
begin
(* accept real numbers *)
if peekchar = '.' then
begin
(* this is a real number *)
st := sreal;
wb[wl] := nextchar;
wl := wl + 1;
while numchar(peekchar) do
begin
wb[wl] := nextchar;
wl := wl + 1
end
end;
c := peekchar;
if (c = 'e') or (c = 'E') then
begin
(* this is a real number *)
st := sreal;
c := nextchar;
wb[wl] := xpnent;
wl := wl + 1;
c := peekchar;
if (c = '-') or (c = '+') then
begin
wb[wl] := nextchar;
wl := wl + 1
end;
while numchar(peekchar) do
begin
wb[wl] := nextchar;
wl := wl + 1
end
end;
if st = sreal then
begin
wb[wl] := chr(null);
vflt := savestr(wb)
end
end
end;
'(':
if peekchar = '.' then
begin
(* some compilers on non-ascii systems
use (. for [ and .) for ] *)
c := nextchar;
st := slbrack
end
else
st := slpar;
')':
st := srpar;
'[':
st := slbrack;
']':
st := srbrack;
'.':
if peekchar = '.' then
begin
c := nextchar;
st := sdotdot
end
else if peekchar = ')' then
begin
c := nextchar;
st := srbrack
end
else
st := sdot;
';':
st := ssemic;
':':
if peekchar = '=' then
begin
c := nextchar;
st := sassign
end
else
st := scolon;
',':
st := scomma;
'@',
'^':
st := sarrow;
'=':
st := seq;
'<':
if peekchar = '=' then
begin
c := nextchar;
st := sle
end
else if peekchar = '>' then
begin
c := nextchar;
st := sne
end
else
st := slt;
'>':
if peekchar = '=' then
begin
c := nextchar;
st := sge
end
else
st := sgt;
'+':
st := splus;
'-':
st := sminus;
'*':
st := smul;
'/':
st := squot;
quote:
begin
(* assume the symbol is a literal string *)
wl := 0;
ready := false;
repeat
if eoln then
begin
lasttok[lastchr] := chr(null);
error(ebadstring)
end;
c := nextchar;
if c = quote then
if peekchar = quote then
c := nextchar
else
ready := true;
if c = chr(null) then
begin
if eof then
error(eeofstr);
lasttok[lastchr] := chr(null);
error(enulchr)
end;
if not ready then
begin
wl := wl + 1;
if wl >= maxtoknlen then
begin
lasttok[lastchr] :=
chr(null);
error(elongstring)
end;
wb[wl] := c
end
until ready;
if wl = 1 then
begin
(* only 1 character => not a string *)
st := schar;
vchr := wb[1]
end
else begin
(* > 1 character => its a string *)
wl := wl + 1;
if wl >= maxtoknlen then
begin
lasttok[lastchr] := chr(null);
error(elongstring)
end;
wb[wl] := chr(null);
st := sstring;
vstr := savestr(wb)
end
end
end;(* case *)
if lastchr = 0 then
lastchr := 1;
lasttok[lastchr] := chr(null)
end; (* nexttoken *)
begin (* nextsymbol *)
nexttoken(sreal in ss);
checksymbol(ss)
end; (* nextsymbol *)
(* Return a pointer to the node describing the type of tp. This *)
(* function also stores the result in the node for future ref. *)
function typeof(tp : treeptr) : treeptr;
var tf, tq : treeptr;
begin
tq := tp;
tf := tq^.ttype;
(* keep working until a type is found *)
while tf = nil do
begin
case tq^.tt of
nchar:
tf := typnods[tchar];
ninteger:
tf := typnods[tinteger];
nreal:
tf := typnods[treal];
nstring:
tf := typnods[tstring];
nnil:
tf := typnods[tnil];
nid:
begin
tq := idup(tq);
if tq = nil then
fatal(etree)
end;
ntype,
nvar,
nconst,
nfield,
nvalpar,
nvarpar:
tq := tq^.tbind;
npredef,
nptr,
nscalar,
nrecord,
nconfarr,
narray,
nfileof,
nsetof:
tf := tq; (* these nodetypes represent types *)
nsubrange:
if tq^.tup^.tt = nconfarr then
tf := tq^.tup^.tindtyp
else
tf := tq;
ncall:
begin
tf := typeof(tq^.tcall);
if tf = typnods[tpoly] then
tf := typeof(tq^.taparm)
end;
nfunc:
tq := tq^.tfuntyp;
nparfunc:
tq := tq^.tpartyp;
nproc,
nparproc:
tf := typnods[tnone];
nvariant,
nlabel,
npgm,
nempty,
nbegin,
nlabstmt,
nassign,
npush,
npop,
nif,
nwhile,
nrepeat,
nfor,
ncase,
nchoise,
ngoto,
nwith,
nwithvar:
fatal(etree);
nformat,
nrange:
tq := tq^.texpl;
nplus,
nminus,
nmul:
begin
tf := typeof(tq^.texpl);
if tf = typnods[tinteger] then
tf := typeof(tq^.texpr)
else if tf^.tt = nsetof then
tf := typnods[tset]
end;
numinus,
nuplus:
tq := tq^.texps;
nmod,
ndiv:
tf := typnods[tinteger];
nquot:
tf := typnods[treal];
neq,
nne,
nlt,
nle,
ngt,
nge,
nin,
nor,
nand,
nnot:
tf := typnods[tboolean];
nset:
tf := typnods[tset];
nselect:
tq := tq^.tfield;
nderef:
begin
tq := typeof(tq^.texps);
case tq^.tt of
nptr:
tq := tq^.tptrid;
nfileof:
tq := tq^.tof;
npredef:
tf := typnods[tchar] (* textfile *)
end (* case *)
end;
nindex:
begin
tq := typeof(tq^.tvariable);
if tq^.tt = nconfarr then
tq := tq^.tcelem
else if tq = typnods[tstring] then
tf := typnods[tchar]
else
tq := tq^.taelem
end;
end (* case *)
end;
if tp^.ttype = nil then
tp^.ttype := tf; (* remember type for future reference *)
typeof := tf
end; (* typeof *)
(* Connect all nodes to their fathers. *)
procedure linkup(up, tp : treeptr);
begin
while tp <> nil do
begin
if tp^.tup = nil then
begin
tp^.tup := up;
case tp^.tt of
npgm,
nfunc,
nproc:
begin
linkup(tp, tp^.tsubid);
linkup(tp, tp^.tsubpar);
linkup(tp, tp^.tfuntyp);
linkup(tp, tp^.tsublab);
linkup(tp, tp^.tsubconst);
linkup(tp, tp^.tsubtype);
linkup(tp, tp^.tsubvar);
linkup(tp, tp^.tsubsub);
linkup(tp, tp^.tsubstmt)
end;
nvalpar,
nvarpar,
nconst,
ntype,
nfield,
nvar:
begin
linkup(tp, tp^.tidl);
linkup(tp, tp^.tbind)
end;
nparproc,
nparfunc:
begin
linkup(tp, tp^.tparid);
linkup(tp, tp^.tparparm);
linkup(tp, tp^.tpartyp)
end;
nptr:
linkup(tp, tp^.tptrid);
nscalar:
linkup(tp, tp^.tscalid);
nsubrange:
begin
linkup(tp, tp^.tlo);
linkup(tp, tp^.thi)
end;
nvariant:
begin
linkup(tp, tp^.tselct);
linkup(tp, tp^.tvrnt)
end;
nrecord:
begin
linkup(tp, tp^.tflist);
linkup(tp, tp^.tvlist)
end;
nconfarr:
begin
linkup(tp, tp^.tcindx);
linkup(tp, tp^.tcelem);
linkup(tp, tp^.tindtyp)
end;
narray:
begin
linkup(tp, tp^.taindx);
linkup(tp, tp^.taelem)
end;
nfileof,
nsetof:
linkup(tp, tp^.tof);
nbegin:
linkup(tp, tp^.tbegin);
nlabstmt:
begin
linkup(tp, tp^.tlabno);
linkup(tp, tp^.tstmt)
end;
nassign:
begin
linkup(tp, tp^.tlhs);
linkup(tp, tp^.trhs)
end;
npush,
npop:
begin
linkup(tp, tp^.tglob);
linkup(tp, tp^.tloc);
linkup(tp, tp^.ttmp)
end;
ncall:
begin
linkup(tp, tp^.tcall);
linkup(tp, tp^.taparm )
end;
nif:
begin
linkup(tp, tp^.tifxp);
linkup(tp, tp^.tthen);
linkup(tp, tp^.telse)
end;
nwhile:
begin
linkup(tp, tp^.twhixp);
linkup(tp, tp^.twhistmt)
end;
nrepeat:
begin
linkup(tp, tp^.treptstmt);
linkup(tp, tp^.treptxp)
end;
nfor:
begin
linkup(tp, tp^.tforid);
linkup(tp, tp^.tfrom);
linkup(tp, tp^.tto);
linkup(tp, tp^.tforstmt)
end;
ncase:
begin
linkup(tp, tp^.tcasxp);
linkup(tp, tp^.tcaslst);
linkup(tp, tp^.tcasother)
end;
nchoise:
begin
linkup(tp, tp^.tchocon);
linkup(tp, tp^.tchostmt)
end;
nwith:
begin
linkup(tp, tp^.twithvar);
linkup(tp, tp^.twithstmt)
end;
nwithvar:
linkup(tp, tp^.texpw);
nindex:
begin
linkup(tp, tp^.tvariable);
linkup(tp, tp^.toffset)
end;
nselect:
begin
linkup(tp, tp^.trecord);
linkup(tp, tp^.tfield)
end;
ngoto:
linkup(tp, tp^.tlabel);
nrange, nformat,
nin, neq,
nne, nlt, nle,
ngt, nge, nor,
nplus, nminus,
nand, nmul,
ndiv, nmod,
nquot:
begin
linkup(tp, tp^.texpl);
linkup(tp, tp^.texpr)
end;
nderef,
nnot, nset,
numinus,
nuplus:
linkup(tp, tp^.texps);
nid,
nnil, ninteger,
nreal, nchar,
nstring, npredef,
nlabel, nempty:
(* no op *)
end (* case *)
end;
tp := tp^.tnext
end
end; (* linkup *)
(* Allocate a new symbol node. *)
function mksym(vt : ltypes) : symptr;
var mp : symptr;
begin
new(mp);
if mp = nil then
error(enew);
mp^.lt := vt;
mp^.lnext := nil;
mp^.lsymdecl := nil;
mp^.ldecl := nil;
mksym := mp
end;
(* Enter a symbol at current declarationlevel. *)
procedure declsym(sp : symptr);
var h : hashtyp;
begin
if sp^.lt in [lpredef, lidentifier, lfield, lforward, lpointer] then
h := sp^.lid^.ihash
else
h := hashmax;
sp^.lnext := symtab^.ddecl[h];
symtab^.ddecl[h] := sp;
sp^.ldecl := symtab
end;
(* Create a node of selected type. *)
function mknode(nt : treetyp) : treeptr;
var tp : treeptr;
begin
tp := nil;
case nt of
npredef: new(tp, npredef);
npgm: new(tp, npgm);
nfunc: new(tp, nfunc);
nproc: new(tp, nproc);
nlabel: new(tp, nlabel);
nconst: new(tp, nconst);
ntype: new(tp, ntype);
nvar: new(tp, nvar);
nvalpar: new(tp, nvalpar);
nvarpar: new(tp, nvarpar);
nparproc: new(tp, nparproc);
nparfunc: new(tp, nparfunc);
nsubrange: new(tp, nsubrange);
nvariant: new(tp, nvariant);
nfield: new(tp, nfield);
nrecord: new(tp, nrecord);
nconfarr: new(tp, nconfarr);
narray: new(tp, narray);
nfileof: new(tp, nfileof);
nsetof: new(tp, nsetof);
nbegin: new(tp, nbegin);
nptr: new(tp, nptr);
nscalar: new(tp, nscalar);
nif: new(tp, nif);
nwhile: new(tp, nwhile);
nrepeat: new(tp, nrepeat);
nfor: new(tp, nfor);
ncase: new(tp, ncase);
nchoise: new(tp, nchoise);
ngoto: new(tp, ngoto);
nwith: new(tp, nwith);
nwithvar: new(tp, nwithvar);
nempty: new(tp, nempty);
nlabstmt: new(tp, nlabstmt);
nassign: new(tp, nassign);
nformat: new(tp, nformat);
nin: new(tp, nin);
neq: new(tp, neq);
nne: new(tp, nne);
nlt: new(tp, nlt);
nle: new(tp, nle);
ngt: new(tp, ngt);
nge: new(tp, nge);
nor: new(tp, nor);
nplus: new(tp, nplus);
nminus: new(tp, nminus);
nand: new(tp, nand);
nmul: new(tp, nmul);
ndiv: new(tp, ndiv);
nmod: new(tp, nmod);
nquot: new(tp, nquot);
nnot: new(tp, nnot);
numinus: new(tp, numinus);
nuplus: new(tp, nuplus);
nset: new(tp, nset);
nrange: new(tp, nrange);
nindex: new(tp, nindex);
nselect: new(tp, nselect);
nderef: new(tp, nderef);
ncall: new(tp, ncall);
nid: new(tp, nid);
nchar: new(tp, nchar);
ninteger: new(tp, ninteger);
nreal: new(tp, nreal);
nstring: new(tp, nstring);
nnil: new(tp, nnil);
npush: new(tp, npush);
npop: new(tp, npop);
nbreak: new(tp, nbreak)
end;(* case *)
if tp = nil then
error(enew);
tp^.tt := nt;
tp^.tnext := nil;
tp^.tup := nil;
tp^.ttype := nil;
mknode := tp
end;
(* Create a node with a literal value. *)
function mklit : treeptr;
var sp : symptr;
tp : treeptr;
begin
case currsym.st of
sinteger:
begin
sp := mksym(linteger);
sp^.linum := currsym.vint;
tp := mknode(ninteger);
end;
sreal:
begin
sp := mksym(lreal);
sp^.lfloat := currsym.vflt;
tp := mknode(nreal);
end;
schar:
begin
sp := mksym(lcharacter);
sp^.lchar := currsym.vchr;
tp := mknode(nchar);
end;
sstring:
begin
sp := mksym(lstring);
sp^.lstr := currsym.vstr;
tp := mknode(nstring);
end
end;(* case *)
tp^.tsym := sp;
sp^.lsymdecl := tp;
mklit := tp
end;
(* Look up an identifier among declared symbols. *)
function lookupid(ip : idptr; fieldok : boolean) : symptr;
label 999;
var sp : symptr;
dp : declptr;
vs : set of ltypes;
begin
lookupid := nil;
if fieldok then
vs := [lidentifier, lforward, lpointer, lfield]
else
vs := [lidentifier, lforward, lpointer];
sp := nil;
(* pick up symboltable from innermost scope *)
dp := symtab;
while dp <> nil do
begin
(* scan linked symbols with same hasvalue *)
sp := dp^.ddecl[ip^.ihash];
while sp <> nil do
begin
(* break out when proper id found *)
if (sp^.lt in vs) and (sp^.lid = ip) then
goto 999;
sp := sp^.lnext
end;
(* proceed to enclosing scope *)
dp := dp^.dprev
end;
999:
lookupid := sp
end;
(* Look up a label. *)
function lookuplabel(i : integer) : symptr;
label 999;
var sp : symptr;
dp : declptr;
begin
sp := nil;
dp := symtab;
while dp <> nil do
begin
sp := dp^.ddecl[hashmax];
while sp <> nil do
begin
if (sp^.lt in [lforwlab, llabel]) and (sp^.lno = i) then
goto 999;
sp := sp^.lnext
end;
dp := dp^.dprev
end;
999:
lookuplabel := sp
end;
(* Create a new declaration level (a new scope) link declnode to *)
(* previous node. dp is non-nil when a procedure/function body *)
(* is encountered for which we have seen a forward declaration. *)
procedure enterscope(dp : declptr);
var h : hashtyp;
begin
if dp = nil then
begin
new(dp);
for h := 0 to hashmax do
dp^.ddecl[h] := nil
end;
dp^.dprev := symtab;
symtab := dp
end;
(* Return current scope (as a pointer to symbol-table). *)
function currscope : declptr;
begin
currscope := symtab
end;
(* Drop innermost declaration scope. *)
procedure leavescope;
begin
symtab := symtab^.dprev
end;
(* Create a new identifier symbol. *)
function mkid(ip : idptr) : symptr;
var sp : symptr;
begin
sp := mksym(lidentifier);
sp^.lid := ip;
sp^.lused := false;
declsym(sp);
ip^.inref := ip^.inref + 1;
mkid := sp
end;
(* Check that the current identifier is new then save it in the *)
(* current scope. Create and return a new node representing this *)
(* instance of the identifier. *)
function newid(ip : idptr) : treeptr;
var sp : symptr;
tp : treeptr;
begin
sp := lookupid(ip, false);
if sp <> nil then
if sp^.ldecl <> symtab then
sp := nil;
if sp = nil then
begin
(* new identifier *)
tp := mknode(nid);
sp := mkid(ip);
sp^.lsymdecl := tp;
tp^.tsym := sp
end
else if sp^.lt = lpointer then
begin
(* previously declared as a pointer type *)
tp := mknode(nid);
tp^.tsym := sp;
sp^.lt := lidentifier;
sp^.lsymdecl := tp
end
else if sp^.lt = lforward then
begin
(* previously forward declared *)
sp^.lt := lidentifier;
tp := sp^.lsymdecl
end
else
error(emultdeclid);
newid := tp
end;
(* Check that the current identifier is already declared, *)
(* we fail unless l in [lforward, lpointer]. *)
(* Create and return a new node referencing it. *)
function oldid(ip : idptr; l : ltypes) : treeptr;
var sp : symptr;
tp : treeptr;
begin
sp := lookupid(ip, true);
if sp = nil then
begin
if l in [lforward, lpointer] then
begin
tp := newid(ip);
tp^.tsym^.lt := l
end
else
error(enotdeclid)
end
else begin
sp^.lused := true;
tp := mknode(nid);
tp^.tsym := sp;
if (sp^.lt = lpointer) and (l = lidentifier) then
begin
sp^.lt := lidentifier;
sp^.lsymdecl := tp
end
end;
oldid := tp
end;
(* Look up a field in a record declaration. *)
(* Return nil if field isn't declared in "tp" or its variants. *)
function oldfield(tp : treeptr; ip : idptr) : treeptr;
label 999;
var tq, ti,
fp : treeptr;
begin
fp := nil;
tq := tp^.tflist;
while tq <> nil do
begin
ti := tq^.tidl;
while ti <> nil do
begin
if ti^.tsym^.lid = ip then
begin
fp := mknode(nid);
fp^.tsym := ti^.tsym;
goto 999
end;
ti := ti^.tnext
end;
tq := tq^.tnext
end;
tq := tp^.tvlist;
while tq <> nil do
begin
fp := oldfield(tq^.tvrnt, ip);
if fp <> nil then
tq := nil
else
tq := tq^.tnext
end;
999:
oldfield := fp
end;
(* This is the main parsing routine. It parses a correct pascal- *)
(* program and builds a parsetree which is left in the global *)
(* variable top. *)
(* Parsing is done through recursive descent using a set of *)
(* mutually recursive functions. *)
procedure parse;
function plabel : treeptr; forward;
function pidlist(l : ltypes) : treeptr; forward;
function pconst : treeptr; forward;
function pconstant(realok : boolean) : treeptr; forward;
function precord(cs : symtyp; dp : declptr) : treeptr; forward;
function ptypedef : treeptr; forward;
function ptype : treeptr; forward;
function pvar : treeptr; forward;
function psubs : treeptr; forward;
function psubpar : treeptr; forward;
function plabstmt : treeptr; forward;
function pstmt : treeptr; forward;
function psimple : treeptr; forward;
function pvariable(varptr : treeptr) : treeptr; forward;
function pexpr(tnp : treeptr) : treeptr; forward;
function pcase : treeptr; forward;
function pif : treeptr; forward;
function pwhile : treeptr; forward;
function prepeat : treeptr; forward;
function pfor : treeptr; forward;
function pwith : treeptr; forward;
function pgoto : treeptr; forward;
function pbegin(retain : boolean) : treeptr; forward;
(* Open scope of a record variable. *)
procedure scopeup(tp : treeptr);
(* Scan a record-declaration and add all fields to *)
(* current scope. *)
procedure addfields(rp : treeptr);
var fp, ip, vp : treeptr;
sp : symptr;
begin
fp := rp^.tflist;
while fp <> nil do
begin
ip := fp^.tidl;
while ip <> nil do
begin
sp := mksym(lfield);
sp^.lid := ip^.tsym^.lid;
sp^.lused := false;
sp^.lsymdecl := ip;
declsym(sp);
ip := ip^.tnext
end;
fp := fp^.tnext
end;
vp := rp^.tvlist;
while vp <> nil do
begin
addfields(vp^.tvrnt);
vp := vp^.tnext
end
end;
begin
addfields(typeof(tp))
end;
(* Check that the current label is new then save it in the *)
(* current scope. Create and return a new node referencing *)
(* the label. *)
function newlbl : treeptr;
var sp : symptr;
tp : treeptr;
begin
tp := mknode(nlabel);
sp := lookuplabel(currsym.vint);
if sp <> nil then
if sp^.ldecl <> symtab then
sp := nil;
if sp = nil then
begin
sp := mksym(lforwlab);
sp^.lno := currsym.vint;
sp^.lgo := false;
sp^.lsymdecl := tp;
declsym(sp)
end
else
error(emultdecllab);
tp^.tsym := sp;
newlbl := tp
end;
(* Check that the current label is already declared. *)
(* Create and return a new node referencing it. *)
function oldlbl(defpt : boolean) : treeptr;
var sp : symptr;
tp : treeptr;
begin
sp := lookuplabel(currsym.vint);
if sp = nil then
begin
prtmsg(enotdecllab);
tp := newlbl;
sp := tp^.tsym
end
else begin
tp := mknode(nlabel);
tp^.tsym := sp
end;
if defpt then
begin
if sp^.lt = lforwlab then
sp^.lt := llabel
else
error(emuldeflab);
end;
oldlbl := tp
end;
(* Parse declaration and statement-body for prog/subs. *)
procedure pbody(tp : treeptr);
var tq : treeptr;
begin
statlvl := statlvl + 1;
if currsym.st = slabel then
begin
tp^.tsublab := plabel;
linkup(tp, tp^.tsublab)
end
else
tp^.tsublab := nil;
if currsym.st = sconst then
begin
tp^.tsubconst := pconst;
linkup(tp, tp^.tsubconst)
end
else
tp^.tsubconst := nil;
if currsym.st = stype then
begin
tp^.tsubtype := ptype;
linkup(tp, tp^.tsubtype)
end
else
tp^.tsubtype := nil;
if currsym.st = svar then
begin
tp^.tsubvar := pvar;
linkup(tp, tp^.tsubvar)
end
else
tp^.tsubvar := nil;
tp^.tsubsub := nil;
tq := nil;
while (currsym.st = sproc) or (currsym.st = sfunc) do
begin
if tq = nil then
begin
tq := psubs;
tp^.tsubsub := tq
end
else begin
tq^.tnext := psubs;
tq := tq^.tnext
end
end;
linkup(tp, tp^.tsubsub);
checksymbol([sbegin, seof]);
if currsym.st = sbegin then
begin
tp^.tsubstmt := pbegin(false);
linkup(tp, tp^.tsubstmt)
end;
statlvl := statlvl - 1
end;
(* Parse program-declaration. *)
function pprogram : treeptr;
var tp : treeptr;
(* Parse a program parameter id-list. *)
function pprmlist : treeptr;
label 999;
var tp,
tq : treeptr;
din,
dut : idptr;
begin
tp := nil;
din := deftab[dinput]^.tidl^.tsym^.lid;
dut := deftab[doutput]^.tidl^.tsym^.lid;
while (currsym.vid = din) or (currsym.vid = dut) do
begin
(* ignore input/output as parameters so that
they will be bound to stdin/stdout unless
declared as variables *)
if currsym.vid = din then
defnams[dinput]^.lused := true
else
defnams[doutput]^.lused := true;
nextsymbol([scomma, srpar]);
if currsym.st = srpar then
goto 999;
nextsymbol([sid])
end;
tq := newid(currsym.vid);
tq^.tsym^.lt := lpointer;
tp := tq;
nextsymbol([scomma, srpar]);
while currsym.st = scomma do
begin
nextsymbol([sid]);
if currsym.vid = din then
defnams[dinput]^.lused := true
else if currsym.vid = dut then
defnams[doutput]^.lused := true
else begin
tq^.tnext := newid(currsym.vid);
tq := tq^.tnext;
tq^.tsym^.lt := lpointer;
end;
nextsymbol([scomma, srpar])
end;
999:
pprmlist := tp
end;
begin (* pprogram *)
enterscope(nil);
tp := mknode(npgm);
nextsymbol([sid]);
tp^.tstat := statlvl;
tp^.tsubid := mknode(nid);
tp^.tsubid^.tup := tp;
tp^.tsubid^.tsym := mksym(lidentifier);
tp^.tsubid^.tsym^.lid := currsym.vid;
tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid;
linkup(tp, tp^.tsubid);
nextsymbol([slpar, ssemic]);
if currsym.st = slpar then
begin
nextsymbol([sid]);
tp^.tsubpar := pprmlist;
linkup(tp, tp^.tsubpar);
nextsymbol([ssemic])
end
else
tp^.tsubpar := nil;
nextsymbol([slabel, sconst, stype, svar,
sproc, sfunc, sbegin]);
pbody(tp);
checksymbol([sdot]);
tp^.tscope := currscope;
leavescope;
pprogram := tp
end; (* pprogram *)
(* Parse a module. *)
function pmodule : treeptr;
var tp : treeptr;
begin (* pmodule *)
enterscope(nil);
tp := mknode(npgm);
tp^.tstat := statlvl;
tp^.tsubid := nil;
tp^.tsubpar := nil;
pbody(tp);
checksymbol([ssemic]);
tp^.tscope := currscope;
leavescope;
pmodule := tp
end; (* pmodule *)
(* Parse label-clause. *)
function plabel;
var tp,
tq : treeptr;
begin
tq := nil;
repeat
nextsymbol([sinteger]);
if tq = nil then
begin
tq := newlbl;
tp := tq
end
else begin
tq^.tnext := newlbl;
tq := tq^.tnext;
end;
nextsymbol([scomma, ssemic])
until currsym.st = ssemic;
nextsymbol([sconst, stype, svar, sbegin, sproc, sfunc]);
plabel := tp
end;
(* Parse an id-list. *)
function pidlist;
var tp,
tq : treeptr;
begin
tq := newid(currsym.vid);
tq^.tsym^.lt := l;
tp := tq;
nextsymbol([scomma, scolon, seq, srpar]);
while currsym.st = scomma do
begin
nextsymbol([sid]);
tq^.tnext := newid(currsym.vid);
tq := tq^.tnext;
tq^.tsym^.lt := l;
nextsymbol([scomma, scolon, seq, srpar])
end;
pidlist := tp
end;
(* Parse const-clause. *)
function pconst;
var tp,
tq : treeptr;
begin
tq := nil;
nextsymbol([sid]);
repeat
if tq = nil then
begin
tq := mknode(nconst);
tq^.tattr := anone;
tp := tq
end
else begin
tq^.tnext := mknode(nconst);
tq := tq^.tnext;
tq^.tattr := anone
end;
tq^.tidl := pidlist(lidentifier);
checksymbol([seq]);
nextsymbol([sid, schar, sstring, sinteger, sreal,
splus, sminus]);
tq^.tbind := pconstant(true);
nextsymbol([ssemic]);
nextsymbol([sid, stype, svar, sbegin,
sfunc, sproc, seof])
until currsym.st <> sid;
pconst := tp
end;
(* Parse a declared constant or a case-statment const. *)
function pconstant;
var tp,
tq : treeptr;
neg : boolean;
begin
neg := currsym.st = sminus;
if currsym.st in [splus, sminus] then
if realok then
nextsymbol([sid, sinteger, sreal])
else
nextsymbol([sid, sinteger]);
if currsym.st = sid then
tp := oldid(currsym.vid, lidentifier)
else
tp := mklit;
if neg then
begin
tq := mknode(numinus);
tq^.texps := tp;
tp := tq
end;
pconstant := tp
end;
(* Parse a record (or record-variant) declaration. *)
(* Cs is the expected closing symbol, dp the scope. *)
function precord;
label 999;
var tp,
tq,
tl,
tv : treeptr;
tsym : lexsym;
begin
tp := mknode(nrecord);
tp^.tflist := nil;
tp^.tvlist := nil;
tp^.tuid := nil;
tp^.trscope := nil;
if cs = send then
begin
enterscope(dp);
dp := currscope
end;
nextsymbol([sid, scase] + [cs]);
tq := nil;
while currsym.st = sid do
begin
if tq = nil then
begin
tq := mknode(nfield);
tq^.tattr := anone;
tp^.tflist := tq
end
else begin
tq^.tnext := mknode(nfield);
tq := tq^.tnext;
tq^.tattr := anone
end;
tq^.tidl := pidlist(lfield);
checksymbol([scolon]);
leavescope;
tq^.tbind := ptypedef;
enterscope(dp);
if currsym.st = ssemic then
nextsymbol([sid, scase] + [cs])
end;
if currsym.st = scase then
begin
nextsymbol([sid]);
tsym := currsym;
nextsymbol([scolon, sof]);
if currsym.st = scolon then
begin
tv := newid(tsym.vid);
if tq = nil then
begin
tq := mknode(nfield);
tp^.tflist := tq
end
else begin
tq^.tnext := mknode(nfield);
tq := tq^.tnext
end;
tq^.tidl := tv;
tv^.tsym^.lt := lfield;
nextsymbol([sid]);
leavescope;
tq^.tbind := oldid(currsym.vid, lidentifier);
enterscope(dp);
nextsymbol([sof])
end;
tq := nil;
repeat
tv := nil;
repeat
nextsymbol([sid, sinteger, schar, splus,
sminus] + [cs]);
if currsym.st = cs then
goto 999;
if tv = nil then
begin
tv := pconstant(false);
tl := tv
end
else begin
tv^.tnext := pconstant(false);
tv := tv^.tnext
end;
nextsymbol([scolon, scomma])
until currsym.st = scolon;
nextsymbol([slpar]);
if tq = nil then
begin
tq := mknode(nvariant);
tp^.tvlist := tq;
end
else begin
tq^.tnext := mknode(nvariant);
tq := tq^.tnext;
end;
tq^.tselct := tl;
tq^.tvrnt := precord(srpar, dp)
until currsym.st = cs
end;
999:
if cs = send then
begin
tp^.trscope := dp;
leavescope
end;
nextsymbol([ssemic, send, srpar]);
(* currsym is the symbol following record end/rpar,
(usually semicolon, sometimes enclosing end/rpar) *)
precord := tp
end;
function ptypedef;
var tp,
tq : treeptr;
st : symtyp;
ss : symset;
begin
nextsymbol([sid, slpar, sarrow, sinteger, schar, splus, sminus,
spacked, sarray, srecord, sfile, sset]);
(* the "packed" keyword is completely ignored *)
if currsym.st = spacked then
nextsymbol([sarray, srecord, sfile, sset]);
ss := [ssemic, send, srpar, scomma, srbrack];
case currsym.st of
splus,
sminus,
schar,
sinteger,
sid:
begin
st := currsym.st;
tp := pconstant(false);
if st = sid then
nextsymbol([sdotdot] + ss)
else
nextsymbol([sdotdot]);
if currsym.st = sdotdot then
begin
nextsymbol([sid, sinteger, schar,
splus, sminus]);
tq := mknode(nsubrange);
tq^.tlo := tp;
tq^.thi := pconstant(false);
tp := tq;
nextsymbol(ss)
end
end;
slpar:
begin
tp := mknode(nscalar);
nextsymbol([sid]);
tp^.tscalid := pidlist(lidentifier);
checksymbol([srpar]);
nextsymbol(ss)
end;
sarrow:
begin
tp := mknode(nptr);
nextsymbol([sid]);
tp^.tptrid := oldid(currsym.vid, lpointer);
tp^.tptrflag := false;
nextsymbol([ssemic, send, srpar])
end;
sarray:
begin
nextsymbol([slbrack]);
tp := mknode(narray);
tp^.taindx := ptypedef; (* parse subrange ... *)
tq := tp;
while currsym.st = scomma do
begin
(* expand: array [ A , B ] of X
to: array [ A ] of array [ B ] of X *)
tq^.taelem := mknode(narray);
tq := tq^.taelem;
tq^.taindx := ptypedef (* ... again *)
end;
checksymbol([srbrack]);
nextsymbol([sof]);
tq^.taelem := ptypedef
end;
srecord:
tp := precord(send, nil);
sfile,
sset:
begin
if currsym.st = sfile then
tp := mknode(nfileof)
else begin
tp := mknode(nsetof);
usesets := true
end;
nextsymbol([sof]);
tp^.tof := ptypedef
end
end;
(* at this point "currsym" holds the symbol following the type
(usually semicolon, sometimes the following end/rpar) *)
ptypedef := tp
end;
(* Parse type-clause. *)
function ptype;
var tp,
tq : treeptr;
begin
tq := nil;
nextsymbol([sid]);
repeat
if tq = nil then
begin
tq := mknode(ntype);
tq^.tattr := anone;
tp := tq
end
else begin
tq^.tnext := mknode(ntype);
tq := tq^.tnext;
tq^.tattr := anone
end;
tq^.tidl := pidlist(lidentifier);
checksymbol([seq]);
tq^.tbind := ptypedef;
nextsymbol([sid, svar, sbegin, sfunc, sproc, seof])
until currsym.st <> sid;
ptype := tp;
end;
(* Parse var-clause. *)
function pvar;
var ti,
tp,
tq : treeptr;
begin
tq := nil;
nextsymbol([sid]);
repeat
if tq = nil then
begin
tq := mknode(nvar);
tq^.tattr := anone;
tp := tq
end
else begin
tq^.tnext := mknode(nvar);
tq := tq^.tnext;
tq^.tattr := anone
end;
ti := newid(currsym.vid);
tq^.tidl := ti;
nextsymbol([scomma, scolon]);
while currsym.st = scomma do
begin
nextsymbol([sid]);
ti^.tnext := newid(currsym.vid);
ti := ti^.tnext;
nextsymbol([scomma, scolon])
end;
tq^.tbind := ptypedef;
nextsymbol([sid, sbegin, sfunc, sproc, seof])
until currsym.st <> sid;
pvar := tp
end;
(* Parse subroutine-declaration. *)
function psubs;
var tp, (* return value *)
tv, tq : treeptr; (* temporary *)
func : boolean; (* true for functions *)
colsem : symtyp; (* colon/semicolon *)
begin
(* parsing function or procedure *)
func := currsym.st = sfunc;
if func then
colsem := scolon
else
colsem := ssemic;
(* parse id, it may already be forward declared *)
nextsymbol([sid]);
tq := newid(currsym.vid);
if tq^.tup = nil then
begin
enterscope(nil);
(* id wasn't previously declared, params possible *)
if func then
tp := mknode(nfunc)
else
tp := mknode(nproc);
tp^.tstat := statlvl;
tp^.tsubid := tq;
linkup(tp, tq);
nextsymbol([slpar, colsem]);
if currsym.st = slpar then
begin
tp^.tsubpar := psubpar;
linkup(tp, tp^.tsubpar);
nextsymbol([colsem])
end
else
tp^.tsubpar := nil;
if func then
begin
(* parse function type *)
nextsymbol([sid]);
tp^.tfuntyp := oldid(currsym.vid, lidentifier);
nextsymbol([ssemic])
end
else
tp^.tfuntyp := mknode(nempty);
linkup(tp, tp^.tfuntyp);
nextsymbol([sextern, sforward,
slabel, sconst, stype, svar,
sproc, sfunc, sbegin]);
end
else begin
(* id was forward declared =>
pick up declarations from parameterlist *)
enterscope(tq^.tup^.tscope);
if func then
tp := mknode(nfunc)
else
tp := mknode(nproc);
tp^.tfuntyp := tq^.tup^.tfuntyp;
(* steal id and params from forward decl *)
tv := tq^.tup^.tsubpar;
tp^.tsubpar := tv;
while tv <> nil do
begin
tv^.tup := tp;
tv := tv^.tnext
end;
tp^.tsubid := tq;
tq^.tup := tp;
(* id was forward declared =>
no params, no function type, no forward *)
nextsymbol([ssemic]);
nextsymbol([slabel, sconst, stype, svar,
sproc, sfunc, sbegin]);
end;
if currsym.st in [sforward, sextern] then
begin
tp^.tsubid^.tsym^.lt := lforward;
nextsymbol([ssemic]);
tp^.tsublab := nil;
tp^.tsubconst := nil;
tp^.tsubtype := nil;
tp^.tsubvar := nil;
tp^.tsubsub := nil;
tp^.tsubstmt := nil
end
else
pbody(tp);
nextsymbol([sproc, sfunc, sbegin, seof]);
tp^.tscope := currscope;
leavescope;
psubs := tp
end;
(* Parse a conformant array index type. *)
function pconfsub : treeptr;
var tp : treeptr;
begin
tp := mknode(nsubrange);
nextsymbol([sid]);
tp^.tlo := newid(currsym.vid);
nextsymbol([sdotdot]);
nextsymbol([sid]);
tp^.thi := newid(currsym.vid);
nextsymbol([scolon]);
pconfsub := tp
end;
(* Parse a conformant array-declaration. *)
function pconform : treeptr;
var tp, tq : treeptr;
begin
nextsymbol([slbrack]);
tp := mknode(nconfarr);
tp^.tcuid := mkvariable('S');
tp^.tcindx := pconfsub; (* parse subrange ... *)
nextsymbol([sid]);
tp^.tindtyp := oldid(currsym.vid, lidentifier);
nextsymbol([ssemic, srbrack]);
tq := tp;
while currsym.st = ssemic do
begin
error(econfconf); (* what size does tp have *)
(* expand: array [ A ; B ] of X
to: array [ A ] of array [ B ] of X *)
tq^.tcelem := mknode(nconfarr);
tq := tq^.tcelem;
tq^.tcindx := pconfsub; (* ... again *)
nextsymbol([sid]);
tq^.tindtyp := oldid(currsym.vid, lidentifier);
nextsymbol([ssemic, srbrack])
end;
nextsymbol([sof]);
nextsymbol([sid, sarray]);
case currsym.st of
sid:
tq^.tcelem := oldid(currsym.vid, lidentifier);
sarray:
begin
error(econfconf); (* what size does tp have *)
tq^.tcelem := pconform
end;
end;(* case *)
pconform := tp
end;
(* Parse subroutine parameter list. *)
function psubpar;
var tp,
tq : treeptr;
nt : treetyp;
begin
tq := nil;
repeat
nextsymbol([sid, svar, sfunc, sproc]);
case currsym.st of
sid:
nt := nvalpar;
svar:
nt := nvarpar;
sfunc:
nt := nparfunc;
sproc:
nt := nparproc;
end;
if nt <> nvalpar then
nextsymbol([sid]);
if tq = nil then
begin
tq := mknode(nt);
tp := tq
end
else begin
tq^.tnext := mknode(nt);
tq := tq^.tnext
end;
case nt of
nvarpar,
nvalpar:
begin
tq^.tidl := pidlist(lidentifier);
tq^.tattr := anone;
checksymbol([scolon]);
if nt = nvalpar then
nextsymbol([sid])
else
nextsymbol([sid, sarray]);
case currsym.st of
sid:
tq^.tbind :=
oldid(currsym.vid, lidentifier);
sarray:
tq^.tbind := pconform
end;(* case *)
nextsymbol([srpar, ssemic])
end;
nparproc:
begin
tq^.tparid := newid(currsym.vid);
nextsymbol([ssemic, slpar, srpar]);
if currsym.st = slpar then
begin
enterscope(nil);
tq^.tparparm := psubpar;
nextsymbol([ssemic, srpar]);
leavescope
end
else
tq^.tparparm := nil;
tq^.tpartyp := nil
end;
nparfunc:
begin
tq^.tparid := newid(currsym.vid);
nextsymbol([scolon, slpar]);
if currsym.st = slpar then
begin
enterscope(nil);
tq^.tparparm := psubpar;
nextsymbol([scolon]);
leavescope
end
else
tq^.tparparm := nil;
nextsymbol([sid]);
tq^.tpartyp := oldid(currsym.vid, lidentifier);
nextsymbol([srpar, ssemic])
end
end (* case *)
until currsym.st = srpar;
psubpar := tp
end;
(* Parse a (possibly labeled) statement. *)
function plabstmt;
var tp : treeptr;
begin
nextsymbol([sid, sinteger, sif, swhile, srepeat, sfor, scase,
swith, sbegin, sgoto,
selse, ssemic, send, suntil]);
if currsym.st = sinteger then
begin
tp := mknode(nlabstmt);
tp^.tlabno := oldlbl(true);
nextsymbol([scolon]);
nextsymbol([sid, sif, swhile, srepeat, sfor, scase,
swith, sbegin, sgoto,
selse, ssemic, send, suntil]);
tp^.tstmt := pstmt
end
else
tp := pstmt;
plabstmt := tp
end;
(* Parse an unlabeled statement. *)
function pstmt;
var tp : treeptr;
begin
case currsym.st of
sid:
tp := psimple;
sif:
tp := pif;
swhile:
tp := pwhile;
srepeat:
tp := prepeat;
sfor:
tp := pfor;
scase:
tp := pcase;
swith:
tp := pwith;
sbegin:
tp := pbegin(true);
sgoto:
tp := pgoto;
send,
selse,
suntil,
ssemic:
tp := mknode(nempty);
end;
pstmt := tp
end;
(* Parse an assignment or a procedure call. *)
function psimple;
var tq,
tp : treeptr;
begin
tp := pvariable(oldid(currsym.vid, lidentifier));
if currsym.st = sassign then
begin
tq := mknode(nassign);
tq^.tlhs := tp;
tq^.trhs := pexpr(nil);
tp := tq
end;
psimple := tp
end;
(* Parse a varable-reference (or a subroutine-call). *)
function pvariable;
var tp,
tq : treeptr;
begin
nextsymbol([slpar, slbrack, sdot, sarrow,
sassign, ssemic, scomma, scolon, sdotdot,
splus, sminus, smul, sdiv, smod, squot,
sand, sor, sinn, srpar, srbrack,
sle, slt, seq, sge, sgt, sne,
send, suntil, sthen, selse, sdo, sdownto, sto, sof]);
if currsym.st in [slpar, slbrack, sdot, sarrow] then
begin
case currsym.st of
slpar:
begin
tp := mknode(ncall);
tp^.tcall := varptr;
tq := nil;
repeat
if tq = nil then
begin
tq := pexpr(nil);
tp^.taparm := tq
end
else begin
tq^.tnext := pexpr(nil);
tq := tq^.tnext
end;
until currsym.st = srpar
end;
slbrack:
begin
tq := varptr;
repeat
tp := mknode(nindex);
tp^.tvariable := tq;
tp^.toffset := pexpr(nil);
tq := tp
until currsym.st = srbrack
end;
sdot:
begin
tp := mknode(nselect);
tp^.trecord := varptr;
nextsymbol([sid]);
tq := typeof(varptr);
enterscope(tq^.trscope);
tp^.tfield := oldid(currsym.vid, lfield);
leavescope
end;
sarrow:
begin
tp := mknode(nderef);
tp^.texps := varptr
end
end;(* case *)
tp := pvariable(tp)
end
else begin
tp := varptr;
if tp^.tt = nid then
begin
tq := idup(tp);
if tq <> nil then
if tq^.tt in [nfunc, nproc,
nparproc, nparfunc] then
begin
(* subroutine-call without
parameters *)
tp := mknode(ncall);
tp^.tcall := varptr;
tp^.taparm := nil
end
end
end;
pvariable := tp
end;
(* Parse an expression. *)
function pexpr;
var tp,
tq : treeptr;
nt : treetyp;
next : boolean;
function padjust(tu, tr : treeptr) : treeptr;
begin
if pprio[tu^.tt] >= pprio[tr^.tt] then
begin
if tr^.tt in [nnot, numinus, nuplus,
nset, nderef] then
tr^.texps := padjust(tu, tr^.texps)
else
tr^.texpl := padjust(tu, tr^.texpl);
padjust := tr
end
else begin
if tu^.tt in [nnot, numinus, nuplus,
nset, nderef] then
tu^.texps := tr
else
tu^.texpr := tr;
padjust := tu
end
end;
begin
nextsymbol([sid, schar, sinteger, sreal, sstring, snil,
splus, sminus, snot, slpar, slbrack, srbrack]);
next := true;
case currsym.st of
splus:
begin
tp := mknode(nuplus);
tp^.texps := nil;
tp := pexpr(tp);
next := false
end;
sminus:
begin
tp := mknode(numinus);
tp^.texps := nil;
tp := pexpr(tp);
next := false
end;
snot:
begin
tp := mknode(nnot);
tp^.texps := nil;
tp := pexpr(tp);
next := false
end;
schar,
sinteger,
sreal,
sstring:
tp := mklit;
snil:
begin
usenilp := true;
tp := mknode(nnil);
end;
sid:
begin
tp := pvariable(oldid(currsym.vid, lidentifier));
next := false
end;
slpar:
begin
tp := mknode(nuplus);
tp^.texps := pexpr(nil)
end;
slbrack:
begin
usesets := true;
tp := mknode(nset);
tp^.texps := nil;
tq := nil;
repeat
if tq = nil then
begin
tq := pexpr(nil);
tp^.texps := tq
end
else begin
tq^.tnext := pexpr(nil);
tq := tq^.tnext
end
until currsym.st = srbrack;
end;
srbrack:
begin
tp := mknode(nempty);
next := false
end
end;
if next then
nextsymbol([
scolon, ssemic, scomma, sdotdot, srpar, srbrack,
sle, slt, seq, sge, sgt, sne,
splus, sminus, smul, sdiv, smod, squot,
sand, sor, sinn,
send, suntil, sthen, selse, sdo, sdownto, sto,
sof, slpar, slbrack]);
case currsym.st of
sdotdot:
nt := nrange;
splus:
nt := nplus;
sminus:
nt := nminus;
smul:
nt := nmul;
sdiv:
nt := ndiv;
smod:
nt := nmod;
squot:
begin
defnams[dreal]^.lused := true;
nt := nquot;
end;
sand:
nt := nand;
sor:
nt := nor;
sinn:
begin
nt := nin;
usesets := true
end;
sle:
nt := nle;
slt:
nt := nlt;
seq:
nt := neq;
sge:
nt := nge;
sgt:
nt := ngt;
sne:
nt := nne;
scolon:
nt := nformat;
sid, schar, sinteger, sreal, sstring, snil,
ssemic, scomma, slpar, slbrack, srpar, srbrack,
send, suntil, sthen, selse, sdo, sdownto, sto, sof:
nt := nnil
end;(* case *)
if nt in [nin .. nor, nand, nnot] then
defnams[dboolean]^.lused := true;
if nt <> nnil then
begin
(* binary operator *)
tq := mknode(nt);
tq^.texpl := tp;
tq^.texpr := nil;
tp := pexpr(tq)
end;
(* this statement yilds proper operator precedence *)
if tnp <> nil then
tp := padjust(tnp, tp);
pexpr := tp
end;
(* Parse a case-statement. *)
function pcase;
label 999;
var tp,
tq,
tv : treeptr;
begin
tp := mknode(ncase);
tp^.tcasxp := pexpr(nil);
checksymbol([sof]);
tq := nil;
repeat
if tq = nil then
begin
tq := mknode(nchoise);
tp^.tcaslst := tq
end
else begin
tq^.tnext := mknode(nchoise);
tq := tq^.tnext
end;
tv := nil;
repeat
nextsymbol([sid, sinteger, schar,
splus, sminus, send, sother]);
if currsym.st in [send, sother] then
goto 999;
if tv = nil then
begin
tv := pconstant(false);
tq^.tchocon := tv
end
else begin
tv^.tnext := pconstant(false);
tv := tv^.tnext
end;
nextsymbol([scomma, scolon])
until currsym.st = scolon;
tq^.tchostmt := plabstmt
until currsym.st = send;
999:
if currsym.st = sother then
begin
nextsymbol([scolon, sid, sif, swhile, srepeat, sfor,
scase, swith, sbegin, sgoto,
selse, ssemic, send, suntil]);
if currsym.st = scolon then
nextsymbol([sid, sif, swhile, srepeat, sfor,
scase, swith, sbegin, sgoto,
selse, ssemic, send, suntil]);
tp^.tcasother := pstmt
end
else begin
tp^.tcasother := nil;
usecase := true
end;
nextsymbol([ssemic, send, selse, suntil]);
pcase := tp
end;
(* Parse an if-statement. *)
function pif;
var tp : treeptr;
begin
tp := mknode(nif);
tp^.tifxp := pexpr(nil);
checksymbol([sthen]);
tp^.tthen := plabstmt;
if currsym.st = selse then
tp^.telse := plabstmt
else
tp^.telse := nil;
pif := tp;
end;
(* Parse a while-statement. *)
function pwhile;
var tp : treeptr;
begin
tp := mknode(nwhile);
tp^.twhixp := pexpr(nil);
checksymbol([sdo]);
tp^.twhistmt := plabstmt;
pwhile := tp;
end;
(* Parse a repeat-statement. *)
function prepeat;
var tp,
tq : treeptr;
begin
tp := mknode(nrepeat);
tq := nil;
repeat
if tq = nil then
begin
tq := plabstmt;
tp^.treptstmt := tq
end
else begin
tq^.tnext := plabstmt;
tq := tq^.tnext
end;
checksymbol([ssemic, suntil])
until currsym.st = suntil;
tp^.treptxp := pexpr(nil);
prepeat := tp
end;
(* Parse a for-statement. *)
function pfor;
var tp : treeptr;
begin
tp := mknode(nfor);
nextsymbol([sid]);
tp^.tforid := oldid(currsym.vid, lidentifier);
nextsymbol([sassign]);
tp^.tfrom := pexpr(nil);
checksymbol([sdownto, sto]);
tp^.tincr := currsym.st = sto;
tp^.tto := pexpr(nil);
checksymbol([sdo]);
tp^.tforstmt := plabstmt;
pfor := tp
end;
(* Parse a with-statement. *)
function pwith;
var tp,
tq : treeptr;
begin
tp := mknode(nwith);
tq := nil;
repeat
if tq = nil then
begin
tq := mknode(nwithvar);
tp^.twithvar := tq
end
else begin
tq^.tnext := mknode(nwithvar);
tq := tq^.tnext
end;
enterscope(nil);
tq^.tenv := currscope;
tq^.texpw := pexpr(nil);
scopeup(tq^.texpw);
checksymbol([scomma, sdo])
until currsym.st = sdo;
tp^.twithstmt := plabstmt;
tq := tp^.twithvar;
while tq <> nil do
begin
leavescope;
tq := tq^.tnext
end;
pwith := tp
end;
(* Parse a goto-statement. *)
function pgoto;
var tp : treeptr;
begin
nextsymbol([sinteger]);
tp := mknode(ngoto);
tp^.tlabel := oldlbl(false);
nextsymbol([ssemic, send, suntil, selse]);
pgoto := tp
end;
(* Parse a begin-statement. *)
function pbegin;
var tp,
tq : treeptr;
begin
tq := nil;
repeat
if tq = nil then
begin
tq := plabstmt;
tp := tq
end
else begin
tq^.tnext := plabstmt;
tq := tq^.tnext
end
until currsym.st = send;
if retain then
begin
tq := mknode(nbegin);
tq^.tbegin := tp;
tp := tq
end;
nextsymbol([send, selse, suntil, sdot, ssemic]);
pbegin := tp
end;
begin (* parse *)
nextsymbol([spgm, sconst, stype, svar, sproc, sfunc]);
if currsym.st = spgm then
top := pprogram
else
top := pmodule;
nextsymbol([seof]);
end; (* parse *)
(* Compute value for a node (which must be some kind of constant). *)
function cvalof(tp : treeptr) : integer;
var v : integer;
tq : treeptr;
begin
case tp^.tt of
nuplus:
cvalof := cvalof(tp^.texps);
numinus:
cvalof := - cvalof(tp^.texps);
nnot:
cvalof := 1 - cvalof(tp^.texps);
nid:
begin
tq := idup(tp);
if tq = nil then
fatal(etree);
tp := tp^.tsym^.lsymdecl;
case tq^.tt of
nscalar:
begin
v := 0;
tq := tq^.tscalid;
while tq <> nil do
if tq = tp then
tq := nil
else begin
v := v + 1;
tq := tq^.tnext
end;
cvalof := v
end;
nconst:
cvalof := cvalof(tq^.tbind);
end;(* case *)
end;
ninteger:
cvalof := tp^.tsym^.linum;
nchar:
cvalof := ord(tp^.tsym^.lchar);
end (* case *)
end; (* cvalof *)
(* Compute lower value of subrange or scalar type. *)
function clower(tp : treeptr) : integer;
var tq : treeptr;
begin
tq := typeof(tp);
if tq^.tt = nscalar then
clower := scalbase
else if tq^.tt = nsubrange then
if tq^.tup^.tt = nconfarr then
clower := 0
else
clower := cvalof(tq^.tlo)
else if tq = typnods[tchar] then
clower := 0
else if tq = typnods[tinteger] then
clower := -maxint
else
fatal(etree)
end; (* clower *)
(* Compute upper value of subrange or scalar type. *)
function cupper(tp : treeptr) : integer;
var tq : treeptr;
i : integer;
begin
tq := typeof(tp);
if tq^.tt = nscalar then
begin
tq := tq^.tscalid;
i := scalbase;
while tq^.tnext <> nil do
begin
i := i + 1;
tq := tq^.tnext
end;
cupper := i
end
else if tq^.tt = nsubrange then
if tq^.tup^.tt = nconfarr then
fatal(euprconf)
else
cupper := cvalof(tq^.thi)
else if tq = typnods[tchar] then
cupper := maxchar
else if tq = typnods[tinteger] then
cupper := maxint
else
fatal(etree)
end; (* cupper *)
(* Compute the number of elements in a subrange. *)
function crange(tp : treeptr) : integer;
begin
crange := cupper(tp) - clower(tp) + 1
end;
(* Return number of words uset to store a set. *)
function csetwords(i : integer) : integer;
begin
i := (i+(setbits)) div (setbits+1);
if i > maxsetrange then
error(esetsize);
csetwords := i
end;
(* Return number of words uset to store a set. *)
function csetsize(tp : treeptr) : integer;
var tq : treeptr;
i : integer;
begin
tq := typeof(tp^.tof);
i := clower(tq);
(* bits in sets are always numbered from 0, so we (arbitrarily)
decide that the base must be in the first 6 words to avoid
unnecessary waste of space *)
if (i < 0) or (i >= 6 * (setbits+1)) then
error(esetbase);
csetsize := csetwords(crange(tq)) + 1
end;
(* Determine if tp is declared in the procedure it is used in. *)
function islocal(tp : treeptr) : boolean;
var tq : treeptr;
begin
tq := tp^.tsym^.lsymdecl;
while not (tq^.tt in [nproc, nfunc, npgm]) do
tq := tq^.tup;
while not (tp^.tt in [nproc, nfunc, npgm]) do
tp := tp^.tup;
islocal := tp = tq
end;
(* Perform necessary transformations on tree and identifiers *)
(* before generating code. *)
procedure transform;
(* Rename function when used as a variable. *)
procedure renamf(tp : treeptr);
var ip, iq : symptr;
tq, tv : treeptr;
(* This procedure recursively descends the tree *)
(* and replaces function-assignments with variable *)
(* assignments. *)
procedure crtnvar(tp : treeptr);
begin
while tp <> nil do
begin
case tp^.tt of
npgm:
crtnvar(tp^.tsubsub);
nfunc,
nproc:
begin
crtnvar(tp^.tsubsub);
crtnvar(tp^.tsubstmt)
end;
nbegin:
crtnvar(tp^.tbegin);
nif:
begin
crtnvar(tp^.tthen);
crtnvar(tp^.telse)
end;
nwhile:
crtnvar(tp^.twhistmt);
nrepeat:
crtnvar(tp^.treptstmt);
nfor:
crtnvar(tp^.tforstmt);
ncase:
begin
crtnvar(tp^.tcaslst);
crtnvar(tp^.tcasother)
end;
nchoise:
crtnvar(tp^.tchostmt);
nwith:
crtnvar(tp^.twithstmt);
nlabstmt:
crtnvar(tp^.tstmt);
nassign:
begin
(* revoke calls in assignment lhs, (mis-
parsed due to ambiguous syntax) *)
if tp^.tlhs^.tt = ncall then
begin
tp^.tlhs := tp^.tlhs^.tcall;
tp^.tlhs^.tup := tp
end;
(* function name -> variable name *)
tv := tp^.tlhs;
if tv^.tt = nid then
if tv^.tsym = ip then
tv^.tsym := iq
end;
nbreak,
npush,
npop,
ngoto,
nempty,
ncall:
(* no op *)
end;(* case *)
tp := tp^.tnext
end
end;
begin (* renamf *)
while tp <> nil do
begin
case tp^.tt of
npgm,
nproc:
renamf(tp^.tsubsub);
nfunc:
begin
(* create a variable to hold return value *)
tq := mknode(nvar);
tq^.tattr := aregister;
tq^.tup := tp;
tq^.tidl := newid(mkvariable('R'));
tq^.tidl^.tup := tq;
tq^.tbind := tp^.tfuntyp;
(* put it FIRST among variables, see esubr() *)
tq^.tnext := tp^.tsubvar;
tp^.tsubvar := tq;
iq := tq^.tidl^.tsym;
ip := tp^.tsubid^.tsym;
crtnvar(tp^.tsubsub);
crtnvar(tp^.tsubstmt);
(* process inner functions *)
renamf(tp^.tsubsub)
end;
end;(* case *)
tp := tp^.tnext
end
end; (* renamf *)
(* This procedure rearranges the tree such that multiple *)
(* vardeclarations don't have (structured) types attached *)
(* to them. If such a declararation is found, a new name *)
(* is created and the type is moved to the type section. *)
procedure extract(tp : treeptr);
var vp : treeptr;
(* Create a declaration for tp, enter in pp type- *)
(* list and return an identifier referencing it. *)
function xtrit(tp, pp : treeptr; last : boolean) : treeptr;
var np, rp : treeptr;
ip : idptr;
begin
(* create new declaration *)
np := mknode(ntype);
ip := mkvariable('T');
np^.tidl := newid(ip);
np^.tidl^.tup := np;
(* create substitute id *)
rp := oldid(ip, lidentifier);
rp^.tup := tp^.tup;
rp^.tnext := tp^.tnext;
(* steal type description *)
np^.tbind := tp;
tp^.tup := np;
tp^.tnext := nil;
(* add new declaration to tree *)
np^.tup := pp;
if last and (pp^.tsubtype <> nil) then
begin
pp := pp^.tsubtype;
while pp^.tnext <> nil do
pp := pp^.tnext;
pp^.tnext := np
end
else begin
np^.tnext := pp^.tsubtype;
pp^.tsubtype := np;
end;
xtrit := rp;
end;
(* Extract anonymous enumeration types. *)
function xtrenum(tp, pp : treeptr) : treeptr;
(* Name record-types referenced by ptrs. *)
procedure nametype(tp : treeptr);
begin
tp := typeof(tp);
if tp^.tt = nrecord then
if tp^.tuid = nil then
tp^.tuid := mkvariable('S');
end;
begin
if tp <> nil then
begin
case tp^.tt of
nfield,
ntype,
nvar:
tp^.tbind :=
xtrenum(tp^.tbind, pp);
nscalar:
if tp^.tup^.tt <> ntype then
tp := xtrit(tp, pp, false);
narray:
begin
tp^.taindx := xtrenum(tp^.taindx, pp);
tp^.taelem := xtrenum(tp^.taelem, pp);
end;
nrecord:
begin
tp^.tflist := xtrenum(tp^.tflist, pp);
tp^.tvlist := xtrenum(tp^.tvlist, pp);
end;
nvariant:
tp^.tvrnt := xtrenum(tp^.tvrnt, pp);
nfileof:
tp^.tof := xtrenum(tp^.tof, pp);
nptr:
nametype(tp^.tptrid);
nid,
nsubrange,
npredef,
nempty,
nsetof:
(* no op *)
end;(* case *)
tp^.tnext := xtrenum(tp^.tnext, pp)
end;
xtrenum := tp
end;
begin (* extract *)
while tp <> nil do
begin
(* tp points to a program/procedure/function node *)
tp^.tsubtype := xtrenum(tp^.tsubtype, tp);
tp^.tsubvar := xtrenum(tp^.tsubvar, tp);
vp := tp^.tsubvar;
while vp <> nil do
begin
(* variables of structured unnamed types *)
if vp^.tbind^.tt in [nscalar, narray,
nrecord, nfileof] then
vp^.tbind := xtrit(vp^.tbind, tp, true);
vp := vp^.tnext
end;
extract(tp^.tsubsub);
tp := tp^.tnext
end
end; (* extract *)
(* This procedure moves all local constants and types *)
(* used in nested procedures to the outermost declaration *)
(* level so that nested procedures may be extracted. *)
procedure global(tp, dp : treeptr; depend : boolean);
label 555;
var ip : treeptr;
dep : boolean;
(* Mark all declared identifiers as unused. *)
procedure markdecl(xp : treeptr);
begin
while xp <> nil do
begin
case xp^.tt of
nid:
xp^.tsym^.lused := false;
nconst:
markdecl(xp^.tidl);
ntype,
nvar,
nvalpar,
nvarpar,
nfield:
begin
markdecl(xp^.tidl);
if xp^.tbind^.tt <> nid then
markdecl(xp^.tbind)
end;
nscalar:
markdecl(xp^.tscalid);
nrecord:
begin
markdecl(xp^.tflist);
markdecl(xp^.tvlist)
end;
nvariant:
markdecl(xp^.tvrnt);
nconfarr:
if xp^.tcelem^.tt <> nid then
markdecl(xp^.tcelem);
narray:
if xp^.taelem^.tt <> nid then
markdecl(xp^.taelem);
nsetof,
nfileof:
if xp^.tof^.tt <> nid then
markdecl(xp^.tof);
nparproc,
nparfunc:
markdecl(xp^.tparid);
nptr,
nsubrange:
(* no op *)
end;(* case *)
xp := xp^.tnext
end
end; (* markdecl *)
(* Move all marked declarations to global scope. *)
function movedecl(tp : treeptr) : treeptr;
var ip, np : treeptr;
sp : symptr;
move : boolean;
begin
if tp <> nil then
begin
move := false;
case tp^.tt of
nconst,
ntype:
ip := tp^.tidl
end;(* case *)
while ip <> nil do
begin
if ip^.tsym^.lused then
begin
move := true;
sp := ip^.tsym;
if sp^.lid^.inref > 1 then
begin
sp^.lid :=
mkrename( 'M', sp^.lid);
sp^.lid^.inref :=
sp^.lid^.inref - 1
end;
ip := nil
end
else
ip := ip^.tnext
end;
if move then
begin
np := tp^.tnext;
tp^.tnext := nil;
ip := tp;
while ip^.tt <> npgm do
ip := ip^.tup;
tp^.tup := ip;
case tp^.tt of
nconst:
begin
if ip^.tsubconst = nil then
ip^.tsubconst := tp
else begin
ip := ip^.tsubconst;
while ip^.tnext <> nil
do ip := ip^.tnext;
ip^.tnext := tp
end
end;
ntype:
begin
if ip^.tsubtype = nil then
ip^.tsubtype := tp
else begin
ip := ip^.tsubtype;
while ip^.tnext <> nil
do ip := ip^.tnext;
ip^.tnext := tp
end
end
end;(* case *)
(* tp is moved, drop it and process
remainder of declarationlist *)
tp := movedecl(np)
end
else
tp^.tnext := movedecl(tp^.tnext)
end;
movedecl := tp
end; (* movedecl *)
(* This procedure lifts out variables/parameters *)
(* used in nested procedures/functions. *)
procedure movevars(tp, vp : treeptr);
label 555;
var ep, dp, np : treeptr;
ip : idptr;
sp : symptr;
(* Move a variable declaration to global *)
(* var declaration lists. *)
procedure moveglob(tp, dp : treeptr);
begin
while tp^.tt <> npgm do
tp := tp^.tup;
dp^.tup := tp;
dp^.tnext := tp^.tsubvar;
tp^.tsubvar := dp
end;
(* Create nodes for saving a global *)
(* pointer variable. *)
function stackop(decl, glob, loc : treeptr) : treeptr;
var op, ip, dp, tp : treeptr;
begin
(* create a new variable to hold old value
of the global variable during a call *)
ip := newid(mkvariable('F'));
case vp^.tt of
nvarpar,
nvalpar,
nvar:
begin
dp := mknode(nvarpar);
dp^.tattr := areference;
dp^.tidl := ip;
(* use same type as the global var *)
dp^.tbind := decl^.tbind
end;
nparproc,
nparfunc:
begin
dp := mknode(vp^.tt);
dp^.tparid := ip;
dp^.tparparm := nil;
dp^.tpartyp := vp^.tpartyp
end
end;(* case *)
ip^.tup := dp;
(* add variable to declarationlists *)
tp := decl;
while not (tp^.tt in [nproc, nfunc, npgm]) do
tp := tp^.tup;
dp^.tup := tp;
if tp^.tsubvar = nil then
tp^.tsubvar := dp
else begin
tp := tp^.tsubvar;
while tp^.tnext <> nil do
tp := tp^.tnext;
tp^.tnext := dp
end;
dp^.tnext := nil;
(* create an assignment saving value *)
op := mknode(npush);
op^.tglob := glob;
op^.tloc := loc;
op^.ttmp := ip;
stackop := op
end;
(* Take a "push" node, create "pop" node *)
(* and add both to tree. *)
procedure addcode(tp, push : treeptr);
var pop : treeptr;
begin
pop := mknode(npop);
(* share variables with "push"-node *)
pop^.tglob := push^.tglob;
pop^.ttmp := push^.ttmp;
pop^.tloc := nil;
(* add npush to head of statement list *)
push^.tnext := tp^.tsubstmt;
tp^.tsubstmt := push;
push^.tup := tp;
(* add npop to end of statement list *)
while push^.tnext <> nil do
push := push^.tnext;
push^.tnext := pop;
pop^.tup := tp
end;
begin (* movevars *)
while vp <> nil do
begin
case vp^.tt of
nvar,
nvalpar,
nvarpar:
dp := vp^.tidl;
nparproc,
nparfunc:
begin
dp := vp^.tparid;
if dp^.tsym^.lused then
begin
(* create a var declaration *)
ep := mknode(vp^.tt);
ep^.tparparm := nil;
ep^.tpartyp := vp^.tpartyp;
np := newid(mkrename('G',
dp^.tsym^.lid));
ep^.tparid := np;
np^.tup := ep;
(* swap id's and symbols *)
sp := np^.tsym;
ip := sp^.lid;
np^.tsym^.lid := dp^.tsym^.lid;
dp^.tsym^.lid := ip;
np^.tsym := dp^.tsym;
dp^.tsym := sp;
np^.tsym^.lsymdecl := np;
dp^.tsym^.lsymdecl := dp;
(* make declaration global *)
moveglob(tp, ep);
(* add save/restore-code *)
addcode(tp, stackop(vp, np, dp))
end;
goto 555
end
end;(* case *)
while dp <> nil do
begin
if dp^.tsym^.lused then
begin
(* create a varpar declaration,
(nvarpar will cause emit to
treat the new identifier
as a pointer) *)
ep := mknode(nvarpar);
ep^.tattr := areference;
np := newid(mkrename('G',
dp^.tsym^.lid));
ep^.tidl := np;
np^.tup := ep;
ep^.tbind := vp^.tbind;
if ep^.tbind^.tt = nid then
ep^.tbind^.tsym^.lused
:= true;
(* swap id's and symbols *)
sp := np^.tsym;
ip := sp^.lid;
np^.tsym^.lid := dp^.tsym^.lid;
dp^.tsym^.lid := ip;
np^.tsym := dp^.tsym;
dp^.tsym := sp;
np^.tsym^.lsymdecl := np;
dp^.tsym^.lsymdecl := dp;
(* note that dp is referenced *)
dp^.tup^.tattr := aextern;
(* make declaration global *)
moveglob(tp, ep);
(* add save/restore-code *)
addcode(tp, stackop(vp, np, dp))
end;
dp := dp^.tnext
end;
555:
vp := vp^.tnext
end
end; (* movevars *)
(* Break out a local variable and set the register *)
(* attribute. *)
procedure registervar(tp : treeptr);
var vp, xp : treeptr;
begin
vp := idup(tp);
tp := tp^.tsym^.lsymdecl;
(* vp points to nvar node *)
if (vp^.tidl <> tp) or (tp^.tnext <> nil) then
begin
(* tp is not alone in list of identifiers,
create a new nvar-node and hook up tp *)
xp := mknode(nvar);
xp^.tattr := anone;
xp^.tidl := tp;
tp^.tup := xp;
(* enter new nvar node among declarations *)
xp^.tup := vp^.tup;
xp^.tbind := vp^.tbind; (* borrow type *)
xp^.tnext := vp^.tnext;
vp^.tnext := xp;
(* break tp out of list of identifiers *)
if vp^.tidl = tp then
vp^.tidl := tp^.tnext
else begin
vp := vp^.tidl;
while vp^.tnext <> tp do
vp := vp^.tnext;
vp^.tnext := tp^.tnext
end;
tp^.tnext := nil
end;
(* tp is alone in this declaration, set attribute *)
if tp^.tup^.tattr = anone then
tp^.tup^.tattr := aregister
end; (* registervar *)
(* Check static declarationlevel for a label *)
(* used in a non-local goto. *)
procedure cklevel(tp : treeptr);
begin
tp := tp^.tsym^.lsymdecl;
while not(tp^.tt in [npgm, nproc, nfunc]) do
tp := tp^.tup;
if tp^.tstat > maxlevel then
maxlevel := tp^.tstat
end;
begin (* global *)
while tp <> nil do
begin
case tp^.tt of
nproc,
nfunc:
begin
(* procid/parameters/const/type/var not used *)
markdecl(tp^.tsubid);
markdecl(tp^.tsubpar);
markdecl(tp^.tsubconst);
markdecl(tp^.tsubtype);
markdecl(tp^.tsubvar);
(* mark those used in nested subroutines *)
global(tp^.tsubsub, tp, false);
(* move out variables used in inner scope *)
movevars(tp, tp^.tsubpar);
movevars(tp, tp^.tsubvar);
(* move out const/type used in inner scope *)
tp^.tsubtype := movedecl(tp^.tsubtype);
tp^.tsubconst := movedecl(tp^.tsubconst);
(* mark identifiers used in this subroutine *)
global(tp^.tsubstmt, tp, true);
global(tp^.tsubpar, tp, false);
global(tp^.tsubvar, tp, false);
global(tp^.tsubtype, tp, false);
global(tp^.tfuntyp, tp, false);
end;
npgm:
begin
markdecl(tp^.tsubconst);
markdecl(tp^.tsubtype);
markdecl(tp^.tsubvar);
global(tp^.tsubsub, tp, false);
global(tp^.tsubstmt, tp, true)
end;
nconst,
ntype,
nvar,
nfield,
nvalpar,
nvarpar:
begin
ip := tp^.tidl;
dep := depend;
while (ip <> nil) and not dep do
begin
(* for all used identifiers, propagate
the use to their bindings *)
if ip^.tsym^.lused then
dep := true;
ip := ip^.tnext
end;
global(tp^.tbind, dp, dep);
end;
nparproc,
nparfunc:
begin
global(tp^.tparparm, dp, depend);
global(tp^.tpartyp, dp, depend)
end;
nsubrange:
begin
global(tp^.tlo, dp, depend);
global(tp^.thi, dp, depend)
end;
nvariant:
begin
global(tp^.tselct, dp, depend);
global(tp^.tvrnt, dp, depend)
end;
nrecord:
begin
global(tp^.tflist, dp, depend);
global(tp^.tvlist, dp, depend)
end;
nconfarr:
begin
global(tp^.tcindx, dp, depend);
global(tp^.tcelem, dp, depend)
end;
narray:
begin
global(tp^.taindx, dp, depend);
global(tp^.taelem, dp, depend)
end;
nfileof,
nsetof:
global(tp^.tof, dp, depend);
nptr:
global(tp^.tptrid, dp, depend);
nscalar:
global(tp^.tscalid, dp, depend);
nbegin:
global(tp^.tbegin, dp, depend);
nif:
begin
global(tp^.tifxp, dp, depend);
global(tp^.tthen, dp, depend);
global(tp^.telse, dp, depend)
end;
nwhile:
begin
global(tp^.twhixp, dp, depend);
global(tp^.twhistmt, dp, depend)
end;
nrepeat:
begin
global(tp^.treptstmt, dp, depend);
global(tp^.treptxp, dp, depend)
end;
nfor:
begin
ip := idup(tp^.tforid);
if ip^.tup^.tt in [nproc, nfunc] then
registervar(tp^.tforid);
global(tp^.tforid, dp, depend);
global(tp^.tfrom, dp, depend);
global(tp^.tto, dp, depend);
global(tp^.tforstmt, dp, depend)
end;
ncase:
begin
global(tp^.tcasxp, dp, depend);
global(tp^.tcaslst, dp, depend);
global(tp^.tcasother, dp, depend)
end;
nchoise:
begin
global(tp^.tchocon, dp, depend);
global(tp^.tchostmt, dp, depend);
end;
nwith:
begin
global(tp^.twithvar, dp, depend);
global(tp^.twithstmt, dp, depend)
end;
nwithvar:
begin
ip := typeof(tp^.texpw);
if ip^.tuid = nil then
ip^.tuid := mkvariable('S');
global(tp^.texpw, dp, depend);
end;
nlabstmt:
global(tp^.tstmt, dp, depend);
neq, nne, nlt, nle, ngt, nge:
begin
global(tp^.texpl, dp, depend);
global(tp^.texpr, dp, depend);
ip := typeof(tp^.texpl);
if (ip = typnods[tstring]) or
(ip^.tt = narray) then
usecomp := true;
ip := typeof(tp^.texpr);
if (ip = typnods[tstring]) or
(ip^.tt = narray) then
usecomp := true
end;
nin, nor, nplus, nminus,
nand, nmul, ndiv, nmod, nquot,
nformat, nrange:
begin
global(tp^.texpl, dp, depend);
global(tp^.texpr, dp, depend)
end;
nassign:
begin
global(tp^.tlhs, dp, depend);
global(tp^.trhs, dp, depend)
end;
nnot,
numinus,
nuplus,
nderef:
global(tp^.texps, dp, depend);
nset:
global(tp^.texps, dp, depend);
nindex:
begin
global(tp^.tvariable, dp, depend);
global(tp^.toffset, dp, depend)
end;
nselect:
global(tp^.trecord, dp, depend);
ncall:
begin
global(tp^.tcall, dp, depend);
global(tp^.taparm, dp, depend)
end;
nid:
begin
(* find declaration point *)
ip := idup(tp);
if ip = nil then
goto 555;
(* ip points to nconst/ntype/nvar/nproc/nfunc/
nvalpar/nvarpar/nparproc or nparfunc node,
move to beginning of enclosing scope *)
repeat
ip := ip^.tup;
if ip = nil then
goto 555
(* stop only for locally declared items,
for global or predefined identifiers
we will have gone to label 555 *)
until ip^.tt in [npgm, nproc, nfunc];
if dp = ip then
begin
(* identifier used here, mark it used *)
if depend then
tp^.tsym^.lused := true
end
else begin
(* identifier declared in enclosing
scope, mark it used *)
tp^.tsym^.lused := true
end;
555:
end;
ngoto:
if not islocal(tp^.tlabel) then
begin
tp^.tlabel^.tsym^.lgo := true;
usejmps := true;
cklevel(tp^.tlabel)
end;
nbreak,
npush,
npop,
npredef,
nempty,
nchar,
ninteger,
nreal,
nstring,
nnil:
end;(* case *)
tp := tp^.tnext
end
end; (* global *)
(* Rename identifiers identical to C keywords. *)
procedure renamc;
var ip : idptr;
cn : cnames;
begin
(* rename identifiers that mustn't be redefined
if C and Pascal semantix are to be preserved *)
for cn := cabort to cwrite do
begin
ip := mkrename('C', ctable[cn]);
ctable[cn]^.istr := ip^.istr
end
end;
(* Rename subroutines declared in other subroutines such *)
(* that they can be moved to a global scope without name- *)
(* clashes. *)
procedure renamp(tp : treeptr; on : boolean);
var sp : symptr;
begin
(* tp points to subroutine-list *)
while tp <> nil do
begin
renamp(tp^.tsubsub, true);
if on and (tp^.tsubstmt <> nil) then
begin
(* change name of subroutine by prefixing
a unique name *)
sp := tp^.tsubid^.tsym;
if sp^.lid^.inref > 1 then
begin
sp^.lid := mkrename('P', sp^.lid);
sp^.lid^.inref := sp^.lid^.inref - 1
end
end;
tp := tp^.tnext
end
end;
(* Add initialization-code for file-variables. *)
procedure initcode(tp : treeptr);
var ti, tq, tu, tv : treeptr;
(* Determine if a type contains a file. *)
function filevar(tp : treeptr) : boolean;
var fv : boolean;
tq : treeptr;
begin
case tp^.tt of
npredef:
fv := tp = typnods[ttext];
nfileof:
fv := true;
nconfarr:
fv := filevar(typeof(tp^.tcelem));
narray:
fv := filevar(typeof(tp^.taelem));
nrecord:
begin
fv := false;
tq := tp^.tvlist;
while tq <> nil do
begin
if filevar(tq^.tvrnt) then
error(evrntfile);
tq := tq^.tnext
end;
tq := tp^.tflist;
while tq <> nil do
begin
if filevar(typeof(tq^.tbind)) then
begin
fv := true;
tq := nil
end
else
tq := tq^.tnext
end
end;
nptr:
begin
fv := false;
if not tp^.tptrflag then
begin
tp^.tptrflag := true;
if filevar(typeof(tp^.tptrid)) then
error(evarfile);
tp^.tptrflag := false
end
end;
nsubrange,
nscalar,
nsetof:
fv := false
end;
filevar := fv
end;
(* Create code for initialization of files. *)
function fileinit(ti, tq : treeptr; opn : boolean) : treeptr;
var tx, ty, tz : treeptr;
begin
(* create 1 statement initializing "ti" *)
case tq^.tt of
narray:
begin
(* create declaration for a loopvariable *)
tz := newid(mkvariable('I'));
ty := mknode(nvar);
ty^.tattr := aregister;
ty^.tidl := tz;
ty^.tbind := typeof(tq^.taindx);
tz := tq;
while not(tz^.tt in [nproc, nfunc, npgm]) do
tz := tz^.tup;
linkup(tz, ty);
if tz^.tsubvar = nil then
tz^.tsubvar := ty
else begin
tz := tz^.tsubvar;
while tz^.tnext <> nil do
tz := tz^.tnext;
tz^.tnext := ty
end;
ty := ty^.tidl;
(* create a loop initializing tq *)
tz := mknode(nindex);
tz^.tvariable := ti;
tz^.toffset := ty;
tz := fileinit(tz, tq^.taelem, opn);
tx := mknode(nfor);
tx^.tforid := ty;
ty := typeof(tq^.taindx);
if ty^.tt = nsubrange then
begin
tx^.tfrom := ty^.tlo;
tx^.tto := ty^.thi
end
else if ty^.tt = nscalar then
begin
ty := ty^.tscalid;
tx^.tfrom := ty;
while ty^.tnext <> nil do
ty := ty^.tnext;
tx^.tto := ty
end
else if ty = typnods[tchar] then
begin
currsym.st := schar;
currsym.vchr := chr(minchar);
tx^.tfrom := mklit;
currsym.st := schar;
currsym.vchr := chr(maxchar);
tx^.tto := mklit
end
else if ty = typnods[tinteger] then
begin
currsym.st := sinteger;
currsym.vint := -maxint;
tx^.tfrom := mklit;
currsym.st := sinteger;
currsym.vint := maxint;
tx^.tto := mklit
end
else
fatal(etree);
tx^.tforstmt := tz;
tx^.tincr := true
end;
npredef,
nfileof:
if opn then
begin
(* create file-struct initialization *)
ty := mknode(nselect);
ty^.trecord := ti;
ty^.tfield :=
oldid(defnams[dzinit]^.lid,
lforward);
tx := mknode(nassign);
tx^.tlhs := ty;
currsym.st := sinteger;
currsym.vint := 0;
tx^.trhs := mklit
end
else begin
(* create file-struct wrapup *)
tx := mknode(ncall);
tx^.tcall :=
oldid(defnams[dclose]^.lid,
lidentifier);
tx^.taparm := ti
end;
nrecord:
begin
ty := nil;
tq := tq^.tflist;
while tq <> nil do
begin
if filevar(typeof(tq^.tbind)) then
begin
tz := tq^.tidl;
while tz <> nil do
begin
tx := mknode(nselect);
tx^.trecord := ti;
tx^.tfield := tz;
tx := fileinit(tx,
typeof(tq^.tbind),
opn);
tx^.tnext := ty;
ty := tx;
tz := tz^.tnext
end
end;
tq := tq^.tnext
end;
tx := mknode(nbegin);
tx^.tbegin := ty
end;
end;(* case *)
fileinit := tx
end;
begin (* initcode *)
while tp <> nil do
begin
initcode(tp^.tsubsub);
tv := tp^.tsubvar;
while tv <> nil do
begin
tq := typeof(tv^.tbind);
if filevar(tq) then
begin
ti := tv^.tidl;
while ti <> nil do
begin
tu := fileinit(ti, tq, true);
linkup(tp, tu);
tu^.tnext := tp^.tsubstmt;
tp^.tsubstmt := tu;
while tu^.tnext <> nil do
tu := tu^.tnext;
tu^.tnext := fileinit(ti, tq,
false);
linkup(tp, tu^.tnext);
ti := ti^.tnext
end
end;
tv := tv^.tnext;
end;
tp := tp^.tnext
end
end; (* initcode *)
begin (* transform *)
renamc;
renamp(top^.tsubsub, false);
extract(top);
renamf(top);
initcode(top^.tsubsub);
global(top, top, false)
end; (* transform *)
(* Emit C-code for program or module. *)
procedure emit;
const include = '# include ';
define = '# define ';
ifdef = '# ifdef ';
ifndef = '# ifndef ';
elsif = '# else';
endif = '# endif';
static = 'static ';
xtern = 'extern ';
typdef = 'typedef ';
registr = 'register ';
usigned = 'unsigned ';
indstep = 8;
var conflag,
setused,
dropset,
donearr : boolean;
doarrow,
indnt : integer;
procedure increment;
begin
indnt := indnt + indstep
end;
procedure decrement;
begin
indnt := indnt - indstep
end;
(* Write tabs/blanks to properly (?) indent C-code. *)
procedure indent;
var i : integer;
begin
i := indnt;
(* limit indent to an integral number of tabs *)
if i > 60 then
i := i div tabwidth * tabwidth;
while i >= tabwidth do
begin
write(tab1);
i := i - tabwidth
end;
while i > 0 do
begin
write(space);
i := i - 1
end;
end;
(* Determine if tp must be cast to an integer before being *)
(* used in an arithmetic expression. *)
function arithexpr(tp : treeptr) : boolean;
begin
tp := typeof(tp);
if tp^.tt = nsubrange then
if tp^.tup^.tt = nconfarr then
tp := typeof(tp^.tup^.tindtyp)
else
tp := typeof(tp^.tlo);
arithexpr := (tp = typnods[tinteger]) or
(tp = typnods[tchar]) or
(tp = typnods[treal])
end;
procedure eexpr(tp : treeptr); forward;
procedure etypedef(tp : treeptr); forward;
(* Emit code to select a record member. *)
procedure eselect(tp : treeptr);
begin
doarrow := doarrow + 1;
eexpr(tp);
doarrow := doarrow - 1;
if donearr then
donearr := false
else
write('.')
end;
(* Emit code for call to a predefined function/procedure. *)
procedure epredef(ts, tp : treeptr);
label 444, 555;
var tq,
tv, tx : treeptr;
td : predefs;
nelems : integer;
ch : char;
txtfile : boolean;
(* Determine a format-code for fprintf. *)
(* Update nelems as a sideeffect. *)
function typeletter(tp : treeptr) : char;
label 999;
var tq : treeptr;
begin
tq := tp;
if tq^.tt = nformat then
begin
if tq^.texpl^.tt = nformat then
begin
typeletter := 'f';
goto 999
end;
tq := tp^.texpl
end;
tq := typeof(tq);
if tq^.tt = nsubrange then
tq := typeof(tq^.tlo);
if tq = typnods[tstring] then
typeletter := 's'
else if tq = typnods[tinteger] then
typeletter := 'd'
else if tq = typnods[tchar] then
typeletter := 'c'
else if tq = typnods[treal] then
if tp^.tt = nformat then
typeletter := 'e'
else
typeletter := 'g'
else if tq = typnods[tboolean] then
begin
typeletter := 'b';
nelems := 6
end
else if tq^.tt = narray then
begin
typeletter := 'a';
nelems := crange(tq^.taindx)
end
else if tq^.tt = nconfarr then
begin
typeletter := 'v';
nelems := 0
end
else
fatal(etree);
999:
end; (* typeletter *)
procedure etxt(tp : treeptr);
var w : toknbuf;
c : char;
i : toknidx;
begin
case tp^.tt of
nid:
begin
tp := idup(tp);
if tp^.tt = nconst then
etxt(tp^.tbind)
else
fatal(etree)
end;
nstring:
begin
(* printf format string *)
gettokn(tp^.tsym^.lstr, w);
i := 1;
while w[i] <> chr(null) do
begin
c := w[i];
if (c = cite) or (c = bslash) then
write(bslash)
else if c = percent then
write(percent);
write(c);
i := i + 1
end
end;
nchar:
begin
(* single character in printf format *)
c := tp^.tsym^.lchar;
if (c = cite) or (c = bslash) then
write(bslash)
else if c = percent then
write(percent);
write(c)
end;
end;(* case *)
end; (* etxt *)
(* Emit format for fprintf. *)
procedure eformat(tq : treeptr);
var tx : treeptr;
i : integer;
begin
case typeletter(tq) of
'a':
begin
write(percent);
if tq^.tt = nformat then
if tq^.texpr^.tt = ninteger then
eexpr(tq^.texpr)
else
write('*');
write('.', nelems:1, 's')
end;
'b':
begin
write(percent);
if tq^.tt = nformat then
begin
if tq^.texpr^.tt = ninteger then
eexpr(tq^.texpr)
else
write('*')
end;
write('s')
end;
'c':
if tq^.tt = nchar then
etxt(tq)
else begin
write(percent);
if tq^.tt = nformat then
if tq^.texpr^.tt = ninteger then
eexpr(tq^.texpr)
else
write('*');
write('c')
end;
'd':
begin
write(percent);
if tq^.tt = nformat then
begin
if tq^.texpr^.tt = ninteger then
eexpr(tq^.texpr)
else
write('*')
end
else
write(intlen:1);
write('d')
end;
'e':
begin
write(percent, space);
tx := tq^.texpr;
if tx^.tt = ninteger then
begin
i := cvalof(tx);
write(i:1, '.');
i := i - 7;
if i < 1 then
write('1')
else
write(i:1)
end
else
write('*.*');
write('e')
end;
'f':
begin
write(percent);
tx := tq^.texpl;
if tx^.texpr^.tt = ninteger then
begin
eexpr(tx^.texpr);
write('.');
tx := tq^.texpr;
if tx^.tt = ninteger then
begin
i := cvalof(tx);
tx := tq^.texpl^.texpr;
if i > cvalof(tx) - 1 then
write('1')
else
write(i:1)
end
else
write('*');
end
else
write('*.*');
write('f')
end;
'g':
write(percent, fixlen:1, 'e');
's':
if tq^.tt = nstring then
etxt(tq)
else begin
write(percent);
if tq^.tt = nformat then
if tq^.texpr^.tt = ninteger then
eexpr(tq^.texpr)
else
write('*.*');
write('s')
end
end (* case *)
end; (* eformat *)
(* Emit parameters to fprintf except format. *)
procedure ewrite(tq : treeptr);
var tx : treeptr;
begin
case typeletter(tq) of
'a':
begin
write(', ');
tx := tq;
if tq^.tt = nformat then
begin
if tq^.texpr^.tt <> ninteger then
begin
eexpr(tq^.texpr);
write(', ')
end;
tx := tq^.texpl
end;
eexpr(tx);
write('.A')
end;
'b':
begin
write(', ');
tx := tq;
if tq^.tt = nformat then
begin
if tq^.texpr^.tt <> ninteger then
begin
eexpr(tq^.texpr);
write(', ')
end;
tx := tq^.texpl
end;
usebool := true;
write('Bools[(int)(');
eexpr(tx);
write(')]')
end;
'c':
begin
if tq^.tt = nformat then
begin
if tq^.texpr^.tt <> ninteger then
begin
write(', ');
eexpr(tq^.texpr)
end;
write(', ');
eexpr(tq^.texpl)
end
else if tq^.tt <> nchar then
begin
write(', ');
eexpr(tq)
end
end;
'd':
begin
write(', ');
tx := tq;
if tq^.tt = nformat then
begin
if tq^.texpr^.tt <> ninteger then
begin
eexpr(tq^.texpr);
write(', ')
end;
tx := tq^.texpl
end;
eexpr(tx)
end;
'e':
begin
write(', ');
tx := tq^.texpr;
if tx^.tt <> ninteger then
begin
usemax := true;
eexpr(tx);
write(', Max(');
eexpr(tx);
write(' - 7, 1), ')
end;
eexpr(tq^.texpl)
end;
'f':
begin
write(', ');
tx := tq^.texpl;
if tx^.texpr^.tt <> ninteger then
begin
eexpr(tx^.texpr);
write(', ')
end;
if (tx^.texpr^.tt <> ninteger) or
(tq^.texpr^.tt <> ninteger) then
begin
usemax := true;
write('Max((');
eexpr(tx^.texpr);
write(') - (');
eexpr(tq^.texpr);
write(') - 1, 1), ')
end;
eexpr(tq^.texpl^.texpl)
end;
'g':
begin
write(', ');
eexpr(tq)
end;
's':
begin
if tq^.tt = nformat then
begin
if tq^.texpr^.tt <> ninteger then
begin
write(', ');
eexpr(tq^.texpr);
write(', ');
eexpr(tq^.texpr)
end;
write(', ');
eexpr(tq^.texpl)
end
else if tq^.tt <> nstring then
begin
write(', ');
eexpr(tq)
end
end
end (* case *)
end; (* ewrite *)
(* Emit size of *tp for call to malloc. CPU *)
(* There is no safe way to compute the size of a *)
(* particular variant of a C-union, we assume that *)
(* the size can be computed by taking the address *)
(* of the first member and subracting the address *)
(* of the record and then adding the size of the *)
(* variant containing the record. *)
procedure enewsize(tp : treeptr);
label 555;
var tq, tx, ty : treeptr;
v : integer;
(* Emit size of union member tq. *)
procedure esubsize(tp, tq : treeptr);
label 555, 666;
var tx, ty : treeptr;
addsize : boolean;
begin
tx := tq^.tvrnt;
ty := tx^.tflist;
if ty = nil then
begin
ty := tx^.tvlist;
while ty <> nil do
begin
if ty^.tvrnt^.tflist <> nil then
begin
ty := ty^.tvrnt^.tflist;
goto 555
end;
ty := ty^.tnext
end;
555:
end;
addsize := true;
if ty = nil then
begin
(* empty variant, try using another *)
addsize := false;
ty := tx^.tup^.tup^.tvlist;
while ty <> nil do
begin
if ty^.tvrnt^.tflist <> nil then
begin
ty := ty^.tvrnt^.tflist;
goto 666
end;
ty := ty^.tnext
end;
666:
end;
if ty = nil then
begin
(* its getting too complicated,
ignore tag value *)
write('sizeof(*');
eexpr(tp);
write(')')
end
else begin
(* compute offset to first member of
the selected union variant *)
write('Unionoffs(');
eexpr(tp);
write(', ');
printid(ty^.tidl^.tsym^.lid);
if addsize then
begin
(* add the size of the selected
union variant *)
write(') + sizeof(');
eexpr(tp);
write('->');
printid(tx^.tuid)
end;
write(')')
end
end;
begin (* newsize *)
if (tp^.tnext <> nil) and unionnew then
begin
(* tnext points to a tag-value, evaluate it *)
v := cvalof(tp^.tnext);
(* find union type *)
tq := typeof(tp);
tq := typeof(tq^.tptrid);
if tq^.tt <> nrecord then
fatal(etree);
(* find corresponding variant *)
tx := tq^.tvlist;
while tx <> nil do
begin
ty := tx^.tselct;
while ty <> nil do
begin
if v = cvalof(ty) then
goto 555;
ty := ty^.tnext
end;
tx := tx^.tnext
end;
fatal(etag);
555:
(* emit size for that variant *)
esubsize(tp, tx)
end
else begin
write('sizeof(*');
eexpr(tp);
write(')')
end
end; (* newsize *)
begin (* epredef *)
td := ts^.tsubstmt^.tdef;
case td of
dabs:
begin
tq := typeof(tp^.taparm);
if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
write('abs(') (* LIB *)
else
write('fabs('); (* LIB *)
eexpr(tp^.taparm);
write(')')
end;
dargv:
begin
write('Argvgt(');
eexpr(tp^.taparm);
write(', ');
eexpr(tp^.taparm^.tnext);
write('.A, sizeof(');
eexpr(tp^.taparm^.tnext);
writeln('.A));')
end;
dchr:
begin
tq := typeof(tp^.taparm);
if tq^.tt = nsubrange then
if tq^.tup^.tt = nconfarr then
tq := typeof(tq^.tup^.tindtyp)
else
tq := typeof(tq^.tlo);
if (tq = typnods[tinteger]) or
(tq = typnods[tchar]) then
eexpr(tp^.taparm)
else begin
write('(char)(');
eexpr(tp^.taparm);
write(')')
end
end;
ddispose:
begin
write('free('); (* LIB *)
eexpr(tp^.taparm);
writeln(');')
end;
deof:
begin
write('Eof(');
if tp^.taparm = nil then
begin
defnams[dinput]^.lused := true;
printid(defnams[dinput]^.lid)
end
else
eexpr(tp^.taparm);
write(')')
end;
deoln:
begin
write('Eoln(');
if tp^.taparm = nil then
begin
defnams[dinput]^.lused := true;
printid(defnams[dinput]^.lid)
end
else
eexpr(tp^.taparm);
write(')');
end;
dexit:
begin
write('exit('); (* OS *)
if tp^.taparm = nil then
write('0')
else
eexpr(tp^.taparm);
writeln(');');
end;
dflush:
begin
write('fflush('); (* LIB *)
if tp^.taparm = nil then
begin
defnams[doutput]^.lused := true;
printid(defnams[doutput]^.lid)
end
else
eexpr(tp^.taparm);
writeln('.fp);')
end;
dpage:
begin
(* write form-feed character *)
write('Putchr(', ffchr, ', '); (* CHAR *)
if tp^.taparm = nil then
begin
defnams[doutput]^.lused := true;
printid(defnams[doutput]^.lid)
end
else
eexpr(tp^.taparm);
writeln(');');
end;
dput,
dget:
begin
if typeof(tp^.taparm) = typnods[ttext] then
if td = dget then
write('Getx')
else
write('Putx')
else begin
write(voidcast);
if td = dget then
write('Get')
else
write('Put')
end;
write('(');
eexpr(tp^.taparm);
writeln(');')
end;
dhalt:
writeln('abort();'); (* OS *)
dnew:
begin
eexpr(tp^.taparm);
write(' = (');
etypedef(typeof(tp^.taparm));
write(')malloc((unsigned)('); (* LIB *)
enewsize(tp^.taparm);
writeln('));')
end;
dord:
begin
write('(unsigned)(');
eexpr(tp^.taparm);
write(')')
end;
dread,
dreadln:
begin
txtfile := false;
tq := tp^.taparm;
if tq <> nil then
begin
tv := typeof(tq);
if tv = typnods[ttext] then
begin
(* reading from textfile *)
txtfile := true;
tv := tq;
tq := tq^.tnext
end
else if tv^.tt = nfileof then
begin
(* reading from other file *)
txtfile := typeof(tv^.tof) =
typnods[tchar];
tv := tq;
tq := tq^.tnext
end
else begin
(* reading from std-input *)
txtfile := true;
tv := nil
end
end
else begin
tv := nil;
txtfile := true
end;
if txtfile then
begin
(* check for special case *)
if tq = nil then
goto 444;
if (tq^.tt <> nformat) and
(tq^.tnext = nil) and
(typeletter(tq) = 'c') then
begin
(* read single char *)
eexpr(tq);
write(' = ');
write('Getchr(');
if tv = nil then
printid(defnams[dinput]^.lid)
else
eexpr(tv);
write(')');
if td = dreadln then
write(',');
goto 444
end;
usescan := true;
write('Fscan(');
if tv = nil then
printid(defnams[dinput]^.lid)
else
eexpr(tv);
write('), ');
(* first pass, emit format string *)
while tq <> nil do
begin
write('Scan(', cite);
ch := typeletter(tq);
case ch of
'a':
write(percent, 's');
'c':
write(percent, 'c');
'd':
write(percent, 'ld');
'g':
write(percent, 'le')
end;(* case *)
write(cite, ', ');
case ch of
'a':
begin
eexpr(tq);
write('.A')
end;
'c':
begin
write('&');
eexpr(tq)
end;
'd':
write('&Tmplng');
'g':
write('&Tmpdbl')
end;(* case *)
write(')');
case ch of
'd':
begin
write(', ');
eexpr(tq);
write(' = Tmplng')
end;
'g':
begin
write(', ');
eexpr(tq);
write(' = Tmpdbl')
end;
'a',
'c':
(* no op *)
end;(* case *)
tq := tq^.tnext;
if tq <> nil then
begin
writeln(',');
indent;
write(tab1)
end
end;
write(', Getx(');
if tv = nil then
printid(defnams[dinput]^.lid)
else
eexpr(tv);
write(')');
if td = dreadln then
write(',');
444:
if td = dreadln then
begin
usegetl := true;
write('Getl(&');
if tv = nil then
printid(defnams[dinput]^.lid)
else
eexpr(tv);
write(')')
end
end
else begin
increment;
while tq <> nil do
begin
write(voidcast, 'Fread(');
eexpr(tq);
write(', ');
eexpr(tv);
write('.fp)');
tq := tq^.tnext;
if tq <> nil then
begin
writeln(',');
indent
end
end;
decrement
end;
writeln(';')
end;
dwrite,
dwriteln,
dmessage:
begin
txtfile := false;
tq := tp^.taparm;
if tq <> nil then
begin
tv := typeof(tq);
if tv = typnods[ttext] then
begin
(* writing to textfile *)
txtfile := true;
tv := tq;
tq := tq^.tnext
end
else if tv^.tt = nfileof then
begin
(* writing to other file *)
txtfile := typeof(tv^.tof) =
typnods[tchar];
tv := tq;
tq := tq^.tnext
end
else begin
(* writing to std-output *)
txtfile := true;
tv := nil
end
end
else begin
tv := nil;
txtfile := true
end;
if txtfile then
begin
(* check for special case *)
if tq = nil then
begin
(* writeln whithout parameters *)
if td in [dwriteln, dmessage] then
begin
write('Putchr(', nlchr, ', ');
if tv = nil then
printid(
defnams[doutput]^.lid)
else
eexpr(tv);
write(')')
end;
writeln(';');
goto 555
end
else if (tq^.tt <> nformat) and
(tq^.tnext = nil) then
if typeletter(tq) = 'c' then
begin
(* print single char *)
write('Putchr(');
eexpr(tq);
write(', ');
if tv = nil then
printid(
defnams[doutput]^.lid)
else
eexpr(tv);
write(')');
if td = dwriteln then
begin
write(',Putchr(',
nlchr, ', ');
if tv = nil then
printid(
defnams[doutput]^.lid)
else
eexpr(tv);
write(')');
end;
writeln(';');
goto 555
end;
tx := nil;
write(voidcast, 'fprintf('); (* LIB *)
if td = dmessage then
write('stderr, ')
else begin
if tv = nil then
printid(defnams[doutput]^.lid)
else
eexpr(tv);
write('.fp, ')
end;
write(cite);
tx := tq; (* remember 1:st parm *)
(* first pass, emit format string *)
while tq <> nil do
begin
eformat(tq);
tq := tq^.tnext
end;
if (td = dmessage) or (td = dwriteln) then
write('\n');
write(cite);
(* second pass, add parameters *)
tq := tx;
while tq <> nil do
begin
ewrite(tq);
tq := tq^.tnext
end;
write('), Putl(');
if tv = nil then
printid(defnams[doutput]^.lid)
else
eexpr(tv);
if td = dwrite then
write(', 0)')
else
write(', 1)')
end
else begin
increment;
tx := typeof(tv);
if tx = typnods[ttext] then
tx := typnods[tchar]
else if tx^.tt = nfileof then
tx := typeof(tx^.tof)
else
fatal(etree);
while tq <> nil do
begin
if (tq^.tt in [nid, nindex, nselect,
nderef]) and
(tx = typeof(tq)) then
begin
write(voidcast, 'Fwrite(');
eexpr(tq)
end
else begin
if tx^.tt = nsetof then
begin
usescpy := true;
write('Setncpy(');
eselect(tv);
write('buf.S, ');
eexpr(tq);
if typeof(tp^.trhs) =
typnods[tset] then
eexpr(tq)
else begin
eselect(tq);
write('S')
end;
write(', sizeof(');
eexpr(tv);
write('.buf))');
end
else begin
eexpr(tv);
write('.buf = ');
eexpr(tq)
end;
write(', Fwrite(');
eexpr(tv);
write('.buf');
end;
write(', ');
eexpr(tv);
write('.fp)');
tq := tq^.tnext;
if tq <> nil then
begin
writeln(',');
indent
end
end;
decrement
end;
writeln(';');
555:
end;
dclose:
begin
tq := typeof(tp^.taparm);
txtfile := tq = typnods[ttext];
if (not txtfile) and (tq^.tt = nfileof) then
if typeof(tq^.tof) = typnods[tchar] then
txtfile := true;
if txtfile then
write('Closex(')
else
write('Close(');
eexpr(tp^.taparm);
writeln(');');
end;
dreset,
drewrite:
begin
tq := typeof(tp^.taparm);
txtfile := tq = typnods[ttext];
if (not txtfile) and (tq^.tt = nfileof) then
if typeof(tq^.tof) = typnods[tchar] then
txtfile := true;
if txtfile then
if td = dreset then
write('Resetx(')
else
write('Rewritex(')
else
if td = dreset then
write('Reset(')
else
write('Rewrite(');
eexpr(tp^.taparm);
write(', ');
tq := tp^.taparm^.tnext;
if tq = nil then
write('NULL')
else begin
tq := typeof(tq);
if tq = typnods[tchar] then
begin
write(cite);
ch := chr(cvalof(tp^.taparm^.tnext));
if (ch = bslash) or (ch = cite) then
write(bslash);
write(ch, cite)
end
else if tq = typnods[tstring] then
eexpr(tp^.taparm^.tnext)
else if tq^.tt in [narray, nconfarr] then
begin
eexpr(tp^.taparm^.tnext);
write('.A')
end
else
fatal(etree)
end;
writeln(');')
end;
darctan:
begin
write('atan('); (* LIB *)
if typeof(tp^.taparm) <> typnods[treal] then
write(dblcast);
eexpr(tp^.taparm);
write(')')
end;
dln:
begin
write('log('); (* LIB *)
if typeof(tp^.taparm) <> typnods[treal] then
write(dblcast);
eexpr(tp^.taparm);
write(')')
end;
dexp:
begin
write('exp('); (* LIB *)
if typeof(tp^.taparm) <> typnods[treal] then
write(dblcast);
eexpr(tp^.taparm);
write(')')
end;
dcos,
dsin,
dsqrt:
begin
eexpr(tp^.tcall); (* LIB *)
write('(');
if typeof(tp^.taparm) <> typnods[treal] then
write(dblcast);
eexpr(tp^.taparm);
write(')')
end;
dtan:
begin
write('atan('); (* LIB *)
if typeof(tp^.taparm) <> typnods[treal] then
write(dblcast);
eexpr(tp^.taparm);
write(')')
end;
dsucc,
dpred:
begin
tq := typeof(tp^.taparm);
if tq^.tt = nsubrange then
if tq^.tup^.tt = nconfarr then
tq := typeof(tq^.tup^.tindtyp)
else
tq := typeof(tq^.tlo);
if (tq = typnods[tinteger]) or
(tq = typnods[tchar]) then
begin
write('((');
eexpr(tp^.taparm);
if td = dpred then
write(')-1)')
else
write(')+1)')
end
else begin
(* some sort of scalar type, casting needed *)
write('(');
tq := tq^.tup;
if tq^.tt = ntype then
begin
(* cast only if it is a named type *)
write('(');
printid(tq^.tidl^.tsym^.lid);
write(')')
end;
write('((int)(');
eexpr(tp^.taparm);
if td = dpred then
write(')-1))')
else
write(')+1))')
end
end;
dodd:
begin
write('(');
printid(defnams[dboolean]^.lid);
write(')((');
eexpr(tp^.taparm);
write(') & 1)')
end;
dsqr:
begin
tq := typeof(tp^.taparm);
if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
begin
write('((');
eexpr(tp^.taparm);
write(') * (');
eexpr(tp^.taparm);
write('))')
end
else begin
write('pow('); (* LIB *)
if typeof(tp^.taparm) <> typnods[treal] then
write(dblcast);
eexpr(tp^.taparm);
write(', 2.0)')
end
end;
dround:
begin
write('Round(');
eexpr(tp^.taparm);
write(')')
end;
dtrunc:
begin
write('Trunc(');
eexpr(tp^.taparm);
write(')')
end;
dpack:
begin
tq := typeof(tp^.taparm);
tx := typeof(tp^.taparm^.tnext^.tnext);
write('{ ', registr, inttyp, tab1, '_j, _i = ');
if not arithexpr(tp^.taparm^.tnext) then
write('(int)');
eexpr(tp^.taparm^.tnext);
if tx^.tt = narray then
write(' - ', clower(tq^.taindx):1);
writeln(';');
indent;
write(' for (_j = 0; _j < ');
if tq^.tt = nconfarr then
begin
write('(int)(');
printid(tx^.tcindx^.thi^.tsym^.lid);
write(')')
end
else
write(crange(tx^.taindx):1);
writeln('; )');
indent;
write(tab1);
eexpr(tp^.taparm^.tnext^.tnext);
write('.A[_j++] = ');
eexpr(tp^.taparm);
writeln('.A[_i++];');
indent;
writeln('}')
end;
dunpack:
begin
tq := typeof(tp^.taparm);
tx := typeof(tp^.taparm^.tnext);
write('{ ', registr, inttyp, tab1, '_j, _i = ');
if not arithexpr(tp^.taparm^.tnext^.tnext) then
write('(int)');
eexpr(tp^.taparm^.tnext^.tnext);
if tx^.tt <> nconfarr then
write(' - ', clower(tx^.taindx):1);
writeln(';');
indent;
write(' for (_j = 0; _j < ');
if tq^.tt = nconfarr then
begin
write('(int)(');
printid(tq^.tcindx^.thi^.tsym^.lid);
write(')')
end
else
write(crange(tq^.taindx):1);
writeln('; )');
indent;
write(tab1);
eexpr(tp^.taparm^.tnext);
write('.A[_i++] = ');
eexpr(tp^.taparm);
writeln('.A[_j++];');
indent;
writeln('}')
end;
end (* case *)
end; (* epredef *)
procedure eaddr(tp : treeptr);
begin
write('&');
if not(tp^.tt in [nid, nselect, nindex, nderef]) then
error(evarpar);
eexpr(tp)
end;
(* Emit code for a subroutine call. *)
procedure ecall(tp : treeptr);
var tf, tq, tx : treeptr;
begin
(* find first formal parameter id *)
tf := idup(tp^.tcall);
case tf^.tt of
nproc,
nfunc:
tf := tf^.tsubpar;
nparproc,
nparfunc:
tf := tf^.tparparm
end;(* case *)
if tf <> nil then
begin
case tf^.tt of
nvalpar,
nvarpar:
tf := tf^.tidl;
nparproc,
nparfunc:
tf := tf^.tparid
end (* case *)
end;
(* emit called function name *)
eexpr(tp^.tcall);
write('(');
(* emit actual parameters *)
tq := tp^.taparm;
while tq <> nil do
begin
if tf^.tup^.tt in [nparfunc, nparproc] then
begin
(* single subroutine-nid converted to ncall *)
if tq^.tt = ncall then
printid(tq^.tcall^.tsym^.lid)
else
printid(tq^.tsym^.lid)
end
else begin
tx := typeof(tq);
if tx = typnods[tboolean] then
begin
tx := tq;
while tx^.tt = nuplus do
tx := tx^.texps;
if tx^.tt in [nin .. nor, nand, nnot]
then
begin
write('(');
printid(defnams[dboolean]^.lid);
write(')(');
eexpr(tq);
write(')')
end
else
eexpr(tq);
end
else if (tx = typnods[tstring]) or
(tx = typnods[tset]) then
begin
(* cast literal to proper type *)
write('*((');
etypedef(tf^.tup^.tbind);
write(' *)');
if tx = typnods[tset] then
begin
dropset := true;
eexpr(tq);
dropset := false
end
else
eexpr(tq);
write(')')
end
else if tx = typnods[tnil] then
begin
write('(');
etypedef(tf^.tup^.tbind);
write(')NIL')
end
else if tf^.tup^.tbind^.tt = nconfarr then
begin
write('(struct ');
printid(tf^.tup^.tbind^.tcuid);
write(' *)&');
eexpr(tq);
(* add upper bound of actual value *)
if tq^.tnext = nil then
write(', ',
crange(tx^.taindx):1)
end
else begin
if tf^.tup^.tt = nvarpar then
eaddr(tq)
else
eexpr(tq)
end
end;
tq := tq^.tnext;
if tq <> nil then
begin
write(', ');
(* next formal parameter *)
if tf^.tnext = nil then
begin
tf := tf^.tup^.tnext;
case tf^.tt of
nvalpar,
nvarpar:
tf := tf^.tidl;
nparproc,
nparfunc:
tf := tf^.tparid
end (* case *)
end
else
tf := tf^.tnext;
end;
end;
write(')')
end; (* ecall *)
(* Emit code for a general expression. *)
procedure eexpr;
label 999;
var tq : treeptr;
flag : boolean;
function constset(tp : treeptr) : boolean;
function constxps(tp : treeptr) : boolean;
begin
case tp^.tt of
nrange:
if constxps(tp^.texpr) then
constxps := constxps(tp^.texpl)
else
constxps := false;
nempty,
ninteger,
nchar:
constxps := true;
nid:
begin
tp := idup(tp);
constxps := (tp^.tt = nconst)
or (tp^.tt = nscalar)
end;
nin, neq, nne, nlt, nle, ngt, nge, nor,
nplus, nminus, nand, nmul, ndiv, nmod,
nquot, nnot, numinus, nuplus, nset,
nindex, nselect, nderef, ncall,
nreal, nstring, nnil:
constxps := false
end (* case *)
end;
begin
constset := true;
while tp <> nil do
if constxps(tp) then
tp := tp^.tnext
else begin
constset := false;
tp := nil
end
end;
begin (* eexpr *)
donearr := false;
if tp^.tt in [nplus, nminus, nmul, nle, nge, neq, nne] then
begin
tq := typeof(tp^.texpl);
if (tq^.tt in [nset, nsetof]) or
(tq = typnods[tset]) then
begin
(* set operations *)
case tp^.tt of
nplus:
begin
setused := true;
useunion := true;
write('Union')
end;
nminus:
begin
setused := true;
usediff := true;
write('Diff')
end;
nmul:
begin
setused := true;
useintr := true;
write('Inter')
end;
neq:
begin
useseq := true;
write('Eq')
end;
nne:
begin
usesne := true;
write('Ne')
end;
nge:
begin
usesge := true;
write('Ge')
end;
nle:
begin
usesle := true;
write('Le')
end
end;(* case *)
if tp^.tt in [nplus, nminus, nmul] then
dropset := false;
write('(');
eexpr(tp^.texpl);
if tq^.tt = nsetof then
write('.S');
write(', ');
eexpr(tp^.texpr);
tq := typeof(tp^.texpr);
if tq^.tt = nsetof then
write('.S');
write(')');
goto 999
end
end;
if tp^.tt in [neq, nne, ngt, nlt, nge, nle] then
begin
tq := typeof(tp^.texpl);
if tq^.tt = nconfarr then
fatal(ecmpconf);
if (tq^.tt in [nstring, narray]) or
(tq = typnods[tstring]) then
begin
write('Cmpstr(');
eexpr(tp^.texpl);
if tq^.tt = narray then
write('.A');
write(', ');
tq := typeof(tp^.texpr);
if tq^.tt = nconfarr then
fatal(ecmpconf);
eexpr(tp^.texpr);
if tq^.tt = narray then
write('.A');
write(')');
case tp^.tt of
neq:
write(' == ');
nne:
write(' != ');
ngt:
write(' > ');
nlt:
write(' < ');
nge:
write(' >= ');
nle:
write(' <= ');
end;(* case *)
write('0');
goto 999
end
end;
case tp^.tt of
neq, nne, nlt, nle,
ngt, nge, nor, nand, nplus, nminus,
nmul, ndiv, nmod, nquot:
begin
flag := cprio[tp^.tt] > cprio[tp^.texpl^.tt];
if (tp^.tt in [nlt, nle, ngt, nge]) and
not arithexpr(tp^.texpl) then
begin
write('(int)');
flag := true
end;
if flag then
write('(');
eexpr(tp^.texpl);
if flag then
write(')');
case tp^.tt of
neq:
write(' == ');
nne:
write(' != ');
nlt:
write(' < ');
nle:
write(' <= ');
ngt:
write(' > ');
nge:
write(' >= ');
nor:
write(' || ');
nand:
write(' && ');
nplus:
write(' + ');
nminus:
write(' - ');
nmul:
write(' * ');
ndiv:
write(' / ');
nmod:
write(' % ');
nquot:
begin
write(' / ((');
printid(defnams[dreal]^.lid);
write(')')
end
end;(* case *)
flag := cprio[tp^.tt] > cprio[tp^.texpr^.tt];
if (tp^.tt in [nlt, nle, ngt, nge]) and
not arithexpr(tp^.texpr) then
begin
write('(int)');
flag := true
end;
if flag then
write('(');
eexpr(tp^.texpr);
if flag then
write(')');
if tp^.tt = nquot then
write(')')
end;
nuplus, numinus, nnot:
begin
case tp^.tt of
numinus:
write('-');
nnot:
write('!');
nuplus:
end;(* case *)
flag := cprio[tp^.tt] >= cprio[tp^.texps^.tt];
if flag then
write('(');
eexpr(tp^.texps);
if flag then
write(')');
end;
nin:
begin
usememb := true;
write('Member((unsigned)(');
eexpr(tp^.texpl);
write('), ');
dropset := true; (* no need to save set-expr *)
eexpr(tp^.texpr);
dropset := false;
tq := typeof(tp^.texpr);
if tq^.tt = nsetof then
write('.S');
write(')')
end;
nassign:
begin
tq := typeof(tp^.trhs);
if tq = typnods[tstring] then
begin
write(voidcast, 'strncpy(');
eexpr(tp^.tlhs);
write('.A, ');
eexpr(tp^.trhs);
write(', sizeof(');
eexpr(tp^.tlhs);
write('.A))')
end
else if tq = typnods[tboolean] then
begin
eexpr(tp^.tlhs);
write(' = ');
tq := tp^.trhs;
while tq^.tt = nuplus do
tq := tq^.texps;
if tq^.tt in [nin .. nor, nand, nnot] then
begin
write('(');
printid(defnams[dboolean]^.lid);
write(')(');
eexpr(tq);
write(')')
end
else
eexpr(tq)
end
else if tq = typnods[tnil] then
begin
eexpr(tp^.tlhs);
write(' = (');
etypedef(typeof(tp^.tlhs));
write(')NIL')
end
else begin
tq := typeof(tp^.tlhs);
if tq^.tt = nsetof then
begin
usescpy := true;
write('Setncpy(');
eselect(tp^.tlhs);
write('S, ');
dropset := true;
tq := typeof(tp^.trhs);
if tq = typnods[tset] then
eexpr(tp^.trhs)
else begin
eselect(tp^.trhs);
write('S')
end;
dropset := false;
write(', sizeof(');
eselect(tp^.tlhs);
write('S))')
end
else begin
eexpr(tp^.tlhs);
write(' = ');
eexpr(tp^.trhs)
end
end
end;
ncall:
begin
tq := idup(tp^.tcall);
if (tq^.tt in [nfunc, nproc]) and
(tq^.tsubstmt <> nil) then
if tq^.tsubstmt^.tt = npredef then
epredef(tq, tp)
else
ecall(tp)
else
ecall(tp)
end;
nselect:
begin
eselect(tp^.trecord);
eexpr(tp^.tfield)
end;
nindex:
begin
eselect(tp^.tvariable);
write('A[');
tq := tp^.toffset;
if arithexpr(tq) then
eexpr(tq)
else begin
write('(int)(');
eexpr(tq);
write(')')
end;
tq := typeof(tp^.tvariable);
if tq^.tt = narray then
if clower(tq^.taindx) <> 0 then
begin
write(' - ');
tq := typeof(tq^.taindx);
if tq^.tt = nsubrange then
if arithexpr(tq^.tlo) then
eexpr(tq^.tlo)
else begin
write('(int)(');
eexpr(tq^.tlo);
write(')')
end
else
fatal(etree)
end;
write(']')
end;
nderef:
begin
tq := typeof(tp^.texps);
if (tq^.tt = nfileof) or
((tq^.tt = npredef) and (tq^.tdef = dtext)) then
begin
(* using a file-variable as pointer *)
eexpr(tp^.texps);
write('.buf')
end
else if doarrow = 0 then
begin
write('*');
eexpr(tp^.texps)
end
else begin
eexpr(tp^.texps);
write('->');
donearr := true
end
end;
nid:
begin
(* add pointer-dereference if this id is declared as a
var-parameter or as a procedure-parameter *)
tq := idup(tp);
if tq^.tt = nvarpar then
begin
if (doarrow = 0) or
(tq^.tattr = areference) then
begin
write('(*');
printid(tp^.tsym^.lid);
write(')')
end
else begin
printid(tp^.tsym^.lid);
write('->');
donearr := true
end
end
else if (tq^.tt = nconst) and conflag then
write(cvalof(tp):1)
else if tq^.tt in [nparproc, nparfunc] then
begin
write('(*');
printid(tp^.tsym^.lid);
write(')')
end
else
printid(tp^.tsym^.lid);
end;
nchar:
printchr(tp^.tsym^.lchar);
ninteger:
write(tp^.tsym^.linum:1);
nreal:
printtok(tp^.tsym^.lfloat);
nstring:
printstr(tp^.tsym^.lstr);
nset:
if constset(tp^.texps) then
begin
(* save set expression for initialization *)
write('Conset[', setcnt:1, ']');
setcnt := setcnt + 1;
tq := mknode(nset);
tq^.tnext := setlst;
setlst := tq;
tq^.texps := tp^.texps
end
else begin
increment;
flag := dropset;
(* if a set-constructor is used in an
expression involving + - * it will need to
be saved temporarily (by Saveset) but often
we can simply forget the set-value when we
have finished using it *)
if dropset then
dropset := false
else
write('Saveset(');
write('(Tmpset = Newset(), ');
tq := tp^.texps;
while tq <> nil do
begin
case tq^.tt of
nrange:
begin
usemksub := true;
write(voidcast, 'Mksubr(');
write('(unsigned)(');
eexpr(tq^.texpl);
write('), ');
write('(unsigned)(');
eexpr(tq^.texpr);
write('), Tmpset)')
end;
nin, neq, nne, nlt, nle, ngt, nge,
nor, nand, nmul, ndiv, nmod, nquot,
nplus, nminus, nnot, numinus, nuplus,
nindex, nselect, nderef, ncall,
ninteger, nchar, nid:
begin
useins := true;
write(voidcast, 'Insmem(');
write('(unsigned)(');
eexpr(tq);
write('), Tmpset)')
end
end;(* case *)
tq := tq^.tnext;
if tq <> nil then
begin
writeln(',');
indent
end
end;
write(', Tmpset)');
if not flag then
begin
write(')');
setused := true
end;
decrement
end;
nnil:
begin
tq := tp;
repeat
tq := tq^.tup
until tq^.tt in [neq, nne, ncall, nassign, npgm];
if tq^.tt in [neq, nne] then
begin
if typeof(tq^.texpl) = typnods[tnil] then
tq := typeof(tq^.texpr)
else
tq := typeof(tq^.texpl);
if tq^.tt = nptr then
begin
write('(');
etypedef(tq);
write(')')
end
end;
write('NIL')
end;
end;(* case *)
999:
end; (* eexpr *)
(* Emit constant definitions. *)
procedure econst(tp : treeptr);
var sp : symptr;
begin
while tp <> nil do
begin
sp := tp^.tidl^.tsym;
if sp^.lid^.inref > 1 then
sp^.lid := mkrename('X', sp^.lid);
if tp^.tbind^.tt = nstring then
begin
(* string constants emitted as
static local variables *)
indent;
write(static, chartyp, tab1);
printid(sp^.lid);
write('[] = ');
eexpr(tp^.tbind);
writeln(';')
end
else begin
(* all other constants emitted as
preprocessor # defines *)
write(define);
printid(sp^.lid);
write(space);
eexpr(tp^.tbind);
writeln
end;
tp := tp^.tnext
end
end; (* econst *)
(* Emit a typedef. *)
procedure etypedef;
(* Workhorse for etypedef, this procedure also *)
(* renames all fields in record-unions when *)
(* necessary. *)
procedure etdef(uid : idptr; tp : treeptr);
var i : integer;
tq : treeptr;
(* Emit definition for an integer subrange *)
(* using data from worddefs set up during *)
(* initialization. *)
procedure etrange(tp : treeptr);
label 999;
var lo, hi : integer;
i : 1 .. maxmachdefs;
begin
lo := clower(tp);
hi := cupper(tp);
(* scan CPU word definitions for a type
enclosing wanted range *)
for i := 1 to nmachdefs do
with machdefs[i] do
if (lo >= lolim) and (hi <= hilim) then
begin
(* found it, print type name *)
printtok(typstr);
goto 999
end;
fatal(erange);
999:
end;
(* Print last component of identifier. *)
procedure printsuf(ip : idptr);
var w : toknbuf;
i, j : toknidx;
begin
gettokn(ip^.istr, w);
i := 1;
j := i;
while w[i] <> chr(null) do
begin
if w[i] = '.' then
j := i;
i := i + 1
end;
if w[j] = '.' then
j := j + 1;
while w[j] <> chr(null) do
begin
write(w[j]);
j := j + 1
end
end;
begin (* etdef *)
case tp^.tt of
nid:
printid(tp^.tsym^.lid);
nptr:
begin
tq := typeof(tp^.tptrid);
if tq^.tt = nrecord then
begin
write('struct ');
printid(tq^.tuid)
end
else
printid(tp^.tptrid^.tsym^.lid);
write(' *');
end;
nscalar:
begin
write('enum { ');
increment;
tp := tp^.tscalid;
(* avoid bug in C-compiler:
enums are mixed in same namespace *)
if tp^.tsym^.lid^.inref > 1 then
tp^.tsym^.lid :=
mkrename('E', tp^.tsym^.lid);
printid(tp^.tsym^.lid);
i := 1;
while tp^.tnext <> nil do
begin
if i >= 4 then
begin
writeln(',');
indent;
i := 1
end
else begin
write(', ');
i := i + 1
end;
tp := tp^.tnext;
if tp^.tsym^.lid^.inref > 1 then
tp^.tsym^.lid :=
mkrename('E', tp^.tsym^.lid);
printid(tp^.tsym^.lid)
end;
decrement;
write(' } ')
end;
nsubrange:
begin
tq := typeof(tp^.tlo);
if tq = typnods[tinteger] then
etrange(tp)
else begin
if tq^.tup^.tt = ntype then
tq := tq^.tup^.tidl;
etdef(nil, tq)
end
end;
nfield:
begin
etdef(nil, tp^.tbind);
write(tab1);
tp := tp^.tidl;
if uid <> nil then
tp^.tsym^.lid :=
mkconc('.', uid, tp^.tsym^.lid);
printsuf(tp^.tsym^.lid);
i := 1;
while tp^.tnext <> nil do
begin
if i >= 4 then
begin
writeln(',');
indent;
write(tab1);
i := 1
end
else begin
write(', ');
i := i + 1
end;
tp := tp^.tnext;
if uid <> nil then
tp^.tsym^.lid :=
mkconc('.', uid, tp^.tsym^.lid);
printsuf(tp^.tsym^.lid);
end;
writeln(';');
end;
nrecord:
begin
write('struct ');
if tp^.tuid = nil then
tp^.tuid := uid
else if uid = nil then
printid(tp^.tuid);
writeln(' {');
increment;
if (tp^.tflist = nil) and
(tp^.tvlist = nil) then
begin
(* C doesn't allow empty structures *)
indent;
writeln(inttyp, tab1, 'dummy;')
end;
tq := tp^.tflist;
while tq <> nil do
begin
indent;
etdef(uid, tq);
tq := tq^.tnext
end;
if tp^.tvlist <> nil then
begin
indent;
writeln('union {');
increment;
tq := tp^.tvlist;
while tq <> nil do
begin
if (tq^.tvrnt^.tflist <> nil) or
(tq^.tvrnt^.tvlist <> nil) then
begin
indent;
if uid = nil then
etdef(mkvrnt,
tq^.tvrnt)
else
etdef(mkconc('.',
uid, mkvrnt),
tq^.tvrnt);
writeln(';')
end;
tq := tq^.tnext
end;
decrement;
indent;
writeln('} U;');
end;
decrement;
indent;
if tp^.tup^.tt = nvariant then
begin
write('} ');
printsuf(tp^.tuid)
end
else
write('}');
end;
nconfarr:
begin
write('struct ');
printid(tp^.tcuid);
write(' { ');
etdef(nil, tp^.tcelem);
write(tab1, 'A[]; }')
end;
narray:
begin
write('struct { ');
etdef(nil, tp^.taelem);
write(tab1, 'A[');
tq := typeof(tp^.taindx);
if tq^.tt = nsubrange then
begin
if arithexpr(tq^.thi) then
begin
eexpr(tq^.thi);
if cvalof(tq^.tlo) <> 0 then
begin
write(' - ');
eexpr(tq^.tlo)
end
end
else begin
write('(int)(');
eexpr(tq^.thi);
if cvalof(tq^.tlo) <> 0 then
begin
write(') - (int)(');
eexpr(tq^.tlo)
end;
write(')')
end;
write(' + 1')
end
else
write(crange(tp^.taindx):1);
write(']; }')
end;
nfileof:
begin
writeln('struct {');
indent;
writeln(tab1, 'FILE', tab1, '*fp;');
indent;
writeln(tab1, filebits, tab1, 'eoln:1,');
indent;
writeln(tab3, 'eof:1,');
indent;
writeln(tab3, 'out:1,');
indent;
writeln(tab3, 'init:1,');
indent;
writeln(tab3, ':', filefill:1, ';');
indent;
write(tab1);
etdef(nil, tp^.tof);
writeln(tab1, 'buf;');
indent;
write('} ')
end;
nsetof:
write('struct { ', setwtyp, tab1, 'S[',
csetsize(tp):1, ']; }');
npredef:
begin
case tp^.tobtyp of
tboolean:
printid(defnams[dboolean]^.lid);
tchar:
write(chartyp);
tinteger:
printid(defnams[dinteger]^.lid);
treal:
printid(defnams[dreal]^.lid);
tstring:
write(chartyp, ' *');
ttext:
write('text');
tnil,
tset,
terror:
fatal(etree);
tnone:
write(voidtyp);
end (* case *)
end;
nempty:
write(voidtyp);
end;(* case *)
end; (* etdef *)
begin
etdef(nil, tp)
end; (* etypedef *)
(* Emit code for type declarations. *)
procedure etype(tp : treeptr);
var sp : symptr;
begin
while tp <> nil do
begin
(* if identifier used more than once we rename the type
to avoid typedef'ing an identifier twice *)
sp := tp^.tidl^.tsym;
if sp^.lid^.inref > 1 then
sp^.lid := mkrename('Y', sp^.lid);
indent;
write(typdef);
etypedef(tp^.tbind);
write(tab1);
printid(sp^.lid);
writeln(';');
tp := tp^.tnext
end
end;
(* Emit code for variable declarations. *)
procedure evar(tp : treeptr);
label 555;
var tq : treeptr;
i : integer;
begin
while tp <> nil do
begin
indent;
case tp^.tt of
nvar,
nvalpar,
nvarpar:
begin
if tp^.tattr = aregister then
write(registr);
etypedef(tp^.tbind)
end;
nparproc,
nparfunc:
begin
if tp^.tt = nparproc then
write(voidtyp)
else
etypedef(tp^.tpartyp);
tq := tp^.tparid;
write(tab1, '(*');
printid(tq^.tsym^.lid);
write(')()');
goto 555
end
end;(* case *)
write(tab1);
tq := tp^.tidl;
i := 1;
repeat
if tp^.tt = nvarpar then
write('*');
printid(tq^.tsym^.lid);
tq := tq^.tnext;
if tq <> nil then
begin
if i >= 6 then
begin
i := 1;
writeln(',');
indent;
write(tab1)
end
else begin
i := i + 1;
write(', ')
end
end
until tq = nil;
555:
writeln(';');
if tp^.tt = nvarpar then
if tp^.tbind^.tt = nconfarr then
begin
indent;
etypedef(tp^.tbind^.tindtyp);
write(tab1);
tq := tp^.tbind^.tcindx^.thi;
printid(tq^.tsym^.lid);
writeln(';')
end;
tp := tp^.tnext
end
end; (* evar *)
(* Emit code for a statment. *)
procedure estmt(tp : treeptr);
var tq : treeptr;
locid1,
locid2 : idptr;
stusd : boolean;
opc1,
opc2 : char;
(* Emit typename for with-variable. *)
procedure ewithtype(tp : treeptr);
var tq : treeptr;
begin
tq := typeof(tp);
write('struct ');
printid(tq^.tuid)
end;
(* Emit code for a case-choise. *)
procedure echoise(tp : treeptr);
var tq : treeptr;
i : integer;
begin
while tp <> nil do
begin
tq := tp^.tchocon;
i := 0;
indent;
while tq <> nil do
begin
write(' case ');
conflag := true;
eexpr(tq);
conflag := false;
write(':');
i := i + 1;
tq := tq^.tnext;
if (tq = nil) or (i mod 4 = 0) then
begin
writeln;
if tq <> nil then
indent;
i := 0
end
end;
increment;
if tp^.tchostmt^.tt = nbegin then
estmt(tp^.tchostmt^.tbegin)
else
estmt(tp^.tchostmt);
indent;
writeln('break ;');
decrement;
tp := tp^.tnext;
if tp <> nil then
if tp^.tchocon = nil then
tp := nil
end
end; (* echoise *)
(* Rename all accessible record-fields to include *)
(* pointer name. *)
procedure cenv(ip : idptr; dp : declptr);
var tp : treeptr;
sp : symptr;
np : idptr;
h : hashtyp;
begin
with dp^ do
for h := 0 to hashmax - 1 do
begin
sp := ddecl[h];
while sp <> nil do
begin
if sp^.lt = lfield then
begin
np := sp^.lid;
tp := sp^.lsymdecl^.tup^.tup;
if (tp^.tup^.tt = nvariant) and
(tp^.tuid <> nil) then
np := mkconc('.',
tp^.tuid, np);
np := mkconc('>', ip, np);
sp^.lid := np
end;
sp := sp^.lnext
end
end
end; (* cenv *)
(* Emit identifiers for push/pop of global ptrs. *)
procedure eglobid(tp : treeptr);
var j : toknidx;
w : toknbuf;
begin
gettokn(tp^.tsym^.lid^.istr, w);
j := 1;
if w[1] = '*' then
j := 2;
while w[j] <> chr(null) do
begin
write(w[j]);
j := j + 1
end
end;
begin (* estmt *)
while tp <> nil do
begin
case tp^.tt of
nbegin:
begin
if tp^.tup^.tt in [nbegin, nrepeat,
nproc, nfunc, npgm] then
indent;
writeln('{');
increment;
estmt(tp^.tbegin);
decrement;
indent;
write('}');
if tp^.tup^.tt <> nif then
writeln
end;
nrepeat:
begin
indent;
writeln('do {');
increment;
estmt(tp^.treptstmt);
decrement;
indent;
write('} while (!(');
eexpr(tp^.treptxp);
writeln('));')
end;
nwhile:
begin
indent;
write('while (');
increment;
eexpr(tp^.twhixp);
stusd := setused;
if tp^.twhistmt^.tt = nbegin then
begin
decrement;
write(') ');
estmt(tp^.twhistmt)
end
else begin
writeln(')');
estmt(tp^.twhistmt);
decrement
end;
setused := stusd or setused
end;
nfor:
begin
indent;
if tp^.tincr then
begin
opc1 := '+'; (* increment variable *)
opc2 := '<' (* test for <= *)
end
else begin
opc1 := '-'; (* decrement variable *)
opc2 := '>'; (* test for >= *)
end;
if not lazyfor then
begin
locid1 := mkvariable('B');
locid2 := mkvariable('B');
writeln('{');
increment;
indent;
tq := idup(tp^.tforid);
etypedef(tq^.tbind);
tq := typeof(tq^.tbind);
write(tab1);
printid(locid1);
write(' = ');
eexpr(tp^.tfrom);
writeln(',');
indent;
write(tab1);
printid(locid2);
write(' = ');
eexpr(tp^.tto);
writeln(';');
writeln;
indent;
write('if (');
if tq^.tt = nscalar then
begin
write('(int)(');
printid(locid1);
write(')')
end
else
printid(locid1);
write(' ', opc2, '= ');
if tq^.tt = nscalar then
begin
write('(int)(');
printid(locid2);
write(')')
end
else
printid(locid2);
writeln(')');
increment;
indent;
tp^.tfrom := newid(locid1);
tp^.tfrom^.tup := tp
end;
write('for (');
increment;
eexpr(tp^.tforid);
tq := typeof(tp^.tforid);
write(' = ');
eexpr(tp^.tfrom);
write('; ');
if lazyfor then
begin
if tq^.tt = nscalar then
begin
write('(int)(');
eexpr(tp^.tforid);
write(')')
end
else
eexpr(tp^.tforid);
write(' ', opc2, '= ');
if tq^.tt = nscalar then
begin
write('(int)(');
eexpr(tp^.tto);
write(')')
end
else
eexpr(tp^.tto)
end;
write('; ');
eexpr(tp^.tforid);
if tq^.tt = nscalar then
begin
write(' = (');
eexpr(tq^.tup^.tidl);
write(')((int)(');
eexpr(tp^.tforid);
write(')', opc1, '1)')
end
else
write(opc1, opc1);
if not lazyfor then
begin
if tp^.tforstmt^.tt <> nbegin then
begin
(* create compund stmt *)
tq := mknode(nbegin);
tq^.tbegin := tp^.tforstmt;
tq^.tbegin^.tup := tq;
tp^.tforstmt := tq;
tq^.tup := tp
end;
(* find end of loop *)
tq := tp^.tforstmt^.tbegin;
while tq^.tnext <> nil do
tq := tq^.tnext;
(* add break stmt *)
tq^.tnext := mknode(nbreak);
tq := tq^.tnext;
tq^.tup := tp^.tforstmt;
tq^.tbrkid := tp^.tforid;
tq^.tbrkxp := newid(locid2);
tq^.tbrkxp^.tup := tq
end;
if tp^.tforstmt^.tt = nbegin then
begin
decrement;
write(') ');
estmt(tp^.tforstmt)
end
else begin
writeln(')');
estmt(tp^.tforstmt);
decrement
end;
if not lazyfor then
begin
decrement;
decrement;
indent;
writeln('}')
end
end;
nif:
begin
indent;
write('if (');
increment;
eexpr(tp^.tifxp);
stusd := setused;
setused := false;
if tp^.tthen^.tt = nbegin then
begin
decrement;
write(') ');
estmt(tp^.tthen);
if tp^.telse <> nil then
write(space)
else
writeln
end
else begin
writeln(')');
estmt(tp^.tthen);
decrement;
if tp^.telse <> nil then
indent
end;
if tp^.telse <> nil then
begin
write('else');
if tp^.telse^.tt = nbegin then
begin
write(space);
estmt(tp^.telse);
writeln
end
else begin
increment;
writeln;
estmt(tp^.telse);
decrement
end;
end;
setused := stusd or setused
end;
ncase:
begin
indent;
write('switch (');
increment;
eexpr(tp^.tcasxp);
writeln(') {');
decrement;
echoise(tp^.tcaslst);
indent;
writeln(' default:');
increment;
if tp^.tcasother = nil then
begin
indent;
writeln('Caseerror(Line);')
end
else
estmt(tp^.tcasother);
decrement;
indent;
writeln('}')
end;
nwith:
begin
indent;
writeln('{');
increment;
tq := tp^.twithvar;
while tq <> nil do
begin
indent;
write(registr);
ewithtype(tq^.texpw);
write(' *');
locid1 := mkvariable('W');
printid(locid1);
write(' = ');
eaddr(tq^.texpw);
writeln(';');
cenv(locid1, tq^.tenv);
tq := tq^.tnext
end;
writeln;
if tp^.twithstmt^.tt = nbegin then
estmt(tp^.twithstmt^.tbegin)
else
estmt(tp^.twithstmt);
decrement;
indent;
writeln('}')
end;
ngoto:
begin
indent;
if islocal(tp^.tlabel) then
writeln('goto L',
tp^.tlabel^.tsym^.lno:1, ';')
else begin
tq := idup(tp^.tlabel);
writeln('longjmp(J[', (* LIB *)
tq^.tstat:1, '].jb, ',
tp^.tlabel^.tsym^.lno:1, ');')
end
end;
nlabstmt:
begin
decrement;
indent;
writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
increment;
estmt(tp^.tstmt)
end;
nassign:
begin
indent;
eexpr(tp);
writeln(';')
end;
ncall:
begin
indent;
tq := idup(tp^.tcall);
if (tq^.tt in [nfunc, nproc]) and
(tq^.tsubstmt <> nil) then
if tq^.tsubstmt^.tt = npredef then
epredef(tq, tp)
else begin
ecall(tp);
writeln(';')
end
else begin
ecall(tp);
writeln(';')
end
end;
npush:
begin
indent;
eglobid(tp^.ttmp);
write(' = ');
eglobid(tp^.tglob);
writeln(';');
indent;
eglobid(tp^.tglob);
write(' = ');
if tp^.tloc^.tt = nid then
begin
tq := idup(tp^.tloc);
if tq^.tt in [nparproc, nparfunc] then
printid(tp^.tloc^.tsym^.lid)
else
eaddr(tp^.tloc)
end
else
eaddr(tp^.tloc);
writeln(';')
end;
npop:
begin
indent;
eglobid(tp^.tglob);
write(' = ');
eglobid(tp^.ttmp);
writeln(';')
end;
nbreak:
begin
indent;
write('if (');
eexpr(tp^.tbrkid);
write(' == ');
eexpr(tp^.tbrkxp);
writeln(') break;')
end;
nempty:
if not (tp^.tup^.tt in [npgm, nproc, nfunc,
nchoise, nbegin, nrepeat]) then
begin
indent;
writeln(';')
end
end;(* case *)
if setused and
(tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
nbegin, nchoise, nwith]) then
begin
indent;
writeln('Claimset();');
setused := false
end;
tp := tp^.tnext
end
end; (* estmt *)
(* Emit initialization for non-local gotos. *)
procedure elabel(tp : treeptr);
var tq : treeptr;
i : integer;
begin
i := 0;
tq := tp^.tsublab;
while tq <> nil do
begin
if tq^.tsym^.lgo then
i := i + 1;
tq := tq^.tnext
end;
if i =1 then
begin
tq := tp^.tsublab;
while not tq^.tsym^.lgo do
tq := tq^.tnext;
indent;
writeln('if (',
'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
end
else if i > 1 then
begin
indent;
writeln('switch (',
'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
indent;
writeln(' case 0:');
indent;
writeln(tab1, 'break');
tq := tp^.tsublab;
while tq <> nil do
begin
if tq^.tsym^.lgo then
begin
(* label used in non-local goto *)
indent;
writeln(' case ',
tq^.tsym^.lno:1, ':');
indent;
writeln(tab1, 'goto L',
tq^.tsym^.lno:1, ';')
end;
tq := tq^.tnext
end;
indent;
writeln(' default:');
indent;
writeln(tab1, 'Caseerror(Line)');
indent;
writeln('}')
end
end; (* elabel *)
(* Emit declaration for lower bound of conformant array. *)
procedure econf(tp : treeptr);
var tq : treeptr;
begin
while tp <> nil do
begin
if tp^.tt = nvarpar then
if tp^.tbind^.tt = nconfarr then
begin
indent;
etypedef(tp^.tbind^.tindtyp);
write(tab1);
tq := tp^.tbind^.tcindx^.tlo;
printid(tq^.tsym^.lid);
write(' = (');
etypedef(tp^.tbind^.tindtyp);
writeln(')0;')
end;
tp := tp^.tnext
end
end; (* econf *)
(* Emit code for subroutines. *)
procedure esubr(tp : treeptr);
label 999;
var tq, ti : treeptr;
begin
while tp <> nil do
begin
(* emit nested subroutines *)
if tp^.tsubsub <> nil then
begin
(* emit forward declaration of this subroutine
in case of recursion *)
etypedef(tp^.tfuntyp);
write(space);
printid(tp^.tsubid^.tsym^.lid);
writeln('();');
writeln;
esubr(tp^.tsubsub)
end;
(* emit this subroutine *)
if tp^.tsubstmt = nil then
begin
(* forward/external decl *)
if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
write(xtern);
etypedef(tp^.tfuntyp);
write(space);
printid(tp^.tsubid^.tsym^.lid);
writeln('();');
goto 999
end;
write(space);
etypedef(tp^.tfuntyp);
writeln;
printid(tp^.tsubid^.tsym^.lid);
write('(');
tq := tp^.tsubpar;
while tq <> nil do
begin
case tq^.tt of
nvarpar,
nvalpar:
begin
ti := tq^.tidl;
while ti <> nil do
begin
printid(ti^.tsym^.lid);
ti := ti^.tnext;
if ti <> nil then
write(', ');
end;
if tq^.tbind^.tt = nconfarr then
begin
(* add upper bound parameter *)
ti := tq^.tbind^.tcindx^.thi;
write(', ');
printid(ti^.tsym^.lid)
end;
end;
nparproc,
nparfunc:
begin
ti := tq^.tparid;
printid(ti^.tsym^.lid)
end
end;(* case *)
tq := tq^.tnext;
if tq <> nil then
write(', ');
end;
writeln(')');
increment;
evar(tp^.tsubpar);
writeln('{');
econf(tp^.tsubpar);
econst(tp^.tsubconst);
etype(tp^.tsubtype);
evar(tp^.tsubvar);
if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
(tp^.tsubvar <> nil) then
writeln;
elabel(tp);
estmt(tp^.tsubstmt);
if tp^.tt = nfunc then
begin
(* return value in the FIRST variable,
see renamf() above *)
indent;
write('return ');
printid(tp^.tsubvar^.tidl^.tsym^.lid);
writeln(';');
end;
decrement;
writeln('}');
999:
writeln;
tp := tp^.tnext
end
end; (* esubr *)
function use(d : predefs) : boolean;
begin
use := defnams[d]^.lused
end;
(* Emit code for main program. *)
procedure eprogram(tp : treeptr);
(* Symbol that sp refers to is renamed if it has *)
(* been redefined in source program. *)
procedure capital(sp : symptr);
var tb : toknbuf;
begin
if sp^.lid^.inref > 1 then
begin
gettokn(sp^.lid^.istr, tb);
tb[1] := uppercase(tb[1]);
sp^.lid := saveid(tb)
end
end;
procedure etextdef;
var tq : treeptr;
begin
write('typedef ');
tq := mknode(nfileof);
tq^.tof := typnods[tchar];
etypedef(tq);
writeln(tab1, 'text;')
end;
begin (* eprogram *)
if tp^.tsubid <> nil then
begin
(* program heading was seen *)
writeln('/', '*');
write('** Code derived from program ');
printid(tp^.tsubid^.tsym^.lid);
writeln;
writeln('*', '/');
writeln(xtern, voidtyp, tab1, 'exit();')
end;
if usecase or usesets or
use(dinput) or use(doutput) or
use(dwrite) or use(dwriteln) or use(dmessage) or
use(deof) or use(deoln) or use(dflush) or use(dpage) or
use(dread) or use(dreadln) or use(dclose) or
use(dreset) or use(drewrite) or use(dget) or use(dput) then
begin
writeln('/', '*');
writeln('** Definitions for i/o');
writeln('*', '/');
writeln(include, '<stdio.h>') (* LIB *)
end;
if use(dinput) or use(doutput) or use(dtext) then
begin
etextdef;
if use(dinput) then
begin
if tp^.tsubid = nil then
write(xtern);
write('text', tab1);
printid(defnams[dinput]^.lid);
if tp^.tsubid <> nil then
write(' = { stdin, 0, 0 }');
writeln(';')
end;
if use(doutput) then
begin
if tp^.tsubid = nil then
write(xtern);
write('text', tab1);
printid(defnams[doutput]^.lid);
if tp^.tsubid <> nil then
write(' = { stdout, 0, 0 }');
writeln(';')
end
end;
if use(dinput) or use(dget) or use(dread) or use(dreadln) or
use(deof) or use(deoln) or use(dreset) or use(drewrite) then
begin
writeln(define, 'Fread(x, f) ',
'fread((char *)&x, sizeof(x), 1, f)'); (* LIB *)
writeln(define, 'Get(f) Fread((f).buf, (f).fp)');
writeln(define, 'Getx(f) (f).init = 1, ',
'(f).eoln = (((f).buf = ',
'fgetc((f).fp)', (* LIB *)
') == ', nlchr, ') ? (((f).buf = ',
spchr, '), 1) : 0');
writeln(define, 'Getchr(f) (f).buf, Getx(f)')
end;
if use(dread) or use(dreadln) then
begin
writeln(static, 'FILE', tab1, '*Tmpfil;');
writeln(static, 'long', tab1, 'Tmplng;');
writeln(static, 'double', tab1, 'Tmpdbl;');
writeln(define, 'Fscan(f) (f).init ? ',
'ungetc((f).buf, (f).fp)', (* LIB *)
' : 0, Tmpfil = (f).fp');
writeln(define, 'Scan(p, a) ',
'Scanck(fscanf(Tmpfil, p, a))'); (* LIB *)
writeln(voidtyp, tab1, 'Scanck();');
if use(dreadln) then
writeln(voidtyp, tab1, 'Getl();');
end;
if use(deoln) then
writeln(define, 'Eoln(f) ((f).eoln ? true : false)');
if use(deof) then
writeln(define, 'Eof(f) ',
'((((f).init == 0) ? (Get(f)) : 0, ',
'((f).eof ? 1 : ',
'feof((f).fp))) ? ', (* LIB *)
'true : false)');
if use(doutput) or use(dput) or
use(dwrite) or use(dwriteln) or
use(dreset) or use(drewrite) or use(dclose) then
begin
writeln(define, 'Fwrite(x, f) ',
'fwrite((char *)&x, sizeof(x), 1, f)');(* LIB *)
writeln(define, 'Put(f) Fwrite((f).buf, (f).fp)');
writeln(define, 'Putx(f) (f).eoln = ((f).buf == ',
nlchr, '), ', voidcast,
'fputc((f).buf, (f).fp)'); (* LIB *)
writeln(define, 'Putchr(c, f) (f).buf = (c), Putx(f)');
writeln(define, 'Putl(f, v) (f).eoln = v')
end;
if use(dreset) or use(drewrite) or use(dclose) then
writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
'(Putchr(', nlchr, ', f), 0) : 0, ',
'rewind((f).fp)'); (* LIB *)
if use(dclose) then
begin
writeln(define, 'Close(f) (f).init = ',
'((f).init ? (',
'fclose((f).fp), ', (* LIB *)
'0) : 0), (f).fp = NULL');
writeln(define, 'Closex(f) (f).init = ',
'((f).init ? ',
'(Finish(f), ',
'fclose((f).fp), ', (* LIB *)
'0) : 0), (f).fp = NULL')
end;
if use(dreset) then
begin
writeln(ifdef, 'READONLY');
writeln(static, chartyp, tab1, 'Rmode[] = "r";');
writeln(elsif);
writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
writeln(endif);
writeln(define, 'Reset(f, n) (f).init = ',
'(f).init ? rewind((f).fp) : ', (* LIB *)
'(((f).fp = Fopen(n, Rmode)), 1), ',
'(f).eof = (f).out = 0, Get(f)');
writeln(define, 'Resetx(f, n) (f).init = ',
'(f).init ? (Finish(f)) : ',
'(((f).fp = Fopen(n, Rmode)), 1), ',
'(f).eof = (f).out = 0, Getx(f)');
usefopn := true
end;
if use(drewrite) then
begin
writeln(ifdef, 'WRITEONLY');
writeln(static, chartyp, tab1, 'Wmode[] = "w";');
writeln(elsif);
writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
writeln(endif);
writeln(define, 'Rewrite(f, n) (f).init = ',
'(f).init ? rewind((f).fp) : ', (* LIB *)
'(((f).fp = Fopen(n, Wmode)), 1), ',
'(f).out = (f).eof = 1');
writeln(define, 'Rewritex(f, n) (f).init = ',
'(f).init ? (Finish(f)) : ',
'(((f).fp = Fopen(n, Wmode)), 1), ',
'(f).out = (f).eof = (f).eoln = 1');
usefopn := true
end;
if usefopn then
begin
writeln('FILE *Fopen();');
writeln(define, 'MAXFILENAME 256')
end;
if usecase or usejmps then
begin
writeln('/', '*');
writeln('** Definitions for case-statements');
writeln('** and for non-local gotos');
writeln('*', '/');
writeln(define, 'Line __LINE__');
writeln(voidtyp, tab1, 'Caseerror();')
end;
if usejmps then
begin
writeln(include, '<setjmp.h>'); (* LIB *)
writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
(maxlevel+1):1, '];')
end;
if use(dinteger) or use(dmaxint) or
use(dboolean) or use(dfalse) or use(dtrue) or
use(deof) or use(deoln) or use(dexp) or
use(dln) or use(dsqr) or use(dsin) or
use(dcos) or use(dtan) or use(darctan) or
use(dsqrt) or use(dreal) then
begin
writeln('/', '*');
writeln('** Definitions for standard types');
writeln('*', '/')
end;
if usecomp then
begin
writeln(xtern, inttyp, ' strncmp();'); (* LIB *)
writeln(define,
'Cmpstr(x, y) ',
'strncmp((x), (y), sizeof(x))') (* LIB *)
end;
if use(dboolean) or use(dfalse) or use(dtrue) or
use(deof) or use(deoln) or usesets then
begin
capital(defnams[dboolean]);
write(typdef, chartyp, tab1);
printid(defnams[dboolean]^.lid);
writeln(';');
capital(defnams[dfalse]);
write(define);
printid(defnams[dfalse]^.lid);
write(' (');
printid(defnams[dboolean]^.lid);
writeln(')0');
capital(defnams[dtrue]);
write(define);
printid(defnams[dtrue]^.lid);
write(' (');
printid(defnams[dboolean]^.lid);
writeln(')1');
writeln(xtern, chartyp, tab1, '*Bools[];')
end;
capital(defnams[dinteger]);
if use(dinteger) then
begin
write(typdef, inttyp, tab1);
printid(defnams[dinteger]^.lid);
writeln(';')
end;
if use(dmaxint) then
writeln(define, 'maxint', tab1, maxint:1);
capital(defnams[dreal]);
if use(dreal) then
begin
write(typdef, realtyp, tab1);
printid(defnams[dreal]^.lid);
writeln(';')
end;
if use(dexp) then
writeln(xtern, doubletyp, ' exp();'); (* LIB *)
if use(dln) then
writeln(xtern, doubletyp, ' log();'); (* LIB *)
if use(dsqr) then
writeln(xtern, doubletyp, ' pow();'); (* LIB *)
if use(dsin) then
writeln(xtern, doubletyp, ' sin();'); (* LIB *)
if use(dcos) then
writeln(xtern, doubletyp, ' cos();'); (* LIB *)
if use(dtan) then
writeln(xtern, doubletyp, ' tan();'); (* LIB *)
if use(darctan) then
writeln(xtern, doubletyp, ' atan();'); (* LIB *)
if use(dsqrt) then
writeln(xtern, doubletyp, ' sqrt();'); (* LIB *)
if use(dabs) and use(dreal) then
writeln(xtern, doubletyp, ' fabs();'); (* LIB *)
if use(dhalt) then
writeln(xtern, voidtyp, ' abort();'); (* LIB *)
if use(dnew) or usenilp then
begin
writeln('/', '*');
writeln('** Definitions for pointers');
writeln('*', '/');
end;
if use(dnew) then
begin
writeln(ifndef, 'Unionoffs');
writeln(define, 'Unionoffs(p, m) ',
'(((long)(&(p)->m))-((long)(p)))'); (* CPU *)
writeln(endif)
end;
if usenilp then
writeln(define, 'NIL 0'); (* CPU *)
if use(dnew) then
writeln(xtern, chartyp, ' *malloc();'); (* LIB *)
if use(ddispose) then
writeln(xtern, voidtyp, ' free();'); (* LIB *)
if usesets then
begin
writeln('/', '*');
writeln('** Definitions for set-operations');
writeln('*', '/');
writeln(define, 'Claimset() ',
voidcast, 'Currset(0, (', setptyp, ')0)');
writeln(define, 'Newset() ',
'Currset(1, (', setptyp, ')0)');
writeln(define, 'Saveset(s) Currset(2, s)');
writeln(define, 'setbits ', setbits:1);
writeln(typdef, wordtype, tab1, setwtyp, ';');
writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
printid(defnams[dboolean]^.lid);
writeln(tab1, 'Member(), Le(), Ge(), Eq(), Ne();');
writeln(setptyp, tab1, 'Union(), Diff();');
writeln(setptyp, tab1, 'Insmem(), Mksubr();');
writeln(setptyp, tab1, 'Currset(), Inter();');
writeln(static, setptyp, tab1, 'Tmpset;');
writeln(xtern, setptyp, tab1, 'Conset[];');
writeln(voidtyp, tab1, 'Setncpy();')
end;
writeln(xtern, chartyp, ' *strncpy();'); (* LIB *)
if use(dargc) or use(dargv) then
begin
writeln('/', '*');
writeln('** Definitions for argv-operations');
writeln('*', '/');
writeln(inttyp, tab1, 'argc;'); (* OS *)
writeln(chartyp, tab1, '**argv;');
writeln(' void');
writeln('Argvgt(n, cp, l)');
writeln(inttyp, tab1, 'n;');
writeln(registr, inttyp, tab1, 'l;');
writeln(registr, chartyp, tab1, '*cp;');
writeln('{');
writeln(tab1, registr, chartyp, tab1, '*sp;');
writeln;
writeln(tab1, 'for (sp = argv[n]; l > 0 && *sp; l--)');
writeln(tab2, '*cp++ = *sp++;');
writeln(tab1, 'while (l-- > 0)');
writeln(tab2, '*cp++ = ', spchr, ';');
writeln('}');
end;
if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
(tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
begin
writeln('/', '*');
writeln('** Start of program definitions');
writeln('*', '/');
end;
econst(tp^.tsubconst);
etype(tp^.tsubtype);
evar(tp^.tsubvar);
if tp^.tsubsub <> nil then
writeln;
esubr(tp^.tsubsub);
if tp^.tsubid <> nil then
begin
(* program heading was seen *)
writeln('/', '*');
writeln('** Start of program code');
writeln('*', '/');
if use(dargc) or use(dargv) then
begin
writeln('main(_ac, _av)'); (* OS *)
writeln(inttyp, tab1, '_ac;');
writeln(chartyp, tab1, '*_av[];');
writeln('{');
writeln;
writeln(tab1, 'argc = _ac;');
writeln(tab1, 'argv = _av;')
end
else begin
writeln('main()');
writeln('{')
end;
increment;
elabel(tp);
estmt(tp^.tsubstmt);
indent;
writeln('exit(0);');
decrement;
writeln('}');
writeln('/', '*');
writeln('** End of program code');
writeln('*', '/')
end
end; (* eprogram *)
(* Emit definitions for constant sets *)
procedure econset(tp : treeptr; len : integer);
var i : integer;
function size(tp : treeptr) : integer;
var r, x : integer;
begin
r := 0;
while tp <> nil do
begin
if tp^.tt = nrange then
x := cvalof(tp^.texpr)
else if tp^.tt = nempty then
x := 0
else
x := cvalof(tp);
if x > r then
r := x;
tp := tp^.tnext
end;
size := csetwords(r+1)
end;
(* Emit bits in a constant set *)
procedure ebits(tp : treeptr);
type bitset = set of 0 .. setbits;
var sets : array [ 0 .. maxsetrange ] of bitset;
s, m, n : integer;
procedure eword(s : bitset);
const bitshex = 4; (* nr of bits in a hex-digit *)
var n, i : integer;
x : 0 .. setbits;
begin
n := 0;
while n <= setbits do
n := n + bitshex;
n := n - bitshex;
while n >= 0 do
begin
(* compute 1 hexdigit *)
x := 0;
for i := 0 to bitshex - 1 do
if (n + i) in s then
case i of
0: x := x + 1;
1: x := x + 2;
2: x := x + 4;
3: x := x + 8
end;(* case *)
(* print it *)
write(hexdig[x]);
n := n - bitshex
end
end;
begin
s := size(tp);
for n := 0 to s - 1 do
sets[n] := [];
while tp <> nil do
begin
if tp^.tt = nrange then
for m := cvalof(tp^.texpl) to
cvalof(tp^.texpr) do
begin
n := m div (setbits+1);
sets[n] := sets[n] +
[m mod (setbits+1)]
end
else if tp^.tt <> nempty then
begin
m := cvalof(tp);
n := m div (setbits+1);
sets[n] := sets[n] +
[m mod (setbits+1)]
end;
tp := tp^.tnext
end;
write(tab1, s:1);
for n := 0 to s - 1 do
begin
write(',');
if n mod 6 = 0 then
writeln;
write(tab1, '0x');
eword(sets[n]);
end;
writeln
end;
begin
i := 0;
while tp <> nil do
begin
writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
ebits(tp^.texps);
writeln('};');
i := i + 1;
tp := tp^.tnext
end;
writeln(static, setwtyp, tab1, '*Conset[] = {');
for i := len - 1 downto 1 do
begin
write(tab1, 'Q', i:1, ',');
if i mod 6 = 5 then
writeln
end;
writeln(tab1, 'Q0');
writeln('};');
end;
begin (* emit *)
indnt := 0;
varno := 0;
conflag := false;
setused := false;
dropset := false;
doarrow := 0;
eprogram(top);
if usebool then
writeln(chartyp, tab1, '*Bools[] = { "false", "true" };');
if usescan then
begin
writeln;
writeln(static, voidtyp);
writeln('Scanck(n)');
writeln(inttyp, tab1, 'n;');
writeln('{');
writeln(tab1, 'if (n != 1) {');
writeln(tab2, voidcast, 'fprintf(stderr, "Bad input\n");');
writeln(tab2, 'exit(1);');
writeln(tab1, '}');
writeln('}')
end;
if usegetl then
begin
writeln;
writeln(static, voidtyp);
writeln('Getl(f)');
writeln(' text', tab1, '*f;');
writeln('{');
writeln(tab1, 'while (f->eoln == 0)');
writeln(tab2, 'Getx(*f);');
writeln(tab1, 'Getx(*f);');
writeln('}')
end;
if usefopn then
begin
writeln;
writeln(static, 'FILE *');
writeln('Fopen(n, m)');
writeln(chartyp, tab1, '*n, *m;');
writeln('{');
writeln(tab1, 'FILE', tab2, '*f;');
writeln(tab1, registr, chartyp, tab1, '*s;');
writeln(tab1, static, chartyp, tab1, 'ch = ',
quote, 'A', quote, ';');
writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];');
writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *)
writeln;
writeln(tab1, 'if (n == NULL)');
writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
writeln(tab1, 'else {');
writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
spchr, ' || *s == ', nulchr, '; )');
writeln(tab3, '*s-- = ', nulchr, ';');
writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
quote, '%s', quote, '\n", n);');
writeln(tab3, 'exit(1);');
writeln(tab2, '}');
writeln(tab1, '}');
writeln(tab1, 's = tmp;');
writeln(tab1, 'if ((f = fopen(s, m)) == NULL) {');
writeln(tab2, voidcast,
'fprintf(stderr, "Cannot open: %s\n", s);');
writeln(tab2, 'exit(1);');
writeln(tab1, '}');
writeln(tab1, 'if (n == NULL)');
writeln(tab2, 'unlink(tmp);'); (* OS *)
writeln(tab1, 'return (f);');
writeln('}');
writeln(xtern, inttyp, tab1, 'rewind();')
end;
if setcnt > 0 then
econset(setlst, setcnt);
if useunion then
begin
writeln;
writeln(static, setptyp);
writeln('Union(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
writeln(tab4, 'p3 = sp;');
writeln;
writeln(tab1, 'j = *p1;');
writeln(tab1, '*p3 = j;');
writeln(tab1, 'if (j > *p2)');
writeln(tab2, 'j = *p2;');
writeln(tab1, 'else');
writeln(tab2, '*p3 = *p2;');
writeln(tab1, 'k = *p1 - *p2;');
writeln(tab1, 'p1++, p2++, p3++;');
writeln(tab1, 'for (i = 0; i < j; i++)');
writeln(tab2, '*p3++ = (*p1++ | *p2++);');
writeln(tab1, 'while (k > 0) {');
writeln(tab2, '*p3++ = *p1++;');
writeln(tab2, 'k--;');
writeln(tab1, '}');
writeln(tab1, 'while (k < 0) {');
writeln(tab2, '*p3++ = *p2++;');
writeln(tab2, 'k++;');
writeln(tab1, '}');
writeln(tab1, 'return (Saveset(sp));');
writeln('}')
end;
if usediff then
begin
writeln;
writeln(static, setptyp);
writeln('Diff(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
writeln(tab4, 'p3 = sp;');
writeln;
writeln(tab1, 'j = *p1;');
writeln(tab1, '*p3 = j;');
writeln(tab1, 'if (j > *p2)');
writeln(tab2, 'j = *p2;');
writeln(tab1, 'k = *p1 - *p2;');
writeln(tab1, 'p1++, p2++, p3++;');
writeln(tab1, 'for (i = 0; i < j; i++)');
writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
writeln(tab1, 'while (k > 0) {');
writeln(tab2, '*p3++ = *p1++;');
writeln(tab2, 'k--;');
writeln(tab1, '}');
writeln(tab1, 'return (Saveset(sp));');
writeln('}')
end;
if useintr then
begin
writeln;
writeln(static, setptyp);
writeln('Inter(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
writeln(tab4, 'p3 = sp;');
writeln;
writeln(tab1, 'if ((j = *p1) > *p2)');
writeln(tab2, 'j = *p2;');
writeln(tab1, '*p3 = j;');
writeln(tab1, 'p1++, p2++, p3++;');
writeln(tab1, 'for (i = 0; i < j; i++)');
writeln(tab2, '*p3++ = (*p1++ & *p2++);');
writeln(tab1, 'return (Saveset(sp));');
writeln('}')
end;
if usememb then
begin
writeln;
write(static);
printid(defnams[dboolean]^.lid);
writeln;
writeln('Member(m, sp)');
writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
writeln(tab1, registr, setptyp, tab1, 'sp;');
writeln('{');
writeln(tab1, registr, usigned, inttyp,
tab1, 'i = m / (setbits+1) + 1;');
writeln;
writeln(tab1, 'if ((i <= *sp) &&',
' (sp[i] & (1 << (m % (setbits+1)))))');
write(tab2, 'return (');
printid(defnams[dtrue]^.lid);
writeln(');');
write(tab1, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln('}')
end;
if useseq or usesne then
begin
writeln;
write(static);
printid(defnams[dboolean]^.lid);
writeln;
writeln('Eq(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
writeln(tab1, registr, inttyp, tab1, 'i, j;');
writeln;
writeln(tab1, 'i = *p1++;');
writeln(tab1, 'j = *p2++;');
writeln(tab1, 'while (i != 0 && j != 0) {');
writeln(tab2, 'if (*p1++ != *p2++)');
write(tab3, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln(tab2, 'i--, j--;');
writeln(tab1, '}');
writeln(tab1, 'while (i != 0) {');
writeln(tab2, 'if (*p1++ != 0)');
write(tab3, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln(tab2, 'i--;');
writeln(tab1, '}');
writeln(tab1, 'while (j != 0) {');
writeln(tab2, 'if (*p2++ != 0)');
write(tab3, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln(tab2, 'j--;');
writeln(tab1, '}');
write(tab1, 'return (');
printid(defnams[dtrue]^.lid);
writeln(');');
writeln('}')
end;
if usesne then
begin
writeln;
write(static);
printid(defnams[dboolean]^.lid);
writeln;
writeln('Ne(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
write(tab1, 'return (!Eq(p1, p2));');
writeln('}')
end;
if usesle then
begin
writeln;
write(static);
printid(defnams[dboolean]^.lid);
writeln;
writeln('Le(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
writeln(tab1, registr, inttyp, tab1, 'i, j;');
writeln;
writeln(tab1, 'i = *p1++;');
writeln(tab1, 'j = *p2++;');
writeln(tab1, 'while (i != 0 && j != 0) {');
writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
write(tab3, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln(tab2, 'i--, j--;');
writeln(tab1, '}');
writeln(tab1, 'while (i != 0) {');
writeln(tab2, 'if (*p1++ != 0)');
write(tab3, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln(tab2, 'i--;');
writeln(tab1, '}');
write(tab1, 'return (');
printid(defnams[dtrue]^.lid);
writeln(');');
writeln('}')
end;
if usesge then
begin
writeln;
write(static);
printid(defnams[dboolean]^.lid);
writeln;
writeln('Ge(p1, p2)');
writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
writeln('{');
writeln(tab1, registr, inttyp, tab1, 'i, j;');
writeln;
writeln(tab1, 'i = *p1++;');
writeln(tab1, 'j = *p2++;');
writeln(tab1, 'while (i != 0 && j != 0) {');
writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
writeln(tab3, 'return (false);');
writeln(tab2, 'i--, j--;');
writeln(tab1, '}');
writeln(tab1, 'while (j != 0) {');
writeln(tab2, 'if (*p2++ != 0)');
write(tab3, 'return (');
printid(defnams[dfalse]^.lid);
writeln(');');
writeln(tab2, 'j--;');
writeln(tab1, '}');
write(tab1, 'return (');
printid(defnams[dtrue]^.lid);
writeln(');');
writeln('}')
end;
if usemksub then
begin
writeln;
writeln(static, setptyp);
writeln('Mksubr(lo, hi, sp)');
writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
writeln(tab1, registr, setptyp, tab1, 'sp;');
writeln('{');
writeln(tab1, registr, inttyp, tab1, 'i, k;');
writeln;
writeln(tab1, 'if (hi < lo)');
writeln(tab2, 'return (sp);');
writeln(tab1, 'i = hi / (setbits+1) + 1;');
writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
writeln(tab2, 'sp[k] = 0;');
writeln(tab1, 'if (*sp < i)');
writeln(tab2, '*sp = i;');
writeln(tab1, 'for (k = lo; k <= hi; k++)');
writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
'(1 << (k % (setbits+1)));');
writeln(tab1, 'return (sp);');
writeln('}')
end;
if useins then
begin
writeln;
writeln(static, setptyp);
writeln('Insmem(m, sp)');
writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
writeln(tab1, registr, setptyp, tab1, 'sp;');
writeln('{');
writeln(tab1, registr, inttyp, tab1, 'i,');
writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
writeln;
writeln(tab1, 'if (*sp < j)');
writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
writeln(tab3, 'sp[i] = 0;');
writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
writeln(tab1, 'return (sp);');
writeln('}')
end;
if usesets then
begin
writeln;
writeln(ifndef, 'SETSPACE');
writeln(define, 'SETSPACE 256');
writeln(endif);
writeln(static, setptyp);
writeln('Currset(n,sp)');
writeln(tab1, inttyp, tab1, 'n;');
writeln(tab1, setptyp, tab1, 'sp;');
writeln('{');
writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
writeln(tab1, static, setptyp, tab1, 'Top = Space;');
writeln;
writeln(tab1, 'switch (n) {');
writeln(tab1, ' case 0:');
writeln(tab2, 'Top = Space;');
writeln(tab2, 'return (0);');
writeln(tab1, ' case 1:');
writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
maxsetrange:1, ') {');
writeln(tab3,
voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
writeln(tab3, 'exit(1);');
writeln(tab2, '}');
writeln(tab2, '*Top = 0;');
writeln(tab2, 'return (Top);');
writeln(tab1, ' case 2:');
writeln(tab2, 'if (Top <= &sp[*sp])');
writeln(tab3, 'Top = &sp[*sp + 1];');
writeln(tab2, 'return (sp);');
writeln(tab1, '}');
writeln(tab1, '/', '* NOTREACHED *', '/');
writeln('}')
end;
if usescpy then
begin
writeln;
writeln(static, voidtyp);
writeln('Setncpy(S1, S2, N)');
writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
writeln('{');
writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
writeln;
writeln(tab1, 'N /= sizeof(', setwtyp, ');');
writeln(tab1, '*S1++ = --N;');
writeln(tab1, 'm = *S2++;');
writeln(tab1, 'while (m != 0 && N != 0) {');
writeln(tab2, '*S1++ = *S2++;');
writeln(tab2, '--N;');
writeln(tab2, '--m;');
writeln(tab1, '}');
writeln(tab1, 'while (N-- != 0)');
writeln(tab2, '*S1++ = 0;');
writeln('}')
end;
if usecase then
begin
writeln;
writeln(static, voidtyp);
writeln('Caseerror(n)');
writeln(tab1, inttyp, tab1, 'n;');
writeln('{');
writeln(tab1, voidcast,
'fprintf(stderr, "Missing case limb: line %d\n", n);');
writeln(tab1, 'exit(1);');
writeln('}')
end;
if usemax then
begin
writeln;
writeln(static, inttyp);
writeln('Max(m, n)');
writeln(tab1, inttyp, tab1, 'm, n;');
writeln('{');
writeln(tab1, 'if (m > n)');
writeln(tab2, 'return (m);');
writeln(tab1, 'return (n);');
writeln('}')
end;
if use(dtrunc) then
begin
writeln(static, inttyp);
writeln('Trunc(f)');
printid(defnams[dreal]^.lid);
writeln(tab1, 'f;');
writeln('{');
writeln(tab1, 'return f;');
writeln('}')
end;
if use(dround) then
begin
writeln(static, inttyp);
writeln('Round(f)');
printid(defnams[dreal]^.lid);
writeln(tab1, 'f;');
writeln('{');
writeln(tab1, xtern, doubletyp, ' floor();'); (* LIB *)
writeln(tab1,
'return floor(', dblcast, '(0.5+f));'); (* LIB *)
writeln('}')
end
end; (* emit *)
(* Initialize all global structures used in translator. *)
procedure initialize;
var s : hashtyp;
t : pretyps;
d : predefs;
(* Define names in ctable. *)
procedure defname(cn : cnames; str : keyword);
label 999;
var w : toknbuf;
i : toknidx;
begin
unpack(str, w, 1);
for i := 1 to keywordlen do
if w[i] = space then
begin
w[i] := chr(null);
goto 999
end;
w[keywordlen+1] := chr(null);
999:
ctable[cn] := saveid(w)
end;
(* Define predefined identifiers. *)
procedure defid(nt : treetyp; did : predefs; str : keyword);
label 999;
var w : toknbuf;
i : toknidx;
tp, tq,
tv : treeptr;
begin
for i := 1 to keywordlen do
if str[i] = space then
begin
w[i] := chr(null);
goto 999
end
else
w[i] := str[i];
w[keywordlen+1] := chr(null);
999:
tp := newid(saveid(w));
defnams[did] := tp^.tsym;
if nt in [ntype, nfunc, nproc] then
begin
(* predefined types, procedures and functions
are marked with a particular node *)
tv := mknode(npredef);
tv^.tdef := did;
tv^.tobtyp := tnone
end
else
tv := nil; (* predefined constants and variables will
eventually be bound to something *)
case nt of
nscalar:
begin
tv := mknode(nscalar);
tv^.tscalid := nil;
tq := mknode(ntype);
tq^.tbind := tv;
tq^.tidl := tp;
tp := tq
end;
nconst,
ntype,
nfield,
nvar:
begin
tq := mknode(nt);
tq^.tbind := tv;
tq^.tidl := tp;
tq^.tattr := anone;
tp := tq
end;
nfunc,
nproc:
begin
tq := mknode(nt);
tq^.tsubid := tp;
tq^.tsubstmt := tv;
tq^.tfuntyp := nil;
tq^.tsubpar := nil;
tq^.tsublab := nil;
tq^.tsubconst := nil;
tq^.tsubtype := nil;
tq^.tsubvar := nil;
tq^.tsubsub := nil;
tq^.tscope := nil;
tq^.tstat := 0;
tp := tq
end;
nid:
end;(* case *)
deftab[did] := tp
end; (* defid *)
(* Define keywords. *)
procedure defkey(s : symtyp; w : keyword);
var i : 1 .. keywordlen;
begin
for i := 1 to keywordlen do
if w[i] = space then
w[i] := chr(null);
(* relies on symtyp being sorted *)
with keytab[ord(s)] do
begin
wrd := w;
sym := s
end;
end;
procedure fixinit(i : strindx);
var t : toknbuf;
begin
gettokn(i, t);
t[1] := 'i';
puttokn(i, t);
end;
(* Add a cpu word type description. *)
(* Parameters lo and hi gives the range of a machine- *)
(* dependant integer type. Parameter str gives the corres- *)
(* ponding C-language type-name. *)
procedure defmach(lo, hi : integer; str : machdefstr);
label 999;
var i : toknidx;
w : toknbuf;
begin
unpack(str, w, 1);
if w[machdeflen] <> space then
error(ebadmach);
for i := machdeflen - 1 downto 1 do
if w[i] <> space then
begin
w[i+1] := chr(null);
goto 999
end;
error(ebadmach);
999:
if nmachdefs >= maxmachdefs then
error(emanymachs);
nmachdefs := nmachdefs + 1;
with machdefs[nmachdefs] do
begin
lolim := lo;
hilim := hi;
typstr := savestr(w)
end
end;
procedure initstrstore;
var i : strbcnt;
begin
for i := 1 to maxblkcnt do
strstor[i] := nil;
new(strstor[0]);
strstor[0]^[0] := chr(null);
strfree := 1;
strleft := maxstrblk
end;
begin (* initialize *)
lineno := 1;
colno := 0;
initstrstore;
setlst := nil;
setcnt := 0;
hexdig := '0123456789ABCDEF';
symtab := nil;
statlvl := 0;
maxlevel := -1;
enterscope(nil);
varno:= 0;
usenilp := false;
usesets := false;
useunion := false;
usediff := false;
usemksub := false;
useintr := false;
usesge := false;
usesle := false;
usesne := false;
useseq := false;
usememb := false;
useins := false;
usescpy := false;
usefopn := false;
usescan := false;
usegetl := false;
usecase := false;
usejmps := false;
usebool := false;
usecomp := false;
usemax := false;
for s := 0 to hashmax do
idtab[s] := nil;
for d := dabs to dztring do
begin
deftab[d] := nil;
defnams[d] := nil
end;
(* Pascal keywords *)
defkey(sand, 'and ');
defkey(sarray, 'array ');
defkey(sbegin, 'begin ');
defkey(scase, 'case ');
defkey(sconst, 'const ');
defkey(sdiv, 'div ');
defkey(sdo, 'do ');
defkey(sdownto, 'downto ');
defkey(selse, 'else ');
defkey(send, 'end ');
defkey(sextern, externsym); (* non-standard *)
defkey(sfile, 'file ');
defkey(sfor, 'for ');
defkey(sforward,'forward ');
defkey(sfunc, 'function ');
defkey(sgoto, 'goto ');
defkey(sif, 'if ');
defkey(sinn, 'in ');
defkey(slabel, 'label ');
defkey(smod, 'mod ');
defkey(snil, 'nil ');
defkey(snot, 'not ');
defkey(sof, 'of ');
defkey(sor, 'or ');
defkey(sother, othersym); (* non-standard *)
defkey(spacked, 'packed ');
defkey(sproc, 'procedure ');
defkey(spgm, 'program ');
defkey(srecord, 'record ');
defkey(srepeat, 'repeat ');
defkey(sset, 'set ');
defkey(sthen, 'then ');
defkey(sto, 'to ');
defkey(stype, 'type ');
defkey(suntil, 'until ');
defkey(svar, 'var ');
defkey(swhile, 'while ');
defkey(swith, 'with ');
defkey(seof, dummysym); (* dummy entry *)
(* C language operator priorities *)
cprio[nformat] := 0;
cprio[nrange] := 0;
cprio[nin] := 0;
cprio[nset] := 0;
cprio[nassign] := 0;
cprio[nor] := 1;
cprio[nand] := 2;
cprio[neq] := 3;
cprio[nne] := 3;
cprio[nlt] := 3;
cprio[nle] := 3;
cprio[ngt] := 3;
cprio[nge] := 3;
cprio[nplus] := 4;
cprio[nminus] := 4;
cprio[nmul] := 5;
cprio[ndiv] := 5;
cprio[nmod] := 5;
cprio[nquot] := 5;
cprio[nnot] := 6;
cprio[numinus] := 6;
cprio[nuplus] := 7;
cprio[nindex] := 7;
cprio[nselect] := 7;
cprio[nderef] := 7;
cprio[ncall] := 7;
cprio[nid] := 7;
cprio[nchar] := 7;
cprio[ninteger] := 7;
cprio[nreal] := 7;
cprio[nstring] := 7;
cprio[nnil] := 7;
(* Pascal language operator priorities *)
pprio[nassign] := 0;
pprio[nformat] := 0;
pprio[nrange] := 1;
pprio[nin] := 1;
pprio[neq] := 1;
pprio[nne] := 1;
pprio[nlt] := 1;
pprio[nle] := 1;
pprio[ngt] := 1;
pprio[nge] := 1;
pprio[nor] := 2;
pprio[nplus] := 2;
pprio[nminus] := 2;
pprio[nand] := 3;
pprio[nmul] := 3;
pprio[ndiv] := 3;
pprio[nmod] := 3;
pprio[nquot] := 3;
pprio[nnot] := 4;
pprio[numinus] := 4;
pprio[nuplus] := 5;
pprio[nset] := 6;
pprio[nindex] := 6;
pprio[nselect] := 6;
pprio[nderef] := 6;
pprio[ncall] := 6;
pprio[nid] := 6;
pprio[nchar] := 6;
pprio[ninteger] := 6;
pprio[nreal] := 6;
pprio[nstring] := 6;
pprio[nnil] := 6;
(* table of C keywords/functions (which Pascal doesn't know about) *)
defname(cabort, 'abort '); (* OS *)
defname(cbreak, 'break ');
defname(ccontinue, 'continue ');
defname(cdefine, 'define ');
defname(cdefault, 'default ');
defname(cdouble, 'double ');
defname(cedata, 'edata '); (* OS *)
defname(cenum, 'enum ');
defname(cetext, 'etext '); (* OS *)
defname(cextern, 'extern ');
defname(cfclose, 'fclose '); (* LIB *)
defname(cfflush, 'fflush '); (* LIB *)
defname(cfgetc, 'fgetc '); (* LIB *)
defname(cfloat, 'float ');
defname(cfloor, 'floor '); (* OS *)
defname(cfprintf, 'fprintf '); (* LIB *)
defname(cfputc, 'fputc '); (* LIB *)
defname(cfread, 'fread '); (* LIB *)
defname(cfscanf, 'fscanf '); (* LIB *)
defname(cfwrite, 'fwrite '); (* LIB *)
defname(cgetc, 'getc '); (* OS *)
defname(cgetpid, 'getpid '); (* OS *)
defname(cint, 'int ');
defname(cinclude, 'include ');
defname(clong, 'long ');
defname(clog, 'log '); (* OS *)
defname(cmain, 'main ');
defname(cmalloc, 'malloc '); (* LIB *)
defname(cprintf, 'printf '); (* LIB *)
defname(cpower, 'pow '); (* OS *)
defname(cputc, 'putc '); (* LIB *)
defname(cread, 'read '); (* OS *)
defname(creturn, 'return ');
defname(cregister, 'register ');
defname(crewind, 'rewind '); (* LIB *)
defname(cscanf, 'scanf '); (* LIB *)
defname(csetbits, 'setbits ');
defname(csetword, 'setword ');
defname(csetptr, 'setptr ');
defname(cshort, 'short ');
defname(csigned, 'signed ');
defname(csizeof, 'sizeof ');
defname(csprintf, 'sprintf '); (* LIB *)
defname(cstatic, 'static ');
defname(cstdin, 'stdin '); (* LIB *)
defname(cstdout, 'stdout '); (* LIB *)
defname(cstderr, 'stderr '); (* LIB *)
defname(cstrncmp, 'strncmp '); (* OS *)
defname(cstrncpy, 'strncpy '); (* OS *)
defname(cstruct, 'struct ');
defname(cswitch, 'switch ');
defname(ctypedef, 'typedef ');
defname(cundef, 'undef ');
defname(cungetc, 'ungetc '); (* LIB *)
defname(cunion, 'union ');
defname(cunlink, 'unlink '); (* OS *)
defname(cunsigned, 'unsigned ');
defname(cwrite, 'write '); (* OS *)
(* create predefined identifiers *)
defid(nfunc, dabs, 'abs ');
defid(nfunc, darctan, 'arctan ');
defid(nvar, dargc, 'argc '); (* OS *)
defid(nproc, dargv, 'argv '); (* OS *)
defid(nscalar, dboolean, 'boolean ');
defid(ntype, dchar, 'char ');
defid(nfunc, dchr, 'chr ');
defid(nproc, dclose, 'close '); (* OS *)
defid(nfunc, dcos, 'cos ');
defid(nproc, ddispose, 'dispose ');
defid(nid, dfalse, 'false ');
defid(nfunc, deof, 'eof ');
defid(nfunc, deoln, 'eoln ');
defid(nproc, dexit, 'exit '); (* OS *)
defid(nfunc, dexp, 'exp ');
defid(nproc, dflush, 'flush '); (* OS *)
defid(nproc, dget, 'get ');
defid(nproc, dhalt, 'halt '); (* OS *)
defid(nvar, dinput, 'input ');
defid(ntype, dinteger, 'integer ');
defid(nfunc, dln, 'ln ');
defid(nconst, dmaxint, 'maxint ');
defid(nproc, dmessage, 'message '); (* OS *)
defid(nproc, dnew, 'new ');
defid(nfunc, dodd, 'odd ');
defid(nfunc, dord, 'ord ');
defid(nvar, doutput, 'output ');
defid(nproc, dpack, 'pack ');
defid(nproc, dpage, 'page ');
defid(nfunc, dpred, 'pred ');
defid(nproc, dput, 'put ');
defid(nproc, dread, 'read ');
defid(nproc, dreadln, 'readln ');
defid(ntype, dreal, 'real ');
defid(nproc, dreset, 'reset ');
defid(nproc, drewrite, 'rewrite ');
defid(nfunc, dround, 'round ');
defid(nfunc, dsin, 'sin ');
defid(nfunc, dsqr, 'sqr ');
defid(nfunc, dsqrt, 'sqrt ');
defid(nfunc, dsucc, 'succ ');
defid(ntype, dtext, 'text ');
defid(nid, dtrue, 'true ');
defid(nfunc, dtrunc, 'trunc ');
defid(nfunc, dtan, 'tan ');
defid(nproc, dunpack, 'unpack ');
defid(nproc, dwrite, 'write ');
defid(nproc, dwriteln, 'writeln ');
defid(nfield, dzinit, '$nit '); (* for internal use *)
defid(ntype, dztring, '$ztring ');
(* bind constants and variables *)
deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
deftab[dfalse]^.tnext := deftab[dtrue];
currsym.st := sinteger;
currsym.vint := maxint;
deftab[dmaxint]^.tbind := mklit;
deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
deftab[dinput]^.tbind := deftab[dtext]^.tbind;
deftab[doutput]^.tbind := deftab[dtext]^.tbind;
for t := tnone to terror do
begin
(* for predefined types: set up pointers to "npredef" nodes
describing type, fill in constant identifying type *)
case t of
tboolean:
typnods[t] := deftab[dboolean]; (* scalar type *)
tchar:
typnods[t] := deftab[dchar]^.tbind;
tinteger:
typnods[t] := deftab[dinteger]^.tbind;
treal:
typnods[t] := deftab[dreal]^.tbind;
ttext:
typnods[t] := deftab[dtext]^.tbind;
tstring:
typnods[t] := deftab[dztring]^.tbind;
tnil,
tset,
tpoly,
tnone:
typnods[t] := mknode(npredef);
terror:
(* no op *)
end;(* case *)
if t in [tchar, tinteger, treal, ttext, tnone, tpoly,
tstring, tnil, tset] then
typnods[t]^.tobtyp := t
end;
(* fix name and type of field "init" *)
fixinit(defnams[dzinit]^.lid^.istr);
deftab[dzinit]^.tbind := deftab[dinteger]^.tbind;
for d := dabs to dztring do
linkup(nil, deftab[d]);
deftab[dchr]^.tfuntyp := typnods[tchar];
deftab[deof]^.tfuntyp := typnods[tboolean];
deftab[deoln]^.tfuntyp := typnods[tboolean];
deftab[dodd]^.tfuntyp := typnods[tboolean];
deftab[dord]^.tfuntyp := typnods[tinteger];
deftab[dround]^.tfuntyp := typnods[tinteger];
deftab[dtrunc]^.tfuntyp := typnods[tinteger];
deftab[darctan]^.tfuntyp := typnods[treal];
deftab[dcos]^.tfuntyp := typnods[treal];
deftab[dsin]^.tfuntyp := typnods[treal];
deftab[dtan]^.tfuntyp := typnods[treal];
deftab[dsqrt]^.tfuntyp := typnods[treal];
deftab[dexp]^.tfuntyp := typnods[treal];
deftab[dln]^.tfuntyp := typnods[treal];
deftab[dsqr]^.tfuntyp := typnods[tpoly];
deftab[dabs]^.tfuntyp := typnods[tpoly];
deftab[dpred]^.tfuntyp := typnods[tpoly];
deftab[dsucc]^.tfuntyp := typnods[tpoly];
deftab[dargv]^.tfuntyp := typnods[tnone];
deftab[ddispose]^.tfuntyp := typnods[tnone];
deftab[dexit]^.tfuntyp := typnods[tnone];
deftab[dget]^.tfuntyp := typnods[tnone];
deftab[dhalt]^.tfuntyp := typnods[tnone];
deftab[dnew]^.tfuntyp := typnods[tnone];
deftab[dpack]^.tfuntyp := typnods[tnone];
deftab[dput]^.tfuntyp := typnods[tnone];
deftab[dread]^.tfuntyp := typnods[tnone];
deftab[dreadln]^.tfuntyp := typnods[tnone];
deftab[dreset]^.tfuntyp := typnods[tnone];
deftab[drewrite]^.tfuntyp := typnods[tnone];
deftab[dwrite]^.tfuntyp := typnods[tnone];
deftab[dwriteln]^.tfuntyp := typnods[tnone];
deftab[dmessage]^.tfuntyp := typnods[tnone];
deftab[dunpack]^.tfuntyp := typnods[tnone];
(* set up definitions for integer subranges *)
nmachdefs := 0;
defmach(0, 255, 'unsigned char '); (* CPU *)
defmach(-128, 127, 'char '); (* CPU *)
defmach(0, 65535, 'unsigned short '); (* CPU *)
defmach(-32768, 32767, 'short '); (* CPU *)
defmach(-2147483647, 2147483647, 'long '); (* CPU *)
{ defmach(0, 4294967295, 'unsigned long ');}(* CPU *)
end; (* initialize *)
procedure exit(i : integer); external; (* OS *)
(* Action to take when an error is detected. *)
procedure error;
begin
prtmsg(m);
exit(1); (* OS *)
goto 9999
end;
(* Action to take when a fatal error is detected. *)
procedure fatal;
begin
prtmsg(m);
halt (* OS *)
(* goto 9999 *)
end;
begin (* program *)
initialize;
if echo then
writeln('# ifdef PASCAL');
parse;
if echo then
writeln('# else');
lineno := 0; lastline := 0;
transform;
emit;
if echo then
writeln('# endif');
9999:
(* the very *)
end.