ack/lang/m2/comp/chk_expr.c

/* E X P R E S S I O N   C H E C K I N G */

#ifndef NORCSID
static char *RcsId = "$Header$";
#endif

/*	Check expressions, and try to evaluate them as far as possible.
*/

#include	"debug.h"

#include	<em_arith.h>
#include	<em_label.h>
#include	<assert.h>
#include	<alloc.h>

#include	"Lpars.h"
#include	"idf.h"
#include	"type.h"
#include	"def.h"
#include	"LLlex.h"
#include	"node.h"
#include	"scope.h"
#include	"const.h"
#include	"standards.h"
#include	"chk_expr.h"

extern char *symbol2str();

STATIC int
chk_arr(expp)
	struct node *expp;
{
	return chk_designator(expp, VARIABLE, D_USED);
}

STATIC int
chk_value(expp)
	struct node *expp;
{
	switch(expp->nd_symb) {
	case REAL:
	case STRING:
	case INTEGER:
		return 1;

	default:
		crash("(chk_value)");
	}
	/*NOTREACHED*/
}

STATIC int
chk_linkorname(expp)
	register struct node *expp;
{
	if (chk_designator(expp, VALUE, D_USED)) {
		if (expp->nd_class == Def &&
		    expp->nd_def->df_kind == D_PROCEDURE) {
			/* Check that this procedure is one that we
			   may take the address from.
			*/
			if (expp->nd_def->df_type == std_type ||
			    expp->nd_def->df_scope->sc_level > 0) {
				/* Address of standard or nested procedure
				   taken.
				*/
node_error(expp, "it is illegal to take the address of a standard or local procedure");
				return 0;
			}
		}
		return 1;
	}
	return 0;
}

STATIC int
RemoveSet(set)
	arith **set;
{
	/*	This routine is only used for error exits of chk_el.
		It frees the set indicated by "set", and returns 0.
	*/
	if (*set) {
		free((char *) *set);
		*set = 0;
	}
	return 0;
}

STATIC int
chk_el(expp, tp, set)
	register struct node *expp;
	register struct type *tp;
	arith **set;
{
	/*	Check elements of a set. This routine may call itself
		recursively.
		Also try to compute the set!
	*/
	register struct node *left = expp->nd_left;
	register struct node *right = expp->nd_right;
	register int i;

	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
		/* { ... , expr1 .. expr2,  ... }
		   First check expr1 and expr2, and try to compute them.
		*/
		if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
			return 0;
		}

		if (left->nd_class == Value && right->nd_class == Value) {
			/* We have a constant range. Put all elements in the
			   set
			*/

		    	if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
				return RemoveSet(set);
			}

			if (*set) {
				for (i=left->nd_INT+1; i<right->nd_INT; i++) {
					(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
				}
			}
		}
		else if (*set) {
			free((char *) *set);
			*set = 0;
		}

		return 1;
	}

	/* Here, a single element is checked
	*/
	if (!chk_expr(expp)) {
		return RemoveSet(set);
	}

	if (!TstCompat(tp, expp->nd_type)) {
		node_error(expp, "set element has incompatible type");
		return RemoveSet(set);
	}

	if (expp->nd_class == Value) {
		/* a constant element
		*/
		i = expp->nd_INT;

	    	if ((tp->tp_fund != T_ENUMERATION &&
		     (i < tp->sub_lb || i > tp->sub_ub))
		   ||
		    (tp->tp_fund == T_ENUMERATION &&
		     (i < 0 || i > tp->enm_ncst))
		   ) {
			node_error(expp, "set element out of range");
			return RemoveSet(set);
		}

		if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
	}

	return 1;
}

