| [a7de7182] | 1 | /* $Id: data.c,v 1.15 2008/05/11 15:28:03 ragge Exp $ */
|
|---|
| 2 | /*
|
|---|
| 3 | * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
|
|---|
| 4 | *
|
|---|
| 5 | * Redistribution and use in source and binary forms, with or without
|
|---|
| 6 | * modification, are permitted provided that the following conditions
|
|---|
| 7 | * are met:
|
|---|
| 8 | *
|
|---|
| 9 | * Redistributions of source code and documentation must retain the above
|
|---|
| 10 | * copyright notice, this list of conditions and the following disclaimer.
|
|---|
| 11 | * Redistributions in binary form must reproduce the above copyright
|
|---|
| 12 | * notice, this list of conditionsand the following disclaimer in the
|
|---|
| 13 | * documentation and/or other materials provided with the distribution.
|
|---|
| 14 | * All advertising materials mentioning features or use of this software
|
|---|
| 15 | * must display the following acknowledgement:
|
|---|
| 16 | * This product includes software developed or owned by Caldera
|
|---|
| 17 | * International, Inc.
|
|---|
| 18 | * Neither the name of Caldera International, Inc. nor the names of other
|
|---|
| 19 | * contributors may be used to endorse or promote products derived from
|
|---|
| 20 | * this software without specific prior written permission.
|
|---|
| 21 | *
|
|---|
| 22 | * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
|
|---|
| 23 | * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
|
|---|
| 24 | * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|---|
| 25 | * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
|---|
| 26 | * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
|
|---|
| 27 | * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|---|
| 28 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
|---|
| 29 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
|---|
| 30 | * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
|
|---|
| 31 | * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
|
|---|
| 32 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|---|
| 33 | * POSSIBILITY OF SUCH DAMAGE.
|
|---|
| 34 | */
|
|---|
| 35 |
|
|---|
| 36 | #include "defines.h"
|
|---|
| 37 | #include "defs.h"
|
|---|
| 38 |
|
|---|
| 39 | #if 1 /* RAGGE */
|
|---|
| 40 | extern FILE *initfile;
|
|---|
| 41 | #endif
|
|---|
| 42 |
|
|---|
| 43 | /* ROUTINES CALLED DURING DATA STATEMENT PROCESSING */
|
|---|
| 44 | LOCAL void setdata(struct bigblock *, struct bigblock *, ftnint, ftnint);
|
|---|
| 45 |
|
|---|
| 46 | static char datafmt[] = "%s\t%05ld\t%05ld\t%d" ;
|
|---|
| 47 |
|
|---|
| 48 | /* another initializer, called from parser */
|
|---|
| 49 | void
|
|---|
| 50 | dataval(repp, valp)
|
|---|
| 51 | register struct bigblock *repp, *valp;
|
|---|
| 52 | {
|
|---|
| 53 | int i, nrep;
|
|---|
| 54 | ftnint elen, vlen;
|
|---|
| 55 | register struct bigblock *p;
|
|---|
| 56 |
|
|---|
| 57 | if(repp == NULL)
|
|---|
| 58 | nrep = 1;
|
|---|
| 59 | else if (ISICON(repp) && repp->b_const.fconst.ci >= 0)
|
|---|
| 60 | nrep = repp->b_const.fconst.ci;
|
|---|
| 61 | else
|
|---|
| 62 | {
|
|---|
| 63 | err("invalid repetition count in DATA statement");
|
|---|
| 64 | frexpr(repp);
|
|---|
| 65 | goto ret;
|
|---|
| 66 | }
|
|---|
| 67 | frexpr(repp);
|
|---|
| 68 |
|
|---|
| 69 | if( ! ISCONST(valp) )
|
|---|
| 70 | {
|
|---|
| 71 | err("non-constant initializer");
|
|---|
| 72 | goto ret;
|
|---|
| 73 | }
|
|---|
| 74 |
|
|---|
| 75 | if(toomanyinit) goto ret;
|
|---|
| 76 | for(i = 0 ; i < nrep ; ++i)
|
|---|
| 77 | {
|
|---|
| 78 | p = nextdata(&elen, &vlen);
|
|---|
| 79 | if(p == NULL)
|
|---|
| 80 | {
|
|---|
| 81 | err("too many initializers");
|
|---|
| 82 | toomanyinit = YES;
|
|---|
| 83 | goto ret;
|
|---|
| 84 | }
|
|---|
| 85 | setdata(p, valp, elen, vlen);
|
|---|
| 86 | frexpr(p);
|
|---|
| 87 | }
|
|---|
| 88 |
|
|---|
| 89 | ret:
|
|---|
| 90 | frexpr(valp);
|
|---|
| 91 | }
|
|---|
| 92 |
|
|---|
| 93 |
|
|---|
| 94 | struct bigblock *nextdata(elenp, vlenp)
|
|---|
| 95 | ftnint *elenp, *vlenp;
|
|---|
| 96 | {
|
|---|
| 97 | register struct bigblock *ip;
|
|---|
| 98 | struct bigblock *pp;
|
|---|
| 99 | register struct bigblock *np;
|
|---|
| 100 | register chainp rp;
|
|---|
| 101 | bigptr p;
|
|---|
| 102 | bigptr neltp;
|
|---|
| 103 | register bigptr q;
|
|---|
| 104 | int skip;
|
|---|
| 105 | ftnint off;
|
|---|
| 106 |
|
|---|
| 107 | while(curdtp)
|
|---|
| 108 | {
|
|---|
| 109 | p = curdtp->chain.datap;
|
|---|
| 110 | if(p->tag == TIMPLDO)
|
|---|
| 111 | {
|
|---|
| 112 | ip = p;
|
|---|
| 113 | if(ip->b_impldo.implb==NULL || ip->b_impldo.impub==NULL || ip->b_impldo.varnp==NULL)
|
|---|
| 114 | fatal1("bad impldoblock 0%o", ip);
|
|---|
| 115 | if(ip->isactive)
|
|---|
| 116 | ip->b_impldo.varvp->b_const.fconst.ci += ip->b_impldo.impdiff;
|
|---|
| 117 | else
|
|---|
| 118 | {
|
|---|
| 119 | q = fixtype(cpexpr(ip->b_impldo.implb));
|
|---|
| 120 | if( ! ISICON(q) )
|
|---|
| 121 | goto doerr;
|
|---|
| 122 | ip->b_impldo.varvp = q;
|
|---|
| 123 |
|
|---|
| 124 | if(ip->b_impldo.impstep)
|
|---|
| 125 | {
|
|---|
| 126 | q = fixtype(cpexpr(ip->b_impldo.impstep));
|
|---|
| 127 | if( ! ISICON(q) )
|
|---|
| 128 | goto doerr;
|
|---|
| 129 | ip->b_impldo.impdiff = q->b_const.fconst.ci;
|
|---|
| 130 | frexpr(q);
|
|---|
| 131 | }
|
|---|
| 132 | else
|
|---|
| 133 | ip->b_impldo.impdiff = 1;
|
|---|
| 134 |
|
|---|
| 135 | q = fixtype(cpexpr(ip->b_impldo.impub));
|
|---|
| 136 | if(! ISICON(q))
|
|---|
| 137 | goto doerr;
|
|---|
| 138 | ip->b_impldo.implim = q->b_const.fconst.ci;
|
|---|
| 139 | frexpr(q);
|
|---|
| 140 |
|
|---|
| 141 | ip->isactive = YES;
|
|---|
| 142 | rp = ALLOC(rplblock);
|
|---|
| 143 | rp->rplblock.nextp = rpllist;
|
|---|
| 144 | rpllist = rp;
|
|---|
| 145 | rp->rplblock.rplnp = ip->b_impldo.varnp;
|
|---|
| 146 | rp->rplblock.rplvp = ip->b_impldo.varvp;
|
|---|
| 147 | rp->rplblock.rpltag = TCONST;
|
|---|
| 148 | }
|
|---|
| 149 |
|
|---|
| 150 | if( (ip->b_impldo.impdiff>0 &&
|
|---|
| 151 | (ip->b_impldo.varvp->b_const.fconst.ci <= ip->b_impldo.implim))
|
|---|
| 152 | || (ip->b_impldo.impdiff<0 &&
|
|---|
| 153 | (ip->b_impldo.varvp->b_const.fconst.ci >= ip->b_impldo.implim)))
|
|---|
| 154 | { /* start new loop */
|
|---|
| 155 | curdtp = ip->b_impldo.datalist;
|
|---|
| 156 | goto next;
|
|---|
| 157 | }
|
|---|
| 158 |
|
|---|
| 159 | /* clean up loop */
|
|---|
| 160 |
|
|---|
| 161 | popstack(&rpllist);
|
|---|
| 162 |
|
|---|
| 163 | frexpr(ip->b_impldo.varvp);
|
|---|
| 164 | ip->isactive = NO;
|
|---|
| 165 | curdtp = curdtp->chain.nextp;
|
|---|
| 166 | goto next;
|
|---|
| 167 | }
|
|---|
| 168 |
|
|---|
| 169 | pp = p;
|
|---|
| 170 | np = pp->b_prim.namep;
|
|---|
| 171 | skip = YES;
|
|---|
| 172 |
|
|---|
| 173 | if(p->b_prim.argsp==NULL && np->b_name.vdim!=NULL)
|
|---|
| 174 | { /* array initialization */
|
|---|
| 175 | q = mkaddr(np);
|
|---|
| 176 | off = typesize[np->vtype] * curdtelt;
|
|---|
| 177 | if(np->vtype == TYCHAR)
|
|---|
| 178 | off *= np->vleng->b_const.fconst.ci;
|
|---|
| 179 | q->b_addr.memoffset = mkexpr(OPPLUS, q->b_addr.memoffset, mkintcon(off) );
|
|---|
| 180 | if( (neltp = np->b_name.vdim->nelt) && ISCONST(neltp))
|
|---|
| 181 | {
|
|---|
| 182 | if(++curdtelt < neltp->b_const.fconst.ci)
|
|---|
| 183 | skip = NO;
|
|---|
| 184 | }
|
|---|
| 185 | else
|
|---|
| 186 | err("attempt to initialize adjustable array");
|
|---|
| 187 | }
|
|---|
| 188 | else
|
|---|
| 189 | q = mklhs( cpexpr(pp) );
|
|---|
| 190 | if(skip)
|
|---|
| 191 | {
|
|---|
| 192 | curdtp = curdtp->chain.nextp;
|
|---|
| 193 | curdtelt = 0;
|
|---|
| 194 | }
|
|---|
| 195 | if(q->vtype == TYCHAR)
|
|---|
| 196 | if(ISICON(q->vleng))
|
|---|
| 197 | *elenp = q->vleng->b_const.fconst.ci;
|
|---|
| 198 | else {
|
|---|
| 199 | err("initialization of string of nonconstant length");
|
|---|
| 200 | continue;
|
|---|
| 201 | }
|
|---|
| 202 | else *elenp = typesize[q->vtype];
|
|---|
| 203 |
|
|---|
| 204 | if(np->vstg == STGCOMMON)
|
|---|
| 205 | *vlenp = extsymtab[np->b_name.vardesc.varno].maxleng;
|
|---|
| 206 | else if(np->vstg == STGEQUIV)
|
|---|
| 207 | *vlenp = eqvclass[np->b_name.vardesc.varno].eqvleng;
|
|---|
| 208 | else {
|
|---|
| 209 | *vlenp = (np->vtype==TYCHAR ?
|
|---|
| 210 | np->vleng->b_const.fconst.ci : typesize[np->vtype]);
|
|---|
| 211 | if(np->b_name.vdim)
|
|---|
| 212 | *vlenp *= np->b_name.vdim->nelt->b_const.fconst.ci;
|
|---|
| 213 | }
|
|---|
| 214 | return(q);
|
|---|
| 215 |
|
|---|
| 216 | doerr:
|
|---|
| 217 | err("nonconstant implied DO parameter");
|
|---|
| 218 | frexpr(q);
|
|---|
| 219 | curdtp = curdtp->chain.nextp;
|
|---|
| 220 |
|
|---|
| 221 | next: curdtelt = 0;
|
|---|
| 222 | }
|
|---|
| 223 |
|
|---|
| 224 | return(NULL);
|
|---|
| 225 | }
|
|---|
| 226 |
|
|---|
| 227 |
|
|---|
| 228 |
|
|---|
| 229 |
|
|---|
| 230 |
|
|---|
| 231 |
|
|---|
| 232 | LOCAL void setdata(varp, valp, elen, vlen)
|
|---|
| 233 | struct bigblock *varp;
|
|---|
| 234 | ftnint elen, vlen;
|
|---|
| 235 | struct bigblock *valp;
|
|---|
| 236 | {
|
|---|
| 237 | union constant con;
|
|---|
| 238 | int i, k;
|
|---|
| 239 | int stg, type, valtype;
|
|---|
| 240 | ftnint offset;
|
|---|
| 241 | register char *s, *t;
|
|---|
| 242 | static char varname[XL+2];
|
|---|
| 243 |
|
|---|
| 244 | /* output form of name is padded with blanks and preceded
|
|---|
| 245 | with a storage class digit
|
|---|
| 246 | */
|
|---|
| 247 |
|
|---|
| 248 | stg = varp->vstg;
|
|---|
| 249 | varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
|
|---|
| 250 | s = memname(stg, varp->b_addr.memno);
|
|---|
| 251 | for(t = varname+1 ; *s ; )
|
|---|
| 252 | *t++ = *s++;
|
|---|
| 253 | while(t < varname+XL+1)
|
|---|
| 254 | *t++ = ' ';
|
|---|
| 255 | varname[XL+1] = '\0';
|
|---|
| 256 |
|
|---|
| 257 | offset = varp->b_addr.memoffset->b_const.fconst.ci;
|
|---|
| 258 | type = varp->vtype;
|
|---|
| 259 | valtype = valp->vtype;
|
|---|
| 260 | if(type!=TYCHAR && valtype==TYCHAR)
|
|---|
| 261 | {
|
|---|
| 262 | if(! ftn66flag)
|
|---|
| 263 | warn("non-character datum initialized with character string");
|
|---|
| 264 | varp->vleng = MKICON(typesize[type]);
|
|---|
| 265 | varp->vtype = type = TYCHAR;
|
|---|
| 266 | }
|
|---|
| 267 | else if( (type==TYCHAR && valtype!=TYCHAR) ||
|
|---|
| 268 | (cktype(OPASSIGN,type,valtype) == TYERROR) )
|
|---|
| 269 | {
|
|---|
| 270 | err("incompatible types in initialization");
|
|---|
| 271 | return;
|
|---|
| 272 | }
|
|---|
| 273 | if(type != TYCHAR) {
|
|---|
| 274 | if(valtype == TYUNKNOWN)
|
|---|
| 275 | con.ci = valp->b_const.fconst.ci;
|
|---|
| 276 | else consconv(type, &con, valtype, &valp->b_const.fconst);
|
|---|
| 277 | }
|
|---|
| 278 |
|
|---|
| 279 | k = 1;
|
|---|
| 280 | switch(type)
|
|---|
| 281 | {
|
|---|
| 282 | case TYLOGICAL:
|
|---|
| 283 | type = tylogical;
|
|---|
| 284 | case TYSHORT:
|
|---|
| 285 | case TYLONG:
|
|---|
| 286 | fprintf(initfile, datafmt, varname, offset, vlen, type);
|
|---|
| 287 | prconi(initfile, type, con.ci);
|
|---|
| 288 | break;
|
|---|
| 289 |
|
|---|
| 290 | case TYCOMPLEX:
|
|---|
| 291 | k = 2;
|
|---|
| 292 | type = TYREAL;
|
|---|
| 293 | case TYREAL:
|
|---|
| 294 | goto flpt;
|
|---|
| 295 |
|
|---|
| 296 | case TYDCOMPLEX:
|
|---|
| 297 | k = 2;
|
|---|
| 298 | type = TYDREAL;
|
|---|
| 299 | case TYDREAL:
|
|---|
| 300 | flpt:
|
|---|
| 301 |
|
|---|
| 302 | for(i = 0 ; i < k ; ++i)
|
|---|
| 303 | {
|
|---|
| 304 | fprintf(initfile, datafmt, varname, offset, vlen, type);
|
|---|
| 305 | prconr(initfile, type, con.cd[i]);
|
|---|
| 306 | offset += typesize[type];
|
|---|
| 307 | }
|
|---|
| 308 | break;
|
|---|
| 309 |
|
|---|
| 310 | case TYCHAR:
|
|---|
| 311 | k = valp->vleng->b_const.fconst.ci;
|
|---|
| 312 | if(elen < k)
|
|---|
| 313 | k = elen;
|
|---|
| 314 |
|
|---|
| 315 | for(i = 0 ; i < k ; ++i)
|
|---|
| 316 | {
|
|---|
| 317 | fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
|
|---|
| 318 | fprintf(initfile, "\t%d\n", valp->b_const.fconst.ccp[i]);
|
|---|
| 319 | }
|
|---|
| 320 | k = elen - valp->vleng->b_const.fconst.ci;
|
|---|
| 321 | while( k-- > 0)
|
|---|
| 322 | {
|
|---|
| 323 | fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
|
|---|
| 324 | fprintf(initfile, "\t%d\n", ' ');
|
|---|
| 325 | }
|
|---|
| 326 | break;
|
|---|
| 327 |
|
|---|
| 328 | default:
|
|---|
| 329 | fatal1("setdata: impossible type %d", type);
|
|---|
| 330 | }
|
|---|
| 331 |
|
|---|
| 332 | }
|
|---|
| 333 |
|
|---|
| 334 |
|
|---|
| 335 | void
|
|---|
| 336 | frdata(p0)
|
|---|
| 337 | chainp p0;
|
|---|
| 338 | {
|
|---|
| 339 | register chainp p;
|
|---|
| 340 | register bigptr q;
|
|---|
| 341 |
|
|---|
| 342 | for(p = p0 ; p ; p = p->chain.nextp)
|
|---|
| 343 | {
|
|---|
| 344 | q = p->chain.datap;
|
|---|
| 345 | if(q->tag == TIMPLDO)
|
|---|
| 346 | {
|
|---|
| 347 | if(q->isbusy)
|
|---|
| 348 | return; /* circular chain completed */
|
|---|
| 349 | q->isbusy = YES;
|
|---|
| 350 | frdata(q->b_impldo.datalist);
|
|---|
| 351 | ckfree(q);
|
|---|
| 352 | }
|
|---|
| 353 | else
|
|---|
| 354 | frexpr(q);
|
|---|
| 355 | }
|
|---|
| 356 |
|
|---|
| 357 | frchain( &p0);
|
|---|
| 358 | }
|
|---|
