Diff | Source/Git

Download diff

	4b825dc642cb6eb9a060e54bf8d69288fbee4904		cfad47cfa334b206c65f22086bcc5d63e6f70944
		1	#ifdef RCSID
		2	static char RCSid[] =
		3	"$Header: d:/cvsroot/tads/TADS2/PRSCOMP.C,v 1.3 1999/07/11 00:46:30 MJRoberts Exp $";
		4	#endif
		5
		6	/*
		7	* Copyright (c) 1993, 2002 Michael J. Roberts. All Rights Reserved.
		8	*
		9	* Please see the accompanying license file, LICENSE.TXT, for information
		10	* on using and copying this software.
		11	*/
		12	/*
		13	Name
		14	prscomp.c - parser functions needed only in compiler
		15	Function
		16	Provides parser functions that are used only by the compiler
		17	(but not by the debugger). Separated from prs.c so that the
		18	debugger doesn't need to link these functions unnecessarily.
		19	Notes
		20	None
		21	Modified
		22	02/07/93 MJRoberts - Creation
		23	*/
		24
		25	#include <string.h>
		26	#include <assert.h>
		27	#include <ctype.h>
		28	#include "os.h"
		29	#include "std.h"
		30	#include "mcm.h"
		31	#include "tok.h"
		32	#include "prs.h"
		33	#include "lst.h"
		34	#include "prp.h"
		35	#include "obj.h"
		36	#include "opc.h"
		37	#include "emt.h"
		38	#include "mch.h"
		39	#include "voc.h"
		40
		41	/* generate an OPCLINE instruction */
		42	static void prsclin(prscxdef ctx, uint curfr, lindef lin,
		43	int tellsrc, const uchar *loc);
		44
		45	/* parse an argument or local variable list */
		46	static toktldef prsvlst(prscxdef ctx, toktldef lcltab, prsndef *inits,
		47	int locals, int args, int varargs, uint curfr)
		48	{
		49	tokdef *t;
		50
		51	/* skip whatever token encouraged caller to parse a variable list */
		52	toknext(ctx->prscxtok);
		53
		54	/* if caller doesn't already have a local table, allocate one now */
		55	if (!lcltab)
		56	{
		57	/* ensure there's enough space */
		58	if (ctx->prscxslcl < sizeof(toktldef) + 20)
		59	errsig(ctx->prscxerr, ERR_NOMEMLC);
		60
		61	/* set up space for linear table and initialize it */
		62	lcltab = (toktldef *)osrndpt(ctx->prscxplcl);
		63	toktlini(ctx->prscxerr, lcltab, (uchar *)(lcltab + 1),
		64	(int)ctx->prscxslcl - (uint)sizeof(toktldef));
		65
		66	/* make new local symbol table the head of search list */
		67	lcltab->toktlsc.toktnxt = ctx->prscxtok->tokcxstab;
		68	ctx->prscxtok->tokcxstab = &lcltab->toktlsc;
		69	}
		70
		71	for (;;)
		72	{
		73	int tnum;
		74
		75	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSYMBOL) break;
		76
		77	/* add the symbol */
		78	++(*locals);
		79	t = &ctx->prscxtok->tokcxcur;
		80	(lcltab->toktlsc.toktfadd)((toktdef )lcltab, t->toknam, t->toklen,
		81	TOKSTLOCAL, (args ? -(locals) : locals),
		82	t->tokhash);
		83
		84	/* check for initializer if initializers are ok */
		85	if (((tnum = toknext(ctx->prscxtok)) == TOKTASSIGN \|\| tnum == TOKTEQ)
		86	&& inits)
		87	{
		88	prsndef *expr;
		89
		90	toknext(ctx->prscxtok); /* skip the := */
		91
		92	/* save the OPCLINE if necessary */
		93	if ((ctx->prscxflg & PRSCXFLIN)
		94	&& !(ctx->prscxtok->tokcxlin->linflg & LINFDBG))
		95	{
		96	uint oldofs = ctx->prscxemt->emtcxofs; /* save PC */
		97	uchar *linrec;
		98	prsndef *n4;
		99	tokdef t2;
		100	uint siz;
		101
		102	/* gen the OPCLINE, and copy into temp storage in tree */
		103	prsclin(ctx, curfr, ctx->prscxtok->tokcxlin, FALSE, 0);
		104	siz = ctx->prscxemt->emtcxofs - oldofs;
		105	linrec = prsbalo(ctx, siz);
		106	memcpy(linrec, ctx->prscxemt->emtcxptr + oldofs,
		107	(size_t)(ctx->prscxemt->emtcxofs - oldofs));
		108
		109	/* now remove the OPCLINE - this isn't the place for it */
		110	ctx->prscxemt->emtcxofs = oldofs;
		111
		112	/* allocate a token node to hold the line information */
		113	t2.tokofs = linrec - ctx->prscxpool;
		114	n4 = prsnew0(ctx, &t2);
		115
		116	/* now build a four-way node with the line information */
		117	expr = prsxini(ctx);
		118	*inits = prsnew4(ctx, TOKTLOCAL, expr, prsnew0(ctx, t),
		119	*inits, n4);
		120	}
		121	else
		122	{
		123	expr = prsxini(ctx); /* parse the initializer */
		124	*inits = prsnew3(ctx, TOKTLOCAL, expr,
		125	prsnew0(ctx, t), *inits);
		126	}
		127	(inits)->prsnv.prsnvn[1]->prsnv.prsnvt.tokval = locals;
		128	}
		129
		130	/* if we don't have a comma, we're done */
		131	if (ctx->prscxtok->tokcxcur.toktyp != TOKTCOMMA) break;
		132	toknext(ctx->prscxtok); /* skip the comma */
		133	}
		134
		135	/* check for varargs specifier */
		136	if (varargs && ctx->prscxtok->tokcxcur.toktyp == TOKTELLIPSIS)
		137	{
		138	*varargs = TRUE;
		139	toknext(ctx->prscxtok); /* skip the ellipsis */
		140	}
		141
		142	/* update the local table pool pointers to follow the table */
		143	ctx->prscxplcl = lcltab->toktlnxt;
		144	ctx->prscxslcl = lcltab->toktlsiz;
		145
		146	return(lcltab);
		147	}
		148
		149	/* callback to generate one symbol's record in a debug frame table */
		150	static void prsvgf0(void ctx0, toksdef sym)
		151	{
		152	prscxdef ctx = (prscxdef )ctx0;
		153	emtcxdef *ec = ctx->prscxemt;
		154
		155	/* write out value (offset from base ptr) and name of symbol */
		156	emtint2(ec, sym->toksval);
		157	emtbyte(ec, sym->tokslen);
		158	emtmem(ec, sym->toksnam, (size_t)sym->tokslen);
		159	}
		160
		161	/* generate a local symbol table debug frame record, if debugging enabled */
		162	static void prsvgfr(prscxdef ctx, toktldef lcltab, uint *encfr)
		163	{
		164	if (ctx->prscxflg & PRSCXFLCL)
		165	{
		166	emtcxdef *ec = ctx->prscxemt;
		167	uint ofs;
		168	uint diff;
		169
		170	/* write the FRAME instruction and operand header */
		171	emtop(ec, OPCFRAME);
		172	ofs = ec->emtcxofs; /* remember the location of the length */
		173	emtint2(ec, 0); /* placeholder - we'll fill this in later */
		174	emtint2(ec, encfr); / point to the enclosing frame */
		175
		176	/* write out the symbols using the callback iterator */
		177	toktleach(&lcltab->toktlsc, prsvgf0, ctx);
		178
		179	/* now write the length of the table back at the beginning */
		180	diff = ctx->prscxemt->emtcxofs - ofs;
		181	emtint2at(ec, diff, ofs);
		182
		183	/* the new table is now the current frame */
		184	*encfr = ofs;
		185	}
		186	}
		187
		188	/* generate an OPCLINE instruction for the current line */
		189	static void prsclin(prscxdef ctx, uint curfr, lindef lin, int tellsrc,
		190	const uchar *saved_loc)
		191	{
		192	int diff = FALSE;
		193
		194	/* tell the line source the location of the line */
		195	if (tellsrc)
		196	{
		197	dbgclin(ctx->prscxtok, ctx->prscxemt->emtcxobj,
		198	(uint)ctx->prscxemt->emtcxofs);
		199	}
		200
		201	/* emit a LINE instruction, noting location and frame */
		202	emtop(ctx->prscxemt, OPCLINE);
		203	emtbyte(ctx->prscxemt, lin->linlln + 4); /* note length of record */
		204	emtint2(ctx->prscxemt, curfr); /* store current frame pointer */
		205	emtbyte(ctx->prscxemt, lin->linid); /* save line source ID */
		206	emtres(ctx->prscxemt, lin->linlln); /* make room for source part */
		207
		208	/* use the saved location, or the current location if there isn't one */
		209	if (saved_loc != 0)
		210	{
		211	uchar cur[LINLLNMAX];
		212
		213	/* use the saved location */
		214	memcpy(ctx->prscxemt->emtcxptr + ctx->prscxemt->emtcxofs,
		215	saved_loc, lin->linlln);
		216
		217	/* check to see if it's different from the current location */
		218	linglop(lin, cur);
		219	diff = memcmp(cur, saved_loc, lin->linlln);
		220	}
		221	else
		222	{
		223	/* no saved location - use the current location from the lindef */
		224	linglop(lin, ctx->prscxemt->emtcxptr + ctx->prscxemt->emtcxofs);
		225	}
		226
		227	/* advance the output pointer */
		228	ctx->prscxemt->emtcxofs += lin->linlln;
		229
		230	/*
		231	* indicate in line source that we've generated a debug record, as long
		232	* as the generated location isn't different from current location (if
		233	* it is, don't mark this line as used yet)
		234	*/
		235	if (!diff)
		236	ctx->prscxtok->tokcxlin->linflg \|= LINFDBG;
		237	}
		238
		239	/* parse a statement (simple or compound) */
		240	void prsstm(prscxdef *ctx, uint brk, uint cont, int parms, int locals,
		241	uint entofs, prscsdef *swctl, uint curfr)
		242	{
		243	tokdef *t;
		244	noreg uint ldone = EMTLLNKEND;
		245	noreg uint lfalse = EMTLLNKEND;
		246	noreg uint lloop = EMTLLNKEND;
		247	ushort oldrrst = ctx->prscxrrst;
		248	uchar *oldnrst = ctx->prscxnrst;
		249	uchar *oldlclp = ctx->prscxplcl;
		250	uint oldlcls = ctx->prscxslcl;
		251	toktdef *oldltab = ctx->prscxtok->tokcxstab;
		252	int compound = FALSE;
		253	uint casecnt = 0; /* current case count */
		254	prsctdef noreg casetab = (prsctdef )0; /* case table */
		255	prsctdef *curctab;
		256	lindef lin = ctx->prscxtok->tokcxlin; / line source */
		257
		258	NOREG((&ldone, &lfalse, &lloop, &casetab))
		259
		260	ERRBEGIN(ctx->prscxerr)
		261
		262	/* if no 'enter' instruction, emit one */
		263	if (!entofs)
		264	{
		265	emtop(ctx->prscxemt, OPCENTER); /* emit the 'enter' instruction */
		266	entofs = ctx->prscxemt->emtcxofs; /* save offset of operand */
		267	emtint2(ctx->prscxemt, 0); /* no locals so far */
		268	}
		269
		270	/* set up with first case table, if in a switch body */
		271	if (swctl) curctab = swctl->prscstab;
		272
		273	/* see if this is going to be a compound statement... */
		274	if (ctx->prscxtok->tokcxcur.toktyp == TOKTLBRACE)
		275	{
		276	prsndef *inits;
		277	toktldef *lcltab;
		278
		279	compound = TRUE; /* note that we have a compound statement */
		280	prsrstn(ctx); /* reset node pool */
		281	toknext(ctx->prscxtok); /* skip the '{' */
		282	lcltab = (toktldef )0; / no local symbol table yet */
		283
		284	/* allow arbitrarily many consecutive 'local' statements */
		285	for (inits = (prsndef *)0 ;
		286	ctx->prscxtok->tokcxcur.toktyp == TOKTLOCAL ; )
		287	{
		288	lcltab = prsvlst(ctx, lcltab, &inits, &locals, FALSE, (int *)0,
		289	curfr);
		290	prsreq(ctx, TOKTSEM);
		291	}
		292	if (lcltab) prsvgfr(ctx, lcltab, &curfr);
		293
		294	/* adjust the 'enter' instruction to make room for new locals */
		295	if (lcltab && locals > emtint2from(ctx->prscxemt, entofs))
		296	emtint2at(ctx->prscxemt, locals, entofs);
		297
		298	/* generate code for initializers, if any */
		299	if (inits) prsgini(ctx, inits, curfr);
		300	}
		301
		302	startover:
		303	do
		304	{
		305	/* generate a line record if debugging if we haven't already done so */
		306	if ((ctx->prscxflg & PRSCXFLIN)
		307	&& !(ctx->prscxtok->tokcxlin->linflg & LINFDBG))
		308	prsclin(ctx, curfr, lin, TRUE, 0);
		309
		310	switch (ctx->prscxtok->tokcxcur.toktyp)
		311	{
		312	case TOKTSEM:
		313	toknext(ctx->prscxtok); /* skip the semicolon - end of statement */
		314	break;
		315
		316	case TOKTRBRACE:
		317	if (compound)
		318	{
		319	compound = FALSE; /* we're done with the compound statement */
		320	toknext(ctx->prscxtok); /* skip the '}' */
		321	}
		322	break;
		323
		324	case TOKTLBRACE:
		325	prsstm(ctx, brk, cont, parms, locals, entofs, (prscsdef *)0, curfr);
		326	break;
		327
		328	case TOKTDSTRING:
		329	prsxgen(ctx);
		330	prsreq(ctx, TOKTSEM);
		331	break;
		332
		333	case TOKTIF:
		334	prsnreq(ctx, TOKTLPAR);
		335	lfalse = emtglbl(ctx->prscxemt);
		336	prsxgen_pia(ctx);
		337	emtjmp(ctx->prscxemt, OPCJF, lfalse);
		338	prsreq(ctx, TOKTRPAR);
		339	prsstm(ctx, brk, cont, parms, locals, entofs, (prscsdef *)0, curfr);
		340
		341	/* in v1 compatibility mode, ignore ';' after 'if{...}' */
		342	if ((ctx->prscxflg & PRSCXFV1E)
		343	&& ctx->prscxtok->tokcxcur.toktyp == TOKTSEM)
		344	toknext(ctx->prscxtok);
		345
		346	if (ctx->prscxtok->tokcxcur.toktyp == TOKTELSE)
		347	{
		348	toknext(ctx->prscxtok); /* skip the 'else' */
		349	ldone = emtglbl(ctx->prscxemt);
		350	emtjmp(ctx->prscxemt, OPCJMP, ldone);
		351	emtslbl(ctx->prscxemt, &lfalse, TRUE);
		352	prsstm(ctx, brk, cont, parms, locals, entofs, (prscsdef *)0,
		353	curfr);
		354	emtslbl(ctx->prscxemt, &ldone, TRUE);
		355	}
		356	else
		357	emtslbl(ctx->prscxemt, &lfalse, TRUE); /* no 'else' */
		358	break;
		359
		360	case TOKTWHILE:
		361	prsnreq(ctx, TOKTLPAR);
		362	ldone = emtglbl(ctx->prscxemt);
		363	lloop = emtgslbl(ctx->prscxemt); /* loop point is right here */
		364	prsxgen_pia(ctx); /* parse and generate condition */
		365
		366	prsreq(ctx, TOKTRPAR);
		367	emtjmp(ctx->prscxemt, OPCJF, ldone);
		368	prsstm(ctx, ldone, lloop, parms, locals, entofs, (prscsdef *)0,
		369	curfr);
		370	emtjmp(ctx->prscxemt, OPCJMP, lloop);
		371	emtslbl(ctx->prscxemt, &ldone, TRUE);
		372	emtdlbl(ctx->prscxemt, &lloop);
		373	break;
		374
		375	case TOKTDO:
		376	toknext(ctx->prscxtok); /* skip the 'do' keyword */
		377
		378	/* get labels - one for loopback, one for break, one for continue */
		379	ldone = emtglbl(ctx->prscxemt);
		380	lloop = emtgslbl(ctx->prscxemt); /* loop point is right here */
		381	lfalse = emtglbl(ctx->prscxemt); /* get label for continue */
		382
		383	/* parse loop body */
		384	prsstm(ctx, ldone, lfalse, parms, locals, entofs, (prscsdef *)0,
		385	curfr);
		386
		387	/* set continue label to just before condition */
		388	emtslbl(ctx->prscxemt, &lfalse, TRUE);
		389
		390	/* parse the while(condition) clause and loop back if true */
		391	prsreq(ctx, TOKTWHILE);
		392	prsxgen_pia(ctx); /* parse the condition */
		393	emtjmp(ctx->prscxemt, OPCJT, lloop);
		394	emtdlbl(ctx->prscxemt, &lloop);
		395
		396	/* set break label to just after the loop */
		397	emtslbl(ctx->prscxemt, &ldone, TRUE);
		398	break;
		399
		400	case TOKTFOR:
		401	{
		402	prsndef reinit = (prsndef )0;
		403	ushort for_oldrrst = ctx->prscxrrst;
		404	uchar *for_oldnrst = ctx->prscxnrst;
		405
		406	prsnreq(ctx, TOKTLPAR);
		407
		408	/* get loop/end labels */
		409	ldone = emtglbl(ctx->prscxemt); /* bottom of loop (continue) */
		410	lloop = emtglbl(ctx->prscxemt); /* top of loop (test) */
		411	lfalse = emtglbl(ctx->prscxemt); /* end of loop (break) */
		412
		413	/* parse initializer, if present */
		414	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSEM) prsxgen(ctx);
		415	emtop(ctx->prscxemt, OPCDISCARD); /* don't need initializer */
		416	prsreq(ctx, TOKTSEM);
		417
		418	/* parse condition, if present */
		419	emtslbl(ctx->prscxemt, &lloop, FALSE);
		420	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSEM)
		421	{
		422	prsxgen_pia(ctx);
		423	emtjmp(ctx->prscxemt, OPCJF, lfalse);
		424	}
		425	prsreq(ctx, TOKTSEM);
		426
		427	/* parse re-initializer, if present */
		428	if (ctx->prscxtok->tokcxcur.toktyp != TOKTRPAR)
		429	reinit = prsexpr(ctx);
		430	prsreq(ctx, TOKTRPAR);
		431
		432	/* save expression context - re-initizlier is in pool */
		433	ctx->prscxrrst = ctx->prscxnrem;
		434	ctx->prscxnrst = ctx->prscxnode;
		435
		436	/* parse loop body */
		437	prsstm(ctx, lfalse, ldone, parms, locals, entofs, (prscsdef *)0,
		438	curfr);
		439
		440	/* generate re-initializer code if needed, and loop back */
		441	emtslbl(ctx->prscxemt, &ldone, FALSE);
		442	if (reinit)
		443	{
		444	prsgexp(ctx, reinit);
		445	emtop(ctx->prscxemt, OPCDISCARD); /* don't save value */
		446	}
		447	emtjmp(ctx->prscxemt, OPCJMP, lloop);
		448
		449	/* set post-loop label, and reset everything */
		450	emtslbl(ctx->prscxemt, &lfalse, TRUE);
		451	emtdlbl(ctx->prscxemt, &lloop);
		452	emtdlbl(ctx->prscxemt, &ldone);
		453	ctx->prscxrrst = for_oldrrst;
		454	ctx->prscxnrst = for_oldnrst;
		455	/* prsrstn(ctx); */
		456	break;
		457	}
		458
		459	case TOKTBREAK:
		460	prsnreq(ctx, TOKTSEM);
		461	if (brk == EMTLLNKEND)
		462	errlog(ctx->prscxerr, ERR_BADBRK);
		463	else
		464	emtjmp(ctx->prscxemt, OPCJMP, brk);
		465	break;
		466
		467	case TOKTCONTINUE:
		468	prsnreq(ctx, TOKTSEM);
		469	if (cont == EMTLLNKEND)
		470	errlog(ctx->prscxerr, ERR_BADCNT);
		471	else
		472	emtjmp(ctx->prscxemt, OPCJMP, cont);
		473	break;
		474
		475	case TOKTGOTO:
		476	/* make sure we get some sort of symbol name */
		477	toknext(ctx->prscxtok);
		478	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSYMBOL)
		479	errsig(ctx->prscxerr, ERR_REQLBL);
		480
		481	/* require a label; if it's not already a label, make it one */
		482	prsdef(ctx, &ctx->prscxtok->tokcxcur, TOKSTLABEL);
		483	if (ctx->prscxtok->tokcxcur.toksym.tokstyp != TOKSTLABEL)
		484	errsig(ctx->prscxerr, ERR_REQLBL);
		485
		486	emtjmp(ctx->prscxemt, OPCJMP,
		487	(uint)ctx->prscxtok->tokcxcur.toksym.toksval);
		488	prsnreq(ctx, TOKTSEM);
		489	break;
		490
		491	case TOKTSWITCH:
		492	{
		493	prsctdef *curctab;
		494	prsctdef *nextctab;
		495	prscsdef myswctl;
		496	ushort sw_oldrrst = ctx->prscxrrst;
		497	uchar *sw_oldnrst = ctx->prscxnrst;
		498
		499	/* parse the selection expression */
		500	prsnreq(ctx, TOKTLPAR);
		501	prsxgen(ctx);
		502	prsreq(ctx, TOKTRPAR);
		503
		504	/* get 'break' label - this jumps past case table */
		505	ldone = emtglbl(ctx->prscxemt);
		506
		507	/* get label for case table, and emit SWITCH instruction for it */
		508	lloop = emtglbl(ctx->prscxemt);
		509	emtjmp(ctx->prscxemt, OPCSWITCH, lloop);
		510
		511	/* allocate the first case table (more can be added later) */
		512	casetab = MCHNEW(ctx->prscxerr, prsctdef, "prsstm: case table");
		513	casetab->prsctnxt = (prsctdef *)0;
		514
		515	/* parse switch body */
		516	myswctl.prscstab = casetab;
		517	myswctl.prscscnt = 0;
		518	myswctl.prscsdflt = 0;
		519	prsstm(ctx, ldone, cont, parms, locals, entofs, &myswctl, curfr);
		520
		521	/* emit case table */
		522	emtjmp(ctx->prscxemt, OPCJMP, ldone); /* jump over case table */
		523	emtslbl(ctx->prscxemt, &lloop, TRUE); /* set case table label */
		524	emtint2(ctx->prscxemt, myswctl.prscscnt); /* number of cases */
		525
		526	for (curctab = casetab ; curctab ; curctab = nextctab)
		527	{
		528	int lastlbl;
		529	int i;
		530	int diff;
		531
		532	nextctab = curctab->prsctnxt;
		533	lastlbl = (nextctab ? PRSCTSIZE : myswctl.prscscnt);
		534	for (i = 0 ; i < lastlbl ; --(myswctl.prscscnt), ++i)
		535	{
		536	/* emit case value, then offset of code for case */
		537	emtval(ctx->prscxemt, &curctab->prsctcase[i].prscttok,
		538	ctx->prscxpool);
		539	diff = (int)(curctab->prsctcase[i].prsctofs
		540	- ctx->prscxemt->emtcxofs);
		541	emtint2(ctx->prscxemt, diff);
		542	}
		543
		544	/* done with this table - free it */
		545	mchfre(curctab);
		546	}
		547	casetab = (prsctdef *)0;
		548
		549	/* emit 'default' entry - use ldone if no 'default' was given */
		550	if (myswctl.prscsdflt)
		551	{
		552	int diff = (int)(myswctl.prscsdflt - ctx->prscxemt->emtcxofs);
		553	emtint2(ctx->prscxemt, diff);
		554	}
		555	else
		556	emtint2(ctx->prscxemt, 2); /* no default - skip ahead */
		557
		558	/* we're done with the saved values in the case table */
		559	ctx->prscxrrst = sw_oldrrst;
		560	ctx->prscxnrst = sw_oldnrst;
		561
		562	/* set end label, and we're done */
		563	emtslbl(ctx->prscxemt, &ldone, TRUE);
		564	break;
		565	}
		566
		567	case TOKTCASE:
		568	{
		569	prsndef *node;
		570	int typ;
		571	int styp;
		572
		573	/* make sure the case occurs in a switch body */
		574	if (!swctl)
		575	errsig(ctx->prscxerr, ERR_NOSW);
		576
		577	/* get the case value, make sure it's valid */
		578	toknext(ctx->prscxtok);
		579	node = prsexpr(ctx);
		580	prsreq(ctx, TOKTCOLON);
		581	if (node->prsnnlf != 0) errsig(ctx->prscxerr, ERR_SWRQCN);
		582	typ = node->prsnv.prsnvt.toktyp;
		583	if (typ == TOKTDSTRING \|\|
		584	(typ == TOKTSYMBOL &&
		585	((styp = node->prsnv.prsnvt.toksym.tokstyp) == TOKSTLOCAL
		586	\|\| styp == TOKSTBIFN \|\| styp == TOKSTPROP
		587	\|\| styp == TOKSTSELF)))
		588	errsig(ctx->prscxerr, ERR_SWRQCN);
		589
		590	/* assume we have an object if it's an undefined symbol */
		591	if (typ == TOKTSYMBOL)
		592	prsdef(ctx, &node->prsnv.prsnvt, TOKSTFWDOBJ);
		593
		594	/* if we need another case table, add one */
		595	if (casecnt == PRSCTSIZE)
		596	{
		597	curctab->prsctnxt = MCHNEW(ctx->prscxerr, prsctdef,
		598	"prsstm: case table extension");
		599	curctab = curctab->prsctnxt;
		600	curctab->prsctnxt = (prsctdef *)0;
		601	casecnt = 0;
		602	}
		603
		604	/* set up this entry with value and code location */
		605	OSCPYSTRUCT(curctab->prsctcase[casecnt].prscttok,
		606	node->prsnv.prsnvt);
		607	curctab->prsctcase[casecnt].prsctofs =
		608	ctx->prscxemt->emtcxofs;
		609	++casecnt;
		610	++(swctl->prscscnt);
		611
		612	/* save anything in the node table - we'll need it later */
		613	ctx->prscxnrst = ctx->prscxnode;
		614	ctx->prscxrrst = ctx->prscxnrem;
		615
		616	prsrstn(ctx);
		617	break;
		618	}
		619
		620	case TOKTDEFAULT:
		621	if (!swctl) errsig(ctx->prscxerr, ERR_NOSW);
		622	prsnreq(ctx, TOKTCOLON);
		623	swctl->prscsdflt = ctx->prscxemt->emtcxofs;
		624	break;
		625
		626	case TOKTELSE:
		627	errlog(ctx->prscxerr, ERR_BADELS);
		628	toknext(ctx->prscxtok);
		629	break;
		630
		631	case TOKTRETURN:
		632	if (toknext(ctx->prscxtok) == TOKTSEM)
		633	{
		634	toknext(ctx->prscxtok);
		635	emtop(ctx->prscxemt, OPCRETURN);
		636	}
		637	else
		638	{
		639	prsxgen_pia(ctx); /* parse return expression */
		640	prsreq(ctx, TOKTSEM);
		641	emtop(ctx->prscxemt, OPCRETVAL);
		642	}
		643	emtint2(ctx->prscxemt, parms);
		644	break;
		645
		646	case TOKTPASS:
		647	{
		648	prpnum p;
		649
		650	toknext(ctx->prscxtok);
		651	p = prsrqpr(ctx); /* we need a property id here */
		652	emtop(ctx->prscxemt, OPCPASS);
		653	emtint2(ctx->prscxemt, p);
		654	prsreq(ctx, TOKTSEM);
		655	}
		656	break;
		657
		658	case TOKTEXIT:
		659	prsnreq(ctx, TOKTSEM);
		660	emtop(ctx->prscxemt, OPCEXIT);
		661	break;
		662
		663	case TOKTABORT:
		664	prsnreq(ctx, TOKTSEM);
		665	emtop(ctx->prscxemt, OPCABORT);
		666	break;
		667
		668	case TOKTASKDO:
		669	prsnreq(ctx, TOKTSEM);
		670	emtop(ctx->prscxemt, OPCASKDO);
		671	break;
		672
		673	case TOKTASKIO:
		674	prsnreq(ctx, TOKTLPAR);
		675	t = &ctx->prscxtok->tokcxcur;
		676	if (t->toktyp != TOKTSYMBOL)
		677	errsig(ctx->prscxerr, ERR_REQOBJ);
		678	prsdef(ctx, t, TOKSTFWDOBJ);
		679	switch (t->toksym.tokstyp)
		680	{
		681	case TOKSTOBJ:
		682	case TOKSTFWDOBJ:
		683	{
		684	mcmon obj;
		685
		686	obj = t->toksym.toksval;
		687	emtop(ctx->prscxemt, OPCASKIO);
		688	emtint2(ctx->prscxemt, obj);
		689	}
		690	break;
		691
		692	default:
		693	errsig(ctx->prscxerr, ERR_REQOBJ);
		694	}
		695	prsnreq(ctx, TOKTRPAR);
		696	prsreq(ctx, TOKTSEM);
		697	break;
		698
		699	case TOKTSYMBOL:
		700	case TOKTLPAR:
		701	case TOKTNUMBER:
		702	case TOKTINC:
		703	case TOKTDEC:
		704	case TOKTDELETE:
		705	{
		706	prsndef *expr;
		707	int needsem;
		708	int t;
		709
		710	/needsem = (ctx->prscxtok->tokcxcur.toktyp != TOKTLPAR);/
		711	needsem = TRUE;
		712	expr = prsexpr(ctx);
		713
		714	if (ctx->prscxtok->tokcxcur.toktyp == TOKTCOLON &&
		715	expr->prsnnlf == 0 && expr->prsnv.prsnvt.toktyp == TOKTSYMBOL
		716	&& ((t = expr->prsnv.prsnvt.toksym.tokstyp) == TOKSTLABEL
		717	\|\| t == TOKSTUNK))
		718	{
		719	uint lbl;
		720
		721	prsdef(ctx, &expr->prsnv.prsnvt, TOKSTLABEL);
		722	lbl = expr->prsnv.prsnvt.toksym.toksval;
		723	emtslbl(ctx->prscxemt, &lbl, FALSE);
		724	toknext(ctx->prscxtok);
		725	goto startover;
		726	}
		727
		728	if (expr->prsntyp == TOKTEQ) errlog(ctx->prscxerr, ERR_WEQASI);
		729	prsgexp(ctx, expr);
		730	prsrstn(ctx); /* reset prior to reading next token */
		731	if (needsem) prsreq(ctx, TOKTSEM);
		732	emtop(ctx->prscxemt, OPCDISCARD);
		733	}
		734	break;
		735
		736	case TOKTEOF:
		737	errsig(ctx->prscxerr, ERR_EOF);
		738
		739	case TOKTLOCAL:
		740	/* log the error */
		741	errlog(ctx->prscxerr, ERR_BADLCL);
		742
		743	/* eat tokens up to the semicolon */
		744	while (ctx->prscxtok->tokcxcur.toktyp != TOKTSEM
		745	&& ctx->prscxtok->tokcxcur.toktyp != TOKTEOF)
		746	toknext(ctx->prscxtok);
		747
		748	/* ignore the statement and continue parsing */
		749	break;
		750
		751	default:
		752	errsig(ctx->prscxerr, ERR_SYNTAX);
		753	}
		754	} while (compound);
		755
		756	/* undo local symbol table if we created one */
		757	ctx->prscxplcl = oldlclp;
		758	ctx->prscxslcl = oldlcls;
		759	ctx->prscxtok->tokcxstab = oldltab;
		760
		761	ERRCLEAN(ctx->prscxerr)
		762	/* undo any labels that have been set */
		763	if (ldone != EMTLLNKEND) emtclbl(ctx->prscxemt, &ldone);
		764	if (lloop != EMTLLNKEND) emtclbl(ctx->prscxemt, &lloop);
		765	if (lfalse != EMTLLNKEND) emtclbl(ctx->prscxemt, &lfalse);
		766
		767	/* reset expression evaluation context */
		768	ctx->prscxrrst = oldrrst;
		769	ctx->prscxnrst = oldnrst;
		770	ctx->prscxplcl = oldlclp;
		771	ctx->prscxslcl = oldlcls;
		772	ctx->prscxtok->tokcxstab = oldltab;
		773	prsrstn(ctx);
		774
		775	/* free case tables if any were allocated */
		776	{
		777	prsctdef *curctab;
		778	prsctdef *nextctab;
		779
		780	for (curctab = casetab ; curctab ; curctab = nextctab)
		781	{
		782	nextctab = curctab->prsctnxt;
		783	mchfre(curctab);
		784	}
		785	}
		786	ERRENDCLN(ctx->prscxerr)
		787	}
		788
		789	/* callback for prsdelgoto - delete one label */
		790	static void prsdel1(void ctx0, toksdef sym)
		791	{
		792	prscxdef ctx = (prscxdef )ctx0;
		793	uint label;
		794
		795	label = sym->toksval;
		796	if (!emtqset(ctx->prscxemt, sym->toksval))
		797	{
		798	errlog1(ctx->prscxerr, ERR_NOGOTO, ERRTSTR,
		799	errstr(ctx->prscxerr, sym->toksnam, sym->tokslen));
		800	emtclbl(ctx->prscxemt, &label);
		801	sym->toksval = label;
		802	}
		803	else
		804	{
		805	emtdlbl(ctx->prscxemt, &label);
		806	sym->toksval = label;
		807	}
		808	}
		809
		810	/* delete 'goto' symbols, and warn if any are undefined */
		811	void prsdelgoto(prscxdef *ctx)
		812	{
		813	toktldef tab = (toktldef )ctx->prscxgtab;
		814
		815	toktleach(&tab->toktlsc, prsdel1, ctx);
		816	toktldel(tab);
		817	}
		818
		819	/* build a template name from a root name, and add a property for it */
		820	static prpnum prstpl(prscxdef ctx, uchar root, char *prefix)
		821	{
		822	tokdef tok;
		823	int pfllen = strlen(prefix);
		824	int rootlen = osrp2(root) - 2;
		825
		826	/* build the symbol from the prefix and the root */
		827	tok.toklen = pfllen + rootlen;
		828	memcpy(tok.toknam, prefix, (size_t)pfllen);
		829	memcpy(tok.toknam + pfllen, root+2, (size_t)rootlen);
		830
		831	/* fold case if we're in case-insensitive mode */
		832	/*
		833	* convert the symbol to lower-case if we're compiling the game in
		834	* case-insensitive mode
		835	*/
		836	tok_case_fold(ctx->prscxtok, &tok);
		837
		838	/* build the token definition */
		839	tok.toknam[pfllen + rootlen] = '\0';
		840	tok.toktyp = TOKTSYMBOL;
		841	tok.tokhash = tokhsh(tok.toknam);
		842	tok.toksym.tokstyp = TOKSTUNK;
		843
		844	/* define or look up the property */
		845	prsdef(ctx, &tok, TOKSTPROP);
		846
		847	/* return the property number */
		848	return(tok.toksym.toksval);
		849	}
		850
		851	/* build a property string for a synonym and get its property number */
		852	static prpnum prssynp(prscxdef ctx, uchar prefix, size_t pfxlen,
		853	uchar *suffix)
		854	{
		855	tokdef tok;
		856	toksdef sym;
		857	size_t suflen;
		858	toktdef *tab;
		859
		860	/* construct the token */
		861	suflen = osrp2(suffix) - 2;
		862	suffix += 2;
		863
		864	/* build the synonym */
		865	tok.toklen = pfxlen + suflen;
		866	memcpy(tok.toknam, prefix, pfxlen);
		867	memcpy(tok.toknam + pfxlen, suffix, suflen);
		868
		869	/* fold case if we're in case-insensitive mode */
		870	tok_case_fold(ctx->prscxtok, &tok);
		871
		872	/* build the token */
		873	tok.toknam[tok.toklen] = '\0';
		874	tok.tokhash = tokhsh(tok.toknam);
		875	tok.toktyp = TOKTSYMBOL;
		876
		877	/* look up the symbol, if it's already in the table */
		878	tab = ctx->prscxstab;
		879	tok.toksym.tokstyp = TOKSTUNK;
		880	(*tab->toktfsea)(tab, tok.toknam, tok.toklen, tok.tokhash, &tok.toksym);
		881
		882	/* make it a property if it's not already */
		883	prsdef(ctx, &tok, TOKSTPROP);
		884
		885	/* now look it up and return its property number */
		886	(*tab->toktfsea)(tab, tok.toknam, tok.toklen, tok.tokhash, &sym);
		887	return(sym.toksval);
		888	}
		889
		890	/* add a synonym property */
		891	static void prssyn(prscxdef ctx, objnum objn, uchar prefix,
		892	uchar synto, uchar synfrom)
		893	{
		894	size_t plen = strlen((char *)prefix);
		895	prpnum propto;
		896	prpnum propfrom;
		897	uchar buf[2];
		898
		899	/* get the property numbers for the 'to' and 'from' strings */
		900	propto = prssynp(ctx, prefix, plen, synto);
		901	propfrom = prssynp(ctx, prefix, plen, synfrom);
		902
		903	/* set the synonym property */
		904	oswp2(buf, propto);
		905	objsetp(ctx->prscxmem, (mcmon)objn, propfrom, DAT_SYN, buf,
		906	(objucxdef *)0);
		907	}
		908
		909
		910	/* maximum number of templates for a single object */
		911	#define PRSTPMAX 30
		912
		913	/* parse an object definition (superclass list is already parsed) */
		914	static void prsobj(prscxdef ctx, noreg tokdef objtok, int numsc,
		915	objnum *sclist, int classflg)
		916	{
		917	objnum *sclistp;
		918	objdef *objptr;
		919	int t;
		920	prpnum p;
		921	objnum objn;
		922	void *val;
		923	uchar valbuf[4];
		924	int typ;
		925	objnum oval;
		926	prpnum pval;
		927	uchar *oldplcl = ctx->prscxplcl;
		928	uint oldslcl = ctx->prscxslcl;
		929	int parms;
		930	uint codeofs;
		931	uchar *scptr;
		932	toktdef *oldltab = ctx->prscxtok->tokcxstab;
		933	int varargs;
		934	objnum prep;
		935	uchar tpl[1 + PRSTPMAXVOCTPL2SIZ]; / templates built during parse */
		936	int tplcur = 1; /* start writing at offset 1 in buffer */
		937	int contset = FALSE; /* check if we see 'contents' property */
		938	objnum locobj = MCMONINV; /* location of this object */
		939	int locnil = FALSE; /* location is set to nil */
		940	int locok = FALSE; /* 'locationOK = true' was specified */
		941	int locwarn = FALSE; /* need to warn if locationOK=true not set */
		942	int hasvoc = FALSE; /* true if object has vocabulary */
		943	int i;
		944	uint curfr; /* offset of current debug frame */
		945	toktldef ltab; / local symbol table */
		946	ushort freeofs;
		947	int indexprop;
		948	tokdef proptok;
		949	uchar tplflags;
		950	size_t tplsiz;
		951	dattyp tpldat;
		952	prpnum tplprop;
		953
		954	/* use new-style or old-style templates, as appropriate */
		955	if (ctx->prscxflg & PRSCXFTPL1)
		956	{
		957	tplsiz = VOCTPLSIZ;
		958	tpldat = DAT_TPL;
		959	tplprop = PRP_TPL;
		960	}
		961	else
		962	{
		963	tplsiz = VOCTPL2SIZ;
		964	tpldat = DAT_TPL2;
		965	tplprop = PRP_TPL2;
		966	}
		967	tpl[0] = 0; /* no templates in array so far */
		968
		969	IF_DEBUG(printf("* compiling object #%d (%s) *\n",
		970	objtok->toksym.toksval, objtok->toknam));
		971
		972	/* lock the object, and initialize its object header */
		973	objn = objtok->toksym.toksval;
		974	objptr = (objdef *)mcmlck(ctx->prscxmem, (mcmon)objn);
		975	objini(ctx->prscxmem, numsc, objn, classflg);
		976
		977	/* set up superclasses in object */
		978	for (scptr = objsc(objptr), i = numsc, sclistp = sclist ; i
		979	; scptr += 2, ++sclistp, --i)
		980	oswp2(scptr, *sclistp);
		981
		982	/* catch any errors that occur while we have the object locked */
		983	ERRBEGIN(ctx->prscxerr)
		984
		985	for (;;)
		986	{
		987	ctx->prscxtok->tokcxstab = oldltab; /* restore old symbol tables */
		988	t = ctx->prscxtok->tokcxcur.toktyp;
		989	if (t == TOKTSEM) break; /* end of object - quit loop */
		990
		991	/* check for special doSynonym or ioSyonym property */
		992	if (t == TOKTDOSYN \|\| t == TOKTIOSYN)
		993	{
		994	uchar synto; / prefix to set synonyms to */
		995	uchar synfrom; / current prefix to set to point to synto */
		996	uchar verpre = (uchar )(t == TOKTDOSYN ? "verDo" : "verIo");
		997	uchar pre = (uchar )(t == TOKTDOSYN ? "do" : "io");
		998
		999	/* scan the 'to' suffix, which should be enclosed in parens */
		1000	prsnreq(ctx, TOKTLPAR); /* check for an open paren */
		1001	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSSTRING)
		1002	errsig(ctx->prscxerr, ERR_BADSYN);
		1003	synto = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1004	prsnreq(ctx, TOKTRPAR); /* require the close paren */
		1005	prsreq(ctx, TOKTEQ); /* and the '=' */
		1006
		1007	/* loop through suffixes to point to 'synto' */
		1008	for (;;)
		1009	{
		1010	/* if we don't have another string, we're done */
		1011	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSSTRING) break;
		1012
		1013	/* get the 'from' suffix, and add the synonym properties */
		1014	synfrom = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1015	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1016	prssyn(ctx, objn, verpre, synto, synfrom);
		1017	prssyn(ctx, objn, pre, synto, synfrom);
		1018	objptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1019
		1020	toknext(ctx->prscxtok);
		1021	}
		1022
		1023	/* entirely done with this property - move along */
		1024	continue;
		1025	}
		1026
		1027	/* check for a "replace" keyword on the property */
		1028	if (t == TOKTREPLACE && numsc >= 1)
		1029	{
		1030	objnum prvobj;
		1031	objnum prvprv;
		1032	objdef *prvptr;
		1033	uint prvmod;
		1034
		1035	/* skip the "replace" keyword and make sure we have a property */
		1036	t = toknext(ctx->prscxtok);
		1037	OSCPYSTRUCT(proptok, ctx->prscxtok->tokcxcur);
		1038	p = prsrqpr(ctx);
		1039
		1040	/* delete the property in all previous definitions of this obj */
		1041	for (prvobj = sclist[0] ; prvobj != MCMONINV ; prvobj = prvprv)
		1042	{
		1043	/* lock the superclass object and get its flags */
		1044	prvptr = mcmlck(ctx->prscxmem, (mcmon)prvobj);
		1045	prvmod = objflg(prvptr) & OBJFMOD;
		1046
		1047	/* if the superclass is a superseded obj, get its sc */
		1048	if (objnsc(prvptr) == 1 && prvmod)
		1049	prvprv = osrp2(objsc(prvptr));
		1050	else
		1051	prvprv = MCMONINV;
		1052
		1053	/* done with superclass object - unlock it */
		1054	mcmunlck(ctx->prscxmem, (mcmon)prvobj);
		1055
		1056	/*
		1057	* If the superclass was superseded, delete this
		1058	* property. Note that if we're generating debugging
		1059	* information, we can only mark the property as
		1060	* deleted, whereas in non-debug mode we can actually
		1061	* remove the data; the reason for the difference is
		1062	* that p-code is all self-relative, and hence can be
		1063	* relocated within an object, except for certain
		1064	* debugging instructions.
		1065	*/
		1066	if (prvmod)
		1067	objdelp(ctx->prscxmem, prvobj, p,
		1068	(ctx->prscxflg & (PRSCXFLIN \| PRSCXFLCL)) != 0);
		1069	}
		1070	}
		1071	else
		1072	{
		1073	OSCPYSTRUCT(proptok, ctx->prscxtok->tokcxcur);
		1074	p = prsrqpr(ctx); /* get property being defined */
		1075	}
		1076
		1077	/* check for template-defining properties */
		1078	if (p == PRP_IOACTION)
		1079	{
		1080	prsreq(ctx, TOKTLPAR); /* look for left paren */
		1081	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSYMBOL)
		1082	errsig(ctx->prscxerr, ERR_REQSYM);
		1083	prsdef(ctx, &ctx->prscxtok->tokcxcur, TOKSTFWDOBJ);
		1084	typ = ctx->prscxtok->tokcxcur.toksym.tokstyp;
		1085	if (typ != TOKSTOBJ && typ != TOKSTFWDOBJ)
		1086	errsig(ctx->prscxerr, ERR_REQOBJ);
		1087	prep = ctx->prscxtok->tokcxcur.toksym.toksval;
		1088	prsnreq(ctx, TOKTRPAR);
		1089	}
		1090
		1091	if (p == PRP_DOACTION \|\| p == PRP_IOACTION)
		1092	{
		1093	uchar *root;
		1094	uchar *thistpl;
		1095
		1096	if (tplcur >= sizeof(tpl)) errsig(ctx->prscxerr, ERR_MANYTPL);
		1097	thistpl = tpl + tplcur;
		1098
		1099	/* presume template flags will be zero, if any */
		1100	tplflags = 0;
		1101
		1102	/* skip the '=' */
		1103	prsreq(ctx, TOKTEQ);
		1104
		1105	/*
		1106	* Check for flags - flags are tokens (non-reserved words)
		1107	* listed in parens after the equals sign.
		1108	*/
		1109	if (ctx->prscxtok->tokcxcur.toktyp == TOKTLBRACK)
		1110	{
		1111	/* flags are not allowed with pre-'C' file format */
		1112	if (ctx->prscxflg & PRSCXFTPL1)
		1113	errlog(ctx->prscxerr, ERR_NOTPLFLG);
		1114
		1115	/* read all flags */
		1116	for (;;)
		1117	{
		1118	int t;
		1119	int i;
		1120	size_t l;
		1121	tokdef *tokp;
		1122	static struct
		1123	{
		1124	char *nam;
		1125	int flagval;
		1126	} *kw, kwlist[] =
		1127	{
		1128	{ "disambigDobjFirst", VOCTPLFLG_DOBJ_FIRST },
		1129	{ "disambigIobjFirst", 0 }
		1130	};
		1131
		1132	/* get the next token, and stop if it's the ']' */
		1133	if ((t = toknext(ctx->prscxtok)) == TOKTRBRACK)
		1134	break;
		1135
		1136	/* we need a symbol */
		1137	if (t != TOKTSYMBOL)
		1138	errsig(ctx->prscxerr, ERR_REQSYM);
		1139
		1140	tokp = &ctx->prscxtok->tokcxcur;
		1141
		1142	/* find the symbol and apply the flag */
		1143	for (kw = kwlist, i = sizeof(kwlist)/sizeof(kwlist[0]) ;
		1144	i ; ++kw, --i)
		1145	{
		1146	l = strlen(kw->nam);
		1147	if (l == (size_t)tokp->toklen &&
		1148	!memcmp(kw->nam, tokp->toknam, l))
		1149	{
		1150	tplflags \|= kw->flagval;
		1151	break;
		1152	}
		1153	}
		1154
		1155	/* if we didn't find the flag, it's an error */
		1156	if (i == 0)
		1157	errsig(ctx->prscxerr, ERR_BADTPLF);
		1158	}
		1159
		1160	/* skip the closing bracket */
		1161	toknext(ctx->prscxtok);
		1162	}
		1163
		1164	/* we need a string to define the template */
		1165	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSSTRING)
		1166	errsig(ctx->prscxerr, ERR_BADTPL);
		1167	root = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1168	if (osrp2(root) + 3 > TOKNAMMAX)
		1169	errsig(ctx->prscxerr, ERR_LONGTPL);
		1170
		1171	/* build the template based on the root name and prep */
		1172	if (p == PRP_IOACTION)
		1173	{
		1174	oswp2(thistpl, prep);
		1175	oswp2(thistpl+2, prstpl(ctx, root, "verIo"));
		1176	oswp2(thistpl+4, prstpl(ctx, root, "io"));
		1177	}
		1178	else
		1179	{
		1180	oswp2(thistpl, MCMONINV);
		1181	oswp2(thistpl+2, 0);
		1182	oswp2(thistpl+4, 0);
		1183	}
		1184	oswp2(thistpl+6, prstpl(ctx, root, "verDo"));
		1185	oswp2(thistpl+8, prstpl(ctx, root, "do"));
		1186
		1187	/* add the flags */
		1188	if (!(ctx->prscxflg & PRSCXFTPL1))
		1189	thistpl[10] = tplflags;
		1190
		1191	/* we're done with this property entirely - move on */
		1192	tplcur += tplsiz; /* move past space we just used */
		1193	tpl[0]++; /* increment count of templates in array */
		1194	toknext(ctx->prscxtok);
		1195	continue;
		1196	}
		1197
		1198	/* error if already defined */
		1199	if (objgetp(ctx->prscxmem, objn, p, (dattyp *)0) != 0)
		1200	errlog(ctx->prscxerr, ERR_PREDEF);
		1201
		1202	/* check for a formal parameter list */
		1203	prsrstn(ctx);
		1204	varargs = FALSE;
		1205	parms = 0;
		1206	curfr = 0; /* no local symbol frame yet */
		1207	ltab = (toktldef *)0;
		1208	if (ctx->prscxtok->tokcxcur.toktyp == TOKTLPAR)
		1209	{
		1210	ltab = prsvlst(ctx, (toktldef )0, (prsndef *)0, &parms, TRUE,
		1211	&varargs, curfr);
		1212	prsreq(ctx, TOKTRPAR);
		1213	}
		1214
		1215	/*
		1216	* Check for redirection syntax: xoVerb -> obj. This means to
		1217	* route xoVerb and verXoVerb to the given object's methods of
		1218	* the same name.
		1219	*/
		1220	if (ctx->prscxtok->tokcxcur.toktyp == TOKTPOINTER)
		1221	{
		1222	char buf[2];
		1223	int typ;
		1224	toksdef *sym;
		1225	tokdef tok2;
		1226	toktdef *tab;
		1227
		1228	/* get the object (and make sure it's an object) */
		1229	if (toknext(ctx->prscxtok) != TOKTSYMBOL)
		1230	errsig(ctx->prscxerr, ERR_REQSYM);
		1231	prsdef(ctx, &ctx->prscxtok->tokcxcur, TOKSTFWDOBJ);
		1232	sym = &ctx->prscxtok->tokcxcur.toksym;
		1233	typ = sym->tokstyp;
		1234	if (typ != TOKSTOBJ && typ != TOKSTFWDOBJ)
		1235	errsig(ctx->prscxerr, ERR_REQOBJ);
		1236
		1237	/* add the definition for this property */
		1238	oswp2(buf, ctx->prscxtok->tokcxcur.toksym.toksval);
		1239	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1240	objsetp(ctx->prscxmem, (mcmon)objn, p, DAT_REDIR, buf,
		1241	(objucxdef *)0);
		1242	objptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1243
		1244	/* figure out the other property name */
		1245	memcpy(tok2.toknam, "ver", (size_t)3);
		1246	memcpy(&tok2.toknam[3], proptok.toknam, (size_t)proptok.toklen);
		1247	tok2.toknam[proptok.toklen + 3] = '\0';
		1248	if (vocislower(tok2.toknam[3]))
		1249	tok2.toknam[3] = toupper(tok2.toknam[3]);
		1250	tok2.toklen = proptok.toklen + 3;
		1251
		1252	/* fold case if we're in case-insensitive mode */
		1253	tok_case_fold(ctx->prscxtok, &tok2);
		1254
		1255	/* find the other property, and make sure it's a property */
		1256	tok2.tokhash = tokhsh(tok2.toknam);
		1257	tok2.toktyp = TOKTSYMBOL;
		1258	tok2.toksym.tokstyp = TOKSTUNK;
		1259	tab = ctx->prscxstab;
		1260	(*tab->toktfsea)(tab, tok2.toknam, tok2.toklen, tok2.tokhash,
		1261	&tok2.toksym);
		1262	prsdef(ctx, &tok2, TOKSTPROP);
		1263	if (tok2.toksym.tokstyp != TOKSTPROP)
		1264	errsig1(ctx->prscxerr, ERR_IMPPROP, ERRTSTR, tok2.toknam);
		1265
		1266	/* add the equivalent definition for this property */
		1267	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1268	objsetp(ctx->prscxmem, (mcmon)objn, tok2.toksym.toksval,
		1269	DAT_REDIR, buf, (objucxdef *)0);
		1270	objptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1271
		1272	/* skip the object name and move on to the next property */
		1273	toknext(ctx->prscxtok);
		1274	continue;
		1275	}
		1276
		1277	/* parse the property definition */
		1278	prsreq(ctx, TOKTEQ);
		1279	if (ctx->prscxtok->tokcxcur.toktyp == TOKTLBRACE)
		1280	{
		1281	/* make sure this isn't a vocabulary property */
		1282	if (prpisvoc(p)) errsig(ctx->prscxerr, ERR_BADVOC);
		1283
		1284	/* set up to emit code into new property */
		1285	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1286	codeofs = objemt(ctx->prscxmem, objn, p, DAT_CODE);
		1287	ctx->prscxemt->emtcxptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1288	ctx->prscxemt->emtcxofs = codeofs;
		1289	ctx->prscxemt->emtcxobj = objn;
		1290
		1291	/* emit argument count checking instruction */
		1292	if (ctx->prscxflg & PRSCXFARC)
		1293	{
		1294	emtop(ctx->prscxemt, OPCCHKARGC);
		1295	emtbyte(ctx->prscxemt, (varargs ? 0x80 : 0) + parms);
		1296	}
		1297
		1298	/* emit debug frame if there are arguments */
		1299	if (ltab) prsvgfr(ctx, ltab, &curfr);
		1300
		1301	/* parse code block, and emit return at the end */
		1302	prsstm(ctx, EMTLLNKEND, EMTLLNKEND, parms, 0, 0, (prscsdef *)0,
		1303	curfr);
		1304	emtop(ctx->prscxemt, OPCRETURN);
		1305	emtint2(ctx->prscxemt, 0);
		1306	prsdelgoto(ctx);
		1307
		1308	/* end code generation, and "close" the property */
		1309	objendemt(ctx->prscxmem, objn, p, ctx->prscxemt->emtcxofs);
		1310
		1311	/* recache objptr in case it changed during code generation */
		1312	objptr = ctx->prscxemt->emtcxptr;
		1313
		1314	/* restore local symbol table information in context */
		1315	ctx->prscxplcl = oldplcl;
		1316	ctx->prscxslcl = oldslcl;
		1317	}
		1318	else
		1319	{
		1320	prsndef *expr;
		1321	lindef *saved_lin;
		1322	uchar saved_loc[LINLLNMAX];
		1323
		1324	/* allow vocabulary list to be enclosed in square brackets */
		1325	if (prpisvoc(p) && ctx->prscxtok->tokcxcur.toktyp == TOKTLBRACK)
		1326	toknext(ctx->prscxtok);
		1327
		1328	/*
		1329	* save the line position at the START of the expression - if
		1330	* it's a one-liner, as most expression properties are, we want
		1331	* to generate the debug record at the start rather than at the
		1332	* next token, which will probably be on the next line
		1333	*/
		1334	saved_lin = ctx->prscxtok->tokcxlin;
		1335	linglop(saved_lin, saved_loc);
		1336
		1337	/* parse the expression */
		1338	expr = prsexpr(ctx);
		1339	if (expr->prsnnlf != 0)
		1340	{
		1341	/* make sure this isn't a vocabulary property */
		1342	if (prpisvoc(p)) errsig(ctx->prscxerr, ERR_BADVOC);
		1343
		1344	/* set up to emit code into new property */
		1345	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1346	codeofs = objemt(ctx->prscxmem, objn, p, DAT_CODE);
		1347	ctx->prscxemt->emtcxptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1348	ctx->prscxemt->emtcxofs = codeofs;
		1349	ctx->prscxemt->emtcxobj = objn;
		1350
		1351	/* emit debug frame if there are arguments */
		1352	if (ltab) prsvgfr(ctx, ltab, &curfr);
		1353
		1354	/* emit argument count checking instruction */
		1355	if (ctx->prscxflg & PRSCXFARC)
		1356	{
		1357	emtop(ctx->prscxemt, OPCCHKARGC);
		1358	emtbyte(ctx->prscxemt, (varargs ? 0x80 : 0 ) + parms);
		1359	}
		1360
		1361	/* generate an ENTER for no locals */
		1362	emtop(ctx->prscxemt, OPCENTER);
		1363	emtint2(ctx->prscxemt, 0);
		1364
		1365	/* generate an OPCLINE instruction if debugging */
		1366	if (ctx->prscxflg & PRSCXFLIN)
		1367	prsclin(ctx, curfr, saved_lin, TRUE, saved_loc);
		1368
		1369	/* generate code for the expression */
		1370	prsgexp(ctx, expr);
		1371
		1372	/* emit a RETVAL instruction and close the property */
		1373	emtop(ctx->prscxemt, OPCRETVAL);
		1374	emtint2(ctx->prscxemt, 0);
		1375	prsdelgoto(ctx);
		1376	objendemt(ctx->prscxmem, objn, p, ctx->prscxemt->emtcxofs);
		1377
		1378	/* recache objptr in case it changed during code generation */
		1379	objptr = ctx->prscxemt->emtcxptr;
		1380	}
		1381	else
		1382	{
		1383	/* set val pointer for list/string types */
		1384	val = &ctx->prscxpool[0] + expr->prsnv.prsnvt.tokofs;
		1385
		1386	/* special handling for vocabulary property */
		1387	if (prpisvoc(p))
		1388	{
		1389	uchar *wrdtxt;
		1390
		1391	hasvoc = TRUE; /* note presence of vocabulary */
		1392
		1393	/* single-quoted string value required */
		1394	if (expr->prsnv.prsnvt.toktyp != TOKTSSTRING)
		1395	errsig(ctx->prscxerr, ERR_BADVOC);
		1396	wrdtxt = ctx->prscxpool + expr->prsnv.prsnvt.tokofs;
		1397
		1398	for (;;)
		1399	{
		1400	/* add the vocabulary word */
		1401	vocadd(ctx->prscxvoc, p, objn,
		1402	(classflg ? VOCFCLASS : 0), (char *)wrdtxt);
		1403
		1404	/* check for additional words in list */
		1405	if (ctx->prscxtok->tokcxcur.toktyp != TOKTSSTRING)
		1406	break;
		1407
		1408	/* another word - get text and skip it */
		1409	wrdtxt = ctx->prscxpool +
		1410	ctx->prscxtok->tokcxcur.tokofs;
		1411	toknext(ctx->prscxtok);
		1412	}
		1413
		1414	/* allow vocabulary list to terminate in ']' */
		1415	if (ctx->prscxtok->tokcxcur.toktyp == TOKTRBRACK)
		1416	toknext(ctx->prscxtok);
		1417	}
		1418	else
		1419	{
		1420	switch(expr->prsnv.prsnvt.toktyp)
		1421	{
		1422	case TOKTSYMBOL:
		1423	prsdef(ctx, &expr->prsnv.prsnvt, TOKSTFWDOBJ);
		1424	switch(expr->prsnv.prsnvt.toksym.tokstyp)
		1425	{
		1426	case TOKSTOBJ:
		1427	case TOKSTFWDOBJ:
		1428	typ = DAT_OBJECT;
		1429	val = valbuf;
		1430	oval = expr->prsnv.prsnvt.toksym.toksval;
		1431	oswp2(valbuf, oval);
		1432	break;
		1433
		1434	case TOKSTFUNC:
		1435	case TOKSTFWDFN:
		1436	typ = DAT_FNADDR;
		1437	val = valbuf;
		1438	oval = expr->prsnv.prsnvt.toksym.toksval;
		1439	oswp2(valbuf, oval);
		1440	break;
		1441
		1442	case TOKSTPROP:
		1443	typ = DAT_PROPNUM;
		1444	val = valbuf;
		1445	pval = expr->prsnv.prsnvt.toksym.toksval;
		1446	oswp2(valbuf, pval);
		1447	break;
		1448
		1449	default:
		1450	errsig(ctx->prscxerr, ERR_BADPVL);
		1451	}
		1452	break;
		1453
		1454	case TOKTDSTRING:
		1455	typ = DAT_DSTRING;
		1456	break;
		1457
		1458	case TOKTSSTRING:
		1459	typ = DAT_SSTRING;
		1460	break;
		1461
		1462	case TOKTLIST:
		1463	/* set up for code/list generation */
		1464	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1465	codeofs = objemt(ctx->prscxmem, objn, p, DAT_LIST);
		1466	ctx->prscxemt->emtcxptr = mcmlck(ctx->prscxmem,
		1467	(mcmon)objn);
		1468	ctx->prscxemt->emtcxofs = codeofs;
		1469	ctx->prscxemt->emtcxobj = objn;
		1470
		1471	/* generate the list value */
		1472	emtlst(ctx->prscxemt, expr->prsnv.prsnvt.tokofs,
		1473	ctx->prscxpool);
		1474
		1475	/* finish code/list generation */
		1476	objendemt(ctx->prscxmem, objn, p,
		1477	ctx->prscxemt->emtcxofs);
		1478	objptr = ctx->prscxemt->emtcxptr;
		1479	goto skip_for_list; /* already set! */
		1480
		1481	case TOKTNUMBER:
		1482	typ = DAT_NUMBER;
		1483	val = valbuf;
		1484	oswp4(valbuf, expr->prsnv.prsnvt.tokval);
		1485	break;
		1486
		1487	case TOKTNIL:
		1488	typ = DAT_NIL;
		1489	break;
		1490
		1491	case TOKTTRUE:
		1492	typ = DAT_TRUE;
		1493	break;
		1494
		1495	case TOKTPOUND:
		1496	typ = DAT_PROPNUM;
		1497	val = valbuf;
		1498	pval = expr->prsnv.prsnvt.tokofs;
		1499	oswp2(valbuf, pval);
		1500	break;
		1501
		1502	default:
		1503	errsig(ctx->prscxerr, ERR_BADPVL);
		1504	}
		1505
		1506	/* now set the property value */
		1507	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1508	objsetp(ctx->prscxmem, objn, p, typ, val, (objucxdef *)0);
		1509	objptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1510
		1511	skip_for_list:
		1512	/* take note of certain special properties */
		1513	switch(p)
		1514	{
		1515	case PRP_LOCATION:
		1516	if (typ == DAT_OBJECT) locobj = oval;
		1517	else if (typ == DAT_NIL) locnil = TRUE;
		1518	else locwarn = TRUE;
		1519	break;
		1520
		1521	case PRP_CONTENTS:
		1522	contset = TRUE;
		1523	break;
		1524
		1525	case PRP_LOCOK:
		1526	if (typ == DAT_TRUE) locok = TRUE;
		1527	break;
		1528	}
		1529	}
		1530	}
		1531	}
		1532	}
		1533
		1534	/* error cleanup: unlock the object, restore context data */
		1535	ERRCLEAN(ctx->prscxerr)
		1536	ctx->prscxslcl = oldslcl;
		1537	ctx->prscxplcl = oldplcl;
		1538	prsdelgoto(ctx);
		1539	ctx->prscxtok->tokcxstab = oldltab;
		1540	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1541	ERRENDCLN(ctx->prscxerr)
		1542
		1543	/* done parsing - unlock object to set some special properties */
		1544	mcmtch(ctx->prscxmem, (mcmon)objn);
		1545	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1546
		1547	/* add templates if any were defined */
		1548	if (tplcur != 1)
		1549	objsetp(ctx->prscxmem, objn, tplprop, tpldat, tpl, (objucxdef *)0);
		1550
		1551	/* add contents for set-on-demand if not already set */
		1552	if (!contset)
		1553	objsetp(ctx->prscxmem, objn, PRP_CONTENTS, DAT_DEMAND, (void *)0,
		1554	(objucxdef *)0);
		1555
		1556	/* add location record */
		1557	vociadd(ctx->prscxvoc, objn, locobj, numsc, sclist,
		1558	(classflg \| (hasvoc ? VOCIFVOC : 0) \| (locnil ? VOCIFLOCNIL : 0)));
		1559
		1560	/* issue location type warning if appropriate */
		1561	if (locwarn && !locok)
		1562	errlog1(ctx->prscxerr, ERR_LOCNOBJ, ERRTSTR,
		1563	errstr(ctx->prscxerr, (char *)objtok->toknam, objtok->toklen));
		1564
		1565	/* later: build an index on the properties if it's a class */
		1566	indexprop = FALSE;
		1567	if (indexprop) objindx(ctx->prscxmem, objn);
		1568
		1569	/* resize the object: exact size for classes, a little room for others */
		1570	objptr = mcmlck(ctx->prscxmem, (mcmon)objn);
		1571	freeofs = objfree(objptr);
		1572	mcmunlck(ctx->prscxmem, (mcmon)objn);
		1573
		1574	if (indexprop) freeofs += objnprop(objptr) * 4;
		1575
		1576	mcmrealo(ctx->prscxmem, (mcmon)objn,
		1577	(ushort)(freeofs + (classflg ? 0 : OBJEXTRA)));
		1578	mcmunlck(ctx->prscxmem, (mcmon)objn); /* unlock (realloc locks it) */
		1579	}
		1580
		1581	/* parse a special word definition */
		1582	static void prsspec(prscxdef *ctx, int modflag)
		1583	{
		1584	uchar *wrd;
		1585	uchar *p;
		1586	int tok;
		1587	size_t len;
		1588	uchar *typ;
		1589	int end_of_list;
		1590	static uchar wordtypes[] =
		1591	{
		1592	VOCW_OF, VOCW_AND, VOCW_THEN, VOCW_ALL, VOCW_BOTH,
		1593	VOCW_BUT, VOCW_ONE, VOCW_ONES, VOCW_IT, VOCW_THEM,
		1594	VOCW_HIM, VOCW_HER, VOCW_ANY, 0
		1595	};
		1596	static struct
		1597	{
		1598	char typ;
		1599	char *def;
		1600	} *defp, defaults[] =
		1601	{
		1602	/* keep equivalent words contiguous */
		1603	{ VOCW_ANY, "any" },
		1604	{ VOCW_ANY, "either" },
		1605	{ 0, 0}
		1606	};
		1607
		1608	/* delete old special words */
		1609	if ((modflag == 0 \|\| modflag == TOKTREPLACE) && ctx->prscxspp)
		1610	{
		1611	if (modflag == 0) errlog(ctx->prscxerr, ERR_RPLSPEC);
		1612	mchfre(ctx->prscxspp);
		1613	ctx->prscxspp = 0;
		1614	ctx->prscxsps = 0;
		1615	ctx->prscxspf = 0;
		1616	}
		1617
		1618	/* start the defaults at the bottom of the list */
		1619	defp = defaults;
		1620
		1621	/* loop through the word types */
		1622	for (end_of_list = FALSE, typ = wordtypes ; *typ ; ++typ)
		1623	{
		1624	/* loop through synonyms for current word */
		1625	do
		1626	{
		1627	if (!end_of_list
		1628	&& (tok = toknext(ctx->prscxtok)) != TOKTSSTRING
		1629	&& tok != TOKTNIL)
		1630	errsig(ctx->prscxerr, ERR_BADSPEC);
		1631
		1632	/* check for 'nil', which keeps original list intact */
		1633	if (!end_of_list && tok == TOKTNIL)
		1634	{
		1635	if (modflag != TOKTMODIFY)
		1636	errsig(ctx->prscxerr, ERR_SPECNIL);
		1637	tok = toknext(ctx->prscxtok);
		1638	break;
		1639	}
		1640
		1641	/*
		1642	* If we've reached the end of the user's list, see if
		1643	* there are defaults. If not, it's an error, since the
		1644	* list ended prematurely (the set of words defined in the
		1645	* v2.0 specialWords list did not have defaults; only words
		1646	* added later have defaults).
		1647	*/
		1648	if (end_of_list)
		1649	{
		1650	/*
		1651	* Find this type in the defaults. If not available,
		1652	* it's an error.
		1653	*/
		1654	while (defp->def && defp->typ != *typ)
		1655	++defp;
		1656	if (!defp->def)
		1657	errsig(ctx->prscxerr, ERR_BADSPEC);
		1658
		1659	/* take this word */
		1660	add_another_default:
		1661	wrd = (uchar *)defp->def;
		1662	len = strlen((char *)wrd);
		1663	}
		1664	else
		1665	{
		1666	/* get the word from the user's token */
		1667	wrd = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1668	len = osrp2(wrd) - 2;
		1669	wrd += 2;
		1670	}
		1671
		1672	/* make sure the word will fit - get more storage if not */
		1673	if (!ctx->prscxspp
		1674	\|\| len + 2 > (size_t)(ctx->prscxsps - ctx->prscxspf))
		1675	{
		1676	uint newsiz;
		1677	uchar *newptr;
		1678
		1679	newsiz = ctx->prscxsps + len + 128;
		1680	newptr = mchalo(ctx->prscxerr, (ushort)newsiz, "prsspec");
		1681
		1682	/* copy old area, if there was one */
		1683	if (ctx->prscxspp)
		1684	{
		1685	memcpy(newptr, ctx->prscxspp, (size_t)ctx->prscxsps);
		1686	mchfre(ctx->prscxspp);
		1687	}
		1688	ctx->prscxspp = (char *)newptr;
		1689	ctx->prscxsps = newsiz;
		1690	}
		1691
		1692	/* set up another entry in the list */
		1693	p = (uchar *)ctx->prscxspp + ctx->prscxspf;
		1694	p++ = typ;
		1695	*p++ = len;
		1696	memcpy(p, wrd, (size_t)len);
		1697	p += len;
		1698	ctx->prscxspf += len + 2;
		1699
		1700	/*
		1701	* If we've hit the end of the list, and we're adding
		1702	* default words, add the next default word for this type.
		1703	*/
		1704	if (end_of_list)
		1705	{
		1706	++defp;
		1707	if (defp->typ == *typ)
		1708	goto add_another_default;
		1709	}
		1710
		1711	/* get the next token, if we haven't already ended the list */
		1712	if (!end_of_list)
		1713	tok = toknext(ctx->prscxtok);
		1714	} while (tok == TOKTEQ);
		1715
		1716	/* if we hit a semicolon, it's the end of the list */
		1717	if (!end_of_list && tok == TOKTSEM)
		1718	end_of_list = TRUE;
		1719
		1720	/* make sure a comma separates sets of words */
		1721	if (*(typ + 1) && !end_of_list && tok != TOKTCOMMA)
		1722	prssigreq(ctx, TOKTCOMMA);
		1723	}
		1724
		1725	prsreq(ctx, TOKTSEM);
		1726	}
		1727
		1728	/* parse a format string definition */
		1729	static void prsfmt(prscxdef *ctx)
		1730	{
		1731	uchar *wrd;
		1732	uchar *src;
		1733	uchar *dst;
		1734	size_t cnt;
		1735	prpnum p;
		1736	uchar *ptr;
		1737	size_t len;
		1738	size_t newlen;
		1739
		1740	/* get string to be translated */
		1741	if (toknext(ctx->prscxtok) != TOKTSSTRING)
		1742	errsig(ctx->prscxerr, ERR_BADFMT);
		1743	wrd = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1744	len = osrp2(wrd);
		1745
		1746	/* convert any (\') sequences into just plain (') */
		1747	for (src = dst = (wrd + 2), cnt = 0, newlen = len ;
		1748	cnt < len - 2 ; dst++ = src++, ++cnt)
		1749	{
		1750	if (*src == '\\')
		1751	{
		1752	++src; /* skip this character of input */
		1753	++cnt; /* note that a character has been skipped */
		1754	--newlen; /* decrease length counter accordingly */
		1755	}
		1756	}
		1757	len = newlen;
		1758	oswp2(wrd, len);
		1759
		1760	/* get property to translate it into */
		1761	toknext(ctx->prscxtok);
		1762	p = prsrqpr(ctx);
		1763
		1764	/* add to format string list */
		1765	if (!ctx->prscxfsp \|\| len + 2 > (size_t)(ctx->prscxfss - ctx->prscxfsf))
		1766	{
		1767	uint newsiz;
		1768	uchar *newptr;
		1769
		1770	/* get more storage */
		1771	newsiz = ctx->prscxfss + len + 256;
		1772	newptr = mchalo(ctx->prscxerr, (ushort)newsiz, "prsfmt");
		1773
		1774	/* set up new storage */
		1775	if (ctx->prscxfsp)
		1776	{
		1777	memcpy(newptr, ctx->prscxfsp, (size_t)ctx->prscxfss);
		1778	mchfre(ctx->prscxfsp);
		1779	}
		1780	ctx->prscxfsp = newptr;
		1781	ctx->prscxfss = newsiz;
		1782	}
		1783
		1784	/* enter new format string information in format string storage */
		1785	ptr = ctx->prscxfsp + ctx->prscxfsf;
		1786	oswp2(ptr, p);
		1787	memcpy(ptr + 2, wrd, (size_t)len);
		1788
		1789	ctx->prscxfsf += len + 2;
		1790
		1791	prsreq(ctx, TOKTSEM); /* statement ends with semicolon */
		1792	}
		1793
		1794	/* parse a compound word definition */
		1795	static void prscmpd(prscxdef *ctx)
		1796	{
		1797	uchar *word1;
		1798	uchar *word2;
		1799	uchar *word3;
		1800	uint need;
		1801	uchar *p;
		1802
		1803	/* get 'word1' */
		1804	if (toknext(ctx->prscxtok) != TOKTSSTRING)
		1805	errsig(ctx->prscxerr, ERR_BADCMPD);
		1806	word1 = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1807
		1808	/* get 'word2' */
		1809	if (toknext(ctx->prscxtok) != TOKTSSTRING)
		1810	errsig(ctx->prscxerr, ERR_BADCMPD);
		1811	word2 = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1812
		1813	/* get 'resultword' */
		1814	if (toknext(ctx->prscxtok) != TOKTSSTRING)
		1815	errsig(ctx->prscxerr, ERR_BADCMPD);
		1816	word3 = ctx->prscxpool + ctx->prscxtok->tokcxcur.tokofs;
		1817
		1818	prsnreq(ctx, TOKTSEM); /* statement ends with semicolon */
		1819
		1820	/* add the new compound word definition */
		1821	need = osrp2(word1) + osrp2(word2) + osrp2(word3);
		1822	if (!ctx->prscxcpp \|\| need > (ctx->prscxcps - ctx->prscxcpf))
		1823	{
		1824	uint newsiz;
		1825	uchar *newptr;
		1826
		1827	/* get more storage */
		1828	newsiz = ctx->prscxcps + need + 256;
		1829	newptr = mchalo(ctx->prscxerr, (ushort)newsiz, "prscmpd");
		1830
		1831	/* set up new storage */
		1832	if (ctx->prscxcpp)
		1833	{
		1834	memcpy(newptr, ctx->prscxcpp, (size_t)ctx->prscxcps);
		1835	mchfre(ctx->prscxcpp);
		1836	}
		1837	ctx->prscxcpp = (char *)newptr;
		1838	ctx->prscxcps = newsiz;
		1839	}
		1840
		1841	/* copy the three parts into the compound word area */
		1842	p = (uchar *)ctx->prscxcpp + ctx->prscxcpf;
		1843	memcpy(p, word1, (size_t)osrp2(word1));
		1844	p += osrp2(word1);
		1845	memcpy(p, word2, (size_t)osrp2(word2));
		1846	p += osrp2(word2);
		1847	memcpy(p, word3, (size_t)osrp2(word3));
		1848	p += osrp2(word3);
		1849
		1850	ctx->prscxcpf += need;
		1851	}
		1852
		1853	/*
		1854	* Parse a function or object definition. If the 'markcomp' flag is
		1855	* true, we'll mark any objects as in initial state (with objcomp) when
		1856	* done. This flag should not by the command-line compiler when not
		1857	* compiling for debugging, because the objects shouldn't be marked
		1858	* until after preinit runs. Under other circumstances (TADS/Pro,
		1859	* compiling for debugging), since preinit will be called before each
		1860	* new run of the game anyway, there is no need to wait until after
		1861	* preinit to objcomp each object, hence this can be done immediately
		1862	* after compilation.
		1863	*/
		1864	void prscode(prscxdef *ctx, int markcomp)
		1865	{
		1866	int t;
		1867	noreg tokdef tok;
		1868	int parms;
		1869	uchar *oldplcl;
		1870	uint oldslcl;
		1871	int numsc = 0; /* number of superclasses for object */
		1872	objnum sc[PRSMAXSC]; /* superclasses of current object */
		1873	objnum *scp;
		1874	int classflg = 0; /* VOCIFCLASS ==> object is a class object */
		1875	toktdef *oldltab;
		1876	int varargs;
		1877	uint curfr;
		1878	toktldef *ltab;
		1879	int oldflg;
		1880	int modflag = 0; /* modify/replace flags */
		1881
		1882	NOREG((&tok))
		1883
		1884	t = ctx->prscxtok->tokcxcur.toktyp;
		1885	if (t == TOKTEOF) return; /* end of file; nothing more to do */
		1886
		1887	/* allow null statements */
		1888	if (t == TOKTSEM)
		1889	{
		1890	toknext(ctx->prscxtok);
		1891	return;
		1892	}
		1893
		1894	/* check for special "compound word" construction */
		1895	if (t == TOKTCOMPOUND)
		1896	{
		1897	prscmpd(ctx);
		1898	return;
		1899	}
		1900
		1901	/* check for special formatString construct */
		1902	if (t == TOKTFORMAT)
		1903	{
		1904	prsfmt(ctx);
		1905	return;
		1906	}
		1907
		1908	/* check for 'replace' or 'modify' keywords */
		1909	if (t == TOKTREPLACE \|\| t == TOKTMODIFY)
		1910	{
		1911	modflag = t;
		1912	t = toknext(ctx->prscxtok);
		1913	}
		1914
		1915	/* check for specialWords construct */
		1916	if (t == TOKTSPECIAL)
		1917	{
		1918	prsspec(ctx, modflag);
		1919	return;
		1920	}
		1921
		1922	/* check for 'class' prefix */
		1923	if (t == TOKTCLASS)
		1924	{
		1925	classflg = VOCIFCLASS;
		1926	t = toknext(ctx->prscxtok);
		1927	}
		1928
		1929	if (t != TOKTSYMBOL) errsig(ctx->prscxerr, ERR_REQSYM);
		1930	OSCPYSTRUCT(tok, ctx->prscxtok->tokcxcur);
		1931
		1932	/* 'modify <object>' skips the colon and goes directly to the body */
		1933	if (modflag == TOKTMODIFY)
		1934	{
		1935	mcmon newobj;
		1936	uchar *newptr;
		1937	uchar *oldptr;
		1938	char newnam[TOKNAMMAX+1];
		1939	int len;
		1940	ushort objsiz;
		1941	lindef *lin;
		1942
		1943	/* require a previously defined object */
		1944	if (tok.toksym.tokstyp != TOKSTOBJ
		1945	\|\| vocinh(ctx->prscxvoc, tok.toksym.toksval) == 0)
		1946	errsig(ctx->prscxerr, ERR_MODOBJ);
		1947
		1948	/* create a copy of the original object */
		1949	objsiz = mcmobjsiz(ctx->prscxmem, (mcmon)tok.toksym.toksval);
		1950	newptr = mcmalo(ctx->prscxmem, objsiz, &newobj);
		1951	oldptr = mcmlck(ctx->prscxmem, (mcmon)tok.toksym.toksval);
		1952	memcpy(newptr, oldptr, (size_t)objsiz);
		1953
		1954	/* remember whether the original object was a class */
		1955	if (objflg(newptr) & OBJFCLASS)
		1956	classflg = VOCIFCLASS;
		1957
		1958	/*
		1959	* Set the "superseded by modified object" flag in the
		1960	* original. Also set the class flag, because we want the
		1961	* modified version to inherit location and vocabulary.
		1962	*/
		1963	objsflg(newptr, objflg(newptr) \| OBJFMOD \| OBJFCLASS);
		1964	mcmtch(ctx->prscxmem, (mcmon)newobj);
		1965
		1966	/* done with the objects - unlock them */
		1967	mcmunlck(ctx->prscxmem, (mcmon)tok.toksym.toksval);
		1968	mcmunlck(ctx->prscxmem, newobj);
		1969
		1970	/* create a fake symbol table entry for the original data */
		1971	len = tok.toksym.tokslen;
		1972	if (len > TOKNAMMAX - 5) len = TOKNAMMAX - 5;
		1973	sprintf(newnam, "%.*s@%d", len, tok.toksym.toksnam,
		1974	(int)newobj);
		1975	(*ctx->prscxstab->toktfadd)(ctx->prscxstab, newnam,
		1976	(int)strlen(newnam), TOKSTOBJ,
		1977	(int)newobj, tokhsh(newnam));
		1978
		1979	/* the superclass for the new object is simply the old object */
		1980	numsc = 1;
		1981	sc[0] = newobj;
		1982
		1983	/* renumber the inheritance records for the old object */
		1984	vociren(ctx->prscxvoc, tok.toksym.toksval, newobj);
		1985
		1986	/* go through all line sources and renumber this object */
		1987	for (lin = ctx->prscxvoc->voccxrun->runcxdbg->dbgcxlin ; lin ;
		1988	lin = lin->linnxt)
		1989	{
		1990	/* renumber instances of the object in this line source */
		1991	linrenum(lin, tok.toksym.toksval, newobj);
		1992	}
		1993
		1994	/* go parse the object body as normal */
		1995	toknext(ctx->prscxtok);
		1996	goto objbody;
		1997	}
		1998
		1999	prsnreq(ctx, TOKTCOLON);
		2000	t = ctx->prscxtok->tokcxcur.toktyp;
		2001	switch(t)
		2002	{
		2003	case TOKTEXTERN:
		2004	if (modflag) errlog(ctx->prscxerr, ERR_MODRPLX);
		2005	prsnreq(ctx, TOKTFUNCTION);
		2006	prsreq(ctx, TOKTSEM);
		2007	prsdef(ctx, (tokdef *)&tok, TOKSTEXTERN);
		2008	if (tok.toksym.tokstyp != TOKSTEXTERN)
		2009	errsig(ctx->prscxerr, ERR_REQEXT);
		2010	break;
		2011
		2012	case TOKTFUNCTION:
		2013	if (modflag == TOKTMODIFY) errlog(ctx->prscxerr, ERR_MODFCN);
		2014	prsdef(ctx, (tokdef *)&tok, TOKSTFWDFN);
		2015	t = toknext(ctx->prscxtok);
		2016	if (t == TOKTSEM)
		2017	{
		2018	if (modflag) errlog(ctx->prscxerr, ERR_MODFWD);
		2019	if (tok.toksym.tokstyp != TOKSTFWDFN &&
		2020	tok.toksym.tokstyp != TOKSTFUNC)
		2021	errsig(ctx->prscxerr, ERR_REQFCN);
		2022	toknext(ctx->prscxtok);
		2023	break;
		2024	}
		2025
		2026	/* check that we're not redefining the symbol, then define as fcn */
		2027	if (!(tok.toksym.tokstyp == TOKSTFWDFN
		2028	\|\| (tok.toksym.tokstyp == TOKSTFUNC && modflag == TOKTREPLACE)))
		2029	{
		2030	/* log the error */
		2031	errlog(ctx->prscxerr, ERR_FREDEF);
		2032
		2033	/*
		2034	* Since the symbol was already defined as something else,
		2035	* we haven't given it a proper function definition yet. In
		2036	* particular, we haven't assigned an object number to the
		2037	* function. Do so now by forcing the symbol to undefined
		2038	* then defining it as a function again.
		2039	*
		2040	* Note that we need to force the change in the global
		2041	* symbol table itself. This will hose down any previous
		2042	* definition of the symbol, but this doesn't matter much
		2043	* since the game is already not playable due to this error.
		2044	*/
		2045
		2046	/* set it to unknown */
		2047	tok.toksym.tokstyp = TOKSTUNK;
		2048
		2049	/* force it back into the global table as unknown */
		2050	(*ctx->prscxstab->toktfset)(ctx->prscxstab,
		2051	(toksdef *)&tok.toksym);
		2052
		2053	/* define it as a forward function to assign an object ID */
		2054	prsdef(ctx, (tokdef *)&tok, TOKSTFWDFN);
		2055	}
		2056
		2057	/*
		2058	* make sure the symbol is in the symbol table as a function if
		2059	* it's not already - it could have been a forward function, in
		2060	* which case it's time to make it a defined function, since
		2061	* this is the definition
		2062	*/
		2063	tok.toksym.tokstyp = TOKSTFUNC;
		2064	(ctx->prscxstab->toktfset)(ctx->prscxstab, (toksdef )&tok.toksym);
		2065
		2066	oldltab = ctx->prscxtok->tokcxstab; /* remember old table */
		2067	oldplcl = ctx->prscxplcl; /* and old table pool data */
		2068	oldslcl = ctx->prscxslcl;
		2069
		2070	varargs = FALSE;
		2071	parms = 0;
		2072	curfr = 0; /* no enclosing frame yet */
		2073	ltab = (toktldef )0; / no local symbol table yet */
		2074	if (t == TOKTLPAR)
		2075	{
		2076	ltab = prsvlst(ctx, (toktldef )0, (prsndef *)0, &parms, TRUE,
		2077	&varargs, curfr);
		2078	prsreq(ctx, TOKTRPAR);
		2079	}
		2080
		2081	/*
		2082	* If we're replacing this function, delete any references in
		2083	* line number records to this object; this will prevent the
		2084	* debugger from attempting to use these records, which will be
		2085	* invalid after we replace the object's pcode with the new
		2086	* pcode here.
		2087	*/
		2088	if (modflag == TOKTREPLACE)
		2089	{
		2090	lindef *lin;
		2091	for (lin = ctx->prscxvoc->voccxrun->runcxdbg->dbgcxlin ; lin ;
		2092	lin = lin->linnxt)
		2093	{
		2094	/* delete instances of the object in this line source */
		2095	lindelnum(lin, (objnum)tok.toksym.toksval);
		2096	}
		2097	}
		2098
		2099	/* set up emit context for the new object */
		2100	ctx->prscxemt->emtcxptr = mcmlck(ctx->prscxmem,
		2101	(mcmon)tok.toksym.toksval);
		2102	ctx->prscxemt->emtcxofs = 0;
		2103	ctx->prscxemt->emtcxobj = tok.toksym.toksval;
		2104
		2105	/* flag that we're doing a function - no "self" */
		2106	oldflg = ctx->prscxflg;
		2107	ctx->prscxflg \|= PRSCXFFUNC;
		2108
		2109	/* now parse the body of the function */
		2110	ERRBEGIN(ctx->prscxerr)
		2111
		2112	if (ctx->prscxflg & PRSCXFARC)
		2113	{
		2114	emtop(ctx->prscxemt, OPCCHKARGC);
		2115	emtbyte(ctx->prscxemt, (varargs ? 0x80 : 0 ) + parms);
		2116	}
		2117
		2118	/* if there's a local symbol table, set up debug record */
		2119	if (ltab) prsvgfr(ctx, ltab, &curfr);
		2120
		2121	if (ctx->prscxtok->tokcxcur.toktyp != TOKTLBRACE)
		2122	prssigreq(ctx, TOKTLBRACE);
		2123	prsstm(ctx, EMTLLNKEND, EMTLLNKEND, parms, 0, 0, (prscsdef *)0,
		2124	curfr);
		2125
		2126	/* be sure to emit a 'return' at the end of the function */
		2127	emtop(ctx->prscxemt, OPCRETURN);
		2128	emtint2(ctx->prscxemt, 0);
		2129
		2130	/* restore local symbol table information in context */
		2131	ctx->prscxplcl = oldplcl;
		2132	ctx->prscxslcl = oldslcl;
		2133
		2134	/* resize the object down to the actual space needed */
		2135	mcmrealo(ctx->prscxmem, (mcmon)tok.toksym.toksval,
		2136	(ushort)ctx->prscxemt->emtcxofs);
		2137
		2138	/* tell cache manager the object's been changed, and unlock it */
		2139	mcmtch(ctx->prscxmem, (mcmon)tok.toksym.toksval);
		2140	mcmunlck(ctx->prscxmem, (mcmon)tok.toksym.toksval);
		2141
		2142	/* to prevent stray writes to this object... */
		2143	ctx->prscxemt->emtcxptr = (uchar *)0;
		2144
		2145	/* clean up context changes, and delete labels */
		2146	ctx->prscxtok->tokcxstab = oldltab;
		2147	ctx->prscxflg = oldflg;
		2148	prsdelgoto(ctx);
		2149
		2150	ERRCLEAN(ctx->prscxerr)
		2151	ctx->prscxplcl = oldplcl;
		2152	ctx->prscxslcl = oldslcl;
		2153	ctx->prscxtok->tokcxstab = oldltab;
		2154	ctx->prscxflg = oldflg;
		2155	prsdelgoto(ctx);
		2156	mcmunlck(ctx->prscxmem, (mcmon)tok.toksym.toksval);
		2157	ERRENDCLN(ctx->prscxerr)
		2158
		2159	break;
		2160
		2161	case TOKTSYMBOL:
		2162	for (scp = sc ;;)
		2163	{
		2164	int typ;
		2165
		2166	/* check that we have room for a new superclass */
		2167	if (numsc >= PRSMAXSC) errsig(ctx->prscxerr, ERR_MANYSC);
		2168
		2169	/* define superclass symbol as object if not already done */
		2170	prsdef(ctx, &ctx->prscxtok->tokcxcur, TOKSTFWDOBJ);
		2171	typ = ctx->prscxtok->tokcxcur.toksym.tokstyp;
		2172	if (typ != TOKSTOBJ && typ != TOKSTFWDOBJ)
		2173	errsig(ctx->prscxerr, ERR_REQOBJ);
		2174
		2175	/* add the object to the superclass array */
		2176	*scp++ = ctx->prscxtok->tokcxcur.toksym.toksval;
		2177	++numsc;
		2178
		2179	/* skip the token, and keep going as long as the list continues */
		2180	if (toknext(ctx->prscxtok) != TOKTCOMMA) break;
		2181	typ = toknext(ctx->prscxtok); /* get next object in list */
		2182	}
		2183	goto objbody;
		2184	/* FALLTHROUGH */
		2185
		2186	case TOKTOBJECT:
		2187	toknext(ctx->prscxtok);
		2188	objbody:
		2189	prsdef(ctx, (tokdef *)&tok, TOKSTFWDOBJ);
		2190	if (!(tok.toksym.tokstyp == TOKSTFWDOBJ
		2191	\|\| (tok.toksym.tokstyp == TOKSTOBJ && modflag != 0)))
		2192	{
		2193	/*
		2194	* it's already defined globally as something other than an
		2195	* object - log an error
		2196	*/
		2197	errlog(ctx->prscxerr, ERR_OREDEF);
		2198
		2199	/*
		2200	* actually redefine the symbol as an object, so that we can
		2201	* proceed with the compilation
		2202	*/
		2203	tok.toksym.tokstyp = TOKSTUNK;
		2204	prsdefobj(ctx, (tokdef *)&tok, TOKSTFWDOBJ);
		2205	}
		2206
		2207	/* if we're replacing the object, delete its vocabulary records */
		2208	if (modflag == TOKTREPLACE && tok.toksym.tokstyp == TOKSTOBJ)
		2209	{
		2210	vocidel(ctx->prscxvoc, (objnum)tok.toksym.toksval);
		2211	vocdel(ctx->prscxvoc, (objnum)tok.toksym.toksval);
		2212	}
		2213
		2214	/* make the symbol refer to an object now */
		2215	tok.toksym.tokstyp = TOKSTOBJ;
		2216	(ctx->prscxstab->toktfset)(ctx->prscxstab, (toksdef )&tok.toksym);
		2217
		2218	/* compile the object */
		2219	prsobj(ctx, &tok, numsc, sc, classflg);
		2220	if (markcomp)
		2221	objcomp(ctx->prscxmem, (objnum)tok.toksym.toksval,
		2222	(ctx->prscxflg & PRSCXFLIN) != 0);
		2223
		2224	prsreq(ctx, TOKTSEM);
		2225	break;
		2226
		2227	default:
		2228	errsig(ctx->prscxerr, ERR_SYNTAX);
		2229	}
		2230	}
		2231

FrobTADS

cfad47cfa3/t2compiler/tads2/prscomp.c