/************************************************************************/
/*                                                                      */
/* 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 "scan.h"
#include "size.h"
#include "stopset.h"
#include "tword.h"
#include "object.h"
#include "node.h"
#include "ident.h"
#include "required.h"
#include "error.h"

extern int opt_s, opt_t;	/* command line options */

/*
 * p_runtime() builds a parse tree node that is the address of the
 * run time function corresponding to the specified Pascal required
 * function or procedure.
 */

NODE *
p_runtime(subp)
	register OBJECT *subp;
{
	register char *name;

	switch(subp->ob.subp.standard) {

	case FUNC_ARCTAN:    name = "atan";         break;
	case FUNC_ARGC:      name = "RT_argc";      break;
	case FUNC_CLOCK:     name = "RT_clock";     break;
	case FUNC_COS:       name = "cos";          break;
	case FUNC_EOF:       name = "RT_eof";       break;
	case FUNC_EOLN:      name = "RT_eoln";      break;
	case FUNC_EXP:       name = "exp";          break;
	case FUNC_LN:        name = "log";          break;
	case FUNC_RANDOM:    name = "RT_random";    break;
	case FUNC_SIN:       name = "sin";          break;
	case FUNC_SQRT:      name = "sqrt";         break;
	case FUNC_SYSCLOCK:  name = "RT_sysclock";  break;
	case FUNC_WALLCLOCK: name = "RT_wallclock"; break;
	case PROC_ARGV:      name = "RT_argv";      break;
	case PROC_DATE:      name = "RT_date";      break;
	case PROC_DISPOSE:   name = "RT_dispose";   break;
	case PROC_GET:       name = "RT_get";       break;
	case PROC_NEW:       name = "RT_new";       break;
	case PROC_PAGE:      name = "RT_page";      break;
	case PROC_PUT:       name = "RT_put";       break;
	case PROC_RESET:     name = "RT_reset";     break;
	case PROC_REWRITE:   name = "RT_rewrite";   break;
	case PROC_SEED:      name = "RT_seed";      break;
	}

	return(nd_runtime(name, subp->ob_tword));
}

/*
 * p_dfltfile() checks the default file argument to an I/O function
 * or procedure in the cases where the user has omitted it, eg,
 * "eof" ==> "eof(input)"  Complains when the default has not
 * been declared.
 */

OBJECT *
p_dfltfile(node, dfltfile, name)
	NODE **node;
	register OBJECT *dfltfile;
	char *name;
{
	register OBJECT *ftype;
	if (dfltfile) {
		ftype = dfltfile->ob_type;
		dfltfile->ob_flags |= OB_USED;
		*node = nd_address(dfltfile);
	}
	else {
		sprintf(err_text, "file \"%s\" missing in program heading",
			name);
		err_msg(E_FATAL, E_PREVSYMBOL);
		ftype = std_text;
		*node = nd_label(0);  /* an inert node */
	}
	return(ftype);
}

/*
 * p_savefile() emits code to save in a temporary variable the address
 * resulting from a variable-access of a file variable.  We may emit code
 * to pass this pointer to several run time functions, but the
 * variable-access appears only once in the source.
 */

OBJECT *
p_savefile(node)
	NODE *node;
{
	OBJECT *fname;

	/* don't save address of simple variable */

	if (node->nd_op == ND_ADDRESS) {
		node->nd_op = ND_FREE;
		return(node->nd_object);
	}
	fname = ob_tmpvar(TW_PTR+TW_STRTY, SZ_PTR, OB_VARIABLE);
	nd_compile(nd_build(SY_ASSIGN, TW_PTR+TW_STRTY, nd_address(fname),
		node));
	return(fname);
}


/*
 * p_filenode(fname) builds a node containing the address of the file
 * denoted by fname, which is either a declared variable, or a temporary
 * variable containing a pointer to the file variable.
 */

NODE *
p_filenode(fname)
	OBJECT *fname;
{
	return(TW_ISPTR(fname->ob_tword) ? nd_value(fname) :
		nd_address(fname));
}

/*
 * p_std_func() compiles calls to required functions.  Some functions
 * emit calls to the run time library, while others emit in-line code.
 */

