00001 /****************************************************************
00002 Copyright 1990, 1992, 1993, 1994 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
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 /* Put out a constant integer */
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 /* Put out a constant address */
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 /* make_int_expr -- takes an arbitrary expression, and replaces all
00132    occurrences of arguments with indirection */
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         } /* switch */
00166 
00167     return e;
00168 } /* make_int_expr */
00169 
00170 
00171 
00172 /* prune_left_conv -- used in prolog() to strip type cast away from
00173    left-hand side of parameter adjustments.  This is necessary to avoid
00174    error messages from cktype() */
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 } /* prune_left_conv */
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                         /* no break */
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 /* Compute the base addresses and offsets for the array parameters, and
00441    assign these values to local variables */
00442 
00443         addif = addif0 = nentry > 1;
00444         for(; p ; p = p->nextp)
00445         {
00446             q = (Namep) p->datap;
00447             if(dp = q->vdim)    /* if this param is an array ... */
00448             {
00449                 expptr Q, expr;
00450 
00451                 /* See whether to protect the following with an if. */
00452                 /* This only happens when there are multiple entries. */
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 /* Store the variable length of each dimension (which is fixed upon
00479    runtime procedure entry) into a local variable */
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                     } /* if dp -> dims[i].dimexpr */
00488 
00489 /* size   will equal the size of a single element, or -1 if the type is
00490    variable length character type */
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                 /* Fudge the argument pointers for arrays so subscripts
00500                  * are 0-based. Not done if array bounds are being checked.
00501                  */
00502                 if(dp->basexpr) {
00503 
00504 /* Compute the base offset for this procedure */
00505 
00506                     write_comment();
00507                     out_and_free_statement (outfile, mkexpr (OPASSIGN,
00508                             cpexpr(fixtype(dp->baseoffset)),
00509                             cpexpr(fixtype(dp->basexpr))));
00510                 } /* if dp -> basexpr */
00511 
00512                 if(! checksubs) {
00513                     if(dp->basexpr) {
00514                         expptr tp;
00515 
00516 /* If the base of this array has a variable adjustment ... */
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 /* Avoid type clash by removing the type conversion */
00528                         tp = prune_left_conv (tp);
00529                         out_and_free_statement (outfile, tp);
00530                     } else if(dp->baseoffset->constblock.Const.ci != 0) {
00531 
00532 /* if the base of this array has a nonzero constant adjustment ... */
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                         } /* else */
00551                     } /* if dp -> baseoffset -> const */
00552                 } /* if !checksubs */
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 } /* prolog */