Initial revision

lang/occam/comp/Makefile

@@ -0,0 +1,27 @@
+GFILES=		occam.g
+PRIMARY=	occam.o Lpars.o keytab.o lex.yy.o code.o em.o
+SECUNDARY=	symtab.o expr.o builtin.o
+TERTIARY=	report.o
+LLOPT=
+LIBRARY=	-lln libemk.a libsystem.a
+
+all:
+		make dummy
+		make oc
+
+dummy:		$(GFILES)
+		LLgen $(LLOPT) $(GFILES)
+		touch dummy
+
+oc:		$(PRIMARY) $(SECUNDARY) $(TERTIARY)
+		$(CC) -o oc $(PRIMARY) $(SECUNDARY) $(TERTIARY) $(LIBRARY)
+
+lex.yy.c:	lex.l
+		lex lex.l
+
+$(PRIMARY):			Lpars.h
+occam.o keytab.o:		token.h
+occam.o $(SECUNDARY):		symtab.h expr.h
+$(PRIMARY) $(SECUNDARY):	sizes.h
+occam.o code.o:			code.h
+code.o em.o:			em.h

lang/occam/comp/builtin.c

@@ -0,0 +1,74 @@
+#include <stdio.h>
+#include "symtab.h"
+#include "expr.h"
+#include "sizes.h"
+
+void init_builtins()
+/* Insert all builtin names into the outermost symbol table (first statement
+ * is sym_down() ).  Note that this table is never destroy()ed, so static
+ * initializers may be used.
+ */
+{
+	union type_info info;
+
+	static char file[]="file";
+
+	static struct par_list
+	open_list[] = {
+		{ &open_list[1], nil, T_VAR },		/* File descriptor */
+		{ &open_list[2], nil, T_VALUE|T_ARR },	/* File name */
+		{ nil,		 nil, T_VALUE|T_ARR }	/* "r", "w", "a" */
+	},
+	close_list[]= {
+		{ nil,		 nil, T_VALUE }		/* File descriptor */
+	},
+	exit_list[]= {
+		{ nil,		 nil, T_VALUE }		/* Exit code */
+	};
+
+	sym_down();	/* Add level of symbols above all others */
+
+	/* CHAN file[20], input=file[0], output=file[1], error=file[2]: */
+
+	info.vc.st.builtin=file;
+	info.vc.offset=0;
+	insert(file, T_CHAN|T_ARR|T_BUILTIN, _NFILE, info);
+
+	info.vc.st.builtin=file;
+	info.vc.offset=0;
+	insert("input", T_CHAN|T_BUILTIN, 1, info);
+
+	info.vc.st.builtin=file;
+	info.vc.offset=wz+pz;
+	insert("output", T_CHAN|T_BUILTIN, 1, info);
+
+	info.vc.st.builtin=file;
+	info.vc.offset=2*(wz+pz);
+	insert("error", T_CHAN|T_BUILTIN, 1, info);
+
+	/* DEF EOF= -1, TEXT= -2, RAW= -3: */
+
+	info.const=new_const(-1L);
+	insert("EOF", T_CONST|T_BUILTIN, 0, info);
+
+	info.const=new_const(-2L);
+	insert("TEXT", T_CONST|T_BUILTIN, 0, info);
+
+	info.const=new_const(-3L);
+	insert("RAW", T_CONST|T_BUILTIN, 0, info);
+
+	/* PROC open(VAR fd, VALUE name[], mode[])= .... : */
+	info.proc.st.builtin="b_open";
+	info.proc.pars=open_list;
+	insert("open", T_PROC|T_BUILTIN, 0, info);
+
+	/* PROC close(VALUE fd)= .... : */
+	info.proc.st.builtin="b_close";
+	info.proc.pars=close_list;
+	insert("close", T_PROC|T_BUILTIN, 0, info);
+
+	/* PROC exit(VALUE code)= .... : */
+	info.proc.st.builtin="b_exit";
+	info.proc.pars=exit_list;
+	insert("exit", T_PROC|T_BUILTIN, 0, info);
+}

lang/occam/comp/code.c

@@ -0,0 +1,607 @@
+#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();
+}

lang/occam/comp/code.h

@@ -0,0 +1,19 @@
+struct replicator {	/* Info transferred from rep_init to rep_test */
+	int counter;
+	int BEGIN;
+	int END;
+};
+
+void rep_init(), rep_test();
+
+void code_val(), code_addr(), code_void();
+void code_assignment(), code_input(), code_any(), code_output();
+
+void code_bool();
+#define positive 1	/* Use positive logic for boolean expression */
+#define negative 0	/* Use negative logic, i.e. 0 = true */
+
+void epilogue(), prologue();
+void leader(), header(), trailer();
+
+void chan_init();

lang/occam/comp/em.c

