#include "defs.h"Include dependency graph for data.c:
Go to the source code of this file.
Functions | |
| void | dataval (register expptr repp, register expptr valp) |
| Addrp | nextdata (ftnint *elenp) |
| void | setdata (register Addrp varp, register Constp valp, ftnint elen) |
| char * | dataname (int stg, long memno) |
| void | frdata (chainp p0) |
| void | dataline (char *varname, ftnint offset, int type) |
| void | make_param (register struct Paramblock *p, expptr e) |
Variables | |
| static char | datafmt [] = "%s\t%09ld\t%d" |
| static char * | cur_varname |
| LOCAL FILEP | dfile |
Definition at line 385 of file data.c.
References buf, memname(), s, STGCOMMON, STGEQUIV, and t.
Referenced by setdata().
00387 { 00388 static char varname[64]; 00389 register char *s, *t; 00390 char buf[16]; 00391 00392 if (stg == STGCOMMON) { 00393 varname[0] = '2'; 00394 sprintf(s = buf, "Q.%ld", memno); 00395 } 00396 else { 00397 varname[0] = stg==STGEQUIV ? '1' : '0'; 00398 s = memname(stg, memno); 00399 } 00400 t = varname + 1; 00401 while(*t++ = *s++); 00402 *t = 0; 00403 return(varname); 00404 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 38 of file data.c.
References err, err_lineno, frexpr(), i, INDATA, ISCONST, ISICON, lineno, nextdata(), nrep, NULL, p, parstate, setdata(), TADDR, TCONST, toomanyinit, UNAM_CONST, and YES.
Referenced by yyparse().
00040 { 00041 ftnint elen, i, nrep; 00042 register Addrp p; 00043 00044 if (parstate < INDATA) { 00045 frexpr(repp); 00046 goto ret; 00047 } 00048 if(repp == NULL) 00049 nrep = 1; 00050 else if (ISICON(repp) && repp->constblock.Const.ci >= 0) 00051 nrep = repp->constblock.Const.ci; 00052 else 00053 { 00054 err("invalid repetition count in DATA statement"); 00055 frexpr(repp); 00056 goto ret; 00057 } 00058 frexpr(repp); 00059 00060 if( ! ISCONST(valp) ) { 00061 if (valp->tag == TADDR 00062 && valp->addrblock.uname_tag == UNAM_CONST) { 00063 /* kludge */ 00064 frexpr(valp->addrblock.memoffset); 00065 valp->tag = TCONST; 00066 } 00067 else { 00068 err("non-constant initializer"); 00069 goto ret; 00070 } 00071 } 00072 00073 if(toomanyinit) goto ret; 00074 for(i = 0 ; i < nrep ; ++i) 00075 { 00076 p = nextdata(&elen); 00077 if(p == NULL) 00078 { 00079 if (lineno != err_lineno) 00080 err("too many initializers"); 00081 toomanyinit = YES; 00082 goto ret; 00083 } 00084 setdata((Addrp)p, (Constp)valp, elen); 00085 frexpr((expptr)p); 00086 } 00087 00088 ret: 00089 frexpr(valp); 00090 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void frdata | ( | chainp | p0 | ) |
Definition at line 414 of file data.c.
References Impldoblock::datalist, free(), frexpr(), Expression::impldoblock, Impldoblock::isbusy, p, Expression::tag, TIMPLDO, and YES.
Referenced by yyparse().
00416 { 00417 register struct Chain *p; 00418 register tagptr q; 00419 00420 for(p = p0 ; p ; p = p->nextp) 00421 { 00422 q = (tagptr)p->datap; 00423 if(q->tag == TIMPLDO) 00424 { 00425 if(q->impldoblock.isbusy) 00426 return; /* circular chain completed */ 00427 q->impldoblock.isbusy = YES; 00428 frdata(q->impldoblock.datalist); 00429 free( (charptr) q); 00430 } 00431 else 00432 frexpr(q); 00433 } 00434 00435 frchain( &p0); 00436 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void make_param | ( | register struct Paramblock * | p, | |
| expptr | e | |||
| ) |
Definition at line 458 of file data.c.
References Constant::ci, CLPARAM, Constblock::Const, Expression::constblock, errstr(), fixexpr(), fixtype(), frexpr(), Expression::headblock, ICON, impldcl(), ISCONST, mkconst(), mkconv(), p, putx(), STGARG, TADDR, Exprblock::tag, Expression::tag, TEXPR, TYCHAR, UNAM_CONST, Exprblock::vleng, Constblock::vleng, Exprblock::vtype, and Headblock::vtype.
Referenced by yyparse().
00460 { 00461 register expptr q; 00462 Constp qc; 00463 00464 if (p->vstg == STGARG) 00465 errstr("Dummy argument %.50s appears in a parameter statement.", 00466 p->fvarname); 00467 p->vclass = CLPARAM; 00468 impldcl((Namep)p); 00469 if (e->headblock.vtype != TYCHAR) 00470 e = putx(fixtype(e)); 00471 p->paramval = q = mkconv(p->vtype, e); 00472 if (p->vtype == TYCHAR) { 00473 if (q->tag == TEXPR) 00474 p->paramval = q = fixexpr((Exprp)q); 00475 if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { 00476 qc = mkconst(TYCHAR); 00477 qc->Const = q->addrblock.user.Const; 00478 qc->vleng = q->addrblock.vleng; 00479 q->addrblock.vleng = 0; 00480 frexpr(q); 00481 p->paramval = q = (expptr)qc; 00482 } 00483 if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { 00484 errstr("invalid value for character parameter %s", 00485 p->fvarname); 00486 return; 00487 } 00488 if (!(e = p->vleng)) 00489 p->vleng = ICON(q->constblock.vleng->constblock.Const.ci 00490 + q->constblock.Const.ccp1.blanks); 00491 else if (q->constblock.vleng->constblock.Const.ci 00492 > e->constblock.Const.ci) { 00493 q->constblock.vleng->constblock.Const.ci 00494 = e->constblock.Const.ci; 00495 q->constblock.Const.ccp1.blanks = 0; 00496 } 00497 else 00498 q->constblock.Const.ccp1.blanks 00499 = e->constblock.Const.ci 00500 - q->constblock.vleng->constblock.Const.ci; 00501 } 00502 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 98 of file data.c.
References Expression::addrblock, ALLOC, buf, Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), cur_varname, curdtelt, curdtp, Chain::datap, err, Fatal(), fixtype(), free(), frexpr(), Nameblock::fvarname, Expression::headblock, ip, ISCONST, ISICON, Addrblock::memoffset, mkaddr(), mkexpr(), mkintcon(), mklhs(), Dimblock::nelt, Chain::nextp, NO, NULL, off, OPPLUS, p, pp, rpllist, Rplblock::rplnextp, Rplblock::rplnp, Rplblock::rpltag, Rplblock::rplvp, skip, STGBSS, STGINIT, TCONST, TIMPLDO, TYCHAR, typesize, Nameblock::vdim, Headblock::vleng, Nameblock::vleng, Nameblock::vstg, Headblock::vtype, Nameblock::vtype, and YES.
Referenced by dataval(), and yyparse().
00100 { 00101 register struct Impldoblock *ip; 00102 struct Primblock *pp; 00103 register Namep np; 00104 register struct Rplblock *rp; 00105 tagptr p; 00106 expptr neltp; 00107 register expptr q; 00108 int skip; 00109 ftnint off, vlen; 00110 00111 while(curdtp) 00112 { 00113 p = (tagptr)curdtp->datap; 00114 if(p->tag == TIMPLDO) 00115 { 00116 ip = &(p->impldoblock); 00117 if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) { 00118 char buf[100]; 00119 sprintf(buf, "bad impldoblock #%lx", 00120 (unsigned long)ip); 00121 Fatal(buf); 00122 } 00123 if(ip->isactive) 00124 ip->varvp->Const.ci += ip->impdiff; 00125 else 00126 { 00127 q = fixtype(cpexpr(ip->implb)); 00128 if( ! ISICON(q) ) 00129 goto doerr; 00130 ip->varvp = (Constp) q; 00131 00132 if(ip->impstep) 00133 { 00134 q = fixtype(cpexpr(ip->impstep)); 00135 if( ! ISICON(q) ) 00136 goto doerr; 00137 ip->impdiff = q->constblock.Const.ci; 00138 frexpr(q); 00139 } 00140 else 00141 ip->impdiff = 1; 00142 00143 q = fixtype(cpexpr(ip->impub)); 00144 if(! ISICON(q)) 00145 goto doerr; 00146 ip->implim = q->constblock.Const.ci; 00147 frexpr(q); 00148 00149 ip->isactive = YES; 00150 rp = ALLOC(Rplblock); 00151 rp->rplnextp = rpllist; 00152 rpllist = rp; 00153 rp->rplnp = ip->varnp; 00154 rp->rplvp = (expptr) (ip->varvp); 00155 rp->rpltag = TCONST; 00156 } 00157 00158 if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) 00159 || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) 00160 { /* start new loop */ 00161 curdtp = ip->datalist; 00162 goto next; 00163 } 00164 00165 /* clean up loop */ 00166 00167 if(rpllist) 00168 { 00169 rp = rpllist; 00170 rpllist = rpllist->rplnextp; 00171 free( (charptr) rp); 00172 } 00173 else 00174 Fatal("rpllist empty"); 00175 00176 frexpr((expptr)ip->varvp); 00177 ip->isactive = NO; 00178 curdtp = curdtp->nextp; 00179 goto next; 00180 } 00181 00182 pp = (struct Primblock *) p; 00183 np = pp->namep; 00184 cur_varname = np->fvarname; 00185 skip = YES; 00186 00187 if(p->primblock.argsp==NULL && np->vdim!=NULL) 00188 { /* array initialization */ 00189 q = (expptr) mkaddr(np); 00190 off = typesize[np->vtype] * curdtelt; 00191 if(np->vtype == TYCHAR) 00192 off *= np->vleng->constblock.Const.ci; 00193 q->addrblock.memoffset = 00194 mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); 00195 if( (neltp = np->vdim->nelt) && ISCONST(neltp)) 00196 { 00197 if(++curdtelt < neltp->constblock.Const.ci) 00198 skip = NO; 00199 } 00200 else 00201 err("attempt to initialize adjustable array"); 00202 } 00203 else 00204 q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0); 00205 if(skip) 00206 { 00207 curdtp = curdtp->nextp; 00208 curdtelt = 0; 00209 } 00210 if(q->headblock.vtype == TYCHAR) 00211 if(ISICON(q->headblock.vleng)) 00212 *elenp = q->headblock.vleng->constblock.Const.ci; 00213 else { 00214 err("initialization of string of nonconstant length"); 00215 continue; 00216 } 00217 else *elenp = typesize[q->headblock.vtype]; 00218 00219 if (np->vstg == STGBSS) { 00220 vlen = np->vtype==TYCHAR 00221 ? np->vleng->constblock.Const.ci 00222 : typesize[np->vtype]; 00223 if(vlen > 0) 00224 np->vstg = STGINIT; 00225 } 00226 return( (Addrp) q ); 00227 00228 doerr: 00229 err("nonconstant implied DO parameter"); 00230 frexpr(q); 00231 curdtp = curdtp->nextp; 00232 00233 next: 00234 curdtelt = 0; 00235 } 00236 00237 return(NULL); 00238 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 251 of file data.c.
References badtype(), blkdfile, blkdfname, Constant::ci, cktype(), CLBLOCK, consconv(), Constblock::Const, Constant::cq, cur_varname, dataline(), dataname(), err, ftn66flag, i, ICON, initfile, initfname, j, lineno, offset, OPASSIGN, opf(), prcona(), prconi(), prconq(), prconr(), procclass, s, STGCOMMON, textwrite, TYADDR, TYBLANK, TYCHAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYERROR, TYINT1, TYLOGICAL, TYLOGICAL1, TYLOGICAL2, TYLONG, type, typesize, TYQUAD, TYREAL, TYSHORT, TYUNKNOWN, UNAM_NAME, Constblock::vleng, and warn1().
Referenced by dataval().
00253 { 00254 struct Constblock con; 00255 register int type; 00256 int j, valtype; 00257 ftnint i, k, offset; 00258 char *varname; 00259 static Addrp badvar; 00260 register unsigned char *s; 00261 static long last_lineno; 00262 static char *last_varname; 00263 00264 if (varp->vstg == STGCOMMON) { 00265 if (!(dfile = blkdfile)) 00266 dfile = blkdfile = opf(blkdfname, textwrite); 00267 } 00268 else { 00269 if (procclass == CLBLOCK) { 00270 if (varp != badvar) { 00271 badvar = varp; 00272 warn1("%s is not in a COMMON block", 00273 varp->uname_tag == UNAM_NAME 00274 ? varp->user.name->fvarname 00275 : "???"); 00276 } 00277 return; 00278 } 00279 if (!(dfile = initfile)) 00280 dfile = initfile = opf(initfname, textwrite); 00281 } 00282 varname = dataname(varp->vstg, varp->memno); 00283 offset = varp->memoffset->constblock.Const.ci; 00284 type = varp->vtype; 00285 valtype = valp->vtype; 00286 if(type!=TYCHAR && valtype==TYCHAR) 00287 { 00288 if(! ftn66flag 00289 && (last_varname != cur_varname || last_lineno != lineno)) { 00290 /* prevent multiple warnings */ 00291 last_lineno = lineno; 00292 warn1( 00293 "non-character datum %.42s initialized with character string", 00294 last_varname = cur_varname); 00295 } 00296 varp->vleng = ICON(typesize[type]); 00297 varp->vtype = type = TYCHAR; 00298 } 00299 else if( (type==TYCHAR && valtype!=TYCHAR) || 00300 (cktype(OPASSIGN,type,valtype) == TYERROR) ) 00301 { 00302 err("incompatible types in initialization"); 00303 return; 00304 } 00305 if(type == TYADDR) 00306 con.Const.ci = valp->Const.ci; 00307 else if(type != TYCHAR) 00308 { 00309 if(valtype == TYUNKNOWN) 00310 con.Const.ci = valp->Const.ci; 00311 else consconv(type, &con, valp); 00312 } 00313 00314 j = 1; 00315 00316 switch(type) 00317 { 00318 case TYLOGICAL: 00319 case TYINT1: 00320 case TYLOGICAL1: 00321 case TYLOGICAL2: 00322 case TYSHORT: 00323 case TYLONG: 00324 #ifdef TYQUAD0 00325 case TYQUAD: 00326 #endif 00327 dataline(varname, offset, type); 00328 prconi(dfile, con.Const.ci); 00329 break; 00330 #ifndef NO_LONG_LONG 00331 case TYQUAD: 00332 dataline(varname, offset, type); 00333 prconq(dfile, con.Const.cq); 00334 break; 00335 #endif 00336 00337 case TYADDR: 00338 dataline(varname, offset, type); 00339 prcona(dfile, con.Const.ci); 00340 break; 00341 00342 case TYCOMPLEX: 00343 case TYDCOMPLEX: 00344 j = 2; 00345 case TYREAL: 00346 case TYDREAL: 00347 dataline(varname, offset, type); 00348 prconr(dfile, &con, j); 00349 break; 00350 00351 case TYCHAR: 00352 k = valp -> vleng -> constblock.Const.ci; 00353 if (elen < k) 00354 k = elen; 00355 s = (unsigned char *)valp->Const.ccp; 00356 for(i = 0 ; i < k ; ++i) { 00357 dataline(varname, offset++, TYCHAR); 00358 fprintf(dfile, "\t%d\n", *s++); 00359 } 00360 k = elen - valp->vleng->constblock.Const.ci; 00361 if(k > 0) { 00362 dataline(varname, offset, TYBLANK); 00363 fprintf(dfile, "\t%d\n", k); 00364 } 00365 break; 00366 00367 default: 00368 badtype("setdata", type); 00369 } 00370 00371 }
Here is the call graph for this function:
Here is the caller graph for this function:
char* cur_varname [static] |
1.5.1
