path: root/rules.y

/* Miranda token declarations and syntax rules for "YACC" */

/**************************************************************************
 * Copyright (C) Research Software Limited 1985-90.  All rights reserved. *
 * The Miranda system is distributed as free software under the terms in  *
 * the file "COPYING" which is included in the distribution.              *
 *                                                                        *
 * Revised to C11 standard and made 64bit compatible, January 2020        *
 *------------------------------------------------------------------------*/

/* miranda symbols */

%token VALUE EVAL WHERE IF TO LEFTARROW  COLONCOLON  COLON2EQ
       TYPEVAR  NAME  CNAME  CONST  DOLLAR2  OFFSIDE  ELSEQ
       ABSTYPE WITH DIAG EQEQ FREE INCLUDE  EXPORT  TYPE
       OTHERWISE  SHOWSYM  PATHNAME  BNF  LEX  ENDIR  ERRORSY ENDSY
       EMPTYSY READVALSY LEXDEF CHARCLASS ANTICHARCLASS LBEGIN

%right ARROW
%right PLUSPLUS ':' MINUSMINUS
%nonassoc DOTDOT
%right VEL
%right '&'
%nonassoc '>' GE '=' NE LE '<'
%left '+' '-'
%left '*'  '/' REM DIV
%right '^'
%left '.'   /* fiddle to make '#' behave */
%left '!'
%right INFIXNAME INFIXCNAME
%token CMBASE  /* placeholder to start combinator values - see combs.h */

%{
/* the following definition has to be kept in line with the token declarations
   above */
char *yysterm[]= {
 0,
 "VALUE",
 "EVAL",
 "where",
 "if",
 "&>",
 "<-",
 "::",
 "::=",
 "TYPEVAR",
 "NAME",
 "CONSTRUCTOR-NAME",
 "CONST",
 "$$",
 "OFFSIDE",
 "OFFSIDE =",
 "abstype",
 "with",
 "//",
 "==",
 "%free",
 "%include",
 "%export",
 "type",
 "otherwise",
 "show",
 "PATHNAME",
 "%bnf",
 "%lex",
 "%%",
 "error",
 "end",
 "empty",
 "readvals",
 "NAME",
 "`char-class`",
 "`char-class`",
 "%%begin",
 "->",
 "++",
 "--",
 "..",
 "\\/",
 ">=",
 "~=",
 "<=",
 "mod",
 "div",
 "$NAME",
 "$CONSTRUCTOR"};

%}

/* Miranda syntax rules */
/* the associated semantic actions perform the compilation */

%{
#include "data.h"
#include "big.h"
#include "lex.h"
extern word nill,k_i,Void;
extern word message,standardout;
extern word big_one;
#define isltmess_t(t) (islist_t(t)&&tl[t]==message)
#define isstring_t(t) (islist_t(t)&&tl[t]==char_t)
extern word SYNERR,errs,echoing,gvars;
extern word listdiff_fn,indent_fn,outdent_fn;
word lastname=0;
word suppressids=NIL;
word idsused=NIL;
word tvarscope=0;
word includees=NIL,embargoes=NIL,exportfiles=NIL,freeids=NIL,exports=NIL;
word lexdefs=NIL,lexstates=NIL,inlex=0,inexplist=0;
word inbnf=0,col_fn=0,fnts=NIL,eprodnts=NIL,nonterminals=NIL,sreds=0;
word ihlist=0,ntspecmap=NIL,ntmap=NIL,lasth=0;
word obrct=0;

void evaluate(x)
word x;
{ word t;
  t=type_of(x);
  if(t==wrong_t)return;
  lastexp=x;
  x=codegen(x);
  if(polyshowerror)return;
  if(process())
                 /* setup new process for each evaluation */
  { (void)signal(SIGINT,(sighandler)dieclean);
      /* if interrupted will flush output etc before going */
    compiling=0;
    resetgcstats();
    output(isltmess_t(t)?x:
            cons(ap(standardout,isstring_t(t)?x
                           :ap(mkshow(0,0,t),x)),NIL));
    (void)signal(SIGINT,SIG_IGN);/* otherwise could do outstats() twice */
    putchar('\n');
    outstats();
    exit(0); }
}

void obey(x) /* like evaluate but no fork, no stats, no extra '\n' */
word x;
{ word t=type_of(x);
  x=codegen(x);
  if(polyshowerror)return;
  compiling=0;
  output(isltmess_t(t)?x:
            cons(ap(standardout,isstring_t(t)?x:ap(mkshow(0,0,t),x)),NIL));
}

int isstring(x)
word x;
{ return(x==NILS||tag[x]==CONS&&is_char(hd[x]));
}

word compose(x) /* used in compiling 'cases' */
word x;
{ word y=hd[x];
  if(hd[y]==OTHERWISE)y=tl[y]; /* OTHERWISE was just a marker - lose it */
  else y=tag[y]==LABEL?label(hd[y],ap(tl[y],FAIL)):
         ap(y,FAIL); /* if all guards false result is FAIL */
  x = tl[x];
  if(x!=NIL)
    { while(tl[x]!=NIL)y=label(hd[hd[x]],ap(tl[hd[x]],y)), x=tl[x];
      y=ap(hd[x],y);
     /* first alternative has no label - label of enclosing rhs applies */
    }
  return(y);
}

int eprod(word);

word starts(x) /* x is grammar rhs - returns list of nonterminals in start set */
word x;
{ L: switch(tag[x])
     { case ID: return(cons(x,NIL));
       case LABEL:
       case LET:
       case LETREC: x=tl[x]; goto L;
       case AP: switch(hd[x])
                { case G_SYMB:
                  case G_SUCHTHAT:
                  case G_RULE: return(NIL);
                  case G_OPT:
                  case G_FBSTAR:
                  case G_STAR: x=tl[x]; goto L;
                  default: if(hd[x]==outdent_fn)
                             { x=tl[x]; goto L; }
                           if(tag[hd[x]]==AP)
                             if(hd[hd[x]]==G_ERROR)
                               { x=tl[hd[x]]; goto L; }
                             if(hd[hd[x]]==G_SEQ)
                               { if(eprod(tl[hd[x]]))
                               return(UNION(starts(tl[hd[x]]),starts(tl[x])));
                                 x=tl[hd[x]]; goto L; } else
                             if(hd[hd[x]]==G_ALT)
                               return(UNION(starts(tl[hd[x]]),starts(tl[x])));
                             else
                             if(hd[hd[x]]==indent_fn)
                               { x=tl[x]; goto L; }
                }
       default: return(NIL);
     }
}

int eprod(x) /* x is grammar rhs - does x admit empty production? */
word x;
{ L: switch(tag[x])
     { case ID: return(member(eprodnts,x));
       case LABEL:
       case LET:
       case LETREC: x=tl[x]; goto L;
       case AP: switch(hd[x])
                { case G_SUCHTHAT:
                  case G_ANY:
                  case G_SYMB: return(0);
                  case G_RULE: return(1);
                  case G_OPT:
                  case G_FBSTAR:
                  case G_STAR: return(1);
                  default: if(hd[x]==outdent_fn)
                             { x=tl[x]; goto L; }
                           if(tag[hd[x]]==AP)
                             if(hd[hd[x]]==G_ERROR)
                               { x=tl[hd[x]]; goto L; }
                             if(hd[hd[x]]==G_SEQ)
                               return(eprod(tl[hd[x]])&&eprod(tl[x])); else
                             if(hd[hd[x]]==G_ALT)
                               return(eprod(tl[hd[x]])||eprod(tl[x]));
                             else
                             if(hd[hd[x]]==indent_fn)
                               { x=tl[x]; goto L; }
                }
       default: return(x==G_STATE||x==G_UNIT);
       /* G_END is special case, unclear whether it counts as an e-prodn.
          decide no for now, sort this out later */
     }
}

word add_prod(d,ps,hr)
word d,ps,hr;
{ word p,n=dlhs(d);
  for(p=ps;p!=NIL;p=tl[p])
  if(dlhs(hd[p])==n)
     if(dtyp(d)==undef_t&&dval(hd[p])==UNDEF)
       { dval(hd[p])=dval(d); return(ps); } else
     if(dtyp(d)!=undef_t&&dtyp(hd[p])==undef_t)
       { dtyp(hd[p])=dtyp(d); return(ps); }
     else
       errs=hr,
       printf(
      "%ssyntax error: conflicting %s of nonterminal \"%s\"\n",
               echoing?"\n":"",
               dtyp(d)==undef_t?"definitions":"specifications",
               get_id(n)),
       acterror();
  return(cons(d,ps));
}
/* clumsy - this algorithm is quadratic in number of prodns - fix later */

word getloc(nt,prods)  /* get here info for nonterminal */
word nt,prods;
{ while(prods!=NIL&&dlhs(hd[prods])!=nt)prods=tl[prods];
  if(prods!=NIL)return(hd[dval(hd[prods])]);
  return(0);  /* should not happen, but just in case */
}

void findnt(nt) /* set errs to here info of undefined nonterminal */
word nt;
{ word p=ntmap;
  while(p!=NIL&&hd[hd[p]]!=nt)p=tl[p];
  if(p!=NIL)
    { errs=tl[hd[p]]; return; }
  p=ntspecmap;
  while(p!=NIL&&hd[hd[p]]!=nt)p=tl[p];
  if(p!=NIL)errs=tl[hd[p]];
}

#define isap2(fn,x) (tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==(fn))
#define firstsymb(term) tl[hd[term]]

void binom(rhs,x)
/* performs the binomial optimisation on rhs of nonterminal x
    x: x alpha1| ... | x alphaN | rest     ||need not be in this order
        ==>
    x: rest (alpha1|...|alphaN)*
*/
word rhs,x;
{ word *p= &tl[rhs];  /* rhs is of form label(hereinf, stuff) */
  word *lastp=0,*holdrhs,suffix,alpha=NIL;
  if(tag[*p]==LETREC)p = &tl[*p]; /* ignore trailing `where defs' */
  if(isap2(G_ERROR,*p))p = &tl[hd[*p]];
  holdrhs=p;
  while(isap2(G_ALT,*p))
    if(firstsymb(tl[hd[*p]])==x)
       alpha=cons(tl[tl[hd[*p]]],alpha),
       *p=tl[*p],p = &tl[*p];
    else lastp=p,p = &tl[tl[*p]];
    /* note each (G_ALT a b) except the outermost is labelled */
  if(lastp&&firstsymb(*p)==x)
    alpha=cons(tl[*p],alpha),
    *lastp=tl[hd[*lastp]];
  if(alpha==NIL)return;
  suffix=hd[alpha],alpha=tl[alpha];
  while(alpha!=NIL)
       suffix=ap2(G_ALT,hd[alpha],suffix),
       alpha=tl[alpha];
  *holdrhs=ap2(G_SEQ,*holdrhs,ap(G_FBSTAR,suffix));
}
/* should put some labels on the alpha's - fix later */

word getcol_fn()
{ extern char *dicp,*dicq;
  if(!col_fn)
    strcpy(dicp,"bnftokenindentation"),
    dicq=dicp+20,
    col_fn=name();
  return(col_fn);
}

void startbnf()
{ ntspecmap=ntmap=nonterminals=NIL; 
  if(fnts==0)col_fn=0; /* reinitialise, a precaution */
}

word ih_abstr(x)  /* abstract inherited attributes from grammar rule */
word x;
{ word ih=ihlist;
  while(ih!=NIL)  /* relies on fact that ihlist is reversed */
       x=lambda(hd[ih],x),ih=tl[ih];
  return(x);
}

int can_elide(x) /* is x of the form $1 applied to ih attributes in order? */
word x;
{ word ih;
  if(ihlist)
    for(ih=ihlist;ih!=NIL&&tag[x]==AP;ih=tl[ih],x=hd[x])
       if(hd[ih]!=tl[x])return(0);
  return(x==mkgvar(1));
}

int e_re(x) /* does regular expression x match empty string ? */
word x;
{ L: if(tag[x]==AP)
       { if(hd[x]==LEX_STAR||hd[x]==LEX_OPT)return(1);
         if(hd[x]==LEX_STRING)return(tl[x]==NIL);
         if(tag[hd[x]]!=AP)return(0);
         if(hd[hd[x]]==LEX_OR)
           { if(e_re(tl[hd[x]]))return(1);
             x=tl[x]; goto L; } else
         if(hd[hd[x]]==LEX_SEQ)
           { if(!e_re(tl[hd[x]]))return(0);
             x=tl[x]; goto L; } else
         if(hd[hd[x]]==LEX_RCONTEXT)
           { x=tl[hd[x]]; goto L; }
       }
     return(0);
}

%}