STATIC int
chk_set(expp)
	register struct node *expp;
{
	/*	Check the legality of a SET aggregate, and try to evaluate it
		compile time. Unfortunately this is all rather complicated.
	*/
	register struct type *tp;
	register struct node *nd;
	register struct def *df;
	arith *set;
	unsigned size;

	assert(expp->nd_symb == SET);

	/* First determine the type of the set
	*/
	if (nd = expp->nd_left) {
		/* A type was given. Check it out
		*/
		if (! chk_designator(nd, 0, D_USED)) return 0;

		assert(nd->nd_class == Def);
		df = nd->nd_def;

		if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
		    (df->df_type->tp_fund != T_SET)) {
node_error(expp, "specifier does not represent a set type");
			return 0;
		}
		tp = df->df_type;
		FreeNode(expp->nd_left);
		expp->nd_left = 0;
	}
	else	tp = bitset_type;
	expp->nd_type = tp;

	nd = expp->nd_right;

	/* Now check the elements given, and try to compute a constant set.
	   First allocate room for the set, but only if it is'nt empty.
	*/
	if (! nd) {
		/* The resulting set IS empty, so we just return
		*/
		expp->nd_class = Set;
		expp->nd_set = 0;
		return 1;
	}
	size = tp->tp_size * (sizeof(arith) / word_size);
	set = (arith *) Malloc(size);
	clear((char *) set, size);

	/* Now check the elements, one by one
	*/
	while (nd) {
		assert(nd->nd_class == Link && nd->nd_symb == ',');

		if (!chk_el(nd->nd_left, tp->next, &set)) return 0;
		nd = nd->nd_right;
	}

	if (set) {
		/* Yes, it was a constant set, and we managed to compute it!
		   Notice that at the moment there is no such thing as
		   partial evaluation. Either we evaluate the set, or we
		   don't (at all). Improvement not neccesary. (???)
		*/
		expp->nd_class = Set;
		expp->nd_set = set;
		FreeNode(expp->nd_right);
		expp->nd_right = 0;
	}

	return 1;
}

STATIC struct node *
getarg(argp, bases, designator)
	struct node **argp;
{
	/*	This routine is used to fetch the next argument from an
		argument list. The argument list is indicated by "argp".
		The parameter "bases" is a bitset indicating which types
		are allowed at this point, and "designator" is a flag
		indicating that the address from this argument is taken, so
		that it must be a designator and may not be a register
		variable.
	*/
	struct type *tp;
	register struct node *arg = *argp;
	register struct node *left;

	if (! arg->nd_right) {
		node_error(arg, "too few arguments supplied");
		return 0;
	}

	arg = arg->nd_right;
	left = arg->nd_left;

	if ((!designator && !chk_expr(left)) ||
	    (designator &&
	     !chk_designator(left, VARIABLE, D_USED|D_NOREG))) {
		return 0;
	}

	tp = left->nd_type;
	if (tp->tp_fund == T_SUBRANGE) tp = tp->next;

	if (bases && !(tp->tp_fund & bases)) {
		node_error(arg, "unexpected type");
		return 0;
	}

	*argp = arg;
	return left;
}

STATIC struct node *
getname(argp, kinds)
	struct node **argp;
{
	register struct node *arg = *argp;

	if (!arg->nd_right) {
		node_error(arg, "too few arguments supplied");
		return 0;
	}

	arg = arg->nd_right;
	if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;

	if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
		node_error(arg, "identifier expected");
		return 0;
	}

	if (!(arg->nd_left->nd_def->df_kind & kinds)) {
		node_error(arg, "unexpected type");
		return 0;
	}

	*argp = arg;
	return arg->nd_left;
}

STATIC int
chk_proccall(expp)
	register struct node *expp;
{
	/*	Check a procedure call
	*/
	register struct node *left;
	struct node *arg;
	register struct paramlist *param;

	left = expp->nd_left;
	arg = expp;
	expp->nd_type = left->nd_type->next;

	for (param = ParamList(left->nd_type); param; param = param->next) {
		if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
		if (left->nd_symb == STRING) {
			TryToString(left, TypeOfParam(param));
		}
		if (! TstParCompat(TypeOfParam(param),
				   left->nd_type,
				   IsVarParam(param),
				   left)) {
node_error(left, "type incompatibility in parameter");
			return 0;
		}
	}

	if (arg->nd_right) {
		node_error(arg->nd_right, "too many parameters supplied");
		return 0;
	}

	return 1;
}

