diff options
Diffstat (limited to 'usr.bin/f2c/gram.head')
| -rw-r--r-- | usr.bin/f2c/gram.head | 300 |
1 files changed, 300 insertions, 0 deletions
diff --git a/usr.bin/f2c/gram.head b/usr.bin/f2c/gram.head new file mode 100644 index 0000000..4af7dc7 --- /dev/null +++ b/usr.bin/f2c/gram.head @@ -0,0 +1,300 @@ +/**************************************************************** +Copyright 1990, 1993 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]; +extern struct Labelblock **labarray; /* Labels in an alternate + return CALL */ +extern int maxlablist; + +/* 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; + } + ; |
