Category : C Source Code
Archive   : F2CSRC.ZIP
Filename : GRAM.DCL

 
Output of file : GRAM.DCL contained in archive : F2CSRC.ZIP

spec: dcl
| common
| external
| intrinsic
| equivalence
| data
| implicit
| namelist
| SSAVE
{ NO66("SAVE statement");
saveall = YES; }
| SSAVE savelist
{ NO66("SAVE statement"); }
| SFORMAT
{ fmtstmt(thislabel); setfmt(thislabel); }
| SPARAM in_dcl SLPAR paramlist SRPAR
{ NO66("PARAMETER statement"); }
;

dcl: type opt_comma name in_dcl new_dcl dims lengspec
{ settype($3, $1, $7);
if(ndim>0) setbound($3,ndim,dims);
}
| dcl SCOMMA name dims lengspec
{ settype($3, $1, $5);
if(ndim>0) setbound($3,ndim,dims);
}
| dcl SSLASHD datainit vallist SSLASHD
{ if (new_dcl == 2) {
err("attempt to give DATA in type-declaration");
new_dcl = 1;
}
}
;

new_dcl: { new_dcl = 2; }

type: typespec lengspec
{ varleng = $2;
if (vartype == TYLOGICAL && varleng == 1) {
varleng = 0;
err("treating LOGICAL*1 as LOGICAL");
--nerr; /* allow generation of .c file */
}
}
;

typespec: typename
{ varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
vartype = $1; }
;

typename: SINTEGER { $$ = TYLONG; }
| SREAL { $$ = tyreal; }
| SCOMPLEX { ++complex_seen; $$ = TYCOMPLEX; }
| SDOUBLE { $$ = TYDREAL; }
| SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
| SLOGICAL { $$ = TYLOGICAL; }
| SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; }
| SUNDEFINED { $$ = TYUNKNOWN; }
| SDIMENSION { $$ = TYUNKNOWN; }
| SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
| SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; }
;

lengspec:
{ $$ = varleng; }
| SSTAR intonlyon expr intonlyoff
{
expptr p;
p = $3;
NO66("length specification *n");
if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
{
$$ = 0;
dclerr("length must be a positive integer constant",
NPNULL);
}
else {
if (vartype == TYCHAR)
$$ = p->constblock.Const.ci;
else switch((int)p->constblock.Const.ci) {
case 1: $$ = 1; break;
case 2: $$ = typesize[TYSHORT]; break;
case 4: $$ = typesize[TYLONG]; break;
case 8: $$ = typesize[TYDREAL]; break;
case 16: $$ = typesize[TYDCOMPLEX]; break;
default:
dclerr("invalid length",NPNULL);
$$ = varleng;
}
}
}
| SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
{ NO66("length specification *(*)"); $$ = -1; }
;

common: SCOMMON in_dcl var
{ incomm( $$ = comblock("") , $3 ); }
| SCOMMON in_dcl comblock var
{ $$ = $3; incomm($3, $4); }
| common opt_comma comblock opt_comma var
{ $$ = $3; incomm($3, $5); }
| common SCOMMA var
{ incomm($1, $3); }
;

comblock: SCONCAT
{ $$ = comblock(""); }
| SSLASH SNAME SSLASH
{ $$ = comblock(token); }
;

external: SEXTERNAL in_dcl name
{ setext($3); }
| external SCOMMA name
{ setext($3); }
;

intrinsic: SINTRINSIC in_dcl name
{ NO66("INTRINSIC statement"); setintr($3); }
| intrinsic SCOMMA name
{ setintr($3); }
;

equivalence: SEQUIV in_dcl equivset
| equivalence SCOMMA equivset
;

equivset: SLPAR equivlist SRPAR
{
struct Equivblock *p;
if(nequiv >= maxequiv)
many("equivalences", 'q', maxequiv);
p = & eqvclass[nequiv++];
p->eqvinit = NO;
p->eqvbottom = 0;
p->eqvtop = 0;
p->equivs = $2;
}
;

equivlist: lhs
{ $$=ALLOC(Eqvchain);
$$->eqvitem.eqvlhs = (struct Primblock *)$1;
}
| equivlist SCOMMA lhs
{ $$=ALLOC(Eqvchain);
$$->eqvitem.eqvlhs = (struct Primblock *) $3;
$$->eqvnextp = $1;
}
;

data: SDATA in_data datalist
| data opt_comma datalist
;

in_data:
{ if(parstate == OUTSIDE)
{
newproc();
startproc(ESNULL, CLMAIN);
}
if(parstate < INDATA)
{
enddcl();
parstate = INDATA;
}
}
;

datalist: datainit datavarlist SSLASH datapop vallist SSLASH
{ ftnint junk;
if(nextdata(&junk) != NULL)
err("too few initializers");
frdata($2);
frrpl();
}
;

datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }

datapop: /* nothing */ { pop_datastack(); }