@@ -0,0 +1,405 @@
+#include <stdio.h>
+#include "sizes.h"
+#include "Lpars.h"
+#include "em_arith.h"
+#include "em_label.h"
+#include "em.h"
+
+/* This file is used to shield code.c as much as possible from em dependant
+ * details.  It introduces some call overhead but not enough for a coffee
+ * break. (Sorry)
+ * Note that functions with a leading upper case letter normally decide between
+ * word or double word arith.
+ */
+
+int wz, pz;
+static Lab=0;
+char *malloc();
+
+void init()
+{
+	C_init((arith) wz, (arith) pz);
+}
+
+void openfile(file) char *file;
+{
+	C_open(file);
+}
+
+void meswp()
+{
+	C_mes_begin(2);
+	C_cst((arith) wz);
+	C_cst((arith) pz);
+	C_mes_end();
+}
+
+void maxdes()
+{
+	C_df_dnam("maxcdes");
+	rom(wz, 0L); rom(wz, -1L); rom(wz, (long) (wz+pz));
+	C_df_dnam("maxwdes");
+	rom(wz, 0L); rom(wz, -1L); rom(wz, (long) vz);
+	C_df_dnam("maxbdes");
+	rom(wz, 0L); rom(wz, -1L); rom(wz, 1L);
+}
+
+int new_label(L) register *L;
+{
+	if (*L==0) *L= ++Lab;
+	return *L;
+}
+
+void Label(L) register L;
+{
+	if (L!=0) C_df_ilb((label) L);
+}
+
+static Dot_label=0;
+
+int new_dot_label(L) int *L;
+{
+	return *L= ++Dot_label;
+}
+
+void dot_label(L) int L;
+{
+	C_df_dlb((label) L);
+}
+
+void branch(L) int *L;
+{
+	C_bra((label) new_label(L));
+}
+
+char *proc_label(L, name) register L; register char *name;
+{
+	static char *lab=nil;
+	register char *n;
+
+	if (lab!=nil) free(lab);
+
+	lab=malloc(strlen(name)+(1+sizeof(int)*3+1));
+		/* That is: P<L><name>\0 */
+
+	sprintf(lab, "P%d", L);
+
+	n=lab+strlen(lab);
+
+	while (*name!=0) {
+		*n++ = *name=='.' ? '_' : *name;
+		name++;
+	}
+	*n=0;
+	return lab;
+}
+
+void magic()	/* magic? should be called invisible */
+{
+	C_magic();
+}
+
+void cwv()
+{
+	if (vz>wz) {
+		C_loc((arith) wz);
+		C_loc((arith) vz);
+		C_cii();
+	}
+}
+
+void cvw()
+{
+	if (vz>wz) {
+		C_loc((arith) vz);
+		C_loc((arith) wz);
+		C_cii();
+	}
+}
+
+void Loc(const) long const;
+{
+	if (vz>wz) C_ldc((arith) const); else C_loc((arith) const);
+}
+
+void Lol(offset) int offset;
+{
+	if (vz>wz) C_ldl((arith) offset); else C_lol((arith) offset);
+}
+
+void Lolp(offset) int offset;
+{
+	if (pz>wz) C_ldl((arith) offset); else C_lol((arith) offset);
+}
+
+void Lil(offset) register offset;
+{
+	if (vz>wz) {
+		Lolp(offset);
+		C_loi((arith) vz);
+	} else
+		C_lil((arith) offset);
+}
+
+void Lof(offset) int offset;
+{
+	if (vz>wz) C_ldf((arith) offset); else C_lof((arith) offset);
+}
+
+void Lofp(offset) int offset;
+{
+	if (pz>wz) C_ldf((arith) offset); else C_lof((arith) offset);
+}
+
+void Lif(offset) register offset;
+{
+	Lofp(offset);
+	C_loi((arith) vz);
+}
+
+void Stl(offset) int offset;
+{
+	if (vz>wz) C_sdl((arith) offset); else C_stl((arith) offset);
+}
+
+void Inl(offset) register offset;
+{
+	if (vz>wz) {
+		C_ldl((arith) offset);
+		C_ldc((arith) 1);
+		C_adi((arith) vz);
+		C_sdl((arith) offset);
+	} else
+		C_inl((arith) offset);
+}
+
+void Del(offset) register offset;
+{
+	if (vz>wz) {
+		C_ldl((arith) offset);
+		C_ldc((arith) 1);
+		C_sbi((arith) vz);
+		C_sdl((arith) offset);
+	} else
+		C_del((arith) offset);
+}
+
+void Loe(name, offset) char *name; int offset;
+{
+	if (vz>wz)
+		C_lde_dnam(name, (arith) offset);
+	else
+		C_loe_dnam(name, (arith) offset);
+}
+
+typedef int (*pfi)();
+
+static int operators[]=	{ '<', '>', '=',  GE,  LE,  NE };
+
+extern C_blt(), C_bgt(), C_beq(), C_bge(), C_ble(), C_bne();
+extern C_tlt(), C_tgt(), C_teq(), C_tge(), C_tle(), C_tne();
+extern C_zlt(), C_zgt(), C_zeq(), C_zge(), C_zle(), C_zne();
+
+static pfi C_bxx[]= { C_blt, C_bgt, C_beq, C_bge, C_ble, C_bne };
+static pfi C_txx[]= { C_tlt, C_tgt, C_teq, C_tge, C_tle, C_tne };
+static pfi C_zxx[]= { C_zlt, C_zgt, C_zeq, C_zge, C_zle, C_zne };
+
+void bxx(pos, op, L) register pos, op, L;
+{
+	register i;
+
+	if (op==AFTER) {
+		C_sbi((arith) vz);
+		if (vz>wz) {
+			C_ldc((arith) 0);
+			C_cmi((arith) vz);
+		}
+		if (pos) C_zle((label) L); else C_zgt((label) L);
+	} else {
+		for (i=0; operators[i]!=op; i++) ;
+		if (pos && (i+=3)>=6) i-=6;
+		if (vz>wz) {
+			C_cmi((arith) vz);
+			(C_zxx[i])((label) L);
+		} else {
+			(C_bxx[i])((label) L);
+		}
+	}
+}
+
+void Txx(op) register int op;
+{
+	register i;
+
+	for (i=0; operators[i]!=op; i++) ;
+
+	(C_txx[i])();
+	cwv();
+	C_ngi((arith) vz);
+}
+
+extern C_adi(), C_sbi(), C_mli(), C_dvi(), C_rmi();
+
+void xxi(op) register op;
+{
+	static int operators[]=	{ '+',   '-',   '*',   '/',   BS };
+	static pfi C_xxi[]=	{ C_adi, C_sbi, C_mli, C_dvi, C_rmi };
+	register i;
+
+	for (i=0; operators[i]!=op; i++) ;
+
+	(C_xxi[i])((arith) vz);
+}
+
+void aar()			{	C_aar((arith) wz); }
+void adp(offset) int offset;	{	C_adp((arith) offset); }
+void and()			{	C_and((arith) vz); }
+void asp(size) int size;	{	C_asp((arith) size); }
+void blm(size) int size;	{	C_blm((arith) size); }
+void blt(lab) int lab;		{	C_blt((label) lab); }
+void cal(lab) char *lab;	{	C_cal(lab); }
+void cmi()			{	C_cmi((arith) vz); }
+void com()			{	C_com((arith) vz); }
+void del(offset) int offset;	{	C_del((arith) offset); }
+void _end(size) int size;	{	C_end((arith) size); }
+void exp(lab) char *lab;	{	C_exp(lab); }
+void ior()			{	C_ior((arith) vz); }
+void lae(lab, offset) char *lab; int offset;
+				{	C_lae_dnam(lab, (arith) offset); }
+void laedot(lab) int lab;	{	C_lae_dlb((label) lab, (arith) 0); }
+void lal(offset) int offset;	{	C_lal((arith) offset); }
+void lar()			{	C_lar((arith) wz); }
+void ldc0()			{	C_ldc((arith) 0); }
+void ldl(offset) int offset;	{	C_ldl((arith) offset); }
+void lfr(size) int size;	{	C_lfr((arith) size); }
+void loc(cst) int cst;		{	C_loc((arith) cst); }
+void loi(size) int size;	{	C_loi((arith) size); }
+void lol(offset) int offset;	{	C_lol((arith) offset); }
+void lor0()			{	C_lor((arith) 0); }
+void lxa(offset) int offset;	{	C_lxa((arith) offset); }
+void lxl(offset) int offset;	{	C_lxl((arith) offset); }
+void meserr()			{	C_mes_begin(0); C_mes_end(); }
+void ngi()			{	C_ngi((arith) vz); }
+void pro(lab) char *lab;	{	C_pro_narg(lab); }
+void ret(size) int size;	{	C_ret((arith) size); }
+void init_rt()			{	C_cal("init");	}
+void sli()			{	C_sli((arith) vz); }
+void sri()			{	C_sri((arith) vz); }
+void ste(lab, offset) char *lab; int offset;
+				{	C_ste_dnam(lab, (arith) offset); }
+void sti(size) int size;	{	C_sti((arith) size); }
+void stl(offset) int offset;	{	C_stl((arith) offset); }
+void trp()			{	C_trp(); }
+void tst()			{	/* No flags in EM */ }
+void xor()			{	C_xor((arith) vz); }
+void zeq(lab) int lab;		{	C_zeq((label) lab); }
+void zgt(lab) int lab;		{	C_zgt((label) lab); }
+void zlt(lab) int lab;		{	C_zlt((label) lab); }
+void zne(lab) int lab;		{	C_zne((label) lab); }
+
+char *itoa(i) long i;
+{
+	static char a[sizeof(long)*3];
+	sprintf(a, "%D", i);
+	return a;
+}
+
+void rom(size, c) int size; long c;
+{
+	C_rom_icon(itoa(c), (arith) size);
+}
+
+void lin()
+{
+	static oldline=0;
+	extern yylineno;
+
+	if (yylineno!=oldline)
+		C_lin((arith) (oldline=yylineno));
+}
+
+static struct ftree {
+	char *file;
+	int lab;
+	struct ftree *left, *right;
+} std_f = { "stdin", 0, nil, nil }, *curr_f= &std_f, *main_f=nil;
+
+char *curr_file="stdin";
+
+static void do_fil(f) struct ftree *f;
+{
+	if (f->lab==0) {
+		dot_label(new_dot_label(&f->lab));
+		C_rom_scon(f->file, (arith) strlen(f->file));
+	}
+	C_fil_dlb((label) f->lab);
+}
+
+void fil()
+{
+	do_fil(curr_f);
+}
+
+void main_fil()
+{
+	do_fil(main_f==nil ? &std_f : main_f);
+}
+
+int set_file(f) char *f;
+{
+	char *strcpy();
+	static struct ftree *ftop=nil;
+	register struct ftree *pf, **apf= &ftop;
+	register cmp;
+
+	while ((pf= *apf)!=nil && (cmp=strcmp(f, pf->file))!=0)
+		apf= cmp<0 ? &pf->left : &pf->right;
+
+	if (pf==nil) {
+		*apf= pf= (struct ftree *) malloc(sizeof *pf);
+		pf->file=strcpy(malloc(strlen(f)+1), f);
+		pf->lab=0;
+		pf->left=pf->right=nil;
+	}
+	curr_f=pf;
+	curr_file=pf->file;
+	if (main_f==nil) {
+		main_f=curr_f;
+		return 0;
+	} else
+		return curr_f!=main_f;
+}
+
+void par_begin()
+{
+	C_lal((arith) curr_offset);
+	C_cal("pc_begin");
+	C_asp((arith) pz);
+}
+
+void par_fork(NONZERO) int *NONZERO;
+{
+	C_cal("pc_fork");
+	C_lfr((arith) wz);
+	C_zne((label) new_label(NONZERO));
+}
+
+void resumenext()
+{
+	C_cal("resumene");
+}
+
+void no_deadlock()
+{
+	C_zre_dnam("deadlock", (arith) 0);
+}
+
+void par_end()
+{
+	C_cal("parend");
+}
+
+void closefile()
+{
+	C_close();
+}

lang/occam/comp/em.h

@@ -0,0 +1,21 @@
+#ifndef nil
+#define nil 0
+#endif
+
+#define word_constant(c)	(-32768L<=(c) && (c)<=32767L)
+void Label(), dot_label(), branch();
+int new_label(), new_dot_label();
+char *proc_label();
+extern char *curr_file;
+
+void cwv(), cvw();
+void bxx(), Loc(), Lol(), Lolp(), Lil(), Lof(), Lofp(), Lif();
+void Txx(), xxi(), Stl(), Inl(), Del(), Loe();
+void cmi(), ngi(), and(), ior(), xor(), sli(), sri(), com(), lar(), lxl();
+void lxa(), lfr(), ste(), lae(), aar(), lal(), adp(), ldc0(), zeq(), zne();
+void zlt(), zgt(), blm(), sti(), cal(), asp(), loc(), lor0(), loi(), pro();
+void ret(), _end(), stl(), laedot(), del(), lol(), ldl(), meswp(), meserr();
+void init_rt(), exp(), rom(), blt(), magic(), lin(), tst(), fil(), trp();
+void main_fil(), init(), openfile(), closefile(), maxdes();
+
+void par_begin(), par_fork(), par_end(), resumenext(), no_deadlock();

lang/occam/comp/expr.c