OBJECT *
p_std_func(node, func, stop)
	register NODE **node;
	OBJECT *func;
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *ptype, *ret;
	register int funcid;

	/* parse argument */

	switch(funcid = func->ob.subp.standard) {

	case FUNC_EOF:	/* zero or one argument */
	case FUNC_EOLN:
		if (symbol != SY_LPAREN) {
			ptype = p_dfltfile(node, std_input, "input");
			p_check(stop);
			break;
		}
		/* fall through */

	default:	/* one argument */
		set_or(mystop, stop, expr_begin, set_cons(SY_RPAREN, 0), S0);
		p_expect(SY_LPAREN, mystop);
		set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
		ptype = (funcid == FUNC_EOLN || funcid == FUNC_EOF) ?
			p_var_access(node, VA_EXPR, mystop) :
			p_expression(node, mystop);
		p_expect(SY_RPAREN, stop);
		break;

	case FUNC_ARGC:		/* no arguments */
	case FUNC_CLOCK:
	case FUNC_RANDOM:
	case FUNC_SYSCLOCK:
	case FUNC_WALLCLOCK:
		p_check(stop);
		ptype = OB_NULL;
		if (opt_s) {
			strcpy(err_text, err_nonstd);
			err_msg(E_WARNING, E_PREVSYMBOL);
		}
		break;
	}

	(ret = func->ob_type) || (ret = ptype);

	if (ptype == std_universal) {
		return(std_universal);
	}

	/* generate function call code */

	switch(funcid) {

	case FUNC_ROUND:
	case FUNC_TRUNC:
		if (ptype != std_real)
			break;
		*node = nd_build(funcid == FUNC_ROUND ? ND_ROUND : ND_TRUNC,
			TW_INT, *node, ND_NULL);
		return (ret);

	case FUNC_ABS:
	case FUNC_SQR:
		if (ptype != std_real && ptype != std_integer)
			break;
		*node = nd_build(funcid == FUNC_ABS ? ND_ABS : ND_SQR,
			ret->ob_tword, *node, ND_NULL);
		return(ret);

	case FUNC_SQRT:
	case FUNC_SIN:
	case FUNC_COS:
	case FUNC_ARCTAN:
	case FUNC_EXP:
	case FUNC_LN:
		if (ptype == std_integer)
			*node = nd_build(ND_SCONV, TW_DOUBLE, *node, ND_NULL);
		else if (ptype != std_real)
			break;

		*node = nd_build(ND_CALL, TW_DOUBLE, p_runtime(func), *node);
		return(ret);


	case FUNC_ORD:
		if (!OB_ISORDINAL(ptype)) 
			break;
		*node = nd_build(ND_SCONV, TW_INT, *node, ND_NULL);
		return(ret);

	case FUNC_PRED:
	case FUNC_SUCC:
		if (!OB_ISORDINAL(ptype)) 
			break;
		*node = nd_build(ND_SCONV, TW_INT, *node, ND_NULL);
		*node = nd_build(funcid == FUNC_SUCC ? SY_PLUS : SY_MINUS,
			TW_INT, *node, nd_icon(1, TW_INT));
		*node = ck_value(*node, ptype);
		if (ptype->ob_tword == TW_CHAR)
			*node = nd_build(ND_SCONV, TW_CHAR, *node, ND_NULL);
		return(ret);

	case FUNC_CHR:
		if (ptype != std_integer)
			break;
		*node = ck_value(*node, std_char);
		*node = nd_build(ND_SCONV, TW_CHAR, *node, ND_NULL);
		return(ret);

	case FUNC_ODD:
		if (ptype != std_integer)
			break;
		*node = nd_build(ND_ODD, TW_INT, *node, ND_NULL);
		return(ret);

	case FUNC_EOLN:
		if (ptype  != std_text)
			break;
		*node = nd_build(ND_CALL, TW_INT, p_runtime(func), *node);
		return(ret);

	case FUNC_EOF:
		if (ptype->ob_kind != OB_FILE)
			break;
		*node = nd_build(ND_CALL, TW_INT, p_runtime(func), *node);
		return(ret);

	case FUNC_ARGC:
	case FUNC_CLOCK:
	case FUNC_RANDOM:
	case FUNC_SYSCLOCK:
	case FUNC_WALLCLOCK:
		*node = nd_build(ND_CALL, ret->ob_tword, p_runtime(func), ND_NULL);
		return(ret);
	}

	/* bad function argument */

	sprintf(err_text, err_stdsubp, "function", func->ob_name);
	err_msg(E_FATAL, E_PREVSYMBOL);
	return(std_universal);
}

