ack/lang/pc/comp/code.c

/* C O D E   G E N E R A T I O N   R O U T I N E S */

#include    <stdlib.h>
#include    <string.h>
#include    "parameters.h"
#include	"debug.h"
#include	<assert.h>
#include	<em.h>
#include	<em_reg.h>
#include	<em_abs.h>

#include	"LLlex.h"
#include	"Lpars.h"
#include	"def.h"
#include	"desig.h"
#include	"f_info.h"
#include	"idf.h"
#include	"main.h"
#include	"misc.h"
#include	"node.h"
#include	"required.h"
#include	"scope.h"
#include	"type.h"
#include    "code.h"
#include    "tmpvar.h"
#include    "typequiv.h"
#include    "error.h"

int fp_used;

static void CodeUoper(register struct node *);
static void CodeBoper(register struct node *, /* the expression tree itself	*/
label);
static void CodeSet(register struct node *);
static void CodeEl(register struct node *, register struct type *);
static void CodePString(struct node *, struct type *);
/* General internal system API calls */
static void CodeStd(struct node *);

static void genrck(register struct type *);
static void RegisterMessages(register struct def *);
static void CodeConfDescr(register struct type *, register struct type *);

extern void call_ini(void);



static void CodeFil(void)
{
	if (!options['L'])
		C_fil_dlb((label ) 1, (arith) 0);
}

void routine_label(register struct def * df)
{
	df->prc_label = ++data_label;
	C_df_dlb(df->prc_label);
	C_rom_scon(df->df_idf->id_text, (arith)(strlen(df->df_idf->id_text) + 1));
}

void RomString(register struct node *nd)
{
	C_df_dlb(++data_label);

	/* A string of the string_type is null-terminated. */
	if (nd->nd_type == string_type)
		C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
	else
		C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */

	nd->nd_SLA = data_label;
}

void RomReal(register struct node *nd)
{
	if (!nd->nd_RLA)
	{
		C_df_dlb(++data_label);
		nd->nd_RLA = data_label;
		C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
	}
}

void BssVar(void)
{
	/* generate bss segments for global variables */
	register struct def *df = GlobalScope->sc_def;

	while (df)
	{
		if (df->df_kind == D_VARIABLE)
		{
			C_df_dnam(df->var_name);

			/* ??? undefined value ??? */
			C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
		}
		df = df->df_nextinscope;
	}
}

static arith CodeGtoDescr(register struct scope *sc)
{
	/*	Create code for goto descriptors
	 */

	register struct node *lb = sc->sc_lablist;
	int first = 1;

	while (lb)
	{
		if (lb->nd_def->lab_descr)
		{
			if (first)
			{
				/* create local for target SP */
				sc->sc_off = -WA(pointer_size - sc->sc_off);
				C_ms_gto();
				first = 0;
			}
			C_df_dlb(lb->nd_def->lab_descr);
			C_rom_ilb(lb->nd_def->lab_no);
			C_rom_cst(sc->sc_off);
		}
		lb = lb->nd_next;
	}
	if (!first)
		return sc->sc_off;
	else
		return (arith) 0;
}