@@ -0,0 +1,471 @@
+#include "symtab.h"
+#include "sizes.h"
+#include "expr.h"
+#include "Lpars.h"
+
+static void rvalue(), assignable(), inputable(), outputable(), subscriptable();
+static void assigned();
+
+/* The new_* functions make use of the used() and assinged() functions to
+ * make known what is done to a variable.
+ */
+
+struct expr *new_node(op, left, right, byte)
+	int op;
+	register struct expr *left, *right;
+	int byte;
+/* Makes a new node with given operator, left and right operand.
+ * Constant folding is done if possible.
+ */
+{
+	if (op!=FOR && constant(left) && (right==nil || constant(right))) {
+		register long lc, rc;
+
+		lc=left->u.const;
+		rc=right->u.const;
+
+		switch (op) {
+		case '+':	lc+=rc; break;
+		case '-':	lc-=rc; break;
+		case '*':	lc*=rc; break;
+		case '/':	if (rc==0L)
+					report("division by zero");
+				else
+					lc/=rc;
+				break;
+		case BS:	lc%=rc; break;
+		case '<':	lc= lc<rc ? -1L : 0L; break;
+		case '>':	lc= lc>rc ? -1L : 0L; break;
+		case LE:	lc= lc<=rc ? -1L : 0L; break;
+		case GE:	lc= lc>=rc ? -1L : 0L; break;
+		case NE:	lc= lc!=rc ? -1L : 0L; break;
+		case '=':	lc= lc==rc ? -1L : 0L; break;
+		case AFTER:	lc= (lc-rc)>0 ? -1L : 0L; break;
+		case BA:	lc&=rc; break;
+		case BO:	lc|=rc; break;
+		case BX:	lc^=rc; break;
+		case AND:	lc= lc&&rc ? -1L : 0L; break;
+		case OR:	lc= lc||rc ? -1L : 0L; break;
+		case LS:	lc<<=rc; break;
+		case RS:	lc>>=rc; break;
+		case '~':	lc= -lc; break;
+		case NOT:	lc= ~lc; break;
+		default:
+			report("illegal operator on constants");
+		}
+		destroy(right);
+
+		left->u.const=lc;
+		return left;
+	} else {
+		register struct expr *pe;
+		int type=0, arr_siz=1;
+
+		switch (op) {
+		case '+':	case '-':	case '*':	case '/':
+		case BS:	case '<':	case '>':	case LE:
+		case GE:	case NE:	case '=':	case AFTER:
+		case BA:	case BO:	case BX:	case AND:
+		case OR:	case LS:	case RS:
+			rvalue(left);
+			rvalue(right);
+			type=T_VALUE;
+			break;
+		case '~':
+		case NOT:
+			rvalue(left);
+			type=T_VALUE;
+			break;
+		case AS:
+			assignable(left, right);
+			type=T_VOID;
+			break;
+		case '[':
+			subscriptable(left, right, byte, &type, &arr_siz);
+			break;
+		}
+		pe= (struct expr *) malloc(sizeof *pe);
+
+		pe->kind=E_NODE;
+		pe->type=type;
+		pe->arr_siz=arr_siz;
+		pe->u.node.op=op;
+		pe->u.node.left=left;
+		pe->u.node.right=right;
+
+		return pe;
+	}
+}
+
+struct expr *new_var(var)
+	register struct symbol *var;
+/* Given a variable an expression node is constructed.  Note the changes in
+ * type!  T_VAR becomes T_VALUE with flag T_LVALUE.
+ */
+{
+	register struct expr *pe;
+
+	pe= (struct expr *) malloc(sizeof *pe);
+
+	pe->kind=E_VAR;
+
+	if ((var->type&T_TYPE)==T_VAR || var->type&T_NOTDECL) {
+		pe->type=(var->type&(~T_TYPE));
+		pe->type|=T_VALUE|T_LVALUE;
+	} else
+		pe->type=var->type;
+
+	pe->arr_siz=var->arr_siz;
+
+	pe->u.var=var;
+
+	return pe;
+}
+
+struct expr *new_const(const)
+	long const;
+/* Make a constant, which is a VALUE, of course. */
+{
+	register struct expr *pe;
+
+	pe= (struct expr *) malloc(sizeof *pe);
+
+	pe->kind=E_CONST;
+	pe->type=T_VALUE;
+	pe->u.const=const;
+
+	return pe;
+}
+
+struct expr *new_table(kind, tab)
+	register kind;
+	register struct table *tab;
+/* One table is being made, it is no doubt a VALUEd ARRay, but maybe even a
+ * BYTE array.  A label is reserved for it and the individual elements are
+ * rommified.
+ */
+{
+	register struct expr *pe;
+
+	pe= (struct expr *) malloc(sizeof *pe);
+
+	pe->kind=kind;
+	pe->type=T_VALUE|T_ARR;
+	if (kind==E_BTAB) pe->type|=T_BYTE;
+	dot_label(new_dot_label(&pe->u.tab));
+
+	pe->arr_siz=0;
+	while (tab!=nil) {
+		register struct table *junk=tab;
+		
+		rom(kind==E_BTAB ? 1 : vz, tab->val);
+
+		tab=tab->next;
+		pe->arr_siz++;
+		free(junk);
+	}
+
+	return pe;
+}
+
+struct expr *copy_const(e) struct expr *e;
+/* If you double it up, you've got one you can throw away.  (Or do something
+ * useful with).
+ */
+{
+	register struct expr *c;
+
+	c= (struct expr *) malloc(sizeof *c);
+
+	*c= *e;
+	return c;
+}
+
+struct expr *new_now()
+/* Now is the time to make a VALUE cell for the clock. */
+{
+	register struct expr *pe;
+
+	pe= (struct expr *) malloc(sizeof *pe);
+
+	pe->kind=E_NOW;
+	pe->type=T_VALUE;
+
+	return pe;
+}
+
+struct expr *new_io(out, chan, args)
+	int out;
+	register struct expr *chan;
+	struct expr_list *args;
+/* Either c ? v0; v1; v2; ... (out=0) or c ! e0; e1; e2; ... (out=1). */
+{
+	register struct expr *pe;
+
+	if ( ( (chan->type&T_TYPE) != T_CHAN || (chan->type&T_ARR) )
+		&& ! (chan->type&T_NOTDECL)
+	)
+		report("channel variable expected");
+	used(chan);
+
+	pe= (struct expr *) malloc(sizeof *pe);
+
+	pe->kind=E_IO;
+	pe->type=T_VOID;
+	pe->u.io.out=out;
+	pe->u.io.chan=chan;
+	pe->u.io.args=args;
+
+	return pe;
+}
+
+struct expr *new_call(proc, args)
+	struct expr *proc;
+	struct expr_list *args;
+/* Dial proc(arg1, arg2, ...) and you'll hear the tone of this function.
+ * Dialing yourself is not allowed, but it will work if you ignore the
+ * compiler generated noise.
+ */
+{
+	register struct expr *pe;
+
+	pe= (struct expr *) malloc(sizeof *pe);
+
+	used(proc);
+
+	check_recursion(proc);
+
+	pe->kind=E_CALL;
+	pe->type=T_VOID;
+	pe->u.call.proc=proc;
+	pe->u.call.args=args;
+
+	return pe;
+}
+
+void table_add(aapt, val) register struct table ***aapt; long val;
+/* Adds a value to a table using a hook to a hook. */
+{
+	register struct table *pt;
+
+	pt= (struct table *) malloc(sizeof *pt);
+
+	pt->val=val;
+	pt->next= **aapt;
+
+	**aapt=pt;
+	*aapt= &pt->next;
+}
+
+void expr_list_add(aaelp, arg)
+	register struct expr_list ***aaelp;
+	struct expr *arg;
+/* Another add, this time for actual arguments and the like. */
+{
+	register struct expr_list *elp;
+
+	elp= (struct expr_list *) malloc(sizeof *elp);
+
+	elp->arg=arg;
+	elp->next= **aaelp;
+	**aaelp=elp;
+	*aaelp= &elp->next;
+}
+
+void check_io(out, arg) int out; struct expr *arg;
+{
+	if (out)
+		outputable(arg);
+	else
+		inputable(arg);
+}
+
+void check_wait(e) struct expr *e;
+{
+	if ((e->type&T_TYPE)!=T_VALUE)
+		report("WAIT process needs valued operand");
+}
+
+static void assigned(e) register struct expr *e;
+/* Tries to tell e that it is assigned to. */
+{
+	if (e->kind==E_VAR || (e->kind==E_NODE && e->u.node.op=='['
+		&& (e=e->u.node.left)->kind==E_VAR)
+	) {
+		register struct symbol *var;
+
+		if ((var=e->u.var)->type&T_REP) {
+			warning("replicator index %s may not be assigned",
+				var->name);
+			var->type&= ~T_REP;
+		}
+		var->type|=T_ASSIGNED;
+	}
+}
+
+void used(e) register struct expr *e;
+{
+	if (e->kind==E_VAR || (e->kind==E_NODE && e->u.node.op=='['
+		&& (e=e->u.node.left)->kind==E_VAR)
+	) {
+		register struct symbol *var;
+
+		if ( ! ( (var=e->u.var)->type&(T_ASSIGNED|T_BUILTIN))
+		    && (var->type&T_TYPE)==T_VAR
+		    && var->info.vc.st.level==curr_level)
+			warning("%s used before assigned", var->name);
+		var->type|=(T_USED|T_ASSIGNED);
+	}
+}
+
+static void rvalue(e) register struct expr *e;
+{
+	if ((e->type&T_TYPE)!=T_VALUE || e->type&T_ARR)
+		report("illegal operand of arithmetic operator");
+	used(e);
+}
+
+static void assignable(l, r) register struct expr *l, *r;
+/* See if l can be assigned r. */
+{
+	if ( ! ( (l->type&T_LVALUE && (r->type&T_TYPE)==T_VALUE
+		  && (l->type&T_ARR)==(r->type&T_ARR))
+		|| (l->type|r->type)&T_NOTDECL
+	))
+		report("operands of assignment are not conformable");
+	else
+	if (l->type&T_ARR && ! ( (l->type|r->type)&T_NOTDECL ) ) {
+		register lsiz=l->arr_siz, rsiz=r->arr_siz;
+
+		if (lsiz!=0 && rsiz!=0 && lsiz!=rsiz)
+			report("arrays have incompatible sizes");
+	}
+	used(r);
+	assigned(l);
+	
+}
+
+static void inputable(e) struct expr *e;
+{
+	if ( ! (e->type&T_LVALUE) )
+		report("operand of input process can't be assigned");
+
+	assigned(e);
+}
+
+static void outputable(e) struct expr *e;
+{
+	if ( ! ( (e->type&T_TYPE)==T_VALUE ) )
+		report("operand of output process has no value");
+	used(e);
+}
+
+static void subscriptable(l, r, byte, atype, arr_siz)
+	register struct expr *l, *r;
+	register byte;
+	int *atype, *arr_siz;
+/* Tries to subscript l by r, returning type and array size for slices. */
+{
+	register type= (l->type&T_TYPE)|byte;
+
+	if ( !(l->type&(T_ARR|T_NOTDECL) ) )
+		report("indexing on a non-array");
+	else
+	if ( ! ( (r->type&T_TYPE)==T_VALUE
+		|| (r->kind==E_NODE && r->u.node.op==FOR)
+	) )
+		report("index is not computable");
+
+	type|=(l->type&T_LVALUE);
+
+	if (r->kind==E_NODE && r->u.node.op==FOR) {
+		type|=T_ARR;
+		if (r->u.node.right->kind!=E_CONST)
+			report("slice must be of constant size");
+		else
+			*arr_siz=r->u.node.right->u.const;
+		used(r->u.node.left);
+	} else
+		used(r);
+	*atype=type;
+}
+
+void check_param(aform, act, err)
+	struct par_list **aform;
+	register struct expr *act;
+	int *err;
+/* Test if formal parameter *aform corresponds with actual act.  Err returns
+ * error status.  The aform hook is set to the next formal after the check.
+ */
+{
+	register struct par_list *form= *aform;
+	register struct expr *left;
+	register struct symbol *var;
+	static char NONCORR[]="actual and formal parameter don't correspond";
+
+	if (form==nil) {
+		if (! *err) {
+			report("too many actual parameters");
+			*err=1;
+		}
+		return;
+	}
+
+	if ((form->type&T_ARR)!=(act->type&T_ARR) && !(act->type&T_NOTDECL) ) {
+			report(NONCORR);
+	} else {
+		switch (form->type&T_TYPE) {
+		case T_VAR:
+			if ( ! (
+				(act->type&T_TYPE)==T_VALUE
+				&& act->type&T_LVALUE
+				&& !(act->type&T_BYTE)
+			))
+				report(NONCORR);
+			assigned(act);
+			used(act);
+			break;
+		case T_CHAN:
+			if((act->type&T_TYPE)!=T_CHAN && !(act->type&T_NOTDECL))
+				report(NONCORR);
+			used(act);
+			break;
+		case T_VALUE:
+			if ((act->type&T_TYPE)!=T_VALUE)
+				report(NONCORR);
+			used(act);
+			break;
+		}
+	}
+	*aform= form->next;
+}
+
+void destroy(e) register struct expr *e;
+/* Opposite of making. */
+{
+	if (e!=nil) {
+		switch (e->kind) {
+		case E_NODE:
+			destroy(e->u.node.left);
+			destroy(e->u.node.right);
+			break;
+		case E_IO:
+		case E_CALL:
+			destroy(e->kind==E_IO ? e->u.io.chan : e->u.call.proc);
+			{
+				register struct expr_list *elp, *junk;
+
+				elp= e->kind==E_IO ? e->u.io.args : e->u.call.args;
+
+				while (elp!=nil) {
+					destroy(elp->arg);
+					junk=elp;
+					elp=elp->next;
+					free(junk);
+				}
+			}
+			break;
+		}
+		free(e);
+	}
+}

