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

extern int opt_s;

int
	symbol,
	p_needfix = 0,
	p_in_typart = 0,
	p_in_decl = 1,
	p_reached,
	p_module = 0,
	p_sawextern = 0
;

/*
 * p_error() outputs an error message whenever the current input
 * symbol is illegal.  For error recovery, it reads input symbols
 * until it finds one in the "stop" set.
 */

p_error(wanted, stop)
	int wanted;
	STOPSET stop;
{
	char *badsymbol, buf[32];

	badsymbol = err_symbol[symbol];
	if (badsymbol[0] == '"' && isalpha(badsymbol[1])) {
		sprintf(buf, "reserved word %s", badsymbol);
		badsymbol = buf;
	}
	if (wanted)
		sprintf(err_text, "syntax error:  expected %s, but got %s",
			err_symbol[wanted], badsymbol);
	else 
		sprintf(err_text, "syntax error:  %s not expected", badsymbol);
		
	err_msg(E_FATAL, E_CURSYMBOL);
	while (!set_in(symbol, stop))
		symbol = sy_get();
}

/*

p_check(stop) -- see macro in stopset.h

*/

/*
 * p_expect() checks that the current input symbol equals the desired
 * symbol and gets the next symbol.
 */

p_expect(wanted, stop)
	int wanted;
	STOPSET stop;
{
	if (symbol == wanted) {
		symbol = sy_get();
		p_check(stop);
	}
	else
		p_error(wanted, stop);
}

/*
 * p_expectident() makes sure the current symbol is an identifier.
 * If so, the scanner has already entered the identifier into the
 * name table and put a pointer to the name table entry in ident_in.
 * p_expectident gets the next input symbol and returns ident_in.
 * For error recovery, it returns id_noname, a dummy name table entry.
 */

IDENT *
p_expectident(stop)
	STOPSET stop;
{
	register IDENT *ret;
	if (symbol == SY_IDENT) {
		ret = ident_in;
		symbol = sy_get();
		p_check(stop);
	}
	else {
		ret = id_noname;
		p_error(SY_IDENT, stop);
	}
	return(ret);
}

/*
 * p_expectlabel() makes sure the current input symbol is a legal
 * statement label.  Strips leading zeros and makes sure the result
 * is not >4 digits.  Makes a name table entry for the label and
 * returns a pointer to it.
 */ 

IDENT *
p_expectlabel(stop)
	STOPSET stop;
{
	register IDENT *ret;
	register char *p;

	if (symbol == SY_DIGSEQ) {
		for (p = word_in; *p == '0'; p++)	/* strip leading zeros */
			;
		if (*p == '\0')		/* label was all zeros */
			p--;
		if (strlen(p) < 5)
			ret = id_get(p, SY_IDENT);
		else {
			sprintf(err_text, "statement label \"%s\" too long", word_in);
			err_msg(E_FATAL, E_CURSYMBOL);
			ret = id_noname;
		}
		symbol = sy_get();
		p_check(stop);
	}
	else {
		ret = id_noname;
		p_error(SY_DIGSEQ, stop);
	}
	return(ret);
}

/*
 * program = program-heading ";" block "." .
 */

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

	/*
	 * a source file may be a complete program or a "module".
	 * a module has not program header and no compound-statement
	 * at the end of the outermost block
	 */
	c_sseg(SG_DATA);
	symbol = sy_get();
	if (symbol != SY_PROGRAM && !opt_s) {  /* module */
		p_module = 1;
		ob_newblock();
		/*
		 * since we have no program heading, assume
		 * "input", "output", and "errfile" are listed.
		 */
		(void) ob_define(id_get("input", SY_IDENT),
			OB_VARIABLE, 0);
		(void) ob_define(id_get("output", SY_IDENT),
			OB_VARIABLE, 0);
		(void) ob_define(id_get("errfile", SY_IDENT),
			OB_VARIABLE, 0);
	}
	else {  /* program */
		c_func(TW_FTN+TW_UNDEF, "main", SC_EXTDEF, 0);
		ob_newblock();
		set_or(mystop, stop, block_begin, set_cons(SY_SEMI, 0), S0);
		p_prog_heading(mystop);
		set_or(mystop, stop, block_begin, S0);
		p_expect(SY_SEMI, mystop);
	}

	/* handle special files in program heading */

	p_ext_files(ob_block[ob_level]);

	/* parse main program block */

	p_block(OB_NULL, stop);
	if (!p_module)
		p_expect(SY_DOT, stop);
	c_end();
}

