ack/lang/occam/comp/code.c

/*
 * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
 * See the copyright notice in the ACK home directory, in the file "Copyright".
 */
#include "em.h"
#include "expr.h"
#include "symtab.h"
#include "sizes.h"
#include "Lpars.h"
#include "code.h"

extern err;

static void subscript();
enum addr_val { address, value };

void code_val(e) register struct expr *e;
/* Compile e for its value, which is put on the stack. */
{
	register struct expr *left, *right;

	if (err) return;

	switch(e->kind) {
	case E_NODE:
		left=e->u.node.left;
		right=e->u.node.right;

		switch (e->u.node.op) {
		case '+':
		case '-':
		case '*':
		case '/':
		case BS:
			code_val(left);
			code_val(right);
			xxi(e->u.node.op);
			break;
		case '<':
		case '>':
		case LE:
		case GE:
		case NE:
		case '=':
			code_val(left);
			code_val(right);
			cmi();
			Txx(e->u.node.op);
			break;
		case AFTER:
			code_val(left);
			code_val(right);
			xxi('-');
			cvw();
			tst();
			Txx('>');
			break;
		case BA:
			code_val(left);
			code_val(right);
			and();
			break;
		case BO:
			code_val(left);
			code_val(right);
			ior();
			break;
		case BX:
			code_val(left);
			code_val(right);
			xor();
			break;
		case AND:
		case OR: {
			int T=0, F=0, L=0;

			code_bool(e, positive, &T, &F);
			Label(T);
			Loc(-1L);
			branch(&L);
			Label(F);
			Loc(0L);
			Label(L);
			}break;
		case LS:
			code_val(left);
			code_val(right);
			cvw();
			sli();
			break;
		case RS:
			code_val(left);
			code_val(right);
			cvw();
			sri();
			break;
		case '~':
			code_val(left);
			ngi();
			break;
		case NOT:
			code_val(left);
			com();
			break;
		case '[':
			subscript(e, value);
			break;
		}
		break;
	case E_VAR: {
		register struct symbol *var=e->u.var;

		if (var->type&T_BUILTIN)
			Loe(var->info.vc.st.builtin, var->info.vc.offset);
		else
		if (var->info.vc.st.level==curr_level)
			if (var->type&T_PARAM && (var->type&T_TYPE)!=T_VALUE)
				Lil(var->info.vc.offset);
			else
				Lol(var->info.vc.offset);
		else {
			if (var->info.vc.offset<0)
				lxl(curr_level-var->info.vc.st.level);
			else
				lxa(curr_level-var->info.vc.st.level);
			if (var->type&T_PARAM && (var->type&T_TYPE)!=T_VALUE)
				Lif(var->info.vc.offset);
			else
				Lof(var->info.vc.offset);
		}
		}break;
	case E_CONST:
		Loc(e->u.const);
		break;
	case E_NOW:
		cal("now");
		lfr(vz);
		break;
	}
}

static void subscript(e, av) register struct expr *e; enum addr_val av;
/* Produce code to compute the address or value of e->left[e->right] or
 * the address of e->left[e->right->left FOR e->right->right].
 */
{
	register char *des;
	register struct expr *left;
	register struct expr *index;

	code_addr(left=e->u.node.left);

	if ((index=e->u.node.right)->kind==E_NODE && index->u.node.op==FOR)
		index=index->u.node.left;

	if (left->arr_siz==0) {
		if ((left->type&T_TYPE)==T_CHAN)
			des="maxcdes";
		else
			des= e->type&T_BYTE ? "maxbdes" : "maxwdes";
	} else {
		register lsiz=left->arr_siz;

		if (left->type&T_BYTE && !(e->type&T_BYTE))
			lsiz/=vz;
		else
		if (!(left->type&T_BYTE) && e->type&T_BYTE)
			lsiz*=vz;

		if (e->type&T_ARR)
			lsiz-=(e->arr_siz -1);

		if (constant(index)) {
			if (index->u.const<0 || index->u.const>=lsiz) {
				warning("constant index outside vector");
				lin();
				loc(0);
				trp();
			}
		} else {
			loc(lsiz);

			if ((left->type&T_TYPE)==T_CHAN)
				des="chandes";
			else
				des= e->type&T_BYTE ? "bytedes" : "worddes";
			ste(des, wz);
		}
	}
	if (constant(index)) {
		register offset=index->u.const;

		if ((left->type&T_TYPE)==T_CHAN)
			offset*=(wz+vz);
		else
		if ( !(e->type&T_BYTE) )
			offset*=vz;

		if (av==address)
			adp(offset);
		else {
			if (e->type&T_BYTE) {
				adp(offset);
				loi(1);
				cwv();
			} else
				Lof(offset);
		}
	} else {
		code_val(index);
		cvw();
		lin();
		lae(des, 0);
		if (av==address) {
			aar();
		} else {
			lar();
			if (e->type&T_BYTE) cwv();
		}
	}
}