vallist: { toomanyinit = NO; } val
| vallist SCOMMA val
;

val: value
{ dataval(ENULL, $1); }
| simple SSTAR value
{ dataval($1, $3); }
;

value: simple
| addop simple
{ if( $1==OPMINUS && ISCONST($2) )
consnegop((Constp)$2);
$$ = $2;
}
| complex_const
;

savelist: saveitem
| savelist SCOMMA saveitem
;

saveitem: name
{ int k;
$1->vsave = YES;
k = $1->vstg;
if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
dclerr("can only save static variables", $1);
}
| comblock
;

paramlist: paramitem
| paramlist SCOMMA paramitem
;

paramitem: name SEQUALS expr
{ if($1->vclass == CLUNKNOWN)
make_param((struct Paramblock *)$1, $3);
else dclerr("cannot make into parameter", $1);
}
;

var: name dims
{ if(ndim>0) setbound($1, ndim, dims); }
;

datavar: lhs
{ Namep np;
np = ( (struct Primblock *) $1) -> namep;
vardcl(np);
if(np->vstg == STGCOMMON)
extsymtab[np->vardesc.varno].extinit = YES;
else if(np->vstg==STGEQUIV)
eqvclass[np->vardesc.varno].eqvinit = YES;
else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
dclerr("inconsistent storage classes", np);
$$ = mkchain((char *)$1, CHNULL);
}
| SLPAR datavarlist SCOMMA dospec SRPAR
{ chainp p; struct Impldoblock *q;
pop_datastack();
q = ALLOC(Impldoblock);
q->tag = TIMPLDO;
(q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
p = $4->nextp;
if(p) { q->implb = (expptr)(p->datap); p = p->nextp; }
if(p) { q->impub = (expptr)(p->datap); p = p->nextp; }
if(p) { q->impstep = (expptr)(p->datap); }
frchain( & ($4) );
$$ = mkchain((char *)q, CHNULL);
q->datalist = hookup($2, $$);
}
;

datavarlist: datavar
{ if (!datastack)
curdtp = 0;
datastack = mkchain((char *)curdtp, datastack);
curdtp = $1; curdtelt = 0;
}
| datavarlist SCOMMA datavar
{ $$ = hookup($1, $3); }
;

dims:
{ ndim = 0; }
| SLPAR dimlist SRPAR
;


dimlist: { ndim = 0; } dim
| dimlist SCOMMA dim
;

dim: ubound
{
if(ndim == maxdim)
err("too many dimensions");
else if(ndim < maxdim)
{ dims[ndim].lb = 0;
dims[ndim].ub = $1;
}
++ndim;
}
| expr SCOLON ubound
{
if(ndim == maxdim)
err("too many dimensions");
else if(ndim < maxdim)
{ dims[ndim].lb = $1;
dims[ndim].ub = $3;
}
++ndim;
}
;

ubound: SSTAR
{ $$ = 0; }
| expr
;

labellist: label
{ nstars = 1; labarray[0] = $1; }
| labellist SCOMMA label
{ if(nstars < MAXLABLIST) labarray[nstars++] = $3; }
;

label: SICON
{ $$ = execlab( convci(toklen, token) ); }
;

implicit: SIMPLICIT in_dcl implist
{ NO66("IMPLICIT statement"); }
| implicit SCOMMA implist
;

implist: imptype SLPAR letgroups SRPAR
| imptype
{ if (vartype != TYUNKNOWN)
dclerr("-- expected letter range",NPNULL);
setimpl(vartype, varleng, 'a', 'z'); }
;

imptype: { needkwd = 1; } type
/* { vartype = $2; } */
;

letgroups: letgroup
| letgroups SCOMMA letgroup
;

letgroup: letter
{ setimpl(vartype, varleng, $1, $1); }
| letter SMINUS letter
{ setimpl(vartype, varleng, $1, $3); }
;

letter: SNAME
{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
{
dclerr("implicit item must be single letter", NPNULL);
$$ = 0;
}
else $$ = token[0];
}
;

namelist: SNAMELIST
| namelist namelistentry
;

namelistentry: SSLASH name SSLASH namelistlist
{
if($2->vclass == CLUNKNOWN)
{
$2->vclass = CLNAMELIST;
$2->vtype = TYINT;
$2->vstg = STGBSS;
$2->varxptr.namelist = $4;
$2->vardesc.varno = ++lastvarno;
}
else dclerr("cannot be a namelist name", $2);
}
;

namelistlist: name
{ $$ = mkchain((char *)$1, CHNULL); }
| namelistlist SCOMMA name
{ $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
;

in_dcl:
{ switch(parstate)
{
case OUTSIDE: newproc();
startproc(ESNULL, CLMAIN);
case INSIDE: parstate = INDCL;
case INDCL: break;

case INDATA:
errstr(
"Statement order error: declaration after DATA",
CNULL);
break;

default:
dclerr("declaration among executables", NPNULL);
}
}
;