![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vax.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to vax.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1992 by AT&T Bell Laboratories and Bellcore. ! 3: ! 4: Permission to use, copy, modify, and distribute this software ! 5: and its documentation for any purpose and without fee is hereby ! 6: granted, provided that the above copyright notice appear in all ! 7: copies and that both that the copyright notice and this ! 8: permission notice and warranty disclaimer appear in supporting ! 9: documentation, and that the names of AT&T Bell Laboratories or ! 10: Bellcore or any of their entities not be used in advertising or ! 11: publicity pertaining to distribution of the software without ! 12: specific, written prior permission. ! 13: ! 14: AT&T and Bellcore disclaim all warranties with regard to this ! 15: software, including all implied warranties of merchantability ! 16: and fitness. In no event shall AT&T or Bellcore be liable for ! 17: any special, indirect or consequential damages or any damages ! 18: whatsoever resulting from loss of use, data or profits, whether ! 19: in an action of contract, negligence or other tortious action, ! 20: arising out of or in connection with the use or performance of ! 21: this software. ! 22: ****************************************************************/ ! 23: ! 24: #include "defs.h" ! 25: #include "pccdefs.h" ! 26: #include "output.h" ! 27: ! 28: int regnum[] = { ! 29: 11, 10, 9, 8, 7, 6 }; ! 30: ! 31: /* Put out a constant integer */ ! 32: ! 33: prconi(fp, n) ! 34: FILEP fp; ! 35: ftnint n; ! 36: { ! 37: fprintf(fp, "\t%ld\n", n); ! 38: } ! 39: ! 40: ! 41: ! 42: /* Put out a constant address */ ! 43: ! 44: prcona(fp, a) ! 45: FILEP fp; ! 46: ftnint a; ! 47: { ! 48: fprintf(fp, "\tL%ld\n", a); ! 49: } ! 50: ! 51: ! 52: ! 53: prconr(fp, x, k) ! 54: FILEP fp; ! 55: int k; ! 56: Constp x; ! 57: { ! 58: char *x0, *x1; ! 59: char cdsbuf0[64], cdsbuf1[64]; ! 60: ! 61: if (k > 1) { ! 62: if (x->vstg) { ! 63: x0 = x->Const.cds[0]; ! 64: x1 = x->Const.cds[1]; ! 65: } ! 66: else { ! 67: x0 = cds(dtos(x->Const.cd[0]), cdsbuf0); ! 68: x1 = cds(dtos(x->Const.cd[1]), cdsbuf1); ! 69: } ! 70: fprintf(fp, "\t%s %s\n", x0, x1); ! 71: } ! 72: else ! 73: fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0] ! 74: : cds(dtos(x->Const.cd[0]), cdsbuf0)); ! 75: } ! 76: ! 77: ! 78: char *memname(stg, mem) ! 79: int stg; ! 80: long mem; ! 81: { ! 82: static char s[20]; ! 83: ! 84: switch(stg) ! 85: { ! 86: case STGCOMMON: ! 87: case STGEXT: ! 88: sprintf(s, "_%s", extsymtab[mem].cextname); ! 89: break; ! 90: ! 91: case STGBSS: ! 92: case STGINIT: ! 93: sprintf(s, "v.%ld", mem); ! 94: break; ! 95: ! 96: case STGCONST: ! 97: sprintf(s, "L%ld", mem); ! 98: break; ! 99: ! 100: case STGEQUIV: ! 101: sprintf(s, "q.%ld", mem+eqvstart); ! 102: break; ! 103: ! 104: default: ! 105: badstg("memname", stg); ! 106: } ! 107: return(s); ! 108: } ! 109: ! 110: /* make_int_expr -- takes an arbitrary expression, and replaces all ! 111: occurrences of arguments with indirection */ ! 112: ! 113: expptr make_int_expr (e) ! 114: expptr e; ! 115: { ! 116: if (e != ENULL) ! 117: switch (e -> tag) { ! 118: case TADDR: ! 119: if (e -> addrblock.vstg == STGARG ! 120: && !e->addrblock.isarray) ! 121: e = mkexpr (OPWHATSIN, e, ENULL); ! 122: break; ! 123: case TEXPR: ! 124: e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp); ! 125: e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp); ! 126: break; ! 127: default: ! 128: break; ! 129: } /* switch */ ! 130: ! 131: return e; ! 132: } /* make_int_expr */ ! 133: ! 134: ! 135: ! 136: /* prune_left_conv -- used in prolog() to strip type cast away from ! 137: left-hand side of parameter adjustments. This is necessary to avoid ! 138: error messages from cktype() */ ! 139: ! 140: expptr prune_left_conv (e) ! 141: expptr e; ! 142: { ! 143: struct Exprblock *leftp; ! 144: ! 145: if (e && e -> tag == TEXPR && e -> exprblock.leftp && ! 146: e -> exprblock.leftp -> tag == TEXPR) { ! 147: leftp = &(e -> exprblock.leftp -> exprblock); ! 148: if (leftp -> opcode == OPCONV) { ! 149: e -> exprblock.leftp = leftp -> leftp; ! 150: free ((charptr) leftp); ! 151: } ! 152: } ! 153: ! 154: return e; ! 155: } /* prune_left_conv */ ! 156: ! 157: ! 158: static int wrote_comment; ! 159: static FILE *comment_file; ! 160: ! 161: static void ! 162: write_comment() ! 163: { ! 164: if (!wrote_comment) { ! 165: wrote_comment = 1; ! 166: nice_printf (comment_file, "/* Parameter adjustments */\n"); ! 167: } ! 168: } ! 169: ! 170: static int * ! 171: count_args() ! 172: { ! 173: register int *ac; ! 174: register chainp cp; ! 175: register struct Entrypoint *ep; ! 176: register Namep q; ! 177: ! 178: ac = (int *)ckalloc(nallargs*sizeof(int)); ! 179: ! 180: for(ep = entries; ep; ep = ep->entnextp) ! 181: for(cp = ep->arglist; cp; cp = cp->nextp) ! 182: if (q = (Namep)cp->datap) ! 183: ac[q->argno]++; ! 184: return ac; ! 185: } ! 186: ! 187: prolog(outfile, p) ! 188: FILE *outfile; ! 189: register chainp p; ! 190: { ! 191: int addif, addif0, i, nd, size; ! 192: int *ac; ! 193: register Namep q; ! 194: register struct Dimblock *dp; ! 195: ! 196: if(procclass == CLBLOCK) ! 197: return; ! 198: wrote_comment = 0; ! 199: comment_file = outfile; ! 200: ac = 0; ! 201: ! 202: /* Compute the base addresses and offsets for the array parameters, and ! 203: assign these values to local variables */ ! 204: ! 205: addif = addif0 = nentry > 1; ! 206: for(; p ; p = p->nextp) ! 207: { ! 208: q = (Namep) p->datap; ! 209: if(dp = q->vdim) /* if this param is an array ... */ ! 210: { ! 211: expptr Q, expr; ! 212: ! 213: /* See whether to protect the following with an if. */ ! 214: /* This only happens when there are multiple entries. */ ! 215: ! 216: nd = dp->ndim - 1; ! 217: if (addif0) { ! 218: if (!ac) ! 219: ac = count_args(); ! 220: if (ac[q->argno] == nentry) ! 221: addif = 0; ! 222: else if (dp->basexpr ! 223: || dp->baseoffset->constblock.Const.ci) ! 224: addif = 1; ! 225: else for(addif = i = 0; i <= nd; i++) ! 226: if (dp->dims[i].dimexpr ! 227: && (i < nd || !q->vlastdim)) { ! 228: addif = 1; ! 229: break; ! 230: } ! 231: if (addif) { ! 232: write_comment(); ! 233: nice_printf(outfile, "if (%s) {\n", /*}*/ ! 234: q->cvarname); ! 235: next_tab(outfile); ! 236: } ! 237: } ! 238: for(i = 0 ; i <= nd; ++i) ! 239: ! 240: /* Store the variable length of each dimension (which is fixed upon ! 241: runtime procedure entry) into a local variable */ ! 242: ! 243: if ((Q = dp->dims[i].dimexpr) ! 244: && (i < nd || !q->vlastdim)) { ! 245: expr = (expptr)cpexpr(Q); ! 246: write_comment(); ! 247: out_and_free_statement (outfile, mkexpr (OPASSIGN, ! 248: fixtype(cpexpr(dp->dims[i].dimsize)), expr)); ! 249: } /* if dp -> dims[i].dimexpr */ ! 250: ! 251: /* size will equal the size of a single element, or -1 if the type is ! 252: variable length character type */ ! 253: ! 254: size = typesize[ q->vtype ]; ! 255: if(q->vtype == TYCHAR) ! 256: if( ISICON(q->vleng) ) ! 257: size *= q->vleng->constblock.Const.ci; ! 258: else ! 259: size = -1; ! 260: ! 261: /* Fudge the argument pointers for arrays so subscripts ! 262: * are 0-based. Not done if array bounds are being checked. ! 263: */ ! 264: if(dp->basexpr) { ! 265: ! 266: /* Compute the base offset for this procedure */ ! 267: ! 268: write_comment(); ! 269: out_and_free_statement (outfile, mkexpr (OPASSIGN, ! 270: cpexpr(fixtype(dp->baseoffset)), ! 271: cpexpr(fixtype(dp->basexpr)))); ! 272: } /* if dp -> basexpr */ ! 273: ! 274: if(! checksubs) { ! 275: if(dp->basexpr) { ! 276: expptr tp; ! 277: ! 278: /* If the base of this array has a variable adjustment ... */ ! 279: ! 280: tp = (expptr) cpexpr (dp -> baseoffset); ! 281: if(size < 0 || q -> vtype == TYCHAR) ! 282: tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng)); ! 283: ! 284: write_comment(); ! 285: tp = mkexpr (OPMINUSEQ, ! 286: mkconv (TYADDR, (expptr)p->datap), ! 287: mkconv(TYINT, fixtype ! 288: (fixtype (tp)))); ! 289: /* Avoid type clash by removing the type conversion */ ! 290: tp = prune_left_conv (tp); ! 291: out_and_free_statement (outfile, tp); ! 292: } else if(dp->baseoffset->constblock.Const.ci != 0) { ! 293: ! 294: /* if the base of this array has a nonzero constant adjustment ... */ ! 295: ! 296: expptr tp; ! 297: ! 298: write_comment(); ! 299: if(size > 0 && q -> vtype != TYCHAR) { ! 300: tp = prune_left_conv (mkexpr (OPMINUSEQ, ! 301: mkconv (TYADDR, (expptr)p->datap), ! 302: mkconv (TYINT, fixtype ! 303: (cpexpr (dp->baseoffset))))); ! 304: out_and_free_statement (outfile, tp); ! 305: } else { ! 306: tp = prune_left_conv (mkexpr (OPMINUSEQ, ! 307: mkconv (TYADDR, (expptr)p->datap), ! 308: mkconv (TYINT, fixtype ! 309: (mkexpr (OPSTAR, cpexpr (dp -> baseoffset), ! 310: cpexpr (q -> vleng)))))); ! 311: out_and_free_statement (outfile, tp); ! 312: } /* else */ ! 313: } /* if dp -> baseoffset -> const */ ! 314: } /* if !checksubs */ ! 315: ! 316: if (addif) { ! 317: nice_printf(outfile, /*{*/ "}\n"); ! 318: prev_tab(outfile); ! 319: } ! 320: } ! 321: } ! 322: if (wrote_comment) ! 323: nice_printf (outfile, "\n/* Function Body */\n"); ! 324: if (ac) ! 325: free((char *)ac); ! 326: } /* prolog */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.