1 /****************************************************************
2 Copyright 1990 - 1996 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 /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
25 /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
26
27 #include "defs.h"
28 #include "pccdefs.h"
29 #include "output.h" /* for nice_printf */
30 #include "names.h"
31 #include "p1defs.h"
32
33 static Addrp intdouble Argdcl((Addrp));
34 static Addrp putcx1 Argdcl((tagptr));
35 static tagptr putaddr Argdcl((tagptr));
36 static tagptr putcall Argdcl((tagptr, Addrp*));
37 static tagptr putcat Argdcl((tagptr, tagptr));
38 static Addrp putch1 Argdcl((tagptr));
39 static tagptr putchcmp Argdcl((tagptr));
40 static tagptr putcheq Argdcl((tagptr));
41 static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
42 static tagptr putcxcmp Argdcl((tagptr));
43 static Addrp putcxeq Argdcl((tagptr));
44 static tagptr putmnmx Argdcl((tagptr));
45 static tagptr putop Argdcl((tagptr));
46 static tagptr putpower Argdcl((tagptr));
47
48 extern int init_ac[TYSUBR+1];
49 extern int ops2[];
50 extern int proc_argchanges, proc_protochanges;
51 extern int krparens;
52
53 #define P2BUFFMAX 128
54
55 /* Puthead -- output the header information about subroutines, functions
56 and entry points */
57
58 void
59 #ifdef KR_headers
puthead(s,classKRH)60 puthead(s, classKRH)
61 char *s;
62 int classKRH;
63 #else
64 puthead(char *s, int classKRH)
65 #endif
66 {
67 if (headerdone == NO) {
68 if (classKRH == CLMAIN)
69 s = "MAIN__";
70 p1_head (classKRH, s);
71 headerdone = YES;
72 }
73 }
74
75 void
76 #ifdef KR_headers
putif(p,else_if_p)77 putif(p, else_if_p)
78 register expptr p;
79 int else_if_p;
80 #else
81 putif(register expptr p, int else_if_p)
82 #endif
83 {
84 register int k;
85 int n;
86 long where;
87
88 if (else_if_p) {
89 p1put(P1_ELSEIFSTART);
90 where = ftell(pass1_file);
91 }
92 if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
93 {
94 if(k != TYERROR)
95 err("non-logical expression in IF statement");
96 }
97 else {
98 if (else_if_p) {
99 if (ei_next >= ei_last)
100 {
101 k = ei_last - ei_first;
102 n = k + 100;
103 ei_next = mem(n,0);
104 ei_last = ei_first + n;
105 if (k)
106 memcpy(ei_next, ei_first, k);
107 ei_first = ei_next;
108 ei_next += k;
109 ei_last = ei_first + n;
110 }
111 p = putx(p);
112 if (*ei_next++ = ftell(pass1_file) > where) {
113 p1_if(p);
114 new_endif();
115 }
116 else
117 p1_elif(p);
118 }
119 else {
120 p = putx(p);
121 p1_if(p);
122 }
123 }
124 }
125
126 void
127 #ifdef KR_headers
putout(p)128 putout(p)
129 expptr p;
130 #else
131 putout(expptr p)
132 #endif
133 {
134 p1_expr (p);
135
136 /* Used to make temporaries in holdtemps available here, but they */
137 /* may be reused too soon (e.g. when multiple **'s are involved). */
138 }
139
140
141 void
142 #ifdef KR_headers
putcmgo(index,nlab,labs)143 putcmgo(index, nlab, labs)
144 expptr index;
145 int nlab;
146 struct Labelblock **labs;
147 #else
148 putcmgo(expptr index, int nlab, struct Labelblock **labs)
149 #endif
150 {
151 if(! ISINT(index->headblock.vtype) )
152 {
153 execerr("computed goto index must be integer", CNULL);
154 return;
155 }
156
157 p1comp_goto (index, nlab, labs);
158 }
159
160 static expptr
161 #ifdef KR_headers
krput(p)162 krput(p)
163 register expptr p;
164 #else
165 krput(register expptr p)
166 #endif
167 {
168 register expptr e, e1;
169 register unsigned op;
170 int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
171
172 op = p->exprblock.opcode;
173 e = p->exprblock.leftp;
174 if (e->tag == TEXPR && e->exprblock.opcode == op) {
175 e1 = (expptr)mktmp(t, ENULL);
176 putout(putassign(cpexpr(e1), e));
177 p->exprblock.leftp = e1;
178 }
179 else
180 p->exprblock.leftp = putx(e);
181
182 e = p->exprblock.rightp;
183 if (e->tag == TEXPR && e->exprblock.opcode == op) {
184 e1 = (expptr)mktmp(t, ENULL);
185 putout(putassign(cpexpr(e1), e));
186 p->exprblock.rightp = e1;
187 }
188 else
189 p->exprblock.rightp = putx(e);
190 return p;
191 }
192
193 expptr
194 #ifdef KR_headers
putx(p)195 putx(p)
196 register expptr p;
197 #else
198 putx(register expptr p)
199 #endif
200 {
201 int opc;
202 int k;
203
204 if (p)
205 switch(p->tag)
206 {
207 case TERROR:
208 break;
209
210 case TCONST:
211 switch(p->constblock.vtype)
212 {
213 case TYLOGICAL1:
214 case TYLOGICAL2:
215 case TYLOGICAL:
216 #ifdef TYQUAD
217 case TYQUAD:
218 #endif
219 case TYLONG:
220 case TYSHORT:
221 case TYINT1:
222 break;
223
224 case TYADDR:
225 break;
226 case TYREAL:
227 case TYDREAL:
228
229 /* Don't write it out to the p2 file, since you'd need to call putconst,
230 which is just what we need to avoid in the translator */
231
232 break;
233 default:
234 p = putx( (expptr)putconst((Constp)p) );
235 break;
236 }
237 break;
238
239 case TEXPR:
240 switch(opc = p->exprblock.opcode)
241 {
242 case OPCALL:
243 case OPCCALL:
244 if( ISCOMPLEX(p->exprblock.vtype) )
245 p = putcxop(p);
246 else p = putcall(p, (Addrp *)NULL);
247 break;
248
249 case OPMIN:
250 case OPMAX:
251 p = putmnmx(p);
252 break;
253
254
255 case OPASSIGN:
256 if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
257 || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
258 (void) putcxeq(p);
259 p = ENULL;
260 } else if( ISCHAR(p) )
261 p = putcheq(p);
262 else
263 goto putopp;
264 break;
265
266 case OPEQ:
267 case OPNE:
268 if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
269 ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
270 {
271 p = putcxcmp(p);
272 break;
273 }
274 case OPLT:
275 case OPLE:
276 case OPGT:
277 case OPGE:
278 if(ISCHAR(p->exprblock.leftp))
279 {
280 p = putchcmp(p);
281 break;
282 }
283 goto putopp;
284
285 case OPPOWER:
286 p = putpower(p);
287 break;
288
289 case OPSTAR:
290 /* m * (2**k) -> m<<k */
291 if(INT(p->exprblock.leftp->headblock.vtype) &&
292 ISICON(p->exprblock.rightp) &&
293 ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
294 {
295 p->exprblock.opcode = OPLSHIFT;
296 frexpr(p->exprblock.rightp);
297 p->exprblock.rightp = ICON(k);
298 goto putopp;
299 }
300 if (krparens && ISREAL(p->exprblock.vtype))
301 return krput(p);
302
303 case OPMOD:
304 goto putopp;
305 case OPPLUS:
306 if (krparens && ISREAL(p->exprblock.vtype))
307 return krput(p);
308 case OPMINUS:
309 case OPSLASH:
310 case OPNEG:
311 case OPNEG1:
312 case OPABS:
313 case OPDABS:
314 if( ISCOMPLEX(p->exprblock.vtype) )
315 p = putcxop(p);
316 else goto putopp;
317 break;
318
319 case OPCONV:
320 if( ISCOMPLEX(p->exprblock.vtype) )
321 p = putcxop(p);
322 else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
323 {
324 p = putx( mkconv(p->exprblock.vtype,
325 (expptr)realpart(putcx1(p->exprblock.leftp))));
326 }
327 else goto putopp;
328 break;
329
330 case OPNOT:
331 case OPOR:
332 case OPAND:
333 case OPEQV:
334 case OPNEQV:
335 case OPADDR:
336 case OPPLUSEQ:
337 case OPSTAREQ:
338 case OPCOMMA:
339 case OPQUEST:
340 case OPCOLON:
341 case OPBITOR:
342 case OPBITAND:
343 case OPBITXOR:
344 case OPBITNOT:
345 case OPLSHIFT:
346 case OPRSHIFT:
347 case OPASSIGNI:
348 case OPIDENTITY:
349 case OPCHARCAST:
350 case OPMIN2:
351 case OPMAX2:
352 case OPDMIN:
353 case OPDMAX:
354 case OPBITTEST:
355 case OPBITCLR:
356 case OPBITSET:
357 #ifdef TYQUAD
358 case OPQBITSET:
359 case OPQBITCLR:
360 #endif
361 putopp:
362 p = putop(p);
363 break;
364
365 case OPCONCAT:
366 /* weird things like ichar(a//a) */
367 p = (expptr)putch1(p);
368 break;
369
370 default:
371 badop("putx", opc);
372 p = errnode ();
373 }
374 break;
375
376 case TADDR:
377 p = putaddr(p);
378 break;
379
380 default:
381 badtag("putx", p->tag);
382 p = errnode ();
383 }
384
385 return p;
386 }
387
388
389
390 LOCAL expptr
391 #ifdef KR_headers
putop(p)392 putop(p)
393 expptr p;
394 #else
395 putop(expptr p)
396 #endif
397 {
398 expptr lp, tp;
399 int pt, lt, lt1;
400 int comma;
401 char *hsave;
402
403 switch(p->exprblock.opcode) /* check for special cases and rewrite */
404 {
405 case OPCONV:
406 pt = p->exprblock.vtype;
407 lp = p->exprblock.leftp;
408 lt = lp->headblock.vtype;
409
410 /* Simplify nested type casts */
411
412 while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
413 ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
414 (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
415 {
416 if(pt==TYDREAL && lt==TYREAL)
417 {
418 if(lp->tag==TEXPR
419 && lp->exprblock.opcode == OPCONV) {
420 lt1 = lp->exprblock.leftp->headblock.vtype;
421 if (lt1 == TYDREAL) {
422 lp->exprblock.leftp =
423 putx(lp->exprblock.leftp);
424 return p;
425 }
426 if (lt1 == TYDCOMPLEX) {
427 lp->exprblock.leftp = putx(
428 (expptr)realpart(
429 putcx1(lp->exprblock.leftp)));
430 return p;
431 }
432 }
433 break;
434 }
435 else if (ISREAL(pt) && ISCOMPLEX(lt)) {
436 p->exprblock.leftp = putx(mkconv(pt,
437 (expptr)realpart(
438 putcx1(p->exprblock.leftp))));
439 break;
440 }
441 if(lt==TYCHAR && lp->tag==TEXPR &&
442 lp->exprblock.opcode==OPCALL)
443 {
444
445 /* May want to make a comma expression here instead. I had one, but took
446 it out for my convenience, not for the convenience of the end user */
447
448 putout (putcall (lp, (Addrp *) &(p ->
449 exprblock.leftp)));
450 return putop (p);
451 }
452 if (lt == TYCHAR) {
453 if (ISCONST(p->exprblock.leftp)
454 && ISNUMERIC(p->exprblock.vtype)) {
455 hsave = halign;
456 halign = 0;
457 p->exprblock.leftp = putx((expptr)
458 putconst((Constp)
459 p->exprblock.leftp));
460 halign = hsave;
461 }
462 else
463 p->exprblock.leftp =
464 putx(p->exprblock.leftp);
465 return p;
466 }
467 if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
468 break;
469 frexpr(p->exprblock.vleng);
470 free( (charptr) p );
471 p = lp;
472 if (p->tag != TEXPR)
473 goto retputx;
474 pt = lt;
475 lp = p->exprblock.leftp;
476 lt = lp->headblock.vtype;
477 } /* while */
478 if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
479 break;
480 retputx:
481 return putx(p);
482
483 case OPADDR:
484 comma = NO;
485 lp = p->exprblock.leftp;
486 free( (charptr) p );
487 if(lp->tag != TADDR)
488 {
489 tp = (expptr)
490 mktmp(lp->headblock.vtype,lp->headblock.vleng);
491 p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
492 lp = tp;
493 comma = YES;
494 }
495 if(comma)
496 p = mkexpr(OPCOMMA, p, putaddr(lp));
497 else
498 p = (expptr)putaddr(lp);
499 return p;
500
501 case OPASSIGN:
502 case OPASSIGNI:
503 case OPLT:
504 case OPLE:
505 case OPGT:
506 case OPGE:
507 case OPEQ:
508 case OPNE:
509 ;
510 }
511
512 if( ops2[p->exprblock.opcode] <= 0)
513 badop("putop", p->exprblock.opcode);
514 lp = p->exprblock.leftp = putx(p->exprblock.leftp);
515 if (p -> exprblock.rightp) {
516 tp = p->exprblock.rightp = putx(p->exprblock.rightp);
517 if (ISCONST(tp) && ISCONST(lp))
518 p = fold(p);
519 }
520 return p;
521 }
522
523 LOCAL expptr
524 #ifdef KR_headers
putpower(p)525 putpower(p)
526 expptr p;
527 #else
528 putpower(expptr p)
529 #endif
530 {
531 expptr base;
532 Addrp t1, t2;
533 ftnint k;
534 int type;
535 char buf[80]; /* buffer for text of comment */
536
537 if(!ISICON(p->exprblock.rightp) ||
538 (k = p->exprblock.rightp->constblock.Const.ci)<2)
539 Fatal("putpower: bad call");
540 base = p->exprblock.leftp;
541 type = base->headblock.vtype;
542 t1 = mktmp(type, ENULL);
543 t2 = NULL;
544
545 free ((charptr) p);
546 p = putassign (cpexpr((expptr) t1), base);
547
548 sprintf (buf, "Computing %ld%s power", k,
549 k == 2 ? "nd" : k == 3 ? "rd" : "th");
550 p1_comment (buf);
551
552 for( ; (k&1)==0 && k>2 ; k>>=1 )
553 {
554 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
555 }
556
557 if(k == 2) {
558
559 /* Write the power computation out immediately */
560 putout (p);
561 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
562 } else {
563 t2 = mktmp(type, ENULL);
564 p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
565 cpexpr((expptr)t1)));
566
567 for(k>>=1 ; k>1 ; k>>=1)
568 {
569 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
570 if(k & 1)
571 {
572 p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
573 }
574 }
575 /* Write the power computation out immediately */
576 putout (p);
577 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
578 mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
579 }
580 frexpr((expptr)t1);
581 if(t2)
582 frexpr((expptr)t2);
583 return p;
584 }
585
586
587
588
589 LOCAL Addrp
590 #ifdef KR_headers
intdouble(p)591 intdouble(p)
592 Addrp p;
593 #else
594 intdouble(Addrp p)
595 #endif
596 {
597 register Addrp t;
598
599 t = mktmp(TYDREAL, ENULL);
600 putout (putassign(cpexpr((expptr)t), (expptr)p));
601 return(t);
602 }
603
604
605
606
607
608 /* Complex-type variable assignment */
609
610 LOCAL Addrp
611 #ifdef KR_headers
putcxeq(p)612 putcxeq(p)
613 register expptr p;
614 #else
615 putcxeq(register expptr p)
616 #endif
617 {
618 register Addrp lp, rp;
619 expptr code;
620
621 if(p->tag != TEXPR)
622 badtag("putcxeq", p->tag);
623
624 lp = putcx1(p->exprblock.leftp);
625 rp = putcx1(p->exprblock.rightp);
626 code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
627
628 if( ISCOMPLEX(p->exprblock.vtype) )
629 {
630 code = mkexpr (OPCOMMA, code, putassign
631 (imagpart(lp), imagpart(rp)));
632 }
633 putout (code);
634 frexpr((expptr)rp);
635 free ((charptr) p);
636 return lp;
637 }
638
639
640
641 /* putcxop -- used to write out embedded calls to complex functions, and
642 complex arguments to procedures */
643
644 expptr
645 #ifdef KR_headers
putcxop(p)646 putcxop(p)
647 expptr p;
648 #else
649 putcxop(expptr p)
650 #endif
651 {
652 return (expptr)putaddr((expptr)putcx1(p));
653 }
654
655 #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
656
657 LOCAL Addrp
658 #ifdef KR_headers
putcx1(p)659 putcx1(p)
660 register expptr p;
661 #else
662 putcx1(register expptr p)
663 #endif
664 {
665 expptr q;
666 Addrp lp, rp;
667 register Addrp resp;
668 int opcode;
669 int ltype, rtype;
670 long ts, tskludge;
671
672 if(p == NULL)
673 return(NULL);
674
675 switch(p->tag)
676 {
677 case TCONST:
678 if( ISCOMPLEX(p->constblock.vtype) )
679 p = (expptr) putconst((Constp)p);
680 return( (Addrp) p );
681
682 case TADDR:
683 resp = &p->addrblock;
684 if (addressable(p))
685 return (Addrp) p;
686 ts = tskludge = 0;
687 if (q = resp->memoffset) {
688 if (resp->uname_tag == UNAM_REF) {
689 q = cpexpr((tagptr)resp);
690 q->addrblock.vtype = tyint;
691 q->addrblock.cmplx_sub = 1;
692 p->addrblock.skip_offset = 1;
693 resp->user.name->vsubscrused = 1;
694 resp->uname_tag = UNAM_NAME;
695 tskludge = typesize[resp->vtype]
696 * (resp->Field ? 2 : 1);
697 }
698 else if (resp->isarray
699 && resp->vtype != TYCHAR) {
700 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
701 && resp->uname_tag == UNAM_NAME)
702 q = mkexpr(OPMINUS, q,
703 mkintcon(resp->user.name->voffset));
704 ts = typesize[resp->vtype]
705 * (resp->Field ? 2 : 1);
706 q = resp->memoffset = mkexpr(OPSLASH, q,
707 ICON(ts));
708 }
709 }
710 resp = mktmp(tyint, ENULL);
711 putout(putassign(cpexpr((expptr)resp), q));
712 p->addrblock.memoffset = tskludge
713 ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
714 : (expptr)resp;
715 if (ts) {
716 resp = &p->addrblock;
717 q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
718 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
719 && resp->uname_tag == UNAM_NAME)
720 q = mkexpr(OPPLUS, q,
721 mkintcon(resp->user.name->voffset));
722 resp->memoffset = q;
723 }
724 return (Addrp) p;
725
726 case TEXPR:
727 if( ISCOMPLEX(p->exprblock.vtype) )
728 break;
729 resp = mktmp(p->exprblock.vtype, ENULL);
730 /*first arg of above mktmp call was TYDREAL before 19950102 */
731 putout (putassign( cpexpr((expptr)resp), p));
732 return(resp);
733
734 case TERROR:
735 return NULL;
736
737 default:
738 badtag("putcx1", p->tag);
739 }
740
741 opcode = p->exprblock.opcode;
742 if(opcode==OPCALL || opcode==OPCCALL)
743 {
744 Addrp t;
745 p = putcall(p, &t);
746 putout(p);
747 return t;
748 }
749 else if(opcode == OPASSIGN)
750 {
751 return putcxeq (p);
752 }
753
754 /* BUG (inefficient) Generates too many temporary variables */
755
756 resp = mktmp(p->exprblock.vtype, ENULL);
757 if(lp = putcx1(p->exprblock.leftp) )
758 ltype = lp->vtype;
759 if(rp = putcx1(p->exprblock.rightp) )
760 rtype = rp->vtype;
761
762 switch(opcode)
763 {
764 case OPCOMMA:
765 frexpr((expptr)resp);
766 resp = rp;
767 rp = NULL;
768 break;
769
770 case OPNEG:
771 case OPNEG1:
772 putout (PAIR (
773 putassign( (expptr)realpart(resp),
774 mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
775 putassign( imagpart(resp),
776 mkexpr(OPNEG, imagpart(lp), ENULL))));
777 break;
778
779 case OPPLUS:
780 case OPMINUS: { expptr r;
781 r = putassign( (expptr)realpart(resp),
782 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
783 if(rtype < TYCOMPLEX)
784 q = putassign( imagpart(resp), imagpart(lp) );
785 else if(ltype < TYCOMPLEX)
786 {
787 if(opcode == OPPLUS)
788 q = putassign( imagpart(resp), imagpart(rp) );
789 else
790 q = putassign( imagpart(resp),
791 mkexpr(OPNEG, imagpart(rp), ENULL) );
792 }
793 else
794 q = putassign( imagpart(resp),
795 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
796 r = PAIR (r, q);
797 putout (r);
798 break;
799 } /* case OPPLUS, OPMINUS: */
800 case OPSTAR:
801 if(ltype < TYCOMPLEX)
802 {
803 if( ISINT(ltype) )
804 lp = intdouble(lp);
805 putout (PAIR (
806 putassign( (expptr)realpart(resp),
807 mkexpr(OPSTAR, cpexpr((expptr)lp),
808 (expptr)realpart(rp))),
809 putassign( imagpart(resp),
810 mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
811 }
812 else if(rtype < TYCOMPLEX)
813 {
814 if( ISINT(rtype) )
815 rp = intdouble(rp);
816 putout (PAIR (
817 putassign( (expptr)realpart(resp),
818 mkexpr(OPSTAR, cpexpr((expptr)rp),
819 (expptr)realpart(lp))),
820 putassign( imagpart(resp),
821 mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
822 }
823 else {
824 putout (PAIR (
825 putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
826 mkexpr(OPSTAR, (expptr)realpart(lp),
827 (expptr)realpart(rp)),
828 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
829 putassign( imagpart(resp), mkexpr(OPPLUS,
830 mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
831 mkexpr(OPSTAR, imagpart(lp),
832 (expptr)realpart(rp))))));
833 }
834 break;
835
836 case OPSLASH:
837 /* fixexpr has already replaced all divisions
838 * by a complex by a function call
839 */
840 if( ISINT(rtype) )
841 rp = intdouble(rp);
842 putout (PAIR (
843 putassign( (expptr)realpart(resp),
844 mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
845 putassign( imagpart(resp),
846 mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
847 break;
848
849 case OPCONV:
850 if (!lp)
851 break;
852 if(ISCOMPLEX(lp->vtype) )
853 q = imagpart(lp);
854 else if(rp != NULL)
855 q = (expptr) realpart(rp);
856 else
857 q = mkrealcon(TYDREAL, "0");
858 putout (PAIR (
859 putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
860 putassign( imagpart(resp), q)));
861 break;
862
863 default:
864 badop("putcx1", opcode);
865 }
866
867 frexpr((expptr)lp);
868 frexpr((expptr)rp);
869 free( (charptr) p );
870 return(resp);
871 }
872
873
874
875
876 /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
877 are not defined */
878
879 LOCAL expptr
880 #ifdef KR_headers
putcxcmp(p)881 putcxcmp(p)
882 register expptr p;
883 #else
884 putcxcmp(register expptr p)
885 #endif
886 {
887 int opcode;
888 register Addrp lp, rp;
889 expptr q;
890
891 if(p->tag != TEXPR)
892 badtag("putcxcmp", p->tag);
893
894 opcode = p->exprblock.opcode;
895 lp = putcx1(p->exprblock.leftp);
896 rp = putcx1(p->exprblock.rightp);
897
898 q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
899 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
900 mkexpr(opcode, imagpart(lp), imagpart(rp)) );
901
902 free( (charptr) lp);
903 free( (charptr) rp);
904 free( (charptr) p );
905 if (ISCONST(q))
906 return q;
907 return putx( fixexpr((Exprp)q) );
908 }
909
910 /* putch1 -- Forces constants into the literal pool, among other things */
911
912 LOCAL Addrp
913 #ifdef KR_headers
putch1(p)914 putch1(p)
915 register expptr p;
916 #else
917 putch1(register expptr p)
918 #endif
919 {
920 Addrp t;
921 expptr e;
922
923 switch(p->tag)
924 {
925 case TCONST:
926 return( putconst((Constp)p) );
927
928 case TADDR:
929 return( (Addrp) p );
930
931 case TEXPR:
932 switch(p->exprblock.opcode)
933 {
934 expptr q;
935
936 case OPCALL:
937 case OPCCALL:
938
939 p = putcall(p, &t);
940 putout (p);
941 break;
942
943 case OPCONCAT:
944 t = mktmp(TYCHAR, ICON(lencat(p)));
945 q = (expptr) cpexpr(p->headblock.vleng);
946 p = putcat( cpexpr((expptr)t), p );
947 /* put the correct length on the block */
948 frexpr(t->vleng);
949 t->vleng = q;
950 putout (p);
951 break;
952
953 case OPCONV:
954 if(!ISICON(p->exprblock.vleng)
955 || p->exprblock.vleng->constblock.Const.ci!=1
956 || ! INT(p->exprblock.leftp->headblock.vtype) )
957 Fatal("putch1: bad character conversion");
958 t = mktmp(TYCHAR, ICON(1));
959 e = mkexpr(OPCONV, (expptr)t, ENULL);
960 e->headblock.vtype = TYCHAR;
961 p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
962 putout (p);
963 break;
964 default:
965 badop("putch1", p->exprblock.opcode);
966 }
967 return(t);
968
969 default:
970 badtag("putch1", p->tag);
971 }
972 /* NOT REACHED */ return 0;
973 }
974
975
976 /* putchop -- Write out a character actual parameter; that is, this is
977 part of a procedure invocation */
978
979 Addrp
980 #ifdef KR_headers
putchop(p)981 putchop(p)
982 expptr p;
983 #else
984 putchop(expptr p)
985 #endif
986 {
987 p = putaddr((expptr)putch1(p));
988 return (Addrp)p;
989 }
990
991
992
993
994 LOCAL expptr
995 #ifdef KR_headers
putcheq(p)996 putcheq(p)
997 register expptr p;
998 #else
999 putcheq(register expptr p)
1000 #endif
1001 {
1002 expptr lp, rp;
1003 int nbad;
1004
1005 if(p->tag != TEXPR)
1006 badtag("putcheq", p->tag);
1007
1008 lp = p->exprblock.leftp;
1009 rp = p->exprblock.rightp;
1010 frexpr(p->exprblock.vleng);
1011 free( (charptr) p );
1012
1013 /* If s = t // u, don't bother copying the result, write it directly into
1014 this buffer */
1015
1016 nbad = badchleng(lp) + badchleng(rp);
1017 if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
1018 p = putcat(lp, rp);
1019 else if( !nbad
1020 && ISONE(lp->headblock.vleng)
1021 && ISONE(rp->headblock.vleng) ) {
1022 lp = mkexpr(OPCONV, lp, ENULL);
1023 rp = mkexpr(OPCONV, rp, ENULL);
1024 lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
1025 p = putop(mkexpr(OPASSIGN, lp, rp));
1026 }
1027 else
1028 p = putx( call2(TYSUBR, "s_copy", lp, rp) );
1029 return p;
1030 }
1031
1032
1033
1034
1035 LOCAL expptr
1036 #ifdef KR_headers
putchcmp(p)1037 putchcmp(p)
1038 register expptr p;
1039 #else
1040 putchcmp(register expptr p)
1041 #endif
1042 {
1043 expptr lp, rp;
1044
1045 if(p->tag != TEXPR)
1046 badtag("putchcmp", p->tag);
1047
1048 lp = p->exprblock.leftp;
1049 rp = p->exprblock.rightp;
1050
1051 if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
1052 lp = mkexpr(OPCONV, lp, ENULL);
1053 rp = mkexpr(OPCONV, rp, ENULL);
1054 lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
1055 }
1056 else {
1057 lp = call2(TYINT,"s_cmp", lp, rp);
1058 rp = ICON(0);
1059 }
1060 p->exprblock.leftp = lp;
1061 p->exprblock.rightp = rp;
1062 p = putop(p);
1063 return p;
1064 }
1065
1066
1067
1068
1069
1070 /* putcat -- Writes out a concatenation operation. Two temporary arrays
1071 are allocated, putct1() is called to initialize them, and then a
1072 call to runtime library routine s_cat() is inserted.
1073
1074 This routine generates code which will perform an (nconc lhs rhs)
1075 at runtime. The runtime funciton does not return a value, the routine
1076 that calls this putcat must remember the name of lhs.
1077 */
1078
1079
1080 LOCAL expptr
1081 #ifdef KR_headers
putcat(lhs0,rhs)1082 putcat(lhs0, rhs)
1083 expptr lhs0;
1084 register expptr rhs;
1085 #else
1086 putcat(expptr lhs0, register expptr rhs)
1087 #endif
1088 {
1089 register Addrp lhs = (Addrp)lhs0;
1090 int n, tyi;
1091 Addrp length_var, string_var;
1092 expptr p;
1093 static char Writing_concatenation[] = "Writing concatenation";
1094
1095 /* Create the temporary arrays */
1096
1097 n = ncat(rhs);
1098 length_var = mktmpn(n, tyioint, ENULL);
1099 string_var = mktmpn(n, TYADDR, ENULL);
1100 frtemp((Addrp)cpexpr((expptr)length_var));
1101 frtemp((Addrp)cpexpr((expptr)string_var));
1102
1103 /* Initialize the arrays */
1104
1105 n = 0;
1106 /* p1_comment scribbles on its argument, so we
1107 * cannot safely pass a string literal here. */
1108 p1_comment(Writing_concatenation);
1109 putct1(rhs, length_var, string_var, &n);
1110
1111 /* Create the invocation */
1112
1113 tyi = tyint;
1114 tyint = tyioint; /* for -I2 */
1115 p = putx (call4 (TYSUBR, "s_cat",
1116 (expptr)lhs,
1117 (expptr)string_var,
1118 (expptr)length_var,
1119 (expptr)putconst((Constp)ICON(n))));
1120 tyint = tyi;
1121
1122 return p;
1123 }
1124
1125
1126
1127
1128
1129 LOCAL void
1130 #ifdef KR_headers
putct1(q,length_var,string_var,ip)1131 putct1(q, length_var, string_var, ip)
1132 register expptr q;
1133 register Addrp length_var;
1134 register Addrp string_var;
1135 int *ip;
1136 #else
1137 putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
1138 #endif
1139 {
1140 int i;
1141 Addrp length_copy, string_copy;
1142 expptr e;
1143 extern int szleng;
1144
1145 if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
1146 {
1147 putct1(q->exprblock.leftp, length_var, string_var,
1148 ip);
1149 putct1(q->exprblock.rightp, length_var, string_var,
1150 ip);
1151 frexpr (q -> exprblock.vleng);
1152 free ((charptr) q);
1153 }
1154 else
1155 {
1156 i = (*ip)++;
1157 e = cpexpr(q->headblock.vleng);
1158 if (!e)
1159 return; /* error -- character*(*) */
1160 length_copy = (Addrp) cpexpr((expptr)length_var);
1161 length_copy->memoffset =
1162 mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
1163 string_copy = (Addrp) cpexpr((expptr)string_var);
1164 string_copy->memoffset =
1165 mkexpr(OPPLUS, string_copy->memoffset,
1166 ICON(i*typesize[TYADDR]));
1167 putout (PAIR (putassign((expptr)length_copy, e),
1168 putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
1169 }
1170 }
1171
1172 /* putaddr -- seems to write out function invocation actual parameters */
1173
1174 LOCAL expptr
1175 #ifdef KR_headers
putaddr(p0)1176 putaddr(p0)
1177 expptr p0;
1178 #else
1179 putaddr(expptr p0)
1180 #endif
1181 {
1182 register Addrp p;
1183 chainp cp;
1184
1185 if (!(p = (Addrp)p0))
1186 return ENULL;
1187
1188 if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
1189 {
1190 frexpr((expptr)p);
1191 return ENULL;
1192 }
1193 if (p->isarray && p->memoffset)
1194 if (p->uname_tag == UNAM_REF) {
1195 cp = p->memoffset->listblock.listp;
1196 for(; cp; cp = cp->nextp)
1197 cp->datap = (char *)fixtype((tagptr)cp->datap);
1198 }
1199 else
1200 p->memoffset = putx(p->memoffset);
1201 return (expptr) p;
1202 }
1203
1204 LOCAL expptr
1205 #ifdef KR_headers
addrfix(e)1206 addrfix(e)
1207 expptr e;
1208 #else
1209 addrfix(expptr e)
1210 #endif
1211 /* fudge character string length if it's a TADDR */
1212 {
1213 return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
1214 }
1215
1216 LOCAL int
1217 #ifdef KR_headers
typekludge(ccall,q,at,j)1218 typekludge(ccall, q, at, j)
1219 int ccall;
1220 register expptr q;
1221 Atype *at;
1222 int j;
1223 #else
1224 typekludge(int ccall, register expptr q, Atype *at, int j)
1225 #endif
1226 /* j = alternate type */
1227 {
1228 register int i, k;
1229 extern int iocalladdr;
1230 register Namep np;
1231
1232 /* Return value classes:
1233 * < 100 ==> Fortran arg (pointer to type)
1234 * < 200 ==> C arg
1235 * < 300 ==> procedure arg
1236 * < 400 ==> external, no explicit type
1237 * < 500 ==> arg that may turn out to be
1238 * either a variable or a procedure
1239 */
1240
1241 k = q->headblock.vtype;
1242 if (ccall) {
1243 if (k == TYREAL)
1244 k = TYDREAL; /* force double for library routines */
1245 return k + 100;
1246 }
1247 if (k == TYADDR)
1248 return iocalladdr;
1249 i = q->tag;
1250 if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
1251 || (i == TADDR && q->addrblock.charleng)
1252 || i == TCONST)
1253 k = TYFTNLEN + 100;
1254 else if (i == TADDR)
1255 switch(q->addrblock.vclass) {
1256 case CLPROC:
1257 if (q->addrblock.uname_tag != UNAM_NAME)
1258 k += 200;
1259 else if ((np = q->addrblock.user.name)->vprocclass
1260 != PTHISPROC) {
1261 if (k && !np->vimpltype)
1262 k += 200;
1263 else {
1264 if (j > 200 && infertypes && j < 300) {
1265 k = j;
1266 inferdcl(np, j-200);
1267 }
1268 else k = (np->vstg == STGEXT
1269 ? extsymtab[np->vardesc.varno].extype
1270 : 0) + 200;
1271 at->cp = mkchain((char *)np, at->cp);
1272 }
1273 }
1274 else if (k == TYSUBR)
1275 k += 200;
1276 break;
1277
1278 case CLUNKNOWN:
1279 if (q->addrblock.vstg == STGARG
1280 && q->addrblock.uname_tag == UNAM_NAME) {
1281 k += 400;
1282 at->cp = mkchain((char *)q->addrblock.user.name,
1283 at->cp);
1284 }
1285 }
1286 else if (i == TNAME && q->nameblock.vstg == STGARG) {
1287 np = &q->nameblock;
1288 switch(np->vclass) {
1289 case CLPROC:
1290 if (!np->vimpltype)
1291 k += 200;
1292 else if (j <= 200 || !infertypes || j >= 300)
1293 k += 300;
1294 else {
1295 k = j;
1296 inferdcl(np, j-200);
1297 }
1298 goto add2chain;
1299
1300 case CLUNKNOWN:
1301 /* argument may be a scalar variable or a function */
1302 if (np->vimpltype && j && infertypes
1303 && j < 300) {
1304 inferdcl(np, j % 100);
1305 k = j;
1306 }
1307 else
1308 k += 400;
1309
1310 /* to handle procedure args only so far known to be
1311 * external, save a pointer to the symbol table entry...
1312 */
1313 add2chain:
1314 at->cp = mkchain((char *)np, at->cp);
1315 }
1316 }
1317 return k;
1318 }
1319
1320 char *
1321 #ifdef KR_headers
Argtype(k,buf)1322 Argtype(k, buf)
1323 int k;
1324 char *buf;
1325 #else
1326 Argtype(int k, char *buf)
1327 #endif
1328 {
1329 if (k < 100) {
1330 sprintf(buf, "%s variable", ftn_types[k]);
1331 return buf;
1332 }
1333 if (k < 200) {
1334 k -= 100;
1335 return ftn_types[k];
1336 }
1337 if (k < 300) {
1338 k -= 200;
1339 if (k == TYSUBR)
1340 return ftn_types[TYSUBR];
1341 sprintf(buf, "%s function", ftn_types[k]);
1342 return buf;
1343 }
1344 if (k < 400)
1345 return "external argument";
1346 k -= 400;
1347 sprintf(buf, "%s argument", ftn_types[k]);
1348 return buf;
1349 }
1350
1351 static void
1352 #ifdef KR_headers
atype_squawk(at,msg)1353 atype_squawk(at, msg)
1354 Argtypes *at;
1355 char *msg;
1356 #else
1357 atype_squawk(Argtypes *at, char *msg)
1358 #endif
1359 {
1360 register Atype *a, *ae;
1361 warn(msg);
1362 for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
1363 frchain(&a->cp);
1364 at->nargs = -1;
1365 if (at->changes & 2 && !at->defined)
1366 proc_protochanges++;
1367 }
1368
1369 static char inconsist[] = "inconsistent calling sequences for ";
1370
1371 void
1372 #ifdef KR_headers
bad_atypes(at,fname,i,j,k,here,prev)1373 bad_atypes(at, fname, i, j, k, here, prev)
1374 Argtypes *at;
1375 char *fname;
1376 int i;
1377 int j;
1378 int k;
1379 char *here;
1380 char *prev;
1381 #else
1382 bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
1383 #endif
1384 {
1385 char buf[208], buf1[32], buf2[32];
1386
1387 sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
1388 inconsist, fname, i, here, Argtype(k, buf1),
1389 prev, Argtype(j, buf2));
1390 atype_squawk(at, buf);
1391 }
1392
1393 int
1394 #ifdef KR_headers
type_fixup(at,a,k)1395 type_fixup(at, a, k)
1396 Argtypes *at;
1397 Atype *a;
1398 int k;
1399 #else
1400 type_fixup(Argtypes *at, Atype *a, int k)
1401 #endif
1402 {
1403 register struct Entrypoint *ep;
1404 if (!infertypes)
1405 return 0;
1406 for(ep = entries; ep; ep = ep->entnextp)
1407 if (ep->entryname && at == ep->entryname->arginfo) {
1408 a->type = k % 100;
1409 return proc_argchanges = 1;
1410 }
1411 return 0;
1412 }
1413
1414
1415 void
1416 #ifdef KR_headers
save_argtypes(arglist,at0,at1,ccall,fname,stg,nchargs,type,zap)1417 save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
1418 chainp arglist;
1419 Argtypes **at0;
1420 Argtypes **at1;
1421 int ccall;
1422 char *fname;
1423 int stg;
1424 int nchargs;
1425 int type;
1426 int zap;
1427 #else
1428 save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
1429 #endif
1430 {
1431 Argtypes *at;
1432 chainp cp;
1433 int i, i0, j, k, nargs, nbad, *t, *te;
1434 Atype *atypes;
1435 expptr q;
1436 char buf[208], buf1[32], buf2[32];
1437 static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
1438 static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
1439 #ifdef TYQUAD
1440 0,
1441 #endif
1442 initargs, initargs+1,0,0,0,initargs+2};
1443
1444 i0 = init_ac[type];
1445 t = init_ap[type];
1446 te = t + i0;
1447 if (at = *at0) {
1448 *at1 = at;
1449 nargs = at->nargs;
1450 if (nargs < 0 && type && at->changes & 2 && !at->defined)
1451 --proc_protochanges;
1452 if (at->dnargs >= 0 && zap != 2)
1453 type = 0;
1454 if (nargs < 0) { /* inconsistent usage seen */
1455 if (type)
1456 goto newlist;
1457 return;
1458 }
1459 atypes = at->atypes;
1460 i = nchargs;
1461 for(nbad = 0; t < te; atypes++) {
1462 if (++i > nargs) {
1463 toomany:
1464 i = nchargs + i0;
1465 for(cp = arglist; cp; cp = cp->nextp)
1466 i++;
1467 toofew:
1468 switch(zap) {
1469 case 2: zap = 6; break;
1470 case 1: if (at->defined & 4)
1471 return;
1472 }
1473 sprintf(buf,
1474 "%s%.90s:\n\there %d, previously %d args and string lengths.",
1475 inconsist, fname, i, nargs);
1476 atype_squawk(at, buf);
1477 if (type) {
1478 t = init_ap[type];
1479 goto newlist;
1480 }
1481 return;
1482 }
1483 j = atypes->type;
1484 k = *t++;
1485 if (j != k && j-400 != k) {
1486 cp = 0;
1487 goto badtypes;
1488 }
1489 }
1490 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1491 if (++i > nargs)
1492 goto toomany;
1493 j = atypes->type;
1494 if (!(q = (expptr)cp->datap))
1495 continue;
1496 k = typekludge(ccall, q, atypes, j);
1497 if (k >= 300 || k == j)
1498 continue;
1499 if (j >= 300) {
1500 if (k >= 200) {
1501 if (k == TYUNKNOWN + 200)
1502 continue;
1503 if (j % 100 != k - 200
1504 && k != TYSUBR + 200
1505 && j != TYUNKNOWN + 300
1506 && !type_fixup(at,atypes,k))
1507 goto badtypes;
1508 }
1509 else if (j % 100 % TYSUBR != k % TYSUBR
1510 && !type_fixup(at,atypes,k))
1511 goto badtypes;
1512 }
1513 else if (k < 200 || j < 200)
1514 if (j) {
1515 if (k == TYUNKNOWN
1516 && q->tag == TNAME
1517 && q->nameblock.vinfproc) {
1518 q->nameblock.vdcldone = 0;
1519 impldcl((Namep)q);
1520 }
1521 goto badtypes;
1522 }
1523 else ; /* fall through to update */
1524 else if (k == TYUNKNOWN+200)
1525 continue;
1526 else if (j != TYUNKNOWN+200)
1527 {
1528 badtypes:
1529 if (++nbad == 1)
1530 bad_atypes(at, fname, i - nchargs,
1531 j, k, "here ", ", previously");
1532 else
1533 fprintf(stderr,
1534 "\targ %d: here %s, previously %s.\n",
1535 i - nchargs, Argtype(k,buf1),
1536 Argtype(j,buf2));
1537 if (!cp)
1538 break;
1539 continue;
1540 }
1541 /* We've subsequently learned the right type,
1542 as in the call on zoo below...
1543
1544 subroutine foo(x, zap)
1545 external zap
1546 call goo(zap)
1547 x = zap(3)
1548 call zoo(zap)
1549 end
1550 */
1551 if (!nbad) {
1552 atypes->type = k;
1553 at->changes |= 1;
1554 }
1555 }
1556 if (i < nargs)
1557 goto toofew;
1558 if (nbad) {
1559 if (type) {
1560 /* we're defining the procedure */
1561 t = init_ap[type];
1562 te = t + i0;
1563 proc_argchanges = 1;
1564 goto newlist;
1565 }
1566 return;
1567 }
1568 if (zap == 1 && (at->changes & 5) != 5)
1569 at->changes = 0;
1570 return;
1571 }
1572 newlist:
1573 i = i0 + nchargs;
1574 for(cp = arglist; cp; cp = cp->nextp)
1575 i++;
1576 k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
1577 *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
1578 : (Argtypes *) mem(k,1);
1579 at->dnargs = at->nargs = i;
1580 at->defined = zap & 6;
1581 at->changes = type ? 0 : 4;
1582 atypes = at->atypes;
1583 for(; t < te; atypes++) {
1584 atypes->type = *t++;
1585 atypes->cp = 0;
1586 }
1587 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1588 atypes->cp = 0;
1589 atypes->type = (q = (expptr)cp->datap)
1590 ? typekludge(ccall, q, atypes, 0)
1591 : 0;
1592 }
1593 for(; --nchargs >= 0; atypes++) {
1594 atypes->type = TYFTNLEN + 100;
1595 atypes->cp = 0;
1596 }
1597 }
1598
1599 static char*
1600 #ifdef KR_headers
get_argtypes(p,pat0,pat1)1601 get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1;
1602 #else
1603 get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1)
1604 #endif
1605 {
1606 Addrp a;
1607 Argtypes **at0, **at1;
1608 Namep np;
1609 expptr rp;
1610 Extsym *e;
1611 char *fname;
1612
1613 a = (Addrp)p->leftp;
1614 switch(a->vstg) {
1615 case STGEXT:
1616 switch(a->uname_tag) {
1617 case UNAM_EXTERN: /* e.g., sqrt() */
1618 e = extsymtab + a->memno;
1619 at0 = at1 = &e->arginfo;
1620 fname = e->fextname;
1621 break;
1622 case UNAM_NAME:
1623 np = a->user.name;
1624 at0 = &extsymtab[np->vardesc.varno].arginfo;
1625 at1 = &np->arginfo;
1626 fname = np->fvarname;
1627 break;
1628 default:
1629 goto bug;
1630 }
1631 break;
1632 case STGARG:
1633 if (a->uname_tag != UNAM_NAME)
1634 goto bug;
1635 np = a->user.name;
1636 at0 = at1 = &np->arginfo;
1637 fname = np->fvarname;
1638 break;
1639 default:
1640 bug:
1641 Fatal("Confusion in saveargtypes");
1642 }
1643 *pat0 = at0;
1644 *pat1 = at1;
1645 return fname;
1646 }
1647
1648 void
1649 #ifdef KR_headers
saveargtypes(p)1650 saveargtypes(p)
1651 register Exprp p;
1652 #else
1653 saveargtypes(register Exprp p)
1654 #endif
1655 /* for writing prototypes */
1656 {
1657 Argtypes **at0, **at1;
1658 chainp arglist;
1659 expptr rp;
1660 char *fname;
1661
1662 fname = get_argtypes(p, &at0, &at1);
1663 rp = p->rightp;
1664 arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
1665 save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
1666 fname, p->leftp->addrblock.vstg, 0, 0, 0);
1667 }
1668
1669 /* putcall - fix up the argument list, and write out the invocation. p
1670 is expected to be initialized and point to an OPCALL or OPCCALL
1671 expression. The return value is a pointer to a temporary holding the
1672 result of a COMPLEX or CHARACTER operation, or NULL. */
1673
1674 LOCAL expptr
1675 #ifdef KR_headers
putcall(p0,temp)1676 putcall(p0, temp)
1677 expptr p0;
1678 Addrp *temp;
1679 #else
1680 putcall(expptr p0, Addrp *temp)
1681 #endif
1682 {
1683 register Exprp p = (Exprp)p0;
1684 chainp arglist; /* Pointer to actual arguments, if any */
1685 chainp charsp; /* List of copies of the variables which
1686 hold the lengths of character
1687 parameters (other than procedure
1688 parameters) */
1689 chainp cp; /* Iterator over argument lists */
1690 register expptr q; /* Pointer to the current argument */
1691 Addrp fval; /* Function return value */
1692 int type; /* type of the call - presumably this was
1693 set elsewhere */
1694 int byvalue; /* True iff we don't want to massage the
1695 parameter list, since we're calling a C
1696 library routine */
1697 char *s;
1698 Argtypes *at, **at0, **at1;
1699 Atype *At, *Ate;
1700
1701 type = p -> vtype;
1702 charsp = NULL;
1703 byvalue = (p->opcode == OPCCALL);
1704
1705 /* Verify the actual parameters */
1706
1707 if (p == (Exprp) NULL)
1708 err ("putcall: NULL call expression");
1709 else if (p -> tag != TEXPR)
1710 erri ("putcall: expected TEXPR, got '%d'", p -> tag);
1711
1712 /* Find the argument list */
1713
1714 if(p->rightp && p -> rightp -> tag == TLIST)
1715 arglist = p->rightp->listblock.listp;
1716 else
1717 arglist = NULL;
1718
1719 /* Count the number of explicit arguments, including lengths of character
1720 variables */
1721
1722 if (!byvalue) {
1723 get_argtypes(p, &at0, &at1);
1724 At = Ate = 0;
1725 if ((at = *at0) && at->nargs >= 0) {
1726 At = at->atypes;
1727 Ate = At + at->nargs;
1728 At += init_ac[type];
1729 }
1730 for(cp = arglist ; cp ; cp = cp->nextp) {
1731 q = (expptr) cp->datap;
1732 if( ISCONST(q) ) {
1733
1734 /* Even constants are passed by reference, so we need to put them in the
1735 literal table */
1736
1737 q = (expptr) putconst((Constp)q);
1738 cp->datap = (char *) q;
1739 }
1740
1741 /* Save the length expression of character variables (NOT character
1742 procedures) for the end of the argument list */
1743
1744 if( ISCHAR(q) &&
1745 (q->headblock.vclass != CLPROC
1746 || q->headblock.vstg == STGARG
1747 && q->tag == TADDR
1748 && q->addrblock.uname_tag == UNAM_NAME
1749 && q->addrblock.user.name->vprocclass == PTHISPROC)
1750 && (!At || At->type % 100 % TYSUBR == TYCHAR))
1751 {
1752 p0 = cpexpr(q->headblock.vleng);
1753 charsp = mkchain((char *)p0, charsp);
1754 if (q->headblock.vclass == CLUNKNOWN
1755 && q->headblock.vstg == STGARG)
1756 q->addrblock.user.name->vpassed = 1;
1757 else if (q->tag == TADDR
1758 && q->addrblock.uname_tag == UNAM_CONST)
1759 p0->constblock.Const.ci
1760 += q->addrblock.user.Const.ccp1.blanks;
1761 }
1762 if (At && ++At == Ate)
1763 At = 0;
1764 }
1765 }
1766 charsp = revchain(charsp);
1767
1768 /* If the routine is a CHARACTER function ... */
1769
1770 if(type == TYCHAR)
1771 {
1772 if( ISICON(p->vleng) )
1773 {
1774
1775 /* Allocate a temporary to hold the return value of the function */
1776
1777 fval = mktmp(TYCHAR, p->vleng);
1778 }
1779 else {
1780 err("adjustable character function");
1781 if (temp)
1782 *temp = 0;
1783 return 0;
1784 }
1785 }
1786
1787 /* If the routine is a COMPLEX function ... */
1788
1789 else if( ISCOMPLEX(type) )
1790 fval = mktmp(type, ENULL);
1791 else
1792 fval = NULL;
1793
1794 /* Write the function name, without taking its address */
1795
1796 p -> leftp = putx(fixtype(putaddr(p->leftp)));
1797
1798 if(fval)
1799 {
1800 chainp prepend;
1801
1802 /* Prepend a copy of the function return value buffer out as the first
1803 argument. */
1804
1805 prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
1806
1807 /* If it's a character function, also prepend the length of the result */
1808
1809 if(type==TYCHAR)
1810 {
1811
1812 prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
1813 p->vleng)), arglist);
1814 }
1815 if (!(q = p->rightp))
1816 p->rightp = q = (expptr)mklist(CHNULL);
1817 q->listblock.listp = prepend;
1818 }
1819
1820 /* Scan through the fortran argument list */
1821
1822 for(cp = arglist ; cp ; cp = cp->nextp)
1823 {
1824 q = (expptr) (cp->datap);
1825 if (q == ENULL)
1826 err ("putcall: NULL argument");
1827
1828 /* call putaddr only when we've got a parameter for a C routine or a
1829 memory resident parameter */
1830
1831 if (q -> tag == TCONST && !byvalue)
1832 q = (expptr) putconst ((Constp)q);
1833
1834 if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
1835 if (q->addrblock.parenused
1836 && !byvalue && q->headblock.vtype != TYCHAR)
1837 goto make_copy;
1838 cp->datap = (char *)putaddr(q);
1839 }
1840 else if( ISCOMPLEX(q->headblock.vtype) )
1841 cp -> datap = (char *) putx (fixtype(putcxop(q)));
1842 else if (ISCHAR(q) )
1843 cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
1844 else if( ! ISERROR(q) )
1845 {
1846 if(byvalue) {
1847 if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) {
1848 if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype)
1849 && q->exprblock.leftp->tag == TEXPR)
1850 q->exprblock.leftp = putcxop(q->exprblock.leftp);
1851 else
1852 q->exprblock.leftp = putx(q->exprblock.leftp);
1853 }
1854 else
1855 cp -> datap = (char *) putx(q);
1856 }
1857 else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
1858 cp -> datap = (char *) putx(q);
1859 else {
1860 expptr t, t1;
1861
1862 /* If we've got a register parameter, or (maybe?) a constant, save it in a
1863 temporary first */
1864 make_copy:
1865 t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
1866
1867 /* Assign to temporary variables before invoking the subroutine or
1868 function */
1869
1870 t1 = putassign( cpexpr(t), q );
1871 if (doin_setbound)
1872 t = mkexpr(OPCOMMA_ARG, t1, t);
1873 else
1874 putout(t1);
1875 cp -> datap = (char *) t;
1876 } /* else */
1877 } /* if !ISERROR(q) */
1878 }
1879
1880 /* Now adjust the lengths of the CHARACTER parameters */
1881
1882 for(cp = charsp ; cp ; cp = cp->nextp)
1883 cp->datap = (char *)addrfix(putx(
1884 /* in case MAIN has a character*(*)... */
1885 (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
1886 : ICON(0)));
1887
1888 /* ... and add them to the end of the argument list */
1889
1890 hookup (arglist, charsp);
1891
1892 /* Return the name of the temporary used to hold the results, if any was
1893 necessary. */
1894
1895 if (temp) *temp = fval;
1896 else frexpr ((expptr)fval);
1897
1898 saveargtypes(p);
1899
1900 return (expptr) p;
1901 }
1902
1903
1904
1905 /* putmnmx -- Put min or max. p must point to an EXPR, not just a
1906 CONST */
1907
1908 LOCAL expptr
1909 #ifdef KR_headers
putmnmx(p)1910 putmnmx(p)
1911 register expptr p;
1912 #else
1913 putmnmx(register expptr p)
1914 #endif
1915 {
1916 int op, op2, type;
1917 expptr arg, qp, temp;
1918 chainp p0, p1;
1919 Addrp sp, tp;
1920 char comment_buf[80];
1921 char *what;
1922
1923 if(p->tag != TEXPR)
1924 badtag("putmnmx", p->tag);
1925
1926 type = p->exprblock.vtype;
1927 op = p->exprblock.opcode;
1928 op2 = op == OPMIN ? OPMIN2 : OPMAX2;
1929 p0 = p->exprblock.leftp->listblock.listp;
1930 free( (charptr) (p->exprblock.leftp) );
1931 free( (charptr) p );
1932
1933 /* special case for two addressable operands */
1934
1935 if (addressable((expptr)p0->datap)
1936 && (p1 = p0->nextp)
1937 && addressable((expptr)p1->datap)
1938 && !p1->nextp) {
1939 if (type == TYREAL && forcedouble)
1940 op2 = op == OPMIN ? OPDMIN : OPDMAX;
1941 p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
1942 mkconv(type, cpexpr((expptr)p1->datap)));
1943 frchain(&p0);
1944 return p;
1945 }
1946
1947 /* general case */
1948
1949 sp = mktmp(type, ENULL);
1950
1951 /* We only need a second temporary if the arg list has an unaddressable
1952 value */
1953
1954 tp = (Addrp) NULL;
1955 qp = ENULL;
1956 for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
1957 if (!addressable ((expptr) p1 -> datap)) {
1958 tp = mktmp(type, ENULL);
1959 qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
1960 qp = fixexpr((Exprp)qp);
1961 break;
1962 } /* if */
1963
1964 /* Now output the appropriate number of assignments and comparisons. Min
1965 and max are implemented by the simple O(n) algorithm:
1966
1967 min (a, b, c, d) ==>
1968 { <type> t1, t2;
1969
1970 t1 = a;
1971 t2 = b; t1 = (t1 < t2) ? t1 : t2;
1972 t2 = c; t1 = (t1 < t2) ? t1 : t2;
1973 t2 = d; t1 = (t1 < t2) ? t1 : t2;
1974 }
1975 */
1976
1977 if (!doin_setbound) {
1978 switch(op) {
1979 case OPLT:
1980 case OPMIN:
1981 case OPDMIN:
1982 case OPMIN2:
1983 what = "IN";
1984 break;
1985 default:
1986 what = "AX";
1987 }
1988 sprintf (comment_buf, "Computing M%s", what);
1989 p1_comment (comment_buf);
1990 }
1991
1992 p1 = p0->nextp;
1993 temp = (expptr)p0->datap;
1994 if (addressable(temp) && addressable((expptr)p1->datap)) {
1995 p = mkconv(type, cpexpr(temp));
1996 arg = mkconv(type, cpexpr((expptr)p1->datap));
1997 temp = mkexpr(op2, p, arg);
1998 if (!ISCONST(temp))
1999 temp = fixexpr((Exprp)temp);
2000 p1 = p1->nextp;
2001 }
2002 p = putassign (cpexpr((expptr)sp), temp);
2003
2004 for(; p1 ; p1 = p1->nextp)
2005 {
2006 if (addressable ((expptr) p1 -> datap)) {
2007 arg = mkconv(type, cpexpr((expptr)p1->datap));
2008 temp = mkexpr(op2, cpexpr((expptr)sp), arg);
2009 temp = fixexpr((Exprp)temp);
2010 } else {
2011 temp = (expptr) cpexpr (qp);
2012 p = mkexpr(OPCOMMA, p,
2013 putassign(cpexpr((expptr)tp), (expptr)p1->datap));
2014 } /* else */
2015
2016 if(p1->nextp)
2017 p = mkexpr(OPCOMMA, p,
2018 putassign(cpexpr((expptr)sp), temp));
2019 else {
2020 if (type == TYREAL && forcedouble)
2021 temp->exprblock.opcode =
2022 op == OPMIN ? OPDMIN : OPDMAX;
2023 if (doin_setbound)
2024 p = mkexpr(OPCOMMA, p, temp);
2025 else {
2026 putout (p);
2027 p = putx(temp);
2028 }
2029 if (qp)
2030 frexpr (qp);
2031 } /* else */
2032 } /* for */
2033
2034 frchain( &p0 );
2035 return p;
2036 }
2037
2038
2039 void
2040 #ifdef KR_headers
putwhile(p)2041 putwhile(p)
2042 expptr p;
2043 #else
2044 putwhile(expptr p)
2045 #endif
2046 {
2047 long where;
2048 int k, n;
2049
2050 if (wh_next >= wh_last)
2051 {
2052 k = wh_last - wh_first;
2053 n = k + 100;
2054 wh_next = mem(n,0);
2055 wh_last = wh_first + n;
2056 if (k)
2057 memcpy(wh_next, wh_first, k);
2058 wh_first = wh_next;
2059 wh_next += k;
2060 wh_last = wh_first + n;
2061 }
2062 p1put(P1_WHILE1START);
2063 where = ftell(pass1_file);
2064 if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
2065 {
2066 if(k != TYERROR)
2067 err("non-logical expression in DO WHILE statement");
2068 }
2069 else {
2070 p = putx(p);
2071 *wh_next++ = ftell(pass1_file) > where;
2072 p1put(P1_WHILE2START);
2073 p1_expr(p);
2074 }
2075 }
2076