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 #include "pccdefs.h"
00026 #include "output.h"
00027
00028 int regnum[] = {
00029 11, 10, 9, 8, 7, 6 };
00030
00031
00032
00033 void
00034 #ifdef KR_headers
00035 prconi(fp, n)
00036 FILEP fp;
00037 ftnint n;
00038 #else
00039 prconi(FILEP fp, ftnint n)
00040 #endif
00041 {
00042 fprintf(fp, "\t%ld\n", n);
00043 }
00044
00045
00046
00047
00048
00049 void
00050 #ifdef KR_headers
00051 prcona(fp, a)
00052 FILEP fp;
00053 ftnint a;
00054 #else
00055 prcona(FILEP fp, ftnint a)
00056 #endif
00057 {
00058 fprintf(fp, "\tL%ld\n", a);
00059 }
00060
00061
00062 void
00063 #ifdef KR_headers
00064 prconr(fp, x, k)
00065 FILEP fp;
00066 Constp x;
00067 int k;
00068 #else
00069 prconr(FILEP fp, Constp x, int k)
00070 #endif
00071 {
00072 char *x0, *x1;
00073 char cdsbuf0[64], cdsbuf1[64];
00074
00075 if (k > 1) {
00076 if (x->vstg) {
00077 x0 = x->Const.cds[0];
00078 x1 = x->Const.cds[1];
00079 }
00080 else {
00081 x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
00082 x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
00083 }
00084 fprintf(fp, "\t%s %s\n", x0, x1);
00085 }
00086 else
00087 fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
00088 : cds(dtos(x->Const.cd[0]), cdsbuf0));
00089 }
00090
00091
00092 char *
00093 #ifdef KR_headers
00094 memname(stg, mem)
00095 int stg;
00096 long mem;
00097 #else
00098 memname(int stg, long mem)
00099 #endif
00100 {
00101 static char s[20];
00102
00103 switch(stg)
00104 {
00105 case STGCOMMON:
00106 case STGEXT:
00107 sprintf(s, "_%s", extsymtab[mem].cextname);
00108 break;
00109
00110 case STGBSS:
00111 case STGINIT:
00112 sprintf(s, "v.%ld", mem);
00113 break;
00114
00115 case STGCONST:
00116 sprintf(s, "L%ld", mem);
00117 break;
00118
00119 case STGEQUIV:
00120 sprintf(s, "q.%ld", mem+eqvstart);
00121 break;
00122
00123 default:
00124 badstg("memname", stg);
00125 }
00126 return(s);
00127 }
00128
00129 extern void addrlit Argdcl((Addrp));
00130
00131
00132
00133
00134 expptr
00135 #ifdef KR_headers
00136 make_int_expr(e)
00137 expptr e;
00138 #else
00139 make_int_expr(expptr e)
00140 #endif
00141 {
00142 chainp listp;
00143 Addrp ap;
00144
00145 if (e != ENULL)
00146 switch (e -> tag) {
00147 case TADDR:
00148 if (e -> addrblock.vstg == STGARG
00149 && !e->addrblock.isarray)
00150 e = mkexpr (OPWHATSIN, e, ENULL);
00151 break;
00152 case TEXPR:
00153 e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
00154 e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
00155 break;
00156 case TLIST:
00157 for(listp = e->listblock.listp; listp; listp = listp->nextp)
00158 if ((ap = (Addrp)listp->datap)
00159 && ap->tag == TADDR
00160 && ap->uname_tag == UNAM_CONST)
00161 addrlit(ap);
00162 break;
00163 default:
00164 break;
00165 }
00166
00167 return e;
00168 }
00169
00170
00171
00172
00173
00174
00175
00176 expptr
00177 #ifdef KR_headers
00178 prune_left_conv(e)
00179 expptr e;
00180 #else
00181 prune_left_conv(expptr e)
00182 #endif
00183 {
00184 struct Exprblock *leftp;
00185
00186 if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
00187 e -> exprblock.leftp -> tag == TEXPR) {
00188 leftp = &(e -> exprblock.leftp -> exprblock);
00189 if (leftp -> opcode == OPCONV) {
00190 e -> exprblock.leftp = leftp -> leftp;
00191 free ((charptr) leftp);
00192 }
00193 }
00194
00195 return e;
00196 }
00197
00198
00199 static int wrote_comment;
00200 static FILE *comment_file;
00201
00202 static void
00203 write_comment(Void)
00204 {
00205 if (!wrote_comment) {
00206 wrote_comment = 1;
00207 nice_printf (comment_file, "/* Parameter adjustments */\n");
00208 }
00209 }
00210
00211 static int *
00212 count_args(Void)
00213 {
00214 register int *ac;
00215 register chainp cp;
00216 register struct Entrypoint *ep;
00217 register Namep q;
00218
00219 ac = (int *)ckalloc(nallargs*sizeof(int));
00220
00221 for(ep = entries; ep; ep = ep->entnextp)
00222 for(cp = ep->arglist; cp; cp = cp->nextp)
00223 if (q = (Namep)cp->datap)
00224 ac[q->argno]++;
00225 return ac;
00226 }
00227
00228 static int nu, *refs, *used;
00229 static void awalk Argdcl((expptr));
00230
00231 static void
00232 #ifdef KR_headers
00233 aawalk(P)
00234 struct Primblock *P;
00235 #else
00236 aawalk(struct Primblock *P)
00237 #endif
00238 {
00239 chainp p;
00240 expptr q;
00241
00242 if (P->argsp)
00243 for(p = P->argsp->listp; p; p = p->nextp) {
00244 q = (expptr)p->datap;
00245 if (q->tag != TCONST)
00246 awalk(q);
00247 }
00248 if (P->namep->vtype == TYCHAR) {
00249 if (q = P->fcharp)
00250 awalk(q);
00251 if (q = P->lcharp)
00252 awalk(q);
00253 }
00254 }
00255
00256 static void
00257 #ifdef KR_headers
00258 afwalk(P)
00259 struct Primblock *P;
00260 #else
00261 afwalk(struct Primblock *P)
00262 #endif
00263 {
00264 chainp p;
00265 expptr q;
00266 Namep np;
00267
00268 for(p = P->argsp->listp; p; p = p->nextp) {
00269 q = (expptr)p->datap;
00270 switch(q->tag) {
00271 case TPRIM:
00272 np = q->primblock.namep;
00273 if (np->vknownarg)
00274 if (!refs[np->argno]++)
00275 used[nu++] = np->argno;
00276 if (q->primblock.argsp == 0) {
00277 if (q->primblock.namep->vclass == CLPROC
00278 && q->primblock.namep->vprocclass
00279 != PTHISPROC
00280 || q->primblock.namep->vdim != NULL)
00281 continue;
00282 }
00283 default:
00284 awalk(q);
00285
00286 case TCONST:
00287 continue;
00288 }
00289 }
00290 }
00291
00292 static void
00293 #ifdef KR_headers
00294 awalk(e)
00295 expptr e;
00296 #else
00297 awalk(expptr e)
00298 #endif
00299 {
00300 Namep np;
00301 top:
00302 if (!e)
00303 return;
00304 switch(e->tag) {
00305 default:
00306 badtag("awalk", e->tag);
00307 case TCONST:
00308 case TERROR:
00309 case TLIST:
00310 return;
00311 case TADDR:
00312 if (e->addrblock.uname_tag == UNAM_NAME) {
00313 np = e->addrblock.user.name;
00314 if (np->vknownarg && !refs[np->argno]++)
00315 used[nu++] = np->argno;
00316 }
00317 e = e->addrblock.memoffset;
00318 goto top;
00319 case TPRIM:
00320 np = e->primblock.namep;
00321 if (np->vknownarg && !refs[np->argno]++)
00322 used[nu++] = np->argno;
00323 if (e->primblock.argsp && np->vclass != CLVAR)
00324 afwalk((struct Primblock *)e);
00325 else
00326 aawalk((struct Primblock *)e);
00327 return;
00328 case TEXPR:
00329 awalk(e->exprblock.rightp);
00330 e = e->exprblock.leftp;
00331 goto top;
00332 }
00333 }
00334
00335 static chainp
00336 #ifdef KR_headers
00337 argsort(p0)
00338 chainp p0;
00339 #else
00340 argsort(chainp p0)
00341 #endif
00342 {
00343 Namep *args, q, *stack;
00344 int i, nargs, nout, nst;
00345 chainp *d, *da, p, rv, *rvp;
00346 struct Dimblock *dp;
00347
00348 if (!p0)
00349 return p0;
00350 for(nargs = 0, p = p0; p; p = p->nextp)
00351 nargs++;
00352 args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
00353 + 2*sizeof(int)));
00354 memset((char *)args, 0, i);
00355 stack = args + nargs;
00356 d = (chainp *)(stack + nargs);
00357 refs = (int *)(d + nargs);
00358 used = refs + nargs;
00359
00360 for(p = p0; p; p = p->nextp) {
00361 q = (Namep) p->datap;
00362 args[q->argno] = q;
00363 }
00364 for(p = p0; p; p = p->nextp) {
00365 q = (Namep) p->datap;
00366 if (!(dp = q->vdim))
00367 continue;
00368 i = dp->ndim;
00369 while(--i >= 0)
00370 awalk(dp->dims[i].dimexpr);
00371 awalk(dp->basexpr);
00372 while(nu > 0) {
00373 refs[i = used[--nu]] = 0;
00374 d[i] = mkchain((char *)q, d[i]);
00375 }
00376 }
00377 for(i = nst = 0; i < nargs; i++)
00378 for(p = d[i]; p; p = p->nextp)
00379 refs[((Namep)p->datap)->argno]++;
00380 while(--i >= 0)
00381 if (!refs[i])
00382 stack[nst++] = args[i];
00383 if (nst == nargs) {
00384 rv = p0;
00385 goto done;
00386 }
00387 nout = 0;
00388 rv = 0;
00389 rvp = &rv;
00390 while(nst > 0) {
00391 nout++;
00392 q = stack[--nst];
00393 *rvp = p = mkchain((char *)q, CHNULL);
00394 rvp = &p->nextp;
00395 da = d + q->argno;
00396 for(p = *da; p; p = p->nextp)
00397 if (!--refs[(q = (Namep)p->datap)->argno])
00398 stack[nst++] = q;
00399 frchain(da);
00400 }
00401 if (nout < nargs)
00402 for(i = 0; i < nargs; i++)
00403 if (refs[i]) {
00404 q = args[i];
00405 errstr("Can't adjust %.38s correctly\n\
00406 due to dependencies among arguments.",
00407 q->fvarname);
00408 *rvp = p = mkchain((char *)q, CHNULL);
00409 rvp = &p->nextp;
00410 frchain(d+i);
00411 }
00412 done:
00413 free((char *)args);
00414 return rv;
00415 }
00416
00417 void
00418 #ifdef KR_headers
00419 prolog(outfile, p)
00420 FILE *outfile;
00421 register chainp p;
00422 #else
00423 prolog(FILE *outfile, register chainp p)
00424 #endif
00425 {
00426 int addif, addif0, i, nd, size;
00427 int *ac;
00428 register Namep q;
00429 register struct Dimblock *dp;
00430 chainp p0, p1;
00431
00432 if(procclass == CLBLOCK)
00433 return;
00434 p0 = p;
00435 p1 = p = argsort(p);
00436 wrote_comment = 0;
00437 comment_file = outfile;
00438 ac = 0;
00439
00440
00441
00442
00443 addif = addif0 = nentry > 1;
00444 for(; p ; p = p->nextp)
00445 {
00446 q = (Namep) p->datap;
00447 if(dp = q->vdim)
00448 {
00449 expptr Q, expr;
00450
00451
00452
00453
00454 nd = dp->ndim - 1;
00455 if (addif0) {
00456 if (!ac)
00457 ac = count_args();
00458 if (ac[q->argno] == nentry)
00459 addif = 0;
00460 else if (dp->basexpr
00461 || dp->baseoffset->constblock.Const.ci)
00462 addif = 1;
00463 else for(addif = i = 0; i <= nd; i++)
00464 if (dp->dims[i].dimexpr
00465 && (i < nd || !q->vlastdim)) {
00466 addif = 1;
00467 break;
00468 }
00469 if (addif) {
00470 write_comment();
00471 nice_printf(outfile, "if (%s) {\n",
00472 q->cvarname);
00473 next_tab(outfile);
00474 }
00475 }
00476 for(i = 0 ; i <= nd; ++i)
00477
00478
00479
00480
00481 if ((Q = dp->dims[i].dimexpr)
00482 && (i < nd || !q->vlastdim)) {
00483 expr = (expptr)cpexpr(Q);
00484 write_comment();
00485 out_and_free_statement (outfile, mkexpr (OPASSIGN,
00486 fixtype(cpexpr(dp->dims[i].dimsize)), expr));
00487 }
00488
00489
00490
00491
00492 size = typesize[ q->vtype ];
00493 if(q->vtype == TYCHAR)
00494 if( ISICON(q->vleng) )
00495 size *= q->vleng->constblock.Const.ci;
00496 else
00497 size = -1;
00498
00499
00500
00501
00502 if(dp->basexpr) {
00503
00504
00505
00506 write_comment();
00507 out_and_free_statement (outfile, mkexpr (OPASSIGN,
00508 cpexpr(fixtype(dp->baseoffset)),
00509 cpexpr(fixtype(dp->basexpr))));
00510 }
00511
00512 if(! checksubs) {
00513 if(dp->basexpr) {
00514 expptr tp;
00515
00516
00517
00518 tp = (expptr) cpexpr (dp -> baseoffset);
00519 if(size < 0 || q -> vtype == TYCHAR)
00520 tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
00521
00522 write_comment();
00523 tp = mkexpr (OPMINUSEQ,
00524 mkconv (TYADDR, (expptr)p->datap),
00525 mkconv(TYINT, fixtype
00526 (fixtype (tp))));
00527
00528 tp = prune_left_conv (tp);
00529 out_and_free_statement (outfile, tp);
00530 } else if(dp->baseoffset->constblock.Const.ci != 0) {
00531
00532
00533
00534 expptr tp;
00535
00536 write_comment();
00537 if(size > 0 && q -> vtype != TYCHAR) {
00538 tp = prune_left_conv (mkexpr (OPMINUSEQ,
00539 mkconv (TYADDR, (expptr)p->datap),
00540 mkconv (TYINT, fixtype
00541 (cpexpr (dp->baseoffset)))));
00542 out_and_free_statement (outfile, tp);
00543 } else {
00544 tp = prune_left_conv (mkexpr (OPMINUSEQ,
00545 mkconv (TYADDR, (expptr)p->datap),
00546 mkconv (TYINT, fixtype
00547 (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
00548 cpexpr (q -> vleng))))));
00549 out_and_free_statement (outfile, tp);
00550 }
00551 }
00552 }
00553
00554 if (addif) {
00555 nice_printf(outfile, "}\n");
00556 prev_tab(outfile);
00557 }
00558 }
00559 }
00560 if (wrote_comment)
00561 nice_printf (outfile, "\n/* Function Body */\n");
00562 if (ac)
00563 free((char *)ac);
00564 if (p0 != p1)
00565 frchain(&p1);
00566 }