%%

entity:  /* the entity to be parsed is either a definition script or an
            expression (the latter appearing as a command line) */

    error|

    script
        = { lastname=0; /* outstats(); */  }|
                        /* statistics not usually wanted after compilation */

/*  MAGIC exp '\n' script
        =  { lastexp=$2; }| /* change to magic scripts 19.11.2013 */

    VALUE exp
        =  { lastexp=$2; }| /* next line of `$+' */

    EVAL exp
        = { if(!SYNERR&&yychar==0)
              { evaluate($2); }
          }|

    EVAL exp COLONCOLON
            /* boring problem - how to make sure no junk chars follow here?
               likewise TO case -- trick used above doesn't work, yychar is
               here always -1 Why? Too fiddly to bother with just now */
          = { word t=type_of($2);
              if(t!=wrong_t)
                { lastexp=$2;
                  if(tag[$2]==ID&&id_type($2)==wrong_t)t=wrong_t;
                  out_type(t);
                  putchar('\n'); }
            }|

    EVAL exp TO
        = { FILE *fil=NULL,*efil;
            word t=type_of($2);
            char *f=token(),*ef;
            if(f)keep(f); ef=token(); /* wasteful of dic space, FIX LATER */
            if(f){ fil= fopen(f,$3?"a":"w");
                   if(fil==NULL)
                     printf("cannot open \"%s\" for writing\n",f); }
            else printf("filename missing after \"&>\"\n");
            if(ef)
              { efil= fopen(ef,$3?"a":"w");
                if(efil==NULL)
                  printf("cannot open \"%s\" for writing\n",ef); }
            if(t!=wrong_t)$2=codegen(lastexp=$2);
            if(!polyshowerror&&t!=wrong_t&&fil!=NULL&&(!ef||efil))
            { int pid;/* launch a concurrent process to perform task */
              sighandler oldsig;
              oldsig=signal(SIGINT,SIG_IGN); /* ignore interrupts */
              if(pid=fork())
                { /* "parent" */
                  if(pid==-1)perror("cannot create process");
                  else printf("process %d\n",pid);
                  fclose(fil);
                  if(ef)fclose(efil);
                  (void)signal(SIGINT,oldsig); }else
              { /* "child" */
                (void)signal(SIGQUIT,SIG_IGN);   /* and quits */
#ifndef SYSTEM5
                (void)signal(SIGTSTP,SIG_IGN);   /* and stops */
#endif
                close(1); dup(fileno(fil));  /* subvert stdout */
                close(2); dup(fileno(ef?efil:fil)); /* subvert stderr */
                /* FUNNY BUG - if redirect stdout stderr to same file by two
                   calls to freopen, their buffers get conflated - whence do
                   by subverting underlying file descriptors, as above
                   (fix due to Martin Guy) */
                /* formerly used dup2, but not present in system V */
                fclose(stdin);
                /* setbuf(stdout,NIL); 
		/* not safe to change buffering of stream already in use */
		/* freopen would have reset the buffering automatically */
                lastexp = NIL;  /* what else should we set to NIL? */
                /*atcount= 1; */
                compiling= 0;
                resetgcstats();
                output(isltmess_t(t)?$2:
                        cons(ap(standardout,isstring_t(t)?$2:
                                       ap(mkshow(0,0,t),$2)),NIL));
                putchar('\n');
                outstats();
                exit(0); } } };