/*
 * program-heading = "program" identifier [ "(" identifier-list ")" ] .
 */

p_prog_heading(stop)
	register STOPSET stop;
{
	STOPBUF mystop;
	int count;

	set_or(mystop, stop, set_cons(SY_IDENT, SY_LPAREN, SY_RPAREN, 0), S0);
	p_expect(SY_PROGRAM, mystop);
	p_expect(SY_IDENT, mystop);
	if (symbol == SY_LPAREN) {
		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);
		(void) p_ident_list(&count, OB_VARIABLE, 0, mystop);
		p_expect(SY_RPAREN, stop);
	}
	else
		p_check(stop);
}

/*
 * p_ext_files sets the "program parameter" flag on all external files
 * and declares the special files "input", "output", and "errfile" if
 * they are present.
 */

p_ext_files(file)
	register OBJECT *file;
{
	for (; file; file = file->ob_prev) {
		file->ob_flags |= OB_PROGPARM;
		if (!strcmp(file->ob_name, "input"))
			std_input = file;
		else if (!strcmp(file->ob_name, "output"))
			std_output = file;
		else if (!strcmp(file->ob_name, "errfile")) {
			std_error = file;
			if (opt_s) {
				strcpy(err_text, err_nonstd);
				err_msg(E_WARNING, E_PREVSYMBOL);
			}
		}
		else {
			file->ob_type = OB_NULL;
			continue;
		}

		file->ob_flags |= OB_INIT;
		file->ob_type  = std_text;
		file->ob_size  = std_text->ob_size;
		file->ob_tword = std_text->ob_tword;
		c_decl(file->ob_tword, file->ob_name, nd_sclass(file),
			file->ob_size, file->ob_level);
	}
}

/*
 * identifier-list = identifier { "," identifier } .
 */


OBJECT *
p_ident_list(count, kind, flags, stop)
	int *count, kind, flags;
	register STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register IDENT *id;
	register OBJECT *ret;

	/*
	 * parse a list of identifiers.  must put them in the
	 * symbol table immediately to prevent duplicates such
	 * as "a,b,a : integer;"  Returns pointer to symbol
	 * table entry for last identifier (which ob_define has
	 * linked to the previous ones.)
	 */
	(*count) = 0;
	set_or(mystop1, stop, set_cons(SY_COMMA, 0), S0);
	set_or(mystop2, stop, set_cons(SY_IDENT, 0), S0);
	for (;;) {
		id = p_expectident(mystop1);
		ret = ob_define(id, kind, flags);
		(*count)++;
		if (symbol != SY_COMMA)
			break;
		p_expect(SY_COMMA, mystop2);
	}
	p_check(stop);
	return(ret);
}

/*
 * block = [ label-declaration-part ] [ constant-declaration-part ]
 *		[ type-declaration-part ] [ variable-declaration-part ]
 *		{ procedure-declaration | function-declaration }
 *		compound-statement .
 */

p_block(subp, stop)
	OBJECT *subp;
	register STOPSET stop;
{
	STOPBUF mystop;
	TWORD tw;

	if (symbol == SY_LABEL) {  /* label declaration part */
		set_or(mystop, stop, set_cons(SY_CONST, SY_TYPE, SY_VAR, SY_PROC,
			SY_FUNC, SY_BEGIN, 0), S0);
		p_label_part(mystop);
	}
	if (symbol == SY_CONST) {  /* constant declaration part */
		set_or(mystop, stop, set_cons(SY_TYPE, SY_VAR, SY_PROC,
			SY_FUNC, SY_BEGIN, 0), S0);
		p_const_part(mystop);
	}
	if (symbol == SY_TYPE) {   /* type declaration part */
		set_or(mystop, stop, set_cons(SY_VAR, SY_PROC,
			SY_FUNC, SY_BEGIN, 0), S0);
		p_type_part(mystop);
	}
	set_or(mystop, stop, set_cons(SY_PROC, SY_FUNC, SY_BEGIN, 0), S0);
	if (symbol == SY_VAR) {    /* variable declaration part */
		p_var_part(mystop);
	}
	while (symbol == SY_PROC || symbol == SY_FUNC) {
		p_subp_decl(mystop);   /* procedure and function declarations */
	}

	/* make sure we have no "unfinished" forward directives */

	ck_subpdef(ob_block[ob_level]);

	/* quit here if this is a module and this is outermost block */

	if (ob_level == 1 && p_module)
		return;

	/* start emitting code for this function/procedure */

	c_epdef();

	/*
	 * if main program, be sure all files in program heading were 
	 * declared.  Initialize "input", "output", "errfile" if
	 * listed in heading.
	 */

	if (ob_level == 1)
		ck_files(ob_block[ob_level]);

	/* parse the algorithm */

	lb_current = LB_NULL;
	p_reached = 1;
	p_in_decl = 0;
	p_compound_stmt(stop);
	p_in_decl = 1;

	/* emit code to close local files declared in this block */

	if (ob_level == 1 || ck_localfile(ob_block[ob_level]))
		nd_compile(nd_build(ND_CALL, TW_UNDEF,
			nd_runtime("RT_fclose", TW_UNDEF),
			nd_icon(ob_level, TW_INT)));

	/* emit code to return from subprogram */

	tw = TW_UNDEF;
	if (ob_level > 1 && subp->ob_kind == OB_FUNC) {
		subp = subp->ob.subp.retval;
		tw = subp->ob_tword;
		nd_compile(nd_value(subp));
	}
	c_return(tw);
	c_efunc(0);

	/* print warnings about unused variable, etc. */

	ck_used(ob_block[ob_level]);
}


