home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Trees / V7 / usr / src / cmd / f77 / data.c next >
Encoding:
C/C++ Source or Header  |  1979-01-10  |  5.7 KB  |  317 lines
  1. #include "defs"
  2.  
  3. /* ROUTINES CALLED DURING DATA STATEMENT PROCESSING */
  4.  
  5. static char datafmt[] = "%s\t%05ld\t%05ld\t%d" ;
  6.  
  7. /* another initializer, called from parser */
  8. dataval(repp, valp)
  9. register struct constblock *repp, *valp;
  10. {
  11. int i, nrep;
  12. ftnint elen, vlen;
  13. register struct addrblock *p;
  14. struct addrblock *nextdata();
  15.  
  16. if(repp == NULL)
  17.     nrep = 1;
  18. else if (ISICON(repp) && repp->const.ci >= 0)
  19.     nrep = repp->const.ci;
  20. else
  21.     {
  22.     err("invalid repetition count in DATA statement");
  23.     frexpr(repp);
  24.     goto ret;
  25.     }
  26. frexpr(repp);
  27.  
  28. if( ! ISCONST(valp) )
  29.     {
  30.     err("non-constant initializer");
  31.     goto ret;
  32.     }
  33.  
  34. if(toomanyinit) goto ret;
  35. for(i = 0 ; i < nrep ; ++i)
  36.     {
  37.     p = nextdata(&elen, &vlen);
  38.     if(p == NULL)
  39.         {
  40.         err("too many initializers");
  41.         toomanyinit = YES;
  42.         goto ret;
  43.         }
  44.     setdata(p, valp, elen, vlen);
  45.     frexpr(p);
  46.     }
  47.  
  48. ret:
  49.     frexpr(valp);
  50. }
  51.  
  52.  
  53. struct addrblock *nextdata(elenp, vlenp)
  54. ftnint *elenp, *vlenp;
  55. {
  56. register struct impldoblock *ip;
  57. struct primblock *pp;
  58. register struct nameblock *np;
  59. register struct rplblock *rp;
  60. tagptr p;
  61. expptr neltp;
  62. register expptr q;
  63. int skip;
  64. ftnint off;
  65. struct constblock *mkintcon();
  66.  
  67. while(curdtp)
  68.     {
  69.     p = curdtp->datap;
  70.     if(p->tag == TIMPLDO)
  71.         {
  72.         ip = p;
  73.         if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
  74.             fatal1("bad impldoblock 0%o", ip);
  75.         if(ip->isactive)
  76.             ip->varvp->const.ci += ip->impdiff;
  77.         else
  78.             {
  79.             q = fixtype(cpexpr(ip->implb));
  80.             if( ! ISICON(q) )
  81.                 goto doerr;
  82.             ip->varvp = q;
  83.  
  84.             if(ip->impstep)
  85.                 {
  86.                 q = fixtype(cpexpr(ip->impstep));
  87.                 if( ! ISICON(q) )
  88.                     goto doerr;
  89.                 ip->impdiff = q->const.ci;
  90.                 frexpr(q);
  91.                 }
  92.             else
  93.                 ip->impdiff = 1;
  94.  
  95.             q = fixtype(cpexpr(ip->impub));
  96.             if(! ISICON(q))
  97.                 goto doerr;
  98.             ip->implim = q->const.ci;
  99.             frexpr(q);
  100.  
  101.             ip->isactive = YES;
  102.             rp = ALLOC(rplblock);
  103.             rp->nextp = rpllist;
  104.             rpllist = rp;
  105.             rp->rplnp = ip->varnp;
  106.             rp->rplvp = ip->varvp;
  107.             rp->rpltag = TCONST;
  108.             }
  109.  
  110.         if( (ip->impdiff>0 && (ip->varvp->const.ci <= ip->implim))
  111.          || (ip->impdiff<0 && (ip->varvp->const.ci >= ip->implim)) )
  112.             { /* start new loop */
  113.             curdtp = ip->datalist;
  114.             goto next;
  115.             }
  116.  
  117.         /* clean up loop */
  118.  
  119.         popstack(&rpllist);
  120.  
  121.         frexpr(ip->varvp);
  122.         ip->isactive = NO;
  123.         curdtp = curdtp->nextp;
  124.         goto next;
  125.         }
  126.  
  127.     pp = p;
  128.     np = pp->namep;
  129.     skip = YES;
  130.  
  131.     if(p->argsp==NULL && np->vdim!=NULL)
  132.         {   /* array initialization */
  133.         q = mkaddr(np);
  134.         off = typesize[np->vtype] * curdtelt;
  135.         if(np->vtype == TYCHAR)
  136.             off *= np->vleng->const.ci;
  137.         q->memoffset = mkexpr(OPPLUS, q->memoffset, mkintcon(off) );
  138.         if( (neltp = np->vdim->nelt) && ISCONST(neltp))
  139.             {
  140.             if(++curdtelt < neltp->const.ci)
  141.                 skip = NO;
  142.             }
  143.         else
  144.             err("attempt to initialize adjustable array");
  145.         }
  146.     else
  147.         q = mklhs( cpexpr(pp) );
  148.     if(skip)
  149.         {
  150.         curdtp = curdtp->nextp;
  151.         curdtelt = 0;
  152.         }
  153.     if(q->vtype == TYCHAR)
  154.         if(ISICON(q->vleng))
  155.             *elenp = q->vleng->const.ci;
  156.         else    {
  157.             err("initialization of string of nonconstant length");
  158.             continue;
  159.             }
  160.     else    *elenp = typesize[q->vtype];
  161.  
  162.     if(np->vstg == STGCOMMON)
  163.         *vlenp = extsymtab[np->vardesc.varno].maxleng;
  164.     else if(np->vstg == STGEQUIV)
  165.         *vlenp = eqvclass[np->vardesc.varno].eqvleng;
  166.     else    {
  167.         *vlenp =  (np->vtype==TYCHAR ?
  168.                 np->vleng->const.ci : typesize[np->vtype]);
  169.         if(np->vdim)
  170.             *vlenp *= np->vdim->nelt->const.ci;
  171.         }
  172.     return(q);
  173.  
  174. doerr:
  175.         err("nonconstant implied DO parameter");
  176.         frexpr(q);
  177.         curdtp = curdtp->nextp;
  178.  
  179. next:    curdtelt = 0;
  180.     }
  181.  
  182. return(NULL);
  183. }
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190. LOCAL setdata(varp, valp, elen, vlen)
  191. struct addrblock *varp;
  192. ftnint elen, vlen;
  193. struct constblock *valp;
  194. {
  195. union constant con;
  196. int i, k;
  197. int stg, type, valtype;
  198. ftnint offset;
  199. register char *s, *t;
  200. char *memname();
  201. static char varname[XL+2];
  202.  
  203. /* output form of name is padded with blanks and preceded
  204.    with a storage class digit
  205. */
  206.  
  207. stg = varp->vstg;
  208. varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
  209. s = memname(stg, varp->memno);
  210. for(t = varname+1 ; *s ; )
  211.     *t++ = *s++;
  212. while(t < varname+XL+1)
  213.     *t++ = ' ';
  214. varname[XL+1] = '\0';
  215.  
  216. offset = varp->memoffset->const.ci;
  217. type = varp->vtype;
  218. valtype = valp->vtype;
  219. if(type!=TYCHAR && valtype==TYCHAR)
  220.     {
  221.     if(! ftn66flag)
  222.         warn("non-character datum initialized with character string");
  223.     varp->vleng = ICON(typesize[type]);
  224.     varp->vtype = type = TYCHAR;
  225.     }
  226. else if( (type==TYCHAR && valtype!=TYCHAR) ||
  227.      (cktype(OPASSIGN,type,valtype) == TYERROR) )
  228.     {
  229.     err("incompatible types in initialization");
  230.     return;
  231.     }
  232. if(type != TYCHAR)
  233.     if(valtype == TYUNKNOWN)
  234.         con.ci = valp->const.ci;
  235.     else    consconv(type, &con, valtype, &valp->const);
  236.  
  237. k = 1;
  238. switch(type)
  239.     {
  240.     case TYLOGICAL:
  241.         type = tylogical;
  242.     case TYSHORT:
  243.     case TYLONG:
  244.         fprintf(initfile, datafmt, varname, offset, vlen, type);
  245.         prconi(initfile, type, con.ci);
  246.         break;
  247.  
  248.     case TYCOMPLEX:
  249.         k = 2;
  250.         type = TYREAL;
  251.     case TYREAL:
  252.         goto flpt;
  253.  
  254.     case TYDCOMPLEX:
  255.         k = 2;
  256.         type = TYDREAL;
  257.     case TYDREAL:
  258.     flpt:
  259.  
  260.         for(i = 0 ; i < k ; ++i)
  261.             {
  262.             fprintf(initfile, datafmt, varname, offset, vlen, type);
  263.             prconr(initfile, type, con.cd[i]);
  264.             offset += typesize[type];
  265.             }
  266.         break;
  267.  
  268.     case TYCHAR:
  269.         k = valp->vleng->const.ci;
  270.         if(elen < k)
  271.             k = elen;
  272.  
  273.         for(i = 0 ; i < k ; ++i)
  274.             {
  275.             fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
  276.             fprintf(initfile, "\t%d\n", valp->const.ccp[i]);
  277.             }
  278.         k = elen - valp->vleng->const.ci;
  279.         while( k-- > 0)
  280.             {
  281.             fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
  282.             fprintf(initfile, "\t%d\n", ' ');
  283.             }
  284.         break;
  285.  
  286.     default:
  287.         fatal1("setdata: impossible type %d", type);
  288.     }
  289.  
  290. }
  291.  
  292.  
  293.  
  294. frdata(p0)
  295. chainp p0;
  296. {
  297. register chainp p;
  298. register tagptr q;
  299.  
  300. for(p = p0 ; p ; p = p->nextp)
  301.     {
  302.     q = p->datap;
  303.     if(q->tag == TIMPLDO)
  304.         {
  305.         if(q->isbusy)
  306.             return;    /* circular chain completed */
  307.         q->isbusy = YES;
  308.         frdata(q->datalist);
  309.         free(q);
  310.         }
  311.     else
  312.         frexpr(q);
  313.     }
  314.  
  315. frchain( &p0);
  316. }
  317.