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

label	9999;				(* end of program		*)

const	version		= '@(#)ptc.p	2.6  Date 87/09/12';

	keytablen	= 38;		(* nr of keywords		*)
	keywordlen	= 10;		(* length of a keyword		*)
	othersym	= 'otherwise '; (* keyword for others		*)
	externsym	= 'external  '; (* keyword for external		*)
	dummysym	= '          '; (* dummy keyword		*)

	(* a Pascal set is implemented as an array of "wordtype" where	*)
	(* each element contains bits numbered from 0 to "setbits"	*)
	wordtype	= 'unsigned short';	(* CPU *)
	setbits		= 15;			(* CPU *)

	(* a Pascal file is implemented as a struct which (among other	*)
	(* things) contain a flag-field, currently 4 bits are used	*)
	filebits	= 'unsigned short';	(* flags for files	*)
	filefill	= 12;			(* 16 less used 4 bits	*)

	maxsetrange	= 15;			(* nr of words in a set	*)
	scalbase	= 0;	(* ordinal value of first scalar member	*)

	maxprio		= 7;

	maxmachdefs	= 8;	(* max nr of machine integer types	*)
	machdeflen	= 16;	(* max length of machine int type name	*)

	(* limit of identifier table, identifiers and strings are saved	*)
	(* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char	*)
	maxstrblk	= 1023;
	maxblkcnt	= 63;
	maxstrstor	= 65535; (* maxstrstor should be ==
					(maxblkcnt+1) * (maxstrblk+1) - 1 *)

	maxtoknlen	= 127;	(* max size of token (i.e. identifier,
				   string or number); must be > keywordlen
				   and should be <= 256, see hashtokn()	*)

	hashmax		= 64;	(* size of hashtable - 1		*)

	null		= 0;	(* "impossible" character value, CHAR;
				   a char with this value is used as delimiter
				   of strings in "strstor" and in toknbuffers;
				   it is also used as end-of-input marker by
				   the input procedures in lexical analysis *)

	minchar		= null;
	maxchar		= 127;	(* greatest possible character, CHAR; limits
				   the number of elements in type "char" *)

	(* tmpfilename is used in the generated code to obtain names of
	   temporary files for reset/rewrite, the last character is supplied
	   by the reset/rewrite routine *)
	tmpfilename	= '"/tmp/ptc%d%c", getpid(), '; (* OS *)
	maxfilename	= 'MAXFILENAME';

	(* some frequently used characters *)
	space		= ' ';
	tab1		= '	';
	tab2		= '		';
	tab3		= '			';
	tab4		= '				';
	bslash		= '\';
	nlchr		= '''\n''';
	ffchr		= '''\f''';
	nulchr		= '''\0''';
	spchr		= ''' ''';
	quote		= '''';
	cite		= '"';
	xpnent		= 'e';		(* exponent char in output. CPU	*)
	percent		= '%';
	uscore		= '_';
	badchr		= '?';		(* CHAR *)
	okchr		= quote;	(* CHAR *)

	tabwidth	= 8;		(* width of a tab-stop. OS	*)

	echo		= false; 	(* echo input as read		*)
	diffcomm	= false; 	(* comment delimiters different	*)
	lazyfor		= false; 	(* compile for-stmts a la C	*)
	unionnew	= true; 	(* malloc unions for variants	*)

	inttyp		= 'int';	(* for predefined functions	*)
	chartyp		= 'char';
	setwtyp		= 'setword';
	setptyp		= 'setptr';
	floattyp	= 'float';
	doubletyp	= 'double';
	dblcast		= '(double)';	(* for predefined functions	*)

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

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

	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	= 0 .. maxstrblk;
	strblk	= array [ strbidx ] of char;
	strptr	= ^ strblk;
	strbcnt	= 0 .. maxblkcnt;

	(* table for stored identifiers *)
	(* an identifier in any scope is represented by an idnode which is
	   hooked to a slot in "idtab" as determined by a hash-function.
	   whenever the input procedures find an identifier its idnode is
	   immediately located, or created, if none was found; the identifier
	   is then always handled though a pointer to the idnode. the actual
	   text of the identifier is stored in "strstor". *)
	idptr	= ^ idnode;
	idnode	= record
			inext	: idptr;	(* chain of idnode's	*)
			inref	: 0 .. 127;	(* # of refs to this id	*)
			ihash	: hashtyp;	(* its hash value	*)
			istr	: strindx;	(* index to "strstor"	*)
		  end;

	(* toknbuf is used to handle identifiers and strings in those situations
	   where the actual text is of intrest *)
	toknidx	= 1 .. maxtoknlen;
	toknbuf	= array [ toknidx ] of char;

	(* a type to hold Pascal keywords *)
	keyword	= packed array [ 1 .. keywordlen ] of char;

	(* predefined identifier enumeration *)
	predefs = (
		dabs,		darctan,	dargc,		dargv,
		dboolean,	dchar,		dchr,		dclose,
		dcos,		ddispose,	deof,		deoln,
		dexit,		dexp,		dfalse,		dflush,
		dget,		dhalt,		dinput,		dinteger,
		dln,		dmaxint,	dmessage,	dnew,
		dodd,		dord,		doutput,	dpage,
		dpack,		dpred,		dput,		dread,
		dreadln,	dreal,		dreset,		drewrite,
		dround,		dsin,		dsqr,		dsqrt,
		dsucc,		dtext,		dtrue,		dtrunc,
		dtan,		dwrite,		dwriteln,	dunpack,
		dzinit,		dztring
	);

	(* lexical symbol enumeration *)
	symtyp	= (
	    (* keywords and eof are sorted alphabetically ...... *)
		sand,		sarray,		sbegin,		scase,
		sconst,		sdiv,		sdo,		sdownto,
		selse,		send,		sextern,	sfile,
		sfor,		sforward,	sfunc,		sgoto,
		sif,		sinn,		slabel,		smod,
		snil,		snot,		sof,		sor,
		sother,		spacked,	sproc,		spgm,
		srecord,	srepeat,	sset,		sthen,
		sto,		stype,		suntil,		svar,
		swhile,		swith,		seof,
	    (* ...... sorted *)
								sinteger,
		sreal,		sstring,	schar,		sid,
		splus,		sminus,		smul,		squot,
		sarrow,		slpar,		srpar,		slbrack,
		srbrack,	seq,		sne,		slt,
		sle,		sgt,		sge,		scomma,
		scolon,		ssemic,		sassign,	sdotdot,
		sdot
	);
	symset	= set of symtyp;

	(* lexical symbol definition *)
	(* the lexical symbol holds a descriptor and the value of a symbol
	   read by the input procedures; note that real values are represented
	   as strings saved in "strstor" like ordinary strings to avoid using
	   float-variables and float-arithmetic in the translator *)
	lexsym	=
	    record
		case st : symtyp of
		  sid:		(vid	: idptr);
		  schar:	(vchr	: char);
		  sinteger:	(vint	: integer);
		  sreal:	(vflt	: strindx);
		  sstring:	(vstr	: strindx);

		  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:		(* -			*)
		    (
			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,
	usefopn,		(* source program uses reset/rewrite	*)
	usescan,
	usegetl,
	usenilp,		(* source program uses nil-pointer 	*)
	usebool	: boolean;	(* source program writes boolean-values	*)

	top	: treeptr;	(* top of parsetree, result from parse	*)

	setlst	: treeptr;	(* list of set-initializations		*)
	setcnt	: integer;	(* counter for setlst length		*)

	currsym	: lexsym;	(* current lexical symbol		*)

	keytab	: array [ 0 .. keytablen ] of	(* table of keywords	*)
		    record
			wrd	: keyword;	(* keyword text		*)
			sym	: symtyp	(* corresponding symbol	*)
		    end;

	strstor	: array [ strbcnt ] of strptr;	(* store for strings	*)
	strfree	: strindx;			(* first free position	*)
	strleft	: strbidx;			(* room in last blk	*)

	idtab	: array [ hashtyp ] of idptr;	(* hashed table of id's	*)

	symtab	: declptr;			(* table of symbols	*)

	statlvl,				(* static decl. level	*)
	maxlevel : integer;			(*  - " - maximum value	*) 

	deftab	: array [ predefs ] of treeptr;	(* predefined idents.	*)
	defnams	: array [ predefs ] of symptr;	(*        - " -		*)
	typnods	: array [ pretyps ] of treeptr;	(* predef. types.	*)

	pprio,
	cprio	: array [ nassign .. nnil ] of 0 .. maxprio;

	ctable	: array [ cnames ] of idptr;	(* table of C-keywords	*)

	nmachdefs : 0 .. maxmachdefs;
	machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types	*)
			record
				lolim, hilim	: integer;
				typstr		: strindx
			end;

	lineno,					(* input line number	*)
	colno,					(* input column number	*)
	lastcol,				(* last OK input column	*)
	lastline : integer;			(* last OK input line	*)

	lasttok	: toknbuf;			(* last input token	*)

	varno	: integer;		(* counter for unique id's	*)

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

	hexdig	: array [ 0 .. 15 ] of char;

(*	Prtmsg produces an error message. It asssumes that procedure	*)
(*	"message" (predefined) will "writeln" to user tty. OS		*)
procedure prtmsg(m : errors);

const	user	= 'Error: ';
	restr	= 'Implementation restriction: ';
	inter	= '* Internal error * ';
	xtoklen	= 64;				(* should be <= maxtoklen *)

var	i	: toknidx;
	xtok	: packed array [ 1 .. xtoklen ] of char;

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

procedure fatal(m : errors);	forward;
procedure error(m : errors);	forward;

(*	Map letters to upper-case.					*)
(*	This function assumes a machine collating sequence where the	*)
(*	letters of either case form a contigous sequence, CHAR.	*)
function uppercase(c : char) : char;

begin
	if (c >= 'a') and (c <= 'z') then
		uppercase := chr(ord(c) + ord('A') - ord('a'))
	else
		uppercase := c
end;


(*	Map letters to lower-case.					*)
(*	This function assumes a machine collating sequence where the	*)
(*	letters of either case form a contigous sequence, CHAR.	*)
function lowercase(c : char) : char;

begin
	if (c >= 'A') and (c <= 'Z') then
		lowercase := chr(ord(c) - ord('A') + ord('a'))
	else
		lowercase := c
end;

(*	Retrieve a string from strstor.				*)
procedure gettokn(i : strindx; var t : toknbuf);

var	c	: char;
	k	: toknidx;
	j	: strbidx;
	p	: strptr;

begin
	k := 1;
	(* compute block and offset in block *)
	p := strstor[i div (maxstrblk + 1)];
	j := i mod (maxstrblk + 1);
	(* retrieve text up to null *)
	repeat
		c := p^[j];
		t[k] := c;
		j := j + 1;
		k := k + 1;
		if k = maxtoknlen then
		    begin
			c := chr(null);
			t[maxtoknlen] := chr(null);
			prtmsg(eoverflow)
		    end
	until	c = chr(null)
end;

(*	Deposit a string into strstor at a given start-position.	*)
procedure puttokn(i : strindx; var t : toknbuf);

var	c	: char;
	k	: toknidx;
	j	: strbidx;
	p	: strptr;

begin
	k := 1;
	p := strstor[i div (maxstrblk + 1)];
	j := i mod (maxstrblk + 1);
	repeat
		c := t[k];
		p^[j] := c;
		k := k + 1;
		j := j + 1
	until	c = chr(null)
end;

(*	Write a token on standard output.				*)
procedure writetok(var w : toknbuf);

var	j	: toknidx;

begin
	j := 1;
	while w[j] <> chr(null) do
	    begin
		write(w[j]);
		j := j + 1
	    end
end;

(*	Print a float number on standard output.			*)
procedure printtok(i : strindx);

var	w	: toknbuf;

begin
	gettokn(i, w);
	writetok(w)
end;

(*	Print an identifier on standard output.				*)
procedure printid(ip : idptr);

begin
	printtok(ip^.istr)
end;

(*	Print a character on standard output with proper C-quoting.	*)
procedure printchr(c : char);

begin
	if (c = quote) or (c = bslash) then
		write(quote, bslash, c, quote)
	else
		write(quote, c, quote)
end;

(*	Print a string on standard output with proper C-quoting.	*)
procedure printstr(i : strindx);

var	k	: toknidx;
	c	: char;
	w	: toknbuf;

begin
	gettokn(i, w);
	write(cite);
	k := 1;
	while w[k] <> chr(null) do
	    begin
		c := w[k];
		k := k + 1;
		if (c = cite) or (c = bslash) then
			write(bslash);
		write(c)
	    end;
	write(cite)
end;

(*	Return a pointer to the declarationpoint of an identifier.	*)
function idup(ip : treeptr) : treeptr;

begin
	idup := ip^.tsym^.lsymdecl^.tup
end;

(*	Compute a hashvalue for an identifier or a string.		*)
function hashtokn(var id : toknbuf) : hashtyp;

var	h	: integer;
	i	: toknidx;

begin
	i := 1;
	h := 0;
	while id[i] <> chr(null) do
	    begin
		(* if ord() of a character ranges from 0 to 127 then we can loop
		   256 times without causing h to exceed 32767, this is safe as
		   both strings and identifiers are limited in length *)
		h := h + ord(id[i]);	(* CHAR, CPU *)
		i := i + 1
	    end;
	hashtokn := h mod hashmax
end;

(*	Global string table update.					*)
(*	This function accepts a string and stores it in strstor.	*)
(*	It returns the id-number for the new string.			*)
function savestr(var t : toknbuf) : strindx;

var	k	: toknidx;
	i	: strindx;
	j	: strbcnt;

begin
	(* find length of new string including null-char *)
	k := 1;
	while t[k] <> chr(null) do
		k := k + 1;
	if k > strleft then
	    begin
		(* out of space in strstore *)
		if strstor[maxblkcnt] <> nil then	(* last slot used *)
			error(emanytokn);
		(* allocate a new block *)
		j := (strfree + maxstrblk) div (maxstrblk + 1);
		new(strstor[j]);
		if strstor[j] = nil then
			error(enew);
		strfree := j * (maxstrblk + 1);
		strleft := maxstrblk
	    end;
	(* copy new str, update location of last used cell,
	   return starting location for new str *)
	i := strfree;
	strfree := strfree + k;
	strleft := strleft - k;
	puttokn(i, t);
	savestr := i
end;

(*	Global id table lookup.						*)
(*	This procedure accepts an identifier and determines if it has	*)
(*	been seen before. If that is the case a pointer to its idnode	*)
(*	is returned, otherwise the identifier is saved and a pointer to	*)
(*	a new node is returned.						*)
function saveid(var id : toknbuf) : idptr;

label	999;

var	k	: toknidx;
	ip	: idptr;
	h	: hashtyp;
	t	: toknbuf;

begin
	h := hashtokn(id);
	ip := idtab[h];				(* scan hashlist for id	*)
	while ip <> nil do
	    begin
		gettokn(ip^.istr, t);		(* look at saved token	*)
		k := 1;
		while id[k] = t[k] do
			if id[k] = chr(null) then
				goto 999	(* found it!		*)
			else
				k := k + 1;	(* look at next char	*)
		ip := ip^.inext
	    end;

	(* identifier wasn't previously seen, manufacture a new idnode,
	   save index to strstor and hashvalue, insert idnode in idtab *)
	new(ip);
	if ip = nil then
		error(enew);
	ip^.inref := 0;
	ip^.istr := savestr(id);
	ip^.ihash := h;
	ip^.inext := idtab[h];
	idtab[h] := ip;

999:
	(* return the idnode *)
	saveid := ip
end;

(*	This function creates a new variable by concatenating one name	*)
(*	with another injecting a given separator.			*)
function mkconc(sep : char; p, q : idptr) : idptr;

var	w, x	: toknbuf;
	i, j	: toknidx;

begin
	(* fetch second part and determine its length *)
	gettokn(q^.istr, x);
	j := 1;
	while x[j] <> chr(null) do
		j := j + 1;
	(* fetch first part and locate its end *)
	w[1] := chr(null);
	if p <> nil then
		gettokn(p^.istr, w);
	i := 1;
	while w[i] <> chr(null) do
		i := i + 1;
	(* check total length *)
	if i + j + 2 >= maxtoknlen then
		error(eoverflow);

	(* add separators *)
	if sep = '>' then
	    begin
		(* special case 1: > gives arrow: a->b *)
		w[i] := '-';
		i := i + 1
	    end;
	if sep <> space then
	    begin
		(* special case 2: space gives nothing: ab *)
		w[i] := sep;
		i := i + 1
	    end;
	(* add second part *)
	j := 1;
	repeat
		w[i] := x[j];
		i := i + 1;
		j := j + 1
	until w[i-1] = chr(null);
	(* save new identifier *)
	mkconc := saveid(w)
end;

(*	Create a new id with name-prefix from w.			*)
function mkuniqname(var t : toknbuf) : idptr;

var	i	: toknidx;

	procedure dig(n : integer);
	begin
		if n > 0 then
		    begin
			dig(n div 10);
			if i = maxtoknlen then
				error(eoverflow);
			t[i] := chr(n mod 10 + ord('0'));	(* CHAR *)
			i := i + 1
		    end
	end;

begin
	i := 1;
	while t[i] <> chr(null) do
		i := i + 1;
	varno := varno + 1;
	dig(varno);
	t[i] := chr(null);
	mkuniqname := saveid(t)
end;

(*	Make a new unique variable with given char as prefix.		*)
function mkvariable(c : char) : idptr;

var	t	: toknbuf;

begin
	t[1] := c;
	t[2] := chr(null);
	mkvariable := mkuniqname(t)
end;

(*	Make a new unique variable with given char as prefix and	*)
(*	with a given id as tail. Commonly used for renaming id's.	*)
function mkrename(c : char; ip : idptr) : idptr;

begin
	mkrename := mkconc(uscore, mkvariable(c), ip)
end;

(*	Make a name for a variant. Variants are mapped onto C unions,	*)
(*	which we always give the name "U", thus the name of the variant	*)
(*	becomes "U.Vnnn" where "nnn" is a unique number.		*)
function mkvrnt : idptr;

var	t	: toknbuf;

begin
	t[1] := 'U';
	t[2] := '.';
	t[3] := 'V';
	t[4] := chr(null);
	mkvrnt := mkuniqname(t)
end;

procedure checksymbol(ss : symset);
begin
	if not (currsym.st in ss) then
		error(ebadsymbol);
end;

(*	Lexical analysis routine.					*)
(*	This procedure reads and classifies the next lexical token in	*)
(*	the input stream. The token is saved in the global variable	*)
(*	"currsym". The found symbol should be one of the symbols given	*)
(*	in the parameter "ss" otherwise the error routine is called.	*)
procedure nextsymbol(ss : symset);

var	lastchr	: 0 .. maxtoknlen;

	(*	This function reads the next character from the input	*)
	(*	and updates "lineno" and "colno" accordingly.		*)
	function nextchar : char;

	var	c	: char;

	begin
		if 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 echo then
				if colno = 0 then
					writeln
				else
					write(c);
			if c = tab1 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	: toknidx;
		wb	: toknbuf;

		(*	Determine if c is valid in an identifier.	*)
		(*	This function assumes a machine collating	*)
		(*	sequence where letters and digits form conti-	*)
		(*	gous sequences, CHAR.				*)
		function idchar(c : char) : boolean;

		begin
			idchar := 
				(c >= 'a') and (c <= 'z') or
				    (c >= '0') and (c <= '9') or
					(c >= 'A') and (c <= 'Z') or
					    (c = uscore)
		end;

		(*	Determine if c is valid in a number. CHAR.	*)
		function numchar(c : char) : boolean;

		begin
			numchar := (c >= '0') and (c <= '9')
		end;

		(*	Convert a digit to its numeric value. CHAR	*)
		function numval(c : char) : integer;

		begin
			numval := ord(c) - ord('0')
		end;

		(*	Determine if the current token is a keyword.	*)
		function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;

		var	n	: 1 .. keywordlen;
			i, j, k	: 0 .. keytablen;
			wrd	: keyword;
			kwc	: symtyp;

		begin
			(* quick check on token length,
			   pascal keywords range from 2 to 9 chars in length *)
			if (l > 1) and (l < keywordlen) then
			    begin
				(* could be a keyword, initialize wrd *)
				wrd := keytab[keytablen].wrd;
				(* copy w to wrd *)
				for n := 1 to l do
					wrd[n] := w[n];

				(* binary search for tokn,
				   relies on symtyp being sorted *)
				i := 0;
				j := keytablen;
				while j > i do
				    begin
					k := (i + j) div 2;
					if keytab[k].wrd >= wrd then
						j := k
					else
						i := k + 1
				    end;
				if keytab[j].wrd = wrd then
					kwc := keytab[j].sym
				else
					kwc := sid
			    end
			else
				kwc := sid;
			keywordcheck := kwc
		end;

	begin	(* nexttoken *)
		(* don't save blanks/comments *)
		lastchr := 0;
		(* read non-blank character *)
		repeat
			c := nextchar;
			(* skip comments, the two comment delimiters of pascal
			   are treated as different if "diffcomm" is true *)
			if c = '{' then
			    begin
				repeat
					c := nextchar;
					if diffcomm then
						ready := c = '}'
					else
						ready := ((c = '*') and
							    (peekchar = ')'))
							or (c = '}')
				until ready or eof;
				if eof and not ready then
					error(eeofcmnt);
				if (c = '*') and not eof then
					c := nextchar;
				c := space
			    end
			else if (c = '(') and (peekchar = '*')  then
			    begin
				c := nextchar;
				repeat
					c := nextchar;
					if diffcomm then
						ready := (c = '*') and
							(peekchar = ')')
					else
						ready := ((c = '*') and
							    (peekchar = ')'))
							or (c = '}')
				until ready or eof;
				if eof and not ready then
					error(eeofcmnt);
				if (c = '*') and not eof then
					c := nextchar;
				c := space
			    end
		until	(c <> space) and (c <> tab1);

		(* save characters from this token and save line- and column-
		   numbers for errormessages *)
		lasttok[1] := c;
		lastchr := 2;
		lastcol := colno;
		lastline := lineno;

		(* map all CHAR control characters onto "badchr" *)
		if c < okchr then
			c := badchr;

		(* decode symbol *)
		with currsym do
		    if eof then
			begin
				lasttok[1] := '*';
				lasttok[2] := 'E';
				lasttok[3] := 'O';
				lasttok[4] := 'F';
				lasttok[5] := '*';
				lastchr := 6;
				st := seof
			end
		    else
			case c of


			(* CHAR, chars not in Pascal *)
			  '|', '`', '~', '}',
			  bslash, uscore, badchr:
				error(ebadchar);

			(* identifiers or keywords *)
			  'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
			  'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
			  'u', 'v', 'w', 'x', 'y', 'z',
			  'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
			  'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
			  'U', 'V', 'W', 'X', 'Y', 'Z':
			    begin
				(* read token into buffer *)
				wb[1] := lowercase(c);
				wl := 2;
				while (wl < maxtoknlen) and idchar(peekchar) do
				    begin
					wb[wl] := lowercase(nextchar);
					wl := wl + 1
				    end;
				if wl >= maxtoknlen then
				    begin
					lasttok[lastchr] := chr(null);
					error(elongtokn)
				    end;
				(* terminate token and match *)
				wb[wl] := chr(null);
				(* check if keyword/identifier *)
				st := keywordcheck(wb, wl-1);
				if st = sid then
					vid := saveid(wb)
			    end;

			(* integer or real numbers *)
			  '0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
			    begin
				(* assume integer number, save it in buffer *)
				wb[1] := c;
				wl := 2;
				n := numval(c);
				while numchar(peekchar) do
				    begin
					c := nextchar;
					n := n * 10 + numval(c);
					wb[wl] := c;
					wl := wl + 1
				    end;
				st := sinteger;
				vint := n;
				if realok 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	: idptr;

		begin
			tp := nil;
			din := deftab[dinput]^.tidl^.tsym^.lid;
			dut := deftab[doutput]^.tidl^.tsym^.lid;
			while (currsym.vid = din) or (currsym.vid = dut) do
			    begin
				(* ignore input/output as parameters so that
				   they will be bound to stdin/stdout unless
				   declared as variables *)
				if currsym.vid = din then
					defnams[dinput]^.lused := true
				else
					defnams[doutput]^.lused := true;
				nextsymbol([scomma, srpar]);
				if currsym.st = srpar then
					goto 999;
				nextsymbol([sid])
			    end;
			tq := newid(currsym.vid);
			tq^.tsym^.lt := lpointer;
			tp := tq;
			nextsymbol([scomma, srpar]);
			while currsym.st = scomma do
			    begin
				nextsymbol([sid]);
				if currsym.vid = din then
					defnams[dinput]^.lused := true
				else if currsym.vid = dut then
					defnams[doutput]^.lused := true
				else begin
					tq^.tnext := newid(currsym.vid);
					tq := tq^.tnext;
					tq^.tsym^.lt := lpointer;
				     end;
				nextsymbol([scomma, srpar])
			    end;
		999:
			pprmlist := tp
		end;

	begin	(* pprogram *)
		enterscope(nil);
		tp := mknode(npgm);
		nextsymbol([sid]);
		tp^.tstat := statlvl;
		tp^.tsubid := mknode(nid);
		tp^.tsubid^.tup := tp;
		tp^.tsubid^.tsym := mksym(lidentifier);
		tp^.tsubid^.tsym^.lid := currsym.vid;
		tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid;
		linkup(tp, tp^.tsubid);
		nextsymbol([slpar, ssemic]);
		if currsym.st = slpar then
		    begin
			nextsymbol([sid]);
			tp^.tsubpar := pprmlist;
			linkup(tp, tp^.tsubpar);
			nextsymbol([ssemic])
		    end
		else
			tp^.tsubpar := nil;
		nextsymbol([slabel, sconst, stype, svar,
						sproc, sfunc, sbegin]);
		pbody(tp);
		checksymbol([sdot]);
		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;

	(*	Parse an assignment or a procedure call.		*)
	function psimple;

	var	tq,
		tp	: treeptr;

	begin
		tp := pvariable(oldid(currsym.vid, lidentifier));
		if currsym.st = sassign then
		    begin
			tq := mknode(nassign);
			tq^.tlhs := tp;
			tq^.trhs := pexpr(nil);
			tp := tq
		    end;
		psimple := tp
	end;

	(*	Parse a varable-reference (or a subroutine-call).	*)
	function pvariable;

	var	tp,
		tq	: treeptr;

	begin
		nextsymbol([slpar, slbrack, sdot, sarrow,
			sassign, ssemic, scomma, scolon, sdotdot,
			splus, sminus, smul, sdiv, smod, squot,
			sand, sor, sinn, srpar, srbrack,
			sle, slt, seq, sge, sgt, sne,
			send, suntil, sthen, selse, sdo, sdownto, sto, sof]);
		if currsym.st in [slpar, slbrack, sdot, sarrow] then
		    begin
			case currsym.st of
			  slpar:
			    begin
				tp := mknode(ncall);
				tp^.tcall := varptr;
				tq := nil;
				repeat
					if tq = nil then
					    begin
						tq := pexpr(nil);
						tp^.taparm  := tq
					    end
					else begin
						tq^.tnext := pexpr(nil);
						tq := tq^.tnext
					     end;
				until	currsym.st = srpar
			    end;
			  slbrack:
			    begin
				tq := varptr;
				repeat
					tp := mknode(nindex);
					tp^.tvariable := tq;
					tp^.toffset := pexpr(nil);
					tq := tp
				until	currsym.st = srbrack
			    end;
			  sdot:
			    begin
				tp := mknode(nselect);
				tp^.trecord := varptr;
				nextsymbol([sid]);
				tq := typeof(varptr);
				enterscope(tq^.trscope);
				tp^.tfield := oldid(currsym.vid, lfield);
				leavescope
			    end;
			  sarrow:
			    begin
				tp := mknode(nderef);
				tp^.texps := varptr
			    end
			end;(* case *)
			tp := pvariable(tp)
		    end
		else begin
			tp := varptr;
			if tp^.tt = nid then
			    begin
				tq := idup(tp);
				if tq <> nil then
					if tq^.tt in [nfunc, nproc,
							nparproc, nparfunc] then
					    begin
						(* subroutine-call without
						   parameters *)
						tp := mknode(ncall);
						tp^.tcall := varptr;
						tp^.taparm := nil
					    end
			    end
		     end;
		pvariable := tp
	end;

	(*	Parse an expression.					*)
	function pexpr;

	var	tp,
		tq	: treeptr;
		nt	: treetyp;
		next	: boolean;

		function padjust(tu, tr : treeptr) : treeptr;
		begin
			if pprio[tu^.tt] >= pprio[tr^.tt] then
			    begin
				if tr^.tt in [nnot, numinus, nuplus,
							nset, nderef] then
					tr^.texps := padjust(tu, tr^.texps)
				else
					tr^.texpl := padjust(tu, tr^.texpl);
				padjust := tr
			    end
			else begin
				if tu^.tt in [nnot, numinus, nuplus,
							nset, nderef] then
					tu^.texps := tr
				else
					tu^.texpr := tr;
				padjust := tu
			     end
		end;

	begin
		nextsymbol([sid, schar, sinteger, sreal, sstring, snil,
				splus, sminus, snot, slpar, slbrack, srbrack]);
		next := true;
		case currsym.st of
		  splus:
		    begin
			tp := mknode(nuplus);
			tp^.texps := nil;
			tp := pexpr(tp);
			next := false
		    end;
		  sminus:
		    begin
			tp := mknode(numinus);
			tp^.texps := nil;
			tp := pexpr(tp);
			next := false
		    end;
		  snot:
		    begin
			tp := mknode(nnot);
			tp^.texps := nil;
			tp := pexpr(tp);
			next := false
		    end;
		  schar,
		  sinteger,
		  sreal,
		  sstring:
			tp := mklit;
		  snil:
		    begin
			usenilp := true;
			tp := mknode(nnil);
		    end;
		  sid:
		    begin
			tp := pvariable(oldid(currsym.vid, lidentifier));
			next := false
		    end;
		  slpar:
		    begin
			tp := mknode(nuplus);
			tp^.texps := pexpr(nil)
		    end;
		  slbrack:
		    begin
			usesets := true;
			tp := mknode(nset);
			tp^.texps := nil;
			tq := nil;
			repeat
				if tq = nil then
				    begin
					tq := pexpr(nil);
					tp^.texps := tq
				    end
				else begin
					tq^.tnext := pexpr(nil);
					tq := tq^.tnext
				     end
			until	currsym.st = srbrack;
		    end;
		  srbrack:
		    begin
			tp := mknode(nempty);
			next := false
		    end
		end;
		if next then
			nextsymbol([
				scolon, ssemic, scomma, sdotdot, srpar, srbrack,
				sle, slt, seq, sge, sgt, sne,
				splus, sminus, smul, sdiv, smod, squot,
				sand, sor, sinn,
				send, suntil, sthen, selse, sdo, sdownto, sto,
				sof, slpar, slbrack]);
		case currsym.st of
		  sdotdot:
			nt := nrange;
		  splus:
			nt := nplus;
		  sminus:
			nt := nminus;
		  smul:
			nt := nmul;
		  sdiv:
			nt := ndiv;
		  smod:
			nt := nmod;
		  squot:
		    begin
			defnams[dreal]^.lused := true;
			nt := nquot;
		    end;
		  sand:
			nt := nand;
		  sor:
			nt := nor;
		  sinn:
		    begin
			nt := nin;
			usesets := true
		    end;
		  sle:
			nt := nle;
		  slt:
			nt := nlt;
		  seq:
			nt := neq;
		  sge:
			nt := nge;
		  sgt:
			nt := ngt;
		  sne:
			nt := nne;
		  scolon:
			nt := nformat;
		  sid, schar, sinteger, sreal, sstring, snil,
		  ssemic, scomma, slpar, slbrack, srpar, srbrack,
		  send, suntil, sthen, selse, sdo, sdownto, sto, sof:
			nt := nnil
		end;(* case *)
		if nt in [nin .. nor, nand, nnot] then
			defnams[dboolean]^.lused := true;
		if nt <> nnil then
		    begin
			(* binary operator *)
			tq := mknode(nt);
			tq^.texpl := tp;
			tq^.texpr := nil;
			tp := pexpr(tq)
		    end;

		(* this statement yilds proper operator precedence *)
		if tnp <> nil then
			tp := padjust(tnp, tp);
		pexpr := tp
	end;

	(*	Parse a case-statement.					*)
	function pcase;

	label	999;

	var	tp,
		tq,
		tv	: treeptr;

	begin
		tp := mknode(ncase);
		tp^.tcasxp := pexpr(nil);
		checksymbol([sof]);
		tq := nil;
		repeat
			if tq = nil then
			    begin
				tq := mknode(nchoise);
				tp^.tcaslst := tq
			    end
			else begin
				tq^.tnext := mknode(nchoise);
				tq := tq^.tnext
			     end;
			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
		    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[dzinit]^.lid,
								lforward);
					tx := mknode(nassign);
					tx^.tlhs := ty;
					currsym.st := sinteger;
					currsym.vint := 0;
					tx^.trhs := mklit
				    end
				else begin
					(* create file-struct wrapup *)
					tx := mknode(ncall);
					tx^.tcall := 
						oldid(defnams[dclose]^.lid,
								lidentifier);
					tx^.taparm := ti
				     end;
			  nrecord:
			    begin
				ty := nil;
				tq := tq^.tflist;
				while tq <> nil do
				    begin
					if filevar(typeof(tq^.tbind)) then
					    begin
						tz := tq^.tidl;
						while tz <> nil do
						    begin
							tx := mknode(nselect);
							tx^.trecord := ti;
							tx^.tfield := tz;
							tx := fileinit(tx,
							    typeof(tq^.tbind),
								opn);
							tx^.tnext := ty;
							ty := tx;
							tz := tz^.tnext
						    end
					    end;
					tq := tq^.tnext
				    end;
				tx := mknode(nbegin);
				tx^.tbegin := ty
			    end;
			end;(* case *)
			fileinit := tx
		end;

	begin	(* initcode *)
		while tp <> nil do
		    begin
			initcode(tp^.tsubsub);
			tv := tp^.tsubvar;
			while tv <> nil do
			    begin
				tq := typeof(tv^.tbind);
				if filevar(tq) then
				    begin
					ti := tv^.tidl;
					while ti <> nil do
					    begin
						tu := fileinit(ti, tq, true);
						linkup(tp, tu);
						tu^.tnext := tp^.tsubstmt;
						tp^.tsubstmt := tu;
						while tu^.tnext <> nil do
							tu := tu^.tnext;
						tu^.tnext := fileinit(ti, tq,
									false);
						linkup(tp, tu^.tnext);
						ti := ti^.tnext
					    end
				    end;
				tv := tv^.tnext;
			    end;
			tp := tp^.tnext
		    end
	end;	(* initcode *)

begin	(* transform *)
	renamc;
	renamp(top^.tsubsub, false);
	extract(top);
	renamf(top);
	initcode(top^.tsubsub);
	global(top, top, false)
end;	(* transform *)

(*	Emit C-code for program or module.				*)
procedure emit;

const	include	= '# include ';
	define	= '# define ';
	undef	= '# undef ';
	ifdef	= '# ifdef ';
	ifndef	= '# ifndef ';
	elsif	= '# else';
	endif	= '# endif';
	static	= 'static ';
	xtern	= 'extern ';
	typdef	= 'typedef ';
	registr	= 'register ';
	usigned	= 'unsigned ';
	indstep	= 8;

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

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

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

	var	da	: boolean;

	begin
		da := doarrow;
		doarrow := true;
		eexpr(tp);
		if donearr then
			donearr := false
		else
			write('.');
		doarrow := da
	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;
				usebool := true;
				write('Bools[(int)(');
				eexpr(tx);
				write(')]')
			    end;
			  'c':
			    begin
				if tq^.tt = nformat then
				    begin
					if tq^.texpr^.tt <> ninteger then
					    begin
						write(', ');
						eexpr(tq^.texpr)
					    end;
					write(', ');
					eexpr(tq^.texpl)
				    end
				else if tq^.tt <> nchar then
				    begin
					write(', ');
					eexpr(tq)
				    end
			    end;
			  'd':
			    begin
				write(', ');
				tx := tq;
				if tq^.tt = nformat then
				    begin
					if tq^.texpr^.tt <> ninteger then
					    begin
						eexpr(tq^.texpr);
						write(', ')
					    end;
					tx := tq^.texpl
				    end;
				eexpr(tx)
			    end;
			  'e':
			    begin
				write(', ');
				tx := tq^.texpr;
				if tx^.tt <> ninteger then
				    begin
					usemax := true;
					eexpr(tx);
					write(', Max(');
					eexpr(tx);
					write(' - 7, 1), ')
				    end;
				eexpr(tq^.texpl)
			    end;
			  'f':
			    begin
				write(', ');
				tx := tq^.texpl;
				if tx^.texpr^.tt <> ninteger then
				    begin
					eexpr(tx^.texpr);
					write(', ')
				    end;
				if (tx^.texpr^.tt <> ninteger) or
					(tq^.texpr^.tt <> ninteger) then
				    begin
					usemax := true;
					write('Max((');
					eexpr(tx^.texpr);
					write(') - (');
					eexpr(tq^.texpr);
					write(') - 1, 1), ')
				    end;
				eexpr(tq^.texpl^.texpl)
			    end;
			  'g':
			    begin
				write(', ');
				eexpr(tq)
			    end;
			  's':
			    begin
				if tq^.tt = nformat then
				    begin
					if tq^.texpr^.tt <> ninteger then
					   begin
						write(', ');
						eexpr(tq^.texpr);
						write(', ');
						eexpr(tq^.texpr)
					   end;
					write(', ');
					eexpr(tq^.texpl)
				    end
				else if tq^.tt <> nstring then
				    begin
					write(', ');
					eexpr(tq)
				    end
			    end;
			  '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('(char)(');
				eexpr(tp^.taparm);
				write(')')
			     end
		    end;
		  ddispose:
		    begin
			write('free(');				(* LIB *)
			eexpr(tp^.taparm);
			writeln(');')
		    end;
		  deof:
		    begin
			write('Eof(');
			if tp^.taparm = nil then
			    begin
				defnams[dinput]^.lused := true;
				printid(defnams[dinput]^.lid)
			    end
			else
				eexpr(tp^.taparm);
			write(')')
		    end;
		  deoln:
		    begin
			write('Eoln(');
			if tp^.taparm = nil then
			    begin
				defnams[dinput]^.lused := true;
				printid(defnams[dinput]^.lid)
			    end
			else
				eexpr(tp^.taparm);
			write(')');
		    end;
		  dexit:
		    begin
			write('exit(');				(* OS *)
			if tp^.taparm = nil then
				write('0')
			else
				eexpr(tp^.taparm);
			writeln(');');
		    end;
		  dflush:
		    begin
			write('fflush(');			(* LIB *)
			if tp^.taparm = nil then
			    begin
				defnams[doutput]^.lused := true;
				printid(defnams[doutput]^.lid)
			    end
			else
				eexpr(tp^.taparm);
			writeln('.fp);')
		    end;
		  dpage:
		    begin
			(* write form-feed character *)
			write('Putchr(', ffchr, ', '); (* CHAR *)
			if tp^.taparm = nil then
			    begin
				defnams[doutput]^.lused := true;
				printid(defnams[doutput]^.lid)
			    end
			else
				eexpr(tp^.taparm);
			writeln(');');
		    end;
		  dput,
		  dget:
		    begin
			if typeof(tp^.taparm) = typnods[ttext] then
				if td = dget then
					write('Getx')
				else
					write('Putx')
			else begin
				write(voidcast);
				if td = dget then
					write('Get')
				else
					write('Put')
			     end;
			write('(');
			eexpr(tp^.taparm);
			writeln(');')
		    end;
		  dhalt:
			writeln('abort();');			(* OS *)
		  dnew:
		    begin
			eexpr(tp^.taparm);
			write(' = (');
			etypedef(typeof(tp^.taparm));
			write(')malloc((unsigned)(');	(* LIB *)
			enewsize(tp^.taparm);
			writeln('));')
		    end;
		  dord:
		    begin
			write('(unsigned)(');
			eexpr(tp^.taparm);
			write(')')
		    end;
		  dread,
		  dreadln:
		    begin
			txtfile := false;
			tq := tp^.taparm;
			if tq <> nil then
			    begin
				tv := typeof(tq);
				if tv = typnods[ttext] then
				    begin
					(* reading from textfile *)
					txtfile := true;
					tv := tq;
					tq := tq^.tnext
				    end
				else if tv^.tt = nfileof then
				    begin
					(* reading from other file *)
					txtfile := typeof(tv^.tof) =
							typnods[tchar];
					tv := tq;
					tq := tq^.tnext
				    end
				else begin
					(* reading from std-input *)
					txtfile := true;
					tv := nil
				     end
			    end
			else begin
				tv := nil;
				txtfile := true
			     end;
			if txtfile then
			    begin
				(* check for special case *)
				if tq = nil then
					goto 444;
				if (tq^.tt <> nformat) and
						(tq^.tnext = nil) and
						(typeletter(tq) = 'c') then
				    begin
					(* read single char *)
					eexpr(tq);
					write(' = ');
					write('Getchr(');
					if tv = nil then
						printid(defnams[dinput]^.lid)
					else
						eexpr(tv);
					write(')');
					if td = dreadln then
						write(',');
					goto 444
				    end;
				usescan := true;
				write('Fscan(');
				if tv = nil then
					printid(defnams[dinput]^.lid)
				else
					eexpr(tv);
				write('), ');
				(* first pass, emit format string *)
				while tq <> nil do
				    begin
					write('Scan(', cite);
					ch := typeletter(tq);
					case ch of
					  'a':
						write(percent, 's');
					  'c':
						write(percent, 'c');
					  'd':
						write(percent, 'ld');
					  'g':
						write(percent, 'le')
					end;(* case *)
					write(cite, ', ');
					case ch of
					  'a':
					    begin
						eexpr(tq);
						write('.A')
					    end;
					  'c':
					    begin
						write('&');
						eexpr(tq)
					    end;
					  'd':
						write('&Tmplng');
					  'g':
						write('&Tmpdbl')
					end;(* case *)
					write(')');
					case ch of
					  'd':
					    begin
						write(', ');
						eexpr(tq);
						write(' = Tmplng')
					    end;
					  'g':
					    begin
						write(', ');
						eexpr(tq);
						write(' = Tmpdbl')
					    end;
					  'a',
					  'c':
						(* no op *)
					end;(* case *)
					tq := tq^.tnext;
					if tq <> nil then
					    begin
						writeln(',');
						indent;
						write(tab1)
					    end
				    end;
				write(', Getx(');
				if tv = nil then
					printid(defnams[dinput]^.lid)
				else
					eexpr(tv);
				write(')');
				if td = dreadln then
					write(',');
			444:
				if td = dreadln then
				    begin
					usegetl := true;
					write('Getl(&');
					if tv = nil then
						printid(defnams[dinput]^.lid)
					else
						eexpr(tv);
					write(')')
				    end
			    end
			else begin
				increment;
				while tq <> nil do
				    begin
					write(voidcast, 'Fread(');
					eexpr(tq);
					write(', ');
					eexpr(tv);
					write('.fp)');
					tq := tq^.tnext;
					if tq <> nil then
					    begin
						writeln(',');
						indent
					    end
				    end;
				decrement
			     end;
			writeln(';')
		    end;
		  dwrite,
		  dwriteln,
		  dmessage:
		    begin
			txtfile := false;
			tq := tp^.taparm;
			if tq <> nil then
			    begin
				tv := typeof(tq);
				if tv = typnods[ttext] then
				    begin
					(* writing to textfile *)
					txtfile := true;
					tv := tq;
					tq := tq^.tnext
				    end
				else if tv^.tt = nfileof then
				    begin
					(* writing to other file *)
					txtfile := typeof(tv^.tof) =
							typnods[tchar];
					tv := tq;
					tq := tq^.tnext
				    end
				else begin
					(* writing to std-output *)
					txtfile := true;
					tv := nil
				     end
			    end
			else begin
				tv := nil;
				txtfile := true
			     end;
			if txtfile then
			    begin
				(* check for special case *)
				if tq = nil then
				    begin
					(* writeln whithout parameters *)
					if td in [dwriteln, dmessage] then
					    begin
						write('Putchr(', nlchr, ', ');
						if tv = nil then
							printid(
							  defnams[doutput]^.lid)
						else
							eexpr(tv);
						write(')')
					    end;
					writeln(';');
					goto 555
				    end
				else if (tq^.tt <> nformat) and
						(tq^.tnext = nil) then
					if typeletter(tq) = 'c' then
					    begin
						(* print single char *)
						write('Putchr(');
						eexpr(tq);
						write(', ');
						if tv = nil then
							printid(
							  defnams[doutput]^.lid)
						else
							eexpr(tv);
						write(')');
						if td = dwriteln then
						    begin
							write(',Putchr(',
							    nlchr, ', ');
							if tv = nil then
							 printid(
							  defnams[doutput]^.lid)
							else
								eexpr(tv);
							write(')');
						    end;
						writeln(';');
						goto 555
					    end;
				tx := nil;
				write(voidcast, 'fprintf(');	(* LIB *)
				if td = dmessage then
					write('stderr, ')
				else begin
					if tv = nil then
						printid(defnams[doutput]^.lid)
					else
						eexpr(tv);
					write('.fp, ')
				     end;
				write(cite);
				tx := tq;	(* remember 1:st parm *)
				(* first pass, emit format string *)
				while tq <> nil do
				    begin
					eformat(tq);
					tq := tq^.tnext
				    end;
				if (td = dmessage) or (td = dwriteln) then
					write('\n');
				write(cite);
				(* second pass, add parameters *)
				tq := tx;
				while tq <> nil do
				    begin
					ewrite(tq);
					tq := tq^.tnext
				    end;
				write('), Putl(');
				if tv = nil then
					printid(defnams[doutput]^.lid)
				else
					eexpr(tv);
				if td = dwrite then
					write(', 0)')
				else
					write(', 1)')
			    end
			else begin
				increment;
				tx := typeof(tv);
				if tx = typnods[ttext] then
					tx := typnods[tchar]
				else if tx^.tt = nfileof then
					tx := typeof(tx^.tof)
				else
					fatal(etree);
				while tq <> nil do
				    begin
					if (tq^.tt in [nid, nindex, nselect,
							nderef]) and
						(tx = typeof(tq)) then
					    begin
						write(voidcast, 'Fwrite(');
						eexpr(tq)
					    end
					else begin
						if tx^.tt = nsetof then
						    begin
							usescpy := true;
							write('Setncpy(');
							eselect(tv);
							write('buf.S, ');
							eexpr(tq);
							if typeof(tp^.trhs) =
							   typnods[tset] then
								eexpr(tq)
							else begin
								eselect(tq);
								write('S')
							     end;
							write(', sizeof(');
							eexpr(tv);
							write('.buf))');
						    end
						else begin
							eexpr(tv);
							write('.buf = ');
							eexpr(tq)
						     end;
						write(', Fwrite(');
						eexpr(tv);
						write('.buf');
					     end;
					write(', ');
					eexpr(tv);
					write('.fp)');
					tq := tq^.tnext;
					if tq <> nil then
					    begin
						writeln(',');
						indent
					    end
				    end;
				decrement
			     end;
			writeln(';');
		555:
		    end;
		  dclose:
		    begin
			tq := typeof(tp^.taparm);
			txtfile := tq = typnods[ttext];
			if (not txtfile) and (tq^.tt = nfileof) then
				if typeof(tq^.tof) = typnods[tchar] then
					txtfile := true;
			if txtfile then
				write('Closex(')
			else
				write('Close(');
			eexpr(tp^.taparm);
			writeln(');');
		    end;
		  dreset,
		  drewrite:
		    begin
			tq := typeof(tp^.taparm);
			txtfile := tq = typnods[ttext];
			if (not txtfile) and (tq^.tt = nfileof) then
				if typeof(tq^.tof) = typnods[tchar] then
					txtfile := true;
			if txtfile then
				if td = dreset then
					write('Resetx(')
				else
					write('Rewritex(')
			else
				if td = dreset then
					write('Reset(')
				else
					write('Rewrite(');
			eexpr(tp^.taparm);
			write(', ');
			tq := tp^.taparm^.tnext;
			if tq = nil then
				write('NULL, 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;
		  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 *)
		donearr := false;
		if tp^.tt in [nplus, nminus, nmul, nle, nge, neq, nne] then
		    begin
			tq := typeof(tp^.texpl);
			if (tq^.tt in [nset, nsetof]) or
						(tq = typnods[tset]) then
			    begin
				(* set operations *)
				case tp^.tt of
				  nplus:
				    begin
					setused := true;
					useunion := true;
					write('Union')
				    end;
				  nminus:
				    begin
					setused := true;
					usediff := true;
					write('Diff')
				    end;
				  nmul:
				    begin
					setused := true;
					useintr := true;
					write('Inter')
				    end;
				  neq:
				    begin
					useseq := true;
					write('Eq')
				    end;
				  nne:
				    begin
					usesne := true;
					write('Ne')
				    end;
				  nge:
				    begin
					usesge := true;
					write('Ge')
				    end;
				  nle:
				    begin
					usesle := true;
					write('Le')
				    end
				end;(* case *)
				if tp^.tt in [nplus, nminus, nmul] then
					dropset := false;
				write('(');
				eexpr(tp^.texpl);
				if tq^.tt = nsetof then
					write('.S');
				write(', ');
				eexpr(tp^.texpr);
				tq := typeof(tp^.texpr);
				if tq^.tt = nsetof then
					write('.S');
				write(')');
				goto 999
			    end
		    end;
		if tp^.tt in [neq, nne, ngt, nlt, nge, nle] then
		    begin
			tq := typeof(tp^.texpl);
			if tq^.tt = nconfarr then
				fatal(ecmpconf);
			if (tq^.tt in [nstring, narray]) or
						(tq = typnods[tstring]) then
			    begin
				write('Cmpstr(');
				eexpr(tp^.texpl);
				if tq^.tt = narray then
					write('.A');
				write(', ');
				tq := typeof(tp^.texpr);
				if tq^.tt = nconfarr then
					fatal(ecmpconf);
				eexpr(tp^.texpr);
				if tq^.tt = narray then
					write('.A');
				write(')');
				case tp^.tt of
				  neq:
					write(' == ');
				  nne:
					write(' != ');
				  ngt:
					write(' > ');
				  nlt:
					write(' < ');
				  nge:
					write(' >= ');
				  nle:
					write(' <= ');
				end;(* case *)
				write('0');
				goto 999
			    end
		    end;
		case tp^.tt of
		  neq, nne, nlt, nle,
		  ngt, nge, nor, nand, nplus, nminus,
		  nmul, ndiv, nmod, nquot:
		    begin
			flag := cprio[tp^.tt] > cprio[tp^.texpl^.tt];
			if (tp^.tt in [nlt, nle, ngt, nge]) and
					not arithexpr(tp^.texpl) then
			    begin
				write('(int)');
				flag := true
			    end;
			if flag then
				write('(');
			eexpr(tp^.texpl);
			if flag then
				write(')');
			case tp^.tt of
			  neq:
				write(' == ');
			  nne:
				write(' != ');
			  nlt:
				write(' < ');
			  nle:
				write(' <= ');
			  ngt:
				write(' > ');
			  nge:
				write(' >= ');
			  nor:
				write(' || ');
			  nand:
				write(' && ');
			  nplus:
				write(' + ');
			  nminus:
				write(' - ');
			  nmul:
				write(' * ');
			  ndiv:
				write(' / ');
			  nmod:
				write(' % ');
			  nquot:
			    begin
				write(' / ((');
				printid(defnams[dreal]^.lid);
				write(')')
			    end
			end;(* case *)
			flag := cprio[tp^.tt] > cprio[tp^.texpr^.tt];
			if (tp^.tt in [nlt, nle, ngt, nge]) and
					not arithexpr(tp^.texpr) then
			    begin
				write('(int)');
				flag := true
			    end;
			if flag then
				write('(');
			eexpr(tp^.texpr);
			if flag then
				write(')');
			if tp^.tt = nquot then
				write(')')
		    end;

		  nuplus, numinus, nnot:
		    begin
			case tp^.tt of
			  numinus:
				write('-');
			  nnot:
				write('!');
			  nuplus:
			end;(* case *)
			flag := cprio[tp^.tt] >= cprio[tp^.texps^.tt];
			if flag then
				write('(');
			eexpr(tp^.texps);
			if flag then
				write(')');
		    end;
		  
		  nin:
		    begin
			usememb := true;
			write('Member((unsigned)(');
			eexpr(tp^.texpl);
			write('), ');
			dropset := true;	(* no need to save set-expr *)
			eexpr(tp^.texpr);
			dropset := false;
			tq := typeof(tp^.texpr);
			if tq^.tt = nsetof then
				write('.S');
			write(')')
		    end;

		  nassign:
		    begin
			tq := typeof(tp^.trhs);
			if tq = typnods[tstring] then
			    begin
				write(voidcast, 'strncpy(');
				eexpr(tp^.tlhs);
				write('.A, ');
				eexpr(tp^.trhs);
				write(', sizeof(');
				eexpr(tp^.tlhs);
				write('.A))')
			    end
			else if tq = typnods[tboolean] then
			    begin
				eexpr(tp^.tlhs);
				write(' = ');
				tq := tp^.trhs;
				while tq^.tt = nuplus do
					tq := tq^.texps;
				if tq^.tt in [nin .. nor, nand, nnot] then
				    begin
					write('(');
					printid(defnams[dboolean]^.lid);
					write(')(');
					eexpr(tq);
					write(')')
				    end
				else
					eexpr(tq)
			    end
			else if tq = typnods[tnil] then
			    begin
				eexpr(tp^.tlhs);
				write(' = (');
				etypedef(typeof(tp^.tlhs));
				write(')NIL')
			    end
			else begin
				tq := typeof(tp^.tlhs);
				if tq^.tt = nsetof then
				    begin
					usescpy := true;
					write('Setncpy(');
					eselect(tp^.tlhs);
					write('S, ');
					dropset := true;
					tq := typeof(tp^.trhs);
					if tq = typnods[tset] then
						eexpr(tp^.trhs)
					else begin
						eselect(tp^.trhs);
						write('S')
					     end;
					dropset := false;
					write(', sizeof(');
					eselect(tp^.tlhs);
					write('S))')
				    end
				else begin
					eexpr(tp^.tlhs);
					write(' = ');
					eexpr(tp^.trhs)
				     end
			     end
		    end;

		  ncall:
		    begin
			tq := idup(tp^.tcall);
			if (tq^.tt in [nfunc, nproc]) and
					(tq^.tsubstmt <> nil) then
				if tq^.tsubstmt^.tt = npredef then
					epredef(tq, tp)
				else
					ecall(tp)
			else
				ecall(tp)
		    end;

		  nselect:
		    begin
			eselect(tp^.trecord);
			eexpr(tp^.tfield)
		    end;
		  nindex:
		    begin
			eselect(tp^.tvariable);
			write('A[');
			tq := tp^.toffset;
			if arithexpr(tq) then
				eexpr(tq)
			else begin
				write('(int)(');
				eexpr(tq);
				write(')')
			     end;
			tq := typeof(tp^.tvariable);
			if tq^.tt = narray then
				if clower(tq^.taindx) <> 0 then
				    begin
					write(' - ');
					tq := typeof(tq^.taindx);
					if tq^.tt = nsubrange then
						if arithexpr(tq^.tlo) then
							eexpr(tq^.tlo)
						else begin
							write('(int)(');
							eexpr(tq^.tlo);
							write(')')
						     end
					else 
						fatal(etree)
				    end;
			write(']')
		    end;
		  nderef:
		    begin
			tq := typeof(tp^.texps);
			if (tq^.tt = nfileof) or
			     ((tq^.tt = npredef) and (tq^.tdef = dtext)) then
			    begin
				(* using a file-variable as pointer *)
				eexpr(tp^.texps);
				write('.buf')
			    end
			else if doarrow then
			    begin
				doarrow := false;
				eexpr(tp^.texps);
				write('->');
				donearr := true
			    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
				if doarrow then
				    begin
					doarrow := false;
					printid(tp^.tsym^.lid);
					write('->');
					donearr := true
				    end
				else 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:
				printid(tp^.tsym^.lid);
			  nptr:
			    begin
				tq := typeof(tp^.tptrid);
				if tq^.tt = nrecord then
				    begin
					write('struct ');
					printid(tq^.tuid)
				    end
				else
					printid(tp^.tptrid^.tsym^.lid);
				write(' *');
			    end;
			  nscalar:
			    begin
				write('enum { ');
				increment;
				tp := tp^.tscalid;

				(* avoid bug in C-compiler:
					   enums are mixed in same namespace *)
				if tp^.tsym^.lid^.inref > 1 then
					tp^.tsym^.lid :=
						mkrename('E', tp^.tsym^.lid);
				printid(tp^.tsym^.lid);
				i := 1;
				while tp^.tnext <> nil do
				    begin
					if i >= 4 then
					    begin
						writeln(',');
						indent;
						i := 1
					    end
					else begin
						write(', ');
						i := i + 1
					     end;
					tp := tp^.tnext;
					if tp^.tsym^.lid^.inref > 1 then
					    tp^.tsym^.lid :=
						mkrename('E', tp^.tsym^.lid);
					printid(tp^.tsym^.lid)
				    end;
				decrement;
				write(' } ')
			    end;
			  nsubrange:
			    begin
				tq := typeof(tp^.tlo);
				if tq = typnods[tinteger] then
					etrange(tp)
				else begin
					if tq^.tup^.tt = ntype then
						tq := tq^.tup^.tidl;
					etdef(nil, tq)
				     end
			    end;
			  nfield:
			    begin
				etdef(nil, tp^.tbind);
				write(tab1);
				tp := tp^.tidl;
				if uid <> nil then
					tp^.tsym^.lid :=
						mkconc('.', uid, tp^.tsym^.lid);
				printsuf(tp^.tsym^.lid);
				i := 1;
				while tp^.tnext <> nil do
				    begin
					if i >= 4 then
					    begin
						writeln(',');
						indent;
						write(tab1);
						i := 1
					    end
					else begin
						write(', ');
						i := i + 1
					     end;
					tp := tp^.tnext;
					if uid <> nil then
					    tp^.tsym^.lid :=
						mkconc('.', uid, tp^.tsym^.lid);
					printsuf(tp^.tsym^.lid);
				    end;
				writeln(';');
			    end;
			  nrecord:
			    begin
				write('struct ');
				if tp^.tuid = nil then
					tp^.tuid := uid
				else if uid = nil then
					printid(tp^.tuid);
				writeln(' {');
				increment;
				if (tp^.tflist = nil) and
							(tp^.tvlist = nil) then
				    begin
					(* C doesn't allow empty structures *)
					indent;
					writeln(inttyp, tab1, 'dummy;')
				    end;
				tq := tp^.tflist;
				while tq <> nil do
				    begin
					indent;
					etdef(uid, tq);
					tq := tq^.tnext
				    end;
				if tp^.tvlist <> nil then
				    begin
					indent;
					writeln('union {');
					increment;
					tq := tp^.tvlist;
					while tq <> nil do
					    begin
						if (tq^.tvrnt^.tflist <> nil) or
						 (tq^.tvrnt^.tvlist <> nil) then
						    begin
							indent;
							if uid = nil then
							    etdef(mkvrnt,
								tq^.tvrnt)
							else
							    etdef(mkconc('.',
								   uid, mkvrnt),
								tq^.tvrnt);
							writeln(';')
						    end;
						tq := tq^.tnext
					    end;
					decrement;
					indent;
					writeln('} U;');
				    end;
				decrement;
				indent;
				if tp^.tup^.tt = nvariant then
				    begin
					write('} ');
					printsuf(tp^.tuid)
				    end
				else
					write('}');
			    end;
			  nconfarr:
			    begin
				write('struct ');
				printid(tp^.tcuid);
				write(' { ');
				etdef(nil, tp^.tcelem);
				write(tab1, 'A[]; }')
			    end;
			  narray:
			    begin
				write('struct { ');
				etdef(nil, tp^.taelem);
				write(tab1, 'A[');
				tq := typeof(tp^.taindx);
				if tq^.tt = nsubrange then
				    begin
					if arithexpr(tq^.thi) then
					    begin
						eexpr(tq^.thi);
						if cvalof(tq^.tlo) <> 0 then
						    begin
							write(' - ');
							eexpr(tq^.tlo)
						    end
					    end
					else begin
						write('(int)(');
						eexpr(tq^.thi);
						if cvalof(tq^.tlo) <> 0 then
						    begin
							write(') - (int)(');
							eexpr(tq^.tlo)
						    end;
						write(')')
					     end;
					write(' + 1')
				    end
				else
					write(crange(tp^.taindx):1);
				write(']; }')
			    end;
			  nfileof:
			    begin
				writeln('struct {');
				indent;
				writeln(tab1, 'FILE', tab1, '*fp;');
				indent;
				writeln(tab1, filebits, tab1, 'eoln:1,');
				indent;
				writeln(tab3, 'eof:1,');
				indent;
				writeln(tab3, 'out:1,');
				indent;
				writeln(tab3, 'init:1,');
				indent;
				writeln(tab3, ':', filefill:1, ';');
				indent;
				write(tab1);
				etdef(nil, tp^.tof);
				writeln(tab1, 'buf;');
				indent;
				write('} ')
			    end;
			  nsetof:
				write('struct { ', setwtyp, tab1, 'S[',
							csetsize(tp):1, ']; }');
			  npredef:
			    begin
				case tp^.tobtyp of
				  tboolean:
					printid(defnams[dboolean]^.lid);
				  tchar:
					write(chartyp);
				  tinteger:
					printid(defnams[dinteger]^.lid);
				  treal:
					printid(defnams[dreal]^.lid);
				  tstring:
					write(chartyp, ' *');
				  ttext:
					write('text');
				  tnil,
				  tset,
				  terror:
					fatal(etree);
				  tnone:
					write(voidtyp);
				end (* case *)
			    end;
			  nempty:
				write(voidtyp);
			end;(* case *)
		end;	(* etdef *)
	begin
		etdef(nil, tp)
	end;	(* etypedef *)

	(*	Emit code for type declarations.			*)
	procedure etype(tp : treeptr);

	var	sp	: symptr;

	begin
		while tp <> nil do
		    begin
			(* if identifier used more than once we rename the type
			   to avoid typedef'ing an identifier twice *)
			sp := tp^.tidl^.tsym;
			if sp^.lid^.inref > 1 then
				sp^.lid := mkrename('Y', sp^.lid);
			indent;
			write(typdef);
			etypedef(tp^.tbind);
			write(tab1);
			printid(sp^.lid);
			writeln(';');
			tp := tp^.tnext
		    end
	end;

	(*	Emit code for variable declarations.			*)
	procedure evar(tp : treeptr);

	label	555;

	var	tq	: treeptr;
		i	: integer;

	begin
		while tp <> nil do
		    begin
			indent;
			case tp^.tt of
			  nvar,
			  nvalpar,
			  nvarpar:
			    begin
				if tp^.tattr = aregister then
					write(registr);
				etypedef(tp^.tbind)
			    end;
			  nparproc,
			  nparfunc:
			    begin
				if tp^.tt = nparproc then
					write(voidtyp)
				else
					etypedef(tp^.tpartyp);
				tq := tp^.tparid;
				write(tab1, '(*');
				printid(tq^.tsym^.lid);
				write(')()');
				goto 555
			    end
			end;(* case *)
			write(tab1);
			tq := tp^.tidl;
			i := 1;
			repeat
				if tp^.tt = nvarpar then
					write('*');
				printid(tq^.tsym^.lid);
				tq := tq^.tnext;
				if tq <> nil then
				    begin
					if i >= 6 then
					    begin
						i := 1;
						writeln(',');
						indent;
						write(tab1)
					    end
					else begin
						i := i + 1;
						write(', ')
					     end

				    end
			until	tq = nil;
		555:
			writeln(';');
			if tp^.tt = nvarpar then
				if tp^.tbind^.tt = nconfarr then
				    begin
					indent;
					etypedef(tp^.tbind^.tindtyp);
					write(tab1);
					tq := tp^.tbind^.tcindx^.thi;
					printid(tq^.tsym^.lid);
					writeln(';')
				    end;
			tp := tp^.tnext
		    end
	end;	(* evar *)

	(*	Emit code for a statment.				*)
	procedure estmt(tp : treeptr);

	var	tq	: treeptr;
		locid1,
		locid2	: idptr;
		stusd	: boolean;
		opc1,
		opc2	: char;

		(*	Emit typename for with-variable.		*)
		procedure ewithtype(tp : treeptr);

		var	tq	: treeptr;

		begin
			tq := typeof(tp);
			write('struct ');
			printid(tq^.tuid)
		end;

		(*	Emit code for a case-choise.		*)
		procedure echoise(tp : treeptr);

		var	tq	: treeptr;
			i	: integer;

		begin
			while tp <> nil do
			    begin
				tq := tp^.tchocon;
				i := 0;
				indent;
				while tq <> nil do
				    begin
					write('  case ');
					conflag := true;
					eexpr(tq);
					conflag := false;
					write(':');
					i := i + 1;
					tq := tq^.tnext;
					if (tq = nil) or (i mod 4 = 0) then
					    begin
						writeln;
						if tq <> nil then
							indent;
						i := 0
					    end
				    end;
				increment;
				if tp^.tchostmt^.tt = nbegin then
					estmt(tp^.tchostmt^.tbegin)
				else
					estmt(tp^.tchostmt);
				indent;
				writeln('break ;');
				decrement;
				tp := tp^.tnext;
				if tp <> nil then
					if tp^.tchocon = nil then
						tp := nil
			    end
		end;	(* echoise *)

		(*	Rename all accessible record-fields to include	*)
		(*	pointer name.					*)
		procedure cenv(ip : idptr; dp : declptr);

		var	tp	: treeptr;
			sp	: symptr;
			np	: idptr;
			h	: hashtyp;

		begin
			with dp^ do
			  for h := 0 to hashmax - 1 do
			    begin
				sp := ddecl[h];
				while sp <> nil do
				    begin
					if sp^.lt = lfield  then
					    begin
						np := sp^.lid;
						tp := sp^.lsymdecl^.tup^.tup;
						if (tp^.tup^.tt = nvariant) and
							(tp^.tuid <> nil) then
							np := mkconc('.',
								tp^.tuid, np);
						np := mkconc('>', ip, np);
						sp^.lid := np
					    end;
					sp := sp^.lnext
				    end
			    end
		end;	(* cenv *)

		(*	Emit identifiers for push/pop of global ptrs.	*)
		procedure eglobid(tp : treeptr);

		var	j	: toknidx;
			w	: toknbuf;

		begin
			gettokn(tp^.tsym^.lid^.istr, w);
			j := 1;
			if w[1] = '*' then
				j := 2;
			while w[j] <> chr(null) do
			    begin
				write(w[j]);
				j := j + 1
			    end
		end;

	begin	(* estmt *)
		while tp <> nil do
		    begin
			case tp^.tt of
			  nbegin:
			    begin
				if tp^.tup^.tt in [nbegin, nrepeat,
						nproc, nfunc, npgm] then
					indent;
				writeln('{');
				increment;
				estmt(tp^.tbegin);
				decrement;
				indent;
				write('}');
				if tp^.tup^.tt <> nif then
					writeln
			    end;
			  nrepeat:
			    begin
				indent;
				writeln('do {');
				increment;
				estmt(tp^.treptstmt);
				decrement;
				indent;
				write('} while (!(');
				eexpr(tp^.treptxp);
				writeln('));')
			    end;
			  nwhile:
			    begin
				indent;
				write('while (');
				increment;
				eexpr(tp^.twhixp);
				stusd := setused;
				if tp^.twhistmt^.tt = nbegin then
				    begin
					decrement;
					write(') ');
					estmt(tp^.twhistmt)
				    end
				else begin
					writeln(')');
					estmt(tp^.twhistmt);
					decrement
				     end;
				setused := stusd or setused
			    end;
			  nfor:
			    begin
				indent;
				if tp^.tincr then
				    begin
					opc1 := '+';	(* increment variable *)
					opc2 := '<'	(* test for <= *)
				    end
				else begin
					opc1 := '-';	(* decrement variable *)
					opc2 := '>';	(* test for >= *)
				     end;
				if not lazyfor then
				    begin
					locid1 := mkvariable('B');
					locid2 := mkvariable('B');
					writeln('{');
					increment;
					indent;
					tq := idup(tp^.tforid);
					etypedef(tq^.tbind);
					tq := typeof(tq^.tbind);
					write(tab1);
					printid(locid1);
					write(' = ');
					eexpr(tp^.tfrom);
					writeln(',');
					indent;
					write(tab1);
					printid(locid2);
					write(' = ');
					eexpr(tp^.tto);
					writeln(';');
					writeln;
					indent;
					write('if (');
					if tq^.tt = nscalar then
					    begin
						write('(int)(');
						printid(locid1);
						write(')')
					    end
					else
						printid(locid1);
					write(' ', opc2, '= ');
					if tq^.tt = nscalar then
					    begin
						write('(int)(');
						printid(locid2);
						write(')')
					    end
					else
						printid(locid2);
					writeln(')');
					increment;
					indent;
					tp^.tfrom := newid(locid1);
					tp^.tfrom^.tup := tp
				    end;
				write('for (');
				increment;
				eexpr(tp^.tforid);
				tq := typeof(tp^.tforid);
				write(' = ');
				eexpr(tp^.tfrom);
				write('; ');
				if lazyfor then
				    begin
					if tq^.tt = nscalar then
					    begin
						write('(int)(');
						eexpr(tp^.tforid);
						write(')')
					    end
					else
						eexpr(tp^.tforid);
					write(' ', opc2, '= ');
					if tq^.tt = nscalar then
					    begin
						write('(int)(');
						eexpr(tp^.tto);
						write(')')
					    end
					else
						eexpr(tp^.tto)
				    end;
				write('; ');
				eexpr(tp^.tforid);
				if tq^.tt = nscalar then
				    begin
					write(' = (');
					eexpr(tq^.tup^.tidl);
					write(')((int)(');
					eexpr(tp^.tforid);
					write(')', opc1, '1)')
				    end
				else
					write(opc1, opc1);
				if not lazyfor then
				    begin
					if tp^.tforstmt^.tt <> nbegin then
					    begin
						(* create compund stmt *)
						tq := mknode(nbegin);
						tq^.tbegin := tp^.tforstmt;
						tq^.tbegin^.tup := tq;
						tp^.tforstmt := tq;
						tq^.tup := tp
					    end;
					(* find end of loop *)
					tq := tp^.tforstmt^.tbegin;
					while tq^.tnext <> nil do
						tq := tq^.tnext;
					(* add break stmt *)
					tq^.tnext := mknode(nbreak);
					tq := tq^.tnext;
					tq^.tup := tp^.tforstmt;
					tq^.tbrkid := tp^.tforid;
					tq^.tbrkxp := newid(locid2);
					tq^.tbrkxp^.tup := tq
				    end;
				if tp^.tforstmt^.tt = nbegin then
				    begin
					decrement;
					write(') ');
					estmt(tp^.tforstmt)
				    end
				else begin
					writeln(')');
					estmt(tp^.tforstmt);
					decrement
				     end;
				if not lazyfor then
				    begin
					decrement;
					decrement;
					indent;
					writeln('}')
				    end
			    end;
			  nif:
			    begin
				indent;
				write('if (');
				increment;
				eexpr(tp^.tifxp);
				stusd := setused;
				setused := false;
				if tp^.tthen^.tt = nbegin then
				    begin
					decrement;
					write(') ');
					estmt(tp^.tthen);
					if tp^.telse <> nil then
						write(space)
					else
						writeln
				    end
				else begin
					writeln(')');
					estmt(tp^.tthen);
					decrement;
					if tp^.telse <> nil then
						indent
				     end;
				if tp^.telse <> nil then
				    begin
					write('else');
					if tp^.telse^.tt = nbegin then
					    begin
						write(space);
						estmt(tp^.telse);
						writeln
					    end
					else begin
						increment;
						writeln;
						estmt(tp^.telse);
						decrement
					     end;
				    end;
				setused := stusd or setused
			    end;
			  ncase:
			    begin
				indent;
				write('switch ((int)(');
				increment;
				eexpr(tp^.tcasxp);
				writeln(')) {');
				decrement;
				echoise(tp^.tcaslst);
				indent;
				writeln('  default:');
				increment;
				if tp^.tcasother = nil then
				    begin
					indent;
					writeln('Caseerror(Line);')
				    end
				else
					estmt(tp^.tcasother);
				decrement;
				indent;
				writeln('}')
			    end;
			  nwith:
			    begin
				indent;
				writeln('{');
				increment;
				tq := tp^.twithvar;
				while tq <> nil do
				    begin
					indent;
					write(registr);
					ewithtype(tq^.texpw);
					write(' *');
					locid1 := mkvariable('W');
					printid(locid1);
					write(' = ');
					eaddr(tq^.texpw);
					writeln(';');
					cenv(locid1, tq^.tenv);
					tq := tq^.tnext
				    end;
				writeln;
				if tp^.twithstmt^.tt = nbegin then
					estmt(tp^.twithstmt^.tbegin)
				else
					estmt(tp^.twithstmt);
				decrement;
				indent;
				writeln('}')
			    end;
			  ngoto:
			    begin
				indent;
				if islocal(tp^.tlabel) then
					writeln('goto L',
						tp^.tlabel^.tsym^.lno:1, ';')
				else begin
					tq := idup(tp^.tlabel);
					writeln('longjmp(J[',	(* LIB *)
						tq^.tstat:1, '].jb, ',
						tp^.tlabel^.tsym^.lno:1, ');')
				     end
			    end;
			  nlabstmt:
			    begin
				decrement;
				indent;
				writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
				increment;
				estmt(tp^.tstmt)
			    end;
			  nassign:
			    begin
				indent;
				eexpr(tp);
				writeln(';')
			    end;
			  ncall:
			    begin
				indent;
				tq := idup(tp^.tcall);
				if (tq^.tt in [nfunc, nproc]) and
						(tq^.tsubstmt <> nil) then
					if tq^.tsubstmt^.tt = npredef then
						epredef(tq, tp)
					else begin
						ecall(tp);
						writeln(';')
					     end
				else begin
					ecall(tp);
					writeln(';')
				     end
			    end;
			  npush:
			    begin
				indent;
				eglobid(tp^.ttmp);
				write(' = ');
				eglobid(tp^.tglob);
				writeln(';');
				indent;
				eglobid(tp^.tglob);
				write(' = ');
				if tp^.tloc^.tt = nid then
				    begin
					tq := idup(tp^.tloc);
					if tq^.tt in [nparproc, nparfunc] then
						printid(tp^.tloc^.tsym^.lid)
					else
						eaddr(tp^.tloc)
				    end
				else
					eaddr(tp^.tloc);
				writeln(';')
			    end;
			  npop:
			    begin
				indent;
				eglobid(tp^.tglob);
				write(' = ');
				eglobid(tp^.ttmp);
				writeln(';')
			    end;
			  nbreak:
			    begin
				indent;
				write('if (');
				eexpr(tp^.tbrkid);
				write(' == ');
				eexpr(tp^.tbrkxp);
				writeln(') break;')
			    end;
			  nempty:
				if not (tp^.tup^.tt in [npgm, nproc, nfunc,
						nchoise, nbegin, nrepeat]) then
				    begin
					indent;
					writeln(';')
				    end
			end;(* case *)
			if setused and
				(tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
						nbegin, nchoise, nwith]) then
			    begin
				indent;
				writeln('Claimset();');
				setused := false
			    end;
			tp := tp^.tnext
		    end
	end;	(* estmt *)

	(*	Emit initialization for non-local gotos.		*)
	procedure elabel(tp : treeptr);

	var	tq	: treeptr;
		i	: integer;

	begin
		i := 0;
		tq := tp^.tsublab;
		while tq <> nil do
		    begin
			if tq^.tsym^.lgo then
				i := i + 1;
			tq := tq^.tnext
		    end;
		if i =1 then
		    begin
			tq := tp^.tsublab;
			while not tq^.tsym^.lgo do
				tq := tq^.tnext;
			indent;
			writeln('if (',
				'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
			writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
		    end
		else if i > 1 then
		    begin
			indent;
			writeln('switch (',
				'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
			indent;
			writeln('  case 0:');
			indent;
			writeln(tab1, 'break;');
			tq := tp^.tsublab;
			while tq <> nil do
			    begin
				if tq^.tsym^.lgo then
				    begin
					(* label used in non-local goto *)
					indent;
					writeln('  case ',
							tq^.tsym^.lno:1, ':');
					indent;
					writeln(tab1, 'goto L',
							tq^.tsym^.lno:1, ';')
				    end;
				tq := tq^.tnext
			    end;
			indent;
			writeln('  default:');
			indent;
			writeln(tab1, 'Caseerror(Line);');
			indent;
			writeln('}')
		    end
	end;	(* elabel *)

	(*	Emit declaration for lower bound of conformant array.	*)
	procedure econf(tp : treeptr);

	var	tq	: treeptr;

	begin
		while tp <> nil do
		    begin
			if tp^.tt = nvarpar then
				if tp^.tbind^.tt = nconfarr then
				    begin
					indent;
					etypedef(tp^.tbind^.tindtyp);
					write(tab1);
					tq := tp^.tbind^.tcindx^.tlo;
					printid(tq^.tsym^.lid);
					write(' = (');
					etypedef(tp^.tbind^.tindtyp);
					writeln(')0;')
				    end;
			tp := tp^.tnext
		    end
	end;	(* econf *)

	(*	Emit code for subroutines.				*)
	procedure esubr(tp : treeptr);

	label	999;

	var	tq, ti	: treeptr;

	begin
		while tp <> nil do
		    begin
			(* emit nested subroutines *)
			if tp^.tsubsub <> nil then
			    begin
				(* emit forward declaration of this subroutine
				   in case of recursion *)
				etypedef(tp^.tfuntyp);
				write(space);
				printid(tp^.tsubid^.tsym^.lid);
				writeln('();');
				writeln;
				esubr(tp^.tsubsub)
			    end;
			(* emit this subroutine *)
			if tp^.tsubstmt = nil then
			    begin
				(* forward/external decl *)
				if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
					write(xtern);
				etypedef(tp^.tfuntyp);
				write(space);
				printid(tp^.tsubid^.tsym^.lid);
				writeln('();');
				goto 999
			    end;
			write(space);
			etypedef(tp^.tfuntyp);
			writeln;
			printid(tp^.tsubid^.tsym^.lid);
			write('(');
			tq := tp^.tsubpar;
			while tq <> nil do
			    begin
				case tq^.tt of
				  nvarpar,
				  nvalpar:
				    begin
					ti := tq^.tidl;
					while ti <> nil do
					    begin
						printid(ti^.tsym^.lid);
						ti := ti^.tnext;
						if ti <> nil then
							write(', ');
					    end;
					if tq^.tbind^.tt = nconfarr then
					    begin
						(* add upper bound parameter *)
						ti := tq^.tbind^.tcindx^.thi;
						write(', ');
						printid(ti^.tsym^.lid)
					    end;
				    end;
				  nparproc,
				  nparfunc:
				    begin
					ti := tq^.tparid;
					printid(ti^.tsym^.lid)
				    end
				end;(* case *)
				tq := tq^.tnext;
				if tq <> nil then
					write(', ');
			    end;
			writeln(')');
			increment;
			evar(tp^.tsubpar);
			writeln('{');
			econf(tp^.tsubpar);
			econst(tp^.tsubconst);
			etype(tp^.tsubtype);
			evar(tp^.tsubvar);

			if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
					(tp^.tsubvar <> nil) then
				writeln;
			elabel(tp);
			estmt(tp^.tsubstmt);
			if tp^.tt = nfunc then
			    begin
				(* return value in the FIRST variable,
				   see renamf() above *)
				indent;
				write('return ');
				printid(tp^.tsubvar^.tidl^.tsym^.lid);
				writeln(';');
			    end;
			decrement;
			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;

		procedure etextdef;

		var	tq	: treeptr;

		begin
			write('typedef ');
			tq := mknode(nfileof);
			tq^.tof := typnods[tchar];
			etypedef(tq);
			writeln(tab1, 'text;')
		end;

	begin	(* eprogram *)
		if tp^.tsubid <> nil then
		    begin
			(* program heading was seen *)
			writeln('/', '*');
			write('**	Code derived from program ');
			printid(tp^.tsubid^.tsym^.lid);
			writeln;
			writeln('*', '/');
			writeln(xtern, voidtyp, tab1, 'exit();')
		    end;
		if usecase or usesets or
		   use(dinput) or use(doutput) or
		   use(dwrite) or use(dwriteln) or use(dmessage) or
		   use(deof) or use(deoln) or use(dflush) or use(dpage) or
		   use(dread) or use(dreadln) or use(dclose) or
		   use(dreset) or use(drewrite) or use(dget) or use(dput) then
		    begin
			writeln('/', '*');
			writeln('**	Definitions for i/o');
			writeln('*', '/');
			writeln(include, '<stdio.h>')	(* LIB *)
		    end;
		if use(dinput) or use(doutput) or use(dtext) then
		    begin
			etextdef;
			if use(dinput) then
			    begin
				if tp^.tsubid = nil then
					write(xtern);
				write('text', tab1);
				printid(defnams[dinput]^.lid);
				if tp^.tsubid <> nil then
					write(' = { stdin, 0, 0 }');
				writeln(';')
			    end;
			if use(doutput) then
			    begin
				if tp^.tsubid = nil then
					write(xtern);
				write('text', tab1);
				printid(defnams[doutput]^.lid);
				if tp^.tsubid <> nil then
					write(' = { stdout, 0, 0 }');
				writeln(';')
			    end
		    end;
		if use(dinput) or use(dget) or use(dread) or use(dreadln) or
		   use(deof) or use(deoln) or use(dreset) or use(drewrite) then
		    begin
			writeln(define, 'Fread(x, f) ',
				'fread((char *)&x, sizeof(x), 1, f)'); (* LIB *)
			writeln(define, 'Get(f) Fread((f).buf, (f).fp)');
			writeln(define, 'Getx(f) (f).init = 1, ',
				'(f).eoln = (((f).buf = ',
					'fgetc((f).fp)',	(* LIB *)
					') == ', nlchr, ') ? (((f).buf = ',
						spchr, '), 1) : 0');
			writeln(define, 'Getchr(f) (f).buf, Getx(f)')
		    end;
		if use(dread) or use(dreadln) then
		    begin
			writeln(static, 'FILE', tab1, '*Tmpfil;');
			writeln(static, 'long', tab1, 'Tmplng;');
			writeln(static, 'double', tab1, 'Tmpdbl;');
			writeln(define, 'Fscan(f) (f).init ? ',
				'ungetc((f).buf, (f).fp)',	(* LIB *)
					' : 0, Tmpfil = (f).fp');
			writeln(define, 'Scan(p, a) ',
				'Scanck(fscanf(Tmpfil, p, a))'); (* LIB *)
			writeln(voidtyp, tab1, 'Scanck();');
			if use(dreadln) then
				writeln(voidtyp, tab1, 'Getl();');
		    end;
		if use(deoln) then
			writeln(define, 'Eoln(f) ((f).eoln ? true : false)');
		if use(deof) then
			writeln(define, 'Eof(f) ',
				'((((f).init == 0) ? (Get(f)) : 0, ',
					'((f).eof ? 1 : ',
						'feof((f).fp))) ? ', (* LIB *)
							'true : false)');
		if use(doutput) or use(dput) or
				use(dwrite) or use(dwriteln) or
				use(dreset) or use(drewrite) or use(dclose) then
		    begin
			writeln(define, 'Fwrite(x, f) ',
				'fwrite((char *)&x, sizeof(x), 1, f)');(* LIB *)
			writeln(define, 'Put(f) Fwrite((f).buf, (f).fp)');
			writeln(define, 'Putx(f) (f).eoln = ((f).buf == ',
			    nlchr, '), ', voidcast,
				'fputc((f).buf, (f).fp)'); (* LIB *)
			writeln(define, 'Putchr(c, f) (f).buf = (c), Putx(f)');
			writeln(define, 'Putl(f, v) (f).eoln = v')
		    end;
		if use(dreset) or use(drewrite) or use(dclose) then
		    begin
			writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
				'(Putchr(', nlchr, ', f), 0) : 0, ',
					'!fseek((f).fp, 0L, 0)'); (* LIB *)
			writeln(xtern, 'int', tab1, 'fseek();')	(* LIB *)
		    end;
		if use(dclose) then
		    begin
			writeln(define, 'Close(f) (f).init = ',
				'((f).init ? (',
					'fclose((f).fp), ',	(* LIB *)
						'0) : 0), (f).fp = NULL');
			writeln(define, 'Closex(f) (f).init = ',
				'((f).init ? ',
					'(Finish(f), ',
					'fclose((f).fp), ',	(* LIB *)
						'0) : 0), (f).fp = NULL')
		    end;
		if use(dreset) then
		    begin
			writeln(ifdef, 'READONLY');
			writeln(static, chartyp, tab1, 'Rmode[] = "r";');
			writeln(elsif);
			writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
			writeln(endif);
			writeln(define, 'Reset(f, n, l) (f).init = ',
			    '(f).init ? !fseek((f).fp, 0L, 0) : ', (* LIB *)
				'(((f).fp = Fopen(n, l, Rmode)), 1), ',
					'(f).eof = (f).out = 0, Get(f)');
			writeln(define, 'Resetx(f, n, l) (f).init = ',
			    '(f).init ? (Finish(f)) : ',
				'(((f).fp = Fopen(n, l, Rmode)), 1), ',
					'(f).eof = (f).out = 0, Getx(f)');
			usefopn := true
		    end;
		if use(drewrite) then
		    begin
			writeln(ifdef, 'WRITEONLY');
			writeln(static, chartyp, tab1, 'Wmode[] = "w";');
			writeln(elsif);
			writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
			writeln(endif);
			writeln(define, 'Rewrite(f, n, l) (f).init = ',
			    '(f).init ? !fseek((f).fp, 0L, 0) : ', (* LIB *)
				'(((f).fp = Fopen(n, l, Wmode)), 1), ',
					'(f).out = (f).eof = 1');
			writeln(define, 'Rewritex(f, n, l) (f).init = ',
			    '(f).init ? (Finish(f)) : ',
				'(((f).fp = Fopen(n, l, Wmode)), 1), ',
					'(f).out = (f).eof = (f).eoln = 1');
			usefopn := true
		    end;
		if usefopn then
		    begin
			writeln('FILE	*Fopen();');
			writeln(ifndef, maxfilename);
			writeln(define, maxfilename, ' ', (maxtoknlen+1):1);
			writeln(endif)
		    end;
		if usecase or usejmps then
		    begin
			writeln('/', '*');
			writeln('**	Definitions for case-statements');
			writeln('**	and for non-local gotos');
			writeln('*', '/');
			writeln(define, 'Line __LINE__');
			writeln(voidtyp, tab1, 'Caseerror();')
		    end;
		if usejmps then
		    begin
			writeln(include, '<setjmp.h>');	(* LIB *)
			writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
							(maxlevel+1):1, '];')
		    end;
		if use(dinteger) or use(dmaxint) or 
			use(dboolean) or use(dfalse) or use(dtrue) or
				use(deof) or use(deoln) or use(dexp) or
				use(dln) or use(dsqr) or use(dsin) or
				use(dcos) or use(dtan) or use(darctan) or
				use(dsqrt) or use(dreal) then
		    begin
			writeln('/', '*');
			writeln('**	Definitions for standard types');
			writeln('*', '/')
		    end;
		if usecomp then
		    begin
			writeln(xtern, inttyp, ' strncmp();');	(* LIB *)
			writeln(define,
				'Cmpstr(x, y) ',
				'strncmp((x), (y), sizeof(x))')	(* LIB *)
		    end;
		if use(dboolean) or use(dfalse) or use(dtrue) or
			use(deof) or use(deoln) or usesets then
		    begin
			capital(defnams[dboolean]);
			write(typdef, chartyp, tab1);
			printid(defnams[dboolean]^.lid);
			writeln(';');
			capital(defnams[dfalse]);
			write(define);
			printid(defnams[dfalse]^.lid);
			write(' (');
			printid(defnams[dboolean]^.lid);
			writeln(')0');
			capital(defnams[dtrue]);
			write(define);
			printid(defnams[dtrue]^.lid);
			write(' (');
			printid(defnams[dboolean]^.lid);
			writeln(')1');
			writeln(chartyp, tab1, '*Bools[];')
		    end;
		capital(defnams[dinteger]);
		if use(dinteger) then
		    begin
			write(typdef, inttyp, tab1);
			printid(defnams[dinteger]^.lid);
			writeln(';')
		    end;
		if use(dmaxint) then
			writeln(define, 'maxint', tab1, maxint:1);
		capital(defnams[dreal]);
		if use(dreal) then
		    begin
			write(typdef, realtyp, tab1);
			printid(defnams[dreal]^.lid);
			writeln(';')
		    end;
		if use(dexp) then
			writeln(xtern, doubletyp, ' exp();');	(* LIB *)
		if use(dln) then
			writeln(xtern, doubletyp, ' log();');	(* LIB *)
		if use(dsqr) then
			writeln(xtern, doubletyp, ' pow();');	(* LIB *)
		if use(dsin) then
			writeln(xtern, doubletyp, ' sin();');	(* LIB *)
		if use(dcos) then
			writeln(xtern, doubletyp, ' cos();');	(* LIB *)
		if use(dtan) then
			writeln(xtern, doubletyp, ' tan();');	(* LIB *)
		if use(darctan) then
			writeln(xtern, doubletyp, ' atan();');	(* LIB *)
		if use(dsqrt) then
			writeln(xtern, doubletyp, ' sqrt();');	(* LIB *)
		if use(dabs) and use(dreal) then
			writeln(xtern, doubletyp, ' fabs();');	(* LIB *)
		if use(dhalt) then
			writeln(xtern, voidtyp, ' abort();');	(* LIB *)
		if use(dnew) or usenilp then
		    begin
			writeln('/', '*');
			writeln('**	Definitions for pointers');
			writeln('*', '/');
		    end;
		if use(dnew) then
		    begin
			writeln(ifndef, 'Unionoffs');
			writeln(define, 'Unionoffs(p, m) ',
			    '(((long)(&(p)->m))-((long)(p)))');	(* CPU *)
			writeln(endif)
		    end;
		if usenilp then
			writeln(define, 'NIL 0');		(* CPU *)
		if use(dnew) then
			writeln(xtern, chartyp, ' *malloc();');	(* LIB *)
		if use(ddispose) then
			writeln(xtern, voidtyp, ' free();');	(* LIB *)
		if usesets then
		    begin
			writeln('/', '*');
			writeln('**	Definitions for set-operations');
			writeln('*', '/');
			writeln(define, 'Claimset() ',
				voidcast, 'Currset(0, (', setptyp, ')0)');
			writeln(define, 'Newset() ',
					'Currset(1, (', setptyp, ')0)');
			writeln(define, 'Saveset(s) Currset(2, s)');
			writeln(define, 'setbits ', setbits:1);
			writeln(typdef, wordtype, tab1, setwtyp, ';');
			writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
			printid(defnams[dboolean]^.lid);
			writeln(tab1, 'Member(), Le(), Ge(), Eq(), Ne();');
			writeln(setptyp, tab1, 'Union(), Diff();');
			writeln(setptyp, tab1, 'Insmem(), Mksubr();');
			writeln(setptyp, tab1, 'Currset(), Inter();');
			writeln(static, setptyp, tab1, 'Tmpset;');
			writeln(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;
		writeln(xtern, chartyp, ' *strncpy();');	(* LIB *)
		if use(dargc) or use(dargv) then
		    begin
			writeln('/', '*');
			writeln('**	Definitions for argv-operations');
			writeln('*', '/');
			writeln(inttyp, tab1, 'argc;');		(* OS *)
			writeln(chartyp, tab1, '**argv;');
			writeln(' void');
			writeln('Argvgt(n, cp, l)');
			writeln(inttyp, tab1, 'n;');
			writeln(registr, inttyp, tab1, 'l;');
			writeln(registr, chartyp, tab1, '*cp;');
			writeln('{');
			writeln(tab1, registr, chartyp, tab1, '*sp;');
			writeln;
			writeln(tab1, 'for (sp = argv[n]; l > 0 && *sp; l--)');
			writeln(tab2, '*cp++ = *sp++;');
			writeln(tab1, 'while (l-- > 0)');
			writeln(tab2, '*cp++ = ', spchr, ';');
			writeln('}');
		    end;
		if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
			(tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
		    begin
			writeln('/', '*');
			writeln('**	Start of program definitions');
			writeln('*', '/');
		    end;
		econst(tp^.tsubconst);
		etype(tp^.tsubtype);
		evar(tp^.tsubvar);
		if tp^.tsubsub <> nil then
			writeln;
		esubr(tp^.tsubsub);
		if tp^.tsubid <> nil then
		    begin
			(* program heading was seen *)
			writeln('/', '*');
			writeln('**	Start of program code');
			writeln('*', '/');
			if use(dargc) or use(dargv) then
			    begin
				writeln('main(_ac, _av)');	(* OS *)
				writeln(inttyp, tab1, '_ac;');
				writeln(chartyp, tab1, '*_av[];');
				writeln('{');
				writeln;
				writeln(tab1, 'argc = _ac;');
				writeln(tab1, 'argv = _av;')
			    end
			else begin
				writeln('main()');
				writeln('{')
			     end;
			if use(dinput) then
			    begin
				writeln(ifdef, 'STDINIT');
				writeln(tab1, voidcast, '(Getx(input));');
				writeln(endif)
			    end;
			increment;
			elabel(tp);
			estmt(tp^.tsubstmt);
			indent;
			writeln('exit(0);');
			indent;
			writeln('/', '* NOTREACHED *', '/');
			decrement;
			writeln('}');
			edconst(tp^.tsubconst);
			writeln('/', '*');
			writeln('**	End of program code');
			writeln('*', '/')
		    end
	end;	(* eprogram *)

	(*	Emit definitions for constant sets	*)
	procedure econset(tp : treeptr; len : integer);

	var	i	: integer;

		function size(tp : treeptr) : integer;

		var	r, x	: integer;

		begin
			r := 0;
			while tp <> nil do
			    begin
				if tp^.tt = nrange then
					x := cvalof(tp^.texpr)
				else if tp^.tt = nempty then
					x := 0
				else
					x := cvalof(tp);
				if x > r then
					r := x;
				tp := tp^.tnext
			    end;
			size := csetwords(r+1)
		end;

		(*	Emit bits in a constant set	*)
		procedure ebits(tp : treeptr);

		type	bitset	= set of 0 .. setbits;

		var	sets	: array [ 0 .. maxsetrange ] of bitset;
			s, m, n	: integer;

			procedure eword(s : bitset);

			const	bitshex	= 4;	(* nr of bits in a hex-digit *)

			var	n, i	: integer;
				x	: 0 .. setbits;

			begin
				n := 0;
				while n <= setbits do
					n := n + bitshex;
				n := n - bitshex;
				while n >= 0 do
				    begin
					(* compute 1 hexdigit *)
					x := 0;
					for i := 0 to bitshex - 1 do
						if (n + i) in s then
							case i of
							  0:	x := x + 1;
							  1:	x := x + 2;
							  2:	x := x + 4;
							  3:	x := x + 8
							end;(* case *)
					(* print it *)
					write(hexdig[x]);
					n := n - bitshex
				    end
			end;

		begin
			s := size(tp);
			for n := 0 to s - 1 do
				sets[n] := [];
			while tp <> nil do
			    begin
				if tp^.tt = nrange then
					for m := cvalof(tp^.texpl) to
							cvalof(tp^.texpr) do
					    begin
						n := m div (setbits+1);
						sets[n] := sets[n] +
							[m mod (setbits+1)]
					    end
				else if tp^.tt <> nempty then
				    begin
					m := cvalof(tp);
					n := m div (setbits+1);
					sets[n] := sets[n] +
						[m mod (setbits+1)]
				    end;
				tp := tp^.tnext
			    end;
			write(tab1, s:1);
			for n := 0 to s - 1 do
			    begin
				write(',');
				if n mod 6 = 0 then
					writeln;
				write(tab1, '0x');
				eword(sets[n]);
			    end;
			writeln
		end;

	begin
		i := 0;
		while tp <> nil do
		    begin
			writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
			ebits(tp^.texps);
			writeln('};');
			i := i + 1;
			tp := tp^.tnext
		    end;
		writeln(static, setwtyp, tab1, '*Conset[] = {');
		for i := len - 1 downto 1 do
		    begin
			write(tab1, 'Q', i:1, ',');
			if i mod 6 = 5 then
				writeln
		    end;
		writeln(tab1, 'Q0');
		writeln('};');
	end;

begin	(* emit *)
	indnt := 0;
	varno := 0;
	conflag := false;
	setused := false;
	dropset := false;
	doarrow := false;
	donearr := false;
	eprogram(top);
	if usebool then
		writeln(static, chartyp, tab1, '*Bools[] = { "false", "true" };');
	if usescan then
	    begin
		writeln;
		writeln(static, voidtyp);
		writeln('Scanck(n)');
		writeln(inttyp, tab1, 'n;');
		writeln('{');
		writeln(tab1, 'if (n != 1) {');
		writeln(tab2, voidcast, 'fprintf(stderr, "Bad input\n");');
		writeln(tab2, 'exit(1);');
		writeln(tab1, '}');
		writeln('}')
	    end;
	if usegetl then
	    begin
		writeln;
		writeln(static, voidtyp);
		writeln('Getl(f)');
		writeln(' text', tab1, '*f;');
		writeln('{');
		writeln(tab1, 'while (f->eoln == 0)');
		writeln(tab2, 'Getx(*f);');
		writeln(tab1, 'Getx(*f);');
		writeln('}')
	    end;
	if usefopn then
	    begin
		writeln;
		writeln(static, 'FILE *');
		writeln('Fopen(n, l, m)');
		writeln(chartyp, tab1, '*n, *m;');
		writeln(inttyp, tab1, 'l;');
		writeln('{');
		writeln(tab1, 'FILE', tab2, '*f;');
		writeln(tab1, registr, chartyp, tab1, '*s;');
		writeln(tab1, static, chartyp, tab1, 'ch = ',
						quote, 'A', quote, ';');
		writeln(tab1, static, chartyp, tab1, 'tmp[', maxfilename, '];');
		writeln(tab1, xtern , inttyp, tab1, 'unlink(),'); (* OS *)
		writeln(tab3, 'strlen();'); (* OS *)
		writeln;
		writeln(tab1, 'if (n == NULL)');
		writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
		writeln(tab1, 'else {');
		writeln(tab2, 'if (l < 0)');
		writeln(tab3, 'l = strlen(n);');
		writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
		writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
			spchr, ' || *s == ', nulchr, ' || s - tmp > l; )');
		writeln(tab3, '*s-- = ', nulchr, ';');
		writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
		writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
			quote, '%s', quote, '\n", n);');
		writeln(tab3, 'exit(1);');
		writeln(tab2, '}');
		writeln(tab1, '}');
		writeln(tab1, 's = tmp;');
		writeln(tab1, 'if ((f = fopen(s, m)) == NULL) {');
		writeln(tab2, voidcast,
				'fprintf(stderr, "Cannot open: %s\n", s);');
		writeln(tab2, 'exit(1);');
		writeln(tab1, '}');
		writeln(tab1, 'if (n == NULL)');
		writeln(tab2, 'unlink(tmp);');	(* OS *)
		writeln(tab1, 'return (f);');
		writeln('}');
	    end;
	if setcnt > 0 then
		econset(setlst, setcnt);
	if useunion then
	    begin
		writeln;
		writeln(static, setptyp);
		writeln('Union(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
		writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
		writeln(tab4, 'p3 = sp;');
		writeln;
		writeln(tab1, 'j = *p1;');
		writeln(tab1, '*p3 = j;');
		writeln(tab1, 'if (j > *p2)');
		writeln(tab2, 'j = *p2;');
		writeln(tab1, 'else');
		writeln(tab2, '*p3 = *p2;');
		writeln(tab1, 'k = *p1 - *p2;');
		writeln(tab1, 'p1++, p2++, p3++;');
		writeln(tab1, 'for (i = 0; i < j; i++)');
		writeln(tab2, '*p3++ = (*p1++ | *p2++);');
		writeln(tab1, 'while (k > 0) {');
		writeln(tab2, '*p3++ = *p1++;');
		writeln(tab2, 'k--;');
		writeln(tab1, '}');
		writeln(tab1, 'while (k < 0) {');
		writeln(tab2, '*p3++ = *p2++;');
		writeln(tab2, 'k++;');
		writeln(tab1, '}');
		writeln(tab1, 'return (Saveset(sp));');
		writeln('}')
	    end;
	if usediff then
	    begin
		writeln;
		writeln(static, setptyp);
		writeln('Diff(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
		writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
		writeln(tab4, 'p3 = sp;');
		writeln;
		writeln(tab1, 'j = *p1;');
		writeln(tab1, '*p3 = j;');
		writeln(tab1, 'if (j > *p2)');
		writeln(tab2, 'j = *p2;');
		writeln(tab1, 'k = *p1 - *p2;');
		writeln(tab1, 'p1++, p2++, p3++;');
		writeln(tab1, 'for (i = 0; i < j; i++)');
		writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
		writeln(tab1, 'while (k > 0) {');
		writeln(tab2, '*p3++ = *p1++;');
		writeln(tab2, 'k--;');
		writeln(tab1, '}');
		writeln(tab1, 'return (Saveset(sp));');
		writeln('}')
	    end;
	if useintr then
	    begin
		writeln;
		writeln(static, setptyp);
		writeln('Inter(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
		writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
		writeln(tab4, 'p3 = sp;');
		writeln;
		writeln(tab1, 'if ((j = *p1) > *p2)');
		writeln(tab2, 'j = *p2;');
		writeln(tab1, '*p3 = j;');
		writeln(tab1, 'p1++, p2++, p3++;');
		writeln(tab1, 'for (i = 0; i < j; i++)');
		writeln(tab2, '*p3++ = (*p1++ & *p2++);');
		writeln(tab1, 'return (Saveset(sp));');
		writeln('}')
	    end;
	if usememb then
	    begin
		writeln;
		write(static);
		printid(defnams[dboolean]^.lid);
		writeln;
		writeln('Member(m, sp)');
		writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
		writeln(tab1, registr, setptyp, tab1, 'sp;');
		writeln('{');
		writeln(tab1, registr, usigned, inttyp,
					tab1, 'i = m / (setbits+1) + 1;');
		writeln;
		writeln(tab1, 'if ((i <= *sp) &&',
					' (sp[i] & (1 << (m % (setbits+1)))))');
		write(tab2, 'return (');
		printid(defnams[dtrue]^.lid);
		writeln(');');
		write(tab1, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln('}')
	    end;
	if useseq or usesne then
	    begin
		writeln;
		write(static);
		printid(defnams[dboolean]^.lid);
		writeln;
		writeln('Eq(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab1, 'i, j;');
		writeln;
		writeln(tab1, 'i = *p1++;');
		writeln(tab1, 'j = *p2++;');
		writeln(tab1, 'while (i != 0 && j != 0) {');
		writeln(tab2, 'if (*p1++ != *p2++)');
		write(tab3, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln(tab2, 'i--, j--;');
		writeln(tab1, '}');
		writeln(tab1, 'while (i != 0) {');
		writeln(tab2, 'if (*p1++ != 0)');
		write(tab3, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln(tab2, 'i--;');
		writeln(tab1, '}');
		writeln(tab1, 'while (j != 0) {');
		writeln(tab2, 'if (*p2++ != 0)');
		write(tab3, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln(tab2, 'j--;');
		writeln(tab1, '}');
		write(tab1, 'return (');
		printid(defnams[dtrue]^.lid);
		writeln(');');
		writeln('}')
	    end;
	if usesne then
	    begin
		writeln;
		write(static);
		printid(defnams[dboolean]^.lid);
		writeln;
		writeln('Ne(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		write(tab1, 'return (!Eq(p1, p2));');
		writeln('}')
	    end;
	if usesle then
	    begin
		writeln;
		write(static);
		printid(defnams[dboolean]^.lid);
		writeln;
		writeln('Le(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab1, 'i, j;');
		writeln;
		writeln(tab1, 'i = *p1++;');
		writeln(tab1, 'j = *p2++;');
		writeln(tab1, 'while (i != 0 && j != 0) {');
		writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
		write(tab3, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln(tab2, 'i--, j--;');
		writeln(tab1, '}');
		writeln(tab1, 'while (i != 0) {');
		writeln(tab2, 'if (*p1++ != 0)');
		write(tab3, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln(tab2, 'i--;');
		writeln(tab1, '}');
		write(tab1, 'return (');
		printid(defnams[dtrue]^.lid);
		writeln(');');
		writeln('}')
	    end;
	if usesge then
	    begin
		writeln;
		write(static);
		printid(defnams[dboolean]^.lid);
		writeln;
		writeln('Ge(p1, p2)');
		writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab1, 'i, j;');
		writeln;
		writeln(tab1, 'i = *p1++;');
		writeln(tab1, 'j = *p2++;');
		writeln(tab1, 'while (i != 0 && j != 0) {');
		writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
		writeln(tab3, 'return (false);');
		writeln(tab2, 'i--, j--;');
		writeln(tab1, '}');
		writeln(tab1, 'while (j != 0) {');
		writeln(tab2, 'if (*p2++ != 0)');
		write(tab3, 'return (');
		printid(defnams[dfalse]^.lid);
		writeln(');');
		writeln(tab2, 'j--;');
		writeln(tab1, '}');
		write(tab1, 'return (');
		printid(defnams[dtrue]^.lid);
		writeln(');');
		writeln('}')
	    end;
	if usemksub then
	    begin
		writeln;
		writeln(static, setptyp);
		writeln('Mksubr(lo, hi, sp)');
		writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
		writeln(tab1, registr, setptyp, tab1, 'sp;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab1, 'i, k;');
		writeln;
		writeln(tab1, 'if (hi < lo)');
		writeln(tab2, 'return (sp);');
		writeln(tab1, 'i = hi / (setbits+1) + 1;');
		writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
		writeln(tab2, 'sp[k] = 0;');
		writeln(tab1, 'if (*sp < i)');
		writeln(tab2, '*sp = i;');
		writeln(tab1, 'for (k = lo; k <= hi; k++)');
		writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
						'(1 << (k % (setbits+1)));');
		writeln(tab1, 'return (sp);');
		writeln('}')
	    end;
	if useins then
	    begin
		writeln;
		writeln(static, setptyp);
		writeln('Insmem(m, sp)');
		writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
		writeln(tab1, registr, setptyp, tab1, 'sp;');
		writeln('{');
		writeln(tab1, registr, inttyp, tab1, 'i,');
		writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
		writeln;
		writeln(tab1, 'if (*sp < j)');
		writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
		writeln(tab3, 'sp[i] = 0;');
		writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
		writeln(tab1, 'return (sp);');
		writeln('}')
	    end;
	if usesets then
	    begin
		writeln;
		writeln(ifndef, 'SETSPACE');
		writeln(define, 'SETSPACE 256');
		writeln(endif);
		writeln(static, setptyp);
		writeln('Currset(n,sp)');
		writeln(tab1, inttyp, tab1, 'n;');
		writeln(tab1, setptyp, tab1, 'sp;');
		writeln('{');
		writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
		writeln(tab1, static, setptyp, tab1, 'Top = Space;');
		writeln;
		writeln(tab1, 'switch (n) {');
		writeln(tab1, '  case 0:');
		writeln(tab2, 'Top = Space;');
		writeln(tab2, 'return (0);');
		writeln(tab1, '  case 1:');
		writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
							maxsetrange:1, ') {');
		writeln(tab3,
			voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
		writeln(tab3, 'exit(1);');
		writeln(tab2, '}');
		writeln(tab2, '*Top = 0;');
		writeln(tab2, 'return (Top);');
		writeln(tab1, '  case 2:');
		writeln(tab2, 'if (Top <= &sp[*sp])');
		writeln(tab3, 'Top = &sp[*sp + 1];');
		writeln(tab2, 'return (sp);');
		writeln(tab1, '}');
		writeln(tab1, '/', '* NOTREACHED *', '/');
		writeln('}')
	    end;
	if usescpy then
	    begin
		writeln;
		writeln(static, voidtyp);
		writeln('Setncpy(S1, S2, N)');
		writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
		writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
		writeln('{');
		writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
		writeln;
		writeln(tab1, 'N /= sizeof(', setwtyp, ');');
		writeln(tab1, '*S1++ = --N;');
		writeln(tab1, 'm = *S2++;');
		writeln(tab1, 'while (m != 0 && N != 0) {');
		writeln(tab2, '*S1++ = *S2++;');
		writeln(tab2, '--N;');
		writeln(tab2, '--m;');
		writeln(tab1, '}');
		writeln(tab1, 'while (N-- != 0)');
		writeln(tab2, '*S1++ = 0;');
		writeln('}')
	    end;
	if 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 usecase or usejmps then
	    begin
		writeln;
		writeln(static, voidtyp);
		writeln('Caseerror(n)');
		writeln(tab1, inttyp, tab1, 'n;');
		writeln('{');
		writeln(tab1, voidcast,
			'fprintf(stderr, "Missing case limb: line %d\n", n);');
		writeln(tab1, 'exit(1);');
		writeln(tab1, '/', '* NOTREACHED *', '/');
		writeln('}')
	    end;
	if usemax then
	    begin
		writeln;
		writeln(static, inttyp);
		writeln('Max(m, n)');
		writeln(tab1, inttyp, tab1, 'm, n;');
		writeln('{');
		writeln(tab1, 'if (m > n)');
		writeln(tab2, 'return (m);');
		writeln(tab1, 'return (n);');
		writeln('}')
	    end;
	if use(dtrunc) then
	    begin
		writeln(static, inttyp);
		writeln('Trunc(f)');
		printid(defnams[dreal]^.lid);
		writeln(tab1, 'f;');
		writeln('{');
		writeln(tab1, 'return f;');
		writeln('}')
	    end;
	if use(dround) then
	    begin
		writeln(static, inttyp);
		writeln('Round(f)');
		printid(defnams[dreal]^.lid);
		writeln(tab1, 'f;');
		writeln('{');
		writeln(tab1, xtern, doubletyp, ' floor();');	(* LIB *)
		writeln(tab1,
			'return floor(', dblcast, '(0.5+f));');	(* LIB *)
		writeln('}')
	    end
end;	(* emit *)

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

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

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

	var	t	: toknbuf;

	begin
		gettokn(i, t);
		t[1] := 'i';
		puttokn(i, t);
	end;

	(*	Add a cpu word type description.			*)
	(*	Parameters lo and hi gives the range of a machine-	*)
	(*	dependant integer type. Parameter str gives the corres-	*)
	(*	ponding C-language type-name.				*)
	procedure defmach(lo, hi : integer; str : machdefstr);

	label	999;

	var	i	: toknidx;
		w	: toknbuf;

	begin
		unpack(str, w, 1);
		if w[machdeflen] <> space then
			error(ebadmach);
		for i := machdeflen - 1 downto 1 do
			if w[i] <> space then
			    begin
				w[i+1] := chr(null);
				goto 999
			    end;
		error(ebadmach);
	999:
		if nmachdefs >= maxmachdefs then
			error(emanymachs);
		nmachdefs := nmachdefs + 1;
		with machdefs[nmachdefs] do
		    begin
			lolim := lo;
			hilim := hi;
			typstr := savestr(w)
		    end
	end;

	procedure initstrstore;

	var	i	: strbcnt;

	begin
		for i := 1 to maxblkcnt do
			strstor[i] := nil;
		new(strstor[0]);
		strstor[0]^[0] := chr(null);
		strfree := 1;
		strleft := maxstrblk
	end;

begin	(* initialize *)
	lineno := 1;
	colno := 0;
	pushed := false;

	initstrstore;

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

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

	usenilp := false;

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

	usecase := false;
	usejmps := false;

	usebool := false;

	usecomp := false;
	usemax	:= false;
	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(nfunc,	deof,		'eof       ');
	defid(nfunc,	deoln,		'eoln      ');
	defid(nproc,	dexit,		'exit      ');	(* OS *)
	defid(nfunc,	dexp,		'exp       ');
	defid(nproc,	dflush,		'flush     ');	(* OS *)
	defid(nproc,	dget,		'get       ');
	defid(nproc,	dhalt,		'halt      ');	(* OS *)
	defid(nvar,	dinput,		'input     ');
	defid(ntype,	dinteger,	'integer   ');
	defid(nfunc,	dln,		'ln        ');
	defid(nconst,	dmaxint,	'maxint    ');
	defid(nproc,	dmessage,	'message   ');	(* OS *)
	defid(nproc,	dnew,		'new       ');
	defid(nfunc,	dodd,		'odd       ');
	defid(nfunc,	dord,		'ord       ');
	defid(nvar,	doutput,	'output    ');
	defid(nproc,	dpack,		'pack      ');
	defid(nproc,	dpage,		'page      ');
	defid(nfunc,	dpred,		'pred      ');
	defid(nproc,	dput,		'put       ');
	defid(nproc,	dread,		'read      ');
	defid(nproc,	dreadln,	'readln    ');
	defid(ntype,	dreal,		'real      ');
	defid(nproc,	dreset,		'reset     ');
	defid(nproc,	drewrite,	'rewrite   ');
	defid(nfunc,	dround,		'round     ');
	defid(nfunc,	dsin,		'sin       ');
	defid(nfunc,	dsqr,		'sqr       ');
	defid(nfunc,	dsqrt,		'sqrt      ');
	defid(nfunc,	dsucc,		'succ      ');
	defid(ntype,	dtext,		'text      ');
	defid(nid,	dtrue,		'true      ');
	defid(nfunc,	dtrunc,		'trunc     ');
	defid(nfunc,	dtan,		'tan       ');
	defid(nproc,	dunpack,	'unpack    ');
	defid(nproc,	dwrite,		'write     ');
	defid(nproc,	dwriteln,	'writeln   ');

	defid(nfield,	dzinit,		'$nit      ');	(* for internal use *)
	defid(ntype,	dztring,	'$ztring   ');

	(* bind constants and variables *)
	deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
	deftab[dfalse]^.tnext := deftab[dtrue];
	currsym.st := sinteger;
	currsym.vint := maxint;
	deftab[dmaxint]^.tbind := mklit;
	deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
	deftab[dinput]^.tbind := deftab[dtext]^.tbind;
	deftab[doutput]^.tbind := deftab[dtext]^.tbind;

	for t := tnone to terror do
	    begin
		(* for predefined types: set up pointers to "npredef" nodes
		   describing type, fill in constant identifying type *)
		case t of
		  tboolean:
			typnods[t] := deftab[dboolean]^.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 "init" *)
	fixinit(defnams[dzinit]^.lid^.istr);
	deftab[dzinit]^.tbind := deftab[dinteger]^.tbind;

	for d := dabs to dztring do
		linkup(nil, deftab[d]);

	deftab[dchr]^.tfuntyp := typnods[tchar];

	deftab[deof]^.tfuntyp := typnods[tboolean];
	deftab[deoln]^.tfuntyp := typnods[tboolean];
	deftab[dodd]^.tfuntyp := typnods[tboolean];

	deftab[dord]^.tfuntyp := typnods[tinteger];
	deftab[dround]^.tfuntyp := typnods[tinteger];
	deftab[dtrunc]^.tfuntyp := typnods[tinteger];

	deftab[darctan]^.tfuntyp := typnods[treal];
	deftab[dcos]^.tfuntyp := typnods[treal];
	deftab[dsin]^.tfuntyp := typnods[treal];
	deftab[dtan]^.tfuntyp := typnods[treal];
	deftab[dsqrt]^.tfuntyp := typnods[treal];
	deftab[dexp]^.tfuntyp := typnods[treal];
	deftab[dln]^.tfuntyp := typnods[treal];

	deftab[dsqr]^.tfuntyp := typnods[tpoly];
	deftab[dabs]^.tfuntyp := typnods[tpoly];
	deftab[dpred]^.tfuntyp := typnods[tpoly];
	deftab[dsucc]^.tfuntyp := typnods[tpoly];

	deftab[dargv]^.tfuntyp := typnods[tnone];
	deftab[ddispose]^.tfuntyp := typnods[tnone];
	deftab[dexit]^.tfuntyp := typnods[tnone];
	deftab[dget]^.tfuntyp := typnods[tnone];
	deftab[dhalt]^.tfuntyp := typnods[tnone];
	deftab[dnew]^.tfuntyp := typnods[tnone];
	deftab[dpack]^.tfuntyp := typnods[tnone];
	deftab[dput]^.tfuntyp := typnods[tnone];
	deftab[dread]^.tfuntyp := typnods[tnone];
	deftab[dreadln]^.tfuntyp := typnods[tnone];
	deftab[dreset]^.tfuntyp := typnods[tnone];
	deftab[drewrite]^.tfuntyp := typnods[tnone];
	deftab[dwrite]^.tfuntyp := typnods[tnone];
	deftab[dwriteln]^.tfuntyp := typnods[tnone];
	deftab[dmessage]^.tfuntyp := typnods[tnone];
	deftab[dunpack]^.tfuntyp := typnods[tnone];

	(* set up definitions for integer subranges *)
	nmachdefs := 0;
	defmach(0,		255,		'unsigned char   '); (* CPU *)
	defmach(-128,		127,		'char            '); (* CPU *)
	defmach(0,		65535,		'unsigned short  '); (* CPU *)
	defmach(-32768,		32767,		'short           '); (* CPU *)
	defmach(-2147483647,	2147483647,	'long            '); (* CPU *)
{	defmach(0,		4294967295,	'unsigned long   ');}(* CPU *)
end;	(* initialize *)

procedure exit(i : integer); external;	(* OS *)

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

begin
	prtmsg(m);
	exit(1);	(* OS *)
	goto 9999
end;

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

begin
	prtmsg(m);
	halt		(* OS *)
	(* goto 9999	*)
end;


begin	(* program *)
	initialize;
	if echo then
		writeln('# ifdef PASCAL');
	parse;
	if echo then
		writeln('# else');
	lineno := 0; lastline := 0;
	transform;
	emit;
	if echo then
		writeln('# endif');
9999:
	(* the very *)
end.