int
chk_call(expp)
	register struct node *expp;
{
	/*	Check something that looks like a procedure or function call.
		Of course this does not have to be a call at all.
		it may also be a cast or a standard procedure call.
	*/
	register struct node *left;

	/* First, get the name of the function or procedure
	*/
	expp->nd_type = error_type;
	left = expp->nd_left;
	if (! chk_designator(left, 0, D_USED)) return 0;

	if (IsCast(left)) {
		/* It was a type cast. This is of course not portable.
		*/
		return chk_cast(expp, left);
	}

	if (IsProcCall(left)) {
		/* A procedure call. it may also be a call to a
		   standard procedure
		*/
		if (left->nd_type == std_type) {
			/* A standard procedure
			*/
			return chk_std(expp, left);
		}
		/* Here, we have found a real procedure call. The left hand
		   side may also represent a procedure variable.
		*/
		return chk_proccall(expp);
	}

	node_error(left, "procedure, type, or function expected");
	return 0;
}

STATIC int
FlagCheck(expp, df, flag)
	struct node *expp;
	struct def *df;
{
	/*	See the routine "chk_designator" for an explanation of
		"flag". Here, a definition "df" is checked against it.
	*/

	if (df->df_kind == D_ERROR) return 0;

	if ((flag & VARIABLE) &&
	    !(df->df_kind & (D_FIELD|D_VARIABLE))) {
		node_error(expp, "variable expected");
		return 0;
	}

	if ((flag & HASSELECTORS) &&
	    ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_MODULE)) ||
	      df->df_type->tp_fund != T_RECORD)) {
		node_error(expp, "illegal selection");
		return 0;
	}

	if ((flag & VALUE) &&
	    ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM|D_PROCEDURE)))) {
		node_error(expp, "value expected");
		return 0;
	}

	return 1;
}

int
chk_designator(expp, flag, dflags)
	register struct node *expp;
{
	/*	Find the name indicated by "expp", starting from the current
		scope.  "flag" indicates the kind of designator we expect:
		It contains the flags VARIABLE, indicating that the result must
		be something that can be assigned to.
		It may also contain the flag VALUE, indicating that a
		value is expected. In this case, VARIABLE may not be set.
		Also contained may be the flag HASSELECTORS, indicating that
		the result must have selectors.
		"dflags" contains some flags that must be set at the definition
		found.
	*/
	register struct def *df;
	register struct type *tp;

	if (expp->nd_class == Def || expp->nd_class == LinkDef) {
		expp->nd_def->df_flags |= dflags;
		return 1;
	}

	expp->nd_type = error_type;

	if (expp->nd_class == Name) {
		expp->nd_def = lookfor(expp, CurrVis, 1);
		expp->nd_class = Def;
		expp->nd_type = expp->nd_def->df_type;
	}
	else if (expp->nd_class == Link) {
		register struct node *left = expp->nd_left;

		assert(expp->nd_symb == '.');

		if (! chk_designator(left,
				     HASSELECTORS,
				     dflags)) return 0;

		tp = left->nd_type;
		assert(tp->tp_fund == T_RECORD);

		if (!(df = lookup(expp->nd_IDF, tp->rec_scope))) {
			id_not_declared(expp);
			return 0;
		}
		else {
			expp->nd_def = df;
			expp->nd_type = df->df_type;
			expp->nd_class = LinkDef;
			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
				/* Fields of a record are always D_QEXPORTED,
				   so ...
				*/
node_error(expp, "identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
				return 0;
			}
		}

		if (left->nd_class == Def &&
		    left->nd_def->df_kind == D_MODULE) {
			expp->nd_class = Def;
			FreeNode(left);
			expp->nd_left = 0;
		}
		else {
			return FlagCheck(expp, df, flag);
		}
	}

	if (expp->nd_class == Def) {
		df = expp->nd_def;

		if (! FlagCheck(expp, df, flag)) return 0;

		if (df->df_kind & (D_ENUM | D_CONST)) {
			if (df->df_kind == D_ENUM) {
				expp->nd_class = Value;
				expp->nd_INT = df->enm_val;
				expp->nd_symb = INTEGER;
			}
			else  {
				unsigned int ln;

				assert(df->df_kind == D_CONST);
				ln = expp->nd_lineno;
				*expp = *(df->con_const);
				expp->nd_lineno = ln;
			}
		}

		df->df_flags |= dflags;

		return 1;
	}

	if (expp->nd_class == Arrsel) {
		struct type *tpl, *tpr;

		assert(expp->nd_symb == '[');

		if ( 
		     !chk_designator(expp->nd_left, VARIABLE, dflags)
		   ||
		     !chk_expr(expp->nd_right)
		   ||
		     expp->nd_left->nd_type == error_type
		   )	return 0;

		tpr = expp->nd_right->nd_type;
		tpl = expp->nd_left->nd_type;

		if (tpl->tp_fund != T_ARRAY) {
			node_error(expp,
				   "array index not belonging to an ARRAY");
			return 0;
		}

		/* Type of the index must be assignment compatible with
		   the index type of the array (Def 8.1)
		*/
		if ((tpl->next && !TstAssCompat(tpl->next, tpr)) ||
		    (!tpl->next && !TstAssCompat(intorcard_type, tpr))) {
			node_error(expp, "incompatible index type");
			return 0;
		}

		expp->nd_type = tpl->arr_elem;
		return 1;
	}

	if (expp->nd_class == Arrow) {
		assert(expp->nd_symb == '^');

		if (! chk_designator(expp->nd_right, VARIABLE, dflags)) {
			return 0;
		}

		if (expp->nd_right->nd_type->tp_fund != T_POINTER) {
node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
			return 0;
		}

		expp->nd_type = expp->nd_right->nd_type->next;
		return 1;
	}

	node_error(expp, "designator expected");
	return 0;
}

