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

/*
 * type_identifier = identifier .
 */

OBJECT *
p_get_type(typid, flag)
	IDENT *typid;
	int flag;
{
	/*
	 * Look up a type identifier.  Be sure that it is in the
	 * symbol table, and that the identifier is indeed a type.
	 * If the type is another name for a previously defined
	 * type, then return the symbol table entry for the other
	 * type.  (Required by Pascal type equivalence rules.)
	 * If the type is in the symbol table, but still being
	 * defined we have a recursive type name reference.
	 * This is illegal except when the type being defined
	 * is a pointer type (flag == OB_POINTER).
	 */
	register OBJECT *type;
	if (type = ob_searchall(typid)) {
		if (flag != OB_POINTER && (type->ob_flags & OB_UNDEFINED)) {
			sprintf(err_text, err_recurse, err_kind(type->ob_kind),
				type->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			type = std_universal;
		}
		if (OB_ISATYPE(type->ob_kind)) {
			ob_keepoff(type);	/* prevent redefinition of type id */
			type->ob_flags |= OB_USED;
			if (type->ob_kind == OB_TYPE)	/* type alias */
				type = type->ob_type;
		}
		else {
			sprintf(err_text, "\"%s\" is not a type", type->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			type = std_universal;
		}
	}
	else {
		if (typid != id_noname) {
			sprintf(err_text, err_undef, "identifier", typid->id_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
		}
		type = std_universal;
	}
	return(type);
}

OBJECT *
p_type_ident(id, stop)
	IDENT *id;
	STOPSET stop;
{
	/*
	 * look up a type identifier.  If "id" is non-null, then we
	 * are in a type-declaration-part, defining another name for
	 * the type, eg, "type T2 = T1;"
	 */
	IDENT *typid;
	register OBJECT *type, *newty;
	if (id)
		newty = ob_define(id, OB_TYPE, OB_UNDEFINED);
	typid = p_expectident(stop);
	type = p_get_type(typid, 0);
	if (id) {
		newty->ob_flags &= ~OB_UNDEFINED;
		newty->ob_type = type;
	}
	return(type);
}

/*
 * type-denoter = type-identifier | enumerated-type | subrange-type |
 *		pointer-type | ["packed" ] ( array-type | file-type |
 *		record-type | set-type ) .
 */

OBJECT *
p_type_denoter(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *type;
	int flags = 0;

	/*
	 * determine which species of type declaration we are parsing
	 * and call appropriate parsing function.
	 */
	switch(symbol) {
	case SY_IDENT:
		if ((type = ob_searchall(ident_in)) &&
			type->ob_kind == OB_CONST)
		{
			return(p_subr_type(id, stop));   /* subrange */
		}
		return(p_type_ident(id, stop));  /* type identifier */

	case SY_LPAREN:
		return(p_enum_type(id, stop));   /* enumerated type */

	case SY_UPARROW:
		return(p_ptr_type(id, stop));    /* pointer type */

	default:
		if (set_in(symbol, const_begin))
			return(p_subr_type(id, stop));  /* subrange type */
	}

	if (symbol == SY_PACKED) {
		set_or(mystop, stop, set_cons(SY_ARRAY, SY_FILE, SY_RECORD, SY_SET,
			0), S0);
		p_expect(SY_PACKED, mystop);
		flags = OB_PACKED;
	}

	switch(symbol) {

	case SY_ARRAY:
		type = p_array_type(id, stop, flags);   /* array type */
		break;

	case SY_FILE:
		type = p_file_type(id, stop);    /* file type */
		break;

	case SY_RECORD:
		type = p_record_type(id, stop);  /* record type */
		break;

	case SY_SET:
		type = p_set_type(id, stop);     /* set type */
		break;

	default:
		p_error(0, stop);
		if (id) {
			type = ob_define(id, OB_TYPE, 0);
			type->ob_type = std_universal;
		}
		return(std_universal);
	}

	type->ob_flags |= flags;
	return(type);
}

/*
 * ordinal-type = type-identifier | subrange-type | enumerated-type .
 */

OBJECT *
p_ordinal_type(stop)
	STOPSET stop;
{
	register OBJECT *type;
	switch (symbol) {

	/*
	 * this function is called whenever an ordinal type is
	 * specifically required.
	 */
	case SY_IDENT:
		if ((type = ob_searchall(ident_in)) &&
			type->ob_kind == OB_CONST)
		{
			return(p_subr_type(ID_NULL, stop));
		}
		type = p_type_ident(ID_NULL, stop);
		if (!OB_ISORDINAL(type)) {
			sprintf(err_text, err_ordq, type->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			type = std_universal;
		}
		return(type);

	case SY_LPAREN:
		return (p_enum_type(ID_NULL, stop));

	default:
		if (set_in(symbol, const_begin))
			return (p_subr_type(ID_NULL, stop));
	}
	p_error(0, stop);
	return(std_universal);
}

/*
 * subrange-type = constant ".." constant .
 */

OBJECT *
p_subr_type(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *sub, *low, *high;
	int errflag=0;

	/*
	 * parse the upper and lower constants, see if they are the
	 * same type, not real or string, and lower <= upper
	 */
	sub = ob_define(id, OB_SUBRANGE, OB_UNDEFINED);
	set_or(mystop, stop, const_begin, set_cons(SY_DOTDOT, 0), S0);
	low = p_constant(ID_NULL, mystop);
	set_or(mystop, stop, const_begin, S0);
	p_expect(SY_DOTDOT, mystop);
	high = p_constant(ID_NULL, stop);
	if (low->ob_type == std_universal ||
		high->ob_type == std_universal)
	{
		errflag++;
	}
	else if (!OB_ISORDINAL(low->ob_type) || !OB_ISORDINAL(high->ob_type))
	{
		sprintf(err_text, err_ord, "subrange parent type");
		err_msg(E_FATAL, E_PREVSYMBOL);
		errflag++;
	}
	else if (low->ob_type != high->ob_type) {
		strcpy(err_text,
			"subrange lower and upper bounds are different types");
		err_msg(E_FATAL, E_PREVSYMBOL);
		errflag++;
	}
	else if (low->ob.const.val.i > high->ob.const.val.i) {
		strcpy(err_text,
			"subrange lower bound greater than upper bound");
		err_msg(E_FATAL, E_PREVSYMBOL);
		errflag++;
	}
	if (errflag) {
		sub->ob_kind = OB_TYPE;
		sub->ob_type = std_universal;	/* alias it to universal */
	}
	else {
		sub->ob_type = low->ob_type;
		sub->ob_tword = low->ob_tword;
		sub->ob_size = low->ob_size;
		sub->ob.subrange.min  = low ->ob.const.val.i;
		sub->ob.subrange.max  = high->ob.const.val.i;
	}
	sub->ob_flags &= ~OB_UNDEFINED;
	return(sub);
}

/*
 * enumerated-type = "(" identifier-list ")"
 */

OBJECT *
p_enum_type(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *const, *enu;
	int count;

	/*
	 * parse list of identifiers and define them all as constants
	 * of the parent enumeration type.  Set the values of the
	 * constants.
	 */
	enu = ob_define(id, OB_ENUMER, 0);
	enu->ob.subrange.min = 0;
	enu->ob.subrange.max = 0;
	enu->ob_tword = TW_INT;
	enu->ob_size = SZ_INT;
	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);
	const = p_ident_list(&count, OB_CONST, 0, mystop);
	enu->ob.subrange.max = count-1;
	while (count--) {
		const->ob_type = enu;
		const->ob_size = SZ_INT;
		const->ob_tword = TW_INT;
		const->ob.const.val.i = count;
		const = const->ob_prev;
	}
	p_expect(SY_RPAREN, stop);
	return(enu);
}

/*
 * pointer-type = "^" type-identifier .
 */

OBJECT *
p_ptr_type(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *ptr, *type;
	IDENT *typid;
	register TWORD tw;
	extern int p_in_typart, p_needfix;

	/*
	 * define a pointer type.  It is possible that the type pointed
	 * to is thusfar undefined.  In this case we save the name
	 * table entry of the type pointed to and fix up this definition
	 * at the end of the type-definition-part.
	 */
	ptr = ob_define(id, OB_POINTER, OB_UNDEFINED);
	set_or(mystop, stop, set_cons(SY_IDENT, 0), S0);
	p_expect(SY_UPARROW, mystop);
	typid = p_expectident(stop);
	/*
	 * We can immediately look up the type pointed to if any of these
	 * are true: (1) we are not in a type-definition-part, (2) we are
	 * defining record fields, (3) the name we want to look up is
	 * bound at the current level.  Otherwise we must defer the lookup
	 * to the end of the type-definition-part.
	 */
	if (!p_in_typart || ob_reclevel > ob_level ||
		ob_search(typid, ob_level)) 
	{
		type = p_get_type(typid, OB_POINTER);
		if (type->ob_flags & OB_UNDEFINED)  /* ptype = ^ptype */
			p_needfix = 1;
	}
	else {
		type = OB_NULL;
		ptr->ob.pointer.ident = typid;
		p_needfix = 1;
	}
	ptr->ob_type = type;
	tw = type ? type->ob_tword : TW_UNDEF;
	ptr->ob_tword = TW_INCREF(tw);
	ptr->ob_size = SZ_PTR;
	ptr->ob_flags &= ~OB_UNDEFINED;
	return(ptr);
}


/*
 * constant = [ "+" | "-" ] ( digit-sequence | unsigned-real | identifier )
 *		 | character-string
 */

OBJECT *
p_constant(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	IDENT *constid;
	register OBJECT *ob, *const, *type;
	int sign=0, conv=1;
	double atof();
	extern int p_in_decl;

	/* look for leading "+" or "-" */

	set_or(mystop, stop, set_cons(SY_DIGSEQ, SY_REAL, SY_IDENT, SY_STRING,
		0), S0);
	if (symbol == SY_PLUS || symbol == SY_MINUS) {
		if ((sign = symbol) == SY_MINUS)
			conv = -1;
		p_expect(symbol, mystop);
	}
	
	/*
	 * Never return a symbol table entry -- always return a new
	 * OBJECT.  When parsing a case statement or a variant record
	 * we link the case constants into a list that is separate
	 * from the symbol table.
	 */
	ob = ob_define(id, OB_CONST, OB_UNDEFINED);
	ob->ob_type = std_universal;
	ob->ob.const.val.i = 0;

	switch(symbol) {

	case SY_DIGSEQ:
		ob->ob_type = std_integer;
		ob->ob.const.val.i = atoi(word_in);
		p_expect(SY_DIGSEQ, stop);
		break;

	case SY_REAL:
		ob->ob_type = std_real;
		ob->ob.const.val.r = atof(word_in);
		p_expect(SY_REAL, stop);
		break;

	case SY_IDENT:
		/*
		 * be sure the identifier is in the symbol table, that
		 * it is a constant, and that this is not a recursive
		 * reference "const a=a;"
		 */
		constid = p_expectident(stop);
		if ((const = ob_searchall(constid)) == OB_NULL) {
			if (constid != id_noname) {
				sprintf(err_text, err_undef,
					"identifier", constid->id_name);
				err_msg(E_FATAL, E_PREVSYMBOL);
			}
			break;
		}
		if (const->ob_kind != OB_CONST) {
			sprintf(err_text, "\"%s\" is not a constant", const->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			break;
		}
		if (const->ob_flags & OB_UNDEFINED) {
			sprintf(err_text, err_recurse, "constant", const->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			break;
		}
		ob->ob_type = const->ob_type;
		ob->ob.const.val = const->ob.const.val;
		if (p_in_decl)
			ob_keepoff(const);	/* prevents redefinition of constant id */
		const->ob_flags |= OB_USED;
		if (const->ob_type->ob_kind == OB_ENUMER)
			const->ob_type->ob_flags |= OB_USED;
		break;

	case SY_STRING:
		if (word_in[1] == '\0') {	/* a single-character constant */
			ob->ob_type = std_char;
			ob->ob.const.val.i = *word_in & 0xff;
					/* don't want any sign bit extension here */
		}
		else {
			type = ob->ob_type = ob_alloc();
			*type = *std_string;
			type->ob.array.upper = strlen(word_in);
			type->ob_size = SZ_CHAR * type->ob.array.upper;
			ob->ob.const.val.i = p_str_label(word_in);
		}
		p_expect(SY_STRING, stop);
		break;

	default:
		p_error(0, stop);
		break;
	}

	/* if we had a leading "-", apply it now */

	type = ob->ob_type;
	if (type == std_integer)
		ob->ob.const.val.i *= conv;
	else if (type == std_real)
		ob->ob.const.val.r *= conv;
	else if (sign) {
		sprintf(err_text, err_unop, err_symbol[sign]);
		err_msg(E_FATAL, E_PREVSYMBOL);
	}

	ob->ob_size = type->ob_size;
	ob->ob_tword = type->ob_tword;
	ob->ob_flags &= ~OB_UNDEFINED;
	return(ob);
}

/*
 * p_str_label() generates code to store a string in the data segment
 * and returns a label to the string.
 */

int
p_str_label(s)
	register char *s;
{
	register int label;
	c_sseg(SG_STRNG);
	c_label(label = lb_new());
	c_string(s);
	c_sseg(SG_PROG);
	return(label);
}

/*
 * p_array_size figures out the size of the array and constructs the
 * encoded type word.  We must work our way back from the basetype,
 * hence the recursion.
 */

p_array_size(start, stop)
	register OBJECT *start, *stop;
{
	register OBJECT *btype;
	register TWORD tw;
	if (start != stop)
		p_array_size(start->ob_type, stop);
	btype = start->ob_type;
	start->ob_size = (start->ob_kind == OB_CONFARRAY) ? 0 :
		(start->ob.array.upper - start->ob.array.lower + 1) *
		btype->ob_size;
	tw = btype->ob_tword;
	start->ob_tword = TW_INCREF(tw) - TW_PTR + TW_ARY;
}

/*
 * array-type = "array" "[" ordinal-type { "," ordinal-type } "]" "of"
 *		type-denoter .
 */

OBJECT *
p_array_type(id, stop, flags)
	IDENT *id;
	register STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *array, *ret, *index;

	ret = array = ob_define(id, OB_ARRAY, flags|OB_UNDEFINED);
	set_or(mystop1, stop, type_begin, set_cons(SY_LBRAC, SY_COMMA,
		SY_RBRAC, SY_OF, 0), S0);
	p_expect(SY_ARRAY, mystop1);
	set_or(mystop1, stop, type_begin, set_cons(SY_COMMA, SY_RBRAC,
		SY_OF, 0), S0);
	p_expect(SY_LBRAC, mystop1);
	set_or(mystop2, stop, type_begin, set_cons(SY_RBRAC, SY_OF, 0), S0);
	/*
	 * a multi-dimensional array appears in the symbol table
	 * as an "array of arrays".  The base type of the array
	 * (ob_type) points to another array OBJECT.
	 */
	for (;;) {
		index = array->ob.array.indextype = p_ordinal_type(mystop1);
		array->ob.array.lower = index->ob.subrange.min;
		array->ob.array.upper = index->ob.subrange.max;
		if (symbol != SY_COMMA)
			break;
		p_expect(SY_COMMA, mystop2);
		array = array->ob_type = ob_define(ID_NULL, OB_ARRAY, flags);
	}
	set_or(mystop1, stop, type_begin, set_cons(SY_OF, 0), S0);
	p_expect(SY_RBRAC, mystop1);
	set_or(mystop1, stop, type_begin, S0);
	p_expect(SY_OF, mystop1);
	array->ob_type = p_type_denoter(ID_NULL, stop);
	p_array_size(ret, array);
	ret->ob_flags &= ~OB_UNDEFINED;
	return(ret);
}

/*
 * packed-conformant-array-schema = "packed" array "["
 *		index-type-specification "]" "of" type-identifier .
 */

OBJECT *
p_p_conf_array_schema(stop)
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *array;

	set_or(mystop, stop, set_cons(SY_ARRAY, SY_LBRAC, SY_IDENT, SY_RBRAC,
		SY_OF, 0), S0);
	p_expect(SY_PACKED, mystop);
	set_or(mystop, stop, set_cons(SY_LBRAC, SY_IDENT, SY_RBRAC, SY_OF,
		0), S0);
	p_expect(SY_ARRAY, mystop);
	array = ob_define(ID_NULL, OB_CONFARRAY, OB_PACKED);
	set_or(mystop, stop, set_cons(SY_IDENT, SY_RBRAC, SY_OF, 0), S0);
	p_expect(SY_LBRAC, mystop);
	p_index_type_spec(array, mystop);
	set_or(mystop, stop, set_cons(SY_IDENT, SY_OF, 0), S0);
	p_expect(SY_RBRAC, mystop);
	set_or(mystop, stop, set_cons(SY_IDENT, 0), S0);
	p_expect(SY_OF, mystop);
	array->ob_type = p_type_ident(ID_NULL, stop);
	array->ob_tword = TW_INCREF(array->ob_type->ob_tword) - TW_PTR + TW_ARY;
	array->ob_size = 0;
	return(array);
}

/*
 * unpacked-conformant-array-schema = "array" "[" index-type-specification
 *		{ ";" index-type-specification } "]" "of"
 *		( type-identifier | unpacked-conformant-array-schema |
 *		packed-conformant-array-schema ) .
 */

OBJECT *
p_u_conf_array_schema(stop)
	register STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	register OBJECT *ret, *array;

	set_or(mystop1, stop, set_cons(SY_LBRAC, SY_IDENT, SY_SEMI, SY_RBRAC,
		SY_OF, SY_PACKED, SY_ARRAY, 0), S0);
	p_expect(SY_ARRAY, mystop1);
	ret = array = ob_define(ID_NULL, OB_CONFARRAY, 0);
	set_or(mystop1, stop, set_cons(SY_IDENT, SY_SEMI, SY_RBRAC, SY_OF,
		SY_PACKED, SY_ARRAY, 0), S0);
	p_expect(SY_LBRAC, mystop1);
	set_or(mystop2, stop, set_cons(SY_IDENT, SY_RBRAC, SY_OF, SY_PACKED,
		SY_ARRAY, 0), S0);
	for (;;) {
		p_index_type_spec(array, mystop1);
		if (symbol != SY_SEMI)
			break;
		p_expect(SY_SEMI, mystop2);
		array = array->ob_type = ob_define(ID_NULL, OB_CONFARRAY, 0);
	}
	set_or(mystop1, stop, set_cons(SY_IDENT, SY_OF, SY_PACKED,
		SY_ARRAY, 0), S0);
	p_expect(SY_RBRAC, mystop1);
	set_or(mystop1, stop, set_cons(SY_IDENT, SY_PACKED,
		SY_ARRAY, 0), S0);
	p_expect(SY_OF, mystop1);
	switch (symbol) {
	case SY_ARRAY:
		array->ob_type = p_u_conf_array_schema(stop);
		break;
	case SY_PACKED:
		array->ob_type = p_p_conf_array_schema(stop);
		break;
	default:
		array->ob_type = p_type_ident(ID_NULL, stop);
	}
	p_array_size(ret, array);
	return(ret);
}

/*
 * index-type-specification = identifier ".." identifier ":" type-identifier .
 */

p_index_type_spec(array, stop)
	register OBJECT *array;
	STOPSET stop;
{
	STOPBUF mystop;
	IDENT *id;
	register OBJECT *type, *lower, *upper;

	set_or(mystop, stop, set_cons(SY_IDENT, SY_DOTDOT, SY_COLON, 0), S0);
	id = p_expectident(mystop);
	lower = ob_define(id, OB_BOUNDID, 0);
	set_or(mystop, stop, set_cons(SY_IDENT, SY_COLON, 0), S0);
	p_expect(SY_DOTDOT, mystop);
	id = p_expectident(mystop);
	upper = ob_define(id, OB_BOUNDID, 0);
	set_or(mystop, stop, set_cons(SY_IDENT, 0), S0);
	p_expect(SY_COLON, mystop);
	type = p_type_ident(ID_NULL, stop);
	if (!OB_ISORDINAL(type)) {
		sprintf(err_text, err_ordq, type->ob_name);
		err_msg(E_FATAL, E_PREVSYMBOL);
		type = std_universal;
	}
	lower->ob_type = upper->ob_type = type;
	lower->ob_size = upper->ob_size = type->ob_size;
	lower->ob_tword = upper->ob_tword = type->ob_tword;
	array->ob.confarray.lower = lower;
	array->ob.confarray.upper = upper;
	array->ob.confarray.indextype = type;
	array->ob.confarray.size = ob_tmpvar(TW_INT, SZ_INT, OB_BOUNDID);
}

/*
 * file-type = "file" "of" type-denoter .
 */

OBJECT *
p_file_type(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *file, *type;

	/*
	 * a file variable is a struct defined in the run time system
	 * immediately followed by enough memory for
	 * the file buffer-variable.  The parser merely reserves
	 * space for a file variable; the run time system does all the I/O.
	 */
	file = ob_define(id, OB_FILE, OB_UNDEFINED);
	set_or(mystop, stop, type_begin, set_cons(SY_OF, 0), S0);
	p_expect(SY_FILE, mystop);
	set_or(mystop, stop, type_begin, S0);
	p_expect(SY_OF, mystop);
	type = p_type_denoter(ID_NULL, stop);

	/* cannot have a file of files */

	if (ck_hasfile(type)) {
		strcpy(err_text, "file type cannot contain another file type");
		err_msg(E_FATAL, E_PREVSYMBOL);
		type = std_universal;
	}
	file->ob_type = type;
	file->ob_size = ALIGN(sizeof(FILEAREA) + type->ob_size, AL_ANY);
	file->ob_tword = TW_STRTY;
	file->ob_flags &= ~OB_UNDEFINED;
	return(file);
}


/*
 * record-type = "record" field-list "end" .
 */

OBJECT *
p_record_type(id, stop)
	IDENT *id;
	STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *rec;
	int size;

	/*
	 * when defining record fields we drop down into a new
	 * scope level.
	 */
	rec = ob_define(id, OB_RECORD, OB_UNDEFINED);
	set_or(mystop, stop, set_cons(SY_IDENT, SY_CASE, SY_END, 0), S0);
	p_expect(SY_RECORD, mystop);
	set_or(mystop, stop, set_cons(SY_END, 0), S0);
	ob_newrecblock();
	size = p_field_list(0, OB_NULL, OB_NULL, mystop);
	if (!size)		/* empty record */
		size = SZ_INT;
	rec->ob.record.field = ob_block[ob_reclevel];
	rec->ob_size = ALIGN(size, AL_ANY);
	ob_endrecblock();
	p_expect(SY_END, stop);
	rec->ob_tword = TW_STRTY;
	rec->ob_flags &= ~OB_UNDEFINED;
	return(rec);
}

/*
 * field-list = [ ( fixed-part [ ";" variant-part ] | variant-part )
 *		[ ";" ] ]
 *
 * fixed-part = record-section { ";" record-section } .
 */

int
p_field_list(offset, tag, tagval, stop)
	register int offset;
	OBJECT *tag, *tagval;
	STOPSET stop;
{
	STOPBUF mystop1, mystop2;
	if (symbol == SY_IDENT) {
		set_or(mystop1, stop, set_cons(SY_SEMI, SY_CASE, 0), S0);
		set_or(mystop2, stop, set_cons(SY_CASE, SY_IDENT, 0), S0);
		while (symbol == SY_IDENT) {
			offset = p_record_section(offset, tag, tagval, mystop1);
			if (symbol == SY_SEMI) {
				p_expect(SY_SEMI, mystop2);
				if (symbol == SY_CASE) {
					offset = p_variant_part(offset, tag, tagval, stop);
					break;
				}
			}
			else
				break;
		}
	}
	else if (symbol == SY_CASE) {
		offset = p_variant_part(offset, tag, tagval, stop);
	}
	else if (tag) {

		/* null variant -- need a dummy field for error checking */

		OBJECT *dummy;
		dummy = ob_define(id_noname, OB_FIELD, 0);
		dummy->ob.field.tag = tag;
		dummy->ob.field.tagval = tagval;
	}
	p_check(stop);
	return(offset);
}

/*
 * variant-part = "case" variant-selector "of" variant { ";" variant } .
 *
 * variant-selector = [ identifier ":" ] type-identifier .
 */

int
p_variant_part(voffset, tag, tagval, stop)
	register int voffset;
	OBJECT *tag, *tagval;
	register STOPSET stop;
{
	/*
	 * when dealing with fields in a record variant, we need to 
	 * associate with each field a pointer to the controlling tag
	 * field and a pointer to a linked list of legal values
	 * that the tag field must have for this field to be active.
	 * For a free type union, a dummy tag field is put in the
	 * symbol table.
	 */
	STOPBUF mystop1, mystop2;
	IDENT *id;
	register OBJECT *newtag = OB_NULL, *tagtype;
	int count=0;
	register int offset, maxoffset;

	set_or(mystop1, stop, const_begin, set_cons(SY_OF, SY_SEMI,
		SY_COLON, 0), S0);
	p_expect(SY_CASE, mystop1);
	id = p_expectident(mystop1);
	if (symbol != SY_OF) {		/* discriminated type union */
		newtag = ob_define(id, OB_FIELD, OB_TAGFIELD);
		set_or(mystop1, stop, const_begin, set_cons(SY_OF, SY_SEMI,
			0), S0);
		p_expect(SY_COLON, mystop1);
		tagtype = p_type_ident(ID_NULL, mystop1);
		newtag->ob.field.offset = voffset = p_align(voffset, tagtype);
		voffset += tagtype->ob_size;
	} else {	/* free type union */
		newtag = ob_define(id_noname, OB_FIELD, OB_TAGFIELD);
		/*
		 * cannot call p_type_ident here since we've already gobbled
		 * the identifier.
		 */
		tagtype = p_get_type(id, 0);
	}
	set_or(mystop1, stop, const_begin, set_cons(SY_SEMI, 0), S0);
	p_expect(SY_OF, mystop1);
	if (!OB_ISORDINAL(tagtype)) {
		sprintf(err_text, err_ordq, tagtype->ob_name);
		err_msg(E_FATAL, E_PREVSYMBOL);
		tagtype = std_universal;
	}
	newtag->ob_type = tagtype;
	newtag->ob_size = tagtype->ob_size;
	newtag->ob_tword = tagtype->ob_tword;
	newtag->ob.field.tag = tag;
	newtag->ob.field.tagval = tagval;
	maxoffset = voffset;
	set_or(mystop1, stop, set_cons(SY_SEMI, 0), S0);
	set_or(mystop2, stop, const_begin, S0);
	while (set_in (symbol, const_begin)) {
		offset = p_variant(&count, voffset, newtag, tagtype, mystop1);
		if (offset > maxoffset)
			maxoffset = offset;
		if (symbol == SY_SEMI)
			p_expect(SY_SEMI, mystop2);
		else
			break;
	}
	ck_varpart(newtag, tagtype, ob_block[ob_reclevel], count);
	p_check(stop);
	return(maxoffset);
}

/*
 * record-section = identifier-list ":" type-denoter .
 */

int
p_record_section(offset, tag, tagval, stop)
	register int offset;
	OBJECT *tag, *tagval;
	STOPSET stop;
{
	STOPBUF mystop;
	int count;
	register OBJECT *type, *field;

	set_or(mystop, stop, type_begin, set_cons(SY_COLON, 0), S0);
	field = p_ident_list(&count, OB_FIELD, 0, mystop);
	set_or(mystop, stop, type_begin, S0);
	p_expect(SY_COLON, mystop);
	type = p_type_denoter(ID_NULL, stop);
	while (count--) {
		field->ob_type = type;
		field->ob_tword = type->ob_tword;
		field->ob_size = type->ob_size;
		field->ob.field.tag = tag;
		field->ob.field.tagval = tagval;
		field->ob.field.offset = offset = p_align(offset, type);
		offset += type->ob_size;
		field = field->ob_prev;
	}
	return(offset);
}

/*
 * variant = case-constant-list ":" "(" field-list ")" .
 */

int
p_variant(total, offset, tag, tagtype, stop)
	register int offset;
	int *total;
	OBJECT *tag, *tagtype;
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *tagval;
	int count;

	set_or(mystop, stop, set_cons(SY_COLON, SY_LPAREN, SY_RPAREN,
		SY_CASE, SY_IDENT, 0), S0);
	tagval = p_case_const_list(&count, tagtype, mystop);
	(*total) += count;
	set_or(mystop, stop, set_cons(SY_LPAREN, SY_RPAREN, SY_CASE,
		SY_IDENT, 0), S0);
	p_expect(SY_COLON, mystop);
	set_or(mystop, stop, set_cons(SY_RPAREN, SY_CASE, SY_IDENT, 0), S0);
	p_expect(SY_LPAREN, mystop);
	set_or(mystop, stop, set_cons(SY_RPAREN, 0), S0);
	offset = p_field_list(offset, tag, tagval, mystop);
	p_expect(SY_RPAREN, stop);
	return(offset);
}