lang/occam/comp/expr.h

@@ -0,0 +1,61 @@
+#define E_NODE	0
+#define E_VAR	1	/* Variable *or* channel */
+#define E_CONST	2
+#define E_TABLE	3
+#define E_BTAB	4
+#define E_NOW	5
+#define E_IO	6
+#define E_CALL	7
+
+struct table {
+	long	val;
+	struct table	*next;
+};
+
+struct expr;
+
+struct expr_list {
+	struct expr *arg;
+	struct expr_list	*next;
+};
+
+struct expr {
+	short kind;
+	short type;
+	int arr_siz;
+	union {
+		struct {
+			int op;
+			struct expr *left, *right;
+		} node;
+
+		struct symbol *var;
+
+		long const;
+
+		int tab;
+
+		struct {
+			int out;
+			struct expr *chan;
+			struct expr_list *args;
+		} io;
+
+		struct {
+			struct expr *proc;
+			struct expr_list *args;
+		} call;
+	} u;
+};
+
+struct expr *new_node(), *new_var(), *new_const(), *new_table(), *new_now();
+struct expr *new_io(), *new_call(), *copy_const();
+void table_add(), expr_list_add();
+void check_param(), check_io(), check_wait();
+void destroy(), used();
+
+#define valueless(e)		(((e)->type&T_TYPE)==T_VOID)
+#define valued(e)		(((e)->type&T_TYPE)==T_VALUE)
+#define input_process(e)	((e)->kind==E_IO && !(e)->u.io.out)
+#define constant(e)		((e)->kind==E_CONST)
+#define arr_constant(e)		((e)->kind==E_TABLE || (e)->kind==E_BTAB)

lang/occam/comp/keytab.c

@@ -0,0 +1,82 @@
+/*		keytab.c		*/
+# include "Lpars.h"
+# include <ctype.h>
+
+# define NKEYWORDS	((sizeof keytab) / (sizeof *keytab))
+# define MAXKEYLEN	8
+
+typedef struct {
+	int k_token;
+	char *k_str;
+} KTAB;
+
+KTAB keytab[] = {
+	{ AFTER,	"AFTER"	   }, { ALLOCATE,	"ALLOCATE" },
+	{ ALT,		"ALT" 	   }, { AND,		"AND" 	   },
+	{ ANY,		"ANY" 	   }, { BYTE,		"BYTE" 	   },
+	{ CHAN,		"CHAN"	   }, { DEF,		"DEF"	   },
+	{ FALSE,	"FALSE"	   }, { FOR,		"FOR"	   },
+	{ IF,		"IF"	   }, { LOAD,		"LOAD"	   },
+	{ NOT,		"NOT"	   }, { NOW,		"NOW"	   },
+	{ OR,		"OR"	   }, { PAR,		"PAR"	   },
+	{ PLACED,	"PLACED"   }, { PORT,		"PORT"	   },
+	{ PRI,		"PRI"	   }, { PROC,		"PROC"	   },
+	{ SEQ,		"SEQ"	   }, { SKIP,		"SKIP"	   },
+	{ TABLE,	"TABLE"	   }, { TRUE,		"TRUE"	   },
+	{ VALUE,	"VALUE"	   }, { VAR,		"VAR"	   },
+	{ WAIT,		"WAIT"	   }, { WHILE,		"WHILE"	   },
+};
+
+/*
+ *	The table of keywords is searched for the occurence of `str',
+ *	if found the corresponding token number is returned,
+ *	otherwise IDENTIFIER is the returned token number.
+ */
+keyword(str) char *str;
+{
+	register int high= NKEYWORDS-1;
+	register int low= 0;
+	register int i, cmp;
+	char *lowerupper();
+	register char *key;
+
+	if ((key=lowerupper(str))==0) return IDENTIFIER;
+
+	do {
+		i= (high+low) / 2;
+		if ((cmp= strcmp(key, keytab[i].k_str)) == 0) break;
+		else if (cmp > 0) low= i+1;
+		else high= i-1;
+	} while (low <= high);
+	
+	return low<=high ? keytab[i].k_token : IDENTIFIER;
+}
+
+char *lowerupper(str) register char *str;
+{
+	static char keyword[MAXKEYLEN+1];
+	register char *key=keyword;
+
+	if (islower(*str)) {
+		do
+			*key++ = toupper(*str++);
+		while (key<keyword+MAXKEYLEN && islower(*str));
+	} else {
+		do
+			*key++ = *str++;
+		while (key<keyword+MAXKEYLEN && isupper(*str));
+	}
+	*key=0;
+
+	return *str==0 ? keyword : 0;
+}
+
+char *keyname(key) register int key;
+{
+	register KTAB *kp;
+
+	for (kp= keytab; kp< keytab+NKEYWORDS; kp++)
+		if (kp->k_token == key) return kp->k_str;
+
+	return 0;
+}

lang/occam/comp/lex.l

