1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  *
   6:  *	@(#)gram.head	5.1 (Berkeley) 6/7/85
   7:  */
   8: 
   9: /*
  10:  * gram.head
  11:  *
  12:  * First part of the f77 grammar, f77 compiler pass 1.
  13:  *
  14:  * University of Utah CS Dept modification history:
  15:  *
  16:  * $Log:	gram.head,v $
  17:  * Revision 3.2  84/11/06  17:40:52  donn
  18:  * Fixed bug with redundant labels causing errors when they appear on (e.g.)
  19:  * PROGRAM statements.
  20:  *
  21:  * Revision 3.1  84/10/13  00:22:16  donn
  22:  * Merged Jerry Berkman's version into mine.
  23:  *
  24:  * Revision 2.2  84/08/04  21:13:02  donn
  25:  * Moved some code out of gram.head into gram.exec in accordance with
  26:  * Jerry Berkman's fixes to make ASSIGNs work right.
  27:  *
  28:  * Revision 2.1  84/07/19  12:03:20  donn
  29:  * Changed comment headers for UofU.
  30:  *
  31:  * Revision 1.2  84/03/23  22:43:06  donn
  32:  * The subroutine argument temporary fixes from Bob Corbett didn't take into
  33:  * account the fact that the code generator collects all the assignments to
  34:  * temporaries at the start of a statement -- hence the temporaries need to
  35:  * be initialized once per statement instead of once per call.
  36:  *
  37:  */
  38: 
  39: %{
  40: #	include "defs.h"
  41: #	include "data.h"
  42: 
  43: #ifdef SDB
  44: #	include <a.out.h>
  45: 
  46: #	ifndef N_SO
  47: #		include <stab.h>
  48: #	endif
  49: #endif
  50: 
  51: static int equivlisterr;
  52: static int do_name_err;
  53: static int nstars;
  54: static int ndim;
  55: static int vartype;
  56: static ftnint varleng;
  57: static struct { expptr lb, ub; } dims[MAXDIM+1];
  58: static struct Labelblock *labarray[MAXLABLIST];
  59: static int lastwasbranch = NO;
  60: static int thiswasbranch = NO;
  61: extern ftnint yystno;
  62: extern flag intonly;
  63: 
  64: ftnint convci();
  65: double convcd();
  66: expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
  67: expptr mkcxcon();
  68: struct Listblock *mklist();
  69: struct Listblock *mklist();
  70: struct Impldoblock *mkiodo();
  71: struct Extsym *comblock();
  72: 
  73: %}
  74: 
  75: /* Specify precedences and associativities. */
  76: 
  77: %union  {
  78:     int ival;
  79:     char *charpval;
  80:     chainp chval;
  81:     tagptr tagval;
  82:     expptr expval;
  83:     struct Labelblock *labval;
  84:     struct Nameblock *namval;
  85:     struct Eqvchain *eqvval;
  86:     struct Extsym *extval;
  87:     union  Vexpr *vexpval;
  88:     struct ValList *drvals;
  89:     struct Vlist *dvals;
  90:     union  Delt *deltp;
  91:     struct Rpair *rpairp;
  92:     struct Elist *elistp;
  93:     }
  94: 
  95: %left SCOMMA
  96: %nonassoc SCOLON
  97: %right SEQUALS
  98: %left SEQV SNEQV
  99: %left SOR
 100: %left SAND
 101: %left SNOT
 102: %nonassoc SLT SGT SLE SGE SEQ SNE
 103: %left SCONCAT
 104: %left SPLUS SMINUS
 105: %left SSTAR SSLASH
 106: %right SPOWER
 107: 
 108: %start program
 109: %type <labval> thislabel label assignlabel
 110: %type <tagval> other inelt
 111: %type <ival> lengspec type typespec typename dcl letter addop relop stop nameeq
 112: %type <charpval> filename
 113: %type <chval> namelistlist funarglist funargs dospec
 114: %type <chval> callarglist arglist args exprlist inlist outlist out2 substring
 115: %type <namval> name arg call var entryname progname
 116: %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
 117: %type <expval> ubound callarg complex_const simple_const
 118: %type <extval> common comblock
 119: %type <eqvval> equivlist
 120: %type <expval> datavalue real_const unsignedreal bit_const
 121: %type <vexpval> unsignedint int_const
 122: %type <vexpval> dataname
 123: %type <vexpval> iconprimary iconfactor iconterm iconexpr opticonexpr
 124: %type <drvals>  datarval datarvals
 125: %type <dvals>   iconexprlist datasubs
 126: %type <deltp>   dataelt dataimplieddo datalval
 127: %type <rpairp>  datarange
 128: %type <elistp>  dlist datalvals
 129: 
 130: %%
 131: 
 132: program:
 133:     | program stat SEOS
 134:     ;
 135: 
 136: stat:     thislabel  entry
 137:         { lastwasbranch = NO; }
 138:     | thislabel  spec
 139:     | thislabel  exec
 140:         { if($1 && ($1->labelno==dorange))
 141:             enddo($1->labelno);
 142:           if(lastwasbranch && thislabel==NULL)
 143:             warn("statement cannot be reached");
 144:           lastwasbranch = thiswasbranch;
 145:           thiswasbranch = NO;
 146:           if($1)
 147:             {
 148:             if($1->labtype == LABFORMAT)
 149:                 err("label already that of a format");
 150:             else
 151:                 $1->labtype = LABEXEC;
 152:             }
 153:           if(!optimflag)
 154:             {
 155:             argtemplist = hookup(argtemplist, activearglist);
 156:             activearglist = CHNULL;
 157:             }
 158:         }
 159:     | thislabel SINCLUDE filename
 160:         { doinclude( $3 ); }
 161:     | thislabel  SEND  end_spec
 162:         { lastwasbranch = NO;  endproc(); }
 163:     | thislabel SUNKNOWN
 164:         { execerr("unclassifiable statement", CNULL);  flline(); };
 165:     | error
 166:         { flline();  needkwd = NO;  inioctl = NO;
 167:           yyerrok; yyclearin; }
 168:     ;
 169: 
 170: thislabel:  SLABEL
 171:         {
 172: #ifdef SDB
 173:         if( sdbflag )
 174:             {
 175:             linenostab(lineno);
 176:             }
 177: #endif
 178: 
 179:         if(yystno != 0)
 180:             {
 181:             $$ = thislabel =  mklabel(yystno);
 182:             if(thislabel->labdefined)
 183:                 execerr("label %s already defined",
 184:                     convic(thislabel->stateno) );
 185:             else    {
 186:                 if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
 187:                     && thislabel->labtype!=LABFORMAT)
 188:                     warn1("there is a branch to label %s from outside block",
 189:                           convic( (ftnint) (thislabel->stateno) ) );
 190:                 thislabel->blklevel = blklevel;
 191:                 thislabel->labdefined = YES;
 192:                 }
 193:             }
 194:         else    $$ = thislabel = NULL;
 195:         }
 196:     ;
 197: 
 198: entry:    SPROGRAM new_proc progname
 199:            {startproc($3, CLMAIN); }
 200:     | SBLOCK new_proc progname
 201:         { if($3) NO66("named BLOCKDATA");
 202:           startproc($3, CLBLOCK); }
 203:     | SSUBROUTINE new_proc entryname arglist
 204:         { entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
 205:     | SFUNCTION new_proc entryname arglist
 206:         { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
 207:     | type SFUNCTION new_proc entryname arglist
 208:         { entrypt(CLPROC, $1, varleng, $4, $5); }
 209:     | SENTRY entryname arglist
 210:         { if(parstate==OUTSIDE || procclass==CLMAIN
 211:             || procclass==CLBLOCK)
 212:                 execerr("misplaced entry statement", CNULL);
 213:             entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
 214:         }
 215:     ;
 216: 
 217: new_proc:
 218:         { newproc(); }
 219:     ;
 220: 
 221: entryname:  name
 222:     ;
 223: 
 224: name:     SNAME
 225:         { $$ = mkname(toklen, token); }
 226:     ;
 227: 
 228: progname:       { $$ = NULL; }
 229:     | entryname
 230:     ;
 231: 
 232: arglist:
 233:         { $$ = 0; }
 234:     | SLPAR SRPAR
 235:         { NO66(" () argument list");
 236:           $$ = 0; }
 237:     | SLPAR args SRPAR
 238:         {$$ = $2; }
 239:     ;
 240: 
 241: args:     arg
 242:         { $$ = ($1 ? mkchain($1,CHNULL) : CHNULL ); }
 243:     | args SCOMMA arg
 244:         { if($3) $1 = $$ = hookup($1, mkchain($3,CHNULL)); }
 245:     ;
 246: 
 247: arg:      name
 248:         { if(($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
 249:                 || ($1->vclass == CLPARAM) ) {
 250:             dclerr("name declared as argument after use", $1);
 251:             $$ = NULL;
 252:           } else
 253:             $1->vstg = STGARG;
 254:         }
 255:     | SSTAR
 256:         { NO66("altenate return argument");
 257:           $$ = 0;  substars = YES; }
 258:     ;
 259: 
 260: 
 261: 
 262: filename:   SHOLLERITH
 263:         {
 264:         char *s;
 265:         s = copyn(toklen+1, token);
 266:         s[toklen] = '\0';
 267:         $$ = s;
 268:         }
 269:     ;
Last modified: 1985-06-08
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1409
Valid CSS Valid XHTML 1.0 Strict