STATIC struct type *
ResultOfOperation(operator, tp)
	struct type *tp;
{
	switch(operator) {
	case '=':
	case '#':
	case GREATEREQUAL:
	case LESSEQUAL:
	case '<':
	case '>':
	case IN:
		return bool_type;
	}

	return tp;
}

STATIC int
Boolean(operator)
{
	return operator == OR || operator == AND || operator == '&';
}

STATIC int
AllowedTypes(operator)
{
	switch(operator) {
	case '+':
	case '-':
	case '*':
		return T_NUMERIC|T_SET;
	case '/':
		return T_REAL|T_SET;
	case DIV:
	case MOD:
		return T_INTORCARD;
	case OR:
	case AND:
	case '&':
		return T_ENUMERATION;
	case '=':
	case '#':
		return T_POINTER|T_HIDDEN|T_SET|T_NUMERIC|T_ENUMERATION|T_CHAR;
	case GREATEREQUAL:
	case LESSEQUAL:
		return T_SET|T_NUMERIC|T_CHAR|T_ENUMERATION;
	case '<':
	case '>':
		return T_NUMERIC|T_CHAR|T_ENUMERATION;
	default:
		crash("(AllowedTypes)");
	}
	/*NOTREACHED*/
}

STATIC int
chk_address(tpl, tpr)
	register struct type *tpl, *tpr;
{
	
	if (tpl == address_type) {
		return tpr == address_type || tpr->tp_fund != T_POINTER;
	}

	if (tpr == address_type) {
		return tpl->tp_fund != T_POINTER;
	}

	return 0;
}

