sources/f2c/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                         }
 169                 }
 170         ;
 171
 172 datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
 173                 { ftnint junk;
 174                   if(nextdata(&junk) != NULL)
 175                         err("too few initializers");
 176                   frdata($2);
 177                   frrpl();
 178                 }
 179         ;
 180
 181 datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
 182
 183 datapop: /* nothing */ { pop_datastack(); }
 184
 185 vallist:  { toomanyinit = NO; }  val
 186         | vallist SCOMMA val
 187         ;
 188
 189 val:      value
 190                 { dataval(ENULL, $1); }
 191         | simple SSTAR value
 192                 { dataval($1, $3); }
 193         ;
 194
 195 value:    simple
 196         | addop simple
 197                 { if( $1==OPMINUS && ISCONST($2) )
 198                         consnegop((Constp)$2);
 199                   $$ = $2;
 200                 }
 201         | complex_const
 202         ;
 203
 204 savelist: saveitem
 205         | savelist SCOMMA saveitem
 206         ;
 207
 208 saveitem: name
 209                 { int k;
 210                   $1->vsave = YES;
 211                   k = $1->vstg;
 212                 if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
 213                         dclerr("can only save static variables", $1);
 214                 }
 215         | comblock
 216         ;
 217
 218 paramlist:  paramitem
 219         | paramlist SCOMMA paramitem
 220         ;
 221
 222 paramitem:  name SEQUALS expr
 223                 { if($1->vclass == CLUNKNOWN)
 224                         make_param((struct Paramblock *)$1, $3);
 225                   else dclerr("cannot make into parameter", $1);
 226                 }
 227         ;
 228
 229 var:      name dims
 230                 { if(ndim>0) setbound($1, ndim, dims); }
 231         ;
 232
 233 datavar:          lhs
 234                 { Namep np;
 235                   np = ( (struct Primblock *) $1) -> namep;
 236                   vardcl(np);
 237                   if(np->vstg == STGCOMMON)
 238                         extsymtab[np->vardesc.varno].extinit = YES;
 239                   else if(np->vstg==STGEQUIV)
 240                         eqvclass[np->vardesc.varno].eqvinit = YES;
 241                   else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
 242                         dclerr("inconsistent storage classes", np);
 243                   $$ = mkchain((char *)$1, CHNULL);
 244                 }
 245         | SLPAR datavarlist SCOMMA dospec SRPAR
 246                 { chainp p; struct Impldoblock *q;
 247                 pop_datastack();
 248                 q = ALLOC(Impldoblock);
 249                 q->tag = TIMPLDO;
 250                 (q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
 251                 p = $4->nextp;
 252                 if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
 253                 if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
 254                 if(p)  { q->impstep = (expptr)(p->datap); }
 255                 frchain( & ($4) );
 256                 $$ = mkchain((char *)q, CHNULL);
 257                 q->datalist = hookup($2, $$);
 258                 }
 259         ;
 260
 261 datavarlist: datavar
 262                 { if (!datastack)
 263                         curdtp = 0;
 264                   datastack = mkchain((char *)curdtp, datastack);
 265                   curdtp = $1; curdtelt = 0;
 266                   }
 267         | datavarlist SCOMMA datavar
 268                 { $$ = hookup($1, $3); }
 269         ;
 270
 271 dims:
 272                 { ndim = 0; }
 273         | SLPAR dimlist SRPAR
 274         ;
 275
 276 dimlist:   { ndim = 0; }   dim
 277         | dimlist SCOMMA dim
 278         ;
 279
 280 dim:      ubound
 281                 {
 282                   if(ndim == maxdim)
 283                         err("too many dimensions");
 284                   else if(ndim < maxdim)
 285                         { dims[ndim].lb = 0;
 286                           dims[ndim].ub = $1;
 287                         }
 288                   ++ndim;
 289                 }
 290         | expr SCOLON ubound
 291                 {
 292                   if(ndim == maxdim)
 293                         err("too many dimensions");
 294                   else if(ndim < maxdim)
 295                         { dims[ndim].lb = $1;
 296                           dims[ndim].ub = $3;
 297                         }
 298                   ++ndim;
 299                 }
 300         ;
 301
 302 ubound:   SSTAR
 303                 { $$ = 0; }
 304         | expr
 305         ;
 306
 307 labellist: label
 308                 { nstars = 1; labarray[0] = $1; }
 309         | labellist SCOMMA label
 310                 { if(nstars < MAXLABLIST)  labarray[nstars++] = $3; }
 311         ;
 312
 313 label:    SICON
 314                 { $$ = execlab( convci(toklen, token) ); }
 315         ;
 316
 317 implicit:  SIMPLICIT in_dcl implist
 318                 { NO66("IMPLICIT statement"); }
 319         | implicit SCOMMA implist
 320         ;
 321
 322 implist:  imptype SLPAR letgroups SRPAR
 323         | imptype
 324                 { if (vartype != TYUNKNOWN)
 325                         dclerr("-- expected letter range",NPNULL);
 326                   setimpl(vartype, varleng, 'a', 'z'); }
 327         ;
 328
 329 imptype:   { needkwd = 1; } type
 330                 /* { vartype = $2; } */
 331         ;
 332
 333 letgroups: letgroup
 334         | letgroups SCOMMA letgroup
 335         ;
 336
 337 letgroup:  letter
 338                 { setimpl(vartype, varleng, $1, $1); }
 339         | letter SMINUS letter
 340                 { setimpl(vartype, varleng, $1, $3); }
 341         ;
 342
 343 letter:  SNAME
 344                 { if(toklen!=1 || token[0]<'a' || token[0]>'z')
 345                         {
 346                         dclerr("implicit item must be single letter", NPNULL);
 347                         $$ = 0;
 348                         }
 349                   else $$ = token[0];
 350                 }
 351         ;
 352
 353 namelist:       SNAMELIST
 354         | namelist namelistentry
 355         ;
 356
 357 namelistentry:  SSLASH name SSLASH namelistlist
 358                 {
 359                 if($2->vclass == CLUNKNOWN)
 360                         {
 361                         $2->vclass = CLNAMELIST;
 362                         $2->vtype = TYINT;
 363                         $2->vstg = STGBSS;
 364                         $2->varxptr.namelist = $4;
 365                         $2->vardesc.varno = ++lastvarno;
 366                         }
 367                 else dclerr("cannot be a namelist name", $2);
 368                 }
 369         ;
 370
 371 namelistlist:  name
 372                 { $$ = mkchain((char *)$1, CHNULL); }
 373         | namelistlist SCOMMA name
 374                 { $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
 375         ;
 376
 377 in_dcl:
 378                 { switch(parstate)
 379                         {
 380                         case OUTSIDE:   newproc();
 381                                         startproc(ESNULL, CLMAIN);
 382                         case INSIDE:    parstate = INDCL;
 383                         case INDCL:     break;
 384
 385                         case INDATA:
 386                                 errstr(
 387                                 "Statement order error: declaration after DATA",
 388                                         CNULL);
 389                                 break;
 390
 391                         default:
 392                                 dclerr("declaration among executables", NPNULL);
 393                         }
 394                 }
 395         ;