script:
    /* empty */|
    defs;

exp:
    op | /* will later suppress in favour of (op) in arg */
    e1;

op:
    '~'
        =  { $$ = NOT; }|
    '#'
        =  { $$ = LENGTH; }|
    diop;

diop:
    '-'
        =  { $$ = MINUS; }|
    diop1;

diop1:
    '+'
        =  { $$ = PLUS; }|
    PLUSPLUS
        =  { $$ = APPEND; }|
    ':'
        =  { $$ = P; }|
    MINUSMINUS
        =  { $$ = listdiff_fn; }|
    VEL
        =  { $$ = OR; }|
    '&'
        =  { $$ = AND; }|
    relop |
    '*'
        =  { $$ = TIMES; }|
    '/'
        =  { $$ = FDIV; }|
    DIV
        =  { $$ = INTDIV; }|
    REM
        =  { $$ = MOD; }|
    '^'
        =  { $$ = POWER; }|
    '.'
        =  { $$ = B; }|
    '!'
        =  { $$ = ap(C,SUBSCRIPT); }|
    INFIXNAME|
    INFIXCNAME;

relop:
    '>'
        = { $$ = GR; }|
    GE
        = { $$ = GRE; }|
    eqop
        = { $$ = EQ; }|
    NE
        = { $$ = NEQ; }|
    LE
        = { $$ = ap(C,GRE); }|
    '<'
        = { $$ = ap(C,GR); };

eqop:
    EQEQ|  /* silently accept for benefit of Haskell users */
    '=';

rhs:
    cases WHERE ldefs 
        = { $$ = block($3,compose($1),0); }|
    exp WHERE ldefs 
        = { $$ = block($3,$1,0); }|
    exp|
    cases
        =  { $$ = compose($1); };

cases:
    exp ',' if exp
        =  { $$ = cons(ap2(COND,$4,$1),NIL); }|
    exp ',' OTHERWISE
        =  { $$ = cons(ap(OTHERWISE,$1),NIL); }|
    cases reindent ELSEQ alt
        =  { $$ = cons($4,$1); 
             if(hd[hd[$1]]==OTHERWISE)
               syntax("\"otherwise\" must be last case\n"); };

alt:
    here exp
        =  { errs=$1,
             syntax("obsolete syntax, \", otherwise\" missing\n");
             $$ = ap(OTHERWISE,label($1,$2)); }|
    here exp ',' if exp
        =  { $$ = label($1,ap2(COND,$5,$2)); }|
    here exp ',' OTHERWISE
        =  { $$ = ap(OTHERWISE,label($1,$2)); };

if:
    /* empty */
        = { extern word strictif;
            if(strictif)syntax("\"if\" missing\n"); }|
    IF;

indent:
    /* empty */
        = { if(!SYNERR){layout(); setlmargin();}
          };
/* note that because of yacc's one symbol look ahead, indent must usually be
   invoked one symbol earlier than the non-terminal to which it applies 
   - see `production:' for an exception */

outdent:
    separator
        = { unsetlmargin(); };

separator:
    OFFSIDE | ';' ;

reindent:
    /* empty */
        = { if(!SYNERR)
              { unsetlmargin(); layout(); setlmargin(); }
          };
 
liste:  /* NB - returns list in reverse order */
    exp
        = { $$ = cons($1,NIL); }|
    liste ',' exp  /* left recursive so as not to eat YACC stack */
        = { $$ = cons($3,$1); };

e1:
    '~' e1 %prec '='
        = { $$ = ap(NOT,$2); }|
    e1 PLUSPLUS e1
        = { $$ = ap2(APPEND,$1,$3); }|
    e1 ':' e1
        = { $$ = cons($1,$3); }|
    e1 MINUSMINUS e1
        = { $$ = ap2(listdiff_fn,$1,$3);  }|
    e1 VEL e1
        = { $$ = ap2(OR,$1,$3); }|
    e1 '&' e1
        = { $$ = ap2(AND,$1,$3); }|
    reln |
    e2;

es1:                     /* e1 or presection */
    '~' e1 %prec '='
        = { $$ = ap(NOT,$2); }|
    e1 PLUSPLUS e1
        = { $$ = ap2(APPEND,$1,$3); }|
    e1 PLUSPLUS
        = { $$ = ap(APPEND,$1); }|
    e1 ':' e1
        = { $$ = cons($1,$3); }|
    e1 ':'
        = { $$ = ap(P,$1); }|
    e1 MINUSMINUS e1
        = { $$ = ap2(listdiff_fn,$1,$3);  }|
    e1 MINUSMINUS
        = { $$ = ap(listdiff_fn,$1);  }|
    e1 VEL e1
        = { $$ = ap2(OR,$1,$3); }|
    e1 VEL
        = { $$ = ap(OR,$1); }|
    e1 '&' e1
        = { $$ = ap2(AND,$1,$3); }|
    e1 '&'
        = { $$ = ap(AND,$1); }|
    relsn |
    es2;

e2:
    '-' e2 %prec '-'
        = { $$ = ap(NEG,$2); }|
    '#' e2 %prec '.'
        = { $$ = ap(LENGTH,$2);  }|
    e2 '+' e2
        = { $$ = ap2(PLUS,$1,$3); }|
    e2 '-' e2
        = { $$ = ap2(MINUS,$1,$3); }|
    e2 '*' e2
        = { $$ = ap2(TIMES,$1,$3); }|
    e2 '/' e2
        = { $$ = ap2(FDIV,$1,$3); }|
    e2 DIV e2
        = { $$ = ap2(INTDIV,$1,$3); } |
    e2 REM e2
        = { $$ = ap2(MOD,$1,$3); }|
    e2 '^' e2
        = { $$ = ap2(POWER,$1,$3); } |
    e2 '.' e2
        = { $$ = ap2(B,$1,$3);  }|
    e2 '!' e2
        = { $$ = ap2(SUBSCRIPT,$3,$1); }|
    e3;

es2:               /* e2 or presection */
    '-' e2 %prec '-'
        = { $$ = ap(NEG,$2); }|
    '#' e2 %prec '.'
        = { $$ = ap(LENGTH,$2);  }|
    e2 '+' e2
        = { $$ = ap2(PLUS,$1,$3); }|
    e2 '+'
        = { $$ = ap(PLUS,$1); }|
    e2 '-' e2
        = { $$ = ap2(MINUS,$1,$3); }|
    e2 '-'
        = { $$ = ap(MINUS,$1); }|
    e2 '*' e2
        = { $$ = ap2(TIMES,$1,$3); }|
    e2 '*'
        = { $$ = ap(TIMES,$1); }|
    e2 '/' e2
        = { $$ = ap2(FDIV,$1,$3); }|
    e2 '/'
        = { $$ = ap(FDIV,$1); }|
    e2 DIV e2
        = { $$ = ap2(INTDIV,$1,$3); } |
    e2 DIV
        = { $$ = ap(INTDIV,$1); } |
    e2 REM e2
        = { $$ = ap2(MOD,$1,$3); }|
    e2 REM
        = { $$ = ap(MOD,$1); }|
    e2 '^' e2
        = { $$ = ap2(POWER,$1,$3); } |
    e2 '^'
        = { $$ = ap(POWER,$1); } |
    e2 '.' e2
        = { $$ = ap2(B,$1,$3);  }|
    e2 '.'
        = { $$ = ap(B,$1);  }|
    e2 '!' e2
        = { $$ = ap2(SUBSCRIPT,$3,$1); }|
    e2 '!'
        = { $$ = ap2(C,SUBSCRIPT,$1); }|
    es3;