/*
 * p_std_proc() compiles calls to required procedures.
 */

p_std_proc(proc, stop)
	OBJECT *proc;
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *ptype, *clist;
	register int procid;
	int errflag=0, count;
	NODE *node, *pnode;

	switch(procid = proc->ob.subp.standard) {

	case PROC_DISPOSE:
	case PROC_NEW:
		
		 /*
		  * for new(p) emit code to do p = RT_new(sizeof(*p))
		  *
		  * for dispose(p) emit code to do RT_dispose(p, size)
		  * where size is -1 except when p contains a file
		  * type.  Then RT_dispose will close any open files.
		  */
		set_or(mystop, stop, const_begin, set_cons(SY_COMMA,
			SY_RPAREN, 0), S0);
		p_expect(SY_LPAREN, mystop);
		ptype = procid == PROC_NEW ?
			p_var_access(&pnode, VA_ASSIGN, mystop) :
			p_expression(&pnode, mystop);
		if (ptype->ob_kind != OB_POINTER) {
			errflag++;
			ptype = std_universal;
		}
		if (symbol == SY_COMMA) {
			set_or(mystop, stop, const_begin, set_cons(SY_RPAREN,
				0), S0);
			p_expect(SY_COMMA, mystop);
			set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
			clist = p_case_const_list(&count, std_universal, mystop);
			errflag += ck_new_args(ptype->ob_type, clist, count);
		}
		p_expect(SY_RPAREN, stop);
		if (errflag)
			break;
		if (procid == PROC_NEW) {
			node = nd_build(ND_CALL, ptype->ob_tword, p_runtime(proc),
				nd_icon(ptype->ob_type->ob_size, TW_INT));
			nd_compile(nd_build(SY_ASSIGN, ptype->ob_tword, pnode, node));
		}
		else {
			int size = ck_hasfile(ptype->ob_type) ?
				ptype->ob_type->ob_size : -1;
			pnode = nd_build(SY_COMMA, TW_UNDEF, pnode,
				nd_icon(size, TW_INT));
			nd_compile(nd_build(ND_CALL, TW_UNDEF, p_runtime(proc), pnode));
		}
		break;

	case PROC_GET:		/* single argument I/O procedures */
	case PROC_PUT:
	case PROC_PAGE:
		if (symbol == SY_LPAREN || procid != PROC_PAGE) {
			set_or(mystop, stop, set_cons(SY_IDENT, SY_RPAREN, 0), S0);
			p_expect(SY_LPAREN, mystop);
			set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
			ptype = p_var_access(&node, VA_EXPR, mystop);
			p_expect(SY_RPAREN, stop);
		}
		else {
			ptype = p_dfltfile(&node, std_output, "output");
			p_check(stop);
		}
		if (ptype->ob_kind != OB_FILE || (procid == PROC_PAGE &&
			ptype != std_text))
		{
			errflag++;
		}
		nd_compile(nd_build(ND_CALL, TW_UNDEF, p_runtime(proc), node));
		break;

	case PROC_RESET:
	case PROC_REWRITE:
		errflag += p_rewrite(proc, stop);
		break;

	case PROC_READ:
	case PROC_READLN:
		errflag += p_read(procid, stop);
		break;

	case PROC_WRITE:
	case PROC_WRITELN:
		errflag += p_write(procid, stop);
		break;

	case PROC_PACK:
	case PROC_UNPACK:
		errflag += p_pack(procid, stop);
		break;

	case PROC_ARGV:   /* these are extra functions */
	case PROC_DATE:
	case PROC_SEED:
		if (opt_s) {
			strcpy(err_text, err_nonstd);
			err_msg(E_WARNING, E_PREVSYMBOL);
		}
		switch(procid) {
		case PROC_ARGV:  /* for getting command line argument */
			errflag += p_argv(proc, stop);
			break;
		case PROC_DATE:  /* for getting today's date */
			errflag += p_date(proc, stop);
			break;
		case PROC_SEED:  /* for setting seed of random() */
			set_or(mystop, stop, expr_begin, set_cons(SY_RPAREN, 0), S0);
			p_expect(SY_LPAREN, mystop);
			set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
			ptype = p_expression(&node, mystop);
			if (!OB_SAMETYPE(ptype, std_integer))
				errflag++;
			p_expect(SY_RPAREN, stop);
			nd_compile(nd_build(ND_CALL, TW_UNDEF,
				p_runtime(proc), node));
			break;
		}
		break;
	}
	if (errflag) {
		sprintf(err_text, err_stdsubp, "procedure", proc->ob_name);
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
}

