1spec: dcl 2 | common 3 | external 4 | intrinsic 5 | equivalence 6 | data 7 | implicit 8 | SSAVE 9 { saveall = YES; } 10 | SSAVE savelist 11 | SFORMAT 12 { fmtstmt(thislabel); setfmt(thislabel); } 13 | SPARAM in_dcl SLPAR paramlist SRPAR 14 ; 15 16dcl: type name in_dcl dims lengspec 17 { settype($2, $1, $5); 18 if(ndim>0) setbound($2,ndim,dims); 19 } 20 | dcl SCOMMA name dims lengspec 21 { settype($3, $1, $5); 22 if(ndim>0) setbound($3,ndim,dims); 23 } 24 ; 25 26type: typespec lengspec 27 { varleng = $2; } 28 ; 29 30typespec: typename 31 { varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]); } 32 ; 33 34typename: SINTEGER { $$ = TYLONG; } 35 | SREAL { $$ = TYREAL; } 36 | SCOMPLEX { $$ = TYCOMPLEX; } 37 | SDOUBLE { $$ = TYDREAL; } 38 | SDCOMPLEX { $$ = TYDCOMPLEX; } 39 | SLOGICAL { $$ = TYLOGICAL; } 40 | SCHARACTER { $$ = TYCHAR; } 41 | SUNDEFINED { $$ = TYUNKNOWN; } 42 | SDIMENSION { $$ = TYUNKNOWN; } 43 | SAUTOMATIC { $$ = - STGAUTO; } 44 | SSTATIC { $$ = - STGBSS; } 45 ; 46 47lengspec: 48 { $$ = varleng; } 49 | SSTAR expr 50 { 51 if( ! ISICON($2) ) 52 { 53 $$ = 0; 54 dclerr("length must be an integer constant", 0); 55 } 56 else $$ = $2->b_const.fconst.ci; 57 } 58 | SSTAR SLPAR SSTAR SRPAR 59 { $$ = 0; } 60 ; 61 62common: SCOMMON in_dcl var 63 { incomm( $$ = comblock(0, 0) , $3 ); } 64 | SCOMMON in_dcl comblock var 65 { $$ = $3; incomm($3, $4); } 66 | common opt_comma comblock opt_comma var 67 { $$ = $3; incomm($3, $5); } 68 | common SCOMMA var 69 { incomm($1, $3); } 70 ; 71 72comblock: SCONCAT 73 { $$ = comblock(0, 0); } 74 | SSLASH SFNAME SSLASH 75 { $$ = comblock(toklen, token); } 76 ; 77 78external: SEXTERNAL in_dcl name 79 { setext($3); } 80 | external SCOMMA name 81 { setext($3); } 82 ; 83 84intrinsic: SINTRINSIC in_dcl name 85 { setintr($3); } 86 | intrinsic SCOMMA name 87 { setintr($3); } 88 ; 89 90equivalence: SEQUIV in_dcl equivset 91 | equivalence SCOMMA equivset 92 ; 93 94equivset: SLPAR equivlist SRPAR 95 { 96 struct equivblock *p; 97 if(nequiv >= MAXEQUIV) 98 fatal("too many equivalences"); 99 p = & eqvclass[nequiv++]; 100 p->eqvinit = 0; 101 p->eqvbottom = 0; 102 p->eqvtop = 0; 103 p->equivs = $2; 104 } 105 ; 106 107equivlist: lhs 108 { $$ = ALLOC(eqvchain); $$->eqvchain.eqvitem = $1; } 109 | equivlist SCOMMA lhs 110 { $$ = ALLOC(eqvchain); $$->eqvchain.eqvitem = $3; $$->eqvchain.nextp = $1; } 111 ; 112 113data: SDATA in_data datalist 114 | data opt_comma datalist 115 ; 116 117in_data: 118 { if(parstate == OUTSIDE) 119 { 120 newproc(); 121 startproc(0, CLMAIN); 122 } 123 if(parstate < INDATA) 124 { 125 enddcl(); 126 parstate = INDATA; 127 } 128 } 129 ; 130 131datalist: datavarlist SSLASH vallist SSLASH 132 { ftnint junk; 133 if(nextdata(&junk,&junk) != NULL) 134 { 135 err("too few initializers"); 136 curdtp = NULL; 137 } 138 frdata($1); 139 frrpl(); 140 } 141 ; 142 143vallist: { toomanyinit = NO; } val 144 | vallist SCOMMA val 145 ; 146 147val: value 148 { dataval(NULL, $1); } 149 | simple SSTAR value 150 { dataval($1, $3); } 151 ; 152 153value: simple 154 | addop simple 155 { if( $1==OPMINUS && ISCONST($2) ) 156 consnegop($2); 157 $$ = $2; 158 } 159 | complex_const 160 | bit_const 161 ; 162 163savelist: saveitem 164 | savelist SCOMMA saveitem 165 ; 166 167saveitem: name 168 { int k; 169 $1->b_name.vsave = 1; 170 k = $1->vstg; 171 if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) 172 dclerr("can only save static variables", $1); 173 } 174 | comblock 175 { $1->extsave = 1; } 176 ; 177 178paramlist: paramitem 179 | paramlist SCOMMA paramitem 180 ; 181 182paramitem: name SEQUALS expr 183 { if($1->vclass == CLUNKNOWN) 184 { $1->vclass = CLPARAM; 185 $1->b_param.paramval = $3; 186 } 187 else dclerr("cannot make %s parameter", $1); 188 } 189 ; 190 191var: name dims 192 { if(ndim>0) setbound($1, ndim, dims); } 193 ; 194 195datavar: lhs 196 { struct bigblock *np; 197 vardcl(np = $1->b_prim.namep); 198 if(np->vstg == STGBSS) 199 np->vstg = STGINIT; 200 else if(np->vstg == STGCOMMON) 201 extsymtab[np->b_name.vardesc.varno].extinit = YES; 202 else if(np->vstg==STGEQUIV) 203 eqvclass[np->b_name.vardesc.varno].eqvinit = YES; 204 else if(np->vstg != STGINIT) 205 dclerr("inconsistent storage classes", np); 206 $$ = mkchain($1, 0); 207 } 208 | SLPAR datavarlist SCOMMA dospec SRPAR 209 { chainp p; struct bigblock *q; 210 q = BALLO(); 211 q->tag = TIMPLDO; 212 q->b_impldo.varnp = $4->chain.datap; 213 p = $4->chain.nextp; 214 if(p) { q->b_impldo.implb = p->chain.datap; p = p->chain.nextp; } 215 if(p) { q->b_impldo.impub = p->chain.datap; p = p->chain.nextp; } 216 if(p) { q->b_impldo.impstep = p->chain.datap; p = p->chain.nextp; } 217 frchain( & ($4) ); 218 $$ = mkchain(q, 0); 219 q->b_impldo.datalist = hookup($2, $$); 220 } 221 ; 222 223datavarlist: datavar 224 { curdtp = $1; curdtelt = 0; } 225 | datavarlist SCOMMA datavar 226 { $$ = hookup($1, $3); } 227 ; 228 229dims: 230 { ndim = 0; } 231 | SLPAR dimlist SRPAR 232 ; 233 234dimlist: { ndim = 0; } dim 235 | dimlist SCOMMA dim 236 ; 237 238dim: ubound 239 { dims[ndim].lb = 0; 240 dims[ndim].ub = $1; 241 ++ndim; 242 } 243 | expr SCOLON ubound 244 { dims[ndim].lb = $1; 245 dims[ndim].ub = $3; 246 ++ndim; 247 } 248 ; 249 250ubound: SSTAR 251 { $$ = 0; } 252 | expr 253 ; 254 255labellist: label 256 { nstars = 1; labarray[0] = $1; } 257 | labellist SCOMMA label 258 { labarray[nstars++] = $3; } 259 ; 260 261label: labelval 262 { if($1->labinacc) 263 warn1("illegal branch to inner block, statement %s", 264 convic( (ftnint) ($1->stateno) )); 265 else if($1->labdefined == NO) 266 $1->blklevel = blklevel; 267 $1->labused = YES; 268 } 269 ; 270 271labelval: SICON 272 { $$ = mklabel( convci(toklen, token) ); } 273 ; 274 275implicit: SIMPLICIT in_dcl implist 276 | implicit SCOMMA implist 277 ; 278 279implist: imptype SLPAR letgroups SRPAR 280 ; 281 282imptype: { needkwd = 1; } type 283 { vartype = $2; } 284 ; 285 286letgroups: letgroup 287 | letgroups SCOMMA letgroup 288 ; 289 290letgroup: letter 291 { setimpl(vartype, varleng, $1, $1); } 292 | letter SMINUS letter 293 { setimpl(vartype, varleng, $1, $3); } 294 ; 295 296letter: SFNAME 297 { if(toklen!=1 || token[0]<'a' || token[0]>'z') 298 { 299 dclerr("implicit item must be single letter", 0); 300 $$ = 0; 301 } 302 else $$ = token[0]; 303 } 304 ; 305 306in_dcl: 307 { switch(parstate) 308 { 309 case OUTSIDE: newproc(); 310 startproc(0, CLMAIN); 311 case INSIDE: parstate = INDCL; 312 case INDCL: break; 313 314 default: 315 dclerr("declaration among executables", 0); 316 } 317 } 318 ; 319