/************************************************************************/
/*                                                                      */
/* Copyright (c) 1988 -                                                 */
/*     The Rector and Visitors of the University of Virginia            */
/*                                                                      */
/* This code may not be distributed further without permission          */
/*      from the University of Virginia.                                */
/* This code is distributed WITHOUT ANY WARRANTY.  No claims are        */
/*      made as to whether it serves any particular purpose or even     */
/*      works at all.                                                   */
/*                                                                      */
/************************************************************************/

#include <stdio.h>
#include <string.h>
#include "types.h"
#include "size.h"
#include "scan.h"
#include "stopset.h"
#include "tword.h"
#include "object.h"
#include "node.h"
#include "ident.h"
#include "error.h"
#include "../rt/runtime.h"

extern int p_reached;

/*
 * statement = [ label ":" ] ( procedure-statment | assignment-statement |
 *		compound-statement | case-statment | for-statment |
 *		goto-statement | if-statment | repeat-statment | while-statement |
 *		with-statment | empty-statment ) .
 *
 * label = digit-sequence .
 *
 * emtpy-statment = .
 */

p_statement(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	OBJECT *ob;

	/* handle statement label */

	set_or(mystop, stop, stmt_begin, S0);
	p_check(mystop);
	if (symbol == SY_DIGSEQ) {
		set_or(mystop, stop, nolabel, set_cons(SY_COLON, 0), S0);
		lb_label(p_expectlabel(mystop));
		set_or(mystop, stop, nolabel, S0);
		p_expect(SY_COLON, mystop);
		p_reached = 1;
	}

	if (!p_reached && set_in(symbol, stmt_begin)) {
		strcpy(err_text, "statement is unreachable");
		err_msg(E_WARNING, E_CURSYMBOL);
		p_reached = 1;
	}

	/* determine what kind of statement and call its parse function */

	switch(symbol) {
	case SY_IDENT:
		if ((ob = ob_searchall(ident_in)) && ob->ob_kind == OB_PROC)
			p_proc_stmt(stop);
		else
			p_assign_stmt(stop);
		break;
	case SY_BEGIN:
		p_compound_stmt(stop);
		break;
	case SY_CASE:
		p_case_stmt(stop);
		p_reached = 1;
		break;
	case SY_FOR:
		p_for_stmt(stop);
		p_reached = 1;
		break;
	case SY_GOTO:
		p_goto_stmt(stop);
		p_reached = 0;
		break;
	case SY_IF:
		p_if_stmt(stop);
		p_reached = 1;
		break;
	case SY_REPEAT:
		p_repeat_stmt(stop);
		p_reached = 1;
		break;
	case SY_WHILE:
		p_while_stmt(stop);
		p_reached = 1;
		break;
	case SY_WITH:
		p_with_stmt(stop);
		break;
	default:
		p_check(stop);
	}
}

/*
 * procedure-statment = identifier actual-parameter-list .
 */

p_proc_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	OBJECT *proc;
	NODE *pnode;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, set_cons(SY_LPAREN, 0), S0);
	proc = ob_searchall(p_expectident(mystop));
	ob_keepoff(proc);
	if (proc->ob.subp.standard) {
		p_std_proc(proc, stop);
		return;
	}
	proc->ob_flags |= OB_USED;
	pnode = p_ap_list(proc, stop);
	nd_compile(nd_build(ND_CALL, TW_UNDEF, nd_address(proc), pnode));
}

/*
 * p_nextfp() returns a pointer to the next formal parameter on the list.
 */

OBJECT *
p_nextfp(fplist)
	register OBJECT *fplist;
{
	while (fplist && !(fplist->ob_kind & (OB_VALPARM|OB_VARPARM|
		OB_FUNC|OB_PROC)))
	{
		fplist = fplist->ob_prev;
	}
	return(fplist);
}

/*
 * p_passbound() passes the bound identifiers of a conformant array
 * parameter.  These are the upper and lower bounds of the array
 * index.  Note that we also pass the size of the array to make
 * subscripting in the called function quicker.
 */

