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