?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* add p cc
[mascara-docs.git] / compilers / pcc / pcc-1.0.0 / f77 / fcom / putscj.c
blobfb6302b08f2340b8569a8c2495c79f1d3692d0d0
1 /* $Id: putscj.c,v 1.18 2008/12/19 08:08:48 ragge Exp $ */
2 /*
3 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * Redistributions of source code and documentation must retain the above
10 * copyright notice, this list of conditions and the following disclaimer.
11 * Redistributions in binary form must reproduce the above copyright
12 * notice, this list of conditions and the following disclaimer in the
13 * documentation and/or other materials provided with the distribution.
14 * All advertising materials mentioning features or use of this software
15 * must display the following acknowledgement:
16 * This product includes software developed or owned by Caldera
17 * International, Inc.
18 * Neither the name of Caldera International, Inc. nor the names of other
19 * contributors may be used to endorse or promote products derived from
20 * this software without specific prior written permission.
21 *
22 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
23 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
24 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
25 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26 * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
27 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
28 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
29 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
30 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
31 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
32 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 * POSSIBILITY OF SUCH DAMAGE.
34 */
35 /* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
36 /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
37
38 #include <unistd.h>
39 #include <string.h>
40
41 #include "defines.h"
42 #include "defs.h"
43
44 #include "scjdefs.h"
45
46 LOCAL struct bigblock *putcall(struct bigblock *p);
47 LOCAL NODE *putmnmx(struct bigblock *p);
48 LOCAL NODE *putmem(bigptr, int, ftnint);
49 LOCAL NODE *putaddr(struct bigblock *, int);
50 LOCAL void putct1(bigptr, struct bigblock *, struct bigblock *, int *);
51 LOCAL int ncat(bigptr p);
52 LOCAL NODE *putcat(struct bigblock *, bigptr);
53 LOCAL NODE *putchcmp(struct bigblock *p);
54 LOCAL NODE *putcheq(struct bigblock *p);
55 LOCAL NODE *putcxcmp(struct bigblock *p);
56 LOCAL struct bigblock *putcx1(bigptr);
57 LOCAL NODE *putcxop(bigptr p);
58 LOCAL struct bigblock *putcxeq(struct bigblock *p);
59 LOCAL NODE *putpower(bigptr p);
60 LOCAL NODE *putop(bigptr p);
61 LOCAL NODE *putchop(bigptr p);
62 LOCAL struct bigblock *putch1(bigptr);
63 LOCAL struct bigblock *intdouble(struct bigblock *);
64
65 extern int ops2[];
66 extern int types2[];
67 static char *inproc;
68 static NODE *callval; /* to get return value right */
69 extern int negrel[];
70
71 #define XINT(z) ONEOF(z, MSKINT|MSKCHAR)
72 #define P2TYPE(x) (types2[(x)->vtype])
73 #define P2OP(x) (ops2[(x)->b_expr.opcode])
74
75 static void
76 sendp2(NODE *p)
77 {
78 extern int thisline;
79
80 p2tree(p);
81 thisline = lineno;
82 if (debugflag)
83 fwalk(p, e2print, 0);
84 pass2_compile(ipnode(p));
85 }
86
87 static NODE *
88 putassign(bigptr lp, bigptr rp)
89 {
90 return putx(fixexpr(mkexpr(OPASSIGN, lp, rp)));
91 }
92
93
94 void
95 puthead(char *s)
96 {
97 struct interpass_prolog *ipp = ckalloc(sizeof(struct interpass_prolog));
98 int olbl, lbl1, lbl2;
99 unsigned int i;
100
101 if (s == NULL)
102 return;
103 if (inproc)
104 fatal1("puthead %s in procedure", s);
105 inproc = s;
106 olbl = lastlabno;
107 lbl1 = newlabel();
108 lbl2 = newlabel();
109
110 for (i = 0; i < NIPPREGS; i++)
111 ipp->ipp_regs[i] = 0; /* no regs used yet */
112 ipp->ipp_autos = 0; /* no autos used yet */
113 ipp->ipp_name = copys(s); /* function name */
114 ipp->ipp_type = INT; /* type not known yet? */
115 ipp->ipp_vis = 1; /* always visible */
116 ipp->ip_tmpnum = 0; /* no temp nodes used in F77 yet */
117 ipp->ip_lblnum = olbl; /* # used labels so far */
118 ipp->ipp_ip.ip_lbl = lbl1; /* first label, for optim */
119 ipp->ipp_ip.type = IP_PROLOG;
120 pass2_compile((struct interpass *)ipp);
121
122 }
123
124 /* It is necessary to precede each procedure with a "left bracket"
125 * line that tells pass 2 how many register variables and how
126 * much automatic space is required for the function. This compiler
127 * does not know how much automatic space is needed until the
128 * entire procedure has been processed. Therefore, "puthead"
129 * is called at the begining to record the current location in textfile,
130 * then to put out a placeholder left bracket line. This procedure
131 * repositions the file and rewrites that line, then puts the
132 * file pointer back to the end of the file.
133 */
134
135 void
136 putbracket()
137 {
138 struct interpass_prolog *ipp = ckalloc(sizeof(struct interpass_prolog));
139 unsigned int i;
140
141 if (inproc == 0)
142 fatal1("puteof outside procedure");
143 for (i = 0; i < NIPPREGS; i++)
144 ipp->ipp_regs[i] = 0;
145 ipp->ipp_autos = autoleng;
146 ipp->ipp_name = copys(inproc);
147 ipp->ipp_type = INT; /* XXX should set the correct type */
148 ipp->ipp_vis = 1;
149 ipp->ip_tmpnum = 0;
150 ipp->ip_lblnum = lastlabno;
151 ipp->ipp_ip.ip_lbl = retlabel;
152 ipp->ipp_ip.type = IP_EPILOG;
153 printf("\t.text\n"); /* XXX */
154 pass2_compile((struct interpass *)ipp);
155 inproc = 0;
156 }
157
158
159
160 void
161 putrbrack(int k)
162 {
163 }
164
165
166 void
167 puteof()
168 {
169 }
170
171
172 /* put out code for if( ! p) goto l */
173 void
174 putif(bigptr p, int l)
175 {
176 NODE *p1;
177 int k;
178
179 if( ( k = (p = fixtype(p))->vtype) != TYLOGICAL) {
180 if(k != TYERROR)
181 err("non-logical expression in IF statement");
182 frexpr(p);
183 } else {
184 p1 = putex1(p);
185 if (p1->n_op == EQ && p1->n_right->n_op == ICON &&
186 p1->n_right->n_lval == 0 && logop(p1->n_left->n_op)) {
187 /* created by OPOR */
188 NODE *q = p1->n_left;
189 q->n_op = negrel[q->n_op - EQ];
190 nfree(p1->n_right);
191 nfree(p1);
192 p1 = q;
193 }
194 if (logop(p1->n_op) == 0)
195 p1 = mkbinode(NE, p1, mklnode(ICON, 0, 0, INT), INT);
196 if (p1->n_left->n_op == ICON) {
197 /* change constants to right */
198 NODE *p2 = p1->n_left;
199 p1->n_left = p1->n_right;
200 p1->n_right = p2;
201 if (p1->n_op != EQ && p1->n_op != NE)
202 p1->n_op = negrel[p1->n_op - EQ];
203 }
204 p1->n_op = negrel[p1->n_op - EQ];
205 p1 = mkbinode(CBRANCH, p1, mklnode(ICON, l, 0, INT), INT);
206 sendp2(p1);
207 }
208 }
209
210 /* Arithmetic IF */
211 void
212 prarif(bigptr p, int neg, int zer, int pos)
213 {
214 bigptr x1 = fmktemp(p->vtype, NULL);
215
216 putexpr(mkexpr(OPASSIGN, cpexpr(x1), p));
217 putif(mkexpr(OPGE, cpexpr(x1), MKICON(0)), neg);
218 putif(mkexpr(OPLE, x1, MKICON(0)), pos);
219 putgoto(zer);
220 }
221
222 /* put out code for goto l */
223 void
224 putgoto(int label)
225 {
226 NODE *p;
227
228 p = mkunode(GOTO, mklnode(ICON, label, 0, INT), 0, INT);
229 sendp2(p);
230 }
231
232
233 /* branch to address constant or integer variable */
234 void
235 putbranch(struct bigblock *q)
236 {
237 NODE *p;
238
239 p = mkunode(GOTO, putex1(q), 0, INT);
240 sendp2(p);
241 }
242
243 /*
244 * put out label l: in text segment
245 */
246 void
247 putlabel(int label)
248 {
249 struct interpass *ip = ckalloc(sizeof(struct interpass));
250
251 ip->type = IP_DEFLAB;
252 ip->lineno = lineno;
253 ip->ip_lbl = label;
254 pass2_compile(ip);
255 }
256
257
258 /*
259 * Called from inner routines. Generates a NODE tree and writes it out.
260 */
261 void
262 putexpr(bigptr q)
263 {
264 NODE *p;
265 p = putex1(q);
266 sendp2(p);
267 }
268
269
270
271 void
272 putcmgo(bigptr x, int nlab, struct labelblock *labels[])
273 {
274 bigptr y;
275 int i;
276
277 if (!ISINT(x->vtype)) {
278 execerr("computed goto index must be integer", NULL);
279 return;
280 }
281
282 y = fmktemp(x->vtype, NULL);
283 putexpr(mkexpr(OPASSIGN, cpexpr(y), x));
284 #ifdef notyet /* target-specific computed goto */
285 vaxgoto(y, nlab, labels);
286 #else
287 /*
288 * Primitive implementation, should use table here.
289 */
290 for(i = 0 ; i < nlab ; ++i)
291 putif(mkexpr(OPNE, cpexpr(y), MKICON(i+1)), labels[i]->labelno);
292 frexpr(y);
293 #endif
294 }
295
296 /*
297 * Convert a f77 tree statement to something that looks like a
298 * pcc expression tree.
299 */
300 NODE *
301 putx(bigptr q)
302 {
303 struct bigblock *x1;
304 NODE *p = NULL; /* XXX */
305 int opc;
306 int type, k;
307
308 #ifdef PCC_DEBUG
309 if (tflag) {
310 printf("putx %p\n", q);
311 fprint(q, 0);
312 }
313 #endif
314
315 switch(q->tag) {
316 case TERROR:
317 ckfree(q);
318 break;
319
320 case TCONST:
321 switch(type = q->vtype) {
322 case TYLOGICAL:
323 type = tyint;
324 case TYLONG:
325 case TYSHORT:
326 p = mklnode(ICON, q->b_const.fconst.ci,
327 0, types2[type]);
328 ckfree(q);
329 break;
330
331 case TYADDR:
332 p = mklnode(ICON, 0, 0, types2[type]);
333 p->n_name = copys(memname(STGCONST,
334 (int)q->b_const.fconst.ci));
335 ckfree(q);
336 break;
337
338 default:
339 p = putx(putconst(q));
340 break;
341 }
342 break;
343
344 case TEXPR:
345 switch(opc = q->b_expr.opcode) {
346 case OPCALL:
347 case OPCCALL:
348 if( ISCOMPLEX(q->vtype) )
349 p = putcxop(q);
350 else {
351 putcall(q);
352 p = callval;
353 }
354 break;
355
356 case OPMIN:
357 case OPMAX:
358 p = putmnmx(q);
359 break;
360
361 case OPASSIGN:
362 if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
363 ISCOMPLEX(q->b_expr.rightp->vtype)) {
364 frexpr(putcxeq(q));
365 } else if (ISCHAR(q))
366 p = putcheq(q);
367 else
368 goto putopp;
369 break;
370
371 case OPEQ:
372 case OPNE:
373 if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
374 ISCOMPLEX(q->b_expr.rightp->vtype) ) {
375 p = putcxcmp(q);
376 break;
377 }
378 case OPLT:
379 case OPLE:
380 case OPGT:
381 case OPGE:
382 if(ISCHAR(q->b_expr.leftp))
383 p = putchcmp(q);
384 else
385 goto putopp;
386 break;
387
388 case OPPOWER:
389 p = putpower(q);
390 break;
391
392 case OPSTAR:
393 /* m * (2**k) -> m<<k */
394 if (XINT(q->b_expr.leftp->vtype) &&
395 ISICON(q->b_expr.rightp) &&
396 ((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) {
397 q->b_expr.opcode = OPLSHIFT;
398 frexpr(q->b_expr.rightp);
399 q->b_expr.rightp = MKICON(k);
400 goto putopp;
401 }
402
403 case OPMOD:
404 goto putopp;
405 case OPPLUS:
406 case OPMINUS:
407 case OPSLASH:
408 case OPNEG:
409 if( ISCOMPLEX(q->vtype) )
410 p = putcxop(q);
411 else
412 goto putopp;
413 break;
414
415 case OPCONV:
416 if( ISCOMPLEX(q->vtype) )
417 p = putcxop(q);
418 else if (ISCOMPLEX(q->b_expr.leftp->vtype)) {
419 p = putx(mkconv(q->vtype,
420 realpart(putcx1(q->b_expr.leftp))));
421 ckfree(q);
422 } else
423 goto putopp;
424 break;
425
426 case OPAND:
427 /* Create logical AND */
428 x1 = fmktemp(TYLOGICAL, NULL);
429 putexpr(mkexpr(OPASSIGN, cpexpr(x1),
430 mklogcon(0)));
431 k = newlabel();
432 putif(q->b_expr.leftp, k);
433 putif(q->b_expr.rightp, k);
434 putexpr(mkexpr(OPASSIGN, cpexpr(x1),
435 mklogcon(1)));
436 putlabel(k);
437 p = putx(x1);
438 break;
439
440 case OPNOT: /* Logical NOT */
441 x1 = fmktemp(TYLOGICAL, NULL);
442 putexpr(mkexpr(OPASSIGN, cpexpr(x1),
443 mklogcon(1)));
444 k = newlabel();
445 putif(q->b_expr.leftp, k);
446 putexpr(mkexpr(OPASSIGN, cpexpr(x1),
447 mklogcon(0)));
448 putlabel(k);
449 p = putx(x1);
450 break;
451
452 case OPOR: /* Create logical OR */
453 x1 = fmktemp(TYLOGICAL, NULL);
454 putexpr(mkexpr(OPASSIGN, cpexpr(x1),
455 mklogcon(1)));
456 k = newlabel();
457 putif(mkexpr(OPEQ, q->b_expr.leftp,
458 mklogcon(0)), k);
459 putif(mkexpr(OPEQ, q->b_expr.rightp,
460 mklogcon(0)), k);
461 putexpr(mkexpr(OPASSIGN, cpexpr(x1),
462 mklogcon(0)));
463 putlabel(k);
464 p = putx(x1);
465 break;
466
467 case OPCOMMA:
468 for (x1 = q; x1->b_expr.opcode == OPCOMMA;
469 x1 = x1->b_expr.leftp)
470 putexpr(x1->b_expr.rightp);
471 p = putx(x1);
472 break;
473
474 case OPEQV:
475 case OPNEQV:
476 case OPADDR:
477 case OPBITOR:
478 case OPBITAND:
479 case OPBITXOR:
480 case OPBITNOT:
481 case OPLSHIFT:
482 case OPRSHIFT:
483 putopp:
484 p = putop(q);
485 break;
486
487 default:
488 fatal1("putx: invalid opcode %d", opc);
489 }
490 break;
491
492 case TADDR:
493 p = putaddr(q, YES);
494 break;
495
496 default:
497 fatal1("putx: impossible tag %d", q->tag);
498 }
499 return p;
500 }
501
502 LOCAL NODE *
503 putop(bigptr q)
504 {
505 NODE *p;
506 int k;
507 bigptr lp, tp;
508 int pt, lt;
509
510 #ifdef PCC_DEBUG
511 if (tflag) {
512 printf("putop %p\n", q);
513 fprint(q, 0);
514 }
515 #endif
516 switch(q->b_expr.opcode) { /* check for special cases and rewrite */
517 case OPCONV:
518 pt = q->vtype;
519 lp = q->b_expr.leftp;
520 lt = lp->vtype;
521 while(q->tag==TEXPR && q->b_expr.opcode==OPCONV &&
522 ((ISREAL(pt)&&ISREAL(lt)) ||
523 (XINT(pt)&&(ONEOF(lt,MSKINT|MSKADDR))) )) {
524 if(lp->tag != TEXPR) {
525 if(pt==TYINT && lt==TYLONG)
526 break;
527 if(lt==TYINT && pt==TYLONG)
528 break;
529 }
530 ckfree(q);
531 q = lp;
532 pt = lt;
533 lp = q->b_expr.leftp;
534 lt = lp->vtype;
535 }
536 if(q->tag==TEXPR && q->b_expr.opcode==OPCONV)
537 break;
538 p = putx(q);
539 return p;
540
541 case OPADDR:
542 lp = q->b_expr.leftp;
543 if(lp->tag != TADDR) {
544 tp = fmktemp(lp->vtype, lp->vleng);
545 p = putx(mkexpr(OPASSIGN, cpexpr(tp), lp));
546 sendp2(p);
547 lp = tp;
548 }
549 p = putaddr(lp, NO);
550 ckfree(q);
551 return p;
552 }
553
554 if ((k = ops2[q->b_expr.opcode]) <= 0)
555 fatal1("putop: invalid opcode %d (%d)", q->b_expr.opcode, k);
556 p = putx(q->b_expr.leftp);
557 if(q->b_expr.rightp)
558 p = mkbinode(k, p, putx(q->b_expr.rightp), types2[q->vtype]);
559 else
560 p = mkunode(k, p, 0, types2[q->vtype]);
561
562 if(q->vleng)
563 frexpr(q->vleng);
564 ckfree(q);
565 return p;
566 }
567
568 /*
569 * Put return values into correct register.
570 */
571 void
572 putforce(int t, bigptr p)
573 {
574 NODE *p1;
575
576 p = mkconv(t, fixtype(p));
577 p1 = putx(p);
578 p1 = mkunode(FORCE, p1, 0,
579 (t==TYSHORT ? SHORT : (t==TYLONG ? LONG : LDOUBLE)));
580 sendp2(p1);
581 }
582
583 LOCAL NODE *
584 putpower(bigptr p)
585 {
586 NODE *p3;
587 bigptr base;
588 struct bigblock *t1, *t2;
589 ftnint k = 0; /* XXX gcc */
590 int type;
591
592 if(!ISICON(p->b_expr.rightp) ||
593 (k = p->b_expr.rightp->b_const.fconst.ci)<2)
594 fatal("putpower: bad call");
595 base = p->b_expr.leftp;
596 type = base->vtype;
597 t1 = fmktemp(type, NULL);
598 t2 = NULL;
599 p3 = putassign(cpexpr(t1), cpexpr(base) );
600 sendp2(p3);
601
602 for( ; (k&1)==0 && k>2 ; k>>=1 ) {
603 p3 = putassign(cpexpr(t1),
604 mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
605 sendp2(p3);
606 }
607
608 if(k == 2)
609 p3 = putx(mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
610 else {
611 t2 = fmktemp(type, NULL);
612 p3 = putassign(cpexpr(t2), cpexpr(t1));
613 sendp2(p3);
614
615 for(k>>=1 ; k>1 ; k>>=1) {
616 p3 = putassign(cpexpr(t1),
617 mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
618 sendp2(p3);
619 if(k & 1) {
620 p3 = putassign(cpexpr(t2),
621 mkexpr(OPSTAR, cpexpr(t2), cpexpr(t1)));
622 sendp2(p3);
623 }
624 }
625 p3 = putx( mkexpr(OPSTAR, cpexpr(t2),
626 mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
627 }
628 frexpr(t1);
629 if(t2)
630 frexpr(t2);
631 frexpr(p);
632 return p3;
633 }
634
635 LOCAL struct bigblock *
636 intdouble(struct bigblock *p)
637 {
638 struct bigblock *t;
639
640 t = fmktemp(TYDREAL, NULL);
641
642 sendp2(putassign(cpexpr(t), p));
643 return(t);
644 }
645
646 LOCAL struct bigblock *
647 putcxeq(struct bigblock *q)
648 {
649 struct bigblock *lp, *rp;
650
651 lp = putcx1(q->b_expr.leftp);
652 rp = putcx1(q->b_expr.rightp);
653 sendp2(putassign(realpart(lp), realpart(rp)));
654 if( ISCOMPLEX(q->vtype) ) {
655 sendp2(putassign(imagpart(lp), imagpart(rp)));
656 }
657 frexpr(rp);
658 ckfree(q);
659 return(lp);
660 }
661
662
663
664 LOCAL NODE *
665 putcxop(bigptr q)
666 {
667 NODE *p;
668
669 p = putaddr(putcx1(q), NO);
670 return p;
671 }
672
673 LOCAL struct bigblock *
674 putcx1(bigptr qq)
675 {
676 struct bigblock *q, *lp, *rp;
677 register struct bigblock *resp;
678 NODE *p;
679 int opcode;
680 int ltype, rtype;
681
682 ltype = rtype = 0; /* XXX gcc */
683 if(qq == NULL)
684 return(NULL);
685
686 switch(qq->tag) {
687 case TCONST:
688 if( ISCOMPLEX(qq->vtype) )
689 qq = putconst(qq);
690 return( qq );
691
692 case TADDR:
693 if( ! addressable(qq) ) {
694 resp = fmktemp(tyint, NULL);
695 p = putassign( cpexpr(resp), qq->b_addr.memoffset );
696 sendp2(p);
697 qq->b_addr.memoffset = resp;
698 }
699 return( qq );
700
701 case TEXPR:
702 if( ISCOMPLEX(qq->vtype) )
703 break;
704 resp = fmktemp(TYDREAL, NO);
705 p = putassign( cpexpr(resp), qq);
706 sendp2(p);
707 return(resp);
708
709 default:
710 fatal1("putcx1: bad tag %d", qq->tag);
711 }
712
713 opcode = qq->b_expr.opcode;
714 if(opcode==OPCALL || opcode==OPCCALL) {
715 q = putcall(qq);
716 sendp2(callval);
717 return(q);
718 } else if(opcode == OPASSIGN) {
719 return( putcxeq(qq) );
720 }
721
722 resp = fmktemp(qq->vtype, NULL);
723 if((lp = putcx1(qq->b_expr.leftp) ))
724 ltype = lp->vtype;
725 if((rp = putcx1(qq->b_expr.rightp) ))
726 rtype = rp->vtype;
727
728 switch(opcode) {
729 case OPCOMMA:
730 frexpr(resp);
731 resp = rp;
732 rp = NULL;
733 break;
734
735 case OPNEG:
736 p = putassign(realpart(resp),
737 mkexpr(OPNEG, realpart(lp), NULL));
738 sendp2(p);
739 p = putassign(imagpart(resp),
740 mkexpr(OPNEG, imagpart(lp), NULL));
741 sendp2(p);
742 break;
743
744 case OPPLUS:
745 case OPMINUS:
746 p = putassign( realpart(resp),
747 mkexpr(opcode, realpart(lp), realpart(rp) ));
748 sendp2(p);
749 if(rtype < TYCOMPLEX) {
750 p = putassign(imagpart(resp), imagpart(lp) );
751 } else if(ltype < TYCOMPLEX) {
752 if(opcode == OPPLUS)
753 p = putassign( imagpart(resp), imagpart(rp) );
754 else
755 p = putassign( imagpart(resp),
756 mkexpr(OPNEG, imagpart(rp), NULL) );
757 } else
758 p = putassign( imagpart(resp),
759 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
760 sendp2(p);
761 break;
762
763 case OPSTAR:
764 if(ltype < TYCOMPLEX) {
765 if( ISINT(ltype) )
766 lp = intdouble(lp);
767 p = putassign( realpart(resp),
768 mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
769 sendp2(p);
770 p = putassign( imagpart(resp),
771 mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
772 } else if(rtype < TYCOMPLEX) {
773 if( ISINT(rtype) )
774 rp = intdouble(rp);
775 p = putassign( realpart(resp),
776 mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
777 sendp2(p);
778 p = putassign( imagpart(resp),
779 mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
780 } else {
781 p = putassign( realpart(resp), mkexpr(OPMINUS,
782 mkexpr(OPSTAR, realpart(lp), realpart(rp)),
783 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
784 sendp2(p);
785 p = putassign( imagpart(resp), mkexpr(OPPLUS,
786 mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
787 mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
788 }
789 sendp2(p);
790 break;
791
792 case OPSLASH:
793 /* fixexpr has already replaced all divisions
794 * by a complex by a function call
795 */
796 if( ISINT(rtype) )
797 rp = intdouble(rp);
798 p = putassign( realpart(resp),
799 mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
800 sendp2(p);
801 p = putassign( imagpart(resp),
802 mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
803 sendp2(p);
804 break;
805
806 case OPCONV:
807 p = putassign( realpart(resp), realpart(lp) );
808 if( ISCOMPLEX(lp->vtype) )
809 q = imagpart(lp);
810 else if(rp != NULL)
811 q = realpart(rp);
812 else
813 q = mkrealcon(TYDREAL, 0.0);
814 sendp2(p);
815 p = putassign( imagpart(resp), q);
816 sendp2(p);
817 break;
818
819 default:
820 fatal1("putcx1 of invalid opcode %d", opcode);
821 }
822
823 frexpr(lp);
824 frexpr(rp);
825 ckfree(qq);
826 return(resp);
827 }
828
829
830 LOCAL NODE *
831 putcxcmp(struct bigblock *p)
832 {
833 NODE *p1;
834 int opcode;
835 struct bigblock *lp, *rp;
836 struct bigblock *q;
837
838 opcode = p->b_expr.opcode;
839 lp = putcx1(p->b_expr.leftp);
840 rp = putcx1(p->b_expr.rightp);
841
842 q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
843 mkexpr(opcode, realpart(lp), realpart(rp)),
844 mkexpr(opcode, imagpart(lp), imagpart(rp)) );
845 p1 = putx( fixexpr(q) );
846
847 ckfree(lp);
848 ckfree(rp);
849 ckfree(p);
850 return p1;
851 }
852
853 LOCAL struct bigblock *
854 putch1(bigptr p)
855 {
856 struct bigblock *t;
857
858 switch(p->tag) {
859 case TCONST:
860 return( putconst(p) );
861
862 case TADDR:
863 return(p);
864
865 case TEXPR:
866 switch(p->b_expr.opcode) {
867 case OPCALL:
868 case OPCCALL:
869 t = putcall(p);
870 sendp2(callval);
871 break;
872
873 case OPCONCAT:
874 t = fmktemp(TYCHAR, cpexpr(p->vleng) );
875 sendp2(putcat( cpexpr(t), p ));
876 break;
877
878 case OPCONV:
879 if(!ISICON(p->vleng) ||
880 p->vleng->b_const.fconst.ci!=1
881 || ! XINT(p->b_expr.leftp->vtype) )
882 fatal("putch1: bad character conversion");
883 t = fmktemp(TYCHAR, MKICON(1) );
884 sendp2(putassign( cpexpr(t), p));
885 break;
886 default:
887 fatal1("putch1: invalid opcode %d", p->b_expr.opcode);
888 t = NULL; /* XXX gcc */
889 }
890 return(t);
891
892 default:
893 fatal1("putch1: bad tag %d", p->tag);
894 }
895 /* NOTREACHED */
896 return NULL; /* XXX gcc */
897 }
898 \f
899
900
901
902 LOCAL NODE *
903 putchop(bigptr p)
904 {
905 NODE *p1;
906
907 p1 = putaddr( putch1(p) , NO );
908 return p1;
909 }
910
911
912 /*
913 * Assign a character to another.
914 */
915 LOCAL NODE *
916 putcheq(struct bigblock *p)
917 {
918 NODE *p1, *p2, *p3;
919
920 if( p->b_expr.rightp->tag==TEXPR &&
921 p->b_expr.rightp->b_expr.opcode==OPCONCAT )
922 p3 = putcat(p->b_expr.leftp, p->b_expr.rightp);
923 else if( ISONE(p->b_expr.leftp->vleng) &&
924 ISONE(p->b_expr.rightp->vleng) ) {
925 p1 = putaddr( putch1(p->b_expr.leftp) , YES );
926 p2 = putaddr( putch1(p->b_expr.rightp) , YES );
927 p3 = mkbinode(ASSIGN, p1, p2, CHAR);
928 } else
929 p3 = putx(call2(TYINT, "s_copy",
930 p->b_expr.leftp, p->b_expr.rightp));
931
932 frexpr(p->vleng);
933 ckfree(p);
934 return p3;
935 }
936
937
938
939 /*
940 * Compare character(s) code.
941 */
942 LOCAL NODE *
943 putchcmp(struct bigblock *p)
944 {
945 NODE *p1, *p2, *p3;
946
947 if(ISONE(p->b_expr.leftp->vleng) && ISONE(p->b_expr.rightp->vleng) ) {
948 p1 = putaddr( putch1(p->b_expr.leftp) , YES );
949 p2 = putaddr( putch1(p->b_expr.rightp) , YES );
950 p3 = mkbinode(ops2[p->b_expr.opcode], p1, p2, CHAR);
951 ckfree(p);
952 } else {
953 p->b_expr.leftp = call2(TYINT,"s_cmp",
954 p->b_expr.leftp, p->b_expr.rightp);
955 p->b_expr.rightp = MKICON(0);
956 p3 = putop(p);
957 }
958 return p3;
959 }
960
961 LOCAL NODE *
962 putcat(bigptr lhs, bigptr rhs)
963 {
964 NODE *p3;
965 int n;
966 struct bigblock *lp, *cp;
967
968 n = ncat(rhs);
969 lp = mktmpn(n, TYLENG, NULL);
970 cp = mktmpn(n, TYADDR, NULL);
971
972 n = 0;
973 putct1(rhs, lp, cp, &n);
974
975 p3 = putx( call4(TYSUBR, "s_cat", lhs, cp, lp, MKICON(n) ) );
976 return p3;
977 }
978
979 LOCAL int
980 ncat(bigptr p)
981 {
982 if(p->tag==TEXPR && p->b_expr.opcode==OPCONCAT)
983 return( ncat(p->b_expr.leftp) + ncat(p->b_expr.rightp) );
984 else
985 return(1);
986 }
987
988 LOCAL void
989 putct1(bigptr q, bigptr lp, bigptr cp, int *ip)
990 {
991 NODE *p;
992 int i;
993 struct bigblock *lp1, *cp1;
994
995 if(q->tag==TEXPR && q->b_expr.opcode==OPCONCAT) {
996 putct1(q->b_expr.leftp, lp, cp, ip);
997 putct1(q->b_expr.rightp, lp, cp , ip);
998 frexpr(q->vleng);
999 ckfree(q);
1000 } else {
1001 i = (*ip)++;
1002 lp1 = cpexpr(lp);
1003 lp1->b_addr.memoffset =
1004 mkexpr(OPPLUS, lp1->b_addr.memoffset, MKICON(i*FSZLENG));
1005 cp1 = cpexpr(cp);
1006 cp1->b_addr.memoffset =
1007 mkexpr(OPPLUS, cp1->b_addr.memoffset, MKICON(i*FSZADDR));
1008 p = putassign( lp1, cpexpr(q->vleng) );
1009 sendp2(p);
1010 p = putassign( cp1, addrof(putch1(q)) );
1011 sendp2(p);
1012 }
1013 }
1014
1015 /*
1016 * Create a tree that can later be converted to an OREG.
1017 */
1018 static NODE *
1019 oregtree(int off, int reg, int type)
1020 {
1021 NODE *p, *q;
1022
1023 p = mklnode(REG, 0, reg, INCREF(type));
1024 q = mklnode(ICON, off, 0, INT);
1025 return mkunode(UMUL, mkbinode(PLUS, p, q, INCREF(type)), 0, type);
1026 }
1027
1028 static NODE *
1029 putaddr(bigptr q, int indir)
1030 {
1031 int type, type2, funct;
1032 NODE *p, *p1, *p2;
1033 ftnint offset;
1034 bigptr offp;
1035
1036 p = p1 = p2 = NULL; /* XXX */
1037
1038 type = q->vtype;
1039 type2 = types2[type];
1040 funct = (q->vclass==CLPROC ? FTN<<TSHIFT : 0);
1041
1042 offp = (q->b_addr.memoffset ? cpexpr(q->b_addr.memoffset) : NULL);
1043
1044 offset = simoffset(&offp);
1045 if(offp)
1046 offp = mkconv(TYINT, offp);
1047
1048 switch(q->vstg) {
1049 case STGAUTO:
1050 if(indir && !offp) {
1051 p = oregtree(offset, AUTOREG, type2);
1052 break;
1053 }
1054
1055 if(!indir && !offp && !offset) {
1056 p = mklnode(REG, 0, AUTOREG, INCREF(type2));
1057 break;
1058 }
1059
1060 p = mklnode(REG, 0, AUTOREG, INCREF(type2));
1061 if(offp) {
1062 p1 = putx(offp);
1063 if(offset)
1064 p2 = mklnode(ICON, offset, 0, INT);
1065 } else
1066 p1 = mklnode(ICON, offset, 0, INT);
1067 if (offp && offset)
1068 p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
1069 p = mkbinode(PLUS, p, p1, INCREF(type2));
1070 if (indir)
1071 p = mkunode(UMUL, p, 0, type2);
1072 break;
1073
1074 case STGARG:
1075 p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
1076 ARGREG, INCREF(type2)|funct);
1077
1078 if (offp)
1079 p1 = putx(offp);
1080 if (offset)
1081 p2 = mklnode(ICON, offset, 0, INT);
1082 if (offp && offset)
1083 p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
1084 else if (offset)
1085 p1 = p2;
1086 if (offp || offset)
1087 p = mkbinode(PLUS, p, p1, INCREF(type2));
1088 if (indir)
1089 p = mkunode(UMUL, p, 0, type2);
1090 break;
1091
1092 case STGLENG:
1093 if(indir) {
1094 p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
1095 ARGREG, INCREF(type2)|funct);
1096 } else {
1097 fatal1("faddrnode: STGLENG: fixme!");
1098 #if 0
1099 p2op(P2PLUS, types2[TYLENG] | P2PTR );
1100 p2reg(ARGREG, types2[TYLENG] | P2PTR );
1101 p2icon( ARGOFFSET +
1102 (ftnint) (FUDGEOFFSET*p->b_addr.memno), P2INT);
1103 #endif
1104 }
1105 break;
1106
1107
1108 case STGBSS:
1109 case STGINIT:
1110 case STGEXT:
1111 case STGCOMMON:
1112 case STGEQUIV:
1113 case STGCONST:
1114 if(offp) {
1115 p1 = putx(offp);
1116 p2 = putmem(q, ICON, offset);
1117 p = mkbinode(PLUS, p1, p2, INCREF(type2));
1118 if(indir)
1119 p = mkunode(UMUL, p, 0, type2);
1120 } else
1121 p = putmem(q, (indir ? NAME : ICON), offset);
1122 break;
1123
1124 case STGREG:
1125 if(indir)
1126 p = mklnode(REG, 0, q->b_addr.memno, type2);
1127 else
1128 fatal("attempt to take address of a register");
1129 break;
1130
1131 default:
1132 fatal1("putaddr: invalid vstg %d", q->vstg);
1133 }
1134 frexpr(q);
1135 return p;
1136 }
1137
1138 NODE *
1139 putmem(bigptr q, int class, ftnint offset)
1140 {
1141 NODE *p;
1142 int type2;
1143
1144 type2 = types2[q->vtype];
1145 if(q->vclass == CLPROC)
1146 type2 |= (FTN<<TSHIFT);
1147 if (class == ICON)
1148 type2 |= PTR;
1149 p = mklnode(class, offset, 0, type2);
1150 p->n_name = copys(memname(q->vstg, q->b_addr.memno));
1151 return p;
1152 }
1153
1154
1155 \f
1156 LOCAL struct bigblock *
1157 putcall(struct bigblock *qq)
1158 {
1159 chainp arglist, charsp, cp;
1160 int n, first;
1161 struct bigblock *t;
1162 struct bigblock *q;
1163 struct bigblock *fval;
1164 int type, type2, ctype, indir;
1165 NODE *lp, *p1, *p2;
1166
1167 lp = p2 = NULL; /* XXX */
1168
1169 type2 = types2[type = qq->vtype];
1170 charsp = NULL;
1171 indir = (qq->b_expr.opcode == OPCCALL);
1172 n = 0;
1173 first = YES;
1174
1175 if(qq->b_expr.rightp) {
1176 arglist = qq->b_expr.rightp->b_list.listp;
1177 ckfree(qq->b_expr.rightp);
1178 } else
1179 arglist = NULL;
1180
1181 for(cp = arglist ; cp ; cp = cp->chain.nextp)
1182 if(indir) {
1183 ++n;
1184 } else {
1185 q = cp->chain.datap;
1186 if(q->tag == TCONST)
1187 cp->chain.datap = q = putconst(q);
1188 if( ISCHAR(q) ) {
1189 charsp = hookup(charsp,
1190 mkchain(cpexpr(q->vleng), 0) );
1191 n += 2;
1192 } else if(q->vclass == CLPROC) {
1193 charsp = hookup(charsp,
1194 mkchain( MKICON(0) , 0));
1195 n += 2;
1196 } else
1197 n += 1;
1198 }
1199
1200 if(type == TYCHAR) {
1201 if( ISICON(qq->vleng) ) {
1202 fval = fmktemp(TYCHAR, qq->vleng);
1203 n += 2;
1204 } else {
1205 err("adjustable character function");
1206 return NULL;
1207 }
1208 } else if(ISCOMPLEX(type)) {
1209 fval = fmktemp(type, NULL);
1210 n += 1;
1211 } else
1212 fval = NULL;
1213
1214 ctype = (fval ? P2INT : type2);
1215 p1 = putaddr(qq->b_expr.leftp, NO);
1216
1217 if(fval) {
1218 first = NO;
1219 lp = putaddr( cpexpr(fval), NO);
1220 if(type==TYCHAR)
1221 lp = mkbinode(CM, lp, putx(cpexpr(qq->vleng)), INT);
1222 }
1223
1224 for(cp = arglist ; cp ; cp = cp->chain.nextp) {
1225 q = cp->chain.datap;
1226 if(q->tag==TADDR && (indir || q->vstg!=STGREG) )
1227 p2 = putaddr(q, indir && q->vtype!=TYCHAR);
1228 else if( ISCOMPLEX(q->vtype) )
1229 p2 = putcxop(q);
1230 else if (ISCHAR(q) ) {
1231 p2 = putchop(q);
1232 } else if( ! ISERROR(q) ) {
1233 if(indir)
1234 p2 = putx(q);
1235 else {
1236 t = fmktemp(q->vtype, q->vleng);
1237 p2 = putassign( cpexpr(t), q );
1238 sendp2(p2);
1239 p2 = putaddr(t, NO);
1240 }
1241 }
1242 if(first) {
1243 first = NO;
1244 lp = p2;
1245 } else
1246 lp = mkbinode(CM, lp, p2, INT);
1247 }
1248
1249 if(arglist)
1250 frchain(&arglist);
1251 for(cp = charsp ; cp ; cp = cp->chain.nextp) {
1252 p2 = putx( mkconv(TYLENG,cp->chain.datap) );
1253 lp = mkbinode(CM, lp, p2, INT);
1254 }
1255 frchain(&charsp);
1256 if (n > 0)
1257 callval = mkbinode(CALL, p1, lp, ctype);
1258 else
1259 callval = mkunode(UCALL, p1, 0, ctype);
1260 ckfree(qq);
1261 return(fval);
1262 }
1263
1264 /*
1265 * Write out code to do min/max calculations.
1266 * Note that these operators may have multiple arguments in fortran.
1267 */
1268 LOCAL NODE *
1269 putmnmx(struct bigblock *p)
1270 {
1271 NODE *n1, *n2;
1272 int op, type, lab;
1273 chainp p0, p1;
1274 struct bigblock *tp;
1275
1276 type = p->vtype;
1277 op = (p->b_expr.opcode==OPMIN ? LT : GT );
1278 p0 = p->b_expr.leftp->b_list.listp;
1279 ckfree(p->b_expr.leftp);
1280 ckfree(p);
1281
1282 /*
1283 * Store first value in a temporary, then compare it with
1284 * each following value and save that if needed.
1285 */
1286 tp = fmktemp(type, NULL);
1287 sendp2(putassign(cpexpr(tp), p0->chain.datap));
1288
1289 for(p1 = p0->chain.nextp ; p1 ; p1 = p1->chain.nextp) {
1290 n1 = putx(cpexpr(tp));
1291 n2 = putx(cpexpr(p1->chain.datap));
1292 lab = newlabel();
1293 sendp2(mkbinode(CBRANCH, mkbinode(op, n1, n2, INT),
1294 mklnode(ICON, lab, 0, INT), INT));
1295 sendp2(putassign(cpexpr(tp), p1->chain.datap));
1296 putlabel(lab);
1297 }
1298 return putx(tp);
1299 }
1300
1301 ftnint
1302 simoffset(bigptr *p0)
1303 {
1304 ftnint offset, prod;
1305 bigptr p, lp, rp;
1306
1307 offset = 0;
1308 p = *p0;
1309 if(p == NULL)
1310 return(0);
1311
1312 if( ! ISINT(p->vtype) )
1313 return(0);
1314
1315 if(p->tag==TEXPR && p->b_expr.opcode==OPSTAR) {
1316 lp = p->b_expr.leftp;
1317 rp = p->b_expr.rightp;
1318 if(ISICON(rp) && lp->tag==TEXPR &&
1319 lp->b_expr.opcode==OPPLUS && ISICON(lp->b_expr.rightp)) {
1320 p->b_expr.opcode = OPPLUS;
1321 lp->b_expr.opcode = OPSTAR;
1322 prod = rp->b_const.fconst.ci *
1323 lp->b_expr.rightp->b_const.fconst.ci;
1324 lp->b_expr.rightp->b_const.fconst.ci =
1325 rp->b_const.fconst.ci;
1326 rp->b_const.fconst.ci = prod;
1327 }
1328 }
1329
1330 if(p->tag==TEXPR && p->b_expr.opcode==OPPLUS &&
1331 ISICON(p->b_expr.rightp)) {
1332 rp = p->b_expr.rightp;
1333 lp = p->b_expr.leftp;
1334 offset += rp->b_const.fconst.ci;
1335 frexpr(rp);
1336 ckfree(p);
1337 *p0 = lp;
1338 }
1339
1340 if(p->tag == TCONST) {
1341 offset += p->b_const.fconst.ci;
1342 frexpr(p);
1343 *p0 = NULL;
1344 }
1345
1346 return(offset);
1347 }
1348
1349 /*
1350 * F77 uses ckalloc() (malloc) for NODEs.
1351 */
1352 NODE *
1353 talloc()
1354 {
1355 NODE *p = ckalloc(sizeof(NODE));
1356 p->n_name = "";
1357 return p;
1358 }
1359
1360 #ifdef PCC_DEBUG
1361 static char *tagnam[] = {
1362 "NONE", "NAME", "CONST", "EXPR", "ADDR", "PRIM", "LIST", "IMPLDO", "ERROR",
1363 };
1364 static char *typnam[] = {
1365 "unknown", "addr", "short", "long", "real", "dreal", "complex", "dcomplex",
1366 "logical", "char", "subr", "error",
1367 };
1368 static char *classnam[] = {
1369 "unknown", "param", "var", "entry", "main", "block", "proc",
1370 };
1371 static char *stgnam[] = {
1372 "unknown", "arg", "auto", "bss", "init", "const", "intr", "stfunct",
1373 "common", "equiv", "reg", "leng",
1374 };
1375
1376
1377 /*
1378 * Print out a f77 tree, for diagnostic purposes.
1379 */
1380 void
1381 fprint(bigptr p, int indx)
1382 {
1383 extern char *ops[];
1384 int x = indx;
1385 bigptr lp, rp;
1386 struct chain *bp;
1387
1388 if (p == NULL)
1389 return;
1390
1391 while (x >= 2) {
1392 putchar('\t');
1393 x -= 2;
1394 }
1395 if (x--)
1396 printf(" " );
1397 printf("%p) %s, ", p, tagnam[p->tag]);
1398 if (p->vtype)
1399 printf("type=%s, ", typnam[p->vtype]);
1400 if (p->vclass)
1401 printf("class=%s, ", classnam[p->vclass]);
1402 if (p->vstg)
1403 printf("stg=%s, ", stgnam[p->vstg]);
1404
1405 lp = rp = NULL;
1406 switch (p->tag) {
1407 case TEXPR:
1408 printf("OP %s\n", ops[p->b_expr.opcode]);
1409 lp = p->b_expr.leftp;
1410 rp = p->b_expr.rightp;
1411 break;
1412 case TADDR:
1413 printf("memno=%d\n", p->b_addr.memno);
1414 lp = p->vleng;
1415 rp = p->b_addr.memoffset;
1416 break;
1417 case TCONST:
1418 switch (p->vtype) {
1419 case TYSHORT:
1420 case TYLONG:
1421 case TYLOGICAL:
1422 case TYADDR:
1423 printf("val=%ld\n", p->b_const.fconst.ci);
1424 break;
1425 case TYCHAR:
1426 lp = p->vleng;
1427 printf("\n");
1428 break;
1429 }
1430 break;
1431 case TPRIM:
1432 lp = p->b_prim.namep;
1433 rp = p->b_prim.argsp;
1434 printf("fcharp=%p, lcharp=%p\n", p->b_prim.fcharp, p->b_prim.lcharp);
1435 break;
1436 case TNAME:
1437 printf("name=%s\n", p->b_name.varname);
1438 break;
1439 case TLIST:
1440 printf("\n");
1441 for (bp = &p->b_list.listp->chain; bp; bp = &bp->nextp->chain)
1442 fprint(bp->datap, indx+1);
1443 break;
1444 default:
1445 printf("\n");
1446 }
1447
1448 fprint(lp, indx+1);
1449 fprint(rp, indx+1);
1450 }
1451 #endif