NODE *
p_passbound(ndlist, aptype, fptype)
	register NODE *ndlist;
	register OBJECT *aptype, *fptype;
{
	NODE *lower, *upper, *size;
	while (fptype && fptype->ob_kind == OB_CONFARRAY) {
		if (!aptype)
			break;
		switch (aptype->ob_kind) {
		case OB_ARRAY:
			lower = nd_icon(aptype->ob.array.lower, TW_INT);
			upper = nd_icon(aptype->ob.array.upper, TW_INT);
			lower->nd_type = upper->nd_type = 
				aptype->ob.array.indextype->ob_tword;
			size = nd_icon(aptype->ob_size, TW_INT);
			break;
		case OB_CONFARRAY:
			lower = nd_value(aptype->ob.confarray.lower);
			lower = ck_subrange(lower, fptype->ob.confarray.indextype, 0);
			upper = nd_value(aptype->ob.confarray.upper);
			upper = ck_subrange(upper, fptype->ob.confarray.indextype, 0);
			size  = nd_value(aptype->ob.confarray.size);
			break;
		default:
			return(ndlist);
		}
		ndlist = nd_build(SY_COMMA, TW_UNDEF, ndlist, lower);
		ndlist = nd_build(SY_COMMA, TW_UNDEF, ndlist, upper);
		ndlist = nd_build(SY_COMMA, TW_UNDEF, ndlist, size);
		fptype = fptype->ob_type;
		aptype = aptype->ob_type;
	}
	return(ndlist);
}

/*
 * p_pass_subp(subp) passes a function or procedure as a parameter.
 * when subp is an actual procedure or function, we must save the
 * current static nesting environment (i.e., display) so that
 * when subp is called later, we can set the display to the saved
 * environment, allowing subp to correctly do up level references.
 * Run time procedure RT_save_disp saves the display and the entry
 * point for subp in a temporary variable we must allocate. The
 * functional parameter is a pointer to this temporary variable.
 *
 * If subp is a functional parameter then the display has already
 * been saved, so just pass on the struct pointer.
 */

NODE *
p_pass_subp(subp)
	OBJECT *subp;
{
	NODE *node;
	register OBJECT *tmp;
	if (subp->ob_flags & OB_PARMSUBP)	/* subp is itself a parameter */
		return(nd_address(subp));

	/* declare temp. variable for saving display */

	tmp = ob_tmpvar(TW_STRTY, sizeof(DISPAREA), OB_VARIABLE);
	tmp->ob_flags |= OB_FREETMP;
	node = nd_build(SY_COMMA, TW_UNDEF, nd_address(subp),
		nd_icon(subp->ob_level, TW_INT));
	node = nd_build(SY_COMMA, TW_UNDEF, node, nd_address(tmp));
	return (nd_build(ND_CALL, TW_PTR+TW_STRTY,
		nd_runtime("RT_save_disp", TW_PTR+TW_STRTY), node));
}

/*
 * parameter = expression | variable-access .
 */