@@ -0,0 +1,344 @@
+%{
+/*	lex.l		*/
+# include <ctype.h>
+# include "token.h"
+# include "Lpars.h"
+
+# define TAB	8	/* Size of a acsii tab (\t) in spaces */
+# if (TAB&(TAB-1))!=0
+# define TABSTOP(ind)	((ind)+TAB-(ind)%TAB)
+# else
+# define TABSTOP(ind)	(((ind)+TAB)&(~(TAB-1)))
+# endif
+
+char *malloc(), *strcpy();
+
+struct token token;
+int ind=0;		/* Indentation level of current line */
+static int tab=0;	/* First indentation found */
+
+int included=0;		/* Is current file included? */
+%}
+
+%%
+'((\*[^\n])|([^'\n*]))*'	{
+	if ((token.t_lval=char_constant(yytext+1))== -1L) 
+		report("%s not a character constant", yytext);
+
+	return CHAR_CONST;
+}
+'[^'\n]*'?			{
+	report("missing '.");
+	token.t_lval= -1L;
+
+	return CHAR_CONST;
+}
+\"((\*[^\n])|([^"\n*]))*\"	{
+	char *string();
+
+	token.t_sval=string(yytext);
+
+	return STRING;
+}
+\"[^"\n]*\"?			{
+	report("missing \".");
+	token.t_sval="";
+
+	return STRING;
+}
+#[ \t]*"line"?[ \t]*[0-9]+[ \t]*\"[^"\n]*\"	{
+	set_line_file(yytext);
+	tab=0;
+}
+#[A-Fa-f0-9]+			{
+	long hex_number();
+
+	token.t_lval=hex_number(yytext+1);
+
+	return NUMBER;
+}
+[0-9]+				{
+	long number();
+
+	token.t_lval=number(yytext);
+
+	return NUMBER;
+}
+[A-Za-z][A-Za-z0-9.]*		{
+	register key;
+
+	if ((key=keyword(yytext))==IDENTIFIER)
+		token.t_sval=strcpy(malloc(yyleng+1), yytext);
+	
+	return key;
+}
+\n[ \f\t]*/"--"			{/* Line with only a comment, don't set tab */}
+
+\n[ \f\t]*			{
+
+	ind=indentation(yytext+1);
+	if (tab==0)
+		tab=ind;
+	else
+	if (ind%tab!=0)
+		warning("indentation not on a %d space boundary", tab);
+}
+[ \f\t]				{ /* Nothing */ }
+[-=<>:,;+*/\[\]()?!&]		return yytext[0];
+
+"\\"				return BS;
+":="				return AS;
+"<="				return LE;
+">="				return GE;
+"<>"				return NE;
+"<<"				return LS;
+">>"				return RS;
+"/\\"				return BA;
+"\\/"				return BO;
+"><"				return BX;
+
+"--"[^\n]*			{ /* Comment is skipped */ }
+.				{
+	warning((' '<=yytext[0] && yytext[0]<0177) ? "%s'%c')" : "%soctal: %o)",
+		"bad character seen (", yytext[0]&0377);
+}
+%%
+char *string(s) char *s;
+{
+	register c;
+	register char *p= s;
+	char *str= s;
+	
+	str++; p++;
+	while (*str != '"') {
+		if ((c=character(&str)) != -1)
+			*p++= c;
+		else
+			return "";
+	}
+
+	*p=0;
+	*s=p-(s+1);
+	return s;
+}
+
+long number(s) register char *s;
+{
+	static char max_str[]="2147483647";
+	int  maxlen=sizeof max_str-1;
+	long atol();
+	long num;
+
+	while (*s=='0') { /* skip leading nulls */
+		*s++;
+		yyleng--;
+	}
+
+	if (*s==0)
+		num=0L;
+	else {
+		if ((yyleng>maxlen) || (yyleng==maxlen && strcmp(s, max_str)>0))
+			warning("integer constant overflow.");
+
+		num=atol(s);
+	}
+
+	return num;
+}
+		
+long hex_number(s) register char *s;
+{
+	long number=0L;
+
+	while (*s)
+		number=(number<<4)+hextoint(*s++);
+
+	return number;
+}
+
+int hextoint(c) register c;
+{
+	register val;
+	
+	if (islower(c))
+		val=(c-'a')+10;
+	else
+	if (isupper(c))
+		val=(c-'A')+10;
+	else
+		val=c-'0';
+	
+	return val;
+}
+
+int character(S) register char **S;
+{
+	register char *s= *S;
+	register c, cc;
+
+	if ((c= *s++)=='*') {
+		switch (c= *s++) {
+		case 'c':
+			cc='\r';
+			break;
+		case 'n':
+			cc='\n';
+			break;
+		case 't':
+			cc='\t';
+			break;
+		case 's':
+			cc=' ';
+			break;
+		case '#':
+			if (isxdigit(c= *s++) && isxdigit(*s)) {
+				cc= (hextoint(c)<<4)+hextoint(*s++);
+				break;
+			} else {
+				report("two digit hexadecimal const expected.");
+				return -1;
+			}
+		default:
+			cc=c;
+			break;
+		}
+	} else
+		cc=c;
+	
+	*S=s;
+	return cc;
+}
+	
+int char_constant(s) char *s;
+{
+	register cc;
+
+	cc=character(&s);
+
+	return (*s=='\'' && cc!= -1) ? cc : -1;
+}
+
+int indentation(s) register char *s;
+{
+	register in=0, c;
+
+	while (c= *s++) {
+		if (c=='\t')
+			in=TABSTOP(in);
+		else
+		if (c=='\f')
+			in=0;
+		else
+			in++;
+	}
+	
+	return in;
+}
+
+int tabulated(oind, ind) register oind, ind;
+{
+	if (tab>0 && ind>oind+tab)
+		warning("process' indentation too large (changed to %d tab%s)",
+			oind/tab+1, oind>=tab ? "s" : "");
+	return ind>oind;
+}
+
+int rep_tk=0;
+struct token rep_token;
+
+void repeat_token(tk)
+{
+	rep_tk=tk;
+	rep_token=token;
+}
+
+scanner()
+{
+	register tk;
+
+	if (rep_tk>0) {
+		tk=rep_tk;;
+		rep_tk=0;
+		token=rep_token;
+		return tk;
+	} else
+		return yylex();
+}
+
+char *tokenname(tk, inst) register tk, inst;
+{
+	if (tk<0400) {
+		static char c[7];
+
+		if (' '<tk && tk<='~')
+			sprintf(c, "'%c'", tk);
+		else
+			sprintf(c, "'*#%02x'", tk);
+		return c;
+	} else {
+		switch (tk) {
+			char *keyname();
+			char fake_id[1+sizeof(int)*3+1];
+			static fake_cnt=0;
+		default:
+			return keyname(tk);
+		case IDENTIFIER:
+			if (inst) {
+				sprintf(fake_id, "_%d", ++fake_cnt);
+				token.t_sval=strcpy(malloc(strlen(fake_id)+1),
+					fake_id);
+				return "IDENTIFIER";
+			} else
+				return token.t_sval;
+		case NUMBER:
+		case CHAR_CONST:
+			token.t_lval=0L;
+			return "NUMBER";
+		case STRING:
+			if (inst) {
+				token.t_sval=malloc(1);
+				token.t_sval[0]=0;
+			} else
+				free(token.t_sval);
+			return "STRING";
+		case AS:	case LE:	case GE:	case NE:
+		case LS:	case RS:	case BA:	case BO:
+		case BX:	case BS:	{
+			static int op[]= {
+				AS, LE, GE, NE, LS, RS, BA, BO, BX, BS
+			};
+			static char *opc[]= {
+				":=", "<=", ">=", "<>", "<<", ">>", "/\\",
+				"\\/", "><", "\\"
+			};
+			register i;
+			static char qopc[5];
+
+			for (i=0; op[i]!=tk; i++) ;
+			sprintf(qopc, "'%s'", opc[i]);
+			return qopc;
+			}
+		}
+	}
+}
+
+set_line_file(l) register char *l;
+{
+	register char *file;
+
+	while (*l<'0' || *l>'9') l++;
+
+	yylineno=0;
+	while ('0'<=*l && *l<='9')
+		yylineno=yylineno*10+(*l++ - '0');
+
+	yylineno--;
+
+	while (*l++!='"');
+
+	file=l;
+	while (*l++!='"');
+	*--l=0;
+
+	included=set_file(file);
+}

lang/occam/comp/occam.g

