![[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.