NODE *
p_parameter(ndlist, fplist, lastap, lastfp, stop)
	register NODE *ndlist;
	OBJECT *fplist, **lastap, **lastfp;
	STOPSET stop;
{
	/*
	 * p_parameter() adds a parse tree for an actual parameter to the
	 * parse tree that represents the actual parameter list and
	 * returns a pointer to the new list.
	 */

	OBJECT *subp, *aptype, *fptype, *otmp;
	IDENT *id;
	NODE *node = ND_NULL, *ntmp;
	int fpkind, errflag=0;

	if (fplist) {
		fpkind = fplist->ob_kind;
		fptype = fplist->ob_type;
	}
	else {	/* too many actual parameters */
		fpkind = OB_VALPARM;
		fptype = std_universal;
	}

	/*
	 * Formal parameter is a conformant array.  The actual parameter
	 * must conform to the formal conformant array schema.  Furthermore,
	 * if the previous formal parameter was the same type as the
	 * current formal parameter then the previous actual parameter
	 * must be the same type as the current actual parameter.
	 * Finally, you may not pass a conformant array actual paramter
	 * to a _value_ conformant array formal parameter.
	 */
	if (fptype->ob_kind == OB_CONFARRAY) {
		aptype = (fpkind == OB_VALPARM) ? p_expression(&node, stop) :
			p_var_access(&node, VA_VARPARM, stop);
		if (ck_conforms (aptype, fptype) &&
			(*lastfp != fptype || OB_SAMETYPE(*lastap, aptype)) &&
			(fpkind != OB_VALPARM || aptype->ob_kind != OB_CONFARRAY))
		{
			if (fpkind == OB_VALPARM) {
				/*
				 * make a local copy of actual parameter and pass a
				 * pointer to it.
				 */
				otmp = ob_tmpvar(aptype->ob_tword, aptype->ob_size,
					OB_VARIABLE);
				ntmp = nd_address(otmp);
				ntmp = nd_build(ND_STASG, aptype->ob_tword, ntmp, node);
				ntmp->nd_object = aptype;
				nd_compile(ntmp);
				otmp->ob_flags |= OB_FREETMP;
				node = nd_address(otmp);
			}
		}
		else
			errflag++;
	}
	else {
		switch (fpkind) {
		case OB_VALPARM:
			aptype = p_expression(&node, stop);
			if (!ck_asgcompat(&node, fptype, aptype))
				errflag++;
			if (!OB_ISSIMPLE(aptype->ob_kind)) {
				/* a structured argument */
				node = nd_build(ND_STARG, aptype->ob_tword, node, ND_NULL);
				node->nd_object = aptype;
			}
			break;
		case OB_VARPARM:
			aptype = p_var_access(&node, VA_VARPARM, stop);
			if (!OB_SAMETYPE(aptype, fptype))
				errflag++;
			break;
		case OB_FUNC:
		case OB_PROC:
			aptype = OB_NULL;
			node = ND_NULL;
			id = p_expectident(stop);
			if (subp = ob_searchall(id)) {
				if (!ck_congruous (fplist, subp, 1))
					errflag++;
				else {
					subp->ob_flags |= OB_USED;
					node = p_pass_subp(subp);
				}
			}
			else if (id != id_noname) {
				sprintf(err_text, err_undef, "identifier", id->id_name);
				err_msg(E_FATAL, E_PREVSYMBOL);
			}
			if (!node)
				node = nd_icon(1, TW_INT);	/* error recovery */
			break;
		}
	}

	/* add new node to parameter list tree and return new tree */

	ndlist = ndlist ? nd_build(SY_COMMA, TW_UNDEF, ndlist, node) : node;
	if (errflag && fplist) {
		sprintf(err_text,
			"illegal actual parameter for formal parameter \"%s\"",
			fplist->ob_name);
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	*lastap = aptype;
	*lastfp = fptype;
	return(ndlist);
}
		
/*
 * actual-parameter-list = [ "(" parameter { "," parameter } ")" ] .
 */

NODE *
p_ap_list(subp, stop)
	OBJECT *subp;
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *fplist;
	OBJECT *lastap = OB_NULL, *lastfp = OB_NULL;
	register NODE *ndlist = ND_NULL;
	char *errflag = (char*)0;

	fplist = subp->ob.subp.parameter;
	if (symbol == SY_LPAREN) {
		set_or(mystop1, stop, expr_begin, set_cons(SY_RPAREN, SY_COMMA,
			0), S0);
		p_expect(SY_LPAREN, mystop1);
		set_or(mystop1, stop, set_cons(SY_RPAREN, SY_COMMA, 0), S0);
		set_or(mystop2, stop, expr_begin, set_cons(SY_RPAREN, 0), S0);
		for (;;) {
			if (!(fplist = p_nextfp(fplist)))
				errflag = "too many";
			ndlist = p_parameter(ndlist, fplist, &lastap, &lastfp,
				mystop1);

			/*
			 * get next formal parameter on list.  If it is a
			 * bound identifier we just did a conformant array
			 * so we must pass the array bounds and size.
			 */
			if (fplist) {
				fplist = fplist->ob_prev;
				if (fplist && fplist->ob_kind == OB_BOUNDID)
					ndlist = p_passbound(ndlist, lastap, lastfp);
			}
			if (symbol != SY_COMMA)
				break;
			p_expect(SY_COMMA, mystop2);
		}
		p_expect(SY_RPAREN, stop);
	}
	else
		p_check(stop);
	if (fplist && p_nextfp(fplist))
		errflag = "not enough";
	if (errflag) {
		sprintf(err_text, "%s parameters passed to %s \"%s\"",
			errflag, err_kind(subp->ob_kind), subp->ob_name);
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	return(ndlist);
}

/*
 * assignment-statement = variable-access ":=" expression .
 */

p_assign_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *tleft, *tright;
	NODE *nleft, *nright;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, expr_begin, set_cons(SY_ASSIGN, 0), S0);
	tleft = p_var_access(&nleft, VA_ASSIGN, mystop);
	set_or(mystop, stop, expr_begin, S0);
	p_expect(SY_ASSIGN, mystop);
	tright = p_expression(&nright, stop);
	if (!ck_asgcompat(&nright, tleft, tright)) {
		strcpy(err_text, "illegal assignment");
		err_msg(E_FATAL, E_PREVSYMBOL);
		tleft = std_universal;
	}
	if (OB_ISSIMPLE(tleft->ob_kind))
		nleft = nd_build(SY_ASSIGN, tleft->ob_tword, nleft, nright);
	else {
		nleft = nd_build(ND_STASG, tleft->ob_tword, nleft, nright);
		nleft->nd_object = tleft;
	}
	nd_compile(nleft);
}

/*
 * compound-statment = "begin" statement-sequence "end"
 */

p_compound_stmt(stop)
	register STOPSET stop;
{
	STOPBUF mystop;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, stmt_begin, set_cons(SY_END, SY_SEMI, 0), S0);
	p_expect(SY_BEGIN, mystop);
	set_or(mystop, stop, set_cons(SY_END, 0), S0);
	lb_descend();
	p_stmt_seq(mystop);
	lb_ascend();
	set_or(mystop, stop, set_cons(SY_DOT, 0), S0);
	p_expect(SY_END, mystop);
}

/*
 * statement-sequence = statement { ";" statement } .
 */

p_stmt_seq(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;

	set_or(mystop1, stop, set_cons(SY_SEMI, 0), S0);
	set_or(mystop2, stop, stmt_begin, S0);
	for(;;) {
		p_statement(mystop1);
		if (symbol != SY_SEMI)
			break;
		p_expect(SY_SEMI, mystop2);
	}
	p_check(stop);
}


/*
 * for-statment = "for" identifier ":=" expression ( "to" | "downto" )
 *		expression "do" statement .
 */

NODE *
p_for_value(tmpvar, const, tw)
	OBJECT *tmpvar;
	int const;
	TWORD tw;
{
	return (tmpvar ? nd_value(tmpvar) : nd_icon(const, tw));
}
	