/*
 * set-type = "set" "of" type-denoter .
 */

OBJECT *
p_set_type(id, stop)
	IDENT *id;
	register STOPSET stop;
{
	STOPBUF mystop;
	register OBJECT *set;

	/*
	 * set variables are structs defined in the run time system.
	 * The parser reserves space for sets and emits code to call
	 * run time functions to manipulate them
	 */
	set = ob_define(id, OB_SET, OB_UNDEFINED);
	set_or(mystop, stop, const_begin, set_cons(SY_OF, SY_IDENT, SY_LPAREN,
		0), S0);
	p_expect(SY_SET, mystop);
	set_or(mystop, stop, const_begin, set_cons(SY_IDENT, SY_LPAREN, 0), S0);
	p_expect(SY_OF, mystop);
	set->ob_type = p_ordinal_type(stop);
	set->ob_size = sizeof(SET);
	set->ob_tword = TW_STRTY;
	set->ob_flags &= ~OB_UNDEFINED;
	return(set);
}

/*
 * p_align() adds enough padding to an offset so that the resulting
 * address is legal for the specified type.
 */
int
p_align(offset, type)
	int offset;
	register OBJECT *type;
{
	register int align;

	/* align on the base type of an array */

	while (type->ob_kind == OB_ARRAY)
		type = type->ob_type;

	if (type->ob_kind == OB_POINTER)
		align = AL_PTR;
	else {
		switch(TW_BTYPE(type->ob_tword)) {

		case TW_INT:
			align = AL_INT; break;

		case TW_CHAR:
			align = AL_CHAR; break;

		case TW_DOUBLE:
			align = AL_DOUBLE; break;

		case TW_STRTY:
			align = AL_ANY; break;
		}
	}
	return (ALIGN(offset, align));
}