/*
 * read-parameter-list = "(" [ file-variable "," ] variable-access
 *    { "," variable-access } ")" .
 *
 * readln-parameter-list = [ "(" ( file-variable | variable-access)
 *    { "," variable-access } ")" ] .
 *
 * file-variable = variable-access .
 *
 * Note: read must have a parameter list, but readln need not.
 *       read must have at least 1 non-file parameter, but readln
 *       need not.
 */

int
p_read(procid, stop)
	int procid;
	register STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *ptype, *ftype, *fname;
	int errflag=0, readparm=0, sawparen=0;
	NODE *pnode, *fnode;

	ptype = ftype = OB_NULL;

	/* parse first parameter on list.  See if it's a file */

	if (symbol == SY_LPAREN || procid == PROC_READ) {
		sawparen++;
		set_or(mystop1, stop, set_cons(SY_IDENT, SY_COMMA, SY_RPAREN,
			0), S0);
		p_expect(SY_LPAREN, mystop1);
		set_or(mystop1, stop, set_cons(SY_COMMA, SY_RPAREN, 0), S0);
		set_or(mystop2, stop, set_cons(SY_IDENT, SY_RPAREN, 0), S0);
		ftype = p_var_access(&fnode, VA_READ, mystop1);
		if (ftype->ob_kind == OB_FILE) {
			if (symbol == SY_COMMA) {
				p_expect(SY_COMMA, mystop2);
				ptype = p_var_access(&pnode, VA_READ, mystop1);
			}
		}
		else {	/* first arg is not a file */
			ptype = ftype;
			pnode = fnode;
			ftype = OB_NULL;
		}
	}

	/* use standard file "input" if no file parameter */

	if (!ftype)
		ftype = p_dfltfile(&fnode, std_input, "input");

	/*
	 * copy the file address to a temporary since we need it  more
	 * than once.
	 */

	fname = p_savefile(fnode);

	/* parse rest of parameters */

	if (sawparen) {
		while (ptype) {
			readparm++;
			if (ftype == std_text) {
				errflag += p_rdtext(fname, ptype, pnode);
			}
			else {
				if (!ck_compatible(ptype, ftype->ob_type))
					errflag++;
				p_rdbin(fname, ptype, pnode);
			}
			if (symbol != SY_COMMA)
				break;
			p_expect(SY_COMMA, mystop2);
			ptype = p_var_access(&pnode, VA_READ, mystop1);
		}
		p_expect(SY_RPAREN, stop);
	}
	else
		p_check(stop);

	if (procid == PROC_READLN) {
		if (ftype != std_text)
			errflag++;
		nd_compile(nd_build(ND_CALL, TW_UNDEF,
			nd_runtime("RT_readln", TW_UNDEF), p_filenode(fname)));
	}
	else if (!readparm)		/* read() requires a read-parameter */
		errflag++;
	if (fname->ob_tword == TW_PTR+TW_STRTY)
		ob_freetmp(fname);
	return(errflag);
}

/*
 * write-parameter-list = "(" [ file-variable "," ] write-parameter
 *    { "," write-parameter } ")" .
 *
 * writeln-parameter-list = [ "(" ( file-variable | write-parameter )
 *    { "," write-parameter } ")" ] .
 *
 * file-variable = variable-access .
 *
 * Note: write must have a parameter list, but writeln need not.
 *       write must have at least 1 non-file parameter but writeln
 *       need not.
 */