/*
 * label-declaration-part = "label" digit-sequence
 *		{ "," digit-sequence } ";" .
 */

p_label_part(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	IDENT *id;

	set_or(mystop1, stop, set_cons(SY_DIGSEQ, SY_COMMA, SY_SEMI, 0), S0);
	p_expect(SY_LABEL, mystop1);
	set_or(mystop1, stop, set_cons(SY_COMMA, SY_SEMI, 0), S0);
	set_or(mystop2, stop, set_cons(SY_DIGSEQ, SY_SEMI, 0), S0);
	for (;;) {
		id = p_expectlabel(mystop1);
		lb_deflabel(id);
	    if (symbol != SY_COMMA)
			break;
		p_expect(SY_COMMA, mystop2);
	}
	p_expect(SY_SEMI, stop);
}

/*
 * constant-declaration-part = "const" constant-declaration ";"
 *		{ constant-declaration ";" } .
 *
 * constant-declaration = identifier "=" constant .
 */
	
p_const_part(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2, mystop3, mystop4;
	IDENT *id;
	
	set_or(mystop1, stop, set_cons(SY_IDENT, SY_EQUAL, SY_SEMI, 0),
		const_begin, S0);
	p_expect(SY_CONST, mystop1);
	set_or(mystop1, stop, set_cons(SY_EQUAL, SY_SEMI, 0), const_begin, S0);
	set_or(mystop2, stop, set_cons(SY_IDENT, SY_SEMI, 0), const_begin, S0);
	set_or(mystop3, stop, set_cons(SY_IDENT, SY_EQUAL, SY_SEMI, 0), S0);
	set_or(mystop4, stop, set_cons(SY_IDENT, SY_EQUAL, 0), const_begin, S0);
	do {
		id = p_expectident(mystop1);
		p_expect(SY_EQUAL, mystop2);
		(void) p_constant(id, mystop3);
		p_expect(SY_SEMI, mystop4);
	}while(symbol == SY_IDENT);
	p_check(stop);
}

/*
 * type-declaration-part = "type" type-definition ";"
 *		{ type-definition ";" }
 *
 * type-definition = identifier "=" type-denoter
 */

p_type_part(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2, mystop3, mystop4;
	register IDENT *id;
	register OBJECT *p;

	p_in_typart = 1;
	set_or(mystop1, stop, set_cons(SY_IDENT, SY_EQUAL, SY_SEMI, 0),
		type_begin, S0);
	p_expect(SY_TYPE, mystop1);
	set_or(mystop1, stop, set_cons(SY_EQUAL, SY_SEMI, 0), type_begin, S0);
	set_or(mystop2, stop, set_cons(SY_IDENT, SY_SEMI, 0), type_begin, S0);
	set_or(mystop3, stop, set_cons(SY_IDENT, SY_EQUAL, SY_SEMI, 0), S0);
	set_or(mystop4, stop, set_cons(SY_IDENT, SY_EQUAL, 0), type_begin, S0);
	do {
		id = p_expectident(mystop1);
		p_expect (SY_EQUAL, mystop2);
		(void) p_type_denoter(id, mystop3);
		p_expect (SY_SEMI, mystop4);
	} while (symbol == SY_IDENT);
	p_check(stop);

	/*
	 * if we had any pointer types declared before the type
	 * pointed to, we need to do another pass through the
	 * current level of the symbol table to complete the
	 * pointer type definitions.
	 */

	if (p_needfix) {
		for (p = ob_block[ob_level]; p; p = p->ob_prev)
			p_fixtype(p);
		p_needfix = 0;
	}
	p_in_typart = 0;
}

