Context Navigation

source: mainline/uspace/app/pcc/f77/fcom/expr.c@ 0ffbed9

Visit:

lfn serial ticket/834-toolchain-update topic/msim-upgrade topic/simplify-dev-export

Last change on this file since 0ffbed9 was a7de7182, checked in by Jiří Zárevúcky <zarevucky.jiri@…>, 15 years ago
Added pcc source tree (contents of pcc-1.0.0.tgz)
Property mode set to `100644`
File size: 39.0 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: