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