arith CodeBeginBlock(register struct def *df)
{
	/*	Generate code at the beginning of the main program,
	 procedure or function.
	 */

	arith StackAdjustment = 0;
	arith offset = 0; /* offset to save StackPointer */

	TmpOpen(df->prc_vis->sc_scope);

	if (df->df_kind == D_MODULE) /* nothing */
		;
	else if (df->df_kind == D_PROGRAM)
	{
		C_exp("_m_a_i_n");
		C_pro_narg("_m_a_i_n");
		C_ms_par((arith) 0);
		offset = CodeGtoDescr(df->prc_vis->sc_scope);
		CodeFil();

		/* initialize external files */
		call_ini();
		/* ignore floating point underflow */C_lim();
		C_loc((arith)(1 << EFUNFL));
		C_ior(int_size);
		C_sim();
	}
	else if (df->df_kind & (D_PROCEDURE | D_FUNCTION))
	{
		struct type *tp;
		register struct paramlist *param;

		C_pro_narg(df->prc_name);
		C_ms_par(df->df_type->prc_nbpar);

		offset = CodeGtoDescr(df->prc_vis->sc_scope);
		CodeFil();

		if (options['t'])
		{
			C_lae_dlb(df->prc_label, (arith) 0);
			C_cal("procentry");
			C_asp(pointer_size);
		}

		/* prc_bool is the local variable that indicates if the
		 * function result is assigned. This and can be disabled
		 * with the -R option. The variable, however, is always
		 * allocated and initialized.
		 */
		if (df->prc_res)
		{
			C_zer((arith) int_size);
			C_stl(df->prc_bool);
		}
		for (param = ParamList(df->df_type) ; param; param = param->next)
		{
			if (!IsVarParam(param))
			{
				tp = TypeOfParam(param);

				if (IsConformantArray(tp))
				{
					/* Here, we have to make a copy of the
					 array. We must also remember how much
					 room is reserved for copies, because
					 we have to adjust the stack pointer
					 before we return.
					 */

					if (!StackAdjustment)
					{
						/* First time we get here
						 */
						StackAdjustment = NewInt(0);
						C_loc((arith) 0);
						C_stl(StackAdjustment);
					}
					/* Address of array */
					C_lol(param->par_def->var_off);

					/* First compute size of the array */
					C_lol(tp->arr_cfdescr + word_size);
					C_inc();
					/* gives number of elements */
					C_lol(tp->arr_cfdescr + 2 * word_size);
					/* size of elements */
					C_mli(word_size);
					C_loc(word_size - 1);
					C_adi(word_size);
					C_loc(word_size - 1);
					C_com(word_size);
					C_and(word_size);
					C_dup(word_size);
					C_lol(StackAdjustment);
					C_adi(word_size);
					C_stl(StackAdjustment);
					/* remember stack adjustments */

					C_los(word_size); /* copy */
					C_lor((arith) 1);
					/* push new address of array
					 ... downwards ... ???
					 */
					C_stl(param->par_def->var_off);
				}
			}
		}
	}
	else
	{
		crash("(CodeBeginBlock)");
		/*NOTREACHED*/
	}

	if (offset)
	{
		/* save SP for non-local jump */
		C_lor((arith) 1);
		C_stl(offset);
	}
	return StackAdjustment;
}

void CodeEndBlock(register struct def *df, arith StackAdjustment)
{
	if (df->df_kind == D_PROGRAM)
	{
		C_loc((arith) 0);
		C_cal("_hlt");
	}
	else if (df->df_kind & (D_PROCEDURE | D_FUNCTION))
	{
		struct type *tp;

		if (StackAdjustment)
		{
			/* remove copies of conformant arrays */
			C_lol(StackAdjustment);
			C_ass(word_size);
			FreeInt(StackAdjustment);
		}
		if (!options['n'])
			RegisterMessages(df->prc_vis->sc_scope->sc_def);

		if (options['t'])
		{
			C_lae_dlb(df->prc_label, (arith) 0);
			C_cal("procexit");
			C_asp(pointer_size);
		}
		if ( (tp = ResultType(df->df_type)) )
		{
			if (!options['R'])
			{
				C_lin((arith) LineNumber);
				C_lol(df->prc_bool);
				C_cal("_nfa");
				C_asp(word_size);
			}
			if (tp->tp_size == word_size)
				C_lol(-tp->tp_size);
			else if (tp->tp_size == 2 * word_size)
				C_ldl(-tp->tp_size);
			else
			{
				C_lal(-tp->tp_size);
				C_loi(tp->tp_size);
			}

			C_ret(tp->tp_size);
		}
		else
			C_ret((arith) 0);
	}
	else
	{
		crash("(CodeEndBlock)");
		/*NOTREACHED*/
	}

	C_end(-df->prc_vis->sc_scope->sc_off);
	TmpClose();
}