STATIC int
chk_oper(expp)
	register struct node *expp;
{
	/*	Check a binary operation.
	*/
	register struct node *left, *right;
	struct type *tpl, *tpr;
	int allowed;

	left = expp->nd_left;
	right = expp->nd_right;

	if (!chk_expr(left) || !chk_expr(right)) return 0;

	tpl = left->nd_type;
	tpr = right->nd_type;

	if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
	if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;

	if (tpl == intorcard_type) {
		if (tpr == int_type || tpr == card_type) {
			 left->nd_type = tpl = tpr;
		}
	}
	if (tpr == intorcard_type) {
		if (tpl == int_type || tpl == card_type) {
			right->nd_type = tpr = tpl;
		}
	}

	expp->nd_type = ResultOfOperation(expp->nd_symb, tpl);

	if (expp->nd_symb == IN) {
		/* Handle this one specially */
		if (tpr->tp_fund != T_SET) {
node_error(expp, "RHS of IN operator not a SET type");
			return 0;
		}
		if (!TstAssCompat(tpl, tpr->next)) {
			/* Assignment compatible ???
			   I don't know! Should we be allowed to check
			   if a CARDINAL is a member of a BITSET???
			*/

node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
			return 0;
		}
		if (left->nd_class == Value && right->nd_class == Set) {
			cstset(expp);
		}
		return 1;
	}

	/* Operands must be compatible (distilled from Def 8.2)
	*/
	if (!TstCompat(tpl, tpr)) {
		node_error(expp, "incompatible types for operator \"%s\"",
					symbol2str(expp->nd_symb));
		return 0;
	}

	allowed = AllowedTypes(expp->nd_symb);
	if (!(tpl->tp_fund & allowed) || 
	    (tpl != bool_type && Boolean(expp->nd_symb))) {
		if (!(tpl->tp_fund == T_POINTER &&
		      (T_CARDINAL & allowed) &&
		      chk_address(tpl, tpr))) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
			return 0;
		}
	}

	if (tpl->tp_fund == T_SET) {
	    	if (left->nd_class == Set && right->nd_class == Set) {
			cstset(expp);
		}
	}
	else if ( tpl->tp_fund != T_REAL &&
		  left->nd_class == Value && right->nd_class == Value) {
		cstbin(expp);
	}

	return 1;
}

STATIC int
chk_uoper(expp)
	register struct node *expp;
{
	/*	Check an unary operation.
	*/
	register struct node *right = expp->nd_right;
	register struct type *tpr;

	if (! chk_expr(right)) return 0;

	tpr = right->nd_type;
	if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
	expp->nd_type = tpr;

	switch(expp->nd_symb) {
	case '+':
		if (tpr->tp_fund & T_NUMERIC) {
			expp->nd_token = right->nd_token;
			expp->nd_class = right->nd_class;
			FreeNode(right);
			expp->nd_right = 0;
			return 1;
		}
		break;

	case '-':
		if (tpr->tp_fund & T_INTORCARD) {
			if (tpr == intorcard_type) {
				expp->nd_type = int_type;
			}
			if (right->nd_class == Value) {
				cstunary(expp);
			}
			return 1;
		}
		else if (tpr->tp_fund == T_REAL) {
			expp->nd_type = tpr;
			if (right->nd_class == Value) {
				if (*(right->nd_REL) == '-') (right->nd_REL)++;
				else (right->nd_REL)--;
				expp->nd_class = Value;
				expp->nd_symb = REAL;
				expp->nd_REL = right->nd_REL;
				FreeNode(right);
				expp->nd_right = 0;
			}
			return 1;
		}
		break;

	case NOT:
	case '~':
		if (tpr == bool_type) {
			if (right->nd_class == Value) {
				cstunary(expp);
			}
			return 1;
		}
		break;

	default:
		crash("chk_uoper");
	}
	node_error(expp, "illegal operand for unary operator \"%s\"",
			symbol2str(expp->nd_symb));
	return 0;
}

STATIC struct node *
getvariable(argp)
	struct node **argp;
{
	register struct node *arg = *argp;
	register struct def *df;
	register struct node *left;

	arg = arg->nd_right;
	if (!arg) {
		node_error(arg, "too few parameters supplied");
		return 0;
	}

	left = arg->nd_left;

	if (! chk_designator(left, 0, D_REFERRED)) return 0;
	if (left->nd_class == Arrsel || left->nd_class == Arrow) {
		*argp = arg;
		return left;
	}