@@ -0,0 +1,684 @@
+/*	OCCAM		*/
+{
+#include "token.h"
+#include "symtab.h"
+#include "expr.h"
+#include "code.h"
+#include "sizes.h"
+
+#define MAXERRORS	10	/* Maximum number of insert/delete errors */
+
+static void nonconst(), nonpositive(), rep_cleanup(), check_assoc();
+void init_builtins();
+
+extern int yylineno, LLsymb;
+union type_info info, none;
+}
+%token	AFTER, ALLOCATE, ALT, AND, ANY, BYTE, CHAN, DEF, FALSE, FOR, IF, LOAD;
+%token	NOT, NOW, OR, PAR, PLACED, PORT, PRI, PROC, SEQ, SKIP, TABLE, TRUE;
+%token	VALUE, VAR, WAIT, WHILE;
+%token	IDENTIFIER, NUMBER, CHAR_CONST, STRING;
+%token	AS, LE, GE, NE, LS, RS, BA, BO, BX, BS;
+
+%start	occam, program;
+
+program	: 			{	init_builtins();
+					header();
+				}
+	  process
+	;
+
+process	: primitive
+	| construct
+	|			{	sym_down(); }
+	  declaration ':' process
+				{	sym_up(); }
+	;
+
+primitive { struct expr *e; } :
+	  statement(&e)		{	if (!valueless(e))
+						report("primitive may not have a value");
+					code_void(e);
+					destroy(e);
+				}
+	| WAIT val_expr(&e)	{	int BEGIN=0, END=0, TEST=0;
+					check_wait(e);
+					no_deadlock();
+					branch(&TEST);
+					Label(new_label(&BEGIN));
+					resumenext();
+					Label(TEST);
+					code_bool(e, positive, &END, &BEGIN);
+					Label(END);
+					destroy(e);
+				}
+	| SKIP
+	;
+
+guard(register *F;)		{	struct expr *e1, *e2;
+					register full_guard=0;
+					int T=0;
+		static char EXPECT_INP[]="input process expected as guard";
+				} :
+	  expression(&e1)
+	  [	  '&'		{	full_guard=1;
+					if (!valued(e1))
+						report("boolean part of guard has no value");
+					code_bool(e1, positive, &T, F);
+					Label(T);
+				}
+		  [	  statement(&e2)
+				{	if (!input_process(e2))
+						report(EXPECT_INP);
+					code_any(e2, F);
+					destroy(e2);
+				}
+			  | WAIT val_expr(&e2)
+				{	check_wait(e2);
+					code_bool(e2, positive, &T, F);
+					Label(T);
+					destroy(e2);
+				}
+			  | SKIP
+		  ]
+	  ]?
+				{	if (!full_guard) {
+						if (!input_process(e1))
+							report(EXPECT_INP);
+						code_any(e1, F);
+					}
+					destroy(e1);
+				}
+	| WAIT val_expr(&e1)
+				{	check_wait(e1);
+					code_bool(e1, positive, &T, F);
+					Label(T);
+					destroy(e1);
+				}
+	| SKIP
+	;
+
+guarded_process(register *END;)	{	struct symbol *v;
+					struct expr *e1, *e2;
+					struct replicator to_test;
+					register line, oind;
+					int F=0;
+				} :
+	  guard(&F) process	{	branch(END);
+					Label(F);
+				}
+	| ALT			{	line=yylineno; oind=ind; }
+	  [	  %if (line==yylineno)
+		  replicator(&v, &e1, &e2)
+				{	rep_init(v, e1, e2, &to_test); }
+		  guarded_process(END)
+				{	rep_test(v, e1, e2, &to_test);
+					rep_cleanup(e1, e2);
+				}
+		|
+		  [ %while (tabulated(oind, ind)) guarded_process(END) ]*
+	  ]
+	;
+
+conditional(register *END; )	{	struct symbol *v;
+					struct expr *e1, *e2;
+					struct replicator to_test;
+					register line, oind;
+					int T=0, F=0;
+				} :
+	  val_expr(&e1)		{	if (!valued(e1))
+						report("conditional needs valued expression");
+					code_bool(e1, positive, &T, &F);
+					Label(T);
+					destroy(e1);
+				}
+	  process
+				{	branch(END);
+					Label(F);
+				}
+	| IF			{	line=yylineno; oind=ind; }
+	  [	  %if (line==yylineno)
+		  replicator(&v, &e1, &e2)
+				{	rep_init(v, e1, e2, &to_test); }
+		  conditional(END)
+				{	rep_test(v, e1, e2, &to_test);
+					rep_cleanup(e1, e2);
+				}
+		|
+		  [ %while (tabulated(oind, ind)) conditional(END) ]*
+	  ]
+	;
+
+replicator(register struct symbol **s; register struct expr **e1, **e2; )
+				{	register char *index; }:
+	  IDENTIFIER		{	index=token.t_sval; }
+	  '=' '[' val_expr(e1) FOR val_expr(e2) ']'
+				{	if (!valued(*e1) || !valued(*e2))
+						report("replicator needs valued expressions");
+					sym_down();
+					var_memory(&info, T_VAR, 1);
+					*s=insert(index,
+					T_VAR|T_REP|T_USED|T_ASSIGNED, 1, info);
+				}
+	;
+
+construct			{	struct symbol *v;
+					struct expr *e1, *e2;
+					struct replicator to_test;
+					register line, oind;
+					int BEGIN=0, END=0, NONZERO;
+				}:
+	  SEQ			{	line=yylineno; oind=ind; }
+	  [	  %if (line==yylineno)
+		  replicator(&v, &e1, &e2)
+				{	rep_init(v, e1, e2, &to_test); }
+		  process
+				{	rep_test(v, e1, e2, &to_test);
+					rep_cleanup(e1, e2);
+				}
+		|
+		  [ %while (tabulated(oind, ind)) process ]*
+	  ]
+	| PRI ?
+	  [	  PAR		{	line=yylineno; oind=ind;
+					par_begin();
+				}
+		  [	  %if (line==yylineno)
+			  replicator(&v, &e1, &e2)
+				{	rep_init(v, e1, e2, &to_test);
+					NONZERO=0;
+					par_fork(&NONZERO);
+				}
+			  process
+				{	branch(&END);
+					Label(NONZERO);
+					rep_test(v, e1, e2, &to_test);
+					rep_cleanup(e1, e2);
+				}
+			|
+			  [ %while (tabulated(oind, ind))
+				{	NONZERO=0;
+					par_fork(&NONZERO);
+				}
+				  process
+				{	branch(&END);
+					Label(NONZERO);
+				}
+			  ]*
+		  ]
+				{	Label(END);
+					par_end();
+				}
+		| ALT		{	line=yylineno; oind=ind;
+					no_deadlock();
+					Label(new_label(&BEGIN));
+				}
+		  [	  %if (line==yylineno)
+			  replicator(&v, &e1, &e2)
+				{	rep_init(v, e1, e2, &to_test); }
+			  guarded_process(&END)
+				{	rep_test(v, e1, e2, &to_test);
+					rep_cleanup(e1, e2);
+				}
+			|
+			  [ %while (tabulated(oind, ind)) guarded_process(&END)
+			  ]*
+		  ]
+				{	resumenext();
+					branch(&BEGIN);
+					Label(END);
+				}
+	  ]
+	| IF			{	line=yylineno; oind=ind; }
+	  [	  %if (line==yylineno)
+		  replicator(&v, &e1, &e2)
+				{	rep_init(v, e1, e2, &to_test); }
+		  conditional(&END)
+				{	rep_test(v, e1, e2, &to_test);
+					rep_cleanup(e1, e2);
+				}
+		|
+		  [ %while (tabulated(oind, ind)) conditional(&END) ]*
+	  ]
+				{	Label(END); }
+	| WHILE val_expr(&e1)	{	if (!valued(e1))
+						report("WHILE needs valued expression");
+					branch(&END);
+					Label(new_label(&BEGIN));
+				}
+	  process
+				{	int DONE=0;
+					Label(END);
+					code_bool(e1, negative, &DONE, &BEGIN);
+					Label(DONE);
+					destroy(e1);
+				}
+	;
+
+subscript(register *byte; register struct expr **e; )
+				{	struct expr *e1;
+					register slice=0, err=0;
+				} :
+	  '['			{	*byte=0; }
+	  [	  BYTE		{	*byte=T_BYTE; }
+	  ]?
+	  val_expr(e)		{	if (!valued(*e))
+						err++;
+				}
+	  [	  FOR expression(&e1)
+	  			{	static char siz[]="slize size";
+					if (!constant(e1)) {
+						if (!err)
+							nonconst(siz);
+						destroy(e1);
+						e1=new_const(0L);
+					} else
+					if (e1->u.const<=0)
+						nonpositive(siz);
+					*e=new_node(FOR, *e, e1);
+					slice=1;
+				}
+	  ]?
+	  ']'
+				{	if (err)
+						report(slice ?
+				"slice must be '[' value FOR constant ']'" :
+				"subscript needs valued expression");
+				}
+	;
+
+chan	{ register type, arr_siz=1; register char *name; struct expr *e; }:
+	  IDENTIFIER		{	type=T_CHAN;
+					name=token.t_sval;
+				}
+	  [	  '[' expression(&e) ']'
+				{	static char siz[]="channel array size";
+					if (!constant(e))
+						nonconst(siz);
+					else
+					if (e->u.const<0)
+						nonpositive(siz);
+					else
+						arr_siz=e->u.const;
+					destroy(e);
+					type|=T_ARR;
+				}
+	  ]?
+				{	chan_memory(&info, arr_siz);
+					chan_init(&info, arr_siz);
+					insert(name, type, arr_siz, info);
+				}
+	;
+
+var				{	register type, byte=0, arr_siz=1;
+					register char *name;
+					struct expr *e;
+				}:
+	  IDENTIFIER		{	type=T_VAR; name=token.t_sval; }
+	  [	  '['
+		  [	  BYTE	{	byte=T_BYTE; }
+		  ]?
+		  expression(&e) ']'
+				{	static char siz[]="variable array size";
+					if (!constant(e))
+						nonconst(siz);
+					else
+					if (e->u.const<=0)
+						nonpositive(siz);
+					else
+						arr_siz=e->u.const;
+					destroy(e);
+					type|=T_ARR|byte;
+				}
+	  ]?
+				{	var_memory(&info, type, arr_siz);
+					insert(name, type, arr_siz, info);
+				}
+	;
+
+const_def { register char *name; struct expr *e; }:
+	  IDENTIFIER		{	name=token.t_sval; }
+	  '=' expression(&e)
+				{	if (!constant(e) && !arr_constant(e))
+						nonconst("expression in constant definition");
+					info.const=e;
+					insert(name, T_CONST|T_USED, 0, info);
+				}
+	;
+
+form_parm(register struct par_list ***aapars; register *g_type;)
+				{	register char *name;
+					register type= *g_type;
+				}:
+	  [	  VAR		{	type=T_VAR|T_ASSIGNED|T_USED; }
+		| CHAN		{	type=T_CHAN; }
+		| VALUE		{	type=T_VALUE|T_ASSIGNED; }
+	  ]?
+	  IDENTIFIER		{
+					if (type<0) {
+						report("VAR, CHAN or VALUE expected");
+						type=T_VAR;
+					}
+					name=token.t_sval;
+					*g_type=type;
+				}
+	  [	  '[' ']'
+				{	type|=T_ARR; }
+	  ]?
+				{	pars_add(aapars, type&(T_TYPE|T_ARR),
+					  insert(name, type|T_PARAM, 0, none));
+				}
+	;
+
+form_parms(struct par_list **apars;) { int type= -1; }:
+	  '(' form_parm(&apars, &type)
+	  [	  ',' form_parm(&apars, &type)
+	  ]*
+	  ')'
+	;
+
+declaration:
+	  VAR
+	  var [ ',' var ]*
+	| CHAN
+	  chan [ ',' chan ]*
+	| DEF
+	  const_def [ ',' const_def ]*
+	| proc_declaration
+	;
+	
+proc_declaration		{	struct par_list *pars=nil;
+					register struct symbol *proc;
+					int OVER=0;
+					register old_min_offset;
+				}:
+	  PROC IDENTIFIER	{	branch(&OVER);
+					proc=insert(token.t_sval,
+						T_PROC|T_RECURS, 0, none);
+					old_min_offset=min_offset;
+					sym_down();
+					prologue(proc);
+				}
+	  form_parms(&pars) ?	{	form_offsets(pars);
+					proc->info.proc.pars=pars;
+				}
+	  '=' process		{	epilogue(proc);
+					sym_up();
+					proc->type&= ~T_RECURS;
+					min_offset=old_min_offset;
+					Label(OVER);
+				}
+	;
+
+vector_constant(register struct expr **e;)
+				{	struct table *pt=nil, **apt= &pt;
+					register Tlen=0;
+				}:
+	  table(e)
+	| STRING		{	register char *ps= token.t_sval;
+					register len;
+
+					Tlen+= len= (*ps++ & 0377);
+					while (--len>=0)
+						table_add(&apt, (long) *ps++);
+				}
+	  [ %while (1)	  STRING
+				{	register char *ps= token.t_sval;
+					register len;
+
+					Tlen+= len= (*ps++ & 0377);
+					while (--len>=0)
+						table_add(&apt, (long) *ps++);
+				}
+	  ]*
+				{	apt= &pt;
+					table_add(&apt, (long) Tlen);
+					*e=new_table(E_BTAB, pt);
+				}
+	;
+
+item(register struct expr **e;)
+				{	struct expr *e1;
+					register struct symbol *var;
+					struct par_list *pars=nil;
+					register line, oind;
+					int byte, err=0, subs_call=0;
+					struct expr_list *elp=nil, **aelp= &elp;
+				}:
+	  IDENTIFIER		{	line=yylineno;
+					oind=ind;
+					var=searchall(token.t_sval);
+
+					if (var_constant(var))
+						*e=copy_const(var->info.const);
+					else {
+						if (var_proc(var))
+							pars=var->info.proc.pars;
+						*e=new_var(var);
+					}
+				}
+	  [ %while (line==yylineno || tabulated(oind, ind))
+		  [	  subscript(&byte, &e1)
+				{	*e=new_node('[', *e, e1, byte); }
+			| '('	{	if (!var_declared(var)) {
+						var->type=T_PROC|T_USED|T_NOTDECL;
+						var->info.proc.pars=nil;
+						err=1;
+					}
+					if (!var_proc(var)) {
+						report("%s is not a named process",
+							var->name);
+						err=1;
+					}
+				}
+			  expression(&e1)
+				{ 	check_param(&pars, e1, &err);
+					expr_list_add(&aelp, e1);
+				}
+			  [	  ',' expression(&e1)
+				{ 	check_param(&pars, e1, &err);
+					expr_list_add(&aelp, e1);
+				}
+			  ]*
+				{
+					if (pars!=nil)
+						report("too few actual parameters");
+				}
+			  ')'
+				{	*e=new_call(*e, elp); }
+		  ]
+				{	subs_call=1; }
+	  ]?
+				{	if (!subs_call && var_proc(var)) {
+						if (pars!=nil)
+							report("no actual parameters");
+						*e=new_call(*e, nil);
+					}
+				}
+	| vector_constant(e)
+	  [	  subscript(&byte, &e1)
+				{	*e=new_node('[', *e, e1, byte); }
+	  ]?
+	;
+
+statement(register struct expr **e;)
+				{	struct expr *e1;
+					struct expr_list *elp=nil, **aelp= &elp;
+					register out;
+				}:
+	  item(e)
+	  [	  AS expression(&e1)
+				{	*e=new_node(AS, *e, e1); }
+		| [
+			  '?'	{	out=0; }
+			| '!'	{	out=1; }
+		  ]
+		  io_arg(&e1)
+				{	if (e1!=nil) check_io(out, e1);
+					expr_list_add(&aelp, e1);
+				}
+		  [ %while (1) ';' io_arg(&e1)
+				{	if (e1!=nil) check_io(out, e1);
+					expr_list_add(&aelp, e1);
+				}
+		  ]*
+				{	*e=new_io(out, *e, elp); }
+	  ]?
+	;
+
+io_arg(struct expr **e; ) :
+	  expression(e)
+	| ANY			{	*e=nil;	}
+	;
+
+table(register struct expr **e;)	
+				{	struct table *pt=nil, **apt= &pt;
+					struct expr *e1;
+					register type;
+				}:
+	  TABLE '['		{	type=E_TABLE; }
+	  [	  BYTE		{	type=E_BTAB; }
+	  ]?
+	  expression(&e1)	{	if (!constant(e1))
+						nonconst("table element");
+					else
+						table_add(&apt, e1->u.const);
+					destroy(e1);
+				}
+	  [	  ',' expression(&e1)
+				{	if (!constant(e1))
+						nonconst("table element");
+					else
+						table_add(&apt, e1->u.const);
+					destroy(e1);
+				}
+	  ]*
+				{	*e=new_table(type, pt); }
+	  ']'
+	;
+
+arithmetic_op:	'+' | '-' | '*' | '/' | BS
+	;
+
+comparison_op:	'<' | '>' | LE | GE | NE | '=' | AFTER
+	;
+
+logical_op:	BA | BO | BX
+	;
+
+boolean_op:	AND | OR
+	;
+
+shift_op:	LS | RS
+	;
+
+monadic_op(register *op;):
+	  '-'			{	*op='~'; }
+	| NOT			{	*op=NOT; }
+	;
+
+operator: arithmetic_op | comparison_op | logical_op | boolean_op | shift_op
+	;
+
+element(register struct expr **e;) :
+	  %default NUMBER	{	*e=new_const(token.t_lval); }
+	| statement(e)
+	| TRUE			{	*e=new_const(-1L); }
+	| FALSE			{	*e=new_const(0L); }
+	| NOW			{	*e=new_now(); }
+	| CHAR_CONST		{	*e=new_const(token.t_lval); }
+	| '(' expression(e) ')' {	if (valueless(*e))
+						warning("primitive should not be parenthesized");
+				}
+	;
+
+expression(register struct expr **e;)
+				{	int op=0;
+					struct expr *e1;
+				}:
+	  element(e)
+	  [ %while (1)		{	if (op!=0) check_assoc(op, LLsymb);
+					op=LLsymb;
+				}
+		  operator element(&e1)
+				{	*e=new_node(op, *e, e1); }
+	  ]*
+	| monadic_op(&op) element(&e1)
+				{	*e=new_node(op, e1, nil); }
+	;
+
+val_expr(register struct expr **e;) :
+	  expression(e)		{	used(*e); }
+	;
+
+%lexical scanner;
+{
+int err=0;
+#include <stdio.h>
+
+main(argc, argv) register argc; register char **argv;
+{
+	wz= (argc>1 && strcmp(argv[1], "4")==0) ? 4 : 2;
+	pz= (argc>2 && strcmp(argv[2], "4")==0) ? 4 : wz;
+
+	leader();
+	occam();
+	trailer();
+
+	exit(err);
+}
+
+LLmessage(tk) register tk;
+{
+	static errors=0;
+
+	if (tk>0) {
+		repeat_token(LLsymb);
+		warning("syntax error: %s expected (inserted)", tokenname(tk, 1));
+	} else
+	if (tk==0)
+		warning("syntax error: bad token %s (deleted)", tokenname(LLsymb, 0));
+	else { /* tk<0 */
+		fprintf(stderr, "Compiler stack overflow. Compiler ends.");
+		err=1; trailer(); exit(1);
+	}
+	if (++errors==MAXERRORS) {
+		fprintf(stderr, "Too many insert/delete errors. Compiler ends.\n");
+		err=1; trailer(); exit(1);
+	}
+}
+
+static void nonconst(siz) char *siz;
+{
+	report("%s should be a constant", siz);
+}
+
+static void nonpositive(siz) char *siz;
+{
+	report("%s must be positive", siz);
+}
+
+static void rep_cleanup(e1, e2) struct expr *e1, *e2;
+{
+	destroy(e1);
+	destroy(e2);
+	sym_up();
+}
+
+static void check_assoc(prev_op, op) register prev_op, op;
+{
+	switch (op) {
+		char prev[5];
+	case '+':	case '*':
+	case AND:	case OR:
+	case BA:	case BO:	case BX:
+		if (prev_op==op) break;
+	default:
+		strcpy(prev, tokenname(prev_op, 0));
+
+		warning("Operators %s and %s don't associate",
+			prev, tokenname(op, 0)
+		);
+	}
+}
+}

