1 /****************************************************************
2 Copyright 1990, 1992, 1993, 1994 by AT&T, Lucent Technologies 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,
10 Lucent or Bellcore or any of their entities not be used in
11 advertising or publicity pertaining to distribution of the
12 software without specific, written prior permission.
13
14 AT&T, Lucent and Bellcore disclaim all warranties with regard to
15 this software, including all implied warranties of
16 merchantability and fitness. In no event shall AT&T, Lucent or
17 Bellcore be liable for any special, indirect or consequential
18 damages or any damages whatsoever resulting from loss of use,
19 data or profits, whether in an action of contract, negligence or
20 other tortious action, arising out of or in connection with the
21 use or performance of 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 void
34 #ifdef KR_headers
prconi(fp,n)35 prconi(fp, n)
36 FILEP fp;
37 ftnint n;
38 #else
39 prconi(FILEP fp, ftnint n)
40 #endif
41 {
42 fprintf(fp, "\t%ld\n", n);
43 }
44
45
46
47 /* Put out a constant address */
48
49 void
50 #ifdef KR_headers
prcona(fp,a)51 prcona(fp, a)
52 FILEP fp;
53 ftnint a;
54 #else
55 prcona(FILEP fp, ftnint a)
56 #endif
57 {
58 fprintf(fp, "\tL%ld\n", a);
59 }
60
61
62 void
63 #ifdef KR_headers
prconr(fp,x,k)64 prconr(fp, x, k)
65 FILEP fp;
66 Constp x;
67 int k;
68 #else
69 prconr(FILEP fp, Constp x, int k)
70 #endif
71 {
72 char *x0, *x1;
73 char cdsbuf0[64], cdsbuf1[64];
74
75 if (k > 1) {
76 if (x->vstg) {
77 x0 = x->Const.cds[0];
78 x1 = x->Const.cds[1];
79 }
80 else {
81 x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
82 x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
83 }
84 fprintf(fp, "\t%s %s\n", x0, x1);
85 }
86 else
87 fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
88 : cds(dtos(x->Const.cd[0]), cdsbuf0));
89 }
90
91
92 char *
93 #ifdef KR_headers
memname(stg,mem)94 memname(stg, mem)
95 int stg;
96 long mem;
97 #else
98 memname(int stg, long mem)
99 #endif
100 {
101 static char s[20];
102
103 switch(stg)
104 {
105 case STGCOMMON:
106 case STGEXT:
107 sprintf(s, "_%s", extsymtab[mem].cextname);
108 break;
109
110 case STGBSS:
111 case STGINIT:
112 sprintf(s, "v.%ld", mem);
113 break;
114
115 case STGCONST:
116 sprintf(s, "L%ld", mem);
117 break;
118
119 case STGEQUIV:
120 sprintf(s, "q.%ld", mem+eqvstart);
121 break;
122
123 default:
124 badstg("memname", stg);
125 }
126 return(s);
127 }
128
129 extern void addrlit Argdcl((Addrp));
130
131 /* make_int_expr -- takes an arbitrary expression, and replaces all
132 occurrences of arguments with indirection */
133
134 expptr
135 #ifdef KR_headers
make_int_expr(e)136 make_int_expr(e)
137 expptr e;
138 #else
139 make_int_expr(expptr e)
140 #endif
141 {
142 chainp listp;
143 Addrp ap;
144
145 if (e != ENULL)
146 switch (e -> tag) {
147 case TADDR:
148 if (e -> addrblock.vstg == STGARG
149 && !e->addrblock.isarray)
150 e = mkexpr (OPWHATSIN, e, ENULL);
151 break;
152 case TEXPR:
153 e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
154 e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
155 break;
156 case TLIST:
157 for(listp = e->listblock.listp; listp; listp = listp->nextp)
158 if ((ap = (Addrp)listp->datap)
159 && ap->tag == TADDR
160 && ap->uname_tag == UNAM_CONST)
161 addrlit(ap);
162 break;
163 default:
164 break;
165 } /* switch */
166
167 return e;
168 } /* make_int_expr */
169
170
171
172 /* prune_left_conv -- used in prolog() to strip type cast away from
173 left-hand side of parameter adjustments. This is necessary to avoid
174 error messages from cktype() */
175
176 expptr
177 #ifdef KR_headers
prune_left_conv(e)178 prune_left_conv(e)
179 expptr e;
180 #else
181 prune_left_conv(expptr e)
182 #endif
183 {
184 struct Exprblock *leftp;
185
186 if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
187 e -> exprblock.leftp -> tag == TEXPR) {
188 leftp = &(e -> exprblock.leftp -> exprblock);
189 if (leftp -> opcode == OPCONV) {
190 e -> exprblock.leftp = leftp -> leftp;
191 free ((charptr) leftp);
192 }
193 }
194
195 return e;
196 } /* prune_left_conv */
197
198
199 static int wrote_comment;
200 static FILE *comment_file;
201
202 static void
write_comment(Void)203 write_comment(Void)
204 {
205 if (!wrote_comment) {
206 wrote_comment = 1;
207 nice_printf (comment_file, "/* Parameter adjustments */\n");
208 }
209 }
210
211 static int *
count_args(Void)212 count_args(Void)
213 {
214 register int *ac;
215 register chainp cp;
216 register struct Entrypoint *ep;
217 register Namep q;
218
219 ac = (int *)ckalloc(nallargs*sizeof(int));
220
221 for(ep = entries; ep; ep = ep->entnextp)
222 for(cp = ep->arglist; cp; cp = cp->nextp)
223 if (q = (Namep)cp->datap)
224 ac[q->argno]++;
225 return ac;
226 }
227
228 static int nu, *refs, *used;
229 static void awalk Argdcl((expptr));
230
231 static void
232 #ifdef KR_headers
aawalk(P)233 aawalk(P)
234 struct Primblock *P;
235 #else
236 aawalk(struct Primblock *P)
237 #endif
238 {
239 chainp p;
240 expptr q;
241
242 if (P->argsp)
243 for(p = P->argsp->listp; p; p = p->nextp) {
244 q = (expptr)p->datap;
245 if (q->tag != TCONST)
246 awalk(q);
247 }
248 if (P->namep->vtype == TYCHAR) {
249 if (q = P->fcharp)
250 awalk(q);
251 if (q = P->lcharp)
252 awalk(q);
253 }
254 }
255
256 static void
257 #ifdef KR_headers
afwalk(P)258 afwalk(P)
259 struct Primblock *P;
260 #else
261 afwalk(struct Primblock *P)
262 #endif
263 {
264 chainp p;
265 expptr q;
266 Namep np;
267
268 for(p = P->argsp->listp; p; p = p->nextp) {
269 q = (expptr)p->datap;
270 switch(q->tag) {
271 case TPRIM:
272 np = q->primblock.namep;
273 if (np->vknownarg)
274 if (!refs[np->argno]++)
275 used[nu++] = np->argno;
276 if (q->primblock.argsp == 0) {
277 if (q->primblock.namep->vclass == CLPROC
278 && q->primblock.namep->vprocclass
279 != PTHISPROC
280 || q->primblock.namep->vdim != NULL)
281 continue;
282 }
283 default:
284 awalk(q);
285 /* no break */
286 case TCONST:
287 continue;
288 }
289 }
290 }
291
292 static void
293 #ifdef KR_headers
awalk(e)294 awalk(e)
295 expptr e;
296 #else
297 awalk(expptr e)
298 #endif
299 {
300 Namep np;
301 top:
302 if (!e)
303 return;
304 switch(e->tag) {
305 default:
306 badtag("awalk", e->tag);
307 case TCONST:
308 case TERROR:
309 case TLIST:
310 return;
311 case TADDR:
312 if (e->addrblock.uname_tag == UNAM_NAME) {
313 np = e->addrblock.user.name;
314 if (np->vknownarg && !refs[np->argno]++)
315 used[nu++] = np->argno;
316 }
317 e = e->addrblock.memoffset;
318 goto top;
319 case TPRIM:
320 np = e->primblock.namep;
321 if (np->vknownarg && !refs[np->argno]++)
322 used[nu++] = np->argno;
323 if (e->primblock.argsp && np->vclass != CLVAR)
324 afwalk((struct Primblock *)e);
325 else
326 aawalk((struct Primblock *)e);
327 return;
328 case TEXPR:
329 awalk(e->exprblock.rightp);
330 e = e->exprblock.leftp;
331 goto top;
332 }
333 }
334
335 static chainp
336 #ifdef KR_headers
argsort(p0)337 argsort(p0)
338 chainp p0;
339 #else
340 argsort(chainp p0)
341 #endif
342 {
343 Namep *args, q, *stack;
344 int i, nargs, nout, nst;
345 chainp *d, *da, p, rv, *rvp;
346 struct Dimblock *dp;
347
348 if (!p0)
349 return p0;
350 for(nargs = 0, p = p0; p; p = p->nextp)
351 nargs++;
352 args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
353 + 2*sizeof(int)));
354 memset((char *)args, 0, i);
355 stack = args + nargs;
356 d = (chainp *)(stack + nargs);
357 refs = (int *)(d + nargs);
358 used = refs + nargs;
359
360 for(p = p0; p; p = p->nextp) {
361 q = (Namep) p->datap;
362 args[q->argno] = q;
363 }
364 for(p = p0; p; p = p->nextp) {
365 q = (Namep) p->datap;
366 if (!(dp = q->vdim))
367 continue;
368 i = dp->ndim;
369 while(--i >= 0)
370 awalk(dp->dims[i].dimexpr);
371 awalk(dp->basexpr);
372 while(nu > 0) {
373 refs[i = used[--nu]] = 0;
374 d[i] = mkchain((char *)q, d[i]);
375 }
376 }
377 for(i = nst = 0; i < nargs; i++)
378 for(p = d[i]; p; p = p->nextp)
379 refs[((Namep)p->datap)->argno]++;
380 while(--i >= 0)
381 if (!refs[i])
382 stack[nst++] = args[i];
383 if (nst == nargs) {
384 rv = p0;
385 goto done;
386 }
387 nout = 0;
388 rv = 0;
389 rvp = &rv;
390 while(nst > 0) {
391 nout++;
392 q = stack[--nst];
393 *rvp = p = mkchain((char *)q, CHNULL);
394 rvp = &p->nextp;
395 da = d + q->argno;
396 for(p = *da; p; p = p->nextp)
397 if (!--refs[(q = (Namep)p->datap)->argno])
398 stack[nst++] = q;
399 frchain(da);
400 }
401 if (nout < nargs)
402 for(i = 0; i < nargs; i++)
403 if (refs[i]) {
404 q = args[i];
405 errstr("Can't adjust %.38s correctly\n\
406 due to dependencies among arguments.",
407 q->fvarname);
408 *rvp = p = mkchain((char *)q, CHNULL);
409 rvp = &p->nextp;
410 frchain(d+i);
411 }
412 done:
413 free((char *)args);
414 return rv;
415 }
416
417 void
418 #ifdef KR_headers
prolog(outfile,p)419 prolog(outfile, p)
420 FILE *outfile;
421 register chainp p;
422 #else
423 prolog(FILE *outfile, register chainp p)
424 #endif
425 {
426 int addif, addif0, i, nd, size;
427 int *ac;
428 register Namep q;
429 register struct Dimblock *dp;
430 chainp p0, p1;
431
432 if(procclass == CLBLOCK)
433 return;
434 p0 = p;
435 p1 = p = argsort(p);
436 wrote_comment = 0;
437 comment_file = outfile;
438 ac = 0;
439
440 /* Compute the base addresses and offsets for the array parameters, and
441 assign these values to local variables */
442
443 addif = addif0 = nentry > 1;
444 for(; p ; p = p->nextp)
445 {
446 q = (Namep) p->datap;
447 if(dp = q->vdim) /* if this param is an array ... */
448 {
449 expptr Q, expr;
450
451 /* See whether to protect the following with an if. */
452 /* This only happens when there are multiple entries. */
453
454 nd = dp->ndim - 1;
455 if (addif0) {
456 if (!ac)
457 ac = count_args();
458 if (ac[q->argno] == nentry)
459 addif = 0;
460 else if (dp->basexpr
461 || dp->baseoffset->constblock.Const.ci)
462 addif = 1;
463 else for(addif = i = 0; i <= nd; i++)
464 if (dp->dims[i].dimexpr
465 && (i < nd || !q->vlastdim)) {
466 addif = 1;
467 break;
468 }
469 if (addif) {
470 write_comment();
471 nice_printf(outfile, "if (%s) {\n", /*}*/
472 q->cvarname);
473 next_tab(outfile);
474 }
475 }
476 for(i = 0 ; i <= nd; ++i)
477
478 /* Store the variable length of each dimension (which is fixed upon
479 runtime procedure entry) into a local variable */
480
481 if ((Q = dp->dims[i].dimexpr)
482 && (i < nd || !q->vlastdim)) {
483 expr = (expptr)cpexpr(Q);
484 write_comment();
485 out_and_free_statement (outfile, mkexpr (OPASSIGN,
486 fixtype(cpexpr(dp->dims[i].dimsize)), expr));
487 } /* if dp -> dims[i].dimexpr */
488
489 /* size will equal the size of a single element, or -1 if the type is
490 variable length character type */
491
492 size = typesize[ q->vtype ];
493 if(q->vtype == TYCHAR)
494 if( ISICON(q->vleng) )
495 size *= q->vleng->constblock.Const.ci;
496 else
497 size = -1;
498
499 /* Fudge the argument pointers for arrays so subscripts
500 * are 0-based. Not done if array bounds are being checked.
501 */
502 if(dp->basexpr) {
503
504 /* Compute the base offset for this procedure */
505
506 write_comment();
507 out_and_free_statement (outfile, mkexpr (OPASSIGN,
508 cpexpr(fixtype(dp->baseoffset)),
509 cpexpr(fixtype(dp->basexpr))));
510 } /* if dp -> basexpr */
511
512 if(! checksubs) {
513 if(dp->basexpr) {
514 expptr tp;
515
516 /* If the base of this array has a variable adjustment ... */
517
518 tp = (expptr) cpexpr (dp -> baseoffset);
519 if(size < 0 || q -> vtype == TYCHAR)
520 tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
521
522 write_comment();
523 tp = mkexpr (OPMINUSEQ,
524 mkconv (TYADDR, (expptr)p->datap),
525 mkconv(TYINT, fixtype
526 (fixtype (tp))));
527 /* Avoid type clash by removing the type conversion */
528 tp = prune_left_conv (tp);
529 out_and_free_statement (outfile, tp);
530 } else if(dp->baseoffset->constblock.Const.ci != 0) {
531
532 /* if the base of this array has a nonzero constant adjustment ... */
533
534 expptr tp;
535
536 write_comment();
537 if(size > 0 && q -> vtype != TYCHAR) {
538 tp = prune_left_conv (mkexpr (OPMINUSEQ,
539 mkconv (TYADDR, (expptr)p->datap),
540 mkconv (TYINT, fixtype
541 (cpexpr (dp->baseoffset)))));
542 out_and_free_statement (outfile, tp);
543 } else {
544 tp = prune_left_conv (mkexpr (OPMINUSEQ,
545 mkconv (TYADDR, (expptr)p->datap),
546 mkconv (TYINT, fixtype
547 (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
548 cpexpr (q -> vleng))))));
549 out_and_free_statement (outfile, tp);
550 } /* else */
551 } /* if dp -> baseoffset -> const */
552 } /* if !checksubs */
553
554 if (addif) {
555 nice_printf(outfile, /*{*/ "}\n");
556 prev_tab(outfile);
557 }
558 }
559 }
560 if (wrote_comment)
561 nice_printf (outfile, "\n/* Function Body */\n");
562 if (ac)
563 free((char *)ac);
564 if (p0 != p1)
565 frchain(&p1);
566 } /* prolog */
567