e3:
    comb INFIXNAME e3
        = { $$ = ap2($2,$1,$3); }|
    comb INFIXCNAME e3
        = { $$ = ap2($2,$1,$3); }|
    comb;

es3:                     /* e3 or presection */
    comb INFIXNAME e3
        = { $$ = ap2($2,$1,$3); }|
    comb INFIXNAME
        = { $$ = ap($2,$1); }|
    comb INFIXCNAME e3
        = { $$ = ap2($2,$1,$3); }|
    comb INFIXCNAME
        = { $$ = ap($2,$1); }|
    comb;

comb:
    comb arg
        = { $$ = ap($1,$2); }|
    arg;

reln:
    e2 relop e2
        = { $$ = ap2($2,$1,$3); }|
    reln relop e2
        = { word subject;
            subject = hd[hd[$1]]==AND?tl[tl[$1]]:tl[$1];
            $$ = ap2(AND,$1,ap2($2,subject,$3));
          };  /* EFFICIENCY PROBLEM - subject gets re-evaluated (and
                 retypechecked) - fix later */

relsn:                     /* reln or presection */
    e2 relop e2
        = { $$ = ap2($2,$1,$3); }|
    e2 relop
        = { $$ = ap($2,$1); }|
    reln relop e2
        = { word subject;
            subject = hd[hd[$1]]==AND?tl[tl[$1]]:tl[$1];
            $$ = ap2(AND,$1,ap2($2,subject,$3));
          };  /* EFFICIENCY PROBLEM - subject gets re-evaluated (and
                 retypechecked) - fix later */

arg:
    { if(!SYNERR)lexstates=NIL,inlex=1; }
    LEX lexrules ENDIR
        = { inlex=0; lexdefs=NIL;
            if(lexstates!=NIL)
              { word echoed=0;
                for(;lexstates!=NIL;lexstates=tl[lexstates])
                { if(!echoed)printf(echoing?"\n":""),echoed=1;
                  if(!(tl[hd[lexstates]]&1))
                    printf("warning: lex state %s is never entered\n",
                           get_id(hd[hd[lexstates]])); else
                  if(!(tl[hd[lexstates]]&2))
                    printf("warning: lex state %s has no associated rules\n",
                           get_id(hd[hd[lexstates]])); }
              }
            if($3==NIL)syntax("%lex with no rules\n");
            else tag[$3]=LEXER;
            /* result is lex-list, in reverse order, of items of the form
                 cons(scstuff,cons(matcher,rhs))
               where scstuff is of the form
                 cons(0-or-list-of-startconditions,1+newstartcondition)
            */
            $$ = $3; }|
    NAME |
    CNAME |
    CONST |
    READVALSY
        = { $$ = readvals(0,0); }|
    SHOWSYM
        = { $$ = show(0,0); }|
    DOLLAR2
        = { $$ = lastexp;
            if(lastexp==UNDEF)
            syntax("no previous expression to substitute for $$\n"); }|
    '[' ']'
        = { $$ = NIL; }|
    '[' exp ']'
        = { $$ = cons($2,NIL); }|
    '[' exp ',' exp ']'
        = { $$ = cons($2,cons($4,NIL)); }|
    '[' exp ',' exp ',' liste ']'
        = { $$ = cons($2,cons($4,reverse($6))); }|
    '[' exp DOTDOT exp ']'
        = { $$ = ap3(STEPUNTIL,big_one,$4,$2); }|
    '[' exp DOTDOT ']'
        = { $$ = ap2(STEP,big_one,$2); }|
    '[' exp ',' exp DOTDOT exp ']'
        = { $$ = ap3(STEPUNTIL,ap2(MINUS,$4,$2),$6,$2); }|
    '[' exp ',' exp DOTDOT ']'
        = { $$ = ap2(STEP,ap2(MINUS,$4,$2),$2); }|
    '[' exp '|' qualifiers ']'
        = { $$ = SYNERR?NIL:compzf($2,$4,0);  }|
    '[' exp DIAG qualifiers ']'
        = { $$ = SYNERR?NIL:compzf($2,$4,1);  }|
    '(' op ')'     /* RSB */
        = { $$ = $2; }|
    '(' es1 ')'          /* presection or parenthesised e1 */
        = { $$ = $2; }|
    '(' diop1 e1 ')'     /* postsection */
        = { $$ = (tag[$2]==AP&&hd[$2]==C)?ap(tl[$2],$3): /* optimisation */
                 ap2(C,$2,$3); }|
    '(' ')'
        = { $$ = Void; }|  /* the void tuple */
    '(' exp ',' liste ')'
        = { if(tl[$4]==NIL)$$=pair($2,hd[$4]);
            else { $$=pair(hd[tl[$4]],hd[$4]);
                   $4=tl[tl[$4]];
                   while($4!=NIL)$$=tcons(hd[$4],$$),$4=tl[$4];
                   $$ = tcons($2,$$); }
          /* representation of the tuple (a1,...,an) is
             tcons(a1,tcons(a2,...pair(a(n-1),an))) */
          };

lexrules:
    lexrules lstart here re indent { if(!SYNERR)inlex=2; }
    ARROW exp lpostfix { if(!SYNERR)inlex=1; } outdent
        = { if($9<0 && e_re($4))
              errs=$3,
              syntax("illegal lex rule - lhs matches empty\n");
            $$ = cons(cons(cons($2,1+$9),cons($4,label($3,$8))),$1); }|
    lexdefs
        = { $$ = NIL; };

lstart:
    /* empty */
        = { $$ = 0; }|
    '<' cnames '>'
        = { word ns=NIL;
            for(;$2!=NIL;$2=tl[$2])
               { word *x = &lexstates,i=1;
                 while(*x!=NIL&&hd[hd[*x]]!=hd[$2])i++,x = &tl[*x];
                 if(*x == NIL)*x = cons(cons(hd[$2],2),NIL);
                 else tl[hd[*x]] |= 2; 
                 ns = add1(i,ns); }
            $$ = ns; };

cnames:
    CNAME 
        = { $$=cons($1,NIL); }|
    cnames CNAME
        = { if(member($1,$2))
     printf("%ssyntax error: repeated name \"%s\" in start conditions\n",
                      echoing?"\n":"",get_id($2)),
              acterror();
            $$ = cons($2,$1); };

lpostfix:
        /* empty */
            = { $$ = -1; }|
        LBEGIN CNAME
            = { word *x = &lexstates,i=1;
                while(*x!=NIL&&hd[hd[*x]]!=$2)i++,x = &tl[*x];
                if(*x == NIL)*x = cons(cons($2,1),NIL);
                else tl[hd[*x]] |= 1;
                $$ = i;
              }|
        LBEGIN CONST
            = { if(!isnat($2)||big_toll($2)!=0)
                   syntax("%begin not followed by IDENTIFIER or 0\n");
                $$ = 0; };

lexdefs:
    lexdefs LEXDEF indent '=' re outdent
        = { lexdefs = cons(cons($2,$5),lexdefs); }|
    /* empty */ 
        = { lexdefs = NIL; };

re:   /* regular expression */
    re1 '|' re
        { $$ = ap2(LEX_OR,$1,$3); }|
    re1;

