home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / f2csrc.zip / f2csrc / src / data.c < prev    next >
C/C++ Source or Header  |  1994-06-15  |  11KB  |  491 lines
  1. /****************************************************************
  2. Copyright 1990, 1993, 1994 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25.  
  26. /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
  27.  
  28. static char datafmt[] = "%s\t%09ld\t%d";
  29. static char *cur_varname;
  30.  
  31. /* another initializer, called from parser */
  32.  void
  33. #ifdef KR_headers
  34. dataval(repp, valp)
  35.     register expptr repp;
  36.     register expptr valp;
  37. #else
  38. dataval(register expptr repp, register expptr valp)
  39. #endif
  40. {
  41.     int i, nrep;
  42.     ftnint elen;
  43.     register Addrp p;
  44.  
  45.     if (parstate < INDATA) {
  46.         frexpr(repp);
  47.         goto ret;
  48.         }
  49.     if(repp == NULL)
  50.         nrep = 1;
  51.     else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
  52.         nrep = repp->constblock.Const.ci;
  53.     else
  54.     {
  55.         err("invalid repetition count in DATA statement");
  56.         frexpr(repp);
  57.         goto ret;
  58.     }
  59.     frexpr(repp);
  60.  
  61.     if( ! ISCONST(valp) ) {
  62.         if (valp->tag == TADDR
  63.          && valp->addrblock.uname_tag == UNAM_CONST) {
  64.             /* kludge */
  65.             frexpr(valp->addrblock.memoffset);
  66.             valp->tag = TCONST;
  67.             }
  68.         else {
  69.             err("non-constant initializer");
  70.             goto ret;
  71.             }
  72.         }
  73.  
  74.     if(toomanyinit) goto ret;
  75.     for(i = 0 ; i < nrep ; ++i)
  76.     {
  77.         p = nextdata(&elen);
  78.         if(p == NULL)
  79.         {
  80.             err("too many initializers");
  81.             toomanyinit = YES;
  82.             goto ret;
  83.         }
  84.         setdata((Addrp)p, (Constp)valp, elen);
  85.         frexpr((expptr)p);
  86.     }
  87.  
  88. ret:
  89.     frexpr(valp);
  90. }
  91.  
  92.  
  93.  Addrp
  94. #ifdef KR_headers
  95. nextdata(elenp)
  96.     ftnint *elenp;
  97. #else
  98. nextdata(ftnint *elenp)
  99. #endif
  100. {
  101.     register struct Impldoblock *ip;
  102.     struct Primblock *pp;
  103.     register Namep np;
  104.     register struct Rplblock *rp;
  105.     tagptr p;
  106.     expptr neltp;
  107.     register expptr q;
  108.     int skip;
  109.     ftnint off, vlen;
  110.  
  111.     while(curdtp)
  112.     {
  113.         p = (tagptr)curdtp->datap;
  114.         if(p->tag == TIMPLDO)
  115.         {
  116.             ip = &(p->impldoblock);
  117.             if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
  118.                 fatali("bad impldoblock 0%o", (int) ip);
  119.             if(ip->isactive)
  120.                 ip->varvp->Const.ci += ip->impdiff;
  121.             else
  122.             {
  123.                 q = fixtype(cpexpr(ip->implb));
  124.                 if( ! ISICON(q) )
  125.                     goto doerr;
  126.                 ip->varvp = (Constp) q;
  127.  
  128.                 if(ip->impstep)
  129.                 {
  130.                     q = fixtype(cpexpr(ip->impstep));
  131.                     if( ! ISICON(q) )
  132.                         goto doerr;
  133.                     ip->impdiff = q->constblock.Const.ci;
  134.                     frexpr(q);
  135.                 }
  136.                 else
  137.                     ip->impdiff = 1;
  138.  
  139.                 q = fixtype(cpexpr(ip->impub));
  140.                 if(! ISICON(q))
  141.                     goto doerr;
  142.                 ip->implim = q->constblock.Const.ci;
  143.                 frexpr(q);
  144.  
  145.                 ip->isactive = YES;
  146.                 rp = ALLOC(Rplblock);
  147.                 rp->rplnextp = rpllist;
  148.                 rpllist = rp;
  149.                 rp->rplnp = ip->varnp;
  150.                 rp->rplvp = (expptr) (ip->varvp);
  151.                 rp->rpltag = TCONST;
  152.             }
  153.  
  154.             if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
  155.                 || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
  156.             { /* start new loop */
  157.                 curdtp = ip->datalist;
  158.                 goto next;
  159.             }
  160.  
  161.             /* clean up loop */
  162.  
  163.             if(rpllist)
  164.             {
  165.                 rp = rpllist;
  166.                 rpllist = rpllist->rplnextp;
  167.                 free( (charptr) rp);
  168.             }
  169.             else
  170.                 Fatal("rpllist empty");
  171.  
  172.             frexpr((expptr)ip->varvp);
  173.             ip->isactive = NO;
  174.             curdtp = curdtp->nextp;
  175.             goto next;
  176.         }
  177.  
  178.         pp = (struct Primblock *) p;
  179.         np = pp->namep;
  180.         cur_varname = np->fvarname;
  181.         skip = YES;
  182.  
  183.         if(p->primblock.argsp==NULL && np->vdim!=NULL)
  184.         {   /* array initialization */
  185.             q = (expptr) mkaddr(np);
  186.             off = typesize[np->vtype] * curdtelt;
  187.             if(np->vtype == TYCHAR)
  188.                 off *= np->vleng->constblock.Const.ci;
  189.             q->addrblock.memoffset =
  190.                 mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
  191.             if( (neltp = np->vdim->nelt) && ISCONST(neltp))
  192.             {
  193.                 if(++curdtelt < neltp->constblock.Const.ci)
  194.                     skip = NO;
  195.             }
  196.             else
  197.                 err("attempt to initialize adjustable array");
  198.         }
  199.         else
  200.             q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
  201.         if(skip)
  202.         {
  203.             curdtp = curdtp->nextp;
  204.             curdtelt = 0;
  205.         }
  206.         if(q->headblock.vtype == TYCHAR)
  207.             if(ISICON(q->headblock.vleng))
  208.                 *elenp = q->headblock.vleng->constblock.Const.ci;
  209.             else    {
  210.                 err("initialization of string of nonconstant length");
  211.                 continue;
  212.             }
  213.         else    *elenp = typesize[q->headblock.vtype];
  214.  
  215.         if (np->vstg == STGBSS) {
  216.             vlen = np->vtype==TYCHAR
  217.                 ? np->vleng->constblock.Const.ci
  218.                 : typesize[np->vtype];
  219.             if(vlen > 0)
  220.                 np->vstg = STGINIT;
  221.             }
  222.         return( (Addrp) q );
  223.  
  224. doerr:
  225.         err("nonconstant implied DO parameter");
  226.         frexpr(q);
  227.         curdtp = curdtp->nextp;
  228.  
  229. next:
  230.         curdtelt = 0;
  231.     }
  232.  
  233.     return(NULL);
  234. }
  235.  
  236.  
  237.  
  238. LOCAL FILEP dfile;
  239.  
  240.  void
  241. #ifdef KR_headers
  242. setdata(varp, valp, elen)
  243.     register Addrp varp;
  244.     register Constp valp;
  245.     ftnint elen;
  246. #else
  247. setdata(register Addrp varp, register Constp valp, ftnint elen)
  248. #endif
  249. {
  250.     struct Constblock con;
  251.     register int type;
  252.     int i, k, valtype;
  253.     ftnint offset;
  254.     char *varname;
  255.     static Addrp badvar;
  256.     register unsigned char *s;
  257.     static int last_lineno;
  258.     static char *last_varname;
  259.  
  260.     if (varp->vstg == STGCOMMON) {
  261.         if (!(dfile = blkdfile))
  262.             dfile = blkdfile = opf(blkdfname, textwrite);
  263.         }
  264.     else {
  265.         if (procclass == CLBLOCK) {
  266.             if (varp != badvar) {
  267.                 badvar = varp;
  268.                 warn1("%s is not in a COMMON block",
  269.                     varp->uname_tag == UNAM_NAME
  270.                     ? varp->user.name->fvarname
  271.                     : "???");
  272.                 }
  273.             return;
  274.             }
  275.         if (!(dfile = initfile))
  276.             dfile = initfile = opf(initfname, textwrite);
  277.         }
  278.     varname = dataname(varp->vstg, varp->memno);
  279.     offset = varp->memoffset->constblock.Const.ci;
  280.     type = varp->vtype;
  281.     valtype = valp->vtype;
  282.     if(type!=TYCHAR && valtype==TYCHAR)
  283.     {
  284.         if(! ftn66flag
  285.         && (last_varname != cur_varname || last_lineno != lineno)) {
  286.             /* prevent multiple warnings */
  287.             last_lineno = lineno;
  288.             warn1(
  289.     "non-character datum %.42s initialized with character string",
  290.                 last_varname = cur_varname);
  291.             }
  292.         varp->vleng = ICON(typesize[type]);
  293.         varp->vtype = type = TYCHAR;
  294.     }
  295.     else if( (type==TYCHAR && valtype!=TYCHAR) ||
  296.         (cktype(OPASSIGN,type,valtype) == TYERROR) )
  297.     {
  298.         err("incompatible types in initialization");
  299.         return;
  300.     }
  301.     if(type == TYADDR)
  302.         con.Const.ci = valp->Const.ci;
  303.     else if(type != TYCHAR)
  304.     {
  305.         if(valtype == TYUNKNOWN)
  306.             con.Const.ci = valp->Const.ci;
  307.         else    consconv(type, &con, valp);
  308.     }
  309.  
  310.     k = 1;
  311.  
  312.     switch(type)
  313.     {
  314.     case TYLOGICAL:
  315.         if (tylogical != TYLONG)
  316.             type = tylogical;
  317.     case TYINT1:
  318.     case TYLOGICAL1:
  319.     case TYLOGICAL2:
  320.     case TYSHORT:
  321.     case TYLONG:
  322. #ifdef TYQUAD
  323.     case TYQUAD:
  324. #endif
  325.         dataline(varname, offset, type);
  326.         prconi(dfile, con.Const.ci);
  327.         break;
  328.  
  329.     case TYADDR:
  330.         dataline(varname, offset, type);
  331.         prcona(dfile, con.Const.ci);
  332.         break;
  333.  
  334.     case TYCOMPLEX:
  335.     case TYDCOMPLEX:
  336.         k = 2;
  337.     case TYREAL:
  338.     case TYDREAL:
  339.         dataline(varname, offset, type);
  340.         prconr(dfile, &con, k);
  341.         break;
  342.  
  343.     case TYCHAR:
  344.         k = valp -> vleng -> constblock.Const.ci;
  345.         if (elen < k)
  346.             k = elen;
  347.         s = (unsigned char *)valp->Const.ccp;
  348.         for(i = 0 ; i < k ; ++i) {
  349.             dataline(varname, offset++, TYCHAR);
  350.             fprintf(dfile, "\t%d\n", *s++);
  351.             }
  352.         k = elen - valp->vleng->constblock.Const.ci;
  353.         if(k > 0) {
  354.             dataline(varname, offset, TYBLANK);
  355.             fprintf(dfile, "\t%d\n", k);
  356.             }
  357.         break;
  358.  
  359.     default:
  360.         badtype("setdata", type);
  361.     }
  362.  
  363. }
  364.  
  365.  
  366.  
  367. /*
  368.    output form of name is padded with blanks and preceded
  369.    with a storage class digit
  370. */
  371.  char*
  372. #ifdef KR_headers
  373. dataname(stg, memno)
  374.     int stg;
  375.     long memno;
  376. #else
  377. dataname(int stg, long memno)
  378. #endif
  379. {
  380.     static char varname[64];
  381.     register char *s, *t;
  382.     char buf[16];
  383.  
  384.     if (stg == STGCOMMON) {
  385.         varname[0] = '2';
  386.         sprintf(s = buf, "Q.%ld", memno);
  387.         }
  388.     else {
  389.         varname[0] = stg==STGEQUIV ? '1' : '0';
  390.         s = memname(stg, memno);
  391.         }
  392.     t = varname + 1;
  393.     while(*t++ = *s++);
  394.     *t = 0;
  395.     return(varname);
  396. }
  397.  
  398.  
  399.  
  400.  
  401.  void
  402. #ifdef KR_headers
  403. frdata(p0)
  404.     chainp p0;
  405. #else
  406. frdata(chainp p0)
  407. #endif
  408. {
  409.     register struct Chain *p;
  410.     register tagptr q;
  411.  
  412.     for(p = p0 ; p ; p = p->nextp)
  413.     {
  414.         q = (tagptr)p->datap;
  415.         if(q->tag == TIMPLDO)
  416.         {
  417.             if(q->impldoblock.isbusy)
  418.                 return;    /* circular chain completed */
  419.             q->impldoblock.isbusy = YES;
  420.             frdata(q->impldoblock.datalist);
  421.             free( (charptr) q);
  422.         }
  423.         else
  424.             frexpr(q);
  425.     }
  426.  
  427.     frchain( &p0);
  428. }
  429.  
  430.  
  431.  void
  432. #ifdef KR_headers
  433. dataline(varname, offset, type)
  434.     char *varname;
  435.     ftnint offset;
  436.     int type;
  437. #else
  438. dataline(char *varname, ftnint offset, int type)
  439. #endif
  440. {
  441.     fprintf(dfile, datafmt, varname, offset, type);
  442. }
  443.  
  444.  void
  445. #ifdef KR_headers
  446. make_param(p, e)
  447.     register struct Paramblock *p;
  448.     expptr e;
  449. #else
  450. make_param(register struct Paramblock *p, expptr e)
  451. #endif
  452. {
  453.     register expptr q;
  454.     struct Constblock qc;
  455.  
  456.     p->vclass = CLPARAM;
  457.     impldcl((Namep)p);
  458.     if (e->headblock.vtype != TYCHAR)
  459.         e = putx(fixtype(e));
  460.     p->paramval = q = mkconv(p->vtype, e);
  461.     if (p->vtype == TYCHAR) {
  462.         if (q->tag == TEXPR)
  463.             p->paramval = q = fixexpr((Exprp)q);
  464.         if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) {
  465.             qc.Const = q->addrblock.user.Const;
  466.             qc.tag = TCONST;
  467.             qc.vtype = q->addrblock.vtype;
  468.             qc.vleng = q->addrblock.vleng;
  469.             q = (expptr)&qc;
  470.             }
  471.         if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
  472.             errstr("invalid value for character parameter %s",
  473.                 p->fvarname);
  474.             return;
  475.             }
  476.         if (!(e = p->vleng))
  477.             p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
  478.                     + q->constblock.Const.ccp1.blanks);
  479.         else if (q->constblock.vleng->constblock.Const.ci
  480.                 > e->constblock.Const.ci) {
  481.             q->constblock.vleng->constblock.Const.ci
  482.                 = e->constblock.Const.ci;
  483.             q->constblock.Const.ccp1.blanks = 0;
  484.             }
  485.         else
  486.             q->constblock.Const.ccp1.blanks
  487.                 = e->constblock.Const.ci
  488.                 - q->constblock.vleng->constblock.Const.ci;
  489.         }
  490.     }
  491.