p_for_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *idx, *idxtype, *expr, *tvar1, *tvar2;
	NODE *node;
	int top, nextstmt, nextop, testop;
	int tcon1 = 0, tcon2 = 0;
	int loopskipped, runtime;
	TWORD tw;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, expr_begin, stmt_begin, set_cons(SY_IDENT,
		SY_ASSIGN, SY_TO, SY_DOWNTO, SY_DO, 0), S0);
	p_expect(SY_FOR, mystop);

	/* parse control variable */

	idx = p_simple_var(VA_FORIDX, mystop);
	if (idx->ob_kind == OB_VARIABLE && idx->ob_level == ob_level) {
		idxtype = idx->ob_type;
		if (!OB_ISORDINAL(idxtype)) {
			sprintf(err_text, err_ordq, idx->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			idxtype = std_universal;
		}
		else if (idx->ob_flags & OB_THREAT) {
			sprintf(err_text,
				"\"%s\" is modified in an enclosed subprogram",
				idx->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
		}
		idx->ob_flags |= OB_FORIDX;
	}
	else {
		sprintf(err_text, "\"%s\" is not a local variable", idx->ob_name);
		err_msg(E_FATAL, E_PREVSYMBOL);
		idxtype = std_universal;
	}
	tw = idxtype->ob_tword;

	/*
	 * parse the intitial and final control variable expressions 
	 * and save them in temporary variables if they are not constants.
	 */
	
	set_or(mystop, stop, expr_begin, stmt_begin, set_cons(SY_TO,
		SY_DOWNTO, SY_DO, 0), S0);
	p_expect(SY_ASSIGN, mystop);
	expr = p_expression(&node, mystop);
	if (!ck_compatible(idxtype, expr)) {
		sprintf(err_text, err_forindex, idx->ob_name, "initial");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	if (node->nd_op == ND_ICON) {	/* a constant */
		tcon1 = node->nd.tn.ival;
		node->nd_op = ND_FREE;
		tvar1 = OB_NULL;
	}
	else {
		tvar1 = ob_tmpvar(tw, idxtype->ob_size, OB_VARIABLE);
		nd_compile(nd_build(SY_ASSIGN, tw, nd_address(tvar1), node));
	}
	set_or(mystop, stop, expr_begin, stmt_begin, set_cons(SY_DO, 0), S0);
	if (symbol == SY_DOWNTO) {
		p_expect(SY_DOWNTO, mystop);
		nextop = SY_MINUS;
		testop = SY_GE;
	}
	else {
		p_expect(SY_TO, mystop);
		nextop = SY_PLUS;
		testop = SY_LE;
	}
	set_or(mystop, stop, stmt_begin, set_cons(SY_DO, 0), S0);
	expr = p_expression(&node, mystop);
	if (!ck_compatible(idxtype, expr)) {
		sprintf(err_text, err_forindex, idx->ob_name, "final");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	if (node->nd_op == ND_ICON) {
		tcon2 = node->nd.tn.ival;
		node->nd_op = ND_FREE;
		tvar2 = OB_NULL;
	}
	else {
		tvar2 = ob_tmpvar(tw, idxtype->ob_size, OB_VARIABLE);
		nd_compile(nd_build(SY_ASSIGN, tw, nd_address(tvar2), node));
	}

	set_or(mystop, stop, stmt_begin, S0);
	p_expect(SY_DO, mystop);

	/*
	 * Emit branch to next statement when initial and final expression
	 * prevent loop iteration.
	 */

	nextstmt = lb_new();
	node = nd_build(testop, TW_INT, p_for_value(tvar1, tcon1, tw),
		p_for_value(tvar2, tcon2, tw));
	loopskipped = (node->nd_op == ND_ICON && node->nd.tn.ival == 0);
	nd_compile(nd_build(ND_CBRANCH, TW_INT, node, nd_label(nextstmt)));

	/*
	 * check initial, final expression for range error and
	 * assign initial expression to control variable.
	 */

	if (loopskipped) {
		strcpy(err_text, "\"for\" statement body never executed");
		err_msg(E_WARNING, E_CURLINE);
	}
	else {
		runtime = (tvar1 || tvar2);
		node = ck_subrange(p_for_value(tvar1, tcon1, tw),
			idxtype, runtime);
		nd_compile(nd_build(SY_ASSIGN, tw, nd_address(idx), node));
		node = ck_subrange(p_for_value(tvar2, tcon2, tw),
			idxtype, runtime);
		if (node->nd_op == ND_RANGE)  /* if range node built, compile */
			nd_compile(node);
		else
			nd_freetree(node);
	}
	
	/* compile body of loop */

	c_label(top = lb_new());
	lb_descend();
	p_statement(stop);
	lb_ascend();

	/*
	 * test control variable, increment/decrement, iterate.  Note
	 * that we test for equality with the final value before
	 * incrementing because maxint is a legal final value.
	 * If we increment first, we may overflow and have an
	 * infinite loop.
	 */

	node = nd_build(ND_DEREF, tw, nd_address(idx), ND_NULL);
	node = nd_build(SY_NE, TW_INT, node, p_for_value(tvar2, tcon2, tw));
	nd_compile(nd_build(ND_CBRANCH, TW_INT, node, nd_label(nextstmt)));
	node = nd_build(ND_DEREF, tw, nd_address(idx), ND_NULL);
	node = nd_build(nextop, tw, node, nd_icon(1, tw));
	nd_compile(nd_build(SY_ASSIGN, tw, nd_address(idx), node));
	c_goto(top, ob_level);
	c_label(nextstmt);
	idx->ob_flags &= ~OB_FORIDX;
	if (tvar1)
		ob_freetmp(tvar1);
	if (tvar2)
		ob_freetmp(tvar2);
}

/*
 * goto-statment = "goto" label .
 *
 * label = digit-sequence .
 */

p_goto_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, set_cons(SY_DIGSEQ, 0), S0);
	p_expect (SY_GOTO, mystop);
	lb_goto(p_expectlabel(stop));
}

/*
 * if-statement = "if" expression "then" statement [ "else" statement ] .
 */

p_if_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	OBJECT *expr;
	NODE *ifnode;
	int nextstmt, tmp;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, expr_begin, stmt_begin, set_cons(SY_THEN,
		SY_ELSE, 0), S0);
	p_expect(SY_IF, mystop);
	set_or(mystop, stop, stmt_begin, set_cons(SY_THEN,
		SY_ELSE, 0), S0);
	expr = p_expression(&ifnode, mystop);
	if (!OB_SAMETYPE(expr, std_boolean)) {
		sprintf(err_text, err_boole, "if");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	nextstmt = lb_new();
	nd_compile(nd_build(ND_CBRANCH, TW_INT, ifnode, nd_label(nextstmt)));
	set_or(mystop, stop, stmt_begin, set_cons(SY_ELSE, 0), S0);
	p_expect(SY_THEN, mystop);
	set_or(mystop, stop, set_cons(SY_ELSE, 0), S0);
	lb_descend();
	p_statement(mystop);
	lb_ascend();
	if (symbol == SY_ELSE) {
		c_goto(tmp = lb_new(), ob_level);
		c_label(nextstmt);
		nextstmt = tmp;
		set_or(mystop, stop, stmt_begin, S0);
		p_expect(SY_ELSE, mystop);
		p_reached = 1;
		lb_descend();
		p_statement(stop);
		lb_ascend();
	}
	else
		p_check(stop);
	c_label(nextstmt);
}