/*
 * variable-declaration-part = "var" variable-declaration ";"
 *		{ variable-declaration ";" } .
 *
 * variable-declaration = identifier-list ":" type-denoter .
 */

p_var_part(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2, mystop3;
	register OBJECT *ob, *type;
	int count;

	set_or(mystop1, stop, set_cons(SY_IDENT, SY_COLON, SY_SEMI, 0),
		type_begin, S0);
	p_expect(SY_VAR, mystop1);
	set_or(mystop1, stop, set_cons(SY_COLON, SY_SEMI, 0), type_begin, S0);
	set_or(mystop2, stop, set_cons(SY_IDENT, SY_SEMI, 0), type_begin, S0);
	set_or(mystop3, stop, set_cons(SY_COLON, SY_IDENT, SY_SEMI, 0), S0);
	do {
		ob = p_ident_list(&count, OB_VARIABLE, 0, mystop1);
		p_expect(SY_COLON, mystop2);
		type = p_type_denoter(ID_NULL, mystop2);
		while(count--) {
			if (ob->ob_flags & OB_PROGPARM && type->ob_kind != OB_FILE) {
				sprintf(err_text,
					"type of program parameter \"%s\" is not a file",
					ob->ob_name);
				err_msg(E_FATAL, E_PREVSYMBOL);
			}
			ob->ob_type = type;
			ob->ob_tword = type->ob_tword;
			ob->ob_size = type->ob_size;
			c_decl(ob->ob_tword, ob->ob_name, nd_sclass(ob),
				ob->ob_size, ob->ob_level);
			ob = ob->ob_prev;
		}
		p_expect(SY_SEMI, mystop3);
	} while (symbol == SY_IDENT);
	p_check(stop);
}


/*
 * procedure-declaration = procedure-heading ";" ( block | directive ) ";" .
 *
 * function-declaration = function-heading ";" ( block | directive ) ";" .
 */

