--- /dev/null
+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
--- /dev/null
+#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);
+}
--- /dev/null
+#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();
+}
--- /dev/null
+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();
--- /dev/null
+#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();
+}
--- /dev/null
+#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();
--- /dev/null
+#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);
+ }
+}
--- /dev/null
+#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)
--- /dev/null
+/* 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;
+}
--- /dev/null
+%{
+/* 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);
+}
--- /dev/null
+/* 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)
+ );
+ }
+}
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/* Variable size, wordsize, pointer size. Offsets for local variables. */
+
+#define vz 4
+extern int wz, pz;
+extern int curr_level, curr_offset, min_offset;
--- /dev/null
+#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);
+ }
+ }
+}
--- /dev/null
+#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;
--- /dev/null
+/* token.h */
+
+extern struct token {
+ long t_lval;
+ char *t_sval;
+} token;
+
+extern ind;
+void repeat_token();
+char *tokenname();
+int tabulated();
public / ack.git / commitdiff