int
p_write(procid, stop)
	int procid;
	register STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *ptype, *ftype, *fname;
	int errflag=0, writeparm=0, sawparen=0;
	NODE *pnode, *fnode, *width, *frac;

	ptype = ftype = OB_NULL;

	/* parse first parameter and see if it's a file-variable */

	if (symbol == SY_LPAREN || procid == PROC_WRITE) {
		sawparen++;
		set_or(mystop1, stop, expr_begin, set_cons(SY_COMMA, SY_RPAREN,
			0), S0);
		p_expect(SY_LPAREN, mystop1);
		set_or(mystop1, stop, set_cons(SY_COMMA, SY_RPAREN, 0), S0);
		set_or(mystop2, stop, expr_begin, set_cons(SY_RPAREN, 0), S0);

		/*
		 * Since p_expression eventually parses the file-variable,
		 * which must be a variable-access, we must disallow file
		 * expressions such as "(f)"
		 */

		if (symbol == SY_IDENT) {  /* possibly a file-variable */
			ftype = p_write_parm(&fnode, &width, &frac, mystop1);
			if (ftype->ob_kind == OB_FILE) {
				if (width) {  /* field width specifier ??? */
					strcpy(err_text, err_fwidth);
					err_msg(E_FATAL, E_PREVSYMBOL);
					nd_freetree(width);
					nd_freetree(frac);
				}
				if (symbol == SY_COMMA) {
					p_expect(SY_COMMA, mystop2);
					ptype = p_write_parm(&pnode, &width, &frac, mystop1);
				}
			}
			else {	/* first parameter wasn't a file-variable */
				ptype = ftype;
				pnode = fnode;
				ftype = OB_NULL;
			}
		}
		else {
			ptype = p_write_parm(&pnode, &width, &frac, mystop1);
		}
	}

	/* use standard file "output" if no file parameter */

	if (!ftype)
		ftype = p_dfltfile(&fnode, std_output, "output");

	/*
	 * copy the file address to a temporary since we may need it  more
	 * than once.
	 */

	fname = p_savefile(fnode);

	/* parse rest of parameters */

	if (sawparen) {
		while (ptype) {
			writeparm++;
			if (ftype == std_text) {
				errflag += p_wrtext(fname, ptype, pnode, width, frac);
			}
			else {
				if (width) {
					strcpy(err_text, err_fwidth);
					err_msg(E_FATAL, E_PREVSYMBOL);
					nd_freetree(width);
					nd_freetree(frac);
				}
				if (!ck_compatible(ptype, ftype->ob_type))
					errflag++;
				p_wrbin(fname, ftype->ob_type, pnode);
			}
			if (symbol != SY_COMMA)
				break;
			p_expect(SY_COMMA, mystop2);
			ptype = p_write_parm(&pnode, &width, &frac, mystop1);
		}
		p_expect(SY_RPAREN, stop);
	}
	else
		p_check(stop);

	if (procid == PROC_WRITELN) {
		if (ftype != std_text)
			errflag++;
		nd_compile(nd_build(ND_CALL, TW_UNDEF,
			nd_runtime("RT_writeln", TW_UNDEF), p_filenode(fname)));
	}
	else if (!writeparm)	/* write() requires a write-parameter */
		errflag++;
	if (fname->ob_tword == TW_PTR+TW_STRTY)
		ob_freetmp(fname);
	return(errflag);
}


/*
 * write-parameter = expression [ ":" expression [ ":" expression ] ] .
 */

OBJECT *
p_write_parm(value, width, frac, stop)
	register NODE **value, **width, **frac;
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *ptype, *type;
	int errflag=0;

	*width = *frac = ND_NULL;
	set_or(mystop1, stop, set_cons(SY_COLON, 0), S0);
	ptype = p_expression(value, mystop1);
	if (symbol == SY_COLON) {
		set_or(mystop2, stop, expr_begin, S0);
		p_expect(SY_COLON, mystop2);
		type = p_expression(width, mystop1);
		if (!OB_SAMETYPE(type, std_integer))
			errflag++;
		if (symbol == SY_COLON) {
			p_expect(SY_COLON, mystop2);
			type = p_expression(frac, stop);
			if (ptype != std_real || !OB_SAMETYPE(type, std_integer))
				errflag++;
		}
	}
	if (errflag) {
		strcpy(err_text, err_fwidth);
		err_msg(E_FATAL, E_PREVSYMBOL);
		nd_freetree(*width);
		nd_freetree(*frac);
		*width = *frac = ND_NULL;
	}
	return(ptype);
}