re1:
    lterm '/' lterm
        { $$ = ap2(LEX_RCONTEXT,$1,$3); }|
    lterm '/'
        { $$ = ap2(LEX_RCONTEXT,$1,0); }|
    lterm;

lterm:
    lfac lterm
        { $$ = ap2(LEX_SEQ,$1,$2); }|
    lfac;

lfac:
    lunit '*'
        { if(e_re($1))
            syntax("illegal regular expression - arg of * matches empty\n");
          $$ = ap(LEX_STAR,$1); }|
    lunit '+'
        { $$ = ap2(LEX_SEQ,$1,ap(LEX_STAR,$1)); }|
    lunit '?'
        { $$ = ap(LEX_OPT,$1); }|
    lunit;

lunit:
    '(' re ')'
        = { $$ = $2; }|
    CONST
        = { if(!isstring($1))
              printf("%ssyntax error - unexpected token \"",
                        echoing?"\n":""),
              out(stdout,$1),printf("\" in regular expression\n"),
              acterror();
            $$ = $1==NILS?ap(LEX_STRING,NIL):
                 tl[$1]==NIL?ap(LEX_CHAR,hd[$1]):
                             ap(LEX_STRING,$1);
          }|
    CHARCLASS
        = { if($1==NIL)
              syntax("empty character class `` cannot match\n");
            $$ = tl[$1]==NIL?ap(LEX_CHAR,hd[$1]):ap(LEX_CLASS,$1); }|
    ANTICHARCLASS
        = { $$ = ap(LEX_CLASS,cons(ANTICHARCLASS,$1)); }|
    '.'
        = { $$ = LEX_DOT; }|
    name
        = { word x=lexdefs;
            while(x!=NIL&&hd[hd[x]]!=$1)x=tl[x];
            if(x==NIL)
              printf(
      "%ssyntax error: undefined lexeme %s in regular expression\n",
                      echoing?"\n":"",
                      get_id($1)),
                  acterror();
            else $$ = tl[hd[x]]; };

name: NAME|CNAME;

qualifiers:
    exp
        = { $$ = cons(cons(GUARD,$1),NIL);  }|
    generator
        = { $$ = cons($1,NIL);  }|
    qualifiers ';' generator
        = { $$ = cons($3,$1);   }|
    qualifiers ';' exp
        = { $$ = cons(cons(GUARD,$3),$1);   };

generator:
    e1 ',' generator
        = { /* fix syntax to disallow patlist on lhs of iterate generator */
            if(hd[$3]==GENERATOR)
              { word e=tl[tl[$3]];
                if(tag[e]==AP&&tag[hd[e]]==AP&&
                    (hd[hd[e]]==ITERATE||hd[hd[e]]==ITERATE1))
                  syntax("ill-formed generator\n"); }
            $$ = cons(REPEAT,cons(genlhs($1),$3)); idsused=NIL;  }|
    generator1;

generator1:
    e1 LEFTARROW exp
        = { $$ = cons(GENERATOR,cons(genlhs($1),$3)); idsused=NIL;  }|
    e1 LEFTARROW exp ',' exp DOTDOT
        = { word p = genlhs($1); idsused=NIL;
            $$ = cons(GENERATOR,
                      cons(p,ap2(irrefutable(p)?ITERATE:ITERATE1,
                                 lambda(p,$5),$3)));
          };

defs:
    def|
    defs def;

def:
    v act2 indent '=' here rhs outdent
        = { word l = $1, r = $6;
            word f = head(l);
            if(tag[f]==ID&&!isconstructor(f)) /* fnform defn */
              while(tag[l]==AP)r=lambda(tl[l],r),l=hd[l];
            r = label($5,r); /* to help locate type errors */
            declare(l,r),lastname=l; }|

    spec
        = { word h=reverse(hd[$1]),hr=hd[tl[$1]],t=tl[tl[$1]];
            while(h!=NIL&&!SYNERR)specify(hd[h],t,hr),h=tl[h];
            $$ = cons(nill,NIL); }|

    ABSTYPE here typeforms indent WITH lspecs outdent
        = { extern word TABSTRS;
            extern char *dicp,*dicq;
            word x=reverse($6),ids=NIL,tids=NIL;
            while(x!=NIL&&!SYNERR)
                 specify(hd[hd[x]],cons(tl[tl[hd[x]]],NIL),hd[tl[hd[x]]]),
                  ids=cons(hd[hd[x]],ids),x=tl[x];
            /* each id in specs has its id_type set to const(t,NIL) as a way
               of flagging that t is an abstract type */
            x=reverse($3);
            while(x!=NIL&&!SYNERR)
               { word shfn;
                 decltype(hd[x],abstract_t,undef_t,$2);
                 tids=cons(head(hd[x]),tids);
                 /* check for presence of showfunction */
                 (void)strcpy(dicp,"show");
                 (void)strcat(dicp,get_id(hd[tids]));
                 dicq = dicp+strlen(dicp)+1;
                 shfn=name();
                 if(member(ids,shfn))
                   t_showfn(hd[tids])=shfn;
                 x=tl[x]; }
            TABSTRS = cons(cons(tids,ids),TABSTRS);
            $$ = cons(nill,NIL); }|

    typeform indent act1 here EQEQ type act2 outdent
        = { word x=redtvars(ap($1,$6));
            decltype(hd[x],synonym_t,tl[x],$4);
            $$ = cons(nill,NIL); }|

    typeform indent act1 here COLON2EQ construction act2 outdent
        = { word rhs = $6, r_ids = $6, n=0;
            while(r_ids!=NIL)r_ids=tl[r_ids],n++;
            while(rhs!=NIL&&!SYNERR)
            {  word h=hd[rhs],t=$1,stricts=NIL,i=0;
               while(tag[h]==AP)
                    { if(tag[tl[h]]==AP&&hd[tl[h]]==strict_t)
                        stricts=cons(i,stricts),tl[h]=tl[tl[h]];
                      t=ap2(arrow_t,tl[h],t),h=hd[h],i++; }
               if(tag[h]==ID)
                 declconstr(h,--n,t);
                 /* warning - type not yet in reduced form */
               else { stricts=NIL;
                      if(echoing)putchar('\n');
                      printf("syntax error: illegal construct \"");
                      out_type(hd[rhs]);
                      printf("\" on right of ::=\n");
                      acterror(); } /* can this still happen? check later */
               if(stricts!=NIL) /* ! operators were present */
                 { word k = id_val(h);
                   while(stricts!=NIL)
                        k=ap2(MKSTRICT,i-hd[stricts],k),
                        stricts=tl[stricts];
                   id_val(h)=k; /* overwrite id_val of original constructor */
                 }
               r_ids=cons(h,r_ids);
               rhs = tl[rhs]; }
            if(!SYNERR)decltype($1,algebraic_t,r_ids,$4);
            $$ = cons(nill,NIL); }|

    indent setexp EXPORT parts outdent
        = { inexplist=0;
            if(exports!=NIL)
              errs=$2,
              syntax("multiple %export statements are illegal\n");
            else { if($4==NIL&&exportfiles==NIL&&embargoes!=NIL)
		     exportfiles=cons(PLUS,NIL);
                   exports=cons($2,$4); } /* cons(hereinfo,identifiers) */
            $$ = cons(nill,NIL); }|

    FREE here '{' specs '}'
        = { if(freeids!=NIL)
              errs=$2,
              syntax("multiple %free statements are illegal\n"); else
            { word x=reverse($4);
              while(x!=NIL&&!SYNERR)
                 { specify(hd[hd[x]],tl[tl[hd[x]]],hd[tl[hd[x]]]);
                   freeids=cons(head(hd[hd[x]]),freeids);
                   if(tl[tl[hd[x]]]==type_t)
                     t_class(hd[freeids])=free_t;
                   else id_val(hd[freeids])=FREE; /* conventional value */
                   x=tl[x]; }
              fil_share(hd[files])=0; /* parameterised scripts unshareable */
              freeids=alfasort(freeids); 
              for(x=freeids;x!=NIL;x=tl[x])
                 hd[x]=cons(hd[x],cons(datapair(get_id(hd[x]),0),
                       id_type(hd[x])));
              /* each element of freeids is of the form
                 cons(id,cons(original_name,type)) */
            }
            $$ = cons(nill,NIL); }|

    INCLUDE bindings modifiers outdent
    /* fiddle - 'indent' done by yylex() on reading fileid */
        = { extern char *dicp;
            extern word CLASHES,BAD_DUMP;
            includees=cons(cons($1,cons($3,$2)),includees);
                   /* $1 contains file+hereinfo */
            $$ = cons(nill,NIL); }|

    here BNF { startbnf(); inbnf=1;} names outdent productions ENDIR
    /* fiddle - `indent' done by yylex() while processing directive */
        = { word lhs=NIL,p=$6,subjects,body,startswith=NIL,leftrecs=NIL;
            ihlist=inbnf=0;
            nonterminals=UNION(nonterminals,$4);
            for(;p!=NIL;p=tl[p])
            if(dval(hd[p])==UNDEF)nonterminals=add1(dlhs(hd[p]),nonterminals);
             else lhs=add1(dlhs(hd[p]),lhs);
            nonterminals=setdiff(nonterminals,lhs);
            if(nonterminals!=NIL)
              errs=$1,
              member($4,hd[nonterminals])/*||findnt(hd[nonterminals])*/,
              printf("%sfatal error in grammar, ",echoing?"\n":""),
              printf("undefined nonterminal%s: ",
                      tl[nonterminals]==NIL?"":"s"),
              printlist("",nonterminals),
              acterror(); else
            { /* compute list of nonterminals admitting empty prodn */
            eprodnts=NIL;
          L:for(p=$6;p!=NIL;p=tl[p])
               if(!member(eprodnts,dlhs(hd[p]))&&eprod(dval(hd[p])))
                 { eprodnts=cons(dlhs(hd[p]),eprodnts); goto L; }
            /* now compute startswith reln between nonterminals
               (performing binomial transformation en route)
               and use to detect unremoved left recursion */
            for(p=$6;p!=NIL;p=tl[p])
               if(member(lhs=starts(dval(hd[p])),dlhs(hd[p])))
                 binom(dval(hd[p]),dlhs(hd[p])),
                 startswith=cons(cons(dlhs(hd[p]),starts(dval(hd[p]))),
                                 startswith);
               else startswith=cons(cons(dlhs(hd[p]),lhs),startswith);
            startswith=tclos(sortrel(startswith));
            for(;startswith!=NIL;startswith=tl[startswith])
               if(member(tl[hd[startswith]],hd[hd[startswith]]))
                 leftrecs=add1(hd[hd[startswith]],leftrecs);
            if(leftrecs!=NIL)
              errs=getloc(hd[leftrecs],$6),
              printf("%sfatal error in grammar, ",echoing?"\n":""),
              printlist("irremovable left recursion: ",leftrecs),
              acterror();
            if($4==NIL) /* implied start symbol */
              $4=cons(dlhs(hd[lastlink($6)]),NIL);
            fnts=1; /* fnts is flag indicating %bnf in use */
            if(tl[$4]==NIL) /* only one start symbol */
              subjects=getfname(hd[$4]),
              body=ap2(G_CLOSE,str_conv(get_id(hd[$4])),hd[$4]);
            else
            { body=subjects=Void;
              while($4!=NIL)
                   subjects=pair(getfname(hd[$4]),subjects),
                   body=pair(
                         ap2(G_CLOSE,str_conv(get_id(hd[$4])),hd[$4]),
                            body),
                   $4=tl[$4];
            }
            declare(subjects,label($1,block($6,body, 0)));
          }};