lang/occam/comp/report.c

@@ -0,0 +1,19 @@
+#include <stdio.h>
+
+extern int err, yylineno;
+extern char *curr_file;
+
+report(fmt, arg1, arg2, arg3) char *fmt;
+{
+	fprintf(stderr, "%s (%d) F: ", curr_file, yylineno);
+	fprintf(stderr, fmt, arg1, arg2, arg3);
+	putc('\n', stderr);
+	err=1;
+}
+
+warning(fmt, arg1, arg2, arg3) char *fmt, *arg1;
+{
+	fprintf(stderr, "%s (%d) E: ", curr_file, yylineno);
+	fprintf(stderr, fmt, arg1, arg2, arg3);
+	putc('\n', stderr);
+}

lang/occam/comp/sizes.h

@@ -0,0 +1,5 @@
+/* Variable size, wordsize, pointer size.  Offsets for local variables. */
+
+#define vz	4
+extern int wz, pz;
+extern int curr_level, curr_offset, min_offset;

lang/occam/comp/symtab.c

@@ -0,0 +1,202 @@
+#include "symtab.h"
+#include "expr.h"
+#include "sizes.h"
+
+int curr_level=0;	/* Current local level */
+int curr_offset=0;	/* Current offset within this level */
+int min_offset=0;	/* Minimum of all offsets within current level */
+
+static struct symtab *sym_table=nil;
+
+char *malloc();
+
+static struct symbol **search_sym(tree, name)
+	struct symbol **tree;
+	char *name;
+/* Returns a hook in the tree to the where the given name is or should be. */
+{
+	register struct symbol **aps=tree, *ps;
+	register cmp;
+
+	while ((ps= *aps)!=nil && (cmp=strcmp(name, ps->name))!=0)
+		aps= cmp<0 ? &ps->left : &ps->right;
+
+	return aps;
+}
+
+struct symbol *insert(name, type, arr_siz, info)
+	char *name;
+	int type, arr_siz;
+	union type_info info;
+/* Inserts an object with given name and other info into the current symbol
+ * tree.  A pointer is returned to the inserted symbol so that more info may
+ * or changed.  Nil is returned on redeclaration.
+ */
+{
+	register struct symbol **aps, *ps;
+	extern included;
+
+	if (*(aps=search_sym(&sym_table->local, name))!=nil) {
+		report("%s redeclared", name);
+		return nil;
+	}
+
+	ps= (struct symbol *) malloc(sizeof *ps);
+
+	ps->name=name;
+
+	if (included && curr_level==0)	/* Top_level symbol in include file */
+		type|=T_USED;		/* are always used */
+	ps->type=type;
+	ps->arr_siz=arr_siz;
+	ps->info=info;
+	ps->left=ps->right=nil;
+	*aps=ps;
+
+	return ps;
+}
+
+struct symbol *searchall(name) char *name;
+/* Searches for name in all symbol trees from the inner to the outermost.
+ * If it can't be found then it is inserted as undefined.
+ */
+{
+	register struct symtab *tab=sym_table;
+	register struct symbol *ps;
+
+	while (tab!=nil) {
+		if ((ps= *search_sym(&tab->local, name))!=nil) return ps;
+
+		tab=tab->global;
+	}
+	report("%s not declared", name);
+	return insert(name, T_NOTDECL, 0, none);
+}
+
+void check_recursion(proc)
+	register struct expr *proc;
+{
+	if (proc->kind==E_VAR && proc->u.var->type&T_RECURS)
+		warning("recursion not allowed");
+}
+
+void sym_down()
+{
+	register struct symtab *ps;
+
+	ps= (struct symtab *) malloc(sizeof *ps);
+
+	ps->local=nil;
+	ps->global=sym_table;
+	ps->old_offset=curr_offset;
+
+	sym_table=ps;
+}
+
+static void sym_destroy(ps) register struct symbol *ps;
+{
+	if (ps!=nil) {
+		sym_destroy(ps->left);
+		sym_destroy(ps->right);
+		if ( !(ps->type&T_NOTDECL) ) {
+			if ( !(ps->type&T_USED) )
+				warning("%s: never used", ps->name);
+			else
+			if ( !(ps->type&T_ASSIGNED) && (ps->type&T_TYPE)==T_VAR)
+				warning("%s: never assigned", ps->name);
+		}
+		if ((ps->type&T_TYPE)==T_PROC) {
+			register struct par_list *par, *junk;
+
+			par=ps->info.proc.pars;
+			while (par!=nil) {
+				junk=par;
+				par=par->next;
+				free(junk);
+			}
+		} else
+		if ((ps->type&T_TYPE)==T_CONST)
+			destroy(ps->info.const);
+		free(ps->name);
+		free(ps);
+	}
+}
+
+void sym_up()
+{
+	register struct symtab *ps;
+
+	ps=sym_table->global;
+	curr_offset=sym_table->old_offset;
+
+	sym_destroy(sym_table->local);
+	free(sym_table);
+
+	sym_table=ps;
+}
+
+void var_memory(info, type, n) register union type_info *info; int type, n;
+/* Reserves local memory for an object, and stores it in its info field. */
+{
+	info->vc.st.level=curr_level;
+	curr_offset-= (type&T_BYTE) ? (n+wz-1) & (~(wz-1)) : n*vz;
+	info->vc.offset=curr_offset;
+	if (curr_offset<min_offset) min_offset=curr_offset;
+}
+
+void chan_memory(info, n) register union type_info *info; int n;
+{
+	info->vc.st.level=curr_level;
+	info->vc.offset= curr_offset-=n*(vz+wz);
+	if (curr_offset<min_offset) min_offset=curr_offset;
+}
+
+int memory(z) int z;
+/* Reserves z memory bytes */
+{
+	curr_offset-=z;
+	if (curr_offset<min_offset) min_offset=curr_offset;
+	return curr_offset;
+}
+
+void pars_add(aapars, type, var)
+	register struct par_list ***aapars;
+	int type;
+	struct symbol *var;
+/* Add a formal variable to a parameter list using a hook to a hook. */
+{
+	register struct par_list *pl;
+
+	pl= (struct par_list *) malloc(sizeof *pl);
+
+	pl->type=type;
+	pl->var=var;
+	pl->next= **aapars;
+
+	**aapars=pl;
+	*aapars= &pl->next;
+}
+
+int form_offsets(pars) register struct par_list *pars;
+/* Recursively assign offsets to formal variables. */
+{
+	register struct symbol *var;
+
+	if (pars==nil) return pz;
+
+	if ((var=pars->var)!=nil) {
+		register offset=form_offsets(pars->next);
+
+		switch (var->type&T_TYPE) {
+		case T_VAR:
+		case T_CHAN:
+			var->info.vc.st.level=curr_level;
+			var->info.vc.offset=offset;
+			return offset+pz;
+		case T_VALUE:
+			var->info.vc.st.level=curr_level;
+			var->info.vc.offset=offset;
+			return offset+ ((var->type&T_ARR) ? pz : vz);
+		}
+	}
+}