/*
 * p_rdtext() emits code to call run time function that reads a
 * value from a text file.  Emit assignment to variable.
 */

int
p_rdtext(fname, ptype, pnode)
	OBJECT *fname, *ptype;
	register NODE *pnode;
{
	register NODE *node, *runtime;
	TWORD tw;

	tw = ptype->ob_tword;
	if (ck_compatible(ptype, std_integer))
		runtime = nd_runtime("RT_readint", tw);
	else if (ck_compatible(ptype, std_char))
		runtime = nd_runtime("RT_readchar", tw);
	else if (ptype == std_real)
		runtime = nd_runtime("RT_readreal", tw);
	else {
		nd_freetree(pnode);		/* error recovery */
		return(1);
	}
	node = nd_build(ND_CALL, tw, runtime, p_filenode(fname));
	node = ck_value(node, ptype);
	nd_compile(nd_build (SY_ASSIGN, tw, pnode, node));
	return(0);
}

/*
 * p_rdbin emits code to read a component of a binary file.
 * emit an assignment of buffer variable to read parameter
 * and emit a call to RT_get().
 */

p_rdbin(fname, ptype, pnode)
	register OBJECT *fname, *ptype;
	NODE *pnode;
{
	register TWORD tw;
	register NODE *node;

	tw = ptype->ob_tword;
	node = nd_build(SY_COMMA, TW_UNDEF, p_filenode(fname),
		nd_icon(1, TW_INT));
	node = nd_build(ND_CALL, TW_INCREF(tw),
		nd_runtime("RT_wndo_ptr", TW_INCREF(tw)), node);
	if (OB_ISSIMPLE(ptype->ob_kind)) {
		node = nd_build(ND_DEREF, tw, node, ND_NULL);
		node = ck_value(node, ptype);
		nd_compile(nd_build(SY_ASSIGN, tw, pnode, node));
	}
	else {
		node = nd_build(ND_STASG, tw, pnode, node);
		node->nd_object = ptype;
		nd_compile(node);
	}
	nd_compile(nd_build(ND_CALL, TW_UNDEF,
		nd_runtime("RT_get", TW_UNDEF), p_filenode(fname)));
}

/*
 * p_wrtext() emits code to write a value to a text file, a call to
 * RT_writef.
 */

int
p_wrtext(fname, ptype, pnode, width, frac)
	register OBJECT *fname, *ptype;
	NODE *pnode, *width, *frac;
{
	char fmtchar;
	register NODE *plist;

	if (ptype == std_real) {
		fmtchar = width ? 'e' : 'E';
		if (frac)
			fmtchar = 'f';
	}
	else if (ptype == std_integer || ptype == std_universal) {
		fmtchar = width ? 'd' : 'D';
	}
	else if (ptype == std_char) {
		fmtchar = width ? 'c' : 'C';
	}
	else if (ptype == std_boolean) {
		fmtchar = width ? 'b' : 'B';
	}
	else if (ck_string(ptype)) {
		fmtchar = width ? 's' : 'S';
		frac = nd_icon(ptype->ob.array.upper, TW_INT);
	}
	else {
		nd_freetree(frac);
		nd_freetree(width);
		nd_freetree(pnode);
		return(1);
	}
	if (!frac)
		frac = nd_icon(0, TW_INT);
	if (!width)
		width = nd_icon(0, TW_INT);

	plist = nd_build(SY_COMMA, TW_UNDEF, p_filenode(fname), width);
	plist = nd_build(SY_COMMA, TW_UNDEF, plist, frac);
	plist = nd_build(SY_COMMA, TW_UNDEF, plist, nd_icon(fmtchar, TW_CHAR));
	plist = nd_build(SY_COMMA, TW_UNDEF, plist, pnode);
	nd_compile(nd_build(ND_CALL, TW_UNDEF,
		nd_runtime("RT_writef", TW_UNDEF), plist));
	return (0);
}

