4.4BSD/usr/src/usr.bin/f77/pass1.vax/gram.head
/*-
* Copyright (c) 1980 The Regents of the University of California.
* All rights reserved.
*
* This module is believed to contain source code proprietary to AT&T.
* Use and redistribution is subject to the Berkeley Software License
* Agreement and your Software Agreement with AT&T (Western Electric).
*
* @(#)gram.head 5.2 (Berkeley) 4/12/91
*/
/*
* 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;
}
;