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