/*
 * p_wrbin() emits code to write to a binary file.  Assign value to
 * buffer variable and call RT_put.
 */

p_wrbin(fname, filcomp, pnode)
	OBJECT *fname, *filcomp;
	NODE *pnode;
{
	TWORD tw;
	register NODE *node;

	tw = filcomp->ob_tword;

	/* get address of buffer variable */

	node = nd_build(SY_COMMA, TW_UNDEF, p_filenode(fname),
		nd_icon(0, TW_INT));
	node = nd_build(ND_CALL, TW_INCREF(tw),
		nd_runtime("RT_wndo_ptr", TW_INCREF(tw)), node);

	/* simple types are range checked and assigned to buffer variable */

	if (OB_ISSIMPLE(filcomp->ob_kind)) {
		pnode = ck_subrange(pnode, filcomp, 0);
		nd_compile(nd_build(SY_ASSIGN, tw, node, pnode));
	}
	else {
		node = nd_build(ND_STASG, tw, node, pnode);
		node->nd_object = filcomp;
		nd_compile(node);
	}
	nd_compile(nd_build(ND_CALL, TW_UNDEF,
		nd_runtime("RT_put", TW_UNDEF), p_filenode(fname)));
}

/*
 * p_pack compiles pack() and unpack() calls.  Since the compiler
 * stores packed and unpacked types identically, p_pack generates
 * a ND_STASG (structured assignment).
 */

int
p_pack(procid, stop)
	int procid;
	register STOPSET stop;
{
	STOPBUF mystop1, mystop2, mystop3;
	register OBJECT *array, *parray, *idx;
	NODE *anode, *pnode, *inode;

	set_or(mystop1, stop, expr_begin, set_cons(SY_COMMA, SY_RPAREN,
		0), S0);
	p_expect(SY_LPAREN, mystop1);
	set_or(mystop1, stop, set_cons(SY_COMMA, SY_RPAREN, 0), S0);
	set_or(mystop2, stop, expr_begin, set_cons(SY_RPAREN, 0), S0);
	set_or(mystop3, stop, set_cons(SY_RPAREN, 0), S0);
	if (procid == PROC_PACK) {
		array = p_var_access(&anode, VA_EXPR, mystop1);
		p_expect(SY_COMMA, mystop2);
		idx = p_expression(&inode, mystop1);
		(void) p_array_index(&anode, array, idx, inode);
		p_expect(SY_COMMA, mystop2);
		parray = p_var_access(&pnode, VA_ASSIGN, mystop3);
		anode = nd_build(ND_STASG, parray->ob_tword, pnode, anode);
	}
	else {
		parray = p_var_access(&pnode, VA_EXPR, mystop1);
		p_expect(SY_COMMA, mystop2);
		array = p_var_access(&anode, VA_ASSIGN, mystop1);
		p_expect(SY_COMMA, mystop2);
		idx = p_expression(&inode, mystop3);
		(void) p_array_index(&anode, array, idx, inode);
		anode = nd_build(ND_STASG, parray->ob_tword, anode, pnode);
	}
	p_expect(SY_RPAREN, stop);
	anode->nd_object = parray;
	if ((array->ob_kind  & (OB_ARRAY|OB_CONFARRAY)) &&
		(parray->ob_kind & (OB_ARRAY|OB_CONFARRAY)) &&
		(parray->ob_flags & OB_PACKED) &&
		!(array->ob_flags & OB_PACKED) &&
		OB_SAMETYPE(array->ob_type, parray->ob_type))
	{
		nd_compile(anode);
		return(0);
	}
	nd_freetree(anode);
	return(1);	/* error */
}

/*
 * p_rewrite() compiles calls to reset and rewrite.  Emits code
 * to call RT_reset or RT_rewrite.
 */

