Added
This commit is contained in:
ceriel
299
lang/fortran/comp/gram.head
Normal file
299
lang/fortran/comp/gram.head
Normal file
@@ -0,0 +1,299 @@
|
||||
/****************************************************************
|
||||
Copyright 1990 by AT&T Bell Laboratories, Bellcore.
|
||||
|
||||
Permission to use, copy, modify, and distribute this software
|
||||
and its documentation for any purpose and without fee is hereby
|
||||
granted, provided that the above copyright notice appear in all
|
||||
copies and that both that the copyright notice and this
|
||||
permission notice and warranty disclaimer appear in supporting
|
||||
documentation, and that the names of AT&T Bell Laboratories or
|
||||
Bellcore or any of their entities not be used in advertising or
|
||||
publicity pertaining to distribution of the software without
|
||||
specific, written prior permission.
|
||||
|
||||
AT&T and Bellcore disclaim all warranties with regard to this
|
||||
software, including all implied warranties of merchantability
|
||||
and fitness. In no event shall AT&T or Bellcore be liable for
|
||||
any special, indirect or consequential damages or any damages
|
||||
whatsoever resulting from loss of use, data or profits, whether
|
||||
in an action of contract, negligence or other tortious action,
|
||||
arising out of or in connection with the use or performance of
|
||||
this software.
|
||||
****************************************************************/
|
||||
|
||||
%{
|
||||
# include "defs.h"
|
||||
# include "p1defs.h"
|
||||
|
||||
static int nstars; /* Number of labels in an
|
||||
alternate return CALL */
|
||||
static int datagripe;
|
||||
static int ndim;
|
||||
static int vartype;
|
||||
int new_dcl;
|
||||
static ftnint varleng;
|
||||
static struct Dims dims[MAXDIM+1];
|
||||
static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate
|
||||
return CALL */
|
||||
|
||||
/* The next two variables are used to verify that each statement might be reached
|
||||
during runtime. lastwasbranch is tested only in the defintion of the
|
||||
stat: nonterminal. */
|
||||
|
||||
int lastwasbranch = NO;
|
||||
static int thiswasbranch = NO;
|
||||
extern ftnint yystno;
|
||||
extern flag intonly;
|
||||
static chainp datastack;
|
||||
extern long laststfcn, thisstno;
|
||||
extern int can_include; /* for netlib */
|
||||
|
||||
ftnint convci();
|
||||
Addrp nextdata();
|
||||
expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
|
||||
expptr mkcxcon();
|
||||
struct Listblock *mklist();
|
||||
struct Listblock *mklist();
|
||||
struct Impldoblock *mkiodo();
|
||||
Extsym *comblock();
|
||||
#define ESNULL (Extsym *)0
|
||||
#define NPNULL (Namep)0
|
||||
#define LBNULL (struct Listblock *)0
|
||||
extern void freetemps(), make_param();
|
||||
|
||||
static void
|
||||
pop_datastack() {
|
||||
chainp d0 = datastack;
|
||||
if (d0->datap)
|
||||
curdtp = (chainp)d0->datap;
|
||||
datastack = d0->nextp;
|
||||
d0->nextp = 0;
|
||||
frchain(&d0);
|
||||
}
|
||||
|
||||
%}
|
||||
|
||||
/* Specify precedences and associativities. */
|
||||
|
||||
%union {
|
||||
int ival;
|
||||
ftnint lval;
|
||||
char *charpval;
|
||||
chainp chval;
|
||||
tagptr tagval;
|
||||
expptr expval;
|
||||
struct Labelblock *labval;
|
||||
struct Nameblock *namval;
|
||||
struct Eqvchain *eqvval;
|
||||
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> type typespec typename dcl letter addop relop stop nameeq
|
||||
%type <lval> lengspec
|
||||
%type <charpval> filename
|
||||
%type <chval> datavar datavarlist namelistlist funarglist funargs
|
||||
%type <chval> dospec dospecw
|
||||
%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
|
||||
{
|
||||
/* stat: is the nonterminal for Fortran statements */
|
||||
|
||||
lastwasbranch = NO; }
|
||||
| thislabel spec
|
||||
| thislabel exec
|
||||
{ /* forbid further statement function definitions... */
|
||||
if (parstate == INDATA && laststfcn != thisstno)
|
||||
parstate = INEXEC;
|
||||
thisstno++;
|
||||
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;
|
||||
}
|
||||
freetemps();
|
||||
}
|
||||
| thislabel SINCLUDE filename
|
||||
{ if (can_include)
|
||||
doinclude( $3 );
|
||||
else {
|
||||
fprintf(diagfile, "Cannot open file %s\n", $3);
|
||||
done(1);
|
||||
}
|
||||
}
|
||||
| thislabel SEND end_spec
|
||||
{ if ($1)
|
||||
lastwasbranch = NO;
|
||||
endproc(); /* lastwasbranch = NO; -- set in endproc() */
|
||||
}
|
||||
| thislabel SUNKNOWN
|
||||
{ extern void unclassifiable();
|
||||
unclassifiable();
|
||||
|
||||
/* flline flushes the current line, ignoring the rest of the text there */
|
||||
|
||||
flline(); };
|
||||
| error
|
||||
{ flline(); needkwd = NO; inioctl = NO;
|
||||
yyerrok; yyclearin; }
|
||||
;
|
||||
|
||||
thislabel: SLABEL
|
||||
{
|
||||
if(yystno != 0)
|
||||
{
|
||||
$$ = thislabel = mklabel(yystno);
|
||||
if( ! headerdone ) {
|
||||
if (procclass == CLUNKNOWN)
|
||||
procclass = CLMAIN;
|
||||
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)
|
||||
p1_label((long)(thislabel - labeltab));
|
||||
}
|
||||
}
|
||||
else $$ = thislabel = NULL;
|
||||
}
|
||||
;
|
||||
|
||||
entry: SPROGRAM new_proc progname
|
||||
{startproc($3, CLMAIN); }
|
||||
| SPROGRAM new_proc progname progarglist
|
||||
{ warn("ignoring arguments to main program");
|
||||
/* hashclear(); */
|
||||
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, 1); }
|
||||
;
|
||||
|
||||
name: SNAME
|
||||
{ $$ = mkname(token); }
|
||||
;
|
||||
|
||||
progname: { $$ = NULL; }
|
||||
| entryname
|
||||
;
|
||||
|
||||
progarglist:
|
||||
SLPAR SRPAR
|
||||
| SLPAR progargs SRPAR
|
||||
;
|
||||
|
||||
progargs: progarg
|
||||
| progargs SCOMMA progarg
|
||||
;
|
||||
|
||||
progarg: SNAME
|
||||
| SNAME SEQUALS SNAME
|
||||
;
|
||||
|
||||
arglist:
|
||||
{ $$ = 0; }
|
||||
| SLPAR SRPAR
|
||||
{ NO66(" () argument list");
|
||||
$$ = 0; }
|
||||
| SLPAR args SRPAR
|
||||
{$$ = $2; }
|
||||
;
|
||||
|
||||
args: arg
|
||||
{ $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
|
||||
| args SCOMMA arg
|
||||
{ if($3) $1 = $$ = mkchain((char *)$3, $1); }
|
||||
;
|
||||
|
||||
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");
|
||||
|
||||
/* substars means that '*'ed formal parameters should be replaced.
|
||||
This is used to specify alternate return labels; in theory, only
|
||||
parameter slots which have '*' should accept the statement labels.
|
||||
This compiler chooses to ignore the '*'s in the formal declaration, and
|
||||
always return the proper value anyway.
|
||||
|
||||
This variable is only referred to in proc.c */
|
||||
|
||||
$$ = 0; substars = YES; }
|
||||
;
|
||||
|
||||
|
||||
|
||||
filename: SHOLLERITH
|
||||
{
|
||||
char *s;
|
||||
s = copyn(toklen+1, token);
|
||||
s[toklen] = '\0';
|
||||
$$ = s;
|
||||
}
|
||||
;
|
||||
Reference in New Issue
Block a user