lang/fortran/comp/gram.head

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