(***************************************************************************)
(***************************************************************************)
(**									  **)
(**	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(), fseek() 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, erroutput);

label	9999;				(* end of program		*)

const	version		= '@(#)ptc.p	2.6  Date 87/09/12';
	rcsid		= '$Id: ptc.p,v 1.17 90/03/27 16:24:55 tml Exp $';
	rcsrevision	= '$Revision: 1.17 $';

	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 int';	(* CPU *)
	setbits		= 31;			(* CPU *)

	maxsetrange	= 32;			(* 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	= 1023;
	maxstrstor	= 1048575; (* 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		= 512;	(* 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		= 255;	(* greatest possible character, CHAR; limits
				   the number of elements in type "char" *)

	(* some frequently used characters *)
	space		= ' ';
	tab		= '	';
	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	*)

	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		= 'unsigned char';
	setwtyp		= 'setword';
	setptyp		= 'setptr';
	floattyp	= 'float';
	doubletyp	= 'double';
	dblcast		= '(double)';	(* for predefined functions	*)

	realtyp		= floattyp;	(* user real-vars and functions	*)

	voidtyp		= 'void';	(* for procedures 		*)
	voidcast	= '(void)';

	align		= true;		(* align literal params		*)

	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	= integer; (* 0 .. maxstrblk+1; *)
		(* integer because many varibles of this type in fact get
		  the value maxstrblk+1.  Argh, Pascal subranges are
		  stupid. *) 
	strblk	= array [ 0 .. maxstrblk ] 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	: integer;	(* # 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,
		derroutput,
		dexit,		dexp,		dfalse,		dflush,
		dget,		dhalt,		dinput,		dinteger,
		dln,		dmaxint,	         	dnew,
		dodd,		dord,		doutput,	dpage,
		dpack,		dpred,		dput,		dprompt,
								dread,
		dreadln,	dreal,		dreset,		drewrite,
		dround,		dseek,
				dsin,		dsqr,		dsqrt,
		dsucc,		dtell,
				dtext,		dtrue,		dtrunc,
		dtan,		dwrite,		dwriteln,	dunpack,
		dzfp,		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);

		  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,
		  splus,	sminus,		smul,		squot,
		  sarrow,	slpar,		srpar,		slbrack,
		  srbrack,	seq,		sne,		slt,
		  sle,		sgt,		sge,		scomma,
		  scolon,	ssemic,		sassign,	sdotdot,
		  sdot:		()
	    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:		(* -			*)
		    (
			tisassigndest:	(* used to prevent lazy i/o when
					   assigning to file buffer variable *)
				boolean;
			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,
		cfseek,		cgetchar,	cputchar,
		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,	eprconf
	);

	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	*)
	usealig,		(* source program uses aligned params	*)
	usesal : boolean;

	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	*)

	pushchr	: char;			(* pushback for lexical scanner	*)
	pushed	: boolean;

	hexdig	: array [ 0 .. 15 ] of char;
{ IF-PASCAL
	erroutput : text;
END-IF-PASCAL }

