Added
This commit is contained in:
ceriel
399
lang/fortran/comp/gram.dcl
Normal file
399
lang/fortran/comp/gram.dcl
Normal file
@@ -0,0 +1,399 @@
|
||||
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;
|
||||
datagripe = 1;
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
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:
|
||||
if (datagripe) {
|
||||
errstr(
|
||||
"Statement order error: declaration after DATA",
|
||||
CNULL);
|
||||
datagripe = 0;
|
||||
}
|
||||
break;
|
||||
|
||||
default:
|
||||
dclerr("declaration among executables", NPNULL);
|
||||
}
|
||||
}
|
||||
;
|
||||
Reference in New Issue
Block a user