	df = 0;
	if (left->nd_class == LinkDef || left->nd_class == Def) {
		df = left->nd_def;
	}

	if (!df || !(df->df_kind & (D_VARIABLE|D_FIELD))) {
		node_error(arg, "variable expected");
		return 0;
	}

	*argp = arg;
	return left;
}

int
chk_std(expp, left)
	register struct node *expp, *left;
{
	/*	Check a call of a standard procedure or function
	*/
	struct node *arg = expp;
	int std;

	assert(left->nd_class == Def);
	std = left->nd_def->df_value.df_stdname;

DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));

	switch(std) {
	case S_ABS:
		if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
		expp->nd_type = left->nd_type;
		if (left->nd_class == Value &&
		    expp->nd_type->tp_fund != T_REAL) {
			cstcall(expp, S_ABS);
		}
		break;

	case S_CAP:
		expp->nd_type = char_type;
		if (!(left = getarg(&arg, T_CHAR, 0))) return 0;
		if (left->nd_class == Value) cstcall(expp, S_CAP);
		break;

	case S_CHR:
		expp->nd_type = char_type;
		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
		if (left->nd_class == Value) cstcall(expp, S_CHR);
		break;

	case S_FLOAT:
		expp->nd_type = real_type;
		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
		break;

	case S_HIGH:
		if (!(left = getarg(&arg, T_ARRAY, 0))) return 0;
		expp->nd_type = left->nd_type->next;
		if (!expp->nd_type) {
			/* A dynamic array has no explicit index type
			*/
			expp->nd_type = intorcard_type;
		}
		else	cstcall(expp, S_MAX);
		break;

	case S_MAX:
	case S_MIN:
		if (!(left = getname(&arg, D_ISTYPE))) return 0;
		if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
			node_error(left, "illegal type in MIN or MAX");
			return 0;
		}
		expp->nd_type = left->nd_type;
		cstcall(expp,std);
		break;

	case S_ODD:
		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
		expp->nd_type = bool_type;
		if (left->nd_class == Value) cstcall(expp, S_ODD);
		break;

	case S_ORD:
		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
		if (left->nd_type->tp_size > word_size) {
			node_error(left, "illegal type in argument of ORD");
			return 0;
		}
		expp->nd_type = card_type;
		if (left->nd_class == Value) cstcall(expp, S_ORD);
		break;

	case S_NEW:
	case S_DISPOSE:
		{
			static int warning_given = 0;

			if (!warning_given) {
				warning_given = 1;
				node_warning(expp, "NEW and DISPOSE are old-fashioned");
			}
		}
		if (! (left = getvariable(&arg))) return 0;
		if (! (left->nd_type->tp_fund == T_POINTER)) {
			node_error(left, "pointer variable expected");
			return 0;
		}
		if (left->nd_class == Def) {
			left->nd_def->df_flags |= D_NOREG;
		}
		/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
		{
			struct token dt;
			struct node *nd;

			dt.TOK_INT = left->nd_type->next->tp_size;
			dt.tk_symb = INTEGER;
			dt.tk_lineno = left->nd_lineno;
			nd = MkLeaf(Value, &dt);
			nd->nd_type = card_type;
			dt.tk_symb = ',';
			arg->nd_right = MkNode(Link, nd, NULLNODE, &dt);
			/* Ignore other arguments to NEW and/or DISPOSE ??? */

			FreeNode(expp->nd_left);
			dt.tk_symb = IDENT;
			dt.tk_lineno = expp->nd_left->nd_lineno;
			dt.TOK_IDF = str2idf(std == S_NEW ?
						"ALLOCATE" : "DEALLOCATE", 0);
			expp->nd_left = MkLeaf(Name, &dt);
		}
		return chk_call(expp);

	case S_TSIZE:	/* ??? */
	case S_SIZE:
		expp->nd_type = intorcard_type;
		if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE)) return 0;
		cstcall(expp, S_SIZE);
		break;

	case S_TRUNC:
		expp->nd_type = card_type;
		if (!(left = getarg(&arg, T_REAL, 0))) return 0;
		break;

	case S_VAL:
		{
		struct type *tp;

		if (!(left = getname(&arg, D_ISTYPE))) return 0;
		tp = left->nd_def->df_type;
		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
		if (!(tp->tp_fund & T_DISCRETE)) {
			node_error(arg, "unexpected type");
			return 0;
		}
		expp->nd_type = left->nd_def->df_type;
		expp->nd_right = arg->nd_right;
		arg->nd_right = 0;
		FreeNode(arg);
		arg = expp;
		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
		if (left->nd_class == Value) cstcall(expp, S_VAL);
		break;
		}

	case S_ADR:
		expp->nd_type = address_type;
		if (!(left = getarg(&arg, 0, 1))) return 0;
		break;

	case S_DEC:
	case S_INC:
		expp->nd_type = 0;
		if (! (left = getvariable(&arg))) return 0;
		if (! (left->nd_type->tp_fund & T_DISCRETE)) {
node_error(left, "illegal type in argument of INC or DEC");
			return 0;
		}
		if (arg->nd_right) {
			if (! getarg(&arg, T_INTORCARD, 0)) return 0;
		}
		break;

	case S_HALT:
		expp->nd_type = 0;
		break;

	case S_EXCL:
	case S_INCL:
		{
		struct type *tp;

		expp->nd_type = 0;
		if (!(left = getvariable(&arg))) return 0;
		tp = left->nd_type;
		if (tp->tp_fund != T_SET) {
node_error(arg, "EXCL and INCL expect a SET parameter");
			return 0;
		}
		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
		if (!TstAssCompat(tp->next, left->nd_type)) {
			/* What type of compatibility do we want here?
			   apparently assignment compatibility! ??? ???
			*/
			node_error(arg, "unexpected type");
			return 0;
		}
		break;
		}

	default:
		crash("(chk_std)");
	}

	if (arg->nd_right) {
		node_error(arg->nd_right, "too many parameters supplied");
		return 0;
	}

	return 1;
}