(*	Prtmsg produces an error message.                           	*)
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:
		writeln(erroutput, user, 'Unexpected symbol');
	  ebadchar:
		writeln(erroutput, user, 'Bad character');
	  elongstring:
		writeln(erroutput, restr, 'Too long string');
	  ebadstring:
		writeln(erroutput, user, 'Newline in string or character');
	  eeofstr:
		writeln(erroutput, user, 'End of file in string or character');
	  eeofcmnt:
		writeln(erroutput, user, 'End of file in comment');
	  elongtokn:
		writeln(erroutput, restr, 'Too long identfier');
	  emanytokn:
		writeln(erroutput, restr, 'Too many strings, identifiers or real numbers');
	  enotdeclid:
		writeln(erroutput, user, 'Identifier not declared');
	  emultdeclid:
		writeln(erroutput, user, 'Identifier declared twice');
	  enotdecllab:
		writeln(erroutput, user, 'Label not declared');
	  emultdecllab:
		writeln(erroutput, user, 'Label declared twice');
	  emuldeflab:
		writeln(erroutput, user, 'Label defined twice');
	  evarpar:
		writeln(erroutput, user, 'Actual parameter not a variable');
	  enulchr:
		writeln(erroutput, restr, 'Cannot handle nul-character in strings');
	  enew:
		writeln(erroutput, restr, 'New returned a nil-pointer');
	  eoverflow:
		writeln(erroutput, restr, 'Token buffer overflowed');
	  esetbase:
		writeln(erroutput, restr, 'Cannot handle sets with base >> 0');
	  esetsize:
		writeln(erroutput, restr, 'Cannot handle sets with very large range');
	  etree:
		writeln(erroutput, inter, 'Bad tree structure');
	  etag:
		writeln(erroutput, inter, 'Cannot find tag');
	  evrntfile:
		writeln(erroutput, restr, 'Cannot initialize files in record variants');
	  evarfile:
		writeln(erroutput, restr, 'Cannot handle files in structured variables');
	  euprconf:
		writeln(erroutput, inter, 'No upper bound on conformant arrays');
	  easgnconf:
		writeln(erroutput, inter, 'Cannot assign conformant arrays');
	  ecmpconf:
		writeln(erroutput, inter, 'Cannot compare conformant arrays');
	  econfconf:
		writeln(erroutput, restr, 'Cannot handle nested conformat arrays');
	  erange:
		writeln(erroutput, inter, 'Cannot find C-type for integer-subrange');
	  emanymachs:
		writeln(erroutput, restr, 'Too many machine integer types');
	  ebadmach:
		writeln(erroutput, inter, 'Bad name for machine integer type');
	  eprconf:
		writeln(erroutput, inter, 'Cannot write conformant arrays');
	end;(* case *)
	if lastline <> 0 then
	    begin
		(* error detected during parsing,
		    report line/column and print the offending symbol *)
		writeln(erroutput, '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;
			writeln(erroutput, 'Current symbol: ', xtok:i-1)
		    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 pushed then
		    begin
			c := pushchr;
			pushed := false
		    end
		else if eof then
			c := chr(null)
		else begin
			colno := colno + 1;
			if eoln then
			    begin
				lineno := lineno + 1;
				colno := 0
			    end;
			read(c);
			if c = tab then
				colno := (((colno - 1) 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 pushed then
			peekchar := pushchr
		else 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	: 0..maxtoknlen;
		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 <> tab);

		(* 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 and (peekchar = '.') then
				    begin
					c := nextchar;
					realok := numchar(peekchar);
					pushchr := c;
					pushed := true
				    end;
				if realok then
				    begin
					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 := 1;
				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
						wb[wl] := c;
						if wl >= maxtoknlen then
						    begin
							lasttok[lastchr] :=
								chr(null);
							error(elongstring)
						    end;
						wl := wl + 1;
					    end
				until	ready;
				if wl = 2 then
				    begin
					(* only 1 character => not a string *)
					st := schar;
					vchr := wb[1]
				    end
				else begin
					(* > 1 character => its a string *)
					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,
			der: idptr;

		begin
			tp := nil;
			din := deftab[dinput]^.tidl^.tsym^.lid;
			dut := deftab[doutput]^.tidl^.tsym^.lid;
			der := deftab[derroutput]^.tidl^.tsym^.lid;
			while (currsym.vid = din) or (currsym.vid = dut)
			or (currsym.vid = der) do
			    begin
				(* ignore input/output/erroutput as parameters
				   so that they will be bound to stdin/stdout/
				   stderr unless declared as variables *)
				if currsym.vid = din then
					defnams[dinput]^.lused := true
				else if currsym.vid = dut then
					defnams[doutput]^.lused := true
				else
					defnams[derroutput]^.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 if currsym.vid = der then
					defnams[derroutput]^.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]);
		nextsymbol([seof]);
		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, seof]);
		if currsym.st = ssemic then
			nextsymbol([seof]);
		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;

	procedure flagassigndest(tp : treeptr);

	begin
		if tp^.tt in [ nindex, nselect, nderef ] then
		    case tp^.tt of
		      nindex: flagassigndest(tp^.tvariable);
		      nselect: flagassigndest(tp^.trecord);
		      nderef: tp^.tisassigndest := true;
		    end
	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);
			flagassigndest(tp);
			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^.tisassigndest := false;
				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:
			tp := mknode(nnil);
		  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;
			tq^.tchocon := nil;
			tq^.tchostmt := nil;
			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;
			if currsym.st = ssemic then
			        nextsymbol([send])
		    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
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
						    sp^.lid :=
							mkrename('M', sp^.lid);
						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);
				global(tp^.tsubvar, tp, false);
				global(tp^.tsubtype, 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
					sp^.lid := mkrename('P', sp^.lid)
			    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[dzfp]^.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 ';
	undef	= '# undef ';
	ifdef	= '# ifdef ';
	ifndef	= '# ifndef ';
	elsif	= '# else';
	endif	= '# endif';
	static	= 'static ';
	xtern	= 'extern ';
	typdef	= 'typedef ';
	registr	= 'register ';
	usigned	= 'unsigned ';
	indstep	= 2;

var	conflag,
	setused,
	dropset	: boolean;
	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;

	(* Check if a type is represented in C as unsigned short or *)
	(* char, and thus should be cast to int in expressions to   *)
	(* preserve Pascal semantics				    *)
	function needsintcast(tp : treeptr) : boolean;

	begin
		tp := typeof(tp);
		if tp^.tt <> nsubrange then
			needsintcast := false
		else if clower(tp) < 0 then
			needsintcast := false
		else
			needsintcast := cupper(tp) <= 65535;
	end;

	procedure eexpr(tp : treeptr);				forward;
	procedure etypedef(tp : treeptr);			forward;

	(*	Emit code to select a record member.	*)
	procedure eselect(tp : treeptr);

	begin
		eexpr(tp);
		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;
			  'v':
				fatal(eprconf)
			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;
				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;
			  'v':
				fatal(eprconf)
			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('(unsigned char)(');
				eexpr(tp^.taparm);
				write(')')
			     end
		    end;
		  ddispose:
		    begin
			write('free(');				(* LIB *)
			eexpr(tp^.taparm);
			writeln(');')
		    end;
		  deof:
		    begin
			tq := tp^.taparm;
			if tq <> nil then
			    begin
				tv := typeof(tq);
				if tv = typnods[ttext] then
				    txtfile := true
				else if tv^.tt = nfileof then
				    txtfile := typeof(tv^.tof) =
						    typnods[tchar]
				else
				    txtfile := true
			    end
			else
			    txtfile := true;
			if txtfile then
			    write('Eofx(')
			else
			    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,
		  dprompt:
		    begin
			write('Flush(');
			if tp^.taparm = nil then
			    begin
				defnams[doutput]^.lused := true;
				printid(defnams[doutput]^.lid)
			    end
			else
				eexpr(tp^.taparm);
			writeln(');')
		    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
			tv := typeof(tp^.taparm);
			if (tv = typnods[ttext])
			or ((tv^.tt = nfileof)
			and (typeof(tv^.tof) = typnods[tchar])) 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;
			write('{');
			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;
				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(';');
				if td = dreadln then
					write('; ');
			444:
				if td = dreadln then
				    begin
					write('Getl(&');
					if tv = nil then
						printid(defnams[dinput]^.lid)
					else
						eexpr(tv);
					write(')')
				    end
			    end
			else begin
				increment;
				while tq <> nil do
				    begin
				        eexpr(tq);
					write(' = ');
					write('Buf(');
					eexpr(tv);
					write('), Get(');
					eexpr(tv);
					write(')');
					tq := tq^.tnext;
					if tq <> nil then
					    begin
						writeln('; ');
						indent
					    end
				    end;
				decrement
			     end;
			writeln(';}')
		    end;
		  dwrite,
		  dwriteln:
		    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 = dwriteln 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 *)
				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 = 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, 0')
			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, ', -1')
				    end
				else if tq = typnods[tstring] then
				    begin
					eexpr(tp^.taparm^.tnext);
					write(', -1')
				    end
				else if tq^.tt = narray then
				     begin
					eexpr(tp^.taparm^.tnext);
					write('.A, sizeof(');
					eexpr(tp^.taparm^.tnext);
					write('.A)')
				     end
				else
					fatal(etree)
			     end;
			writeln(');')
		    end;
		  dseek:
		    begin
		        write('Seek(');
			eexpr(tp^.taparm);
			write(',');
			eexpr(tp^.taparm^.tnext);
			write(',');
			eexpr(tp^.taparm^.tnext^.tnext);
			writeln(');');
			defnams[dseek]^.lused := true;
		    end;
		  dtell:
		    begin
		    	write('Tell(');
			eexpr(tp^.taparm);
			write(')');
			defnams[dtell]^.lused := true;
		    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 if tf^.tup^.tt = nvarpar then
						eaddr(tq)
					else
						eexpr(tq)
				    end
				else if tx = typnods[tset] then
				    begin
					write('*((');
					etypedef(tf^.tup^.tbind);
					write(' *)');
					dropset := true;
					if align then
					    begin
						usesal := true;
						write('SETALIGN(');
						eexpr(tq);
						write(')')
					    end
					else
						eexpr(tq);
					dropset := false;
					write(')')
				    end
				else if tx = typnods[tstring] then
				    begin
					write('*((');
					etypedef(tf^.tup^.tbind);
					write(' *)');
					if align then
					    begin
						usealig := true;
						write('STRALIGN(');
						eexpr(tq);
						write(')')
					    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
					    begin
						write(', (');
						eexpr(tx^.taindx^.thi);
						write(' - ');
						eexpr(tx^.taindx^.tlo);
						write(' + 1)')
					    end
				    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 *)
		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))
			or (needsintcast(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))
			or (needsintcast(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 *)
				if tp^.tisassigndest then
				    begin
					eexpr(tp^.texps);
					write('.buf');
				    end
				else
				    begin
					if (tq^.tdef = dtext) then
					    write('Bufx(')
					else
					    write('Buf(');
					eexpr(tp^.texps);
					write(')')
				    end
			    end
			else begin
				write('(*');
				eexpr(tp^.texps);
				write(')')
			     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
					write('(*');
					printid(tp^.tsym^.lid);
					write(')')
				     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 *)

	(*	Undefine constants.					*)
	procedure edconst(tp : treeptr);

	var	sp	: symptr;

	begin
		while tp <> nil do
		    begin
			sp := tp^.tidl^.tsym;
			if tp^.tbind^.tt <> nstring then
			    begin
				(* all non-strings are emitted as
				   preprocessor # defines *)
				write(undef);
				printid(sp^.lid);
				writeln
			    end;
			tp := tp^.tnext
		    end
	end;	(* edconst *)


	(*	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:
				(* Could we test this in a simpler way? *)
			        if tp^.tsym^.lsymdecl
				    = typnods[tchar]^.tup^.tidl then
			  		write(chartyp)
				else
					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(inttyp, tab1, 'bufvalid, eoln, eof, ',
				    'writable;');
				indent;
				etdef(nil, tp^.tof);
				writeln(tab1, 'buf;');
				indent;
				writeln(inttyp, tab1, 'auxbuf;');
				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 ((int)(');
				increment;
				eexpr(tp^.tcasxp);
				writeln(')) {');
				decrement;
				echoise(tp^.tcaslst);
				indent;
				writeln('  default:');
				increment;
				if tp^.tcasother = nil then
				    begin
					indent;
					writeln('PTCerror(PTC_E_CASE, ',
					    '__LINE__, 0, 0);')
				    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, 
			    'PTCerror(PTC_E_CASE, __LINE__, 0, 0);');
			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;
			edconst(tp^.tsubconst);
			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;

	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('**	Translated by ptc ', rcsrevision);
			writeln('**	', rcsid);
			writeln('*', '/');
		    end;
		(* there aren't many programs that don't do I/O... *)
		writeln(include, '<stdio.h>');
		(* or string operations, so we might as well include these *)
		writeln(include, '<string.h>');
		writeln(include, '<ptc.h>');
		if 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(dabs) or use(dtrunc) or use(dround) then
			writeln(include, '<math.h>');
		if use(dinput) or use(doutput) or use(derroutput) then
		    begin
			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, 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, 0, 1}');
				writeln(';')
			    end;
			if use(derroutput) then
			    begin
				if tp^.tsubid = nil then
					write(xtern);
				write('text', tab1);
				printid(defnams[derroutput]^.lid);
				if tp^.tsubid <> nil then
					write(' = { stderr, 0, 0, 0, 1 }');
				writeln(';')
			    end
		    end;
		if use(dread) or use(dreadln) then
		    begin
			writeln(static, 'FILE', tab1, '*Tmpfil;');
			writeln(static, 'long', tab1, 'Tmplng;');
			writeln(static, 'double', tab1, 'Tmpdbl;');
		    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 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(static, chartyp, tab1, '*Bools[] = { "false", "true" };')
		    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(dnew) then
		    begin
			writeln(ifndef, 'Unionoffs');
			writeln(define, 'Unionoffs(p, m) ',
			    '(((long)(&(p)->m))-((long)(p)))');	(* CPU *)
			writeln(endif)
		    end;
		if usesets then
		    begin
			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(setptyp, tab1, 'Conset[];');
			writeln(voidtyp, tab1, 'Setncpy();')
		    end;
		if align then					(* CPU *)
		    begin
			writeln(ifndef, 'SETALIGN');
			writeln(define, 'SETALIGN(x) Alignset(x)');
			writeln('struct Set { ', wordtype, tab1, 'S[',
					maxsetrange:1, '+1]; } *Alignset();');
			writeln(endif);
			writeln(ifndef, 'STRALIGN');
			writeln(define, 'STRALIGN(x) Alignstr(x)');
			writeln('struct String { char	A[',
					maxtoknlen:1, '+1]; } *Alignstr();');
			writeln(endif)
		    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(inttyp, tab1, 'argc;');
			writeln(chartyp, tab1, '**argv;');
			writeln;
			writeln('main(_ac, _av)');	(* OS *)
			writeln(inttyp, tab1, '_ac;');
			writeln(chartyp, tab1, '*_av[];');
			writeln('{');
			writeln;
			increment;
			indent;
			writeln('argc = _ac;');
			indent;
			writeln('argv = _av;');
			elabel(tp);
			estmt(tp^.tsubstmt);
			indent;
			writeln('exit(0);');
			indent;
			writeln('/', '* NOTREACHED *', '/');
			decrement;
			writeln('}');
			edconst(tp^.tsubconst);
		    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;
	eprogram(top);
	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 usesal then
	    begin
		writeln;
		writeln(static, 'struct Set *');
		writeln('Alignset(Sp)');
		writeln(tab1, registr, wordtype, tab1, '*Sp;');
		writeln('{');
		writeln(tab1, static, 'struct Set', tab1, 'tmp;');
		writeln(tab1, registr, wordtype, tab1, '*tp = tmp.S;');
		writeln(tab1, registr, inttyp, tab2, 'i = *Sp;');
		writeln;
		writeln(tab1, 'while (i-- >= 0)');
		writeln(tab2, '*tp++ = *Sp++;');
		writeln(tab1, 'return (&tmp);');
		writeln('}')
	    end;
	if usealig then
	    begin
		writeln;
		writeln(static, 'struct String *');
		writeln('Alignstr(Cp)');
		writeln(tab1, registr, chartyp, tab1, '*Cp;');
		writeln('{');
		writeln(tab1, static, 'struct String', tab1, 'tmp;');
		writeln(tab1, registr, chartyp, tab1, '*sp = tmp.A;');
		writeln;
		writeln(tab1, 'while (*sp++ = *Cp++)');
		writeln(tab2, ';');
		writeln(tab1, 'return (&tmp);');
		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;
end;	(* emit *)

(*	Initialize all global structures used in translator.		*)
procedure initialize;

var	s	: hashtyp;
	t	: pretyps;
	d	: predefs;

	hx	: packed array [ 1 .. 16 ] of char;

	(*	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 fixfp(i : strindx);

	var	t	: toknbuf;

	begin
		gettokn(i, t);
		t[1] := 'f';
		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 *)
{ IF-PASCAL
	rewrite(erroutput, '/dev/tty'); 
END-IF-PASCAL }
	lineno := 1;
	colno := 0;
	pushed := false;

	initstrstore;

	setlst := nil;
	setcnt := 0;
	hx := '0123456789ABCDEF';
	unpack(hx, hexdig, 0);

	symtab := nil;
	statlvl := 0;
	maxlevel := -1;
	enterscope(nil);
	varno:= 0;

	usesets := false;
	useunion := false;
	usediff := false;
	usemksub := false;
	useintr := false;
	usesge := false;
	usesle := false;
	usesne := false;
	useseq := false;
	usememb := false;
	useins := false;
	usescpy := false;

	usecase := false;
	usejmps := false;

	usecomp := false;
	usemax	:= false;
	usealig	:= false;
	usesal	:= 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(cfseek,		'fseek     ');	(* LIB *)
	defname(cgetchar,	'getchar   ');	(* LIB *)
	defname(cputchar,	'putchar   ');	(* LIB *)
	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(nvar,	derroutput,	'erroutput ');
	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,	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,	dprompt,	'prompt    '); (* OS *)
	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(nproc,	dseek,		'seek      ');
	defid(nfunc,	dsin,		'sin       ');
	defid(nfunc,	dsqr,		'sqr       ');
	defid(nfunc,	dsqrt,		'sqrt      ');
	defid(nfunc,	dsucc,		'succ      ');
	defid(nfunc,	dtell,		'tell      ');
	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,	dzfp,		'$p        ');	(* 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;
	deftab[derroutput]^.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]^.tbind;
		  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 "fp" *)
	fixfp(defnams[dzfp]^.lid^.istr);
	deftab[dzfp]^.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[dtell]^.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[dflush]^.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[dprompt]^.tfuntyp := typnods[tnone];
	deftab[dread]^.tfuntyp := typnods[tnone];
	deftab[dreadln]^.tfuntyp := typnods[tnone];
	deftab[dreset]^.tfuntyp := typnods[tnone];
	deftab[drewrite]^.tfuntyp := typnods[tnone];
	deftab[dseek]^.tfuntyp := typnods[tnone];
	deftab[dwrite]^.tfuntyp := typnods[tnone];
	deftab[dwriteln]^.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 *)

(*	Action to take when an error is detected.			*)
procedure error;

begin
	prtmsg(m);
{ IF-PASCAL
	goto 9999;
END-IF-PASCAL }
{ IF-C }
	exit(1);
{ END-IF-C }
end;

(*	Action to take when a fatal error is detected.			*)
procedure fatal;

begin
	prtmsg(m);
{ IF-PASCAL
	goto 9999;
END-IF-PASCAL }
{ IF-C }
	exit(1);
{ END-IF-C }
end;


begin	(* program *)
	initialize;
	parse;
	lineno := 0; lastline := 0;
	transform;
	emit;
9999:
	(* the very *)
end.
