ack/lang/occam/comp/occam.g

/* $Header$ */
/*
 * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
 * See the copyright notice in the ACK home directory, in the file "Copyright".
 */
/*	OCCAM		*/
{
#include "token.h"
#include "symtab.h"
#include "expr.h"
#include "code.h"
#include "sizes.h"
#include <system.h>
#include <em.h>

#define MAXERRORS	10	/* Maximum number of insert/delete errors */

static void nonconst(), nonpositive(), rep_cleanup(), check_assoc();
void init_builtins();
char *strcpy();

extern int lineno, 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=lineno; oind=ind; }
	  [	  %if (line==lineno)
		  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=lineno; oind=ind; }
	  [	  %if (line==lineno)
		  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=lineno; oind=ind; }
	  [	  %if (line==lineno)
		  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=lineno; oind=ind;
					par_begin();
				}
		  [	  %if (line==lineno)
			  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=lineno; oind=ind;
					no_deadlock();
					Label(new_label(&BEGIN));
				}
		  [	  %if (line==lineno)
			  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=lineno; oind=ind; }
	  [	  %if (line==lineno)
		  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, *byte);
					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.t_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->s_info.proc.pars=pars;
				}
	  '=' process		{	epilogue(proc);
					sym_up();
					proc->s_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=lineno;
					oind=ind;
					var=searchall(token.t_sval);

					if (var_constant(var))
						*e=copy_const(var->s_info.t_const);
					else {
						if (var_proc(var))
							pars=var->s_info.proc.pars;
						*e=new_var(var);
					}
				}
	  [ %while (line==lineno || tabulated(oind, ind))
		  [	  subscript(&byte, &e1)
				{	*e=new_node('[', *e, e1, byte); }
			| '('	{	if (!var_declared(var)) {
						var->s_type=T_PROC|T_USED|T_NOTDECL;
						var->s_info.proc.pars=nil;
						err=1;
					}
					if (!var_proc(var)) {
						report("%s is not a named process",
							var->s_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, (char *)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, 0); }
		| [
			  '?'	{	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, 0); }
	  ]*
	| monadic_op(&op) element(&e1)
				{	*e=new_node(op, e1, (char *)nil, 0); }
	;

val_expr(register struct expr **e;) :
	  expression(e)		{	used(*e); }
	;

%lexical scanner;
{
int err=0;

main(argc, argv) register argc; register char **argv;
{
	while (argc > 1 && argv[1][0] == '-') {
		do_option(&argv[1][1]);
		argc--;
		argv++;
	}

	leader();
	occam();
	trailer();

	exit(err);
}

do_option(text)
	char *text;
{
	extern int Lflag;

	switch(*text++)	{

	default:
		fatal("illegal option: %c", *--text);

	case 'L' :			/* no fil/lin */
		Lflag++;
		break;
	case 'V' :	/* set object sizes and alignment requirements	*/
	{
		arith size, align;
		char c;

		while (c = *text++)	{
			size = txt2int(&text);
			switch (c)	{
			case 'w':	/* word		*/
				if (size != (arith)0)
					wz = size;
				break;
			case 'p':	/* pointer	*/
				if (size != (arith)0)
					pz = size;
				break;
			case 'l':	/* long		*/
				if (size != (arith)0)
					vz = size;
				break;
			default:
				fatal("-V: bad type indicator %c\n", c);
			}
		}
		break;
	}
	}
}

int
txt2int(tp)
	char **tp;
{
	/*	the integer pointed to by *tp is read, while increasing
		*tp; the resulting value is yielded.
	*/
	register int val = 0, ch;
	
	while (ch = **tp, ch >= '0' && ch <= '9')	{
		val = val * 10 + ch - '0';
		(*tp)++;
	}
	return val;
}

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 */
		warning("syntax error: garbage at end of program");
	}
	if (++errors==MAXERRORS) {
		fprint(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)
		);
	}
}

No_Mem()
{
	fatal("out of memory");
}
}