int
p_rewrite(proc, stop)
	OBJECT *proc;
	register STOPSET stop;
{
	register OBJECT *ptype;
	STOPBUF mystop;
	NODE *node, *pathname;
	int procid, reclength, errflag=0;

	procid = proc->ob.subp.standard;
	set_or(mystop, stop, set_cons(SY_IDENT, SY_STRING, SY_COMMA,
		SY_RPAREN, 0), S0);
	p_expect(SY_LPAREN, mystop);
	set_or(mystop, stop, set_cons(SY_STRING, SY_COMMA, SY_RPAREN,
		0), S0);
	ptype = p_var_access(&node, VA_ASSIGN, mystop);
	if (ptype->ob_kind != OB_FILE) {
		errflag++;
		ptype = std_text;
	}
	if (procid == PROC_REWRITE)
		reclength = ptype == std_text ? 0 : ptype->ob_type->ob_size;

	/*
	 * local extension:  reset/rewrite allows a null terminated
	 * unix pathname as a second argument when the first argument
	 * is a permanent file.
	 */
	if (symbol == SY_COMMA && node->nd_op == ND_ADDRESS &&
		node->nd_object->ob_flags & OB_PROGPARM)
	{
		set_or(mystop, stop, set_cons(SY_STRING, SY_IDENT,
			SY_RPAREN, 0), S0);
		p_expect(SY_COMMA, mystop);
		set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
		ptype = p_expression(&pathname, mystop);
		if (!ck_string(ptype))
			errflag++;
		if (opt_s) {
			strcpy(err_text, err_nonstd);
			err_msg(E_WARNING, E_PREVSYMBOL);
		}
	}
	else {  /* pass null pointer */
		pathname = nd_icon(0, TW_PTR+TW_CHAR);
	}
	p_expect(SY_RPAREN, stop);

	/* generate call to reset or rewrite */

	node = nd_build(SY_COMMA, TW_UNDEF, node, pathname);
	if (procid == PROC_REWRITE) {
		node = nd_build(SY_COMMA, TW_UNDEF, node,
			nd_icon(reclength, TW_INT));
	}
	nd_compile(nd_build(ND_CALL, TW_UNDEF, p_runtime(proc), node));
	return(errflag);
}

/*
 * p_argv compiles calls argv (local extension to get command line
 * arguments).
 */

int
p_argv(proc, stop)
	OBJECT *proc;
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *ptype;
	NODE *intparm, *strparm;
	int errflag = 0, size;

	set_or(mystop, stop, expr_begin, set_cons(SY_COMMA, SY_RPAREN, 0), S0);
	p_expect(SY_LPAREN, mystop);
	set_or(mystop, stop, set_cons(SY_COMMA, SY_RPAREN, 0), S0);
	ptype = p_expression(&intparm, mystop);
	if (!OB_SAMETYPE(ptype, std_integer))
		errflag++;
	set_or(mystop, stop, set_cons(SY_RPAREN, SY_IDENT, 0), S0);
	p_expect(SY_COMMA, mystop);
	set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
	ptype = p_var_access(&strparm, VA_ASSIGN, mystop);
	if (ck_string(ptype))
		size = ptype->ob.array.upper;
	else {
		errflag++;
		size = 0;
	}
	p_expect(SY_RPAREN, stop);
	intparm = nd_build(SY_COMMA, TW_UNDEF, intparm, strparm);
	intparm = nd_build(SY_COMMA, TW_UNDEF, intparm, nd_icon(size, TW_INT));
	nd_compile(nd_build(ND_CALL, TW_UNDEF, p_runtime(proc), intparm));
	return(errflag);
}

/*
 * p_date compiles calls to procedure date (local extension for
 * getting today's date).
 */

int
p_date(proc, stop)
	OBJECT *proc;
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *ptype;
	NODE *node;
	int errflag = 0, size;

	set_or(mystop, stop, set_cons(SY_IDENT, SY_RPAREN, 0), S0);
	p_expect (SY_LPAREN, mystop);
	set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
	ptype = p_var_access(&node, VA_ASSIGN, mystop);
	if (ck_string(ptype))
		size = ptype->ob.array.upper;
	else {
		size = 0;
		errflag++;
	}
	p_expect(SY_RPAREN, stop);
	node = nd_build(SY_COMMA, TW_UNDEF, node, nd_icon(size, TW_INT));
	nd_compile(nd_build(ND_CALL, TW_UNDEF, p_runtime(proc), node));
	return(errflag);
}
