1 /* $Id: expr.c,v 1.20 2008/05/11 15:28:03 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 conditionsand 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 #include <string.h>
36
37 #include "defines.h"
38 #include "defs.h"
39
40 /* little routines to create constant blocks */
41 LOCAL int letter(int c);
42 LOCAL void conspower(union constant *, struct bigblock *, ftnint);
43 LOCAL void consbinop(int, int, union constant *, union constant *,
44 union constant *);
45 LOCAL void zdiv(struct dcomplex *, struct dcomplex *, struct dcomplex *);
46 LOCAL struct bigblock *stfcall(struct bigblock *, struct bigblock *);
47 LOCAL bigptr mkpower(struct bigblock *p);
48 LOCAL bigptr fold(struct bigblock *e);
49 LOCAL bigptr subcheck(struct bigblock *, bigptr);
50
mkconst(t)51 struct bigblock *mkconst(t)
52 register int t;
53 {
54 register struct bigblock *p;
55
56 p = BALLO();
57 p->tag = TCONST;
58 p->vtype = t;
59 return(p);
60 }
61
62
mklogcon(l)63 struct bigblock *mklogcon(l)
64 register int l;
65 {
66 register struct bigblock * p;
67
68 p = mkconst(TYLOGICAL);
69 p->b_const.fconst.ci = l;
70 return(p);
71 }
72
73
74
mkintcon(l)75 struct bigblock *mkintcon(l)
76 ftnint l;
77 {
78 register struct bigblock *p;
79
80 p = mkconst(TYLONG);
81 p->b_const.fconst.ci = l;
82 #ifdef MAXSHORT
83 if(l >= -MAXSHORT && l <= MAXSHORT)
84 p->vtype = TYSHORT;
85 #endif
86 return(p);
87 }
88
89
90
mkaddcon(l)91 struct bigblock *mkaddcon(l)
92 register int l;
93 {
94 register struct bigblock *p;
95
96 p = mkconst(TYADDR);
97 p->b_const.fconst.ci = l;
98 return(p);
99 }
100
101
102
mkrealcon(t,d)103 struct bigblock *mkrealcon(t, d)
104 register int t;
105 double d;
106 {
107 register struct bigblock *p;
108
109 p = mkconst(t);
110 p->b_const.fconst.cd[0] = d;
111 return(p);
112 }
113
114
mkbitcon(shift,leng,s)115 struct bigblock *mkbitcon(shift, leng, s)
116 int shift;
117 int leng;
118 char *s;
119 {
120 register struct bigblock *p;
121
122 p = mkconst(TYUNKNOWN);
123 p->b_const.fconst.ci = 0;
124 while(--leng >= 0)
125 if(*s != ' ')
126 p->b_const.fconst.ci = (p->b_const.fconst.ci << shift) | hextoi(*s++);
127 return(p);
128 }
129
130
131
132
133
mkstrcon(l,v)134 struct bigblock *mkstrcon(l,v)
135 int l;
136 register char *v;
137 {
138 register struct bigblock *p;
139 register char *s;
140
141 p = mkconst(TYCHAR);
142 p->vleng = MKICON(l);
143 p->b_const.fconst.ccp = s = (char *) ckalloc(l);
144 while(--l >= 0)
145 *s++ = *v++;
146 return(p);
147 }
148
149
mkcxcon(realp,imagp)150 struct bigblock *mkcxcon(realp,imagp)
151 register bigptr realp, imagp;
152 {
153 int rtype, itype;
154 register struct bigblock *p;
155
156 rtype = realp->vtype;
157 itype = imagp->vtype;
158
159 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
160 {
161 p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
162 if( ISINT(rtype) )
163 p->b_const.fconst.cd[0] = realp->b_const.fconst.ci;
164 else p->b_const.fconst.cd[0] = realp->b_const.fconst.cd[0];
165 if( ISINT(itype) )
166 p->b_const.fconst.cd[1] = imagp->b_const.fconst.ci;
167 else p->b_const.fconst.cd[1] = imagp->b_const.fconst.cd[0];
168 }
169 else
170 {
171 err("invalid complex constant");
172 p = errnode();
173 }
174
175 frexpr(realp);
176 frexpr(imagp);
177 return(p);
178 }
179
180
errnode()181 struct bigblock *errnode()
182 {
183 struct bigblock *p;
184 p = BALLO();
185 p->tag = TERROR;
186 p->vtype = TYERROR;
187 return(p);
188 }
189
190
191
192
193
mkconv(t,p)194 bigptr mkconv(t, p)
195 register int t;
196 register bigptr p;
197 {
198 register bigptr q;
199
200 if(t==TYUNKNOWN || t==TYERROR)
201 fatal1("mkconv of impossible type %d", t);
202 if(t == p->vtype)
203 return(p);
204
205 else if( ISCONST(p) && p->vtype!=TYADDR)
206 {
207 q = mkconst(t);
208 consconv(t, &(q->b_const.fconst), p->vtype, &(p->b_const.fconst));
209 frexpr(p);
210 }
211 else
212 {
213 q = mkexpr(OPCONV, p, 0);
214 q->vtype = t;
215 }
216 return(q);
217 }
218
219
220
addrof(p)221 struct bigblock *addrof(p)
222 bigptr p;
223 {
224 return( mkexpr(OPADDR, p, NULL) );
225 }
226
227
228
229 bigptr
cpexpr(p)230 cpexpr(p)
231 register bigptr p;
232 {
233 register bigptr e;
234 int tag;
235 register chainp ep, pp;
236
237 #if 0
238 static int blksize[ ] = { 0, sizeof(struct nameblock), sizeof(struct constblock),
239 sizeof(struct exprblock), sizeof(struct addrblock),
240 sizeof(struct primblock), sizeof(struct listblock),
241 sizeof(struct errorblock)
242 };
243 #endif
244
245 if(p == NULL)
246 return(NULL);
247
248 if( (tag = p->tag) == TNAME)
249 return(p);
250
251 #if 0
252 e = cpblock( blksize[p->tag] , p);
253 #else
254 e = cpblock( sizeof(struct bigblock) , p);
255 #endif
256
257 switch(tag)
258 {
259 case TCONST:
260 if(e->vtype == TYCHAR)
261 {
262 e->b_const.fconst.ccp = copyn(1+strlen(e->b_const.fconst.ccp), e->b_const.fconst.ccp);
263 e->vleng = cpexpr(e->vleng);
264 }
265 case TERROR:
266 break;
267
268 case TEXPR:
269 e->b_expr.leftp = cpexpr(p->b_expr.leftp);
270 e->b_expr.rightp = cpexpr(p->b_expr.rightp);
271 break;
272
273 case TLIST:
274 if((pp = p->b_list.listp))
275 {
276 ep = e->b_list.listp = mkchain( cpexpr(pp->chain.datap), NULL);
277 for(pp = pp->chain.nextp ; pp ; pp = pp->chain.nextp)
278 ep = ep->chain.nextp = mkchain( cpexpr(pp->chain.datap), NULL);
279 }
280 break;
281
282 case TADDR:
283 e->vleng = cpexpr(e->vleng);
284 e->b_addr.memoffset = cpexpr(e->b_addr.memoffset);
285 e->b_addr.istemp = NO;
286 break;
287
288 case TPRIM:
289 e->b_prim.argsp = cpexpr(e->b_prim.argsp);
290 e->b_prim.fcharp = cpexpr(e->b_prim.fcharp);
291 e->b_prim.lcharp = cpexpr(e->b_prim.lcharp);
292 break;
293
294 default:
295 fatal1("cpexpr: impossible tag %d", tag);
296 }
297
298 return(e);
299 }
300
301 void
frexpr(p)302 frexpr(p)
303 register bigptr p;
304 {
305 register chainp q;
306
307 if(p == NULL)
308 return;
309
310 switch(p->tag)
311 {
312 case TCONST:
313 if( ISCHAR(p) )
314 {
315 ckfree(p->b_const.fconst.ccp);
316 frexpr(p->vleng);
317 }
318 break;
319
320 case TADDR:
321 if(p->b_addr.istemp)
322 {
323 frtemp(p);
324 return;
325 }
326 frexpr(p->vleng);
327 frexpr(p->b_addr.memoffset);
328 break;
329
330 case TERROR:
331 break;
332
333 case TNAME:
334 return;
335
336 case TPRIM:
337 frexpr(p->b_prim.argsp);
338 frexpr(p->b_prim.fcharp);
339 frexpr(p->b_prim.lcharp);
340 break;
341
342 case TEXPR:
343 frexpr(p->b_expr.leftp);
344 if(p->b_expr.rightp)
345 frexpr(p->b_expr.rightp);
346 break;
347
348 case TLIST:
349 for(q = p->b_list.listp ; q ; q = q->chain.nextp)
350 frexpr(q->chain.datap);
351 frchain( &(p->b_list.listp) );
352 break;
353
354 default:
355 fatal1("frexpr: impossible tag %d", p->tag);
356 }
357
358 ckfree(p);
359 }
360
361 /* fix up types in expression; replace subtrees and convert
362 names to address blocks */
363
fixtype(p)364 bigptr fixtype(p)
365 register bigptr p;
366 {
367
368 if(p == 0)
369 return(0);
370
371 switch(p->tag)
372 {
373 case TCONST:
374 if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
375 p = putconst(p);
376 return(p);
377
378 case TADDR:
379 p->b_addr.memoffset = fixtype(p->b_addr.memoffset);
380 return(p);
381
382 case TERROR:
383 return(p);
384
385 default:
386 fatal1("fixtype: impossible tag %d", p->tag);
387
388 case TEXPR:
389 return( fixexpr(p) );
390
391 case TLIST:
392 return( p );
393
394 case TPRIM:
395 if(p->b_prim.argsp && p->b_prim.namep->vclass!=CLVAR)
396 return( mkfunct(p) );
397 else return( mklhs(p) );
398 }
399 }
400
401
402
403
404
405 /* special case tree transformations and cleanups of expression trees */
406
fixexpr(p)407 bigptr fixexpr(p)
408 register struct bigblock *p;
409 {
410 bigptr lp;
411 register bigptr rp;
412 register bigptr q;
413 int opcode, ltype, rtype, ptype, mtype;
414
415 if(p->tag == TERROR)
416 return(p);
417 else if(p->tag != TEXPR)
418 fatal1("fixexpr: invalid tag %d", p->tag);
419 opcode = p->b_expr.opcode;
420 lp = p->b_expr.leftp = fixtype(p->b_expr.leftp);
421 ltype = lp->vtype;
422 if(opcode==OPASSIGN && lp->tag!=TADDR)
423 {
424 err("left side of assignment must be variable");
425 frexpr(p);
426 return( errnode() );
427 }
428
429 if(p->b_expr.rightp)
430 {
431 rp = p->b_expr.rightp = fixtype(p->b_expr.rightp);
432 rtype = rp->vtype;
433 }
434 else
435 {
436 rp = NULL;
437 rtype = 0;
438 }
439
440 /* force folding if possible */
441 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
442 {
443 q = mkexpr(opcode, lp, rp);
444 if( ISCONST(q) )
445 return(q);
446 ckfree(q); /* constants did not fold */
447 }
448
449 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
450 {
451 frexpr(p);
452 return( errnode() );
453 }
454
455 switch(opcode)
456 {
457 case OPCONCAT:
458 if(p->vleng == NULL)
459 p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
460 cpexpr(rp->vleng) );
461 break;
462
463 case OPASSIGN:
464 if(ltype == rtype)
465 break;
466 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
467 break;
468 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
469 break;
470 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
471 && typesize[ltype]>=typesize[rtype] )
472 break;
473 p->b_expr.rightp = fixtype( mkconv(ptype, rp) );
474 break;
475
476 case OPSLASH:
477 if( ISCOMPLEX(rtype) )
478 {
479 p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
480 mkconv(ptype, lp), mkconv(ptype, rp) );
481 break;
482 }
483 case OPPLUS:
484 case OPMINUS:
485 case OPSTAR:
486 case OPMOD:
487 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
488 (rtype==TYREAL && ! ISCONST(rp) ) ))
489 break;
490 if( ISCOMPLEX(ptype) )
491 break;
492 if(ltype != ptype)
493 p->b_expr.leftp = fixtype(mkconv(ptype,lp));
494 if(rtype != ptype)
495 p->b_expr.rightp = fixtype(mkconv(ptype,rp));
496 break;
497
498 case OPPOWER:
499 return( mkpower(p) );
500
501 case OPLT:
502 case OPLE:
503 case OPGT:
504 case OPGE:
505 case OPEQ:
506 case OPNE:
507 if(ltype == rtype)
508 break;
509 mtype = cktype(OPMINUS, ltype, rtype);
510 if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
511 (rtype==TYREAL && ! ISCONST(rp)) ))
512 break;
513 if( ISCOMPLEX(mtype) )
514 break;
515 if(ltype != mtype)
516 p->b_expr.leftp = fixtype(mkconv(mtype,lp));
517 if(rtype != mtype)
518 p->b_expr.rightp = fixtype(mkconv(mtype,rp));
519 break;
520
521
522 case OPCONV:
523 ptype = cktype(OPCONV, p->vtype, ltype);
524 if(lp->tag==TEXPR && lp->b_expr.opcode==OPCOMMA)
525 {
526 lp->b_expr.rightp = fixtype( mkconv(ptype, lp->b_expr.rightp) );
527 ckfree(p);
528 p = lp;
529 }
530 break;
531
532 case OPADDR:
533 if(lp->tag==TEXPR && lp->b_expr.opcode==OPADDR)
534 fatal("addr of addr");
535 break;
536
537 case OPCOMMA:
538 break;
539
540 case OPMIN:
541 case OPMAX:
542 ptype = p->vtype;
543 break;
544
545 default:
546 break;
547 }
548
549 p->vtype = ptype;
550 return(p);
551 }
552
553 #if SZINT < SZLONG
554 /*
555 for efficient subscripting, replace long ints by shorts
556 in easy places
557 */
558
shorten(p)559 bigptr shorten(p)
560 register bigptr p;
561 {
562 register bigptr q;
563
564 if(p->vtype != TYLONG)
565 return(p);
566
567 switch(p->tag)
568 {
569 case TERROR:
570 case TLIST:
571 return(p);
572
573 case TCONST:
574 case TADDR:
575 return( mkconv(TYINT,p) );
576
577 case TEXPR:
578 break;
579
580 default:
581 fatal1("shorten: invalid tag %d", p->tag);
582 }
583
584 switch(p->opcode)
585 {
586 case OPPLUS:
587 case OPMINUS:
588 case OPSTAR:
589 q = shorten( cpexpr(p->rightp) );
590 if(q->vtype == TYINT)
591 {
592 p->leftp = shorten(p->leftp);
593 if(p->leftp->vtype == TYLONG)
594 frexpr(q);
595 else
596 {
597 frexpr(p->rightp);
598 p->rightp = q;
599 p->vtype = TYINT;
600 }
601 }
602 break;
603
604 case OPNEG:
605 p->leftp = shorten(p->leftp);
606 if(p->leftp->vtype == TYINT)
607 p->vtype = TYINT;
608 break;
609
610 case OPCALL:
611 case OPCCALL:
612 p = mkconv(TYINT,p);
613 break;
614 default:
615 break;
616 }
617
618 return(p);
619 }
620 #endif
621
622 int
fixargs(doput,p0)623 fixargs(doput, p0)
624 int doput;
625 struct bigblock *p0;
626 {
627 register chainp p;
628 register bigptr q, t;
629 register int qtag;
630 int nargs;
631
632 nargs = 0;
633 if(p0)
634 for(p = p0->b_list.listp ; p ; p = p->chain.nextp)
635 {
636 ++nargs;
637 q = p->chain.datap;
638 qtag = q->tag;
639 if(qtag == TCONST)
640 {
641 if(q->vtype == TYSHORT)
642 q = mkconv(tyint, q);
643 if(doput)
644 p->chain.datap = putconst(q);
645 else
646 p->chain.datap = q;
647 }
648 else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->vclass==CLPROC)
649 p->chain.datap = mkaddr(q->b_prim.namep);
650 else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdim!=NULL)
651 p->chain.datap = mkscalar(q->b_prim.namep);
652 else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdovar &&
653 (t = memversion(q->b_prim.namep)) )
654 p->chain.datap = fixtype(t);
655 else p->chain.datap = fixtype(q);
656 }
657 return(nargs);
658 }
659
660 struct bigblock *
mkscalar(np)661 mkscalar(np)
662 register struct bigblock *np;
663 {
664 register struct bigblock *ap;
665
666 vardcl(np);
667 ap = mkaddr(np);
668
669 #ifdef __vax__
670 /* on the VAX, prolog causes array arguments
671 to point at the (0,...,0) element, except when
672 subscript checking is on
673 */
674 if( !checksubs && np->vstg==STGARG)
675 {
676 register struct dimblock *dp;
677 dp = np->vdim;
678 frexpr(ap->memoffset);
679 ap->memoffset = mkexpr(OPSTAR, MKICON(typesize[np->vtype]),
680 cpexpr(dp->baseoffset) );
681 }
682 #endif
683 return(ap);
684 }
685
686
687
688
689
mkfunct(p)690 bigptr mkfunct(p)
691 register struct bigblock * p;
692 {
693 chainp ep;
694 struct bigblock *ap;
695 struct extsym *extp;
696 register struct bigblock *np;
697 register struct bigblock *q;
698 int k, nargs;
699 int class;
700
701 np = p->b_prim.namep;
702 class = np->vclass;
703
704 if(class == CLUNKNOWN)
705 {
706 np->vclass = class = CLPROC;
707 if(np->vstg == STGUNKNOWN)
708 {
709 if((k = intrfunct(np->b_name.varname)))
710 {
711 np->vstg = STGINTR;
712 np->b_name.vardesc.varno = k;
713 np->b_name.vprocclass = PINTRINSIC;
714 }
715 else
716 {
717 extp = mkext( varunder(VL,np->b_name.varname) );
718 extp->extstg = STGEXT;
719 np->vstg = STGEXT;
720 np->b_name.vardesc.varno = extp - extsymtab;
721 np->b_name.vprocclass = PEXTERNAL;
722 }
723 }
724 else if(np->vstg==STGARG)
725 {
726 if(np->vtype!=TYCHAR && !ftn66flag)
727 warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
728 np->b_name.vprocclass = PEXTERNAL;
729 }
730 }
731
732 if(class != CLPROC)
733 fatal1("invalid class code for function", class);
734 if(p->b_prim.fcharp || p->b_prim.lcharp)
735 {
736 err("no substring of function call");
737 goto error;
738 }
739 impldcl(np);
740 nargs = fixargs( np->b_name.vprocclass!=PINTRINSIC, p->b_prim.argsp);
741
742 switch(np->b_name.vprocclass)
743 {
744 case PEXTERNAL:
745 ap = mkaddr(np);
746 call:
747 q = mkexpr(OPCALL, ap, p->b_prim.argsp);
748 q->vtype = np->vtype;
749 if(np->vleng)
750 q->vleng = cpexpr(np->vleng);
751 break;
752
753 case PINTRINSIC:
754 q = intrcall(np, p->b_prim.argsp, nargs);
755 break;
756
757 case PSTFUNCT:
758 q = stfcall(np, p->b_prim.argsp);
759 break;
760
761 case PTHISPROC:
762 warn("recursive call");
763 for(ep = entries ; ep ; ep = ep->entrypoint.nextp)
764 if(ep->entrypoint.enamep == np)
765 break;
766 if(ep == NULL)
767 fatal("mkfunct: impossible recursion");
768 ap = builtin(np->vtype, varstr(XL, ep->entrypoint.entryname->extname) );
769 goto call;
770
771 default:
772 fatal1("mkfunct: impossible vprocclass %d", np->b_name.vprocclass);
773 q = 0; /* XXX gcc */
774 }
775 ckfree(p);
776 return(q);
777
778 error:
779 frexpr(p);
780 return( errnode() );
781 }
782
783
784
785 LOCAL struct bigblock *
stfcall(struct bigblock * np,struct bigblock * actlist)786 stfcall(struct bigblock *np, struct bigblock *actlist)
787 {
788 register chainp actuals;
789 int nargs;
790 chainp oactp, formals;
791 int type;
792 struct bigblock *q, *rhs;
793 bigptr ap;
794 register chainp rp;
795 chainp tlist;
796
797 if(actlist) {
798 actuals = actlist->b_list.listp;
799 ckfree(actlist);
800 } else
801 actuals = NULL;
802 oactp = actuals;
803
804 nargs = 0;
805 tlist = NULL;
806 type = np->vtype;
807
808 formals = (chainp)np->b_name.vardesc.vstfdesc->chain.datap;
809 rhs = (bigptr)np->b_name.vardesc.vstfdesc->chain.nextp;
810
811 /* copy actual arguments into temporaries */
812 while(actuals!=NULL && formals!=NULL) {
813 rp = ALLOC(rplblock);
814 rp->rplblock.rplnp = q = formals->chain.datap;
815 ap = fixtype(actuals->chain.datap);
816 if(q->vtype==ap->vtype && q->vtype!=TYCHAR
817 && (ap->tag==TCONST || ap->tag==TADDR) ) {
818 rp->rplblock.rplvp = ap;
819 rp->rplblock.rplxp = NULL;
820 rp->rplblock.rpltag = ap->tag;
821 } else {
822 rp->rplblock.rplvp = fmktemp(q->vtype, q->vleng);
823 rp->rplblock.rplxp = fixtype( mkexpr(OPASSIGN,
824 cpexpr(rp->rplblock.rplvp), ap) );
825 if( (rp->rplblock.rpltag =
826 rp->rplblock.rplxp->tag) == TERROR)
827 err("disagreement of argument types in statement function call");
828 }
829 rp->rplblock.nextp = tlist;
830 tlist = rp;
831 actuals = actuals->chain.nextp;
832 formals = formals->chain.nextp;
833 ++nargs;
834 }
835
836 if(actuals!=NULL || formals!=NULL)
837 err("statement function definition and argument list differ");
838
839 /*
840 now push down names involved in formal argument list, then
841 evaluate rhs of statement function definition in this environment
842 */
843 rpllist = hookup(tlist, rpllist);
844 q = mkconv(type, fixtype(cpexpr(rhs)) );
845
846 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
847 while(--nargs >= 0) {
848 if(rpllist->rplblock.rplxp)
849 q = mkexpr(OPCOMMA, rpllist->rplblock.rplxp, q);
850 rp = rpllist->rplblock.nextp;
851 frexpr(rpllist->rplblock.rplvp);
852 ckfree(rpllist);
853 rpllist = rp;
854 }
855
856 frchain( &oactp );
857 return(q);
858 }
859
860
861
862
863 struct bigblock *
mklhs(struct bigblock * p)864 mklhs(struct bigblock *p)
865 {
866 struct bigblock *s;
867 struct bigblock *np;
868 chainp rp;
869 int regn;
870
871 /* first fixup name */
872
873 if(p->tag != TPRIM)
874 return(p);
875
876 np = p->b_prim.namep;
877
878 /* is name on the replace list? */
879
880 for(rp = rpllist ; rp ; rp = rp->rplblock.nextp) {
881 if(np == rp->rplblock.rplnp) {
882 if(rp->rplblock.rpltag == TNAME) {
883 np = p->b_prim.namep = rp->rplblock.rplvp;
884 break;
885 } else
886 return( cpexpr(rp->rplblock.rplvp) );
887 }
888 }
889
890 /* is variable a DO index in a register ? */
891
892 if(np->b_name.vdovar && ( (regn = inregister(np)) >= 0) ) {
893 if(np->vtype == TYERROR)
894 return( errnode() );
895 else {
896 s = BALLO();
897 s->tag = TADDR;
898 s->vstg = STGREG;
899 s->vtype = TYIREG;
900 s->b_addr.memno = regn;
901 s->b_addr.memoffset = MKICON(0);
902 return(s);
903 }
904 }
905
906 vardcl(np);
907 s = mkaddr(np);
908 s->b_addr.memoffset = mkexpr(OPPLUS, s->b_addr.memoffset, suboffset(p) );
909 frexpr(p->b_prim.argsp);
910 p->b_prim.argsp = NULL;
911
912 /* now do substring part */
913
914 if(p->b_prim.fcharp || p->b_prim.lcharp) {
915 if(np->vtype != TYCHAR)
916 err1("substring of noncharacter %s",
917 varstr(VL,np->b_name.varname));
918 else {
919 if(p->b_prim.lcharp == NULL)
920 p->b_prim.lcharp = cpexpr(s->vleng);
921 if(p->b_prim.fcharp)
922 s->vleng = mkexpr(OPMINUS, p->b_prim.lcharp,
923 mkexpr(OPMINUS, p->b_prim.fcharp, MKICON(1) ));
924 else {
925 frexpr(s->vleng);
926 s->vleng = p->b_prim.lcharp;
927 }
928 }
929 }
930
931 s->vleng = fixtype( s->vleng );
932 s->b_addr.memoffset = fixtype( s->b_addr.memoffset );
933 ckfree(p);
934 return(s);
935 }
936
937
938
939
940 void
deregister(np)941 deregister(np)
942 struct bigblock *np;
943 {
944 }
945
946
947
948
memversion(np)949 struct bigblock *memversion(np)
950 register struct bigblock *np;
951 {
952 register struct bigblock *s;
953
954 if(np->b_name.vdovar==NO || (inregister(np)<0) )
955 return(NULL);
956 np->b_name.vdovar = NO;
957 s = mklhs( mkprim(np, 0,0,0) );
958 np->b_name.vdovar = YES;
959 return(s);
960 }
961
962
963 int
inregister(np)964 inregister(np)
965 register struct bigblock *np;
966 {
967 return(-1);
968 }
969
970
971
972 int
enregister(np)973 enregister(np)
974 struct bigblock *np;
975 {
976 return(NO);
977 }
978
979
980
981
suboffset(p)982 bigptr suboffset(p)
983 register struct bigblock *p;
984 {
985 int n;
986 bigptr size;
987 chainp cp;
988 bigptr offp, prod;
989 struct dimblock *dimp;
990 bigptr sub[8];
991 register struct bigblock *np;
992
993 np = p->b_prim.namep;
994 offp = MKICON(0);
995 n = 0;
996 if(p->b_prim.argsp)
997 for(cp = p->b_prim.argsp->b_list.listp ; cp ; cp = cp->chain.nextp)
998 {
999 sub[n++] = fixtype(cpexpr(cp->chain.datap));
1000 if(n > 7)
1001 {
1002 err("more than 7 subscripts");
1003 break;
1004 }
1005 }
1006
1007 dimp = np->b_name.vdim;
1008 if(n>0 && dimp==NULL)
1009 err("subscripts on scalar variable");
1010 else if(dimp && dimp->ndim!=n)
1011 err1("wrong number of subscripts on %s",
1012 varstr(VL, np->b_name.varname) );
1013 else if(n > 0)
1014 {
1015 prod = sub[--n];
1016 while( --n >= 0)
1017 prod = mkexpr(OPPLUS, sub[n],
1018 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1019 #ifdef __vax__
1020 if(checksubs || np->vstg!=STGARG)
1021 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1022 #else
1023 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1024 #endif
1025 if(checksubs)
1026 prod = subcheck(np, prod);
1027 if(np->vtype == TYCHAR)
1028 size = cpexpr(np->vleng);
1029 else size = MKICON( typesize[np->vtype] );
1030 prod = mkexpr(OPSTAR, prod, size);
1031 offp = mkexpr(OPPLUS, offp, prod);
1032 }
1033
1034 if(p->b_prim.fcharp && np->vtype==TYCHAR)
1035 offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->b_prim.fcharp), MKICON(1) ));
1036
1037 return(offp);
1038 }
1039
1040
1041 /*
1042 * Check if an array is addressed out of bounds.
1043 */
1044 bigptr
subcheck(struct bigblock * np,bigptr p)1045 subcheck(struct bigblock *np, bigptr p)
1046 {
1047 struct dimblock *dimp;
1048 bigptr t, badcall;
1049 int l1, l2;
1050
1051 dimp = np->b_name.vdim;
1052 if(dimp->nelt == NULL)
1053 return(p); /* don't check arrays with * bounds */
1054 if( ISICON(p) ) {
1055 if(p->b_const.fconst.ci < 0)
1056 goto badsub;
1057 if( ISICON(dimp->nelt) ) {
1058 if(p->b_const.fconst.ci < dimp->nelt->b_const.fconst.ci)
1059 return(p);
1060 else
1061 goto badsub;
1062 }
1063 }
1064
1065 if (p->tag==TADDR && p->vstg==STGREG) {
1066 t = p;
1067 } else {
1068 t = fmktemp(p->vtype, NULL);
1069 putexpr(mkexpr(OPASSIGN, cpexpr(t), p));
1070 }
1071 /* t now cotains evaluated expression */
1072
1073 l1 = newlabel();
1074 l2 = newlabel();
1075 putif(mkexpr(OPLT, cpexpr(t), cpexpr(dimp->nelt)), l1);
1076 putif(mkexpr(OPGE, cpexpr(t), MKICON(0)), l1);
1077 putgoto(l2);
1078 putlabel(l1);
1079
1080 badcall = call4(t->vtype, "s_rnge", mkstrcon(VL, np->b_name.varname),
1081 mkconv(TYLONG, cpexpr(t)),
1082 mkstrcon(XL, procname), MKICON(lineno));
1083 badcall->b_expr.opcode = OPCCALL;
1084
1085 putexpr(badcall);
1086 putlabel(l2);
1087 return t;
1088
1089 badsub:
1090 frexpr(p);
1091 err1("subscript on variable %s out of range",
1092 varstr(VL,np->b_name.varname));
1093 return ( MKICON(0) );
1094 }
1095
1096
1097
1098
mkaddr(p)1099 struct bigblock *mkaddr(p)
1100 register struct bigblock *p;
1101 {
1102 struct extsym *extp;
1103 register struct bigblock *t;
1104
1105 switch( p->vstg)
1106 {
1107 case STGUNKNOWN:
1108 if(p->vclass != CLPROC)
1109 break;
1110 extp = mkext( varunder(VL, p->b_name.varname) );
1111 extp->extstg = STGEXT;
1112 p->vstg = STGEXT;
1113 p->b_name.vardesc.varno = extp - extsymtab;
1114 p->b_name.vprocclass = PEXTERNAL;
1115
1116 case STGCOMMON:
1117 case STGEXT:
1118 case STGBSS:
1119 case STGINIT:
1120 case STGEQUIV:
1121 case STGARG:
1122 case STGLENG:
1123 case STGAUTO:
1124 t = BALLO();
1125 t->tag = TADDR;
1126 t->vclass = p->vclass;
1127 t->vtype = p->vtype;
1128 t->vstg = p->vstg;
1129 t->b_addr.memno = p->b_name.vardesc.varno;
1130 t->b_addr.memoffset = MKICON(p->b_name.voffset);
1131 if(p->vleng)
1132 t->vleng = cpexpr(p->vleng);
1133 return(t);
1134
1135 case STGINTR:
1136 return( intraddr(p) );
1137
1138 }
1139 /*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
1140 fatal1("mkaddr: impossible storage tag %d", p->vstg);
1141 /* NOTREACHED */
1142 return 0; /* XXX gcc */
1143 }
1144
1145
1146
1147 struct bigblock *
mkarg(type,argno)1148 mkarg(type, argno)
1149 int type, argno;
1150 {
1151 register struct bigblock *p;
1152
1153 p = BALLO();
1154 p->tag = TADDR;
1155 p->vtype = type;
1156 p->vclass = CLVAR;
1157 p->vstg = (type==TYLENG ? STGLENG : STGARG);
1158 p->b_addr.memno = argno;
1159 return(p);
1160 }
1161
1162
1163
1164
mkprim(v,args,lstr,rstr)1165 bigptr mkprim(v, args, lstr, rstr)
1166 register bigptr v;
1167 struct bigblock *args;
1168 bigptr lstr, rstr;
1169 {
1170 register struct bigblock *p;
1171
1172 if(v->vclass == CLPARAM)
1173 {
1174 if(args || lstr || rstr)
1175 {
1176 err1("no qualifiers on parameter name", varstr(VL,v->b_name.varname));
1177 frexpr(args);
1178 frexpr(lstr);
1179 frexpr(rstr);
1180 frexpr(v);
1181 return( errnode() );
1182 }
1183 return( cpexpr(v->b_param.paramval) );
1184 }
1185
1186 p = BALLO();
1187 p->tag = TPRIM;
1188 p->vtype = v->vtype;
1189 p->b_prim.namep = v;
1190 p->b_prim.argsp = args;
1191 p->b_prim.fcharp = lstr;
1192 p->b_prim.lcharp = rstr;
1193 return(p);
1194 }
1195
1196
1197 void
vardcl(v)1198 vardcl(v)
1199 register struct bigblock *v;
1200 {
1201 int nelt;
1202 struct dimblock *t;
1203 struct bigblock *p;
1204 bigptr neltp;
1205
1206 if(v->b_name.vdcldone) return;
1207
1208 if(v->vtype == TYUNKNOWN)
1209 impldcl(v);
1210 if(v->vclass == CLUNKNOWN)
1211 v->vclass = CLVAR;
1212 else if(v->vclass!=CLVAR && v->b_name.vprocclass!=PTHISPROC)
1213 {
1214 dclerr("used as variable", v);
1215 return;
1216 }
1217 if(v->vstg==STGUNKNOWN)
1218 v->vstg = implstg[ letter(v->b_name.varname[0]) ];
1219
1220 switch(v->vstg)
1221 {
1222 case STGBSS:
1223 v->b_name.vardesc.varno = ++lastvarno;
1224 break;
1225 case STGAUTO:
1226 if(v->vclass==CLPROC && v->b_name.vprocclass==PTHISPROC)
1227 break;
1228 nelt = 1;
1229 if((t = v->b_name.vdim)) {
1230 if( (neltp = t->nelt) && ISCONST(neltp) )
1231 nelt = neltp->b_const.fconst.ci;
1232 else
1233 dclerr("adjustable automatic array", v);
1234 }
1235 p = autovar(nelt, v->vtype, v->vleng);
1236 v->b_name.voffset = p->b_addr.memoffset->b_const.fconst.ci;
1237 frexpr(p);
1238 break;
1239
1240 default:
1241 break;
1242 }
1243 v->b_name.vdcldone = YES;
1244 }
1245
1246
1247
1248 void
impldcl(p)1249 impldcl(p)
1250 register struct bigblock *p;
1251 {
1252 register int k;
1253 int type, leng;
1254
1255 if(p->b_name.vdcldone || (p->vclass==CLPROC && p->b_name.vprocclass==PINTRINSIC) )
1256 return;
1257 if(p->vtype == TYUNKNOWN)
1258 {
1259 k = letter(p->b_name.varname[0]);
1260 type = impltype[ k ];
1261 leng = implleng[ k ];
1262 if(type == TYUNKNOWN)
1263 {
1264 if(p->vclass == CLPROC)
1265 return;
1266 dclerr("attempt to use undefined variable", p);
1267 type = TYERROR;
1268 leng = 1;
1269 }
1270 settype(p, type, leng);
1271 }
1272 }
1273
1274
1275
1276
1277 LOCAL int
letter(c)1278 letter(c)
1279 register int c;
1280 {
1281 if( isupper(c) )
1282 c = tolower(c);
1283 return(c - 'a');
1284 }
1285
1286 #define ICONEQ(z, c) (ISICON(z) && z->b_const.fconst.ci==c)
1287 #define COMMUTE { e = lp; lp = rp; rp = e; }
1288
1289
1290 struct bigblock *
mkexpr(opcode,lp,rp)1291 mkexpr(opcode, lp, rp)
1292 int opcode;
1293 register bigptr lp, rp;
1294 {
1295 register struct bigblock *e, *e1;
1296 int etype;
1297 int ltype, rtype;
1298 int ltag, rtag;
1299
1300 ltype = lp->vtype;
1301 ltag = lp->tag;
1302 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1303 {
1304 rtype = rp->vtype;
1305 rtag = rp->tag;
1306 }
1307 else rtype = rtag = 0;
1308
1309 etype = cktype(opcode, ltype, rtype);
1310 if(etype == TYERROR)
1311 goto error;
1312
1313 switch(opcode)
1314 {
1315 /* check for multiplication by 0 and 1 and addition to 0 */
1316
1317 case OPSTAR:
1318 if( ISCONST(lp) )
1319 COMMUTE
1320
1321 if( ISICON(rp) )
1322 {
1323 if(rp->b_const.fconst.ci == 0)
1324 goto retright;
1325 goto mulop;
1326 }
1327 break;
1328
1329 case OPSLASH:
1330 case OPMOD:
1331 if( ICONEQ(rp, 0) )
1332 {
1333 err("attempted division by zero");
1334 rp = MKICON(1);
1335 break;
1336 }
1337 if(opcode == OPMOD)
1338 break;
1339
1340
1341 mulop:
1342 if( ISICON(rp) )
1343 {
1344 if(rp->b_const.fconst.ci == 1)
1345 goto retleft;
1346
1347 if(rp->b_const.fconst.ci == -1)
1348 {
1349 frexpr(rp);
1350 return( mkexpr(OPNEG, lp, 0) );
1351 }
1352 }
1353
1354 if( ISSTAROP(lp) && ISICON(lp->b_expr.rightp) )
1355 {
1356 if(opcode == OPSTAR)
1357 e = mkexpr(OPSTAR, lp->b_expr.rightp, rp);
1358 else if(ISICON(rp) && lp->b_expr.rightp->b_const.fconst.ci % rp->b_const.fconst.ci == 0)
1359 e = mkexpr(OPSLASH, lp->b_expr.rightp, rp);
1360 else break;
1361
1362 e1 = lp->b_expr.leftp;
1363 ckfree(lp);
1364 return( mkexpr(OPSTAR, e1, e) );
1365 }
1366 break;
1367
1368
1369 case OPPLUS:
1370 if( ISCONST(lp) )
1371 COMMUTE
1372 goto addop;
1373
1374 case OPMINUS:
1375 if( ICONEQ(lp, 0) )
1376 {
1377 frexpr(lp);
1378 return( mkexpr(OPNEG, rp, 0) );
1379 }
1380
1381 if( ISCONST(rp) )
1382 {
1383 opcode = OPPLUS;
1384 consnegop(rp);
1385 }
1386
1387 addop:
1388 if( ISICON(rp) )
1389 {
1390 if(rp->b_const.fconst.ci == 0)
1391 goto retleft;
1392 if( ISPLUSOP(lp) && ISICON(lp->b_expr.rightp) )
1393 {
1394 e = mkexpr(OPPLUS, lp->b_expr.rightp, rp);
1395 e1 = lp->b_expr.leftp;
1396 ckfree(lp);
1397 return( mkexpr(OPPLUS, e1, e) );
1398 }
1399 }
1400 break;
1401
1402
1403 case OPPOWER:
1404 break;
1405
1406 case OPNEG:
1407 if(ltag==TEXPR && lp->b_expr.opcode==OPNEG)
1408 {
1409 e = lp->b_expr.leftp;
1410 ckfree(lp);
1411 return(e);
1412 }
1413 break;
1414
1415 case OPNOT:
1416 if(ltag==TEXPR && lp->b_expr.opcode==OPNOT)
1417 {
1418 e = lp->b_expr.leftp;
1419 ckfree(lp);
1420 return(e);
1421 }
1422 break;
1423
1424 case OPCALL:
1425 case OPCCALL:
1426 etype = ltype;
1427 if(rp!=NULL && rp->b_list.listp==NULL)
1428 {
1429 ckfree(rp);
1430 rp = NULL;
1431 }
1432 break;
1433
1434 case OPAND:
1435 case OPOR:
1436 if( ISCONST(lp) )
1437 COMMUTE
1438
1439 if( ISCONST(rp) )
1440 {
1441 if(rp->b_const.fconst.ci == 0)
1442 if(opcode == OPOR)
1443 goto retleft;
1444 else
1445 goto retright;
1446 else if(opcode == OPOR)
1447 goto retright;
1448 else
1449 goto retleft;
1450 }
1451 case OPEQV:
1452 case OPNEQV:
1453
1454 case OPBITAND:
1455 case OPBITOR:
1456 case OPBITXOR:
1457 case OPBITNOT:
1458 case OPLSHIFT:
1459 case OPRSHIFT:
1460
1461 case OPLT:
1462 case OPGT:
1463 case OPLE:
1464 case OPGE:
1465 case OPEQ:
1466 case OPNE:
1467
1468 case OPCONCAT:
1469 break;
1470 case OPMIN:
1471 case OPMAX:
1472
1473 case OPASSIGN:
1474
1475 case OPCONV:
1476 case OPADDR:
1477
1478 case OPCOMMA:
1479 break;
1480
1481 default:
1482 fatal1("mkexpr: impossible opcode %d", opcode);
1483 }
1484
1485 e = BALLO();
1486 e->tag = TEXPR;
1487 e->b_expr.opcode = opcode;
1488 e->vtype = etype;
1489 e->b_expr.leftp = lp;
1490 e->b_expr.rightp = rp;
1491 if(ltag==TCONST && (rp==0 || rtag==TCONST) )
1492 e = fold(e);
1493 return(e);
1494
1495 retleft:
1496 frexpr(rp);
1497 return(lp);
1498
1499 retright:
1500 frexpr(lp);
1501 return(rp);
1502
1503 error:
1504 frexpr(lp);
1505 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1506 frexpr(rp);
1507 return( errnode() );
1508 }
1509
1510 #define ERR(s) { errs = s; goto error; }
1511
1512 int
cktype(op,lt,rt)1513 cktype(op, lt, rt)
1514 register int op, lt, rt;
1515 {
1516 char *errs = NULL; /* XXX gcc */
1517
1518 if(lt==TYERROR || rt==TYERROR)
1519 goto error1;
1520
1521 if(lt==TYUNKNOWN)
1522 return(TYUNKNOWN);
1523 if(rt==TYUNKNOWN)
1524 if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
1525 return(TYUNKNOWN);
1526
1527 switch(op)
1528 {
1529 case OPPLUS:
1530 case OPMINUS:
1531 case OPSTAR:
1532 case OPSLASH:
1533 case OPPOWER:
1534 case OPMOD:
1535 if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1536 return( maxtype(lt, rt) );
1537 ERR("nonarithmetic operand of arithmetic operator")
1538
1539 case OPNEG:
1540 if( ISNUMERIC(lt) )
1541 return(lt);
1542 ERR("nonarithmetic operand of negation")
1543
1544 case OPNOT:
1545 if(lt == TYLOGICAL)
1546 return(TYLOGICAL);
1547 ERR("NOT of nonlogical")
1548
1549 case OPAND:
1550 case OPOR:
1551 case OPEQV:
1552 case OPNEQV:
1553 if(lt==TYLOGICAL && rt==TYLOGICAL)
1554 return(TYLOGICAL);
1555 ERR("nonlogical operand of logical operator")
1556
1557 case OPLT:
1558 case OPGT:
1559 case OPLE:
1560 case OPGE:
1561 case OPEQ:
1562 case OPNE:
1563 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1564 {
1565 if(lt != rt)
1566 ERR("illegal comparison")
1567 }
1568
1569 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
1570 {
1571 if(op!=OPEQ && op!=OPNE)
1572 ERR("order comparison of complex data")
1573 }
1574
1575 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
1576 ERR("comparison of nonarithmetic data")
1577 return(TYLOGICAL);
1578
1579 case OPCONCAT:
1580 if(lt==TYCHAR && rt==TYCHAR)
1581 return(TYCHAR);
1582 ERR("concatenation of nonchar data")
1583
1584 case OPCALL:
1585 case OPCCALL:
1586 return(lt);
1587
1588 case OPADDR:
1589 return(TYADDR);
1590
1591 case OPCONV:
1592 if(rt == 0)
1593 return(0);
1594 case OPASSIGN:
1595 if( ISINT(lt) && rt==TYCHAR)
1596 return(lt);
1597 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1598 if(op!=OPASSIGN || lt!=rt)
1599 {
1600 /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
1601 /* debug fatal("impossible conversion. possible compiler bug"); */
1602 ERR("impossible conversion")
1603 }
1604 return(lt);
1605
1606 case OPMIN:
1607 case OPMAX:
1608 case OPBITOR:
1609 case OPBITAND:
1610 case OPBITXOR:
1611 case OPBITNOT:
1612 case OPLSHIFT:
1613 case OPRSHIFT:
1614 return(lt);
1615
1616 case OPCOMMA:
1617 return(rt);
1618
1619 default:
1620 fatal1("cktype: impossible opcode %d", op);
1621 }
1622 error: err(errs);
1623 error1: return(TYERROR);
1624 }
1625
fold(e)1626 LOCAL bigptr fold(e)
1627 register struct bigblock *e;
1628 {
1629 struct bigblock *p;
1630 register bigptr lp, rp;
1631 int etype, mtype, ltype, rtype, opcode;
1632 int i, ll, lr;
1633 char *q, *s;
1634 union constant lcon, rcon;
1635
1636 opcode = e->b_expr.opcode;
1637 etype = e->vtype;
1638
1639 lp = e->b_expr.leftp;
1640 ltype = lp->vtype;
1641 rp = e->b_expr.rightp;
1642
1643 if(rp == 0)
1644 switch(opcode)
1645 {
1646 case OPNOT:
1647 lp->b_const.fconst.ci = ! lp->b_const.fconst.ci;
1648 return(lp);
1649
1650 case OPBITNOT:
1651 lp->b_const.fconst.ci = ~ lp->b_const.fconst.ci;
1652 return(lp);
1653
1654 case OPNEG:
1655 consnegop(lp);
1656 return(lp);
1657
1658 case OPCONV:
1659 case OPADDR:
1660 return(e);
1661
1662 default:
1663 fatal1("fold: invalid unary operator %d", opcode);
1664 }
1665
1666 rtype = rp->vtype;
1667
1668 p = BALLO();
1669 p->tag = TCONST;
1670 p->vtype = etype;
1671 p->vleng = e->vleng;
1672
1673 switch(opcode)
1674 {
1675 case OPCOMMA:
1676 return(e);
1677
1678 case OPAND:
1679 p->b_const.fconst.ci = lp->b_const.fconst.ci && rp->b_const.fconst.ci;
1680 break;
1681
1682 case OPOR:
1683 p->b_const.fconst.ci = lp->b_const.fconst.ci || rp->b_const.fconst.ci;
1684 break;
1685
1686 case OPEQV:
1687 p->b_const.fconst.ci = lp->b_const.fconst.ci == rp->b_const.fconst.ci;
1688 break;
1689
1690 case OPNEQV:
1691 p->b_const.fconst.ci = lp->b_const.fconst.ci != rp->b_const.fconst.ci;
1692 break;
1693
1694 case OPBITAND:
1695 p->b_const.fconst.ci = lp->b_const.fconst.ci & rp->b_const.fconst.ci;
1696 break;
1697
1698 case OPBITOR:
1699 p->b_const.fconst.ci = lp->b_const.fconst.ci | rp->b_const.fconst.ci;
1700 break;
1701
1702 case OPBITXOR:
1703 p->b_const.fconst.ci = lp->b_const.fconst.ci ^ rp->b_const.fconst.ci;
1704 break;
1705
1706 case OPLSHIFT:
1707 p->b_const.fconst.ci = lp->b_const.fconst.ci << rp->b_const.fconst.ci;
1708 break;
1709
1710 case OPRSHIFT:
1711 p->b_const.fconst.ci = lp->b_const.fconst.ci >> rp->b_const.fconst.ci;
1712 break;
1713
1714 case OPCONCAT:
1715 ll = lp->vleng->b_const.fconst.ci;
1716 lr = rp->vleng->b_const.fconst.ci;
1717 p->b_const.fconst.ccp = q = (char *) ckalloc(ll+lr);
1718 p->vleng = MKICON(ll+lr);
1719 s = lp->b_const.fconst.ccp;
1720 for(i = 0 ; i < ll ; ++i)
1721 *q++ = *s++;
1722 s = rp->b_const.fconst.ccp;
1723 for(i = 0; i < lr; ++i)
1724 *q++ = *s++;
1725 break;
1726
1727
1728 case OPPOWER:
1729 if( ! ISINT(rtype) )
1730 return(e);
1731 conspower(&(p->b_const.fconst), lp, rp->b_const.fconst.ci);
1732 break;
1733
1734
1735 default:
1736 if(ltype == TYCHAR)
1737 {
1738 lcon.ci = cmpstr(lp->b_const.fconst.ccp, rp->b_const.fconst.ccp,
1739 lp->vleng->b_const.fconst.ci, rp->vleng->b_const.fconst.ci);
1740 rcon.ci = 0;
1741 mtype = tyint;
1742 }
1743 else {
1744 mtype = maxtype(ltype, rtype);
1745 consconv(mtype, &lcon, ltype, &(lp->b_const.fconst) );
1746 consconv(mtype, &rcon, rtype, &(rp->b_const.fconst) );
1747 }
1748 consbinop(opcode, mtype, &(p->b_const.fconst), &lcon, &rcon);
1749 break;
1750 }
1751
1752 frexpr(e);
1753 return(p);
1754 }
1755
1756
1757
1758 /* assign constant l = r , doing coercion */
1759 void
consconv(lt,lv,rt,rv)1760 consconv(lt, lv, rt, rv)
1761 int lt, rt;
1762 register union constant *lv, *rv;
1763 {
1764 switch(lt)
1765 {
1766 case TYSHORT:
1767 case TYLONG:
1768 if( ISINT(rt) )
1769 lv->ci = rv->ci;
1770 else lv->ci = rv->cd[0];
1771 break;
1772
1773 case TYCOMPLEX:
1774 case TYDCOMPLEX:
1775 switch(rt)
1776 {
1777 case TYSHORT:
1778 case TYLONG:
1779 /* fall through and do real assignment of
1780 first element
1781 */
1782 case TYREAL:
1783 case TYDREAL:
1784 lv->cd[1] = 0; break;
1785 case TYCOMPLEX:
1786 case TYDCOMPLEX:
1787 lv->cd[1] = rv->cd[1]; break;
1788 }
1789
1790 case TYREAL:
1791 case TYDREAL:
1792 if( ISINT(rt) )
1793 lv->cd[0] = rv->ci;
1794 else lv->cd[0] = rv->cd[0];
1795 break;
1796
1797 case TYLOGICAL:
1798 lv->ci = rv->ci;
1799 break;
1800 }
1801 }
1802
1803
1804 void
consnegop(p)1805 consnegop(p)
1806 register struct bigblock *p;
1807 {
1808 switch(p->vtype)
1809 {
1810 case TYSHORT:
1811 case TYLONG:
1812 p->b_const.fconst.ci = - p->b_const.fconst.ci;
1813 break;
1814
1815 case TYCOMPLEX:
1816 case TYDCOMPLEX:
1817 p->b_const.fconst.cd[1] = - p->b_const.fconst.cd[1];
1818 /* fall through and do the real parts */
1819 case TYREAL:
1820 case TYDREAL:
1821 p->b_const.fconst.cd[0] = - p->b_const.fconst.cd[0];
1822 break;
1823 default:
1824 fatal1("consnegop: impossible type %d", p->vtype);
1825 }
1826 }
1827
1828
1829
1830 LOCAL void
conspower(powp,ap,n)1831 conspower(powp, ap, n)
1832 register union constant *powp;
1833 struct bigblock *ap;
1834 ftnint n;
1835 {
1836 register int type;
1837 union constant x;
1838
1839 switch(type = ap->vtype) /* pow = 1 */
1840 {
1841 case TYSHORT:
1842 case TYLONG:
1843 powp->ci = 1;
1844 break;
1845 case TYCOMPLEX:
1846 case TYDCOMPLEX:
1847 powp->cd[1] = 0;
1848 case TYREAL:
1849 case TYDREAL:
1850 powp->cd[0] = 1;
1851 break;
1852 default:
1853 fatal1("conspower: invalid type %d", type);
1854 }
1855
1856 if(n == 0)
1857 return;
1858 if(n < 0)
1859 {
1860 if( ISINT(type) )
1861 {
1862 err("integer ** negative power ");
1863 return;
1864 }
1865 n = - n;
1866 consbinop(OPSLASH, type, &x, powp, &(ap->b_const.fconst));
1867 }
1868 else
1869 consbinop(OPSTAR, type, &x, powp, &(ap->b_const.fconst));
1870
1871 for( ; ; )
1872 {
1873 if(n & 01)
1874 consbinop(OPSTAR, type, powp, powp, &x);
1875 if(n >>= 1)
1876 consbinop(OPSTAR, type, &x, &x, &x);
1877 else
1878 break;
1879 }
1880 }
1881
1882
1883
1884 /* do constant operation cp = a op b */
1885
1886
1887 LOCAL void
consbinop(opcode,type,cp,ap,bp)1888 consbinop(opcode, type, cp, ap, bp)
1889 int opcode, type;
1890 register union constant *ap, *bp, *cp;
1891 {
1892 int k;
1893 double temp;
1894
1895 switch(opcode)
1896 {
1897 case OPPLUS:
1898 switch(type)
1899 {
1900 case TYSHORT:
1901 case TYLONG:
1902 cp->ci = ap->ci + bp->ci;
1903 break;
1904 case TYCOMPLEX:
1905 case TYDCOMPLEX:
1906 cp->cd[1] = ap->cd[1] + bp->cd[1];
1907 case TYREAL:
1908 case TYDREAL:
1909 cp->cd[0] = ap->cd[0] + bp->cd[0];
1910 break;
1911 }
1912 break;
1913
1914 case OPMINUS:
1915 switch(type)
1916 {
1917 case TYSHORT:
1918 case TYLONG:
1919 cp->ci = ap->ci - bp->ci;
1920 break;
1921 case TYCOMPLEX:
1922 case TYDCOMPLEX:
1923 cp->cd[1] = ap->cd[1] - bp->cd[1];
1924 case TYREAL:
1925 case TYDREAL:
1926 cp->cd[0] = ap->cd[0] - bp->cd[0];
1927 break;
1928 }
1929 break;
1930
1931 case OPSTAR:
1932 switch(type)
1933 {
1934 case TYSHORT:
1935 case TYLONG:
1936 cp->ci = ap->ci * bp->ci;
1937 break;
1938 case TYREAL:
1939 case TYDREAL:
1940 cp->cd[0] = ap->cd[0] * bp->cd[0];
1941 break;
1942 case TYCOMPLEX:
1943 case TYDCOMPLEX:
1944 temp = ap->cd[0] * bp->cd[0] -
1945 ap->cd[1] * bp->cd[1] ;
1946 cp->cd[1] = ap->cd[0] * bp->cd[1] +
1947 ap->cd[1] * bp->cd[0] ;
1948 cp->cd[0] = temp;
1949 break;
1950 }
1951 break;
1952 case OPSLASH:
1953 switch(type)
1954 {
1955 case TYSHORT:
1956 case TYLONG:
1957 cp->ci = ap->ci / bp->ci;
1958 break;
1959 case TYREAL:
1960 case TYDREAL:
1961 cp->cd[0] = ap->cd[0] / bp->cd[0];
1962 break;
1963 case TYCOMPLEX:
1964 case TYDCOMPLEX:
1965 zdiv(&cp->dc, &ap->dc, &bp->dc);
1966 break;
1967 }
1968 break;
1969
1970 case OPMOD:
1971 if( ISINT(type) )
1972 {
1973 cp->ci = ap->ci % bp->ci;
1974 break;
1975 }
1976 else
1977 fatal("inline mod of noninteger");
1978
1979 default: /* relational ops */
1980 switch(type)
1981 {
1982 case TYSHORT:
1983 case TYLONG:
1984 if(ap->ci < bp->ci)
1985 k = -1;
1986 else if(ap->ci == bp->ci)
1987 k = 0;
1988 else k = 1;
1989 break;
1990 case TYREAL:
1991 case TYDREAL:
1992 if(ap->cd[0] < bp->cd[0])
1993 k = -1;
1994 else if(ap->cd[0] == bp->cd[0])
1995 k = 0;
1996 else k = 1;
1997 break;
1998 case TYCOMPLEX:
1999 case TYDCOMPLEX:
2000 if(ap->cd[0] == bp->cd[0] &&
2001 ap->cd[1] == bp->cd[1] )
2002 k = 0;
2003 else k = 1;
2004 break;
2005 default: /* XXX gcc */
2006 k = 0;
2007 break;
2008 }
2009
2010 switch(opcode)
2011 {
2012 case OPEQ:
2013 cp->ci = (k == 0);
2014 break;
2015 case OPNE:
2016 cp->ci = (k != 0);
2017 break;
2018 case OPGT:
2019 cp->ci = (k == 1);
2020 break;
2021 case OPLT:
2022 cp->ci = (k == -1);
2023 break;
2024 case OPGE:
2025 cp->ci = (k >= 0);
2026 break;
2027 case OPLE:
2028 cp->ci = (k <= 0);
2029 break;
2030 }
2031 break;
2032 }
2033 }
2034
2035
2036
2037 int
conssgn(p)2038 conssgn(p)
2039 register bigptr p;
2040 {
2041 if( ! ISCONST(p) )
2042 fatal( "sgn(nonconstant)" );
2043
2044 switch(p->vtype)
2045 {
2046 case TYSHORT:
2047 case TYLONG:
2048 if(p->b_const.fconst.ci > 0) return(1);
2049 if(p->b_const.fconst.ci < 0) return(-1);
2050 return(0);
2051
2052 case TYREAL:
2053 case TYDREAL:
2054 if(p->b_const.fconst.cd[0] > 0) return(1);
2055 if(p->b_const.fconst.cd[0] < 0) return(-1);
2056 return(0);
2057
2058 case TYCOMPLEX:
2059 case TYDCOMPLEX:
2060 return(p->b_const.fconst.cd[0]!=0 || p->b_const.fconst.cd[1]!=0);
2061
2062 default:
2063 fatal1( "conssgn(type %d)", p->vtype);
2064 }
2065 /* NOTREACHED */
2066 return 0; /* XXX gcc */
2067 }
2068
2069 char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2070
2071
mkpower(p)2072 LOCAL bigptr mkpower(p)
2073 register struct bigblock *p;
2074 {
2075 register bigptr q, lp, rp;
2076 int ltype, rtype, mtype;
2077
2078 lp = p->b_expr.leftp;
2079 rp = p->b_expr.rightp;
2080 ltype = lp->vtype;
2081 rtype = rp->vtype;
2082
2083 if(ISICON(rp))
2084 {
2085 if(rp->b_const.fconst.ci == 0)
2086 {
2087 frexpr(p);
2088 if( ISINT(ltype) )
2089 return( MKICON(1) );
2090 else
2091 return( putconst( mkconv(ltype, MKICON(1))) );
2092 }
2093 if(rp->b_const.fconst.ci < 0)
2094 {
2095 if( ISINT(ltype) )
2096 {
2097 frexpr(p);
2098 err("integer**negative");
2099 return( errnode() );
2100 }
2101 rp->b_const.fconst.ci = - rp->b_const.fconst.ci;
2102 p->b_expr.leftp = lp = fixexpr(mkexpr(OPSLASH, MKICON(1), lp));
2103 }
2104 if(rp->b_const.fconst.ci == 1)
2105 {
2106 frexpr(rp);
2107 ckfree(p);
2108 return(lp);
2109 }
2110
2111 if( ONEOF(ltype, MSKINT|MSKREAL) )
2112 {
2113 p->vtype = ltype;
2114 return(p);
2115 }
2116 }
2117 if( ISINT(rtype) )
2118 {
2119 if(ltype==TYSHORT && rtype==TYSHORT)
2120 q = call2(TYSHORT, "pow_hh", lp, rp);
2121 else {
2122 if(ltype == TYSHORT)
2123 {
2124 ltype = TYLONG;
2125 lp = mkconv(TYLONG,lp);
2126 }
2127 q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
2128 }
2129 }
2130 else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
2131 q = call2(mtype, "pow_dd",
2132 mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2133 else {
2134 q = call2(TYDCOMPLEX, "pow_zz",
2135 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2136 if(mtype == TYCOMPLEX)
2137 q = mkconv(TYCOMPLEX, q);
2138 }
2139 ckfree(p);
2140 return(q);
2141 }
2142
2143
2144
2145 /* Complex Division. Same code as in Runtime Library
2146 */
2147
2148
2149
2150 LOCAL void
zdiv(c,a,b)2151 zdiv(c, a, b)
2152 register struct dcomplex *a, *b, *c;
2153 {
2154 double ratio, den;
2155 double abr, abi;
2156
2157 if( (abr = b->dreal) < 0.)
2158 abr = - abr;
2159 if( (abi = b->dimag) < 0.)
2160 abi = - abi;
2161 if( abr <= abi )
2162 {
2163 if(abi == 0)
2164 fatal("complex division by zero");
2165 ratio = b->dreal / b->dimag ;
2166 den = b->dimag * (1 + ratio*ratio);
2167 c->dreal = (a->dreal*ratio + a->dimag) / den;
2168 c->dimag = (a->dimag*ratio - a->dreal) / den;
2169 }
2170
2171 else
2172 {
2173 ratio = b->dimag / b->dreal ;
2174 den = b->dreal * (1 + ratio*ratio);
2175 c->dreal = (a->dreal + a->dimag*ratio) / den;
2176 c->dimag = (a->dimag - a->dreal*ratio) / den;
2177 }
2178
2179 }
2180