ack/lang/occam/comp/occam.g

759 lines
15 KiB
Plaintext

/* $Id$ */
/*
* (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 <stdlib.h>
#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; register struct expr **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.cst<=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.cst<0)
nonpositive(siz);
else
arr_siz=e->u.cst;
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.cst<=0)
nonpositive(siz);
else
arr_siz=e->u.cst;
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.cst);
destroy(e1);
}
[ ',' expression(&e1)
{ if (!constant(e1))
nonconst("table element");
else
table_add(&apt, e1->u.cst);
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)
);
}
}
void
No_Mem()
{
fatal("out of memory");
}
}