setexp:
    here
        =  { $$=$1;
             inexplist=1; };  /* hack to fix lex analyser */

bindings:
    /* empty */
        = { $$ = NIL; }|
    '{' bindingseq '}'
        = { $$ = $2; };

bindingseq:
    bindingseq binding
        = { $$ = cons($2,$1); }|
    binding
        = { $$ = cons($1,NIL); };

binding:
    NAME indent '=' exp outdent
        =  { $$ = cons($1,$4); }|
    typeform indent act1 EQEQ type act2 outdent
        =  { word x=redtvars(ap($1,$5)); 
             word arity=0,h=hd[x];
             while(tag[h]==AP)arity++,h=hd[h];
             $$ = ap(h,make_typ(arity,0,synonym_t,tl[x]));
           };

modifiers:
    /* empty */
        =  { $$ = NIL; }|
    negmods
        =  { word a,b,c=0;
             for(a=$1;a!=NIL;a=tl[a])
                for(b=tl[a];b!=NIL;b=tl[b])
                   { if(hd[hd[a]]==hd[hd[b]])c=hd[hd[a]];
                     if(tl[hd[a]]==tl[hd[b]])c=tl[hd[a]]; 
                     if(c)break; }
             if(c)printf(
                  "%ssyntax error: conflicting aliases (\"%s\")\n",
                      echoing?"\n":"",
                      get_id(c)),
                  acterror();
           };

negmods:
    negmods negmod
        =  { $$ = cons($2,$1); }|
    negmod
        =  { $$ = cons($1,NIL); };

negmod:
    NAME '/' NAME
        =  { $$ = cons($1,$3); }|
    CNAME '/' CNAME
        =  { $$ = cons($1,$3); }|
    '-' NAME
        =  { $$ = cons(make_pn(UNDEF),$2); }/*|
    '-' CNAME */;  /* no - cannot suppress constructors selectively */

here:
    /* empty */ 
        =  { extern word line_no;
             lasth = $$ = fileinfo(get_fil(current_file),line_no);
             /* (script,line_no) for diagnostics */
           };

act1:
    /* empty */
        = { tvarscope=1; };

act2:
    /* empty */
        = { tvarscope=0; idsused= NIL; };

ldefs:
    ldef
        = { $$ = cons($1,NIL);
            dval($1) = tries(dlhs($1),cons(dval($1),NIL));
            if(!SYNERR&&get_ids(dlhs($1))==NIL)
              errs=hd[hd[tl[dval($1)]]],
              syntax("illegal lhs for local definition\n");
          }|
    ldefs ldef
        = { if(dlhs($2)==dlhs(hd[$1]) /*&&dval(hd[$1])!=UNDEF*/)
              { $$ = $1;
                if(!fallible(hd[tl[dval(hd[$1])]]))
                    errs=hd[dval($2)],
                    printf("%ssyntax error: \
unreachable case in defn of \"%s\"\n",echoing?"\n":"",get_id(dlhs($2))),
                    acterror();
                tl[dval(hd[$1])]=cons(dval($2),tl[dval(hd[$1])]); }
            else if(!SYNERR)
                 { word ns=get_ids(dlhs($2)),hr=hd[dval($2)];
                   if(ns==NIL)
                     errs=hr,
                     syntax("illegal lhs for local definition\n");
                   $$ = cons($2,$1);
                   dval($2)=tries(dlhs($2),cons(dval($2),NIL));
                   while(ns!=NIL&&!SYNERR) /* local nameclash check */
                        { nclashcheck(hd[ns],$1,hr);
                          ns=tl[ns]; }
                        /* potentially quadratic - fix later */
                 }
          };