lang/occam/comp/symtab.h

@@ -0,0 +1,91 @@
+#ifndef nil
+#define nil 0
+#endif
+
+	/* Symbol/Expression type: */
+#define	T_VAR		0x0000
+#define	T_CHAN		0x0001
+#define	T_CONST		0x0002
+#define	T_VALUE		0x0003
+#define	T_PROC		0x0004
+#define T_NOW		0x0005
+#define T_VOID		0x0006
+
+#define	T_TYPE		0x0007	/* Mask for type bits */
+
+	/* Flags: */
+#define	T_ARR		0x0008	/* Object is an array */
+#define	T_BYTE		0x0010	/* Object is a byte array if T_ARR */
+#define	T_PARAM		0x0020	/* Formal parameter */
+#define	T_LVALUE	0x0040	/* This object may be assigned */
+#define T_NOTDECL	0x0080	/* If you didn't declare it */
+#define T_USED		0x0100	/* If you've used it */
+#define T_ASSIGNED	0x0200	/* Or assigned it */
+#define T_REP		0x0400	/* Replicator index */
+#define T_BUILTIN	0x0800	/* Builtin name */
+#define T_RECURS	0x1000	/* This proc is now compiled */
+/* Note that some types and flags are only used for symbols, and others only
+ * for expressions.
+ */
+
+struct symbol;
+
+struct par_list {	/* List of parameter types for a proc object */
+	struct par_list *next;
+	struct symbol *var;	/* The formal parameter while visible */
+	int type;		/* Its type */
+};
+
+struct expr;
+
+union storage {		/* An object is found */
+	int level;	/* either at a certain local level */
+	char *builtin;	/* or using a global builtin name */
+};
+
+union type_info {
+	struct {
+		union storage st;
+		int offset;	/* from its local level or builtin name */
+	} vc;			/* Variable or channel */
+
+	struct expr *const;
+
+	struct {
+		union storage st;
+		char *file;	/* file it is in */
+		int label;	/* A unique id*/
+		struct par_list *pars;
+	} proc;
+};
+
+struct symbol {
+	char	*name;
+	short	type;
+	int	arr_siz;
+	union type_info	info;
+	struct symbol	*left, *right;
+};
+
+struct symtab {
+	struct symbol *local;
+	struct symtab *global;
+	int old_offset;
+};
+
+struct symbol *insert();
+struct symbol *searchall();
+
+void sym_down();
+void sym_up();
+void var_memory(), chan_memory();
+
+void pars_add();
+int form_offsets();
+void check_recursion();
+
+#define var_constant(v)	(((v)->type&T_TYPE)==T_CONST)
+#define var_proc(v)	(((v)->type&T_TYPE)==T_PROC)
+#define var_declared(v)	(! ((v)->type&T_NOTDECL))
+
+extern union type_info none;

lang/occam/comp/token.h

@@ -0,0 +1,11 @@
+/*	token.h		*/
+
+extern struct token {
+	long	t_lval;
+	char	*t_sval;
+} token;
+
+extern ind;
+void repeat_token();
+char *tokenname();
+int tabulated();