void code_addr(e) register struct expr *e;
/* The address of e is wat we want. */
{
	if (err) return;

	switch(e->kind) {
	case E_NODE:
		subscript(e, address);
		break;
	case E_VAR: {	/* variable or channel */
		register struct symbol *var=e->u.var;

		if (var->type&T_BUILTIN)
			lae(var->info.vc.st.builtin, var->info.vc.offset);
		else
		if (var->info.vc.st.level==curr_level)
			if (var->type&T_PARAM
			    && (var->type&(T_TYPE|T_ARR))!=T_VALUE)
				Lolp(var->info.vc.offset);
			else
				lal(var->info.vc.offset);
		else {
			if (var->info.vc.offset<0)
				lxl(curr_level-var->info.vc.st.level);
			else
				lxa(curr_level-var->info.vc.st.level);
			if (var->type&T_PARAM
			    && (var->type&(T_TYPE|T_ARR))!=T_VALUE)
				Lofp(var->info.vc.offset);
			else
				adp(var->info.vc.offset);
		}
		} break;
	case E_TABLE:
	case E_BTAB:
		laedot(e->u.tab);
		break;
	}
}

void code_bool(e, pos, T, F)
	register struct expr *e;
	register pos;
	register int *T, *F;
/* if e = pos then
	fall through or jump to T;
   else
	jump to F;
   fi
 */
{
	register Default=0;

	if (err) return;

	if (e->kind==E_NODE) {
		register struct expr *left=e->u.node.left;
		register struct expr *right=e->u.node.right;

		switch(e->u.node.op) {
		case '<':
		case '>':
		case LE:
		case GE:
		case NE:
		case '=':
		case AFTER:
			code_val(left);
			code_val(right);
			bxx(pos, e->u.node.op, new_label(F));
			break;
		case AND:
		case OR:
			if ((e->u.node.op==AND && pos)
			 || (e->u.node.op==OR && !pos)
			) {
				int L=0;
				code_bool(left, pos, &L, F);
				Label(L);
				code_bool(right, pos, T, F);
			} else {
				int L=0;
				code_bool(left, !pos, &L, T);
				Label(L);
				code_bool(right, pos, T, F);
			}
			break;
		case NOT:
			code_bool(left, !pos, T, F);
			break;
		default:
			Default=1;
		}
	} else
		Default=1;

	if (Default) {
		code_val(e);
		if (vz>wz) {
			ldc0();
			cmi();
		} else
			tst();
		if (pos) zeq(new_label(F)); else zne(new_label(F));
	}
}

void code_assignment(e) register struct expr *e;
/* e->left := e->right */
{
	register struct expr *left=e->u.node.left;
	register struct expr *right=e->u.node.right;

	if (left->type&T_ARR) {
		register siz=left->arr_siz;

		code_addr(right);
		code_addr(left);
		blm(left->type&T_BYTE ? siz : siz*vz);
	} else {
		code_val(right);
		code_addr(left);
		sti(left->type&T_BYTE ? 1 : vz);
	}
}

void code_input(e) register struct expr *e;
/* Input one v from c ? v0; v1; ... */
{
	if (e==nil) {
		lae("any", 0);
		cal("chan_in");
		asp(pz);
	} else
	if (e->type&T_ARR) {
		loc(e->arr_siz);
		code_addr(e);
		cal(e->type&T_BYTE ? "c_ba_in" : "c_wa_in");
		asp(pz+wz);
	} else {
		code_addr(e);
		cal(e->type&T_BYTE ? "cbyte_in" : "chan_in");
		asp(pz);
	}
}

void code_output(e) register struct expr *e;
/* Output one e from c ? e0; e1; ... */
{
	if (e==nil) {
		Loc(0L);
		cal("chan_out");
		asp(vz);
	} else
	if (e->type&T_ARR) {
		loc(e->arr_siz);
		code_addr(e);
		cal(e->type&T_BYTE ? "c_ba_out" : "c_wa_out");
		asp(pz+wz);
	} else {
		code_val(e);
		cal("chan_out");
		asp(vz);
	} 
}

void code_any(e, NO) register struct expr *e; int *NO;
/* Test if the channel (push address on stack) has input. If not so remove the
 * channel pointer and jump to NO.  Otherwise input values.
 */
{
	int YES=0;
	register struct expr_list *elp;

	if (err) return;

	code_addr(e->u.io.chan);
	cal("chan_any");
	lfr(wz);
	tst();
	zne(new_label(&YES));
	asp(pz);
	branch(NO);
	Label(YES);
	elp=e->u.io.args;
	while (elp!=nil) {
		code_input(elp->arg);
		elp=elp->next;
	}
	asp(pz);
}