void CodeExpr(register struct node *nd, register struct desig *ds,
		label true_label)
{
	register struct type *tp = nd->nd_type;

	if (tp->tp_fund == T_REAL)
		fp_used = 1;

	switch (nd->nd_class)
	{
	case Value:
		switch (nd->nd_symb)
		{
		case INTEGER:
			C_loc(nd->nd_INT);
			break;
		case REAL:
			RomReal(nd);
			C_lae_dlb(nd->nd_RLA, (arith) 0);
			C_loi(tp->tp_size);
			break;
		case STRING:
			if (tp->tp_fund == T_CHAR)
				C_loc(nd->nd_INT);
			else
				C_lae_dlb(nd->nd_SLA, (arith) 0);
			break;
		case NIL:
			C_zer(pointer_size);
			break;
		default:
			crash("(CodeExpr Value)");
			/*NOTREACHED*/
		}
		ds->dsg_kind = DSG_LOADED;
		break;

	case Uoper:
		CodeUoper(nd);
		ds->dsg_kind = DSG_LOADED;
		break;

	case Boper:
		CodeBoper(nd, true_label);
		ds->dsg_kind = DSG_LOADED;
		true_label = NO_LABEL;
		break;

	case Set:
	{
		register arith *st = nd->nd_set;
		register int i;

		ds->dsg_kind = DSG_LOADED;
		if (!st)
		{
			C_zer(tp->tp_size);
			break;
		}
		for (i = tp->tp_size / word_size, st += i; i > 0; i--)
			C_loc(*--st);

	}
		break;

	case Xset:
		CodeSet(nd);
		ds->dsg_kind = DSG_LOADED;
		break;

	case Call:
		CodeCall(nd);
		ds->dsg_kind = DSG_LOADED;
		break;

	case NameOrCall:
	{
		/* actual procedure/function parameter */
		struct node *left = nd->nd_left;
		struct def *df = left->nd_def;

		if (df->df_kind & D_ROUTINE)
		{
			int level = df->df_scope->sc_level;

			if (level <= 0 || (df->df_flags & D_EXTERNAL))
				C_zer(pointer_size);
			else
				C_lxl((arith)(proclevel - level));

			C_lpi(df->prc_name);
			ds->dsg_kind = DSG_LOADED;
			break;
		}
		assert(df->df_kind == D_VARIABLE);
		assert(df->df_type->tp_fund & T_ROUTINE);

		CodeDesig(left, ds);
		break;
	}

	case Arrow:
	case Arrsel:
	case Def:
	case LinkDef:
		CodeDesig(nd, ds);
		break;

	case Cast:
	{
		/* convert integer to real */
		struct node *right = nd->nd_right;

		CodePExpr(right);
		Int2Real(right->nd_type->tp_size);
		ds->dsg_kind = DSG_LOADED;
		break;
	}
	case IntCoerc:
	{
		/* convert integer to long integer */
		struct node *right = nd->nd_right;

		CodePExpr(right);
		Int2Long();
		ds->dsg_kind = DSG_LOADED;
		break;
	}
	case IntReduc:
	{
		/* convert a long to an integer */
		struct node *right = nd->nd_right;

		CodePExpr(right);
		Long2Int();
		ds->dsg_kind = DSG_LOADED;
		break;
	}
	default:
		crash("(CodeExpr : bad node type)");
		/*NOTREACHED*/
	} /* switch class */

	if (true_label)
	{
		/* Only for boolean expressions
		 */
		CodeValue(ds, tp);
		C_zeq(true_label);
	}
}

