sources/f2c/gram.hd

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories, Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 %{
  25 #       include "defs.h"
  26 #       include "p1defs.h"
  27
  28 static int nstars;                      /* Number of labels in an
  29                                            alternate return CALL */
  30 static int ndim;
  31 static int vartype;
  32 int new_dcl;
  33 static ftnint varleng;
  34 static struct { expptr lb, ub; } dims[MAXDIM+1];
  35 static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate
  36                                                    return CALL */
  37
  38 /* The next two variables are used to verify that each statement might be reached
  39    during runtime.   lastwasbranch   is tested only in the defintion of the
  40    stat:   nonterminal. */
  41
  42 int lastwasbranch = NO;
  43 static int thiswasbranch = NO;
  44 extern ftnint yystno;
  45 extern flag intonly;
  46 static chainp datastack;
  47 extern long laststfcn, thisstno;
  48 extern int can_include; /* for netlib */
  49
  50 ftnint convci();
  51 Addrp nextdata();
  52 expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
  53 expptr mkcxcon();
  54 struct Listblock *mklist();
  55 struct Listblock *mklist();
  56 struct Impldoblock *mkiodo();
  57 Extsym *comblock();
  58 #define ESNULL (Extsym *)0
  59 #define NPNULL (Namep)0
  60 #define LBNULL (struct Listblock *)0
  61 extern void freetemps(), make_param();
  62
  63  static void
  64 pop_datastack() {
  65         chainp d0 = datastack;
  66         if (d0->datap)
  67                 curdtp = (chainp)d0->datap;
  68         datastack = d0->nextp;
  69         d0->nextp = 0;
  70         frchain(&d0);
  71         }
  72
  73 %}
  74
  75 /* Specify precedences and associativities. */
  76
  77 %union  {
  78         int ival;
  79         ftnint lval;
  80         char *charpval;
  81         chainp chval;
  82         tagptr tagval;
  83         expptr expval;
  84         struct Labelblock *labval;
  85         struct Nameblock *namval;
  86         struct Eqvchain *eqvval;
  87         Extsym *extval;
  88         }
  89
  90 %left SCOMMA
  91 %nonassoc SCOLON
  92 %right SEQUALS
  93 %left SEQV SNEQV
  94 %left SOR
  95 %left SAND
  96 %left SNOT
  97 %nonassoc SLT SGT SLE SGE SEQ SNE
  98 %left SCONCAT
  99 %left SPLUS SMINUS
 100 %left SSTAR SSLASH
 101 %right SPOWER
 102
 103 %start program
 104 %type <labval> thislabel label assignlabel
 105 %type <tagval> other inelt
 106 %type <ival> type typespec typename dcl letter addop relop stop nameeq
 107 %type <lval> lengspec
 108 %type <charpval> filename
 109 %type <chval> datavar datavarlist namelistlist funarglist funargs
 110 %type <chval> dospec dospecw
 111 %type <chval> callarglist arglist args exprlist inlist outlist out2 substring
 112 %type <namval> name arg call var
 113 %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
 114 %type <expval> ubound simple value callarg complex_const simple_const bit_const
 115 %type <extval> common comblock entryname progname
 116 %type <eqvval> equivlist
 117
 118 %%
 119
 120 program:
 121         | program stat SEOS
 122         ;
 123
 124 stat:     thislabel  entry
 125                 {
 126 /* stat:   is the nonterminal for Fortran statements */
 127
 128                   lastwasbranch = NO; }
 129         | thislabel  spec
 130         | thislabel  exec
 131                 { /* forbid further statement function definitions... */
 132                   if (parstate == INDATA && laststfcn != thisstno)
 133                         parstate = INEXEC;
 134                   thisstno++;
 135                   if($1 && ($1->labelno==dorange))
 136                         enddo($1->labelno);
 137                   if(lastwasbranch && thislabel==NULL)
 138                         warn("statement cannot be reached");
 139                   lastwasbranch = thiswasbranch;
 140                   thiswasbranch = NO;
 141                   if($1)
 142                         {
 143                         if($1->labtype == LABFORMAT)
 144                                 err("label already that of a format");
 145                         else
 146                                 $1->labtype = LABEXEC;
 147                         }
 148                   freetemps();
 149                 }
 150         | thislabel SINCLUDE filename
 151                 { if (can_include)
 152                         doinclude( $3 );
 153                   else {
 154                         fprintf(diagfile, "Cannot open file %s\n", $3);
 155                         done(1);
 156                         }
 157                 }
 158         | thislabel  SEND  end_spec
 159                 { if ($1)
 160                         lastwasbranch = NO;
 161                   endproc(); /* lastwasbranch = NO; -- set in endproc() */
 162                 }
 163         | thislabel SUNKNOWN
 164                 { extern void unclassifiable();
 165                   unclassifiable();
 166
 167 /* flline flushes the current line, ignoring the rest of the text there */
 168
 169                   flline(); };
 170         | error
 171                 { flline();  needkwd = NO;  inioctl = NO;
 172                   yyerrok; yyclearin; }
 173         ;
 174
 175 thislabel:  SLABEL
 176                 {
 177                 if(yystno != 0)
 178                         {
 179                         $$ = thislabel =  mklabel(yystno);
 180                         if( ! headerdone ) {
 181                                 if (procclass == CLUNKNOWN)
 182                                         procclass = CLMAIN;
 183                                 puthead(CNULL, procclass);
 184                                 }
 185                         if(thislabel->labdefined)
 186                                 execerr("label %s already defined",
 187                                         convic(thislabel->stateno) );
 188                         else    {
 189                                 if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
 190                                     && thislabel->labtype!=LABFORMAT)
 191                                         warn1("there is a branch to label %s from outside block",
 192                                               convic( (ftnint) (thislabel->stateno) ) );
 193                                 thislabel->blklevel = blklevel;
 194                                 thislabel->labdefined = YES;
 195                                 if(thislabel->labtype != LABFORMAT)
 196                                         p1_label((long)(thislabel - labeltab));
 197                                 }
 198                         }
 199                 else    $$ = thislabel = NULL;
 200                 }
 201         ;
 202
 203 entry:    SPROGRAM new_proc progname
 204                    {startproc($3, CLMAIN); }
 205         | SPROGRAM new_proc progname progarglist
 206                    {    warn("ignoring arguments to main program");
 207                         /* hashclear(); */
 208                         startproc($3, CLMAIN); }
 209         | SBLOCK new_proc progname
 210                 { if($3) NO66("named BLOCKDATA");
 211                   startproc($3, CLBLOCK); }
 212         | SSUBROUTINE new_proc entryname arglist
 213                 { entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
 214         | SFUNCTION new_proc entryname arglist
 215                 { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
 216         | type SFUNCTION new_proc entryname arglist
 217                 { entrypt(CLPROC, $1, varleng, $4, $5); }
 218         | SENTRY entryname arglist
 219                  { if(parstate==OUTSIDE || procclass==CLMAIN
 220                         || procclass==CLBLOCK)
 221                                 execerr("misplaced entry statement", CNULL);
 222                   entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
 223                 }
 224         ;
 225
 226 new_proc:
 227                 { newproc(); }
 228         ;
 229
 230 entryname:  name
 231                 { $$ = newentry($1, 1); }
 232         ;
 233
 234 name:     SNAME
 235                 { $$ = mkname(token); }
 236         ;
 237
 238 progname:               { $$ = NULL; }
 239         | entryname
 240         ;
 241
 242 progarglist:
 243           SLPAR SRPAR
 244         | SLPAR progargs SRPAR
 245         ;
 246
 247 progargs: progarg
 248         | progargs SCOMMA progarg
 249         ;
 250
 251 progarg:  SNAME
 252         | SNAME SEQUALS SNAME
 253         ;
 254
 255 arglist:
 256                 { $$ = 0; }
 257         | SLPAR SRPAR
 258                 { NO66(" () argument list");
 259                   $$ = 0; }
 260         | SLPAR args SRPAR
 261                 {$$ = $2; }
 262         ;
 263
 264 args:     arg
 265                 { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
 266         | args SCOMMA arg
 267                 { if($3) $1 = $$ = mkchain((char *)$3, $1); }
 268         ;
 269
 270 arg:      name
 271                 { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
 272                         dclerr("name declared as argument after use", $1);
 273                   $1->vstg = STGARG;
 274                 }
 275         | SSTAR
 276                 { NO66("altenate return argument");
 277
 278 /* substars   means that '*'ed formal parameters should be replaced.
 279    This is used to specify alternate return labels; in theory, only
 280    parameter slots which have '*' should accept the statement labels.
 281    This compiler chooses to ignore the '*'s in the formal declaration, and
 282    always return the proper value anyway.
 283
 284    This variable is only referred to in   proc.c   */
 285
 286                   $$ = 0;  substars = YES; }
 287         ;
 288
 289
 290
 291 filename:   SHOLLERITH
 292                 {
 293                 char *s;
 294                 s = copyn(toklen+1, token);
 295                 s[toklen] = '\0';
 296                 $$ = s;
 297                 }
 298         ;