BSD 4 release

[unix-history] / usr / src / cmd / f77 / gram.head

%{
#       include "defs"

#ifdef SDB
#       include <a.out.h>
char *stabline();
#       ifdef UCBVAXASM
               char *stabdline();
#       endif

#       ifndef N_SO
#               include <stab.h>
#       endif
#endif

static int nstars;
static int ndim;
static int vartype;
static ftnint varleng;
static struct { expptr lb, ub; } dims[MAXDIM+1];
static struct Labelblock *labarray[MAXLABLIST];
static int lastwasbranch = NO;
static int thiswasbranch = NO;
extern ftnint yystno;
extern flag intonly;

ftnint convci();
double convcd();
Addrp nextdata();
expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
expptr mkcxcon();
struct Listblock *mklist();
struct Listblock *mklist();
struct Impldoblock *mkiodo();
struct Extsym *comblock();

%}

/* Specify precedences and associativities. */

%union  {
       int ival;
       char *charpval;
       chainp chval;
       tagptr tagval;
       expptr expval;
       struct Labelblock *labval;
       struct Nameblock *namval;
       struct Eqvchain *eqvval;
       struct Extsym *extval;
       }

%left SCOMMA
%nonassoc SCOLON
%right SEQUALS
%left SEQV SNEQV
%left SOR
%left SAND
%left SNOT
%nonassoc SLT SGT SLE SGE SEQ SNE
%left SCONCAT
%left SPLUS SMINUS
%left SSTAR SSLASH
%right SPOWER

%start program
%type <labval> thislabel label assignlabel
%type <tagval> other inelt
%type <ival> lengspec type typespec typename dcl letter addop relop stop nameeq
%type <charpval> filename
%type <chval> datavar datavarlist namelistlist funarglist funargs dospec
%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
%type <namval> name arg call var
%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
%type <expval> ubound simple value callarg complex_const simple_const bit_const
%type <extval> common comblock entryname progname
%type <eqvval> equivlist

%%

program:
       | program stat SEOS
       ;

stat:     thislabel  entry
               { lastwasbranch = NO; }
       | thislabel  spec
       | thislabel  exec
               { if($1 && ($1->labelno==dorange))
                       enddo($1->labelno);
                 if(lastwasbranch && thislabel==NULL)
                       warn("statement cannot be reached");
                 lastwasbranch = thiswasbranch;
                 thiswasbranch = NO;
                 if($1)
                       {
                       if($1->labtype == LABFORMAT)
                               err("label already that of a format");
                       else
                               $1->labtype = LABEXEC;
                       }
               }
       | thislabel SINCLUDE filename
               { doinclude( $3 ); }
       | thislabel  SEND  end_spec
               { lastwasbranch = NO;  endproc(); }
       | thislabel SUNKNOWN
               { execerr("unclassifiable statement", CNULL);  flline(); };
       | error
               { flline();  needkwd = NO;  inioctl = NO; 
                 yyerrok; yyclearin; }
       ;

thislabel:  SLABEL
               {
#ifdef SDB
               char buff[10];
               if( sdbflag )
                       {
#       ifdef UCBVAXASM
                       p2pass( stabdline(N_SLINE, lineno) );
#       else
                       sprintf(buff,"LL%d", ++dbglabel);
                       p2pass( stabline(0, N_SLINE, lineno, buff) );
                       p2pi("LL%d:\n", dbglabel);
#       endif
                       }
#endif

               if(yystno != 0)
                       {
                       $$ = thislabel =  mklabel(yystno);
                       if( ! headerdone )
                               puthead(CNULL, procclass);
                       if(thislabel->labdefined)
                               execerr("label %s already defined",
                                       convic(thislabel->stateno) );
                       else    {
                               if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
                                   && thislabel->labtype!=LABFORMAT)
                                       warn1("there is a branch to label %s from outside block",
                                             convic( (ftnint) (thislabel->stateno) ) );
                               thislabel->blklevel = blklevel;
                               thislabel->labdefined = YES;
                               if(thislabel->labtype != LABFORMAT)
                                       putlabel(thislabel->labelno);
                               }
                       }
               else    $$ = thislabel = NULL;
               }
       ;

entry:    SPROGRAM new_proc progname
                  {startproc($3, CLMAIN); }
       | SBLOCK new_proc progname
               { if($3) NO66("named BLOCKDATA");
                 startproc($3, CLBLOCK); }
       | SSUBROUTINE new_proc entryname arglist
               { entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
       | SFUNCTION new_proc entryname arglist
               { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
       | type SFUNCTION new_proc entryname arglist
               { entrypt(CLPROC, $1, varleng, $4, $5); }
       | SENTRY entryname arglist
                { if(parstate==OUTSIDE || procclass==CLMAIN
                       || procclass==CLBLOCK)
                               execerr("misplaced entry statement", CNULL);
                 entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
               }
       ;

new_proc:
               { newproc(); }
       ;

entryname:  name
               { $$ = newentry($1); }
       ;

name:     SNAME
               { $$ = mkname(toklen, token); }
       ;

progname:               { $$ = NULL; }
       | entryname
       ;

arglist:
               { $$ = 0; }
       | SLPAR SRPAR
               { NO66(" () argument list");
                 $$ = 0; }
       | SLPAR args SRPAR
               {$$ = $2; }
       ;

args:     arg
               { $$ = ($1 ? mkchain($1,CHNULL) : CHNULL ); }
       | args SCOMMA arg
               { if($3) $1 = $$ = hookup($1, mkchain($3,CHNULL)); }
       ;

arg:      name
               { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
                       dclerr("name declared as argument after use", $1);
                 $1->vstg = STGARG;
               }
       | SSTAR
               { NO66("altenate return argument");
                 $$ = 0;  substars = YES; }
       ;



filename:   SHOLLERITH
               {
               char *s;
               s = copyn(toklen+1, token);
               s[toklen] = '\0';
               $$ = s;
               }
       ;