mirror of
https://github.com/freebsd/freebsd-src
synced 2024-11-05 18:22:52 +00:00
404 lines
8 KiB
Text
404 lines
8 KiB
Text
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; }
|
|
;
|
|
|
|
typespec: typename
|
|
{ varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(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; }
|
|
| SBYTE { $$ = TYINT1; }
|
|
;
|
|
|
|
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;
|
|
int tt = $1->tag;
|
|
if (tt != TPRIM) {
|
|
if (tt == TCONST)
|
|
err("parameter in data statement");
|
|
else
|
|
erri("tag %d in data statement",tt);
|
|
$$ = 0;
|
|
break;
|
|
}
|
|
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);
|
|
}
|
|
}
|
|
;
|