p_subp_decl(stop)
	STOPSET stop;
{
	STOPBUF mystop;
	IDENT *id;
	OBJECT *subp, *dir, *parm, *type;

	set_or(mystop, stop, block_begin, set_cons(SY_SEMI, SY_IDENT, 0), S0);
	subp = p_subp_heading(0, mystop);
	p_expect(SY_SEMI, mystop);
	set_or(mystop, stop, set_cons(SY_SEMI, 0), S0);

	if ((subp->ob_flags & (OB_FORWARD|OB_EXTERNAL)) ||
		set_in(symbol, block_begin))
	{
		subp->ob_flags &= ~(OB_FORWARD|OB_EXTERNAL);
		c_func(subp->ob_tword, subp->ob_name, nd_sclass(subp),
			subp->ob_level);

		/* declare subprogram parameters */

		for (parm = subp->ob.subp.parameter; parm; parm = parm->ob_prev) {
			if (parm->ob_kind & (OB_VALPARM|OB_VARPARM| 
				OB_PROC|OB_FUNC|OB_BOUNDID))
			{
				c_decl(parm->ob_tword, parm->ob_name, nd_sclass(parm),
					parm->ob_size, parm->ob_level);
			}
		}

		/* get temporary variable for function return value */

		if (subp->ob_kind == OB_FUNC) {
			type = subp->ob_type;
			subp->ob.subp.retval = ob_tmpvar(type->ob_tword,
				type->ob_size, OB_VARIABLE);
			subp->ob.subp.retval->ob_type = type;
		}

		p_block(subp, mystop);

		if (subp->ob_kind == OB_FUNC && !(subp->ob_flags & OB_INIT)) {
			sprintf(err_text,
				"function \"%s\" was never assigned a return value",
				subp->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
		}
	}
	else if (symbol == SY_IDENT) {  /* "forward" or "external" */
		id = p_expectident(mystop);
		if ((dir = ob_searchall(id)) && dir->ob_kind == OB_DIRECTIVE) {
			if (dir == std_forward)
				subp->ob_flags |= OB_FORWARD;
			else if (ob_level == 2) {
				if (opt_s) {
					strcpy(err_text, err_nonstd);
					err_msg(E_WARNING, E_PREVSYMBOL);
				}
				subp->ob_flags |= OB_EXTERNAL;
				p_sawextern = 1;
			}
			else {
				strcpy(err_text,
					"illegally placed \"external\" directive");
				err_msg(E_FATAL, E_PREVSYMBOL);
			}
		}
		else {
			strcpy(err_text, "expected \"forward\" or \"external\"");
			err_msg(E_FATAL, E_PREVSYMBOL);
		}
	}
	else {
		p_error(0, mystop);
	}
	p_expect(SY_SEMI, stop);
	ob_endblock();
}

/*
 * function-heading = "function" identifier [ [ formal-parameter-list ]
 *		":" identifier ] .
 *
 * procedure-heading = "procedure" identifier [ formal-parameter-list ] .
 */

OBJECT *
p_subp_heading(flags, stop)
	int flags;
	STOPSET stop;
{
	int kind;
	STOPBUF mystop;
	IDENT *id;
	register OBJECT *subp, *type;

	if (symbol == SY_FUNC) {
		kind = OB_FUNC;
		set_or(mystop, stop, set_cons(SY_IDENT, SY_LPAREN, SY_COLON, 0), S0);
	}
	else {
		kind = OB_PROC;
		set_or(mystop, stop, set_cons(SY_IDENT, SY_LPAREN, 0), S0);
	}
	p_expect(symbol, mystop);
	id = p_expectident(mystop);
	subp = ob_define(id, kind, flags);
	ob_newblock();

	/*
	 * if subprogram had previous "forward" definition, we've already
	 * parsed the formal paramter list.  Link list back into symbol
	 * table and return.
	 */
	if (subp->ob_flags & (OB_FORWARD|OB_EXTERNAL)) {
		ob_block[ob_level] = subp->ob.subp.parameter;
		p_check(stop);
		return(subp);
	}
	if (kind == OB_FUNC) {
		set_or(mystop, stop, set_cons(SY_COLON, SY_IDENT, 0), S0);
		subp->ob.subp.parameter =
			(symbol == SY_LPAREN) ? p_fp_list(mystop) : OB_NULL;
		set_or(mystop, stop, set_cons(SY_IDENT, 0), S0);
		p_expect(SY_COLON, mystop);

		/*
		 * when parsing the function return type, we must temporarily
		 * go up a level in scope to handle the following _legal_
		 * code correctly.
		 * function x (gotcha : integer) : gotcha;
		 */
		ob_endblock();
		type = p_type_ident(ID_NULL, stop);
		if (!OB_ISSIMPLE(type->ob_kind)) {
			sprintf(err_text, "\"%s\" is not a valid function return type",
				type->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			type = std_universal;
		}
		subp->ob_type = type;
		subp->ob_tword = TW_INCREF(type->ob_tword) + TW_FTN - TW_PTR;

		/* now restore old scope level */

		ob_newblock();
		ob_block[ob_level] = subp->ob.subp.parameter;
	}
	else {  /* procedure declaration */
		subp->ob.subp.parameter =
			(symbol == SY_LPAREN) ? p_fp_list(stop) : OB_NULL;
		subp->ob_type = OB_NULL;
		subp->ob_tword = TW_FTN + TW_UNDEF;
	}
	subp->ob.subp.standard = 0;
	subp->ob_size = SZ_PTR;
	if (flags & OB_PARMSUBP) {	/* a parameter subprogram */
		subp->ob_tword = TW_PTR+TW_STRTY;
		ob_endblock();
	}
	p_check(stop);
	return(subp);
}


/*
 * formal-parameter-list = "(" formal-parameter-section
 *		{ ";" formal-parameter-section } ")" .
 */

OBJECT *
p_fp_list(stop)
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *reverse, *next, *parm;
	int section=1;

	set_or(mystop1, stop, set_cons(SY_IDENT, SY_VAR, SY_PROC, SY_FUNC,
		SY_SEMI, SY_RPAREN, 0), S0);
	p_expect(SY_LPAREN, mystop1);
	set_or(mystop1, stop, set_cons(SY_SEMI, SY_RPAREN, 0), S0);
	set_or(mystop2, stop, set_cons(SY_IDENT, SY_VAR, SY_PROC, SY_FUNC,
		SY_RPAREN, 0), S0);
	for (;;) {
		p_fp_section(section++, mystop1);
	    if (symbol != SY_SEMI)
			break;
		p_expect(SY_SEMI, mystop2);
	}
	p_expect(SY_RPAREN, stop);

	/*
	 * The formal parameters are now in the symbol table in the
	 * reverse order of appearance in the source text.  Reverse
	 * them back to make processing actual parameters easier.
	 * Also neutralize any OB_KEEPOFFs in the list.
	 */

	reverse = OB_NULL;
	for (parm = ob_block[ob_level]; parm; parm = next) {
		next = parm->ob_prev;
		if (parm->ob_kind == OB_KEEPOFF)
			parm->ob_name = "";
		parm->ob_prev = reverse;
		reverse = parm;
	}
	return(ob_block[ob_level] = reverse);
}

/*
 * formal-parameter-section = procedure-heading | function-heading |
 *		ordinary-parameter-specification .
 */

p_fp_section(section, stop)
	int section;
	STOPSET stop;
{
	if (symbol == SY_PROC || symbol == SY_FUNC)
		(void) p_subp_heading(OB_PARMSUBP, stop);
	else 
		p_ordinary_parm_spec(section, stop);
}

/*
 * ordinary-parameter-specification = [ "var" ] identifier-list ":"
 *		( type-identifer | unpacked-conformant-array-schema |
 *		packed-conformant-array-schema ) .
 */

p_ordinary_parm_spec(section, stop)
	int section;
	STOPSET stop;
{
	STOPBUF mystop;
	int count, kind;
	register OBJECT *ob, *type;

	set_or(mystop, stop, set_cons(SY_COLON, SY_IDENT, SY_PACKED,
		SY_ARRAY, 0), S0);
	kind = OB_VALPARM;
	if (symbol == SY_VAR) {
		p_expect(SY_VAR, mystop);
		kind = OB_VARPARM;
	}
	ob = p_ident_list(&count, kind, 0, mystop);
	set_or(mystop, stop, set_cons(SY_IDENT, SY_PACKED, SY_ARRAY, 0), S0);
	p_expect(SY_COLON, mystop);
	switch(symbol) {
	case SY_IDENT:
		type = p_type_ident(ID_NULL, stop);
		break;
	case SY_PACKED:
		type = p_p_conf_array_schema(stop);
		break;
	case SY_ARRAY:
		type = p_u_conf_array_schema(stop);
		break;
	default:
		type = std_universal;
		p_error(0, stop);
	}
	while (count--) {
		ob->ob_type = type;
		if (kind == OB_VARPARM || type->ob_kind == OB_CONFARRAY) {
			ob->ob_tword = TW_INCREF(type->ob_tword);
			ob->ob_size = SZ_PTR;
		}
		else {
			ob->ob_size = type->ob_size;
			ob->ob_tword = type->ob_tword;
		}
		ob->ob.parameter.section = section;	/* for parameter congruity test */
		ob = ob->ob_prev;
	}
	if (kind == OB_VALPARM && ck_hasfile(type)) {
		strcpy(err_text, "value parameter has file type");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
}

/*
 * p_fixtype() fixes incomplete entries in the symbol table arising when
 * "type foo = ^bar" is encountered and "bar" is not defined at the
 * current scope level.  p_fixtype goes ahead and fixes everything
 * since it's no easier to pick out only those entries that need it.
 */

p_fixtype(ob)
	register OBJECT *ob;
{
	register OBJECT *type;

	if (ob->ob_flags & OB_SEEN)	{
		return;
	}
	ob->ob_flags |= OB_SEEN;
	switch(ob->ob_kind) {
	case OB_FIELD:
		p_fixtype(type = ob->ob_type);
		ob->ob_tword = type->ob_tword;
		break;
	case OB_RECORD:
		for (type = ob->ob.record.field; type; type = type->ob_prev)
			p_fixtype(type);
		ob->ob_tword = TW_STRTY;
		break;
	case OB_ARRAY:
		p_fixtype(type = ob->ob_type);
		ob->ob_tword = TW_INCREF(type->ob_tword) - TW_PTR + TW_ARY;
		break;
	case OB_POINTER:
		if (!(type = ob->ob_type))
			type = ob->ob_type = p_get_type(ob->ob.pointer.ident, 0);
		p_fixtype(type);
		ob->ob_tword = TW_INCREF(type->ob_tword);
		break;
	case OB_FILE:
		p_fixtype(ob->ob_type);
		ob->ob_tword = TW_STRTY;
		break;
	}
	ob->ob_flags &= ~OB_SEEN;
}