ldef:
    spec
        = { errs=hd[tl[$1]];
            syntax("`::' encountered in local defs\n");
            $$ = cons(nill,NIL); }|
    typeform here EQEQ
        = { errs=$2;
            syntax("`==' encountered in local defs\n");
            $$ = cons(nill,NIL); }|
    typeform here COLON2EQ
        = { errs=$2;
            syntax("`::=' encountered in local defs\n");
            $$ = cons(nill,NIL); }|
    v act2 indent '=' here rhs outdent
        = { word l = $1, r = $6;
            word f = head(l);
            if(tag[f]==ID&&!isconstructor(f)) /* fnform defn */
              while(tag[l]==AP)r=lambda(tl[l],r),l=hd[l];
            r = label($5,r); /* to help locate type errors */
            $$ = defn(l,undef_t,r); };

vlist:
    v
        = { $$ = cons($1,NIL); }|
    vlist ',' v /* left recursive so as not to eat YACC stack */
        = { $$ = cons($3,$1);  }; /* reverse order, NB */

v:
    v1 |
    v1 ':' v
        = { $$ = cons($1,$3); };

v1:
    v1 '+' CONST  /* n+k pattern */
        = { if(!isnat($3))
              syntax("inappropriate use of \"+\" in pattern\n");
            $$ = ap2(PLUS,$3,$1); }|
    '-' CONST
        = { /* if(tag[$2]==DOUBLE)
              $$ = cons(CONST,sto_dbl(-get_dbl($2))); else */
            if(tag[$2]==INT)
              $$ = cons(CONST,big_negate($2)); else
            syntax("inappropriate use of \"-\" in pattern\n"); }|
    v2 INFIXNAME v1
        = { $$ = ap2($2,$1,$3); }|
    v2 INFIXCNAME v1
        = { $$ = ap2($2,$1,$3); }|
    v2;

v2:
    v3 |
    v2 v3
        = { $$ = ap(hd[$1]==CONST&&tag[tl[$1]]==ID?tl[$1]:$1,$2); };
        /* repeated name apparatus may have wrapped CONST around leading id
           - not wanted */

v3:
    NAME
        = { if(sreds&&member(gvars,$1))syntax("illegal use of $num symbol\n");
              /* cannot use grammar variable in a binding position */
            if(memb(idsused,$1))$$ = cons(CONST,$1);
                            /* picks up repeated names in a template */
            else idsused= cons($1,idsused);   } |
    CNAME |
    CONST
        = { if(tag[$1]==DOUBLE)
	      syntax("use of floating point literal in pattern\n");
	    $$ = cons(CONST,$1); }|
    '[' ']'
        = { $$ = nill; }|
    '[' vlist ']'
        = { word x=$2,y=nill;
            while(x!=NIL)y = cons(hd[x],y), x = tl[x];
            $$ = y; }|
    '(' ')'
        = { $$ = Void; }|
    '(' v ')'
        = { $$ = $2; }|
    '(' v ',' vlist ')'
        = { if(tl[$4]==NIL)$$=pair($2,hd[$4]);
            else { $$=pair(hd[tl[$4]],hd[$4]);
                   $4=tl[tl[$4]];
                   while($4!=NIL)$$=tcons(hd[$4],$$),$4=tl[$4];
                   $$ = tcons($2,$$); }
          /* representation of the tuple (a1,...,an) is
             tcons(a1,tcons(a2,...pair(a(n-1),an))) */
          };

type:
    type1 |
    type ARROW type
        = { $$ = ap2(arrow_t,$1,$3); };

type1:
    type2 INFIXNAME type1
        = { $$ = ap2($2,$1,$3); }|
    type2;

type2:
    /* type2 argtype  /* too permissive - fix later */
        /* = { $$ = ap($1,$2); }| */
    tap|
    argtype;

tap:
    NAME argtype
        = { $$ = ap($1,$2); }|
    tap argtype
        = { $$ = ap($1,$2); };

argtype:
    NAME
        = { $$ = transtypeid($1); }|
           /* necessary while prelude not meta_tchecked (for prelude)*/
    typevar
        = { if(tvarscope&&!memb(idsused,$1))
            printf("%ssyntax error: unbound type variable ",echoing?"\n":""),
                 out_type($1),putchar('\n'),acterror();
            $$ = $1; }|
    '(' typelist ')'
        = { $$ = $2; }|
    '[' type ']'  /* at release one was `typelist' */
        = { $$ = ap(list_t,$2); }|
    '[' type ',' typel ']'
        = { syntax(
             "tuple-type with missing parentheses (obsolete syntax)\n"); };

typelist:
    /* empty */
        = { $$ = void_t; }|  /* voidtype */
    type |
    type ',' typel
        = { word x=$3,y=void_t;
            while(x!=NIL)y = ap2(comma_t,hd[x],y), x = tl[x];
            $$ = ap2(comma_t,$1,y); };

typel:
    type 
        = { $$ = cons($1,NIL); }|
    typel ',' type /* left recursive so as not to eat YACC stack */
        = { $$ = cons($3,$1); };

parts: /* returned in reverse order */
    parts NAME 
        = { $$ = add1($2,$1); }|
    parts '-' NAME
	= { $$ = $1; embargoes=add1($3,embargoes); }|
    parts PATHNAME 
        = { $$ = $1; }| /*the pathnames are placed on exportfiles in yylex*/
    parts '+'
        = { $$ = $1;
            exportfiles=cons(PLUS,exportfiles); }|
    NAME
        = { $$ = add1($1,NIL); }|
    '-' NAME
	= { $$ = NIL; embargoes=add1($2,embargoes); }|
    PATHNAME
        = { $$ = NIL; }|
    '+'
        = { $$ = NIL;
            exportfiles=cons(PLUS,exportfiles); };

specs:  /* returns a list of cons(id,cons(here,type))
           in reverse order of appearance */
    specs spec
        = { word x=$1,h=hd[$2],t=tl[$2];
            while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
            $$ = x; }|
    spec
        = { word x=NIL,h=hd[$1],t=tl[$1];
            while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
            $$ = x; };

spec:
    typeforms indent here COLONCOLON ttype outdent
        = { $$ = cons($1,cons($3,$5)); };
            /* hack: `typeforms' includes `namelist' */

lspecs:  /* returns a list of cons(id,cons(here,type))
           in reverse order of appearance */
    lspecs lspec
        = { word x=$1,h=hd[$2],t=tl[$2];
            while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
            $$ = x; }|
    lspec
        = { word x=NIL,h=hd[$1],t=tl[$1];
            while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
            $$ = x; };

lspec:
    namelist indent here {inbnf=0;} COLONCOLON type outdent
        = { $$ = cons($1,cons($3,$6)); };

namelist:
    NAME ',' namelist
        = { $$ = cons($1,$3); }|
    NAME
        = { $$ = cons($1,NIL); };

typeforms:
    typeforms ',' typeform act2 
        = { $$ = cons($3,$1); }|
    typeform act2
        = { $$ = cons($1,NIL); };
            
typeform:
    CNAME typevars
        = { syntax("upper case identifier out of context\n"); }|
    NAME typevars   /* warning if typevar is repeated */
        = { $$ = $1;
            idsused=$2;
            while($2!=NIL)
              $$ = ap($$,hd[$2]),$2 = tl[$2];
          }|
    typevar INFIXNAME typevar
        = { if(eqtvar($1,$3))
              syntax("repeated type variable in typeform\n");
            idsused=cons($1,cons($3,NIL));
            $$ = ap2($2,$1,$3); }|
    typevar INFIXCNAME typevar
        = { syntax("upper case identifier cannot be used as typename\n"); };

ttype:
    type|
    TYPE
        =  { $$ = type_t; };

typevar:
    '*'
        = { $$ = mktvar(1); }|
    TYPEVAR;

typevars:
    /* empty */
        = { $$ = NIL; }|
    typevar typevars
        = { if(memb($2,$1))
              syntax("repeated type variable on lhs of type def\n");
            $$ = cons($1,$2); };

