BSD 4_3 release

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

/*
* Copyright (c) 1980 Regents of the University of California.
* All rights reserved.  The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
*
*      @(#)gram.head   5.1 (Berkeley) 6/7/85
*/

/*
* gram.head
*
* First part of the f77 grammar, f77 compiler pass 1.
*
* University of Utah CS Dept modification history:
*
* $Log:        gram.head,v $
* Revision 3.2  84/11/06  17:40:52  donn
* Fixed bug with redundant labels causing errors when they appear on (e.g.)
* PROGRAM statements.
* 
* Revision 3.1  84/10/13  00:22:16  donn
* Merged Jerry Berkman's version into mine.
* 
* Revision 2.2  84/08/04  21:13:02  donn
* Moved some code out of gram.head into gram.exec in accordance with
* Jerry Berkman's fixes to make ASSIGNs work right.
* 
* Revision 2.1  84/07/19  12:03:20  donn
* Changed comment headers for UofU.
* 
* Revision 1.2  84/03/23  22:43:06  donn
* The subroutine argument temporary fixes from Bob Corbett didn't take into
* account the fact that the code generator collects all the assignments to
* temporaries at the start of a statement -- hence the temporaries need to
* be initialized once per statement instead of once per call.
* 
*/

%{
#       include "defs.h"
#       include "data.h"

#ifdef SDB
#       include <a.out.h>

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

static int equivlisterr;
static int do_name_err;
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();
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;
       union  Vexpr *vexpval;
       struct ValList *drvals;
       struct Vlist *dvals;
       union  Delt *deltp;
       struct Rpair *rpairp;
       struct Elist *elistp;
       }

%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> namelistlist funarglist funargs dospec
%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
%type <namval> name arg call var entryname progname
%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
%type <expval> ubound callarg complex_const simple_const 
%type <extval> common comblock
%type <eqvval> equivlist
%type <expval> datavalue real_const unsignedreal bit_const
%type <vexpval> unsignedint int_const
%type <vexpval> dataname
%type <vexpval> iconprimary iconfactor iconterm iconexpr opticonexpr
%type <drvals>  datarval datarvals
%type <dvals>   iconexprlist datasubs
%type <deltp>   dataelt dataimplieddo datalval
%type <rpairp>  datarange
%type <elistp>  dlist datalvals

%%

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;
                       }
                 if(!optimflag)
                       {
                       argtemplist = hookup(argtemplist, activearglist);
                       activearglist = CHNULL;
                       }
               }
       | 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
               if( sdbflag )
                       {
                       linenostab(lineno);
                       }
#endif

               if(yystno != 0)
                       {
                       $$ = thislabel =  mklabel(yystno);
                       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;
                               }
                       }
               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
       ;

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)
                               || ($1->vclass == CLPARAM) ) {
                       dclerr("name declared as argument after use", $1);
                       $$ = NULL;
                 } else
                       $1->vstg = STGARG;
               }
       | SSTAR
               { NO66("altenate return argument");
                 $$ = 0;  substars = YES; }
       ;



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