lang/fortran/comp/gram.dcl

   1 spec:     dcl
   2         | common
   3         | external
   4         | intrinsic
   5         | equivalence
   6         | data
   7         | implicit
   8         | namelist
   9         | SSAVE
  10                 { NO66("SAVE statement");
  11                   saveall = YES; }
  12         | SSAVE savelist
  13                 { NO66("SAVE statement"); }
  14         | SFORMAT
  15                 { fmtstmt(thislabel); setfmt(thislabel); }
  16         | SPARAM in_dcl SLPAR paramlist SRPAR
  17                 { NO66("PARAMETER statement"); }
  18         ;
  19
  20 dcl:      type opt_comma name in_dcl new_dcl dims lengspec
  21                 { settype($3, $1, $7);
  22                   if(ndim>0) setbound($3,ndim,dims);
  23                 }
  24         | dcl SCOMMA name dims lengspec
  25                 { settype($3, $1, $5);
  26                   if(ndim>0) setbound($3,ndim,dims);
  27                 }
  28         | dcl SSLASHD datainit vallist SSLASHD
  29                 { if (new_dcl == 2) {
  30                         err("attempt to give DATA in type-declaration");
  31                         new_dcl = 1;
  32                         }
  33                 }
  34         ;
  35
  36 new_dcl:        { new_dcl = 2; }
  37
  38 type:     typespec lengspec
  39                 { varleng = $2;
  40                   if (vartype == TYLOGICAL && varleng == 1) {
  41                         varleng = 0;
  42                         err("treating LOGICAL*1 as LOGICAL");
  43                         --nerr; /* allow generation of .c file */
  44                         }
  45                 }
  46         ;
  47
  48 typespec:  typename
  49                 { varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
  50                   vartype = $1; }
  51         ;
  52
  53 typename:    SINTEGER   { $$ = TYLONG; }
  54         | SREAL         { $$ = tyreal; }
  55         | SCOMPLEX      { ++complex_seen; $$ = tycomplex; }
  56         | SDOUBLE       { $$ = TYDREAL; }
  57         | SDCOMPLEX     { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
  58         | SLOGICAL      { $$ = TYLOGICAL; }
  59         | SCHARACTER    { NO66("CHARACTER statement"); $$ = TYCHAR; }
  60         | SUNDEFINED    { $$ = TYUNKNOWN; }
  61         | SDIMENSION    { $$ = TYUNKNOWN; }
  62         | SAUTOMATIC    { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
  63         | SSTATIC       { NOEXT("STATIC statement"); $$ = - STGBSS; }
  64         ;
  65
  66 lengspec:
  67                 { $$ = varleng; }
  68         | SSTAR intonlyon expr intonlyoff
  69                 {
  70                 expptr p;
  71                 p = $3;
  72                 NO66("length specification *n");
  73                 if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
  74                         {
  75                         $$ = 0;
  76                         dclerr("length must be a positive integer constant",
  77                                 NPNULL);
  78                         }
  79                 else {
  80                         if (vartype == TYCHAR)
  81                                 $$ = p->constblock.Const.ci;
  82                         else switch((int)p->constblock.Const.ci) {
  83                                 case 1: $$ = 1; break;
  84                                 case 2: $$ = typesize[TYSHORT]; break;
  85                                 case 4: $$ = typesize[TYLONG];  break;
  86                                 case 8: $$ = typesize[TYDREAL]; break;
  87                                 case 16: $$ = typesize[TYDCOMPLEX]; break;
  88                                 default:
  89                                         dclerr("invalid length",NPNULL);
  90                                         $$ = varleng;
  91                                 }
  92                         }
  93                 }
  94         | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
  95                 { NO66("length specification *(*)"); $$ = -1; }
  96         ;
  97
  98 common:   SCOMMON in_dcl var
  99                 { incomm( $$ = comblock("") , $3 ); }
 100         | SCOMMON in_dcl comblock var
 101                 { $$ = $3;  incomm($3, $4); }
 102         | common opt_comma comblock opt_comma var
 103                 { $$ = $3;  incomm($3, $5); }
 104         | common SCOMMA var
 105                 { incomm($1, $3); }
 106         ;
 107
 108 comblock:  SCONCAT
 109                 { $$ = comblock(""); }
 110         | SSLASH SNAME SSLASH
 111                 { $$ = comblock(token); }
 112         ;
 113
 114 external: SEXTERNAL in_dcl name
 115                 { setext($3); }
 116         | external SCOMMA name
 117                 { setext($3); }
 118         ;
 119
 120 intrinsic:  SINTRINSIC in_dcl name
 121                 { NO66("INTRINSIC statement"); setintr($3); }
 122         | intrinsic SCOMMA name
 123                 { setintr($3); }
 124         ;
 125
 126 equivalence:  SEQUIV in_dcl equivset
 127         | equivalence SCOMMA equivset
 128         ;
 129
 130 equivset:  SLPAR equivlist SRPAR
 131                 {
 132                 struct Equivblock *p;
 133                 if(nequiv >= maxequiv)
 134                         many("equivalences", 'q', maxequiv);
 135                 p  =  & eqvclass[nequiv++];
 136                 p->eqvinit = NO;
 137                 p->eqvbottom = 0;
 138                 p->eqvtop = 0;
 139                 p->equivs = $2;
 140                 }
 141         ;
 142
 143 equivlist:  lhs
 144                 { $$=ALLOC(Eqvchain);
 145                   $$->eqvitem.eqvlhs = (struct Primblock *)$1;
 146                 }
 147         | equivlist SCOMMA lhs
 148                 { $$=ALLOC(Eqvchain);
 149                   $$->eqvitem.eqvlhs = (struct Primblock *) $3;
 150                   $$->eqvnextp = $1;
 151                 }
 152         ;
 153
 154 data:     SDATA in_data datalist
 155         | data opt_comma datalist
 156         ;
 157
 158 in_data:
 159                 { if(parstate == OUTSIDE)
 160                         {
 161                         newproc();
 162                         startproc(ESNULL, CLMAIN);
 163                         }
 164                   if(parstate < INDATA)
 165                         {
 166                         enddcl();
 167                         parstate = INDATA;
 168                         datagripe = 1;
 169                         }
 170                 }
 171         ;
 172
 173 datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
 174                 { ftnint junk;
 175                   if(nextdata(&junk) != NULL)
 176                         err("too few initializers");
 177                   frdata($2);
 178                   frrpl();
 179                 }
 180         ;
 181
 182 datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
 183
 184 datapop: /* nothing */ { pop_datastack(); }
 185
 186 vallist:  { toomanyinit = NO; }  val
 187         | vallist SCOMMA val
 188         ;
 189
 190 val:      value
 191                 { dataval(ENULL, $1); }
 192         | simple SSTAR value
 193                 { dataval($1, $3); }
 194         ;
 195
 196 value:    simple
 197         | addop simple
 198                 { if( $1==OPMINUS && ISCONST($2) )
 199                         consnegop((Constp)$2);
 200                   $$ = $2;
 201                 }
 202         | complex_const
 203         ;
 204
 205 savelist: saveitem
 206         | savelist SCOMMA saveitem
 207         ;
 208
 209 saveitem: name
 210                 { int k;
 211                   $1->vsave = YES;
 212                   k = $1->vstg;
 213                 if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
 214                         dclerr("can only save static variables", $1);
 215                 }
 216         | comblock
 217         ;
 218
 219 paramlist:  paramitem
 220         | paramlist SCOMMA paramitem
 221         ;
 222
 223 paramitem:  name SEQUALS expr
 224                 { if($1->vclass == CLUNKNOWN)
 225                         make_param((struct Paramblock *)$1, $3);
 226                   else dclerr("cannot make into parameter", $1);
 227                 }
 228         ;
 229
 230 var:      name dims
 231                 { if(ndim>0) setbound($1, ndim, dims); }
 232         ;
 233
 234 datavar:          lhs
 235                 { Namep np;
 236                   np = ( (struct Primblock *) $1) -> namep;
 237                   vardcl(np);
 238                   if(np->vstg == STGCOMMON)
 239                         extsymtab[np->vardesc.varno].extinit = YES;
 240                   else if(np->vstg==STGEQUIV)
 241                         eqvclass[np->vardesc.varno].eqvinit = YES;
 242                   else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
 243                         dclerr("inconsistent storage classes", np);
 244                   $$ = mkchain((char *)$1, CHNULL);
 245                 }
 246         | SLPAR datavarlist SCOMMA dospec SRPAR
 247                 { chainp p; struct Impldoblock *q;
 248                 pop_datastack();
 249                 q = ALLOC(Impldoblock);
 250                 q->tag = TIMPLDO;
 251                 (q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
 252                 p = $4->nextp;
 253                 if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
 254                 if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
 255                 if(p)  { q->impstep = (expptr)(p->datap); }
 256                 frchain( & ($4) );
 257                 $$ = mkchain((char *)q, CHNULL);
 258                 q->datalist = hookup($2, $$);
 259                 }
 260         ;
 261
 262 datavarlist: datavar
 263                 { if (!datastack)
 264                         curdtp = 0;
 265                   datastack = mkchain((char *)curdtp, datastack);
 266                   curdtp = $1; curdtelt = 0;
 267                   }
 268         | datavarlist SCOMMA datavar
 269                 { $$ = hookup($1, $3); }
 270         ;
 271
 272 dims:
 273                 { ndim = 0; }
 274         | SLPAR dimlist SRPAR
 275         ;
 276
 277 dimlist:   { ndim = 0; }   dim
 278         | dimlist SCOMMA dim
 279         ;
 280
 281 dim:      ubound
 282                 {
 283                   if(ndim == maxdim)
 284                         err("too many dimensions");
 285                   else if(ndim < maxdim)
 286                         { dims[ndim].lb = 0;
 287                           dims[ndim].ub = $1;
 288                         }
 289                   ++ndim;
 290                 }
 291         | expr SCOLON ubound
 292                 {
 293                   if(ndim == maxdim)
 294                         err("too many dimensions");
 295                   else if(ndim < maxdim)
 296                         { dims[ndim].lb = $1;
 297                           dims[ndim].ub = $3;
 298                         }
 299                   ++ndim;
 300                 }
 301         ;
 302
 303 ubound:   SSTAR
 304                 { $$ = 0; }
 305         | expr
 306         ;
 307
 308 labellist: label
 309                 { nstars = 1; labarray[0] = $1; }
 310         | labellist SCOMMA label
 311                 { if(nstars < MAXLABLIST)  labarray[nstars++] = $3; }
 312         ;
 313
 314 label:    SICON
 315                 { $$ = execlab( convci(toklen, token) ); }
 316         ;
 317
 318 implicit:  SIMPLICIT in_dcl implist
 319                 { NO66("IMPLICIT statement"); }
 320         | implicit SCOMMA implist
 321         ;
 322
 323 implist:  imptype SLPAR letgroups SRPAR
 324         | imptype
 325                 { if (vartype != TYUNKNOWN)
 326                         dclerr("-- expected letter range",NPNULL);
 327                   setimpl(vartype, varleng, 'a', 'z'); }
 328         ;
 329
 330 imptype:   { needkwd = 1; } type
 331                 /* { vartype = $2; } */
 332         ;
 333
 334 letgroups: letgroup
 335         | letgroups SCOMMA letgroup
 336         ;
 337
 338 letgroup:  letter
 339                 { setimpl(vartype, varleng, $1, $1); }
 340         | letter SMINUS letter
 341                 { setimpl(vartype, varleng, $1, $3); }
 342         ;
 343
 344 letter:  SNAME
 345                 { if(toklen!=1 || token[0]<'a' || token[0]>'z')
 346                         {
 347                         dclerr("implicit item must be single letter", NPNULL);
 348                         $$ = 0;
 349                         }
 350                   else $$ = token[0];
 351                 }
 352         ;
 353
 354 namelist:       SNAMELIST
 355         | namelist namelistentry
 356         ;
 357
 358 namelistentry:  SSLASH name SSLASH namelistlist
 359                 {
 360                 if($2->vclass == CLUNKNOWN)
 361                         {
 362                         $2->vclass = CLNAMELIST;
 363                         $2->vtype = TYINT;
 364                         $2->vstg = STGBSS;
 365                         $2->varxptr.namelist = $4;
 366                         $2->vardesc.varno = ++lastvarno;
 367                         }
 368                 else dclerr("cannot be a namelist name", $2);
 369                 }
 370         ;
 371
 372 namelistlist:  name
 373                 { $$ = mkchain((char *)$1, CHNULL); }
 374         | namelistlist SCOMMA name
 375                 { $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
 376         ;
 377
 378 in_dcl:
 379                 { switch(parstate)
 380                         {
 381                         case OUTSIDE:   newproc();
 382                                         startproc(ESNULL, CLMAIN);
 383                         case INSIDE:    parstate = INDCL;
 384                         case INDCL:     break;
 385
 386                         case INDATA:
 387                                 if (datagripe) {
 388                                         errstr(
 389                                 "Statement order error: declaration after DATA",
 390                                                 CNULL);
 391                                         datagripe = 0;
 392                                         }
 393                                 break;
 394
 395                         default:
 396                                 dclerr("declaration among executables", NPNULL);
 397                         }
 398                 }
 399         ;