void code_void(e) register struct expr *e;
/* Assignment, I/O, or procedure call. */
{
	if (err) return;

	switch (e->kind) {
	case E_NODE:	/* Must be assignment */
		code_assignment(e);
		break;
	case E_IO: {
		register struct expr_list *elp;

		code_addr(e->u.io.chan);

		elp=e->u.io.args;
		while (elp!=nil) {
			if (e->u.io.out)
				code_output(elp->arg);
			else
				code_input(elp->arg);
			elp=elp->next;
		}
		asp(pz);
		}
		break;
	case E_CALL: {
		register size=0;
		register struct expr_list *elp=e->u.call.args;
		register struct symbol *proc=e->u.call.proc->u.var;
		register struct par_list *pars=proc->info.proc.pars;

		while (elp!=nil) {
			if (pars->type==T_VALUE) {
				code_val(elp->arg);
				size+=vz;
			} else {
				code_addr(elp->arg);
				size+=pz;
			}
			elp=elp->next;
			pars=pars->next;
		}
		if (proc->type&T_BUILTIN) {
			cal(proc->info.proc.st.builtin);
			asp(size);
		} else {
			if (proc->info.proc.st.level>curr_level) {
				/* Call down */
				lor0();
			} else
			if (proc->info.proc.st.level==curr_level) {
				/* Call at same level */
				Lolp(0);
			} else {
				/* Call up */
				lxa(curr_level-proc->info.proc.st.level);
				loi(pz);
			}
			cal(proc_label(proc->info.proc.label, proc->name));
			asp(size+pz);
			if (proc->info.proc.file!=curr_file) fil();
		}
		} break;
	}
}

void prologue(proc) register struct symbol *proc;
/* Open up the scope for a new proc definition. */
{
	static P=0;

	if (err) return;

	proc->info.proc.st.level= ++curr_level;
	proc->info.proc.file= curr_file;
	proc->info.proc.label= ++P;
	curr_offset=min_offset=0;
	pro(proc_label(proc->info.proc.label, proc->name));
	if (curr_level==1) fil();
}

void epilogue(proc) register struct symbol *proc;
/* Close the scope of a proc def. */
{
	if (err) return;

	curr_level--;
	ret(0);
	_end(-min_offset);
}

void rep_init(v, e1, e2, r_info)
	struct symbol *v;
	register struct expr *e1, *e2;
	register struct replicator *r_info;
/* Compile v=[e1 FOR e2].  Info tells rep_test what decisions rep_init makes. */
{
	if (err) return;

	r_info->BEGIN=r_info->END=0;

	code_val(e1);
	Stl(v->info.vc.offset);

	if (!constant(e1) || !constant(e2)) {
		if (constant(e2) && word_constant(e2->u.const)) {
			r_info->counter=memory(wz);
			loc((int) e2->u.const);
			stl(r_info->counter);
		} else {
			r_info->counter=memory(vz);
			code_val(e2);
			Stl(r_info->counter);
		}
	}
	if (!constant(e2) || e2->u.const<=0L)
		branch(&r_info->END);
	Label(new_label(&r_info->BEGIN));
}

void rep_test(v, e1, e2, r_info)
	register struct symbol *v;
	register struct expr *e1, *e2;
	register struct replicator *r_info;
{
	if (err) return;

	Inl(v->info.vc.offset);

	if (constant(e1) && constant(e2)) {
		Lol(v->info.vc.offset);
		Loc(e1->u.const+e2->u.const);
		if (vz>wz) {
			cmi();
			zlt(r_info->BEGIN);
		} else
			blt(r_info->BEGIN);
		Label(r_info->END);
	} else {
		if (constant(e2) && word_constant(e2->u.const)) {
			del(r_info->counter);
			Label(r_info->END);
			lol(r_info->counter);
			tst();
		} else {
			Del(r_info->counter);
			Label(r_info->END);
			Lol(r_info->counter);
			if (vz>wz) {
				ldc0();
				cmi();
			} else
				tst();
		}
		zgt(r_info->BEGIN);
	}
}

void chan_init(info, arr_siz) union type_info *info; int arr_siz;
/* Garbage disposal unit for fresh channels. */
{
	if (err) return;

	loc(arr_siz);
	lal(info->vc.offset);
	cal("c_init");
	asp(wz+pz);
}

void leader()
{
	init();
	openfile((char *) nil);
	magic();
	meswp();
	maxdes();
}

void header()
{
	exp("main");
	pro("main");
	init_rt();
	main_fil();
}

void trailer()
{
	if (err)
		meserr();
	else {
		loc(0);
		ret(wz);
		_end(-min_offset);
	}
	closefile();
}