Doxygen Source Code Documentation
Main Page Alphabetical List Data Structures File List Data Fields Globals Search
data.c
Go to the documentation of this file.00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025
00026
00027
00028 static char datafmt[] = "%s\t%09ld\t%d";
00029 static char *cur_varname;
00030
00031
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
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 {
00158 curdtp = ip->datalist;
00159 goto next;
00160 }
00161
00162
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 {
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
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
00368
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;
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 }