chk_cast(expp, left)
	register struct node *expp, *left;
{
	/*	Check a cast and perform it if the argument is constant.
		If the sizes don't match, only complain if at least one of them
		has a size larger than the word size.
		If both sizes are equal to or smaller than the word size, there
		is no problem as such values take a word on the EM stack
		anyway.
	*/
	register struct node *arg = expp->nd_right;

	if ((! arg) || arg->nd_right) {
node_error(expp, "only one parameter expected in type cast");
		return 0;
	}

	arg = arg->nd_left;
	if (! chk_expr(arg)) return 0;

	if (arg->nd_type->tp_size != left->nd_type->tp_size &&
	    (arg->nd_type->tp_size > word_size ||
	     left->nd_type->tp_size > word_size)) {
		node_error(expp, "unequal sizes in type cast");
	}

	if (arg->nd_class == Value) {
		struct type *tp = left->nd_type;

		FreeNode(left);
		expp->nd_right->nd_left = 0;
		FreeNode(expp->nd_right);
		expp->nd_left = expp->nd_right = 0;
		*expp = *arg;
		expp->nd_type = tp;
	}
	else expp->nd_type = left->nd_type;

	return 1;
}

TryToString(nd, tp)
	struct node *nd;
	struct type *tp;
{
	/*	Try a coercion from character constant to string.
	*/
	if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
		int ch = nd->nd_INT;

		nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
		nd->nd_token.tk_data.tk_str = 
			(struct string *) Malloc(sizeof(struct string));
		nd->nd_STR = Salloc("X", 2);
		*(nd->nd_STR) = ch;
		nd->nd_SLE = 1;
	}
}

extern int	NodeCrash();

int (*ChkTable[])() = {
	chk_value,
	chk_arr,
	chk_oper,
	chk_uoper,
	chk_arr,
	chk_call,
	chk_linkorname,
	NodeCrash,
	chk_set,
	NodeCrash,
	NodeCrash,
	chk_linkorname,
	NodeCrash
};