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