projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Sprinkled with ${.CURDIR} to get the builds of gram.c and tokdefs.h
[unix-history] / usr.bin / f2c / expr.c
CommitLineData
f1525c23
WH		 1/****************************************************************
2Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3
4Permission to use, copy, modify, and distribute this software
5and its documentation for any purpose and without fee is hereby
6granted, provided that the above copyright notice appear in all
7copies and that both that the copyright notice and this
8permission notice and warranty disclaimer appear in supporting
9documentation, and that the names of AT&T Bell Laboratories or
10Bellcore or any of their entities not be used in advertising or
11publicity pertaining to distribution of the software without
12specific, written prior permission.
13
14AT&T and Bellcore disclaim all warranties with regard to this
15software, including all implied warranties of merchantability
16and fitness. In no event shall AT&T or Bellcore be liable for
17any special, indirect or consequential damages or any damages
18whatsoever resulting from loss of use, data or profits, whether
19in an action of contract, negligence or other tortious action,
20arising out of or in connection with the use or performance of
21this software.
22****************************************************************/
23
24#include "defs.h"
25#include "output.h"
26#include "names.h"
27
28LOCAL void conspower(), consbinop(), zdiv();
29LOCAL expptr fold(), mkpower(), stfcall();
30#ifndef stfcall_MAX
31#define stfcall_MAX 144
32#endif
33
34typedef struct { double dreal, dimag; } dcomplex;
35
36extern char dflttype[26];
37extern int htype;
38
39/* little routines to create constant blocks */
40
41Constp mkconst(t)
42register int t;
43{
44 register Constp p;
45
46 p = ALLOC(Constblock);
47 p->tag = TCONST;
48 p->vtype = t;
49 return(p);
50}
51
52
53/* mklogcon -- Make Logical Constant */
54
55expptr mklogcon(l)
56register int l;
57{
58 register Constp p;
59
60 p = mkconst(tylog);
61 p->Const.ci = l;
62 return( (expptr) p );
63}
64
65
66
67/* mkintcon -- Make Integer Constant */
68
69expptr mkintcon(l)
70ftnint l;
71{
72 register Constp p;
73
74 p = mkconst(tyint);
75 p->Const.ci = l;
76 return( (expptr) p );
77}
78
79
80
81
82/* mkaddcon -- Make Address Constant, given integer value */
83
84expptr mkaddcon(l)
85register long l;
86{
87 register Constp p;
88
89 p = mkconst(TYADDR);
90 p->Const.ci = l;
91 return( (expptr) p );
92}
93
94
95
96/* mkrealcon -- Make Real Constant. The type t is assumed
97 to be TYREAL or TYDREAL */
98
99expptr mkrealcon(t, d)
100 register int t;
101 char *d;
102{
103 register Constp p;
104
105 p = mkconst(t);
106 p->Const.cds[0] = cds(d,CNULL);
107 p->vstg = 1;
108 return( (expptr) p );
109}
110
111
112/* mkbitcon -- Make bit constant. Reads the input string, which is
113 assumed to correctly specify a number in base 2^shift (where shift
114 is the input parameter). shift may not exceed 4, i.e. only binary,
115 quad, octal and hex bases may be input. Constants may not exceed 32
116 bits, or whatever the size of (struct Constblock).ci may be. */
117
118expptr mkbitcon(shift, leng, s)
119int shift;
120int leng;
121char *s;
122{
123 register Constp p;
124 register long x;
125
126 p = mkconst(TYLONG);
127 x = 0;
128 while(--leng >= 0)
129 if(*s != ' ')
130 x = (x << shift) | hextoi(*s++);
131 /* mwm wanted to change the type to short for short constants,
132 * but this is dangerous -- there is no syntax for long constants
133 * with small values.
134 */
135 p->Const.ci = x;
136 return( (expptr) p );
137}
138
139
140
141
142
143/* mkstrcon -- Make string constant. Allocates storage and initializes
144 the memory for a copy of the input Fortran-string. */
145
146expptr mkstrcon(l,v)
147int l;
148register char *v;
149{
150 register Constp p;
151 register char *s;
152
153 p = mkconst(TYCHAR);
154 p->vleng = ICON(l);
155 p->Const.ccp = s = (char *) ckalloc(l+1);
156 p->Const.ccp1.blanks = 0;
157 while(--l >= 0)
158 *s++ = *v++;
159 *s = '\0';
160 return( (expptr) p );
161}
162
163
164
165/* mkcxcon -- Make complex contsant. A complex number is a pair of
166 values, each of which may be integer, real or double. */
167
168expptr mkcxcon(realp,imagp)
169register expptr realp, imagp;
170{
171 int rtype, itype;
172 register Constp p;
173 expptr errnode();
174
175 rtype = realp->headblock.vtype;
176 itype = imagp->headblock.vtype;
177
178 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
179 {
180 p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
181 ? TYDCOMPLEX : tycomplex);
182 if (realp->constblock.vstg || imagp->constblock.vstg) {
183 p->vstg = 1;
184 p->Const.cds[0] = ISINT(rtype)
185 ? string_num("", realp->constblock.Const.ci)
186 : realp->constblock.vstg
187 ? realp->constblock.Const.cds[0]
188 : dtos(realp->constblock.Const.cd[0]);
189 p->Const.cds[1] = ISINT(itype)
190 ? string_num("", imagp->constblock.Const.ci)
191 : imagp->constblock.vstg
192 ? imagp->constblock.Const.cds[0]
193 : dtos(imagp->constblock.Const.cd[0]);
194 }
195 else {
196 p->Const.cd[0] = ISINT(rtype)
197 ? realp->constblock.Const.ci
198 : realp->constblock.Const.cd[0];
199 p->Const.cd[1] = ISINT(itype)
200 ? imagp->constblock.Const.ci
201 : imagp->constblock.Const.cd[0];
202 }
203 }
204 else
205 {
206 err("invalid complex constant");
207 p = (Constp)errnode();
208 }
209
210 frexpr(realp);
211 frexpr(imagp);
212 return( (expptr) p );
213}
214
215
216/* errnode -- Allocate a new error block */
217
218expptr errnode()
219{
220 struct Errorblock *p;
221 p = ALLOC(Errorblock);
222 p->tag = TERROR;
223 p->vtype = TYERROR;
224 return( (expptr) p );
225}
226
227
228
229
230
231/* mkconv -- Make type conversion. Cast expression p into type t.
232 Note that casting to a character copies only the first sizeof(char)
233 bytes. */
234
235expptr mkconv(t, p)
236register int t;
237register expptr p;
238{
239 register expptr q;
240 register int pt, charwarn = 1;
241 expptr opconv();
242
243 if (t >= 100) {
244 t -= 100;
245 charwarn = 0;
246 }
247 if(t==TYUNKNOWN || t==TYERROR)
248 badtype("mkconv", t);
249 pt = p->headblock.vtype;
250
251/* Casting to the same type is a no-op */
252
253 if(t == pt)
254 return(p);
255
256/* If we're casting a constant which is not in the literal table ... */
257
258 else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
259 {
260 if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
261 /* avoid trouble with -i2 */
262 p->headblock.vtype = t;
263 return p;
264 }
265 q = (expptr) mkconst(t);
266 consconv(t, &q->constblock, &p->constblock );
267 frexpr(p);
268 }
269 else {
270 if (pt == TYCHAR && t != TYADDR && charwarn
271 && (!halign || p->tag != TADDR
272 || p->addrblock.uname_tag != UNAM_CONST))
273 warn(
274 "ichar([first char. of] char. string) assumed for conversion to numeric");
275 q = opconv(p, t);
276 }
277
278 if(t == TYCHAR)
279 q->constblock.vleng = ICON(1);
280 return(q);
281}
282
283
284
285/* opconv -- Convert expression p to type t using the main
286 expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */
287
288expptr opconv(p, t)
289expptr p;
290int t;
291{
292 register expptr q;
293
294 if (t == TYSUBR)
295 err("illegal use of subroutine name");
296 q = mkexpr(OPCONV, p, ENULL);
297 q->headblock.vtype = t;
298 return(q);
299}
300
301
302
303/* addrof -- Create an ADDR expression operation */
304
305expptr addrof(p)
306expptr p;
307{
308 return( mkexpr(OPADDR, p, ENULL) );
309}
310
311
312
313/* cpexpr - Returns a new copy of input expression p */
314
315tagptr cpexpr(p)
316register tagptr p;
317{
318 register tagptr e;
319 int tag;
320 register chainp ep, pp;
321 tagptr cpblock();
322
323/* This table depends on the ordering of the T macros, e.g. TNAME */
324
325 static int blksize[ ] =
326 {
327 0,
328 sizeof(struct Nameblock),
329 sizeof(struct Constblock),
330 sizeof(struct Exprblock),
331 sizeof(struct Addrblock),
332 sizeof(struct Primblock),
333 sizeof(struct Listblock),
334 sizeof(struct Impldoblock),
335 sizeof(struct Errorblock)
336 };
337
338 if(p == NULL)
339 return(NULL);
340
341/* TNAMEs are special, and don't get copied. Each name in the current
342 symbol table has a unique TNAME structure. */
343
344 if( (tag = p->tag) == TNAME)
345 return(p);
346
347 e = cpblock(blksize[p->tag], (char *)p);
348
349 switch(tag)
350 {
351 case TCONST:
352 if(e->constblock.vtype == TYCHAR)
353 {
354 e->constblock.Const.ccp =
355 copyn((int)e->constblock.vleng->constblock.Const.ci+1,
356 e->constblock.Const.ccp);
357 e->constblock.vleng =
358 (expptr) cpexpr(e->constblock.vleng);
359 }
360 case TERROR:
361 break;
362
363 case TEXPR:
364 e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp);
365 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
366 break;
367
368 case TLIST:
369 if(pp = p->listblock.listp)
370 {
371 ep = e->listblock.listp =
372 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
373 for(pp = pp->nextp ; pp ; pp = pp->nextp)
374 ep = ep->nextp =
375 mkchain((char *)cpexpr((tagptr)pp->datap),
376 CHNULL);
377 }
378 break;
379
380 case TADDR:
381 e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng);
382 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
383 e->addrblock.istemp = NO;
384 break;
385
386 case TPRIM:
387 e->primblock.argsp = (struct Listblock *)
388 cpexpr((expptr)e->primblock.argsp);
389 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
390 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
391 break;
392
393 default:
394 badtag("cpexpr", tag);
395 }
396
397 return(e);
398}
399
400/* frexpr -- Free expression -- frees up memory used by expression p */
401
402frexpr(p)
403register tagptr p;
404{
405 register chainp q;
406
407 if(p == NULL)
408 return;
409
410 switch(p->tag)
411 {
412 case TCONST:
413 if( ISCHAR(p) )
414 {
415 free( (charptr) (p->constblock.Const.ccp) );
416 frexpr(p->constblock.vleng);
417 }
418 break;
419
420 case TADDR:
421 if (p->addrblock.vtype > TYERROR) /* i/o block */
422 break;
423 frexpr(p->addrblock.vleng);
424 frexpr(p->addrblock.memoffset);
425 break;
426
427 case TERROR:
428 break;
429
430/* TNAME blocks don't get free'd - probably because they're pointed to in
431 the hash table. 14-Jun-88 -- mwm */
432
433 case TNAME:
434 return;
435
436 case TPRIM:
437 frexpr((expptr)p->primblock.argsp);
438 frexpr(p->primblock.fcharp);
439 frexpr(p->primblock.lcharp);
440 break;
441
442 case TEXPR:
443 frexpr(p->exprblock.leftp);
444 if(p->exprblock.rightp)
445 frexpr(p->exprblock.rightp);
446 break;
447
448 case TLIST:
449 for(q = p->listblock.listp ; q ; q = q->nextp)
450 frexpr((tagptr)q->datap);
451 frchain( &(p->listblock.listp) );
452 break;
453
454 default:
455 badtag("frexpr", p->tag);
456 }
457
458 free( (charptr) p );
459}
460
461 void
462wronginf(np)
463 Namep np;
464{
465 int c, k;
466 warn1("fixing wrong type inferred for %.65s", np->fvarname);
467 np->vinftype = 0;
468 c = letter(np->fvarname[0]);
469 if ((np->vtype = impltype[c]) == TYCHAR
470 && (k = implleng[c]))
471 np->vleng = ICON(k);
472 }
473
474/* fix up types in expression; replace subtrees and convert
475 names to address blocks */
476
477expptr fixtype(p)
478register tagptr p;
479{
480
481 if(p == 0)
482 return(0);
483
484 switch(p->tag)
485 {
486 case TCONST:
487 if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
488 MSKREAL) )
489 return( (expptr) p);
490
491 return( (expptr) putconst((Constp)p) );
492
493 case TADDR:
494 p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
495 return( (expptr) p);
496
497 case TERROR:
498 return( (expptr) p);
499
500 default:
501 badtag("fixtype", p->tag);
502
503/* This case means that fixexpr can't call fixtype with any expr,
504 only a subexpr of its parameter. */
505
506 case TEXPR:
507 return( fixexpr((Exprp)p) );
508
509 case TLIST:
510 return( (expptr) p );
511
512 case TPRIM:
513 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
514 {
515 if(p->primblock.namep->vtype == TYSUBR)
516 {
517 err("function invocation of subroutine");
518 return( errnode() );
519 }
520 else {
521 if (p->primblock.namep->vinftype)
522 wronginf(p->primblock.namep);
523 return( mkfunct(p) );
524 }
525 }
526
527/* The lack of args makes p a function name, substring reference
528 or variable name. */
529
530 else return mklhs((struct Primblock *) p, keepsubs);
531 }
532}
533
534
535 int
536badchleng(p) register expptr p;
537{
538 if (!p->headblock.vleng) {
539 if (p->headblock.tag == TADDR
540 && p->addrblock.uname_tag == UNAM_NAME)
541 errstr("bad use of character*(*) variable %.60s",
542 p->addrblock.user.name->fvarname);
543 else
544 err("Bad use of character*(*)");
545 return 1;
546 }
547 return 0;
548 }
549
550
551 static expptr
552cplenexpr(p)
553 expptr p;
554{
555 expptr rv;
556
557 if (badchleng(p))
558 return ICON(1);
559 rv = cpexpr(p->headblock.vleng);
560 if (ISCONST(p) && p->constblock.vtype == TYCHAR)
561 rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
562 return rv;
563 }
564
565
566/* special case tree transformations and cleanups of expression trees.
567 Parameter p should have a TEXPR tag at its root, else an error is
568 returned */
569
570expptr fixexpr(p)
571register Exprp p;
572{
573 expptr lp;
574 register expptr rp;
575 register expptr q;
576 int opcode, ltype, rtype, ptype, mtype;
577
578 if( ISERROR(p) )
579 return( (expptr) p );
580 else if(p->tag != TEXPR)
581 badtag("fixexpr", p->tag);
582 opcode = p->opcode;
583
584/* First set the types of the left and right subexpressions */
585
586 lp = p->leftp;
587 if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
588 lp = p->leftp = fixtype(lp);
589 ltype = lp->headblock.vtype;
590
591 if(opcode==OPASSIGN && lp->tag!=TADDR)
592 {
593 err("left side of assignment must be variable");
594 frexpr((expptr)p);
595 return( errnode() );
596 }
597
598 if(rp = p->rightp)
599 {
600 if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
601 rp = p->rightp = fixtype(rp);
602 rtype = rp->headblock.vtype;
603 }
604 else
605 rtype = 0;
606
607 if(ltype==TYERROR || rtype==TYERROR)
608 {
609 frexpr((expptr)p);
610 return( errnode() );
611 }
612
613/* Now work on the whole expression */
614
615 /* force folding if possible */
616
617 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
618 {
619 q = opcode == OPCONV && lp->constblock.vtype == p->vtype
620 ? lp : mkexpr(opcode, lp, rp);
621
622/* mkexpr is expected to reduce constant expressions */
623
624 if( ISCONST(q) ) {
625 p->leftp = p->rightp = 0;
626 frexpr((expptr)p);
627 return(q);
628 }
629 free( (charptr) q ); /* constants did not fold */
630 }
631
632 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
633 {
634 frexpr((expptr)p);
635 return( errnode() );
636 }
637
638 if (ltype == TYCHAR && ISCONST(lp))
639 p->leftp = lp = (expptr)putconst((Constp)lp);
640 if (rtype == TYCHAR && ISCONST(rp))
641 p->rightp = rp = (expptr)putconst((Constp)rp);
642
643 switch(opcode)
644 {
645 case OPCONCAT:
646 if(p->vleng == NULL)
647 p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
648 cplenexpr(rp) );
649 break;
650
651 case OPASSIGN:
652 if (rtype == TYREAL || ISLOGICAL(ptype))
653 break;
654 case OPPLUSEQ:
655 case OPSTAREQ:
656 if(ltype == rtype)
657 break;
658 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
659 break;
660 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
661 break;
662 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
663 && typesize[ltype]>=typesize[rtype] )
664 break;
665
666/* Cast the right hand side to match the type of the expression */
667
668 p->rightp = fixtype( mkconv(ptype, rp) );
669 break;
670
671 case OPSLASH:
672 if( ISCOMPLEX(rtype) )
673 {
674 p = (Exprp) call2(ptype,
675
676/* Handle double precision complex variables */
677
678 ptype == TYCOMPLEX ? "c_div" : "z_div",
679 mkconv(ptype, lp), mkconv(ptype, rp) );
680 break;
681 }
682 case OPPLUS:
683 case OPMINUS:
684 case OPSTAR:
685 case OPMOD:
686 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
687 (rtype==TYREAL && ! ISCONST(rp) ) ))
688 break;
689 if( ISCOMPLEX(ptype) )
690 break;
691
692/* Cast both sides of the expression to match the type of the whole
693 expression. */
694
695 if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL))
696 p->leftp = fixtype(mkconv(ptype,lp));
697 if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL))
698 p->rightp = fixtype(mkconv(ptype,rp));
699 break;
700
701 case OPPOWER:
702 return( mkpower((expptr)p) );
703
704 case OPLT:
705 case OPLE:
706 case OPGT:
707 case OPGE:
708 case OPEQ:
709 case OPNE:
710 if(ltype == rtype)
711 break;
712 if (htype) {
713 if (ltype == TYCHAR) {
714 p->leftp = fixtype(mkconv(rtype,lp));
715 break;
716 }
717 if (rtype == TYCHAR) {
718 p->rightp = fixtype(mkconv(ltype,rp));
719 break;
720 }
721 }
722 mtype = cktype(OPMINUS, ltype, rtype);
723 if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
724 (rtype==TYREAL && ! ISCONST(rp)) ))
725 break;
726 if( ISCOMPLEX(mtype) )
727 break;
728 if(ltype != mtype)
729 p->leftp = fixtype(mkconv(mtype,lp));
730 if(rtype != mtype)
731 p->rightp = fixtype(mkconv(mtype,rp));
732 break;
733
734 case OPCONV:
735 ptype = cktype(OPCONV, p->vtype, ltype);
736 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
737 && !ISCOMPLEX(ptype))
738 {
739 lp->exprblock.rightp =
740 fixtype( mkconv(ptype, lp->exprblock.rightp) );
741 free( (charptr) p );
742 p = (Exprp) lp;
743 }
744 break;
745
746 case OPADDR:
747 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
748 Fatal("addr of addr");
749 break;
750
751 case OPCOMMA:
752 case OPQUEST:
753 case OPCOLON:
754 break;
755
756 case OPMIN:
757 case OPMAX:
758 case OPMIN2:
759 case OPMAX2:
760 case OPDMIN:
761 case OPDMAX:
762 case OPABS:
763 case OPDABS:
764 ptype = p->vtype;
765 break;
766
767 default:
768 break;
769 }
770
771 p->vtype = ptype;
772 return((expptr) p);
773}
774
775
776/* fix an argument list, taking due care for special first level cases */
777
778fixargs(doput, p0)
779int doput; /* doput is true if constants need to be passed by reference */
780struct Listblock *p0;
781{
782 register chainp p;
783 register tagptr q, t;
784 register int qtag;
785 int nargs;
786 Addrp mkscalar();
787
788 nargs = 0;
789 if(p0)
790 for(p = p0->listp ; p ; p = p->nextp)
791 {
792 ++nargs;
793 q = (tagptr)p->datap;
794 qtag = q->tag;
795 if(qtag == TCONST)
796 {
797
798/* Call putconst() to store values in a constant table. Since even
799 constants must be passed by reference, this can optimize on the storage
800 required */
801
802 p->datap = doput ? (char *)putconst((Constp)q)
803 : (char *)q;
804 }
805
806/* Take a function name and turn it into an Addr. This only happens when
807 nothing else has figured out the function beforehand */
808
809 else if(qtag==TPRIM && q->primblock.argsp==0 &&
810 q->primblock.namep->vclass==CLPROC &&
811 q->primblock.namep->vprocclass != PTHISPROC)
812 p->datap = (char *)mkaddr(q->primblock.namep);
813
814 else if(qtag==TPRIM && q->primblock.argsp==0 &&
815 q->primblock.namep->vdim!=NULL)
816 p->datap = (char *)mkscalar(q->primblock.namep);
817
818 else if(qtag==TPRIM && q->primblock.argsp==0 &&
819 q->primblock.namep->vdovar &&
820 (t = (tagptr) memversion(q->primblock.namep)) )
821 p->datap = (char *)fixtype(t);
822 else
823 p->datap = (char *)fixtype(q);
824 }
825 return(nargs);
826}
827
828
829
830/* mkscalar -- only called by fixargs above, and by some routines in
831 io.c */
832
833Addrp mkscalar(np)
834register Namep np;
835{
836 register Addrp ap;
837
838 vardcl(np);
839 ap = mkaddr(np);
840
841 /* The prolog causes array arguments to point to the
842 * (0,...,0) element, unless subscript checking is on.
843 */
844 if( !checksubs && np->vstg==STGARG)
845 {
846 register struct Dimblock *dp;
847 dp = np->vdim;
848 frexpr(ap->memoffset);
849 ap->memoffset = mkexpr(OPSTAR,
850 (np->vtype==TYCHAR ?
851 cpexpr(np->vleng) :
852 (tagptr)ICON(typesize[np->vtype]) ),
853 cpexpr(dp->baseoffset) );
854 }
855 return(ap);
856}
857
858
859 static void
860adjust_arginfo(np) /* adjust arginfo to omit the length arg for the
861 arg that we now know to be a character-valued
862 function */
863 register Namep np;
864{
865 struct Entrypoint *ep;
866 register chainp args;
867 Argtypes *at;
868
869 for(ep = entries; ep; ep = ep->entnextp)
870 for(args = ep->arglist; args; args = args->nextp)
871 if (np == (Namep)args->datap
872 && (at = ep->entryname->arginfo))
873 --at->nargs;
874 }
875
876
877
878expptr mkfunct(p0)
879 expptr p0;
880{
881 register struct Primblock *p = (struct Primblock *)p0;
882 struct Entrypoint *ep;
883 Addrp ap;
884 Extsym *extp;
885 register Namep np;
886 register expptr q;
887 expptr intrcall();
888 extern chainp new_procs;
889 int k, nargs;
890 int class;
891
892 if(p->tag != TPRIM)
893 return( errnode() );
894
895 np = p->namep;
896 class = np->vclass;
897
898
899 if(class == CLUNKNOWN)
900 {
901 np->vclass = class = CLPROC;
902 if(np->vstg == STGUNKNOWN)
903 {
904 if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
905 && (zflag || !(*(struct Intrpacked *)&k).f4
906 || dcomplex_seen))
907 {
908 np->vstg = STGINTR;
909 np->vardesc.varno = k;
910 np->vprocclass = PINTRINSIC;
911 }
912 else
913 {
914 extp = mkext(np->fvarname,
915 addunder(np->cvarname));
916 extp->extstg = STGEXT;
917 np->vstg = STGEXT;
918 np->vardesc.varno = extp - extsymtab;
919 np->vprocclass = PEXTERNAL;
920 }
921 }
922 else if(np->vstg==STGARG)
923 {
924 if(np->vtype == TYCHAR) {
925 adjust_arginfo(np);
926 if (np->vpassed) {
927 char wbuf[160], *who;
928 who = np->fvarname;
929 sprintf(wbuf, "%s%s%s\n\t%s%s%s",
930 "Character-valued dummy procedure ",
931 who, " not declared EXTERNAL.",
932 "Code may be wrong for previous function calls having ",
933 who, " as a parameter.");
934 warn(wbuf);
935 }
936 }
937 np->vprocclass = PEXTERNAL;
938 }
939 }
940
941 if(class != CLPROC) {
942 if (np->vstg == STGCOMMON)
943 fatalstr(
944 "Cannot invoke common variable %.50s as a function.",
945 np->fvarname);
946 fatali("invalid class code %d for function", class);
947 }
948
949/* F77 doesn't allow subscripting of function calls */
950
951 if(p->fcharp || p->lcharp)
952 {
953 err("no substring of function call");
954 goto error;
955 }
956 impldcl(np);
957 np->vimpltype = 0; /* invoking as function ==> inferred type */
958 np->vcalled = 1;
959 nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp);
960
961 switch(np->vprocclass)
962 {
963 case PEXTERNAL:
964 if(np->vtype == TYUNKNOWN)
965 {
966 dclerr("attempt to use untyped function", np);
967 np->vtype = dflttype[letter(np->fvarname[0])];
968 }
969 ap = mkaddr(np);
970 if (!extsymtab[np->vardesc.varno].extseen) {
971 new_procs = mkchain((char *)np, new_procs);
972 extsymtab[np->vardesc.varno].extseen = 1;
973 }
974call:
975 q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
976 q->exprblock.vtype = np->vtype;
977 if(np->vleng)
978 q->exprblock.vleng = (expptr) cpexpr(np->vleng);
979 break;
980
981 case PINTRINSIC:
982 q = intrcall(np, p->argsp, nargs);
983 break;
984
985 case PSTFUNCT:
986 q = stfcall(np, p->argsp);
987 break;
988
989 case PTHISPROC:
990 warn("recursive call");
991
992/* entries is the list of multiple entry points */
993
994 for(ep = entries ; ep ; ep = ep->entnextp)
995 if(ep->enamep == np)
996 break;
997 if(ep == NULL)
998 Fatal("mkfunct: impossible recursion");
999
1000 ap = builtin(np->vtype, ep->entryname->cextname, -2);
1001 /* the negative last arg prevents adding */
1002 /* this name to the list of used builtins */
1003 goto call;
1004
1005 default:
1006 fatali("mkfunct: impossible vprocclass %d",
1007 (int) (np->vprocclass) );
1008 }
1009 free( (charptr) p );
1010 return(q);
1011
1012error:
1013 frexpr((expptr)p);
1014 return( errnode() );
1015}
1016
1017
1018
1019LOCAL expptr stfcall(np, actlist)
1020Namep np;
1021struct Listblock *actlist;
1022{
1023 register chainp actuals;
1024 int nargs;
1025 chainp oactp, formals;
1026 int type;
1027 expptr Ln, Lq, q, q1, rhs, ap;
1028 Namep tnp;
1029 register struct Rplblock *rp;
1030 struct Rplblock *tlist;
1031 static int inv_count;
1032
1033 if (++inv_count > stfcall_MAX)
1034 Fatal("Loop invoking recursive statement function?");
1035 if(actlist)
1036 {
1037 actuals = actlist->listp;
1038 free( (charptr) actlist);
1039 }
1040 else
1041 actuals = NULL;
1042 oactp = actuals;
1043
1044 nargs = 0;
1045 tlist = NULL;
1046 if( (type = np->vtype) == TYUNKNOWN)
1047 {
1048 dclerr("attempt to use untyped statement function", np);
1049 type = np->vtype = dflttype[letter(np->fvarname[0])];
1050 }
1051 formals = (chainp) np->varxptr.vstfdesc->datap;
1052 rhs = (expptr) (np->varxptr.vstfdesc->nextp);
1053
1054 /* copy actual arguments into temporaries */
1055 while(actuals!=NULL && formals!=NULL)
1056 {
1057 rp = ALLOC(Rplblock);
1058 rp->rplnp = tnp = (Namep) formals->datap;
1059 ap = fixtype((tagptr)actuals->datap);
1060 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
1061 && (ap->tag==TCONST || ap->tag==TADDR) )
1062 {
1063
1064/* If actuals are constants or variable names, no temporaries are required */
1065 rp->rplvp = (expptr) ap;
1066 rp->rplxp = NULL;
1067 rp->rpltag = ap->tag;
1068 }
1069 else {
1070 rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
1071 rp -> rplxp = NULL;
1072 putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
1073 if((rp->rpltag = rp->rplvp->tag) == TERROR)
1074 err("disagreement of argument types in statement function call");
1075 }
1076 rp->rplnextp = tlist;
1077 tlist = rp;
1078 actuals = actuals->nextp;
1079 formals = formals->nextp;
1080 ++nargs;
1081 }
1082
1083 if(actuals!=NULL || formals!=NULL)
1084 err("statement function definition and argument list differ");
1085
1086 /*
1087 now push down names involved in formal argument list, then
1088 evaluate rhs of statement function definition in this environment
1089*/
1090
1091 if(tlist) /* put tlist in front of the rpllist */
1092 {
1093 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
1094 ;
1095 rp->rplnextp = rpllist;
1096 rpllist = tlist;
1097 }
1098
1099/* So when the expression finally gets evaled, that evaluator must read
1100 from the globl rpllist 14-jun-88 mwm */
1101
1102 q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
1103
1104 /* get length right of character-valued statement functions... */
1105 if (type == TYCHAR
1106 && (Ln = np->vleng)
1107 && q->tag != TERROR
1108 && (Lq = q->exprblock.vleng)
1109 && (Lq->tag != TCONST
1110 || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
1111 q1 = (expptr) mktmp(type, Ln);
1112 putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
1113 q = q1;
1114 }
1115
1116 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
1117 while(--nargs >= 0)
1118 {
1119 if(rpllist->rplxp)
1120 q = mkexpr(OPCOMMA, rpllist->rplxp, q);
1121 rp = rpllist->rplnextp;
1122 frexpr(rpllist->rplvp);
1123 free((char *)rpllist);
1124 rpllist = rp;
1125 }
1126 frchain( &oactp );
1127 --inv_count;
1128 return(q);
1129}
1130
1131
1132static int replaced;
1133
1134/* mkplace -- Figure out the proper storage class for the input name and
1135 return an addrp with the appropriate stuff */
1136
1137Addrp mkplace(np)
1138register Namep np;
1139{
1140 register Addrp s;
1141 register struct Rplblock *rp;
1142 int regn;
1143
1144 /* is name on the replace list? */
1145
1146 for(rp = rpllist ; rp ; rp = rp->rplnextp)
1147 {
1148 if(np == rp->rplnp)
1149 {
1150 replaced = 1;
1151 if(rp->rpltag == TNAME)
1152 {
1153 np = (Namep) (rp->rplvp);
1154 break;
1155 }
1156 else return( (Addrp) cpexpr(rp->rplvp) );
1157 }
1158 }
1159
1160 /* is variable a DO index in a register ? */
1161
1162 if(np->vdovar && ( (regn = inregister(np)) >= 0) )
1163 if(np->vtype == TYERROR)
1164 return((Addrp) errnode() );
1165 else
1166 {
1167 s = ALLOC(Addrblock);
1168 s->tag = TADDR;
1169 s->vstg = STGREG;
1170 s->vtype = TYIREG;
1171 s->memno = regn;
1172 s->memoffset = ICON(0);
1173 s -> uname_tag = UNAM_NAME;
1174 s -> user.name = np;
1175 return(s);
1176 }
1177
1178 if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
1179 errstr("external %.60s used as a variable", np->fvarname);
1180 vardcl(np);
1181 return(mkaddr(np));
1182}
1183
1184 static expptr
1185subskept(p,a)
1186struct Primblock *p;
1187Addrp a;
1188{
1189 expptr ep;
1190 struct Listblock *Lb;
1191 chainp cp;
1192
1193 if (a->uname_tag != UNAM_NAME)
1194 erri("subskept: uname_tag %d", a->uname_tag);
1195 a->user.name->vrefused = 1;
1196 a->user.name->visused = 1;
1197 a->uname_tag = UNAM_REF;
1198 Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
1199 for(cp = Lb->listp; cp; cp = cp->nextp)
1200 cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
1201 if (a->vtype == TYCHAR) {
1202 ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
1203 : ICON(0);
1204 Lb->listp = mkchain((char *)ep, Lb->listp);
1205 }
1206 return (expptr)Lb;
1207 }
1208
1209 static int doing_vleng;
1210
1211/* mklhs -- Compute the actual address of the given expression; account
1212 for array subscripts, stack offset, and substring offsets. The f -> C
1213 translator will need this only to worry about the subscript stuff */
1214
1215expptr mklhs(p, subkeep)
1216register struct Primblock *p; int subkeep;
1217{
1218 expptr suboffset();
1219 register Addrp s;
1220 Namep np;
1221
1222 if(p->tag != TPRIM)
1223 return( (expptr) p );
1224 np = p->namep;
1225
1226 replaced = 0;
1227 s = mkplace(np);
1228 if(s->tag!=TADDR || s->vstg==STGREG)
1229 {
1230 free( (charptr) p );
1231 return( (expptr) s );
1232 }
1233 s->parenused = p->parenused;
1234
1235 /* compute the address modified by subscripts */
1236
1237 if (!replaced)
1238 s->memoffset = (subkeep && np->vdim
1239 && (np->vdim->ndim > 1 || np->vtype == TYCHAR
1240 && (!ISCONST(np->vleng)
1241 || np->vleng->constblock.Const.ci != 1)))
1242 ? subskept(p,s)
1243 : mkexpr(OPPLUS, s->memoffset, suboffset(p) );
1244 frexpr((expptr)p->argsp);
1245 p->argsp = NULL;
1246
1247 /* now do substring part */
1248
1249 if(p->fcharp || p->lcharp)
1250 {
1251 if(np->vtype != TYCHAR)
1252 errstr("substring of noncharacter %s", np->fvarname);
1253 else {
1254 if(p->lcharp == NULL)
1255 p->lcharp = (expptr) cpexpr(s->vleng);
1256 if(p->fcharp) {
1257 doing_vleng = 1;
1258 s->vleng = fixtype(mkexpr(OPMINUS,
1259 p->lcharp,
1260 mkexpr(OPMINUS, p->fcharp, ICON(1) )));
1261 doing_vleng = 0;
1262 }
1263 else {
1264 frexpr(s->vleng);
1265 s->vleng = p->lcharp;
1266 }
1267 }
1268 }
1269
1270 s->vleng = fixtype( s->vleng );
1271 s->memoffset = fixtype( s->memoffset );
1272 free( (charptr) p );
1273 return( (expptr) s );
1274}
1275
1276
1277
1278
1279
1280/* deregister -- remove a register allocation from the list; assumes that
1281 names are deregistered in stack order (LIFO order - Last In First Out) */
1282
1283deregister(np)
1284Namep np;
1285{
1286 if(nregvar>0 && regnamep[nregvar-1]==np)
1287 {
1288 --nregvar;
1289 }
1290}
1291
1292
1293
1294
1295/* memversion -- moves a DO index REGISTER into a memory location; other
1296 objects are passed through untouched */
1297
1298Addrp memversion(np)
1299register Namep np;
1300{
1301 register Addrp s;
1302
1303 if(np->vdovar==NO || (inregister(np)<0) )
1304 return(NULL);
1305 np->vdovar = NO;
1306 s = mkplace(np);
1307 np->vdovar = YES;
1308 return(s);
1309}
1310
1311
1312
1313/* inregister -- looks for the input name in the global list regnamep */
1314
1315inregister(np)
1316register Namep np;
1317{
1318 register int i;
1319
1320 for(i = 0 ; i < nregvar ; ++i)
1321 if(regnamep[i] == np)
1322 return( regnum[i] );
1323 return(-1);
1324}
1325
1326
1327
1328/* suboffset -- Compute the offset from the start of the array, given the
1329 subscripts as arguments */
1330
1331expptr suboffset(p)
1332register struct Primblock *p;
1333{
1334 int n;
1335 expptr si, size;
1336 chainp cp;
1337 expptr e, e1, offp, prod;
1338 expptr subcheck();
1339 struct Dimblock *dimp;
1340 expptr sub[MAXDIM+1];
1341 register Namep np;
1342
1343 np = p->namep;
1344 offp = ICON(0);
1345 n = 0;
1346 if(p->argsp)
1347 for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
1348 {
1349 si = fixtype(cpexpr((tagptr)cp->datap));
1350 if (!ISINT(si->headblock.vtype)) {
1351 NOEXT("non-integer subscript");
1352 si = mkconv(TYLONG, si);
1353 }
1354 sub[n++] = si;
1355 if(n > maxdim)
1356 {
1357 erri("more than %d subscripts", maxdim);
1358 break;
1359 }
1360 }
1361
1362 dimp = np->vdim;
1363 if(n>0 && dimp==NULL)
1364 errstr("subscripts on scalar variable %.68s", np->fvarname);
1365 else if(dimp && dimp->ndim!=n)
1366 errstr("wrong number of subscripts on %.68s", np->fvarname);
1367 else if(n > 0)
1368 {
1369 prod = sub[--n];
1370 while( --n >= 0)
1371 prod = mkexpr(OPPLUS, sub[n],
1372 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1373 if(checksubs || np->vstg!=STGARG)
1374 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1375
1376/* Add in the run-time bounds check */
1377
1378 if(checksubs)
1379 prod = subcheck(np, prod);
1380 size = np->vtype == TYCHAR ?
1381 (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
1382 prod = mkexpr(OPSTAR, prod, size);
1383 offp = mkexpr(OPPLUS, offp, prod);
1384 }
1385
1386/* Check for substring indicator */
1387
1388 if(p->fcharp && np->vtype==TYCHAR) {
1389 e = p->fcharp;
1390 e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
1391 if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
1392 e = (expptr)mktmp(TYLONG, ENULL);
1393 putout(putassign(cpexpr(e), e1));
1394 p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
1395 e1 = e;
1396 }
1397 offp = mkexpr(OPPLUS, offp, e1);
1398 }
1399 return(offp);
1400}
1401
1402
1403
1404
1405expptr subcheck(np, p)
1406Namep np;
1407register expptr p;
1408{
1409 struct Dimblock *dimp;
1410 expptr t, checkvar, checkcond, badcall;
1411
1412 dimp = np->vdim;
1413 if(dimp->nelt == NULL)
1414 return(p); /* don't check arrays with * bounds */
1415 np->vlastdim = 0;
1416 if( ISICON(p) )
1417 {
1418
1419/* check for negative (constant) offset */
1420
1421 if(p->constblock.Const.ci < 0)
1422 goto badsub;
1423 if( ISICON(dimp->nelt) )
1424
1425/* see if constant offset exceeds the array declaration */
1426
1427 if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
1428 return(p);
1429 else
1430 goto badsub;
1431 }
1432
1433/* We know that the subscript offset p or dimp -> nelt is not a constant.
1434 Now find a register to use for run-time bounds checking */
1435
1436 if(p->tag==TADDR && p->addrblock.vstg==STGREG)
1437 {
1438 checkvar = (expptr) cpexpr(p);
1439 t = p;
1440 }
1441 else {
1442 checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
1443 t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
1444 }
1445 checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
1446 if( ! ISICON(p) )
1447 checkcond = mkexpr(OPAND, checkcond,
1448 mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
1449
1450/* Construct the actual test */
1451
1452 badcall = call4(p->headblock.vtype, "s_rnge",
1453 mkstrcon(strlen(np->fvarname), np->fvarname),
1454 mkconv(TYLONG, cpexpr(checkvar)),
1455 mkstrcon(strlen(procname), procname),
1456 ICON(lineno) );
1457 badcall->exprblock.opcode = OPCCALL;
1458 p = mkexpr(OPQUEST, checkcond,
1459 mkexpr(OPCOLON, checkvar, badcall));
1460
1461 return(p);
1462
1463badsub:
1464 frexpr(p);
1465 errstr("subscript on variable %s out of range", np->fvarname);
1466 return ( ICON(0) );
1467}
1468
1469
1470
1471
1472Addrp mkaddr(p)
1473register Namep p;
1474{
1475 Extsym *extp;
1476 register Addrp t;
1477 Addrp intraddr();
1478 int k;
1479
1480 switch( p->vstg)
1481 {
1482 case STGAUTO:
1483 if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
1484 return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
1485 goto other;
1486
1487 case STGUNKNOWN:
1488 if(p->vclass != CLPROC)
1489 break; /* Error */
1490 extp = mkext(p->fvarname, addunder(p->cvarname));
1491 extp->extstg = STGEXT;
1492 p->vstg = STGEXT;
1493 p->vardesc.varno = extp - extsymtab;
1494 p->vprocclass = PEXTERNAL;
1495 if ((extp->exproto || infertypes)
1496 && (p->vtype == TYUNKNOWN || p->vimpltype)
1497 && (k = extp->extype))
1498 inferdcl(p, k);
1499
1500
1501 case STGCOMMON:
1502 case STGEXT:
1503 case STGBSS:
1504 case STGINIT:
1505 case STGEQUIV:
1506 case STGARG:
1507 case STGLENG:
1508 other:
1509 t = ALLOC(Addrblock);
1510 t->tag = TADDR;
1511
1512 t->vclass = p->vclass;
1513 t->vtype = p->vtype;
1514 t->vstg = p->vstg;
1515 t->memno = p->vardesc.varno;
1516 t->memoffset = ICON(p->voffset);
1517 if (p->vdim)
1518 t->isarray = 1;
1519 if(p->vleng)
1520 {
1521 t->vleng = (expptr) cpexpr(p->vleng);
1522 if( ISICON(t->vleng) )
1523 t->varleng = t->vleng->constblock.Const.ci;
1524 }
1525
1526/* Keep the original name around for the C code generation */
1527
1528 t -> uname_tag = UNAM_NAME;
1529 t -> user.name = p;
1530 return(t);
1531
1532 case STGINTR:
1533
1534 return ( intraddr (p));
1535 }
1536 badstg("mkaddr", p->vstg);
1537 /* NOT REACHED */ return 0;
1538}
1539
1540
1541
1542
1543/* mkarg -- create storage for a new parameter. This is called when a
1544 function returns a string (for the return value, which is the first
1545 parameter), or when a variable-length string is passed to a function. */
1546
1547Addrp mkarg(type, argno)
1548int type, argno;
1549{
1550 register Addrp p;
1551
1552 p = ALLOC(Addrblock);
1553 p->tag = TADDR;
1554 p->vtype = type;
1555 p->vclass = CLVAR;
1556
1557/* TYLENG is the type of the field holding the length of a character string */
1558
1559 p->vstg = (type==TYLENG ? STGLENG : STGARG);
1560 p->memno = argno;
1561 return(p);
1562}
1563
1564
1565
1566
1567/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
1568 Nameblock (or Paramblock), arguments (actual params or array
1569 subscripts) and substring bounds. Requires that v have lots of
1570 extra (uninitialized) storage, since it could be a paramblock or
1571 nameblock */
1572
1573expptr mkprim(v0, args, substr)
1574 Namep v0;
1575 struct Listblock *args;
1576 chainp substr;
1577{
1578 typedef union {
1579 struct Paramblock paramblock;
1580 struct Nameblock nameblock;
1581 struct Headblock headblock;
1582 } *Primu;
1583 register Primu v = (Primu)v0;
1584 register struct Primblock *p;
1585
1586 if(v->headblock.vclass == CLPARAM)
1587 {
1588
1589/* v is to be a Paramblock */
1590
1591 if(args || substr)
1592 {
1593 errstr("no qualifiers on parameter name %s",
1594 v->paramblock.fvarname);
1595 frexpr((expptr)args);
1596 if(substr)
1597 {
1598 frexpr((tagptr)substr->datap);
1599 frexpr((tagptr)substr->nextp->datap);
1600 frchain(&substr);
1601 }
1602 frexpr((expptr)v);
1603 return( errnode() );
1604 }
1605 return( (expptr) cpexpr(v->paramblock.paramval) );
1606 }
1607
1608 p = ALLOC(Primblock);
1609 p->tag = TPRIM;
1610 p->vtype = v->nameblock.vtype;
1611
1612/* v is to be a Nameblock */
1613
1614 p->namep = (Namep) v;
1615 p->argsp = args;
1616 if(substr)
1617 {
1618 p->fcharp = (expptr) substr->datap;
1619 p->lcharp = (expptr) substr->nextp->datap;
1620 frchain(&substr);
1621 }
1622 return( (expptr) p);
1623}
1624
1625
1626
1627/* vardcl -- attempt to fill out the Name template for variable v.
1628 This function is called on identifiers known to be variables or
1629 recursive references to the same function */
1630
1631vardcl(v)
1632register Namep v;
1633{
1634 struct Dimblock *t;
1635 expptr neltp;
1636 extern int doing_stmtfcn;
1637
1638 if(v->vclass == CLUNKNOWN) {
1639 v->vclass = CLVAR;
1640 if (v->vinftype) {
1641 v->vtype = TYUNKNOWN;
1642 if (v->vdcldone) {
1643 v->vdcldone = 0;
1644 impldcl(v);
1645 }
1646 }
1647 }
1648 if(v->vdcldone)
1649 return;
1650 if(v->vclass == CLNAMELIST)
1651 return;
1652
1653 if(v->vtype == TYUNKNOWN)
1654 impldcl(v);
1655 else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
1656 {
1657 dclerr("used as variable", v);
1658 return;
1659 }
1660 if(v->vstg==STGUNKNOWN) {
1661 if (doing_stmtfcn) {
1662 /* neither declare this variable if its only use */
1663 /* is in defining a stmt function, nor complain */
1664 /* that it is never used */
1665 v->vimpldovar = 1;
1666 return;
1667 }
1668 v->vstg = implstg[ letter(v->fvarname[0]) ];
1669 v->vimplstg = 1;
1670 }
1671
1672/* Compute the actual storage location, i.e. offsets from base addresses,
1673 possibly the stack pointer */
1674
1675 switch(v->vstg)
1676 {
1677 case STGBSS:
1678 v->vardesc.varno = ++lastvarno;
1679 break;
1680 case STGAUTO:
1681 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
1682 break;
1683 if(t = v->vdim)
1684 if( (neltp = t->nelt) && ISCONST(neltp) ) ;
1685 else
1686 dclerr("adjustable automatic array", v);
1687 break;
1688
1689 default:
1690 break;
1691 }
1692 v->vdcldone = YES;
1693}
1694
1695
1696
1697/* Set the implicit type declaration of parameter p based on its first
1698 letter */
1699
1700impldcl(p)
1701register Namep p;
1702{
1703 register int k;
1704 int type;
1705 ftnint leng;
1706
1707 if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
1708 return;
1709 if(p->vtype == TYUNKNOWN)
1710 {
1711 k = letter(p->fvarname[0]);
1712 type = impltype[ k ];
1713 leng = implleng[ k ];
1714 if(type == TYUNKNOWN)
1715 {
1716 if(p->vclass == CLPROC)
1717 return;
1718 dclerr("attempt to use undefined variable", p);
1719 type = dflttype[k];
1720 leng = 0;
1721 }
1722 settype(p, type, leng);
1723 p->vimpltype = 1;
1724 }
1725}
1726
1727 void
1728inferdcl(np,type)
1729 Namep np;
1730 int type;
1731{
1732 int k = impltype[letter(np->fvarname[0])];
1733 if (k != type) {
1734 np->vinftype = 1;
1735 np->vtype = type;
1736 frexpr(np->vleng);
1737 np->vleng = 0;
1738 }
1739 np->vimpltype = 0;
1740 np->vinfproc = 1;
1741 }
1742
1743
1744#define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c)
1745#define COMMUTE { e = lp; lp = rp; rp = e; }
1746
1747
1748
1749/* mkexpr -- Make expression, and simplify constant subcomponents (tree
1750 order is not preserved). Assumes that lp is nonempty, and uses
1751 fold() to simplify adjacent constants */
1752
1753expptr mkexpr(opcode, lp, rp)
1754int opcode;
1755register expptr lp, rp;
1756{
1757 register expptr e, e1;
1758 int etype;
1759 int ltype, rtype;
1760 int ltag, rtag;
1761 long L;
1762
1763 ltype = lp->headblock.vtype;
1764 ltag = lp->tag;
1765 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1766 {
1767 rtype = rp->headblock.vtype;
1768 rtag = rp->tag;
1769 }
1770 else rtype = 0;
1771
1772 etype = cktype(opcode, ltype, rtype);
1773 if(etype == TYERROR)
1774 goto error;
1775
1776 switch(opcode)
1777 {
1778 /* check for multiplication by 0 and 1 and addition to 0 */
1779
1780 case OPSTAR:
1781 if( ISCONST(lp) )
1782 COMMUTE
1783
1784 if( ISICON(rp) )
1785 {
1786 if(rp->constblock.Const.ci == 0)
1787 goto retright;
1788 goto mulop;
1789 }
1790 break;
1791
1792 case OPSLASH:
1793 case OPMOD:
1794 if( ICONEQ(rp, 0) )
1795 {
1796 err("attempted division by zero");
1797 rp = ICON(1);
1798 break;
1799 }
1800 if(opcode == OPMOD)
1801 break;
1802
1803/* Handle multiplying or dividing by 1, -1 */
1804
1805mulop:
1806 if( ISICON(rp) )
1807 {
1808 if(rp->constblock.Const.ci == 1)
1809 goto retleft;
1810
1811 if(rp->constblock.Const.ci == -1)
1812 {
1813 frexpr(rp);
1814 return( mkexpr(OPNEG, lp, ENULL) );
1815 }
1816 }
1817
1818/* Group all constants together. In particular,
1819
1820 (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
1821 (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
1822*/
1823
1824 if (lp->tag != TEXPR || !lp->exprblock.rightp
1825 || !ISICON(lp->exprblock.rightp))
1826 break;
1827
1828 if (lp->exprblock.opcode == OPLSHIFT) {
1829 L = 1 << lp->exprblock.rightp->constblock.Const.ci;
1830 if (opcode == OPSTAR || ISICON(rp) &&
1831 !(L % rp->constblock.Const.ci)) {
1832 lp->exprblock.opcode = OPSTAR;
1833 lp->exprblock.rightp->constblock.Const.ci = L;
1834 }
1835 }
1836
1837 if (lp->exprblock.opcode == OPSTAR) {
1838 if(opcode == OPSTAR)
1839 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
1840 else if(ISICON(rp) &&
1841 (lp->exprblock.rightp->constblock.Const.ci %
1842 rp->constblock.Const.ci) == 0)
1843 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
1844 else break;
1845
1846 e1 = lp->exprblock.leftp;
1847 free( (charptr) lp );
1848 return( mkexpr(OPSTAR, e1, e) );
1849 }
1850 break;
1851
1852
1853 case OPPLUS:
1854 if( ISCONST(lp) )
1855 COMMUTE
1856 goto addop;
1857
1858 case OPMINUS:
1859 if( ICONEQ(lp, 0) )
1860 {
1861 frexpr(lp);
1862 return( mkexpr(OPNEG, rp, ENULL) );
1863 }
1864
1865 if( ISCONST(rp) && is_negatable((Constp)rp))
1866 {
1867 opcode = OPPLUS;
1868 consnegop((Constp)rp);
1869 }
1870
1871/* Group constants in an addition expression (also subtraction, since the
1872 subtracted value was negated above). In particular,
1873
1874 (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
1875*/
1876
1877addop:
1878 if( ISICON(rp) )
1879 {
1880 if(rp->constblock.Const.ci == 0)
1881 goto retleft;
1882 if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
1883 {
1884 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
1885 e1 = lp->exprblock.leftp;
1886 free( (charptr) lp );
1887 return( mkexpr(OPPLUS, e1, e) );
1888 }
1889 }
1890 if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
1891 /* check for (i [+const]) - (i [+const]) */
1892 if (lp->tag == TPRIM)
1893 e = lp;
1894 else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
1895 && lp->exprblock.rightp->tag == TCONST) {
1896 e = lp->exprblock.leftp;
1897 if (e->tag != TPRIM)
1898 break;
1899 }
1900 else
1901 break;
1902 if (e->primblock.argsp)
1903 break;
1904 if (rp->tag == TPRIM)
1905 e1 = rp;
1906 else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
1907 && rp->exprblock.rightp->tag == TCONST) {
1908 e1 = rp->exprblock.leftp;
1909 if (e1->tag != TPRIM)
1910 break;
1911 }
1912 else
1913 break;
1914 if (e->primblock.namep != e1->primblock.namep
1915 || e1->primblock.argsp)
1916 break;
1917 L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
1918 if (e1 != rp)
1919 L -= rp->exprblock.rightp->constblock.Const.ci;
1920 frexpr(lp);
1921 frexpr(rp);
1922 return ICON(L);
1923 }
1924
1925 break;
1926
1927
1928 case OPPOWER:
1929 break;
1930
1931/* Eliminate outermost double negations */
1932
1933 case OPNEG:
1934 case OPNEG1:
1935 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
1936 {
1937 e = lp->exprblock.leftp;
1938 free( (charptr) lp );
1939 return(e);
1940 }
1941 break;
1942
1943/* Eliminate outermost double NOTs */
1944
1945 case OPNOT:
1946 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
1947 {
1948 e = lp->exprblock.leftp;
1949 free( (charptr) lp );
1950 return(e);
1951 }
1952 break;
1953
1954 case OPCALL:
1955 case OPCCALL:
1956 etype = ltype;
1957 if(rp!=NULL && rp->listblock.listp==NULL)
1958 {
1959 free( (charptr) rp );
1960 rp = NULL;
1961 }
1962 break;
1963
1964 case OPAND:
1965 case OPOR:
1966 if( ISCONST(lp) )
1967 COMMUTE
1968
1969 if( ISCONST(rp) )
1970 {
1971 if(rp->constblock.Const.ci == 0)
1972 if(opcode == OPOR)
1973 goto retleft;
1974 else
1975 goto retright;
1976 else if(opcode == OPOR)
1977 goto retright;
1978 else
1979 goto retleft;
1980 }
1981 case OPEQV:
1982 case OPNEQV:
1983
1984 case OPBITAND:
1985 case OPBITOR:
1986 case OPBITXOR:
1987 case OPBITNOT:
1988 case OPLSHIFT:
1989 case OPRSHIFT:
1990
1991 case OPLT:
1992 case OPGT:
1993 case OPLE:
1994 case OPGE:
1995 case OPEQ:
1996 case OPNE:
1997
1998 case OPCONCAT:
1999 break;
2000 case OPMIN:
2001 case OPMAX:
2002 case OPMIN2:
2003 case OPMAX2:
2004 case OPDMIN:
2005 case OPDMAX:
2006
2007 case OPASSIGN:
2008 case OPASSIGNI:
2009 case OPPLUSEQ:
2010 case OPSTAREQ:
2011 case OPMINUSEQ:
2012 case OPSLASHEQ:
2013 case OPMODEQ:
2014 case OPLSHIFTEQ:
2015 case OPRSHIFTEQ:
2016 case OPBITANDEQ:
2017 case OPBITXOREQ:
2018 case OPBITOREQ:
2019
2020 case OPCONV:
2021 case OPADDR:
2022 case OPWHATSIN:
2023
2024 case OPCOMMA:
2025 case OPCOMMA_ARG:
2026 case OPQUEST:
2027 case OPCOLON:
2028 case OPDOT:
2029 case OPARROW:
2030 case OPIDENTITY:
2031 case OPCHARCAST:
2032 case OPABS:
2033 case OPDABS:
2034 break;
2035
2036 default:
2037 badop("mkexpr", opcode);
2038 }
2039
2040 e = (expptr) ALLOC(Exprblock);
2041 e->exprblock.tag = TEXPR;
2042 e->exprblock.opcode = opcode;
2043 e->exprblock.vtype = etype;
2044 e->exprblock.leftp = lp;
2045 e->exprblock.rightp = rp;
2046 if(ltag==TCONST && (rp==0 || rtag==TCONST) )
2047 e = fold(e);
2048 return(e);
2049
2050retleft:
2051 frexpr(rp);
2052 if (lp->tag == TPRIM)
2053 lp->primblock.parenused = 1;
2054 return(lp);
2055
2056retright:
2057 frexpr(lp);
2058 if (rp->tag == TPRIM)
2059 rp->primblock.parenused = 1;
2060 return(rp);
2061
2062error:
2063 frexpr(lp);
2064 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
2065 frexpr(rp);
2066 return( errnode() );
2067}
2068
2069#define ERR(s) { errs = s; goto error; }
2070
2071/* cktype -- Check and return the type of the expression */
2072
2073cktype(op, lt, rt)
2074register int op, lt, rt;
2075{
2076 char *errs;
2077
2078 if(lt==TYERROR || rt==TYERROR)
2079 goto error1;
2080
2081 if(lt==TYUNKNOWN)
2082 return(TYUNKNOWN);
2083 if(rt==TYUNKNOWN)
2084
2085/* If not unary operation, return UNKNOWN */
2086
2087 if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
2088 return(TYUNKNOWN);
2089
2090 switch(op)
2091 {
2092 case OPPLUS:
2093 case OPMINUS:
2094 case OPSTAR:
2095 case OPSLASH:
2096 case OPPOWER:
2097 case OPMOD:
2098 if( ISNUMERIC(lt) && ISNUMERIC(rt) )
2099 return( maxtype(lt, rt) );
2100 ERR("nonarithmetic operand of arithmetic operator")
2101
2102 case OPNEG:
2103 case OPNEG1:
2104 if( ISNUMERIC(lt) )
2105 return(lt);
2106 ERR("nonarithmetic operand of negation")
2107
2108 case OPNOT:
2109 if(ISLOGICAL(lt))
2110 return(lt);
2111 ERR("NOT of nonlogical")
2112
2113 case OPAND:
2114 case OPOR:
2115 case OPEQV:
2116 case OPNEQV:
2117 if(ISLOGICAL(lt) && ISLOGICAL(rt))
2118 return( maxtype(lt, rt) );
2119 ERR("nonlogical operand of logical operator")
2120
2121 case OPLT:
2122 case OPGT:
2123 case OPLE:
2124 case OPGE:
2125 case OPEQ:
2126 case OPNE:
2127 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
2128 {
2129 if(lt != rt){
2130 if (htype
2131 && (lt == TYCHAR && ISNUMERIC(rt)
2132 || rt == TYCHAR && ISNUMERIC(lt)))
2133 return TYLOGICAL;
2134 ERR("illegal comparison")
2135 }
2136 }
2137
2138 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
2139 {
2140 if(op!=OPEQ && op!=OPNE)
2141 ERR("order comparison of complex data")
2142 }
2143
2144 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
2145 ERR("comparison of nonarithmetic data")
2146 return(TYLOGICAL);
2147
2148 case OPCONCAT:
2149 if(lt==TYCHAR && rt==TYCHAR)
2150 return(TYCHAR);
2151 ERR("concatenation of nonchar data")
2152
2153 case OPCALL:
2154 case OPCCALL:
2155 case OPIDENTITY:
2156 return(lt);
2157
2158 case OPADDR:
2159 case OPCHARCAST:
2160 return(TYADDR);
2161
2162 case OPCONV:
2163 if(rt == 0)
2164 return(0);
2165 if(lt==TYCHAR && ISINT(rt) )
2166 return(TYCHAR);
2167 if (ISLOGICAL(lt) && ISLOGICAL(rt))
2168 return lt;
2169 case OPASSIGN:
2170 case OPASSIGNI:
2171 case OPMINUSEQ:
2172 case OPPLUSEQ:
2173 case OPSTAREQ:
2174 case OPSLASHEQ:
2175 case OPMODEQ:
2176 case OPLSHIFTEQ:
2177 case OPRSHIFTEQ:
2178 case OPBITANDEQ:
2179 case OPBITXOREQ:
2180 case OPBITOREQ:
2181 if( ISINT(lt) && rt==TYCHAR)
2182 return(lt);
2183 if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
2184 return lt;
2185 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
2186 if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
2187 || (lt!=rt))
2188 {
2189 ERR("impossible conversion")
2190 }
2191 return(lt);
2192
2193 case OPMIN:
2194 case OPMAX:
2195 case OPDMIN:
2196 case OPDMAX:
2197 case OPMIN2:
2198 case OPMAX2:
2199 case OPBITOR:
2200 case OPBITAND:
2201 case OPBITXOR:
2202 case OPBITNOT:
2203 case OPLSHIFT:
2204 case OPRSHIFT:
2205 case OPWHATSIN:
2206 case OPABS:
2207 case OPDABS:
2208 return(lt);
2209
2210 case OPCOMMA:
2211 case OPCOMMA_ARG:
2212 case OPQUEST:
2213 case OPCOLON: /* Only checks the rightmost type because
2214 of C language definition (rightmost
2215 comma-expr is the value of the expr) */
2216 return(rt);
2217
2218 case OPDOT:
2219 case OPARROW:
2220 return (lt);
2221 break;
2222 default:
2223 badop("cktype", op);
2224 }
2225error:
2226 err(errs);
2227error1:
2228 return(TYERROR);
2229}
2230
2231/* fold -- simplifies constant expressions; it assumes that e -> leftp and
2232 e -> rightp are TCONST or NULL */
2233
2234 LOCAL expptr
2235fold(e)
2236 register expptr e;
2237{
2238 Constp p;
2239 register expptr lp, rp;
2240 int etype, mtype, ltype, rtype, opcode;
2241 int i, bl, ll, lr;
2242 char *q, *s;
2243 struct Constblock lcon, rcon;
2244 long L;
2245 double d;
2246
2247 opcode = e->exprblock.opcode;
2248 etype = e->exprblock.vtype;
2249
2250 lp = e->exprblock.leftp;
2251 ltype = lp->headblock.vtype;
2252 rp = e->exprblock.rightp;
2253
2254 if(rp == 0)
2255 switch(opcode)
2256 {
2257 case OPNOT:
2258 lp->constblock.Const.ci = ! lp->constblock.Const.ci;
2259 retlp:
2260 e->exprblock.leftp = 0;
2261 frexpr(e);
2262 return(lp);
2263
2264 case OPBITNOT:
2265 lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
2266 goto retlp;
2267
2268 case OPNEG:
2269 case OPNEG1:
2270 consnegop((Constp)lp);
2271 goto retlp;
2272
2273 case OPCONV:
2274 case OPADDR:
2275 return(e);
2276
2277 case OPABS:
2278 case OPDABS:
2279 switch(ltype) {
2280 case TYINT1:
2281 case TYSHORT:
2282 case TYLONG:
2283#ifdef TYQUAD
2284 case TYQUAD:
2285#endif
2286 if ((L = lp->constblock.Const.ci) < 0)
2287 lp->constblock.Const.ci = -L;
2288 goto retlp;
2289 case TYREAL:
2290 case TYDREAL:
2291 if (lp->constblock.vstg) {
2292 s = lp->constblock.Const.cds[0];
2293 if (*s == '-')
2294 lp->constblock.Const.cds[0] = s + 1;
2295 goto retlp;
2296 }
2297 if ((d = lp->constblock.Const.cd[0]) < 0.)
2298 lp->constblock.Const.cd[0] = -d;
2299 case TYCOMPLEX:
2300 case TYDCOMPLEX:
2301 return e; /* lazy way out */
2302 }
2303 default:
2304 badop("fold", opcode);
2305 }
2306
2307 rtype = rp->headblock.vtype;
2308
2309 p = ALLOC(Constblock);
2310 p->tag = TCONST;
2311 p->vtype = etype;
2312 p->vleng = e->exprblock.vleng;
2313
2314 switch(opcode)
2315 {
2316 case OPCOMMA:
2317 case OPCOMMA_ARG:
2318 case OPQUEST:
2319 case OPCOLON:
2320 return(e);
2321
2322 case OPAND:
2323 p->Const.ci = lp->constblock.Const.ci &&
2324 rp->constblock.Const.ci;
2325 break;
2326
2327 case OPOR:
2328 p->Const.ci = lp->constblock.Const.ci ||
2329 rp->constblock.Const.ci;
2330 break;
2331
2332 case OPEQV:
2333 p->Const.ci = lp->constblock.Const.ci ==
2334 rp->constblock.Const.ci;
2335 break;
2336
2337 case OPNEQV:
2338 p->Const.ci = lp->constblock.Const.ci !=
2339 rp->constblock.Const.ci;
2340 break;
2341
2342 case OPBITAND:
2343 p->Const.ci = lp->constblock.Const.ci &
2344 rp->constblock.Const.ci;
2345 break;
2346
2347 case OPBITOR:
2348 p->Const.ci = lp->constblock.Const.ci |
2349 rp->constblock.Const.ci;
2350 break;
2351
2352 case OPBITXOR:
2353 p->Const.ci = lp->constblock.Const.ci ^
2354 rp->constblock.Const.ci;
2355 break;
2356
2357 case OPLSHIFT:
2358 p->Const.ci = lp->constblock.Const.ci <<
2359 rp->constblock.Const.ci;
2360 break;
2361
2362 case OPRSHIFT:
2363 p->Const.ci = lp->constblock.Const.ci >>
2364 rp->constblock.Const.ci;
2365 break;
2366
2367 case OPCONCAT:
2368 ll = lp->constblock.vleng->constblock.Const.ci;
2369 lr = rp->constblock.vleng->constblock.Const.ci;
2370 bl = lp->constblock.Const.ccp1.blanks;
2371 p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
2372 p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
2373 p->vleng = ICON(ll+lr+bl);
2374 s = lp->constblock.Const.ccp;
2375 for(i = 0 ; i < ll ; ++i)
2376 *q++ = *s++;
2377 for(i = 0 ; i < bl ; i++)
2378 *q++ = ' ';
2379 s = rp->constblock.Const.ccp;
2380 for(i = 0; i < lr; ++i)
2381 *q++ = *s++;
2382 break;
2383
2384
2385 case OPPOWER:
2386 if( ! ISINT(rtype) )
2387 return(e);
2388 conspower(p, (Constp)lp, rp->constblock.Const.ci);
2389 break;
2390
2391
2392 default:
2393 if(ltype == TYCHAR)
2394 {
2395 lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
2396 rp->constblock.Const.ccp,
2397 lp->constblock.vleng->constblock.Const.ci,
2398 rp->constblock.vleng->constblock.Const.ci);
2399 rcon.Const.ci = 0;
2400 mtype = tyint;
2401 }
2402 else {
2403 mtype = maxtype(ltype, rtype);
2404 consconv(mtype, &lcon, &lp->constblock);
2405 consconv(mtype, &rcon, &rp->constblock);
2406 }
2407 consbinop(opcode, mtype, p, &lcon, &rcon);
2408 break;
2409 }
2410
2411 frexpr(e);
2412 return( (expptr) p );
2413}
2414
2415
2416
2417/* assign constant l = r , doing coercion */
2418
2419consconv(lt, lc, rc)
2420 int lt;
2421 register Constp lc, rc;
2422{
2423 int rt = rc->vtype;
2424 register union Constant *lv = &lc->Const, *rv = &rc->Const;
2425
2426 lc->vtype = lt;
2427 if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
2428 memcpy((char *)lv, (char *)rv, sizeof(union Constant));
2429 lc->vstg = rc->vstg;
2430 if (ISCOMPLEX(lt) && ISREAL(rt)) {
2431 if (rc->vstg)
2432 lv->cds[1] = cds("0",CNULL);
2433 else
2434 lv->cd[1] = 0.;
2435 }
2436 return;
2437 }
2438 lc->vstg = 0;
2439
2440 switch(lt)
2441 {
2442
2443/* Casting to character means just copying the first sizeof (character)
2444 bytes into a new 1 character string. This is weird. */
2445
2446 case TYCHAR:
2447 *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
2448 lv->ccp1.blanks = 0;
2449 break;
2450
2451 case TYINT1:
2452 case TYSHORT:
2453 case TYLONG:
2454#ifdef TYQUAD
2455 case TYQUAD:
2456#endif
2457 if(rt == TYCHAR)
2458 lv->ci = rv->ccp[0];
2459 else if( ISINT(rt) )
2460 lv->ci = rv->ci;
2461 else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
2462
2463 break;
2464
2465 case TYCOMPLEX:
2466 case TYDCOMPLEX:
2467 lv->cd[1] = 0.;
2468 lv->cd[0] = rv->ci;
2469 break;
2470
2471 case TYREAL:
2472 case TYDREAL:
2473 lv->cd[0] = rv->ci;
2474 break;
2475
2476 case TYLOGICAL:
2477 case TYLOGICAL1:
2478 case TYLOGICAL2:
2479 lv->ci = rv->ci;
2480 break;
2481 }
2482}
2483
2484
2485
2486/* Negate constant value -- changes the input node's value */
2487
2488consnegop(p)
2489register Constp p;
2490{
2491 register char *s;
2492
2493 if (p->vstg) {
2494 if (ISCOMPLEX(p->vtype)) {
2495 s = p->Const.cds[1];
2496 p->Const.cds[1] = *s == '-' ? s+1
2497 : *s == '0' ? s : s-1;
2498 }
2499 s = p->Const.cds[0];
2500 p->Const.cds[0] = *s == '-' ? s+1
2501 : *s == '0' ? s : s-1;
2502 return;
2503 }
2504 switch(p->vtype)
2505 {
2506 case TYINT1:
2507 case TYSHORT:
2508 case TYLONG:
2509#ifdef TYQUAD
2510 case TYQUAD:
2511#endif
2512 p->Const.ci = - p->Const.ci;
2513 break;
2514
2515 case TYCOMPLEX:
2516 case TYDCOMPLEX:
2517 p->Const.cd[1] = - p->Const.cd[1];
2518 /* fall through and do the real parts */
2519 case TYREAL:
2520 case TYDREAL:
2521 p->Const.cd[0] = - p->Const.cd[0];
2522 break;
2523 default:
2524 badtype("consnegop", p->vtype);
2525 }
2526}
2527
2528
2529
2530/* conspower -- Expand out an exponentiation */
2531
2532 LOCAL void
2533conspower(p, ap, n)
2534 Constp p, ap;
2535 ftnint n;
2536{
2537 register union Constant *powp = &p->Const;
2538 register int type;
2539 struct Constblock x, x0;
2540
2541 if (n == 1) {
2542 memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
2543 return;
2544 }
2545
2546 switch(type = ap->vtype) /* pow = 1 */
2547 {
2548 case TYINT1:
2549 case TYSHORT:
2550 case TYLONG:
2551#ifdef TYQUAD
2552 case TYQUAD:
2553#endif
2554 powp->ci = 1;
2555 break;
2556 case TYCOMPLEX:
2557 case TYDCOMPLEX:
2558 powp->cd[1] = 0;
2559 case TYREAL:
2560 case TYDREAL:
2561 powp->cd[0] = 1;
2562 break;
2563 default:
2564 badtype("conspower", type);
2565 }
2566
2567 if(n == 0)
2568 return;
2569 switch(type) /* x0 = ap */
2570 {
2571 case TYINT1:
2572 case TYSHORT:
2573 case TYLONG:
2574#ifdef TYQUAD
2575 case TYQUAD:
2576#endif
2577 x0.Const.ci = ap->Const.ci;
2578 break;
2579 case TYCOMPLEX:
2580 case TYDCOMPLEX:
2581 x0.Const.cd[1] =
2582 ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
2583 case TYREAL:
2584 case TYDREAL:
2585 x0.Const.cd[0] =
2586 ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
2587 break;
2588 }
2589 x0.vtype = type;
2590 x0.vstg = 0;
2591 if(n < 0)
2592 {
2593 if( ISINT(type) )
2594 {
2595 err("integer ** negative number");
2596 return;
2597 }
2598 else if (!x0.Const.cd[0]
2599 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
2600 err("0.0 ** negative number");
2601 return;
2602 }
2603 n = -n;
2604 consbinop(OPSLASH, type, &x, p, &x0);
2605 }
2606 else
2607 consbinop(OPSTAR, type, &x, p, &x0);
2608
2609 for( ; ; )
2610 {
2611 if(n & 01)
2612 consbinop(OPSTAR, type, p, p, &x);
2613 if(n >>= 1)
2614 consbinop(OPSTAR, type, &x, &x, &x);
2615 else
2616 break;
2617 }
2618}
2619
2620
2621
2622/* do constant operation cp = a op b -- assumes that ap and bp have data
2623 matching the input type */
2624
2625 LOCAL void
2626zerodiv()
2627{ Fatal("division by zero during constant evaluation; cannot recover"); }
2628
2629 LOCAL void
2630consbinop(opcode, type, cpp, app, bpp)
2631 int opcode, type;
2632 Constp cpp, app, bpp;
2633{
2634 register union Constant *ap = &app->Const,
2635 *bp = &bpp->Const,
2636 *cp = &cpp->Const;
2637 int k;
2638 double ad[2], bd[2], temp;
2639
2640 cpp->vstg = 0;
2641
2642 if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
2643 ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
2644 bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
2645 if (ISCOMPLEX(type)) {
2646 ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
2647 bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
2648 }
2649 }
2650 switch(opcode)
2651 {
2652 case OPPLUS:
2653 switch(type)
2654 {
2655 case TYINT1:
2656 case TYSHORT:
2657 case TYLONG:
2658#ifdef TYQUAD
2659 case TYQUAD:
2660#endif
2661 cp->ci = ap->ci + bp->ci;
2662 break;
2663 case TYCOMPLEX:
2664 case TYDCOMPLEX:
2665 cp->cd[1] = ad[1] + bd[1];
2666 case TYREAL:
2667 case TYDREAL:
2668 cp->cd[0] = ad[0] + bd[0];
2669 break;
2670 }
2671 break;
2672
2673 case OPMINUS:
2674 switch(type)
2675 {
2676 case TYINT1:
2677 case TYSHORT:
2678 case TYLONG:
2679#ifdef TYQUAD
2680 case TYQUAD:
2681#endif
2682 cp->ci = ap->ci - bp->ci;
2683 break;
2684 case TYCOMPLEX:
2685 case TYDCOMPLEX:
2686 cp->cd[1] = ad[1] - bd[1];
2687 case TYREAL:
2688 case TYDREAL:
2689 cp->cd[0] = ad[0] - bd[0];
2690 break;
2691 }
2692 break;
2693
2694 case OPSTAR:
2695 switch(type)
2696 {
2697 case TYINT1:
2698 case TYSHORT:
2699 case TYLONG:
2700#ifdef TYQUAD
2701 case TYQUAD:
2702#endif
2703 cp->ci = ap->ci * bp->ci;
2704 break;
2705 case TYREAL:
2706 case TYDREAL:
2707 cp->cd[0] = ad[0] * bd[0];
2708 break;
2709 case TYCOMPLEX:
2710 case TYDCOMPLEX:
2711 temp = ad[0] * bd[0] - ad[1] * bd[1] ;
2712 cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ;
2713 cp->cd[0] = temp;
2714 break;
2715 }
2716 break;
2717 case OPSLASH:
2718 switch(type)
2719 {
2720 case TYINT1:
2721 case TYSHORT:
2722 case TYLONG:
2723#ifdef TYQUAD
2724 case TYQUAD:
2725#endif
2726 if (!bp->ci)
2727 zerodiv();
2728 cp->ci = ap->ci / bp->ci;
2729 break;
2730 case TYREAL:
2731 case TYDREAL:
2732 if (!bd[0])
2733 zerodiv();
2734 cp->cd[0] = ad[0] / bd[0];
2735 break;
2736 case TYCOMPLEX:
2737 case TYDCOMPLEX:
2738 if (!bd[0] && !bd[1])
2739 zerodiv();
2740 zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
2741 break;
2742 }
2743 break;
2744
2745 case OPMOD:
2746 if( ISINT(type) )
2747 {
2748 cp->ci = ap->ci % bp->ci;
2749 break;
2750 }
2751 else
2752 Fatal("inline mod of noninteger");
2753
2754 case OPMIN2:
2755 case OPDMIN:
2756 switch(type)
2757 {
2758 case TYINT1:
2759 case TYSHORT:
2760 case TYLONG:
2761#ifdef TYQUAD
2762 case TYQUAD:
2763#endif
2764 cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
2765 break;
2766 case TYREAL:
2767 case TYDREAL:
2768 cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
2769 break;
2770 default:
2771 Fatal("inline min of exected type");
2772 }
2773 break;
2774
2775 case OPMAX2:
2776 case OPDMAX:
2777 switch(type)
2778 {
2779 case TYINT1:
2780 case TYSHORT:
2781 case TYLONG:
2782#ifdef TYQUAD
2783 case TYQUAD:
2784#endif
2785 cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
2786 break;
2787 case TYREAL:
2788 case TYDREAL:
2789 cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
2790 break;
2791 default:
2792 Fatal("inline max of exected type");
2793 }
2794 break;
2795
2796 default: /* relational ops */
2797 switch(type)
2798 {
2799 case TYINT1:
2800 case TYSHORT:
2801 case TYLONG:
2802#ifdef TYQUAD
2803 case TYQUAD:
2804#endif
2805 if(ap->ci < bp->ci)
2806 k = -1;
2807 else if(ap->ci == bp->ci)
2808 k = 0;
2809 else k = 1;
2810 break;
2811 case TYREAL:
2812 case TYDREAL:
2813 if(ad[0] < bd[0])
2814 k = -1;
2815 else if(ad[0] == bd[0])
2816 k = 0;
2817 else k = 1;
2818 break;
2819 case TYCOMPLEX:
2820 case TYDCOMPLEX:
2821 if(ad[0] == bd[0] &&
2822 ad[1] == bd[1] )
2823 k = 0;
2824 else k = 1;
2825 break;
2826 }
2827
2828 switch(opcode)
2829 {
2830 case OPEQ:
2831 cp->ci = (k == 0);
2832 break;
2833 case OPNE:
2834 cp->ci = (k != 0);
2835 break;
2836 case OPGT:
2837 cp->ci = (k == 1);
2838 break;
2839 case OPLT:
2840 cp->ci = (k == -1);
2841 break;
2842 case OPGE:
2843 cp->ci = (k >= 0);
2844 break;
2845 case OPLE:
2846 cp->ci = (k <= 0);
2847 break;
2848 }
2849 break;
2850 }
2851}
2852
2853
2854
2855/* conssgn - returns the sign of a Fortran constant */
2856
2857conssgn(p)
2858register expptr p;
2859{
2860 register char *s;
2861
2862 if( ! ISCONST(p) )
2863 Fatal( "sgn(nonconstant)" );
2864
2865 switch(p->headblock.vtype)
2866 {
2867 case TYINT1:
2868 case TYSHORT:
2869 case TYLONG:
2870#ifdef TYQUAD
2871 case TYQUAD:
2872#endif
2873 if(p->constblock.Const.ci > 0) return(1);
2874 if(p->constblock.Const.ci < 0) return(-1);
2875 return(0);
2876
2877 case TYREAL:
2878 case TYDREAL:
2879 if (p->constblock.vstg) {
2880 s = p->constblock.Const.cds[0];
2881 if (*s == '-')
2882 return -1;
2883 if (*s == '0')
2884 return 0;
2885 return 1;
2886 }
2887 if(p->constblock.Const.cd[0] > 0) return(1);
2888 if(p->constblock.Const.cd[0] < 0) return(-1);
2889 return(0);
2890
2891
2892/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
2893
2894 case TYCOMPLEX:
2895 case TYDCOMPLEX:
2896 if (p->constblock.vstg)
2897 return *p->constblock.Const.cds[0] != '0'
2898 && *p->constblock.Const.cds[1] != '0';
2899 return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
2900
2901 default:
2902 badtype( "conssgn", p->constblock.vtype);
2903 }
2904 /* NOT REACHED */ return 0;
2905}
2906
2907char *powint[ ] = {
2908 "pow_ii",
2909#ifdef TYQUAD
2910 "pow_qi",
2911#endif
2912 "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2913
2914LOCAL expptr mkpower(p)
2915register expptr p;
2916{
2917 register expptr q, lp, rp;
2918 int ltype, rtype, mtype, tyi;
2919
2920 lp = p->exprblock.leftp;
2921 rp = p->exprblock.rightp;
2922 ltype = lp->headblock.vtype;
2923 rtype = rp->headblock.vtype;
2924
2925 if (lp->tag == TADDR)
2926 lp->addrblock.parenused = 0;
2927
2928 if (rp->tag == TADDR)
2929 rp->addrblock.parenused = 0;
2930
2931 if(ISICON(rp))
2932 {
2933 if(rp->constblock.Const.ci == 0)
2934 {
2935 frexpr(p);
2936 if( ISINT(ltype) )
2937 return( ICON(1) );
2938 else if (ISREAL (ltype))
2939 return mkconv (ltype, ICON (1));
2940 else
2941 return( (expptr) putconst((Constp)
2942 mkconv(ltype, ICON(1))) );
2943 }
2944 if(rp->constblock.Const.ci < 0)
2945 {
2946 if( ISINT(ltype) )
2947 {
2948 frexpr(p);
2949 err("integer**negative");
2950 return( errnode() );
2951 }
2952 rp->constblock.Const.ci = - rp->constblock.Const.ci;
2953 p->exprblock.leftp = lp
2954 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
2955 }
2956 if(rp->constblock.Const.ci == 1)
2957 {
2958 frexpr(rp);
2959 free( (charptr) p );
2960 return(lp);
2961 }
2962
2963 if( ONEOF(ltype, MSKINT|MSKREAL) ) {
2964 p->exprblock.vtype = ltype;
2965 return(p);
2966 }
2967 }
2968 if( ISINT(rtype) )
2969 {
2970 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2971 q = call2(TYSHORT, "pow_hh", lp, rp);
2972 else {
2973 if(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
2974 {
2975 ltype = TYLONG;
2976 lp = mkconv(TYLONG,lp);
2977 }
2978#ifdef TYQUAD
2979 if (ltype == TYQUAD)
2980 rp = mkconv(TYQUAD,rp);
2981 else
2982#endif
2983 rp = mkconv(TYLONG,rp);
2984 if (ISCONST(rp)) {
2985 tyi = tyint;
2986 tyint = TYLONG;
2987 rp = (expptr)putconst((Constp)rp);
2988 tyint = tyi;
2989 }
2990 q = call2(ltype, powint[ltype-TYLONG], lp, rp);
2991 }
2992 }
2993 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
2994 extern int callk_kludge;
2995 callk_kludge = TYDREAL;
2996 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2997 callk_kludge = 0;
2998 }
2999 else {
3000 q = call2(TYDCOMPLEX, "pow_zz",
3001 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
3002 if(mtype == TYCOMPLEX)
3003 q = mkconv(TYCOMPLEX, q);
3004 }
3005 free( (charptr) p );
3006 return(q);
3007}
3008
3009
3010/* Complex Division. Same code as in Runtime Library
3011*/
3012
3013
3014 LOCAL void
3015zdiv(c, a, b)
3016 register dcomplex *a, *b, *c;
3017{
3018 double ratio, den;
3019 double abr, abi;
3020
3021 if( (abr = b->dreal) < 0.)
3022 abr = - abr;
3023 if( (abi = b->dimag) < 0.)
3024 abi = - abi;
3025 if( abr <= abi )
3026 {
3027 if(abi == 0)
3028 Fatal("complex division by zero");
3029 ratio = b->dreal / b->dimag ;
3030 den = b->dimag * (1 + ratio*ratio);
3031 c->dreal = (a->dreal*ratio + a->dimag) / den;
3032 c->dimag = (a->dimag*ratio - a->dreal) / den;
3033 }
3034
3035 else
3036 {
3037 ratio = b->dimag / b->dreal ;
3038 den = b->dreal * (1 + ratio*ratio);
3039 c->dreal = (a->dreal + a->dimag*ratio) / den;
3040 c->dimag = (a->dimag - a->dreal*ratio) / den;
3041 }
3042}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.