sources/f2c/data.c

   1 /****************************************************************
   2 Copyright 1990 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
  30 /* another initializer, called from parser */
  31 dataval(repp, valp)
  32 register expptr repp, valp;
  33 {
  34         int i, nrep;
  35         ftnint elen;
  36         register Addrp p;
  37         Addrp nextdata();
  38
  39         if (parstate < INDATA) {
  40                 frexpr(repp);
  41                 goto ret;
  42                 }
  43         if(repp == NULL)
  44                 nrep = 1;
  45         else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
  46                 nrep = repp->constblock.Const.ci;
  47         else
  48         {
  49                 err("invalid repetition count in DATA statement");
  50                 frexpr(repp);
  51                 goto ret;
  52         }
  53         frexpr(repp);
  54
  55         if( ! ISCONST(valp) )
  56         {
  57                 err("non-constant initializer");
  58                 goto ret;
  59         }
  60
  61         if(toomanyinit) goto ret;
  62         for(i = 0 ; i < nrep ; ++i)
  63         {
  64                 p = nextdata(&elen);
  65                 if(p == NULL)
  66                 {
  67                         err("too many initializers");
  68                         toomanyinit = YES;
  69                         goto ret;
  70                 }
  71                 setdata((Addrp)p, (Constp)valp, elen);
  72                 frexpr((expptr)p);
  73         }
  74
  75 ret:
  76         frexpr(valp);
  77 }
  78
  79
  80 Addrp nextdata(elenp)
  81 ftnint *elenp;
  82 {
  83         register struct Impldoblock *ip;
  84         struct Primblock *pp;
  85         register Namep np;
  86         register struct Rplblock *rp;
  87         tagptr p;
  88         expptr neltp;
  89         register expptr q;
  90         int skip;
  91         ftnint off, vlen;
  92
  93         while(curdtp)
  94         {
  95                 p = (tagptr)curdtp->datap;
  96                 if(p->tag == TIMPLDO)
  97                 {
  98                         ip = &(p->impldoblock);
  99                         if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
 100                                 fatali("bad impldoblock 0%o", (int) ip);
 101                         if(ip->isactive)
 102                                 ip->varvp->Const.ci += ip->impdiff;
 103                         else
 104                         {
 105                                 q = fixtype(cpexpr(ip->implb));
 106                                 if( ! ISICON(q) )
 107                                         goto doerr;
 108                                 ip->varvp = (Constp) q;
 109
 110                                 if(ip->impstep)
 111                                 {
 112                                         q = fixtype(cpexpr(ip->impstep));
 113                                         if( ! ISICON(q) )
 114                                                 goto doerr;
 115                                         ip->impdiff = q->constblock.Const.ci;
 116                                         frexpr(q);
 117                                 }
 118                                 else
 119                                         ip->impdiff = 1;
 120
 121                                 q = fixtype(cpexpr(ip->impub));
 122                                 if(! ISICON(q))
 123                                         goto doerr;
 124                                 ip->implim = q->constblock.Const.ci;
 125                                 frexpr(q);
 126
 127                                 ip->isactive = YES;
 128                                 rp = ALLOC(Rplblock);
 129                                 rp->rplnextp = rpllist;
 130                                 rpllist = rp;
 131                                 rp->rplnp = ip->varnp;
 132                                 rp->rplvp = (expptr) (ip->varvp);
 133                                 rp->rpltag = TCONST;
 134                         }
 135
 136                         if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
 137                             || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
 138                         { /* start new loop */
 139                                 curdtp = ip->datalist;
 140                                 goto next;
 141                         }
 142
 143                         /* clean up loop */
 144
 145                         if(rpllist)
 146                         {
 147                                 rp = rpllist;
 148                                 rpllist = rpllist->rplnextp;
 149                                 free( (charptr) rp);
 150                         }
 151                         else
 152                                 Fatal("rpllist empty");
 153
 154                         frexpr((expptr)ip->varvp);
 155                         ip->isactive = NO;
 156                         curdtp = curdtp->nextp;
 157                         goto next;
 158                 }
 159
 160                 pp = (struct Primblock *) p;
 161                 np = pp->namep;
 162                 skip = YES;
 163
 164                 if(p->primblock.argsp==NULL && np->vdim!=NULL)
 165                 {   /* array initialization */
 166                         q = (expptr) mkaddr(np);
 167                         off = typesize[np->vtype] * curdtelt;
 168                         if(np->vtype == TYCHAR)
 169                                 off *= np->vleng->constblock.Const.ci;
 170                         q->addrblock.memoffset =
 171                             mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
 172                         if( (neltp = np->vdim->nelt) && ISCONST(neltp))
 173                         {
 174                                 if(++curdtelt < neltp->constblock.Const.ci)
 175                                         skip = NO;
 176                         }
 177                         else
 178                                 err("attempt to initialize adjustable array");
 179                 }
 180                 else
 181                         q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
 182                 if(skip)
 183                 {
 184                         curdtp = curdtp->nextp;
 185                         curdtelt = 0;
 186                 }
 187                 if(q->headblock.vtype == TYCHAR)
 188                         if(ISICON(q->headblock.vleng))
 189                                 *elenp = q->headblock.vleng->constblock.Const.ci;
 190                         else    {
 191                                 err("initialization of string of nonconstant length");
 192                                 continue;
 193                         }
 194                 else    *elenp = typesize[q->headblock.vtype];
 195
 196                 if (np->vstg == STGBSS) {
 197                         vlen = np->vtype==TYCHAR
 198                                 ? np->vleng->constblock.Const.ci
 199                                 : typesize[np->vtype];
 200                         if(vlen > 0)
 201                                 np->vstg = STGINIT;
 202                         }
 203                 return( (Addrp) q );
 204
 205 doerr:
 206                 err("nonconstant implied DO parameter");
 207                 frexpr(q);
 208                 curdtp = curdtp->nextp;
 209
 210 next:
 211                 curdtelt = 0;
 212         }
 213
 214         return(NULL);
 215 }
 216
 217
 218
 219 LOCAL FILEP dfile;
 220
 221
 222 setdata(varp, valp, elen)
 223 register Addrp varp;
 224 ftnint elen;
 225 register Constp valp;
 226 {
 227         struct Constblock con;
 228         register int type;
 229         int i, k, valtype;
 230         ftnint offset;
 231         char *dataname(), *varname;
 232         static Addrp badvar;
 233
 234         if (varp->vstg == STGCOMMON) {
 235                 if (!(dfile = blkdfile))
 236                         dfile = blkdfile = opf(blkdfname, textwrite);
 237                 }
 238         else {
 239                 if (procclass == CLBLOCK) {
 240                         if (varp != badvar) {
 241                                 badvar = varp;
 242                                 warn1("%s is not in a COMMON block",
 243                                         varp->uname_tag == UNAM_NAME
 244                                         ? varp->user.name->fvarname
 245                                         : "???");
 246                                 }
 247                         return;
 248                         }
 249                 if (!(dfile = initfile))
 250                         dfile = initfile = opf(initfname, textwrite);
 251                 }
 252         varname = dataname(varp->vstg, varp->memno);
 253         offset = varp->memoffset->constblock.Const.ci;
 254         type = varp->vtype;
 255         valtype = valp->vtype;
 256         if(type!=TYCHAR && valtype==TYCHAR)
 257         {
 258                 if(! ftn66flag)
 259                         warn("non-character datum initialized with character string");
 260                 varp->vleng = ICON(typesize[type]);
 261                 varp->vtype = type = TYCHAR;
 262         }
 263         else if( (type==TYCHAR && valtype!=TYCHAR) ||
 264             (cktype(OPASSIGN,type,valtype) == TYERROR) )
 265         {
 266                 err("incompatible types in initialization");
 267                 return;
 268         }
 269         if(type == TYADDR)
 270                 con.Const.ci = valp->Const.ci;
 271         else if(type != TYCHAR)
 272         {
 273                 if(valtype == TYUNKNOWN)
 274                         con.Const.ci = valp->Const.ci;
 275                 else    consconv(type, &con, valp);
 276         }
 277
 278         k = 1;
 279
 280         switch(type)
 281         {
 282         case TYLOGICAL:
 283                 if (tylogical != TYLONG)
 284                         type = tylogical;
 285         case TYSHORT:
 286         case TYLONG:
 287                 dataline(varname, offset, type);
 288                 prconi(dfile, con.Const.ci);
 289                 break;
 290
 291         case TYADDR:
 292                 dataline(varname, offset, type);
 293                 prcona(dfile, con.Const.ci);
 294                 break;
 295
 296         case TYCOMPLEX:
 297         case TYDCOMPLEX:
 298                 k = 2;
 299         case TYREAL:
 300         case TYDREAL:
 301                 dataline(varname, offset, type);
 302                 prconr(dfile, &con, k);
 303                 break;
 304
 305         case TYCHAR:
 306                 k = valp -> vleng -> constblock.Const.ci;
 307                 if (elen < k)
 308                         k = elen;
 309                 for(i = 0 ; i < k ; ++i) {
 310                         dataline(varname, offset++, TYCHAR);
 311                         fprintf(dfile, "\t%d\n",
 312                             valp->Const.ccp[i]);
 313                         }
 314                 k = elen - valp->vleng->constblock.Const.ci;
 315                 if(k > 0) {
 316                         dataline(varname, offset, TYBLANK);
 317                         fprintf(dfile, "\t%d\n", k);
 318                         }
 319                 break;
 320
 321         default:
 322                 badtype("setdata", type);
 323         }
 324
 325 }
 326
 327
 328
 329 /*
 330    output form of name is padded with blanks and preceded
 331    with a storage class digit
 332 */
 333 char *dataname(stg,memno)
 334  int stg;
 335  long memno;
 336 {
 337         static char varname[64];
 338         register char *s, *t;
 339         char buf[16], *memname();
 340
 341         if (stg == STGCOMMON) {
 342                 varname[0] = '2';
 343                 sprintf(s = buf, "Q.%ld", memno);
 344                 }
 345         else {
 346                 varname[0] = stg==STGEQUIV ? '1' : '0';
 347                 s = memname(stg, memno);
 348                 }
 349         t = varname + 1;
 350         while(*t++ = *s++);
 351         *t = 0;
 352         return(varname);
 353 }
 354
 355
 356
 357
 358
 359 frdata(p0)
 360 chainp p0;
 361 {
 362         register struct Chain *p;
 363         register tagptr q;
 364
 365         for(p = p0 ; p ; p = p->nextp)
 366         {
 367                 q = (tagptr)p->datap;
 368                 if(q->tag == TIMPLDO)
 369                 {
 370                         if(q->impldoblock.isbusy)
 371                                 return; /* circular chain completed */
 372                         q->impldoblock.isbusy = YES;
 373                         frdata(q->impldoblock.datalist);
 374                         free( (charptr) q);
 375                 }
 376                 else
 377                         frexpr(q);
 378         }
 379
 380         frchain( &p0);
 381 }
 382
 383
 384
 385 dataline(varname, offset, type)
 386 char *varname;
 387 ftnint offset;
 388 int type;
 389 {
 390         fprintf(dfile, datafmt, varname, offset, type);
 391 }
 392
 393  void
 394 make_param(p, e)
 395  register struct Paramblock *p;
 396  expptr e;
 397 {
 398         p->vclass = CLPARAM;
 399         impldcl((Namep)p);
 400         p->paramval = mkconv(p->vtype, e);
 401         }