00001 /****************************************************************
00002 Copyright 1990, 1993 - 1996 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 
00026 /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
00027 
00028 static char datafmt[] = "%s\t%09ld\t%d";
00029 static char *cur_varname;
00030 
00031 /* another initializer, called from parser */
00032  void
00033 #ifdef KR_headers
00034 dataval(repp, valp)
00035         register expptr repp;
00036         register expptr valp;
00037 #else
00038 dataval(register expptr repp, register expptr valp)
00039 #endif
00040 {
00041         int i, nrep;
00042         ftnint elen;
00043         register Addrp p;
00044 
00045         if (parstate < INDATA) {
00046                 frexpr(repp);
00047                 goto ret;
00048                 }
00049         if(repp == NULL)
00050                 nrep = 1;
00051         else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
00052                 nrep = repp->constblock.Const.ci;
00053         else
00054         {
00055                 err("invalid repetition count in DATA statement");
00056                 frexpr(repp);
00057                 goto ret;
00058         }
00059         frexpr(repp);
00060 
00061         if( ! ISCONST(valp) ) {
00062                 if (valp->tag == TADDR
00063                  && valp->addrblock.uname_tag == UNAM_CONST) {
00064                         /* kludge */
00065                         frexpr(valp->addrblock.memoffset);
00066                         valp->tag = TCONST;
00067                         }
00068                 else {
00069                         err("non-constant initializer");
00070                         goto ret;
00071                         }
00072                 }
00073 
00074         if(toomanyinit) goto ret;
00075         for(i = 0 ; i < nrep ; ++i)
00076         {
00077                 p = nextdata(&elen);
00078                 if(p == NULL)
00079                 {
00080                         if (lineno != err_lineno)
00081                                 err("too many initializers");
00082                         toomanyinit = YES;
00083                         goto ret;
00084                 }
00085                 setdata((Addrp)p, (Constp)valp, elen);
00086                 frexpr((expptr)p);
00087         }
00088 
00089 ret:
00090         frexpr(valp);
00091 }
00092 
00093 
00094  Addrp
00095 #ifdef KR_headers
00096 nextdata(elenp)
00097         ftnint *elenp;
00098 #else
00099 nextdata(ftnint *elenp)
00100 #endif
00101 {
00102         register struct Impldoblock *ip;
00103         struct Primblock *pp;
00104         register Namep np;
00105         register struct Rplblock *rp;
00106         tagptr p;
00107         expptr neltp;
00108         register expptr q;
00109         int skip;
00110         ftnint off, vlen;
00111 
00112         while(curdtp)
00113         {
00114                 p = (tagptr)curdtp->datap;
00115                 if(p->tag == TIMPLDO)
00116                 {
00117                         ip = &(p->impldoblock);
00118                         if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
00119                                 fatali("bad impldoblock 0%o", (int) ip);
00120                         if(ip->isactive)
00121                                 ip->varvp->Const.ci += ip->impdiff;
00122                         else
00123                         {
00124                                 q = fixtype(cpexpr(ip->implb));
00125                                 if( ! ISICON(q) )
00126                                         goto doerr;
00127                                 ip->varvp = (Constp) q;
00128 
00129                                 if(ip->impstep)
00130                                 {
00131                                         q = fixtype(cpexpr(ip->impstep));
00132                                         if( ! ISICON(q) )
00133                                                 goto doerr;
00134                                         ip->impdiff = q->constblock.Const.ci;
00135                                         frexpr(q);
00136                                 }
00137                                 else
00138                                         ip->impdiff = 1;
00139 
00140                                 q = fixtype(cpexpr(ip->impub));
00141                                 if(! ISICON(q))
00142                                         goto doerr;
00143                                 ip->implim = q->constblock.Const.ci;
00144                                 frexpr(q);
00145 
00146                                 ip->isactive = YES;
00147                                 rp = ALLOC(Rplblock);
00148                                 rp->rplnextp = rpllist;
00149                                 rpllist = rp;
00150                                 rp->rplnp = ip->varnp;
00151                                 rp->rplvp = (expptr) (ip->varvp);
00152                                 rp->rpltag = TCONST;
00153                         }
00154 
00155                         if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
00156                             || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
00157                         { /* start new loop */
00158                                 curdtp = ip->datalist;
00159                                 goto next;
00160                         }
00161 
00162                         /* clean up loop */
00163 
00164                         if(rpllist)
00165                         {
00166                                 rp = rpllist;
00167                                 rpllist = rpllist->rplnextp;
00168                                 free( (charptr) rp);
00169                         }
00170                         else
00171                                 Fatal("rpllist empty");
00172 
00173                         frexpr((expptr)ip->varvp);
00174                         ip->isactive = NO;
00175                         curdtp = curdtp->nextp;
00176                         goto next;
00177                 }
00178 
00179                 pp = (struct Primblock *) p;
00180                 np = pp->namep;
00181                 cur_varname = np->fvarname;
00182                 skip = YES;
00183 
00184                 if(p->primblock.argsp==NULL && np->vdim!=NULL)
00185                 {   /* array initialization */
00186                         q = (expptr) mkaddr(np);
00187                         off = typesize[np->vtype] * curdtelt;
00188                         if(np->vtype == TYCHAR)
00189                                 off *= np->vleng->constblock.Const.ci;
00190                         q->addrblock.memoffset =
00191                             mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
00192                         if( (neltp = np->vdim->nelt) && ISCONST(neltp))
00193                         {
00194                                 if(++curdtelt < neltp->constblock.Const.ci)
00195                                         skip = NO;
00196                         }
00197                         else
00198                                 err("attempt to initialize adjustable array");
00199                 }
00200                 else
00201                         q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
00202                 if(skip)
00203                 {
00204                         curdtp = curdtp->nextp;
00205                         curdtelt = 0;
00206                 }
00207                 if(q->headblock.vtype == TYCHAR)
00208                         if(ISICON(q->headblock.vleng))
00209                                 *elenp = q->headblock.vleng->constblock.Const.ci;
00210                         else    {
00211                                 err("initialization of string of nonconstant length");
00212                                 continue;
00213                         }
00214                 else    *elenp = typesize[q->headblock.vtype];
00215 
00216                 if (np->vstg == STGBSS) {
00217                         vlen = np->vtype==TYCHAR
00218                                 ? np->vleng->constblock.Const.ci
00219                                 : typesize[np->vtype];
00220                         if(vlen > 0)
00221                                 np->vstg = STGINIT;
00222                         }
00223                 return( (Addrp) q );
00224 
00225 doerr:
00226                 err("nonconstant implied DO parameter");
00227                 frexpr(q);
00228                 curdtp = curdtp->nextp;
00229 
00230 next:
00231                 curdtelt = 0;
00232         }
00233 
00234         return(NULL);
00235 }
00236 
00237 
00238 
00239 LOCAL FILEP dfile;
00240 
00241  void
00242 #ifdef KR_headers
00243 setdata(varp, valp, elen)
00244         register Addrp varp;
00245         register Constp valp;
00246         ftnint elen;
00247 #else
00248 setdata(register Addrp varp, register Constp valp, ftnint elen)
00249 #endif
00250 {
00251         struct Constblock con;
00252         register int type;
00253         int i, k, valtype;
00254         ftnint offset;
00255         char *varname;
00256         static Addrp badvar;
00257         register unsigned char *s;
00258         static int last_lineno;
00259         static char *last_varname;
00260 
00261         if (varp->vstg == STGCOMMON) {
00262                 if (!(dfile = blkdfile))
00263                         dfile = blkdfile = opf(blkdfname, textwrite);
00264                 }
00265         else {
00266                 if (procclass == CLBLOCK) {
00267                         if (varp != badvar) {
00268                                 badvar = varp;
00269                                 warn1("%s is not in a COMMON block",
00270                                         varp->uname_tag == UNAM_NAME
00271                                         ? varp->user.name->fvarname
00272                                         : "???");
00273                                 }
00274                         return;
00275                         }
00276                 if (!(dfile = initfile))
00277                         dfile = initfile = opf(initfname, textwrite);
00278                 }
00279         varname = dataname(varp->vstg, varp->memno);
00280         offset = varp->memoffset->constblock.Const.ci;
00281         type = varp->vtype;
00282         valtype = valp->vtype;
00283         if(type!=TYCHAR && valtype==TYCHAR)
00284         {
00285                 if(! ftn66flag
00286                 && (last_varname != cur_varname || last_lineno != lineno)) {
00287                         /* prevent multiple warnings */
00288                         last_lineno = lineno;
00289                         warn1(
00290         "non-character datum %.42s initialized with character string",
00291                                 last_varname = cur_varname);
00292                         }
00293                 varp->vleng = ICON(typesize[type]);
00294                 varp->vtype = type = TYCHAR;
00295         }
00296         else if( (type==TYCHAR && valtype!=TYCHAR) ||
00297             (cktype(OPASSIGN,type,valtype) == TYERROR) )
00298         {
00299                 err("incompatible types in initialization");
00300                 return;
00301         }
00302         if(type == TYADDR)
00303                 con.Const.ci = valp->Const.ci;
00304         else if(type != TYCHAR)
00305         {
00306                 if(valtype == TYUNKNOWN)
00307                         con.Const.ci = valp->Const.ci;
00308                 else    consconv(type, &con, valp);
00309         }
00310 
00311         k = 1;
00312 
00313         switch(type)
00314         {
00315         case TYLOGICAL:
00316         case TYINT1:
00317         case TYLOGICAL1:
00318         case TYLOGICAL2:
00319         case TYSHORT:
00320         case TYLONG:
00321 #ifdef TYQUAD
00322         case TYQUAD:
00323 #endif
00324                 dataline(varname, offset, type);
00325                 prconi(dfile, con.Const.ci);
00326                 break;
00327 
00328         case TYADDR:
00329                 dataline(varname, offset, type);
00330                 prcona(dfile, con.Const.ci);
00331                 break;
00332 
00333         case TYCOMPLEX:
00334         case TYDCOMPLEX:
00335                 k = 2;
00336         case TYREAL:
00337         case TYDREAL:
00338                 dataline(varname, offset, type);
00339                 prconr(dfile, &con, k);
00340                 break;
00341 
00342         case TYCHAR:
00343                 k = valp -> vleng -> constblock.Const.ci;
00344                 if (elen < k)
00345                         k = elen;
00346                 s = (unsigned char *)valp->Const.ccp;
00347                 for(i = 0 ; i < k ; ++i) {
00348                         dataline(varname, offset++, TYCHAR);
00349                         fprintf(dfile, "\t%d\n", *s++);
00350                         }
00351                 k = elen - valp->vleng->constblock.Const.ci;
00352                 if(k > 0) {
00353                         dataline(varname, offset, TYBLANK);
00354                         fprintf(dfile, "\t%d\n", k);
00355                         }
00356                 break;
00357 
00358         default:
00359                 badtype("setdata", type);
00360         }
00361 
00362 }
00363 
00364 
00365 
00366 /*
00367    output form of name is padded with blanks and preceded
00368    with a storage class digit
00369 */
00370  char*
00371 #ifdef KR_headers
00372 dataname(stg, memno)
00373         int stg;
00374         long memno;
00375 #else
00376 dataname(int stg, long memno)
00377 #endif
00378 {
00379         static char varname[64];
00380         register char *s, *t;
00381         char buf[16];
00382 
00383         if (stg == STGCOMMON) {
00384                 varname[0] = '2';
00385                 sprintf(s = buf, "Q.%ld", memno);
00386                 }
00387         else {
00388                 varname[0] = stg==STGEQUIV ? '1' : '0';
00389                 s = memname(stg, memno);
00390                 }
00391         t = varname + 1;
00392         while(*t++ = *s++);
00393         *t = 0;
00394         return(varname);
00395 }
00396 
00397 
00398 
00399 
00400  void
00401 #ifdef KR_headers
00402 frdata(p0)
00403         chainp p0;
00404 #else
00405 frdata(chainp p0)
00406 #endif
00407 {
00408         register struct Chain *p;
00409         register tagptr q;
00410 
00411         for(p = p0 ; p ; p = p->nextp)
00412         {
00413                 q = (tagptr)p->datap;
00414                 if(q->tag == TIMPLDO)
00415                 {
00416                         if(q->impldoblock.isbusy)
00417                                 return; /* circular chain completed */
00418                         q->impldoblock.isbusy = YES;
00419                         frdata(q->impldoblock.datalist);
00420                         free( (charptr) q);
00421                 }
00422                 else
00423                         frexpr(q);
00424         }
00425 
00426         frchain( &p0);
00427 }
00428 
00429 
00430  void
00431 #ifdef KR_headers
00432 dataline(varname, offset, type)
00433         char *varname;
00434         ftnint offset;
00435         int type;
00436 #else
00437 dataline(char *varname, ftnint offset, int type)
00438 #endif
00439 {
00440         fprintf(dfile, datafmt, varname, offset, type);
00441 }
00442 
00443  void
00444 #ifdef KR_headers
00445 make_param(p, e)
00446         register struct Paramblock *p;
00447         expptr e;
00448 #else
00449 make_param(register struct Paramblock *p, expptr e)
00450 #endif
00451 {
00452         register expptr q;
00453         Constp qc;
00454 
00455         if (p->vstg == STGARG)
00456                 errstr("Dummy argument %.50s appears in a parameter statement.",
00457                         p->fvarname);
00458         p->vclass = CLPARAM;
00459         impldcl((Namep)p);
00460         if (e->headblock.vtype != TYCHAR)
00461                 e = putx(fixtype(e));
00462         p->paramval = q = mkconv(p->vtype, e);
00463         if (p->vtype == TYCHAR) {
00464                 if (q->tag == TEXPR)
00465                         p->paramval = q = fixexpr((Exprp)q);
00466                 if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) {
00467                         qc = mkconst(TYCHAR);
00468                         qc->Const = q->addrblock.user.Const;
00469                         qc->vleng = q->addrblock.vleng;
00470                         q->addrblock.vleng = 0;
00471                         frexpr(q);
00472                         p->paramval = q = (expptr)qc;
00473                         }
00474                 if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
00475                         errstr("invalid value for character parameter %s",
00476                                 p->fvarname);
00477                         return;
00478                         }
00479                 if (!(e = p->vleng))
00480                         p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
00481                                         + q->constblock.Const.ccp1.blanks);
00482                 else if (q->constblock.vleng->constblock.Const.ci
00483                                 > e->constblock.Const.ci) {
00484                         q->constblock.vleng->constblock.Const.ci
00485                                 = e->constblock.Const.ci;
00486                         q->constblock.Const.ccp1.blanks = 0;
00487                         }
00488                 else
00489                         q->constblock.Const.ccp1.blanks
00490                                 = e->constblock.Const.ci
00491                                 - q->constblock.vleng->constblock.Const.ci;
00492                 }
00493         }