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