Return to data.c CVS log

Up to [CSRG BSD Unix] / 42BSD / old / f77

Annotation of 42BSD/old/f77/data.c, revision 1.1

1.1     ! root        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 expptr repp, valp;
        !            10: {
        !            11: int i, nrep;
        !            12: ftnint elen, vlen;
        !            13: register Addrp p;
        !            14: Addrp nextdata();
        !            15: 
        !            16: if(repp == NULL)
        !            17:        nrep = 1;
        !            18: else if (ISICON(repp) && repp->constblock.const.ci >= 0)
        !            19:        nrep = repp->constblock.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: Addrp nextdata(elenp, vlenp)
        !            54: ftnint *elenp, *vlenp;
        !            55: {
        !            56: register struct Impldoblock *ip;
        !            57: struct Primblock *pp;
        !            58: register Namep np;
        !            59: register struct Rplblock *rp;
        !            60: tagptr p;
        !            61: expptr neltp;
        !            62: register expptr q;
        !            63: int skip;
        !            64: ftnint off;
        !            65: 
        !            66: while(curdtp)
        !            67:        {
        !            68:        p = curdtp->datap;
        !            69:        if(p->tag == TIMPLDO)
        !            70:                {
        !            71:                ip = &(p->impldoblock);
        !            72:                if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
        !            73:                        fatali("bad impldoblock 0%o", (int) ip);
        !            74:                if(ip->isactive)
        !            75:                        ip->varvp->const.ci += ip->impdiff;
        !            76:                else
        !            77:                        {
        !            78:                        q = fixtype(cpexpr(ip->implb));
        !            79:                        if( ! ISICON(q) )
        !            80:                                goto doerr;
        !            81:                        ip->varvp = (Constp) q;
        !            82: 
        !            83:                        if(ip->impstep)
        !            84:                                {
        !            85:                                q = fixtype(cpexpr(ip->impstep));
        !            86:                                if( ! ISICON(q) )
        !            87:                                        goto doerr;
        !            88:                                ip->impdiff = q->constblock.const.ci;
        !            89:                                frexpr(q);
        !            90:                                }
        !            91:                        else
        !            92:                                ip->impdiff = 1;
        !            93: 
        !            94:                        q = fixtype(cpexpr(ip->impub));
        !            95:                        if(! ISICON(q))
        !            96:                                goto doerr;
        !            97:                        ip->implim = q->constblock.const.ci;
        !            98:                        frexpr(q);
        !            99: 
        !           100:                        ip->isactive = YES;
        !           101:                        rp = ALLOC(Rplblock);
        !           102:                        rp->rplnextp = rpllist;
        !           103:                        rpllist = rp;
        !           104:                        rp->rplnp = ip->varnp;
        !           105:                        rp->rplvp = (expptr) (ip->varvp);
        !           106:                        rp->rpltag = TCONST;
        !           107:                        }
        !           108: 
        !           109:                if( (ip->impdiff>0 && (ip->varvp->const.ci <= ip->implim))
        !           110:                 || (ip->impdiff<0 && (ip->varvp->const.ci >= ip->implim)) )
        !           111:                        { /* start new loop */
        !           112:                        curdtp = ip->datalist;
        !           113:                        goto next;
        !           114:                        }
        !           115: 
        !           116:                /* clean up loop */
        !           117: 
        !           118:                if(rpllist)
        !           119:                        {
        !           120:                        rp = rpllist;
        !           121:                        rpllist = rpllist->rplnextp;
        !           122:                        free( (charptr) rp);
        !           123:                        }
        !           124:                else
        !           125:                        fatal("rpllist empty");
        !           126: 
        !           127:                frexpr(ip->varvp);
        !           128:                ip->isactive = NO;
        !           129:                curdtp = curdtp->nextp;
        !           130:                goto next;
        !           131:                }
        !           132: 
        !           133:        pp = (struct Primblock *) p;
        !           134:        np = pp->namep;
        !           135:        skip = YES;
        !           136: 
        !           137:        if(p->primblock.argsp==NULL && np->vdim!=NULL)
        !           138:                {   /* array initialization */
        !           139:                q = (expptr) mkaddr(np);
        !           140:                off = typesize[np->vtype] * curdtelt;
        !           141:                if(np->vtype == TYCHAR)
        !           142:                        off *= np->vleng->constblock.const.ci;
        !           143:                q->addrblock.memoffset =
        !           144:                        mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
        !           145:                if( (neltp = np->vdim->nelt) && ISCONST(neltp))
        !           146:                        {
        !           147:                        if(++curdtelt < neltp->constblock.const.ci)
        !           148:                                skip = NO;
        !           149:                        }
        !           150:                else
        !           151:                        err("attempt to initialize adjustable array");
        !           152:                }
        !           153:        else
        !           154:                q = mklhs( cpexpr(pp) );
        !           155:        if(skip)
        !           156:                {
        !           157:                curdtp = curdtp->nextp;
        !           158:                curdtelt = 0;
        !           159:                }
        !           160:        if(q->headblock.vtype == TYCHAR)
        !           161:                if(ISICON(q->headblock.vleng))
        !           162:                        *elenp = q->headblock.vleng->constblock.const.ci;
        !           163:                else    {
        !           164:                        err("initialization of string of nonconstant length");
        !           165:                        continue;
        !           166:                        }
        !           167:        else    *elenp = typesize[q->headblock.vtype];
        !           168: 
        !           169:        if(np->vstg == STGCOMMON)
        !           170:                *vlenp = extsymtab[np->vardesc.varno].maxleng;
        !           171:        else if(np->vstg == STGEQUIV)
        !           172:                *vlenp = eqvclass[np->vardesc.varno].eqvleng;
        !           173:        else    {
        !           174:                *vlenp =  (np->vtype==TYCHAR ?
        !           175:                                np->vleng->constblock.const.ci :
        !           176:                                        typesize[np->vtype]);
        !           177:                if(np->vstg==STGBSS && *vlenp>0)
        !           178:                        np->vstg = STGINIT;
        !           179:                if(np->vdim)
        !           180:                        *vlenp *= np->vdim->nelt->constblock.const.ci;
        !           181:                }
        !           182:        return( (Addrp) q );
        !           183: 
        !           184: doerr:
        !           185:                err("nonconstant implied DO parameter");
        !           186:                frexpr(q);
        !           187:                curdtp = curdtp->nextp;
        !           188: 
        !           189: next:  curdtelt = 0;
        !           190:        }
        !           191: 
        !           192: return(NULL);
        !           193: }
        !           194: 
        !           195: 
        !           196: 
        !           197: 
        !           198: 
        !           199: 
        !           200: setdata(varp, valp, elen, vlen)
        !           201: register Addrp varp;
        !           202: ftnint elen, vlen;
        !           203: register Constp valp;
        !           204: {
        !           205: union Constant con;
        !           206: register int type;
        !           207: int i, k, valtype;
        !           208: ftnint offset;
        !           209: char *dataname(), *varname;
        !           210: 
        !           211: varname = dataname(varp->vstg, varp->memno);
        !           212: offset = varp->memoffset->constblock.const.ci;
        !           213: type = varp->vtype;
        !           214: valtype = valp->vtype;
        !           215: if(type!=TYCHAR && valtype==TYCHAR)
        !           216:        {
        !           217:        if(! ftn66flag)
        !           218:                warn("non-character datum initialized with character string");
        !           219:        varp->vleng = ICON(typesize[type]);
        !           220:        varp->vtype = type = TYCHAR;
        !           221:        }
        !           222: else if( (type==TYCHAR && valtype!=TYCHAR) ||
        !           223:         (cktype(OPASSIGN,type,valtype) == TYERROR) )
        !           224:        {
        !           225:        err("incompatible types in initialization");
        !           226:        return;
        !           227:        }
        !           228: if(type == TYADDR)
        !           229:        con.ci = valp->const.ci;
        !           230: else if(type != TYCHAR)
        !           231:        {
        !           232:        if(valtype == TYUNKNOWN)
        !           233:                con.ci = valp->const.ci;
        !           234:        else    consconv(type, &con, valtype, &valp->const);
        !           235:        }
        !           236: 
        !           237: k = 1;
        !           238: switch(type)
        !           239:        {
        !           240:        case TYLOGICAL:
        !           241:                type = tylogical;
        !           242:        case TYSHORT:
        !           243:        case TYLONG:
        !           244:                dataline(varname, offset, vlen, type);
        !           245:                prconi(initfile, type, con.ci);
        !           246:                break;
        !           247: 
        !           248:        case TYADDR:
        !           249:                dataline(varname, offset, vlen, type);
        !           250:                prcona(initfile, con.ci);
        !           251:                break;
        !           252: 
        !           253:        case TYCOMPLEX:
        !           254:                k = 2;
        !           255:                type = TYREAL;
        !           256:        case TYREAL:
        !           257:                goto flpt;
        !           258: 
        !           259:        case TYDCOMPLEX:
        !           260:                k = 2;
        !           261:                type = TYDREAL;
        !           262:        case TYDREAL:
        !           263:        flpt:
        !           264: 
        !           265:                for(i = 0 ; i < k ; ++i)
        !           266:                        {
        !           267:                        dataline(varname, offset, vlen, type);
        !           268:                        prconr(initfile, type, con.cd[i]);
        !           269:                        offset += typesize[type];
        !           270:                        }
        !           271:                break;
        !           272: 
        !           273:        case TYCHAR:
        !           274:                k = valp->vleng->constblock.const.ci;
        !           275:                if(elen < k)
        !           276:                        k = elen;
        !           277: 
        !           278:                for(i = 0 ; i < k ; ++i)
        !           279:                        {
        !           280:                        dataline(varname, offset++, vlen, TYCHAR);
        !           281:                        fprintf(initfile, "\t%d\n",
        !           282:                                valp->const.ccp[i]);
        !           283:                        }
        !           284:                k = elen - valp->vleng->constblock.const.ci;
        !           285:                if(k > 0)
        !           286:                        {
        !           287:                        dataline(varname, offset, vlen, TYBLANK);
        !           288:                        fprintf(initfile, "\t%d\n", k);
        !           289:                        offset += k;
        !           290:                        }
        !           291:                break;
        !           292: 
        !           293:        default:
        !           294:                badtype("setdata", type);
        !           295:        }
        !           296: 
        !           297: }
        !           298: 
        !           299: 
        !           300: 
        !           301: /*
        !           302:    output form of name is padded with blanks and preceded
        !           303:    with a storage class digit
        !           304: */
        !           305: char *dataname(stg,memno)
        !           306: int stg, memno;
        !           307: {
        !           308: static char varname[XL+2];
        !           309: register char *s, *t;
        !           310: char *memname();
        !           311: 
        !           312: varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
        !           313: s = memname(stg, memno);
        !           314: for(t = varname+1 ; *s ; )
        !           315:        *t++ = *s++;
        !           316: while(t < varname+XL+1)
        !           317:        *t++ = ' ';
        !           318: varname[XL+1] = '\0';
        !           319: return(varname);
        !           320: }
        !           321: 
        !           322: 
        !           323: 
        !           324: 
        !           325: 
        !           326: frdata(p0)
        !           327: chainp p0;
        !           328: {
        !           329: register struct Chain *p;
        !           330: register tagptr q;
        !           331: 
        !           332: for(p = p0 ; p ; p = p->nextp)
        !           333:        {
        !           334:        q = p->datap;
        !           335:        if(q->tag == TIMPLDO)
        !           336:                {
        !           337:                if(q->impldoblock.isbusy)
        !           338:                        return; /* circular chain completed */
        !           339:                q->impldoblock.isbusy = YES;
        !           340:                frdata(q->impldoblock.datalist);
        !           341:                free( (charptr) q);
        !           342:                }
        !           343:        else
        !           344:                frexpr(q);
        !           345:        }
        !           346: 
        !           347: frchain( &p0);
        !           348: }
        !           349: 
        !           350: 
        !           351: 
        !           352: dataline(varname, offset, vlen, type)
        !           353: char *varname;
        !           354: ftnint offset, vlen;
        !           355: int type;
        !           356: {
        !           357: fprintf(initfile, datafmt, varname, offset, vlen, type);
        !           358: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.