static void CodeUoper(register struct node *nd)
{
	register struct type *tp = nd->nd_type;

	CodePExpr(nd->nd_right);

	switch (nd->nd_symb)
	{
	case '-':
		assert(tp->tp_fund & T_NUMERIC);
		if (tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG)
			C_ngi(tp->tp_size);
		else
			C_ngf(tp->tp_size);
		break;

	case NOT:
		C_teq();
		break;

	case '(':
		break;

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

/*	truthvalue() serves as an auxiliary function of CodeBoper	*/
static void truthvalue(int relop)
{
	switch (relop)
	{
	case '<':
		C_tlt();
		break;
	case LESSEQUAL:
		C_tle();
		break;
	case '>':
		C_tgt();
		break;
	case GREATEREQUAL:
		C_tge();
		break;
	case '=':
		C_teq();
		break;
	case NOTEQUAL:
		C_tne();
		break;
	default:
		crash("(truthvalue)");
		/*NOTREACHED*/
	}
}



static void Operands(register struct node *leftop, register struct node *rightop)
{
	CodePExpr(leftop);
	CodePExpr(rightop);
}

static void CodeBoper(register struct node *expr, /* the expression tree itself	*/
label true_label) /* label to jump to in logical exprs */
{
	register struct node *leftop = expr->nd_left;
	register struct node *rightop = expr->nd_right;
	register struct type *tp = expr->nd_type;

	switch (expr->nd_symb)
	{
	case '+':
		Operands(leftop, rightop);
		switch (tp->tp_fund)
		{
		case T_INTEGER:
		case T_LONG:
			C_adi(tp->tp_size);
			break;
		case T_REAL:
			C_adf(tp->tp_size);
			break;
		case T_SET:
			C_ior(tp->tp_size);
			break;
		default:
			crash("(CodeBoper: bad type +)");
		}
		break;

	case '-':
		Operands(leftop, rightop);
		switch (tp->tp_fund)
		{
		case T_INTEGER:
		case T_LONG:
			C_sbi(tp->tp_size);
			break;
		case T_REAL:
			C_sbf(tp->tp_size);
			break;
		case T_SET:
			C_com(tp->tp_size);
			C_and(tp->tp_size);
			break;
		default:
			crash("(CodeBoper: bad type -)");
		}
		break;

	case '*':
		Operands(leftop, rightop);
		switch (tp->tp_fund)
		{
		case T_INTEGER:
		case T_LONG:
			C_mli(tp->tp_size);
			break;
		case T_REAL:
			C_mlf(tp->tp_size);
			break;
		case T_SET:
			C_and(tp->tp_size);
			break;
		default:
			crash("(CodeBoper: bad type *)");
		}
		break;

	case '/':
		Operands(leftop, rightop);
		if (tp->tp_fund == T_REAL)
			C_dvf(tp->tp_size);
		else
			crash("(CodeBoper: bad type /)");
		break;

	case DIV:
	case MOD:
		Operands(leftop, rightop);
		if (tp->tp_fund == T_INTEGER)
		{
			C_cal(expr->nd_symb == MOD ? "_mdi" : "_dvi");
			C_asp(2 * tp->tp_size);
			C_lfr(tp->tp_size);
		}
		else if (tp->tp_fund == T_LONG)
		{
			C_cal(expr->nd_symb == MOD ? "_mdil" : "_dvil");
			C_asp(2 * tp->tp_size);
			C_lfr(tp->tp_size);
		}
		else
			crash("(CodeBoper: bad type MOD)");
		break;

	case '<':
	case LESSEQUAL:
	case '>':
	case GREATEREQUAL:
	case '=':
	case NOTEQUAL:
		CodePExpr(leftop);
		CodePExpr(rightop);
		tp = BaseType(rightop->nd_type);

		switch (tp->tp_fund)
		{
		case T_INTEGER:
		case T_LONG:
			C_cmi(tp->tp_size);
			break;
		case T_REAL:
			C_cmf(tp->tp_size);
			break;
		case T_ENUMERATION:
		case T_CHAR:
			C_cmu(word_size);
			break;
		case T_POINTER:
			C_cmp();
			break;

		case T_SET:
			if (expr->nd_symb == GREATEREQUAL)
			{
				/* A >= B is the same as A equals A + B
				 */
				C_dup(2 * tp->tp_size);
				C_asp(tp->tp_size);
				C_ior(tp->tp_size);
				expr->nd_symb = '=';
			}
			else if (expr->nd_symb == LESSEQUAL)
			{
				/* A <= B is the same as A - B = []
				 */
				C_com(tp->tp_size);
				C_and(tp->tp_size);
				C_zer(tp->tp_size);
				expr->nd_symb = '=';
			}
			C_cms(tp->tp_size);
			break;

		case T_STRINGCONST:
		case T_ARRAY:
			C_loc((arith) IsString(tp));
			C_cal("_bcp");
			C_asp(2 * pointer_size + word_size);
			C_lfr(word_size);
			break;

		case T_STRING:
			C_cmp();
			break;

		default:
			crash("(CodeBoper : bad type COMPARE)");
		}
		truthvalue(expr->nd_symb);
		if (true_label != NO_LABEL )
			C_zeq(true_label);
		break;

	case IN:
		/* In this case, evaluate right hand side first! The INN
		 instruction expects the bit number on top of the stack
		 */
		CodePExpr(rightop);
		CodePExpr(leftop);
		if (rightop->nd_type == emptyset_type)
			C_and(rightop->nd_type->tp_size);
		else
			C_inn(rightop->nd_type->tp_size);

		if (true_label != NO_LABEL )
			C_zeq(true_label);
		break;

	case AND:
	case OR:
		Operands(leftop, rightop);
		if (expr->nd_symb == AND)
			C_and(tp->tp_size);
		else
			C_ior(tp->tp_size);
		if (true_label != NO_LABEL )
			C_zeq(true_label);
		break;
	default:
		crash("(CodeBoper Bad operator %s\n)", symbol2str(expr->nd_symb));
	}
}


static void CodeSet(register struct node *nd)
{
	register struct type *tp = nd->nd_type;

	C_zer(tp->tp_size);
	nd = nd->nd_right;
	while (nd)
	{
		assert(nd->nd_class == Link && nd->nd_symb == ',');

		CodeEl(nd->nd_left, tp);
		nd = nd->nd_right;
	}
}

static void CodeEl(register struct node *nd, register struct type *tp)
{
	if (nd->nd_class == Link && nd->nd_symb == UPTO)
	{
		Operands(nd->nd_left, nd->nd_right);
		C_loc(tp->tp_size); /* push size */
		C_cal("_bts"); /* library routine to fill set */
		C_asp(3 * word_size);
	}
	else
	{
		CodePExpr(nd);
		C_set(tp->tp_size);
		C_ior(tp->tp_size);
	}
}

static struct type * CodeParameters(struct paramlist *param, struct node *arg)
{
	register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
	struct node *left;
	struct desig ds;

	assert(param && arg);

	if (param->next)
		last_tp = CodeParameters(param->next, arg->nd_right);

	tp = TypeOfParam(param);
	left = arg->nd_left;
	left_tp = left->nd_type;

	if (IsConformantArray(tp))
	{
		if (last_tp != tp)
			/* push descriptors only once */
			CodeConfDescr(tp, left_tp);

		CodeDAddress(left);
		return tp;
	}
	if (IsVarParam(param))
	{
		CodeDAddress(left);
		return tp;
	}
	if (left_tp->tp_fund == T_STRINGCONST)
	{
		CodePString(left, tp);
		return tp;
	}

	ds = InitDesig;
	CodeExpr(left, &ds, NO_LABEL );
	CodeValue(&ds, left_tp);

	RangeCheck(tp, left_tp);
	if (tp == real_type && BaseType(left_tp) == int_type)
		Int2Real(int_size);

	return tp;
}

static void CodeConfDescr(register struct type *ftp, register struct type *atp)
{
	struct type *elemtp = ftp->arr_elem;

	if (IsConformantArray(elemtp))
		CodeConfDescr(elemtp, atp->arr_elem);

	if (atp->tp_fund == T_STRINGCONST)
	{
		C_loc((arith) 1);
		C_loc(atp->tp_psize - 1);
		C_loc((arith) 1);
	}
	else if (IsConformantArray(atp))
	{
		if (atp->arr_sclevel < proclevel)
		{
			C_lxa((arith) proclevel - atp->arr_sclevel);
			C_adp(atp->arr_cfdescr);
		}
		else
			C_lal(atp->arr_cfdescr);

		C_loi(3 * word_size);
	}
	else
	{ /* normal array */
		assert(atp->tp_fund == T_ARRAY);
		assert(!IsConformantArray(atp));
		C_lae_dlb(atp->arr_ardescr, (arith) 0);
		C_loi(3 * word_size);
	}
}

static void CodePString(struct node *nd, struct type *tp)
{
	/* no null padding */
	C_lae_dlb(nd->nd_SLA, (arith) 0);
	C_loi(tp->tp_size);
}

void CodeCall(register struct node *nd)
{
	/*	Generate code for a procedure call. Checking of parameters
	 and result is already done.
	 */
	register struct node *left = nd->nd_left;
	register struct node *right = nd->nd_right;
	register struct def *df = left->nd_def;
	register struct type *result_tp;

	assert(IsProcCall(left));

	if (left->nd_type == std_type)
	{
		CodeStd(nd);
		return;
	}

	if (right)
		(void) CodeParameters(ParamList(left->nd_type), right);

	assert(left->nd_class == Def);

	if (df->df_kind & D_ROUTINE)
	{
		int level = df->df_scope->sc_level;

		if (level > 0 && !(df->df_flags & D_EXTERNAL))
			C_lxl((arith)(proclevel - level));
		C_cal(df->prc_name);
		C_asp(left->nd_type->prc_nbpar);
	}
	else
	{
		label l1 = ++text_label;
		label l2 = ++text_label;

		assert(df->df_kind == D_VARIABLE);

		/* Push value of procedure/function parameter */
		CodePExpr(left);

		/* Test if value is a global or local procedure/function */
		C_exg(pointer_size);
		C_dup(pointer_size);
		C_zer(pointer_size);
		C_cmp();

		C_zeq(l1);
		/* At this point, on top of the stack the LB */
		C_exg(pointer_size);
		/* Now, the name of the procedure/function */C_cai();
		C_asp(pointer_size + left->nd_type->prc_nbpar);
		C_bra(l2);

		/* value is a global procedure/function */
		C_df_ilb(l1);
		C_asp(pointer_size); /* no LB needed */
		C_cai();
		C_asp(left->nd_type->prc_nbpar);
		C_df_ilb(l2);
	}

	if ( (result_tp = ResultType(left->nd_type)) )
		C_lfr(result_tp->tp_size);
}

static void CodeStd(struct node *nd)
{
	register struct node *arg = nd->nd_right;
	register struct node *left = arg->nd_left;
	register struct type *tp = BaseType(left->nd_type);
	int req = nd->nd_left->nd_def->df_value.df_reqname;

	assert(arg->nd_class == Link && arg->nd_symb == ',');

	switch (req)
	{
	case R_ABS:
		CodePExpr(left);
		if (tp == int_type)
			C_cal("_abi");
		else if (tp == long_type)
			C_cal("_abl");
		else
			C_cal("_abr");
		C_asp(tp->tp_size);
		C_lfr(tp->tp_size);
		break;

	case R_SQR:
		CodePExpr(left);
		C_dup(tp->tp_size);
		if (tp == int_type || tp == long_type)
			C_mli(tp->tp_size);
		else
			C_mlf(real_size);
		break;

	case R_SIN:
	case R_COS:
	case R_EXP:
	case R_LN:
	case R_SQRT:
	case R_ARCTAN:
		assert(tp == real_type);
		CodePExpr(left);
		switch (req)
		{
		case R_SIN:
			C_cal("_sin");
			break;
		case R_COS:
			C_cal("_cos");
			break;
		case R_EXP:
			C_cal("_exp");
			break;
		case R_LN:
			C_cal("_log");
			break;
		case R_SQRT:
			C_cal("_sqt");
			break;
		case R_ARCTAN:
			C_cal("_atn");
			break;
		default:
			crash("(CodeStd)");
			/*NOTREACHED*/
		}
		C_asp(real_size);
		C_lfr(real_size);
		break;

	case R_TRUNC:
		assert(tp == real_type);
		CodePExpr(left);
		Real2Int();
		break;

	case R_ROUND:
		assert(tp == real_type);
		CodePExpr(left);
		C_cal("_rnd");
		C_asp(real_size);
		C_lfr(real_size);
		Real2Int();
		break;

	case R_ORD:
		CodePExpr(left);
		break;

	case R_CHR:
		CodePExpr(left);
		genrck(char_type);
		break;

	case R_SUCC:
	case R_PRED:
		CodePExpr(left);
		C_loc((arith) 1);
		if (tp == long_type)
			Int2Long();

		if (req == R_SUCC)
			C_adi(tp->tp_size);
		else
			C_sbi(tp->tp_size);

		if (bounded(left->nd_type))
			genrck(left->nd_type);
		break;

	case R_ODD:
		CodePExpr(left);
		C_loc((arith) 1);
		if (tp == long_type)
			Int2Long();
		C_and(tp->tp_size);
		if (tp == long_type)
			Long2Int(); /* bool_size == int_size */
		break;

	case R_EOF:
	case R_EOLN:
		CodeDAddress(left);
		if (req == R_EOF)
			C_cal("_efl");
		else
			C_cal("_eln");
		C_asp(pointer_size);
		C_lfr(word_size);
		break;

	case R_REWRITE:
	case R_RESET:
		CodeDAddress(left);
		if (tp == text_type)
			C_loc((arith) 0);
		else
			C_loc(tp->next->tp_psize);
		/* ??? elements of packed size ??? */
		if (req == R_REWRITE)
			C_cal("_cre");
		else
			C_cal("_opn");
		C_asp(pointer_size + word_size);
		break;

	case R_PUT:
	case R_GET:
		CodeDAddress(left);
		if (req == R_PUT)
			C_cal("_put");
		else
			C_cal("_get");
		C_asp(pointer_size);
		break;

	case R_PAGE:
		CodeDAddress(left);
		C_cal("_pag");
		C_asp(pointer_size);
		break;

	case R_PACK:
	{
		label lba = tp->arr_ardescr;

		CodeDAddress(left);
		arg = arg->nd_right;
		left = arg->nd_left;
		CodePExpr(left);
		arg = arg->nd_right;
		left = arg->nd_left;
		CodeDAddress(left);
		C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
		C_lae_dlb(lba, (arith) 0);
		C_cal("_pac");
		C_asp(4 * pointer_size + word_size);
		break;
	}

	case R_UNPACK:
	{
		/* change sequence of arguments of the library routine
		 _unp to merge code of R_PACK and R_UNPACK.
		 */
		label lba, lbz = tp->arr_ardescr;

		tp = tp->arr_elem;
		if (tp->tp_fund == T_SUBRANGE && tp->sub_lb >= 0)
		{
			C_loc((arith) 1);
		}
		else
			C_loc((arith) 0);
		CodeDAddress(left);
		arg = arg->nd_right;
		left = arg->nd_left;
		CodeDAddress(left);
		lba = left->nd_type->arr_ardescr;
		arg = arg->nd_right;
		left = arg->nd_left;
		CodePExpr(left);
		C_lae_dlb(lbz, (arith) 0);
		C_lae_dlb(lba, (arith) 0);
		C_cal("_unp");
		C_asp(4 * pointer_size + 2 * word_size);
		break;
	}

	case R_NEW:
	case R_DISPOSE:
		CodeDAddress(left);
		C_loc(PointedtoType(tp)->tp_size);
		if (req == R_NEW)
			C_cal("_new");
		else
			C_cal("_dis");
		C_asp(pointer_size + word_size);
		break;

	case R_HALT:
		if (left)
			CodePExpr(left);
		else
			C_zer(int_size);
		C_cal("_hlt"); /* can't return */
		C_asp(int_size); /* help the optimizer(s) */
		break;

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

void Long2Int(void)
{
	/* convert a long to integer */

	if (int_size == long_size)
		return;

	C_loc(long_size);
	C_loc(int_size);
	C_cii();
}

void Int2Long(void)
{
	/* convert integer to long */

	if (int_size == long_size)
		return;
	C_loc(int_size);
	C_loc(long_size);
	C_cii();
}

void Int2Real(arith size)
/* size is different for integers and longs */
{
	/* convert integer to real */
	C_loc(size);
	C_loc(real_size);
	C_cif();
}

void Real2Int(void)
{
	/* convert real to integer */
	C_loc(real_size);
	C_loc(int_size);
	C_cfi();
}

void RangeCheck(register struct type *tpl, register struct type *tpr)
{
	/*	Generate a range check if neccessary
	 */

	arith llo, lhi, rlo, rhi;

	if (bounded(tpl))
	{
		/* in this case we might need a range check */
		if (!bounded(tpr))
			/* yes, we need one */
			genrck(tpl);
		else
		{
			/* both types are restricted. check the bounds to see
			 whether we need a range check.  We don't need one
			 if the range of values of the right hand side is a
			 subset of the range of values of the left hand side.
			 */
			getbounds(tpl, &llo, &lhi);
			getbounds(tpr, &rlo, &rhi);
			if (llo > rlo || lhi < rhi)
				genrck(tpl);
		}
	}
}

static void genrck(register struct type *tp)
{
	/*	Generate a range check descriptor for type "tp" when
	 necessary. Return its label.
	 */

	arith lb, ub;
	register label o1;
	int newlabel = 0;

	if (options['R'])
		return;

	getbounds(tp, &lb, &ub);

	if (tp->tp_fund == T_SUBRANGE)
	{
		if (!(o1 = tp->sub_rck))
		{
			tp->sub_rck = o1 = ++data_label;
			newlabel = 1;
		}
	}
	else if (!(o1 = tp->enm_rck))
	{
		tp->enm_rck = o1 = ++data_label;
		newlabel = 1;
	}
	if (newlabel)
	{
		C_df_dlb(o1);
		C_rom_cst(lb);
		C_rom_cst(ub);
	}
	C_lae_dlb(o1, (arith) 0);
	C_rck(word_size);
}

void CodePExpr(register struct node *nd)
{
	/*	Generate code to push the value of the expression "nd"
	 on the stack.
	 */

	struct desig designator;
	struct type *tp = BaseType(nd->nd_type);

	designator = InitDesig;
	CodeExpr(nd, &designator, NO_LABEL );
	if (tp->tp_fund & (T_ARRAY | T_RECORD))
		CodeAddress(&designator);
	else
		CodeValue(&designator, nd->nd_type);
}

void CodeDAddress(struct node *nd)
{
	/*	Generate code to push the address of the designator "nd"
	 on the stack.
	 */

	struct desig designator;

	designator = InitDesig;
	CodeDesig(nd, &designator);
	CodeAddress(&designator);
}

void CodeDStore(register struct node *nd)
{
	/*	Generate code to store the expression on the stack
	 into the designator "nd".
	 */

	struct desig designator;

	designator = InitDesig;
	CodeDesig(nd, &designator);
	CodeStore(&designator, nd->nd_type);
}

static void RegisterMessages(register struct def *df)
{
	register struct type *tp;

	for (; df; df = df->df_nextinscope)
	{
		if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG))
		{
			/* Examine type and size
			 */
			tp = BaseType(df->df_type);
			if (df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER)
				C_ms_reg(df->var_off, pointer_size, reg_pointer, 0);

			else if (df->df_flags & D_LOOPVAR)
				C_ms_reg(df->var_off, tp->tp_size, reg_loop, 2);
			else if (tp->tp_fund & T_NUMERIC)
				C_ms_reg(df->var_off, tp->tp_size,
						tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
		}
	}
}