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