construction:
    constructs
        = { extern word SGC;  /* keeps track of sui-generis constructors */
            if( tl[$1]==NIL && tag[hd[$1]]!=ID )
                            /* 2nd conjunct excludes singularity types */
              SGC=cons(head(hd[$1]),SGC);
          };

constructs:
    construct
        = { $$ = cons($1,NIL); }|
    constructs '|' construct
        = { $$ = cons($3,$1); };

construct:
    field here INFIXCNAME field
        = { $$ = ap2($3,$1,$4); 
            id_who($3)=$2; }|
    construct1;

construct1:
    '(' construct ')'
        = { $$ = $2; }|
    construct1 field1
        = { $$ = ap($1,$2); }|
    here CNAME
        = { $$ = $2;
            id_who($2)=$1; };

field:
    type|
    argtype '!'
        = { $$ = ap(strict_t,$1); };

field1:
    argtype '!'
        = { $$ = ap(strict_t,$1); }|
    argtype;

names:          /* used twice - for bnf list, and for inherited attr list */
    /* empty */
        = { $$ = NIL; }|
    names NAME
        = { if(member($1,$2))
            printf("%ssyntax error: repeated identifier \"%s\" in %s list\n",
                      echoing?"\n":"",get_id($2),inbnf?"bnf":"attribute"),
              acterror();
            $$ = inbnf?add1($2,$1):cons($2,$1);
          };

productions:
    lspec
        = { word h=reverse(hd[$1]),hr=hd[tl[$1]],t=tl[tl[$1]];
            inbnf=1;
            $$=NIL;
            while(h!=NIL&&!SYNERR)
                 ntspecmap=cons(cons(hd[h],hr),ntspecmap),
                 $$=add_prod(defn(hd[h],t,UNDEF),$$,hr),
                 h=tl[h];
          }|
    production
        = { $$ = cons($1,NIL); }|
    productions lspec
        = { word h=reverse(hd[$2]),hr=hd[tl[$2]],t=tl[tl[$2]];
            inbnf=1;
            $$=$1;
            while(h!=NIL&&!SYNERR)
                 ntspecmap=cons(cons(hd[h],hr),ntspecmap),
                 $$=add_prod(defn(hd[h],t,UNDEF),$$,hr),
                 h=tl[h];
          }|
    productions production
        = { $$ = add_prod($2,$1,hd[dval($2)]); };

production:
    NAME params ':' indent grhs outdent
    /* found by experiment that indent must follow ':' here */
        = { $$ = defn($1,undef_t,$5); };

params:   /* places inherited attributes, if any, on ihlist */
    /* empty */
        = { ihlist=0; }|
    { inbnf=0; } '(' names ')'
        = { inbnf=1;
            if($3==NIL)syntax("unexpected token ')'\n");
            ihlist=$3; }

grhs:
    here phrase
        = { $$ = label($1,$2); };

phrase:
    error_term
        = { $$ = ap2(G_ERROR,G_ZERO,$1); }|
    phrase1
        = { $$=hd[$1], $1=tl[$1];
            while($1!=NIL)
                 $$=label(hd[$1],$$),$1=tl[$1],
                 $$=ap2(G_ALT,hd[$1],$$),$1=tl[$1];
        }|
    phrase1 '|' error_term
        = { $$=hd[$1], $1=tl[$1];
            while($1!=NIL)
                 $$=label(hd[$1],$$),$1=tl[$1],
                 $$=ap2(G_ALT,hd[$1],$$),$1=tl[$1];
            $$ = ap2(G_ERROR,$$,$3); };
    /* we right rotate G_ALT's to facilitate left factoring (see trans) */

phrase1:
    term
        = { $$=cons($1,NIL); }|
    phrase1 '|' here term
        = { $$ = cons($4,cons($3,$1)); };

term:
    count_factors
        = { word n=0,f=$1,rule=Void;
                         /* default value of a production is () */
                         /* rule=mkgvar(sreds); /* formerly last symbol */
            if(f!=NIL&&hd[f]==G_END)sreds++;
            if(ihlist)rule=ih_abstr(rule);
            while(n<sreds)rule=lambda(mkgvar(++n),rule);
            sreds=0;
            rule=ap(G_RULE,rule);
            while(f!=NIL)rule=ap2(G_SEQ,hd[f],rule),f=tl[f];
            $$ = rule; }|
    count_factors {inbnf=2;} indent '=' here rhs outdent
        = { if($1!=NIL&&hd[$1]==G_END)sreds++;
            if(sreds==1&&can_elide($6))
              inbnf=1,sreds=0,$$=hd[$1]; /* optimisation */
            else
            { word f=$1,rule=label($5,$6),n=0;
              inbnf=1;
              if(ihlist)rule=ih_abstr(rule);
              while(n<sreds)rule=lambda(mkgvar(++n),rule);
              sreds=0;
              rule=ap(G_RULE,rule);
              while(f!=NIL)rule=ap2(G_SEQ,hd[f],rule),f=tl[f];
              $$ = rule; }
          };

error_term:
    ERRORSY
        = { word rule = ap(K,Void); /* default value of a production is () */
            if(ihlist)rule=ih_abstr(rule);
            $$ = rule; }|
    ERRORSY { inbnf=2,sreds=2; } indent '=' here rhs outdent
        = { word rule = label($5,$6);
            if(ihlist)rule=ih_abstr(rule);
            $$ = lambda(pair(mkgvar(1),mkgvar(2)),rule);
            inbnf=1,sreds=0; };

count_factors:
    EMPTYSY
        = { sreds=0; $$=NIL; }|
    EMPTYSY factors
        = { syntax("unexpected token after empty\n");
            sreds=0; $$=NIL; }|
    { obrct=0; } factors
        = { word f=$2;
            if(obrct)
              syntax(obrct>0?"unmatched { in grammar rule\n":
                             "unmatched } in grammar rule\n");
            for(sreds=0;f!=NIL;f=tl[f])sreds++;
            if(hd[$2]==G_END)sreds--;
            $$ = $2; };

factors:
    factor
        =  { $$ = cons($1,NIL); }|
    factors factor
        =  { if(hd[$1]==G_END)
               syntax("unexpected token after end\n");
             $$ = cons($2,$1); };

factor:
    unit|
    '{' unit '}'
        = { $$ = ap(outdent_fn,ap2(indent_fn,getcol_fn(),$2)); }|
    '{' unit
        = { obrct++;
            $$ = ap2(indent_fn,getcol_fn(),$2); }|
    unit '}'
        = { if(--obrct<0)syntax("unmatched `}' in grammar rule\n");
            $$ = ap(outdent_fn,$1); } ;

unit:
    symbol|
    symbol '*'
        = { $$ = ap(G_STAR,$1); }|
    symbol '+'
        = { $$ = ap2(G_SEQ,$1,ap2(G_SEQ,ap(G_STAR,$1),ap(G_RULE,ap(C,P)))); }|
    symbol '?'
        = { $$ = ap(G_OPT,$1); };

symbol:
    NAME
        = { extern word NEW;
            nonterminals=newadd1($1,nonterminals);
            if(NEW)ntmap=cons(cons($1,lasth),ntmap); }|
    ENDSY
        = { $$ = G_END; }|
    CONST
        = { if(!isstring($1))
              printf("%ssyntax error: illegal terminal ",echoing?"\n":""),
              out(stdout,$1),printf(" (should be string-const)\n"),
              acterror();
            $$ = ap(G_SYMB,$1); }|
    '^'
        = { $$=G_STATE; }|
    {inbnf=0;} '[' exp {inbnf=1;} ']'
        = { $$ = ap(G_SUCHTHAT,$3); }|
    '-'
        = { $$ = G_ANY; };

%%
/*  end of Miranda rules  */