/*
 * repeat-statement = "repeat" statement-sequence "until" expression .
 */

p_repeat_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	OBJECT *expr;
	NODE *rpnode;
	int top;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, stmt_begin, expr_begin,
		set_cons(SY_UNTIL, SY_SEMI, 0), S0);
	p_expect(SY_REPEAT, mystop);
	set_or(mystop, stop, expr_begin, set_cons(SY_UNTIL, 0), S0);
	lb_descend();
	c_label(top = lb_new());
	p_stmt_seq(mystop);
	lb_ascend();
	set_or(mystop, stop, expr_begin, S0);
	p_expect(SY_UNTIL, mystop);
	expr = p_expression(&rpnode,stop);
	if (!OB_SAMETYPE(expr, std_boolean)) {
		sprintf(err_text, err_boole, "until");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	nd_compile(nd_build(ND_CBRANCH, TW_INT, rpnode, nd_label(top)));
}

/*
 * while-statement = "while" expression "do" statement .
 */

p_while_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	OBJECT *expr;
	int top, nextstmt;
	NODE *whnode;

	c_bgnstmt(src_linenum());
	set_or(mystop, stop, expr_begin, stmt_begin, set_cons(SY_DO, 0), S0);
	p_expect(SY_WHILE, mystop);
	set_or(mystop, stop, stmt_begin, set_cons(SY_DO, 0), S0);
	c_label(top = lb_new());
	expr = p_expression(&whnode, mystop);
	if (!OB_SAMETYPE(expr, std_boolean)) {
		sprintf(err_text, err_boole, "while");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	nextstmt = lb_new();
	nd_compile(nd_build(ND_CBRANCH, TW_INT, whnode, nd_label(nextstmt)));
	set_or(mystop, stop, stmt_begin, S0);
	p_expect(SY_DO, mystop);
	lb_descend();
	p_statement(stop);
	lb_ascend();
	c_goto(top, ob_level);
	c_label(nextstmt);
}

/*
 * with-statement = "with" record-variable-list "do" statement .
 *
 * record-variable-list = variable-access { "," variable-access } .
 */


p_with_stmt(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *rec, *wtmp;
	int level=0;
	NODE *node;

	c_bgnstmt(src_linenum());
	set_or(mystop1, stop, stmt_begin, set_cons(SY_COMMA, SY_DO, 0), S0);
	set_or(mystop2, stop, stmt_begin, set_cons(SY_DO, 0), S0);
	p_expect(SY_WITH, mystop1);
	for (;;) {
		rec = p_var_access(&node, VA_WITH, mystop1);
		if (rec->ob_kind != OB_RECORD) {
			strcpy(err_text, "with statement variable is not a record");
			err_msg(E_FATAL, E_PREVSYMBOL);
			nd_freetree(node);
		}
		else {
			/*
			 * Save in a temporary variable a pointer to the record
			 * returned by p_var_access().  We define the temporary
			 * variable and link it and the record's field list into
			 * the symbol table on the next block level.  See
			 * nd_address() in node.h for what happens when a field
			 * name is referenced in the with stmt.
			 */
			ob_newrecblock();
			ob_block[ob_reclevel] = wtmp =
				ob_tmpvar(TW_PTR+TW_STRTY, SZ_PTR, OB_VARIABLE);
			wtmp->ob_prev = rec->ob.record.field;
			nd_compile(nd_build(SY_ASSIGN, wtmp->ob_tword,
				nd_address(wtmp), node));
			level++;
		}
		if (symbol != SY_COMMA)
			break;
		p_expect(SY_COMMA, mystop2);
	}
	set_or(mystop1, stop, stmt_begin, S0);
	p_expect(SY_DO, mystop1);
	lb_descend();
	p_statement(stop);
	lb_ascend();
	while(level--) {
		ob_freetmp(ob_block[ob_reclevel]);
		ob_endrecblock();
	}
}
