Context Navigation

source: mainline/uspace/app/pcc/f77/fcom/putscj.c@ a44424f

Visit:

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

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

Line
1	/* $Id: putscj.c,v 1.18 2008/12/19 08:08:48 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 conditions and 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	/* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
36	/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
37
38	#include <unistd.h>
39	#include <string.h>
40
41	#include "defines.h"
42	#include "defs.h"
43
44	#include "scjdefs.h"
45
46	LOCAL struct bigblock putcall(struct bigblock p);
47	LOCAL NODE putmnmx(struct bigblock p);
48	LOCAL NODE *putmem(bigptr, int, ftnint);
49	LOCAL NODE putaddr(struct bigblock , int);
50	LOCAL void putct1(bigptr, struct bigblock , struct bigblock , int *);
51	LOCAL int ncat(bigptr p);
52	LOCAL NODE putcat(struct bigblock , bigptr);
53	LOCAL NODE putchcmp(struct bigblock p);
54	LOCAL NODE putcheq(struct bigblock p);
55	LOCAL NODE putcxcmp(struct bigblock p);
56	LOCAL struct bigblock *putcx1(bigptr);
57	LOCAL NODE *putcxop(bigptr p);
58	LOCAL struct bigblock putcxeq(struct bigblock p);
59	LOCAL NODE *putpower(bigptr p);
60	LOCAL NODE *putop(bigptr p);
61	LOCAL NODE *putchop(bigptr p);
62	LOCAL struct bigblock *putch1(bigptr);
63	LOCAL struct bigblock intdouble(struct bigblock );
64
65	extern int ops2[];
66	extern int types2[];
67	static char *inproc;
68	static NODE callval; / to get return value right */
69	extern int negrel[];
70
71	#define XINT(z) ONEOF(z, MSKINT\|MSKCHAR)
72	#define P2TYPE(x) (types2[(x)->vtype])
73	#define P2OP(x) (ops2[(x)->b_expr.opcode])
74
75	static void
76	sendp2(NODE *p)
77	{
78	extern int thisline;
79
80	p2tree(p);
81	thisline = lineno;
82	if (debugflag)
83	fwalk(p, e2print, 0);
84	pass2_compile(ipnode(p));
85	}
86
87	static NODE *
88	putassign(bigptr lp, bigptr rp)
89	{
90	return putx(fixexpr(mkexpr(OPASSIGN, lp, rp)));
91	}
92
93
94	void
95	puthead(char *s)
96	{
97	struct interpass_prolog *ipp = ckalloc(sizeof(struct interpass_prolog));
98	int olbl, lbl1, lbl2;
99	unsigned int i;
100
101	if (s == NULL)
102	return;
103	if (inproc)
104	fatal1("puthead %s in procedure", s);
105	inproc = s;
106	olbl = lastlabno;
107	lbl1 = newlabel();
108	lbl2 = newlabel();
109
110	for (i = 0; i < NIPPREGS; i++)
111	ipp->ipp_regs[i] = 0; /* no regs used yet */
112	ipp->ipp_autos = 0; /* no autos used yet */
113	ipp->ipp_name = copys(s); /* function name */
114	ipp->ipp_type = INT; /* type not known yet? */
115	ipp->ipp_vis = 1; /* always visible */
116	ipp->ip_tmpnum = 0; /* no temp nodes used in F77 yet */
117	ipp->ip_lblnum = olbl; /* # used labels so far */
118	ipp->ipp_ip.ip_lbl = lbl1; /* first label, for optim */
119	ipp->ipp_ip.type = IP_PROLOG;
120	pass2_compile((struct interpass *)ipp);
121
122	}
123
124	/* It is necessary to precede each procedure with a "left bracket"
125	* line that tells pass 2 how many register variables and how
126	* much automatic space is required for the function. This compiler
127	* does not know how much automatic space is needed until the
128	* entire procedure has been processed. Therefore, "puthead"
129	* is called at the begining to record the current location in textfile,
130	* then to put out a placeholder left bracket line. This procedure
131	* repositions the file and rewrites that line, then puts the
132	* file pointer back to the end of the file.
133	*/
134
135	void
136	putbracket()
137	{
138	struct interpass_prolog *ipp = ckalloc(sizeof(struct interpass_prolog));
139	unsigned int i;
140
141	if (inproc == 0)
142	fatal1("puteof outside procedure");
143	for (i = 0; i < NIPPREGS; i++)
144	ipp->ipp_regs[i] = 0;
145	ipp->ipp_autos = autoleng;
146	ipp->ipp_name = copys(inproc);
147	ipp->ipp_type = INT; /* XXX should set the correct type */
148	ipp->ipp_vis = 1;
149	ipp->ip_tmpnum = 0;
150	ipp->ip_lblnum = lastlabno;
151	ipp->ipp_ip.ip_lbl = retlabel;
152	ipp->ipp_ip.type = IP_EPILOG;
153	printf("\t.text\n"); /* XXX */
154	pass2_compile((struct interpass *)ipp);
155	inproc = 0;
156	}
157
158
159
160	void
161	putrbrack(int k)
162	{
163	}
164
165
166	void
167	puteof()
168	{
169	}
170
171
172	/* put out code for if( ! p) goto l */
173	void
174	putif(bigptr p, int l)
175	{
176	NODE *p1;
177	int k;
178
179	if( ( k = (p = fixtype(p))->vtype) != TYLOGICAL) {
180	if(k != TYERROR)
181	err("non-logical expression in IF statement");
182	frexpr(p);
183	} else {
184	p1 = putex1(p);
185	if (p1->n_op == EQ && p1->n_right->n_op == ICON &&
186	p1->n_right->n_lval == 0 && logop(p1->n_left->n_op)) {
187	/* created by OPOR */
188	NODE *q = p1->n_left;
189	q->n_op = negrel[q->n_op - EQ];
190	nfree(p1->n_right);
191	nfree(p1);
192	p1 = q;
193	}
194	if (logop(p1->n_op) == 0)
195	p1 = mkbinode(NE, p1, mklnode(ICON, 0, 0, INT), INT);
196	if (p1->n_left->n_op == ICON) {
197	/* change constants to right */
198	NODE *p2 = p1->n_left;
199	p1->n_left = p1->n_right;
200	p1->n_right = p2;
201	if (p1->n_op != EQ && p1->n_op != NE)
202	p1->n_op = negrel[p1->n_op - EQ];
203	}
204	p1->n_op = negrel[p1->n_op - EQ];
205	p1 = mkbinode(CBRANCH, p1, mklnode(ICON, l, 0, INT), INT);
206	sendp2(p1);
207	}
208	}
209
210	/* Arithmetic IF */
211	void
212	prarif(bigptr p, int neg, int zer, int pos)
213	{
214	bigptr x1 = fmktemp(p->vtype, NULL);
215
216	putexpr(mkexpr(OPASSIGN, cpexpr(x1), p));
217	putif(mkexpr(OPGE, cpexpr(x1), MKICON(0)), neg);
218	putif(mkexpr(OPLE, x1, MKICON(0)), pos);
219	putgoto(zer);
220	}
221
222	/* put out code for goto l */
223	void
224	putgoto(int label)
225	{
226	NODE *p;
227
228	p = mkunode(GOTO, mklnode(ICON, label, 0, INT), 0, INT);
229	sendp2(p);
230	}
231
232
233	/* branch to address constant or integer variable */
234	void
235	putbranch(struct bigblock *q)
236	{
237	NODE *p;
238
239	p = mkunode(GOTO, putex1(q), 0, INT);
240	sendp2(p);
241	}
242
243	/*
244	* put out label l: in text segment
245	*/
246	void
247	putlabel(int label)
248	{
249	struct interpass *ip = ckalloc(sizeof(struct interpass));
250
251	ip->type = IP_DEFLAB;
252	ip->lineno = lineno;
253	ip->ip_lbl = label;
254	pass2_compile(ip);
255	}
256
257
258	/*
259	* Called from inner routines. Generates a NODE tree and writes it out.
260	*/
261	void
262	putexpr(bigptr q)
263	{
264	NODE *p;
265	p = putex1(q);
266	sendp2(p);
267	}
268
269
270
271	void
272	putcmgo(bigptr x, int nlab, struct labelblock *labels[])
273	{
274	bigptr y;
275	int i;
276
277	if (!ISINT(x->vtype)) {
278	execerr("computed goto index must be integer", NULL);
279	return;
280	}
281
282	y = fmktemp(x->vtype, NULL);
283	putexpr(mkexpr(OPASSIGN, cpexpr(y), x));
284	#ifdef notyet /* target-specific computed goto */
285	vaxgoto(y, nlab, labels);
286	#else
287	/*
288	* Primitive implementation, should use table here.
289	*/
290	for(i = 0 ; i < nlab ; ++i)
291	putif(mkexpr(OPNE, cpexpr(y), MKICON(i+1)), labels[i]->labelno);
292	frexpr(y);
293	#endif
294	}
295
296	/*
297	* Convert a f77 tree statement to something that looks like a
298	* pcc expression tree.
299	*/
300	NODE *
301	putx(bigptr q)
302	{
303	struct bigblock *x1;
304	NODE p = NULL; / XXX */
305	int opc;
306	int type, k;
307
308	#ifdef PCC_DEBUG
309	if (tflag) {
310	printf("putx %p\n", q);
311	fprint(q, 0);
312	}
313	#endif
314
315	switch(q->tag) {
316	case TERROR:
317	ckfree(q);
318	break;
319
320	case TCONST:
321	switch(type = q->vtype) {
322	case TYLOGICAL:
323	type = tyint;
324	case TYLONG:
325	case TYSHORT:
326	p = mklnode(ICON, q->b_const.fconst.ci,
327	0, types2[type]);
328	ckfree(q);
329	break;
330
331	case TYADDR:
332	p = mklnode(ICON, 0, 0, types2[type]);
333	p->n_name = copys(memname(STGCONST,
334	(int)q->b_const.fconst.ci));
335	ckfree(q);
336	break;
337
338	default:
339	p = putx(putconst(q));
340	break;
341	}
342	break;
343
344	case TEXPR:
345	switch(opc = q->b_expr.opcode) {
346	case OPCALL:
347	case OPCCALL:
348	if( ISCOMPLEX(q->vtype) )
349	p = putcxop(q);
350	else {
351	putcall(q);
352	p = callval;
353	}
354	break;
355
356	case OPMIN:
357	case OPMAX:
358	p = putmnmx(q);
359	break;
360
361	case OPASSIGN:
362	if (ISCOMPLEX(q->b_expr.leftp->vtype) \|\|
363	ISCOMPLEX(q->b_expr.rightp->vtype)) {
364	frexpr(putcxeq(q));
365	} else if (ISCHAR(q))
366	p = putcheq(q);
367	else
368	goto putopp;
369	break;
370
371	case OPEQ:
372	case OPNE:
373	if (ISCOMPLEX(q->b_expr.leftp->vtype) \|\|
374	ISCOMPLEX(q->b_expr.rightp->vtype) ) {
375	p = putcxcmp(q);
376	break;
377	}
378	case OPLT:
379	case OPLE:
380	case OPGT:
381	case OPGE:
382	if(ISCHAR(q->b_expr.leftp))
383	p = putchcmp(q);
384	else
385	goto putopp;
386	break;
387
388	case OPPOWER:
389	p = putpower(q);
390	break;
391
392	case OPSTAR:
393	/* m * (2*k) -> m<<k /
394	if (XINT(q->b_expr.leftp->vtype) &&
395	ISICON(q->b_expr.rightp) &&
396	((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) {
397	q->b_expr.opcode = OPLSHIFT;
398	frexpr(q->b_expr.rightp);
399	q->b_expr.rightp = MKICON(k);
400	goto putopp;
401	}
402
403	case OPMOD:
404	goto putopp;
405	case OPPLUS:
406	case OPMINUS:
407	case OPSLASH:
408	case OPNEG:
409	if( ISCOMPLEX(q->vtype) )
410	p = putcxop(q);
411	else
412	goto putopp;
413	break;
414
415	case OPCONV:
416	if( ISCOMPLEX(q->vtype) )
417	p = putcxop(q);
418	else if (ISCOMPLEX(q->b_expr.leftp->vtype)) {
419	p = putx(mkconv(q->vtype,
420	realpart(putcx1(q->b_expr.leftp))));
421	ckfree(q);
422	} else
423	goto putopp;
424	break;
425
426	case OPAND:
427	/* Create logical AND */
428	x1 = fmktemp(TYLOGICAL, NULL);
429	putexpr(mkexpr(OPASSIGN, cpexpr(x1),
430	mklogcon(0)));
431	k = newlabel();
432	putif(q->b_expr.leftp, k);
433	putif(q->b_expr.rightp, k);
434	putexpr(mkexpr(OPASSIGN, cpexpr(x1),
435	mklogcon(1)));
436	putlabel(k);
437	p = putx(x1);
438	break;
439
440	case OPNOT: /* Logical NOT */
441	x1 = fmktemp(TYLOGICAL, NULL);
442	putexpr(mkexpr(OPASSIGN, cpexpr(x1),
443	mklogcon(1)));
444	k = newlabel();
445	putif(q->b_expr.leftp, k);
446	putexpr(mkexpr(OPASSIGN, cpexpr(x1),
447	mklogcon(0)));
448	putlabel(k);
449	p = putx(x1);
450	break;
451
452	case OPOR: /* Create logical OR */
453	x1 = fmktemp(TYLOGICAL, NULL);
454	putexpr(mkexpr(OPASSIGN, cpexpr(x1),
455	mklogcon(1)));
456	k = newlabel();
457	putif(mkexpr(OPEQ, q->b_expr.leftp,
458	mklogcon(0)), k);
459	putif(mkexpr(OPEQ, q->b_expr.rightp,
460	mklogcon(0)), k);
461	putexpr(mkexpr(OPASSIGN, cpexpr(x1),
462	mklogcon(0)));
463	putlabel(k);
464	p = putx(x1);
465	break;
466
467	case OPCOMMA:
468	for (x1 = q; x1->b_expr.opcode == OPCOMMA;
469	x1 = x1->b_expr.leftp)
470	putexpr(x1->b_expr.rightp);
471	p = putx(x1);
472	break;
473
474	case OPEQV:
475	case OPNEQV:
476	case OPADDR:
477	case OPBITOR:
478	case OPBITAND:
479	case OPBITXOR:
480	case OPBITNOT:
481	case OPLSHIFT:
482	case OPRSHIFT:
483	putopp:
484	p = putop(q);
485	break;
486
487	default:
488	fatal1("putx: invalid opcode %d", opc);
489	}
490	break;
491
492	case TADDR:
493	p = putaddr(q, YES);
494	break;
495
496	default:
497	fatal1("putx: impossible tag %d", q->tag);
498	}
499	return p;
500	}
501
502	LOCAL NODE *
503	putop(bigptr q)
504	{
505	NODE *p;
506	int k;
507	bigptr lp, tp;
508	int pt, lt;
509
510	#ifdef PCC_DEBUG
511	if (tflag) {
512	printf("putop %p\n", q);
513	fprint(q, 0);
514	}
515	#endif
516	switch(q->b_expr.opcode) { /* check for special cases and rewrite */
517	case OPCONV:
518	pt = q->vtype;
519	lp = q->b_expr.leftp;
520	lt = lp->vtype;
521	while(q->tag==TEXPR && q->b_expr.opcode==OPCONV &&
522	((ISREAL(pt)&&ISREAL(lt)) \|\|
523	(XINT(pt)&&(ONEOF(lt,MSKINT\|MSKADDR))) )) {
524	if(lp->tag != TEXPR) {
525	if(pt==TYINT && lt==TYLONG)
526	break;
527	if(lt==TYINT && pt==TYLONG)
528	break;
529	}
530	ckfree(q);
531	q = lp;
532	pt = lt;
533	lp = q->b_expr.leftp;
534	lt = lp->vtype;
535	}
536	if(q->tag==TEXPR && q->b_expr.opcode==OPCONV)
537	break;
538	p = putx(q);
539	return p;
540
541	case OPADDR:
542	lp = q->b_expr.leftp;
543	if(lp->tag != TADDR) {
544	tp = fmktemp(lp->vtype, lp->vleng);
545	p = putx(mkexpr(OPASSIGN, cpexpr(tp), lp));
546	sendp2(p);
547	lp = tp;
548	}
549	p = putaddr(lp, NO);
550	ckfree(q);
551	return p;
552	}
553
554	if ((k = ops2[q->b_expr.opcode]) <= 0)
555	fatal1("putop: invalid opcode %d (%d)", q->b_expr.opcode, k);
556	p = putx(q->b_expr.leftp);
557	if(q->b_expr.rightp)
558	p = mkbinode(k, p, putx(q->b_expr.rightp), types2[q->vtype]);
559	else
560	p = mkunode(k, p, 0, types2[q->vtype]);
561
562	if(q->vleng)
563	frexpr(q->vleng);
564	ckfree(q);
565	return p;
566	}
567
568	/*
569	* Put return values into correct register.
570	*/
571	void
572	putforce(int t, bigptr p)
573	{
574	NODE *p1;
575
576	p = mkconv(t, fixtype(p));
577	p1 = putx(p);
578	p1 = mkunode(FORCE, p1, 0,
579	(t==TYSHORT ? SHORT : (t==TYLONG ? LONG : LDOUBLE)));
580	sendp2(p1);
581	}
582
583	LOCAL NODE *
584	putpower(bigptr p)
585	{
586	NODE *p3;
587	bigptr base;
588	struct bigblock t1, t2;
589	ftnint k = 0; /* XXX gcc */
590	int type;
591
592	if(!ISICON(p->b_expr.rightp) \|\|
593	(k = p->b_expr.rightp->b_const.fconst.ci)<2)
594	fatal("putpower: bad call");
595	base = p->b_expr.leftp;
596	type = base->vtype;
597	t1 = fmktemp(type, NULL);
598	t2 = NULL;
599	p3 = putassign(cpexpr(t1), cpexpr(base) );
600	sendp2(p3);
601
602	for( ; (k&1)==0 && k>2 ; k>>=1 ) {
603	p3 = putassign(cpexpr(t1),
604	mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
605	sendp2(p3);
606	}
607
608	if(k == 2)
609	p3 = putx(mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
610	else {
611	t2 = fmktemp(type, NULL);
612	p3 = putassign(cpexpr(t2), cpexpr(t1));
613	sendp2(p3);
614
615	for(k>>=1 ; k>1 ; k>>=1) {
616	p3 = putassign(cpexpr(t1),
617	mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
618	sendp2(p3);
619	if(k & 1) {
620	p3 = putassign(cpexpr(t2),
621	mkexpr(OPSTAR, cpexpr(t2), cpexpr(t1)));
622	sendp2(p3);
623	}
624	}
625	p3 = putx( mkexpr(OPSTAR, cpexpr(t2),
626	mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
627	}
628	frexpr(t1);
629	if(t2)
630	frexpr(t2);
631	frexpr(p);
632	return p3;
633	}
634
635	LOCAL struct bigblock *
636	intdouble(struct bigblock *p)
637	{
638	struct bigblock *t;
639
640	t = fmktemp(TYDREAL, NULL);
641
642	sendp2(putassign(cpexpr(t), p));
643	return(t);
644	}
645
646	LOCAL struct bigblock *
647	putcxeq(struct bigblock *q)
648	{
649	struct bigblock lp, rp;
650
651	lp = putcx1(q->b_expr.leftp);
652	rp = putcx1(q->b_expr.rightp);
653	sendp2(putassign(realpart(lp), realpart(rp)));
654	if( ISCOMPLEX(q->vtype) ) {
655	sendp2(putassign(imagpart(lp), imagpart(rp)));
656	}
657	frexpr(rp);
658	ckfree(q);
659	return(lp);
660	}
661
662
663
664	LOCAL NODE *
665	putcxop(bigptr q)
666	{
667	NODE *p;
668
669	p = putaddr(putcx1(q), NO);
670	return p;
671	}
672
673	LOCAL struct bigblock *
674	putcx1(bigptr qq)
675	{
676	struct bigblock q, lp, *rp;
677	register struct bigblock *resp;
678	NODE *p;
679	int opcode;
680	int ltype, rtype;
681
682	ltype = rtype = 0; /* XXX gcc */
683	if(qq == NULL)
684	return(NULL);
685
686	switch(qq->tag) {
687	case TCONST:
688	if( ISCOMPLEX(qq->vtype) )
689	qq = putconst(qq);
690	return( qq );
691
692	case TADDR:
693	if( ! addressable(qq) ) {
694	resp = fmktemp(tyint, NULL);
695	p = putassign( cpexpr(resp), qq->b_addr.memoffset );
696	sendp2(p);
697	qq->b_addr.memoffset = resp;
698	}
699	return( qq );
700
701	case TEXPR:
702	if( ISCOMPLEX(qq->vtype) )
703	break;
704	resp = fmktemp(TYDREAL, NO);
705	p = putassign( cpexpr(resp), qq);
706	sendp2(p);
707	return(resp);
708
709	default:
710	fatal1("putcx1: bad tag %d", qq->tag);
711	}
712
713	opcode = qq->b_expr.opcode;
714	if(opcode==OPCALL \|\| opcode==OPCCALL) {
715	q = putcall(qq);
716	sendp2(callval);
717	return(q);
718	} else if(opcode == OPASSIGN) {
719	return( putcxeq(qq) );
720	}
721
722	resp = fmktemp(qq->vtype, NULL);
723	if((lp = putcx1(qq->b_expr.leftp) ))
724	ltype = lp->vtype;
725	if((rp = putcx1(qq->b_expr.rightp) ))
726	rtype = rp->vtype;
727
728	switch(opcode) {
729	case OPCOMMA:
730	frexpr(resp);
731	resp = rp;
732	rp = NULL;
733	break;
734
735	case OPNEG:
736	p = putassign(realpart(resp),
737	mkexpr(OPNEG, realpart(lp), NULL));
738	sendp2(p);
739	p = putassign(imagpart(resp),
740	mkexpr(OPNEG, imagpart(lp), NULL));
741	sendp2(p);
742	break;
743
744	case OPPLUS:
745	case OPMINUS:
746	p = putassign( realpart(resp),
747	mkexpr(opcode, realpart(lp), realpart(rp) ));
748	sendp2(p);
749	if(rtype < TYCOMPLEX) {
750	p = putassign(imagpart(resp), imagpart(lp) );
751	} else if(ltype < TYCOMPLEX) {
752	if(opcode == OPPLUS)
753	p = putassign( imagpart(resp), imagpart(rp) );
754	else
755	p = putassign( imagpart(resp),
756	mkexpr(OPNEG, imagpart(rp), NULL) );
757	} else
758	p = putassign( imagpart(resp),
759	mkexpr(opcode, imagpart(lp), imagpart(rp) ));
760	sendp2(p);
761	break;
762
763	case OPSTAR:
764	if(ltype < TYCOMPLEX) {
765	if( ISINT(ltype) )
766	lp = intdouble(lp);
767	p = putassign( realpart(resp),
768	mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
769	sendp2(p);
770	p = putassign( imagpart(resp),
771	mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
772	} else if(rtype < TYCOMPLEX) {
773	if( ISINT(rtype) )
774	rp = intdouble(rp);
775	p = putassign( realpart(resp),
776	mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
777	sendp2(p);
778	p = putassign( imagpart(resp),
779	mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
780	} else {
781	p = putassign( realpart(resp), mkexpr(OPMINUS,
782	mkexpr(OPSTAR, realpart(lp), realpart(rp)),
783	mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
784	sendp2(p);
785	p = putassign( imagpart(resp), mkexpr(OPPLUS,
786	mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
787	mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
788	}
789	sendp2(p);
790	break;
791
792	case OPSLASH:
793	/* fixexpr has already replaced all divisions
794	* by a complex by a function call
795	*/
796	if( ISINT(rtype) )
797	rp = intdouble(rp);
798	p = putassign( realpart(resp),
799	mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
800	sendp2(p);
801	p = putassign( imagpart(resp),
802	mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
803	sendp2(p);
804	break;
805
806	case OPCONV:
807	p = putassign( realpart(resp), realpart(lp) );
808	if( ISCOMPLEX(lp->vtype) )
809	q = imagpart(lp);
810	else if(rp != NULL)
811	q = realpart(rp);
812	else
813	q = mkrealcon(TYDREAL, 0.0);
814	sendp2(p);
815	p = putassign( imagpart(resp), q);
816	sendp2(p);
817	break;
818
819	default:
820	fatal1("putcx1 of invalid opcode %d", opcode);
821	}
822
823	frexpr(lp);
824	frexpr(rp);
825	ckfree(qq);
826	return(resp);
827	}
828
829
830	LOCAL NODE *
831	putcxcmp(struct bigblock *p)
832	{
833	NODE *p1;
834	int opcode;
835	struct bigblock lp, rp;
836	struct bigblock *q;
837
838	opcode = p->b_expr.opcode;
839	lp = putcx1(p->b_expr.leftp);
840	rp = putcx1(p->b_expr.rightp);
841
842	q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
843	mkexpr(opcode, realpart(lp), realpart(rp)),
844	mkexpr(opcode, imagpart(lp), imagpart(rp)) );
845	p1 = putx( fixexpr(q) );
846
847	ckfree(lp);
848	ckfree(rp);
849	ckfree(p);
850	return p1;
851	}
852
853	LOCAL struct bigblock *
854	putch1(bigptr p)
855	{
856	struct bigblock *t;
857
858	switch(p->tag) {
859	case TCONST:
860	return( putconst(p) );
861
862	case TADDR:
863	return(p);
864
865	case TEXPR:
866	switch(p->b_expr.opcode) {
867	case OPCALL:
868	case OPCCALL:
869	t = putcall(p);
870	sendp2(callval);
871	break;
872
873	case OPCONCAT:
874	t = fmktemp(TYCHAR, cpexpr(p->vleng) );
875	sendp2(putcat( cpexpr(t), p ));
876	break;
877
878	case OPCONV:
879	if(!ISICON(p->vleng) \|\|
880	p->vleng->b_const.fconst.ci!=1
881	\|\| ! XINT(p->b_expr.leftp->vtype) )
882	fatal("putch1: bad character conversion");
883	t = fmktemp(TYCHAR, MKICON(1) );
884	sendp2(putassign( cpexpr(t), p));
885	break;
886	default:
887	fatal1("putch1: invalid opcode %d", p->b_expr.opcode);
888	t = NULL; /* XXX gcc */
889	}
890	return(t);
891
892	default:
893	fatal1("putch1: bad tag %d", p->tag);
894	}
895	/* NOTREACHED */
896	return NULL; /* XXX gcc */
897	}
898
899
900
901
902
903	LOCAL NODE *
904	putchop(bigptr p)
905	{
906	NODE *p1;
907
908	p1 = putaddr( putch1(p) , NO );
909	return p1;
910	}
911
912
913	/*
914	* Assign a character to another.
915	*/
916	LOCAL NODE *
917	putcheq(struct bigblock *p)
918	{
919	NODE p1, p2, *p3;
920
921	if( p->b_expr.rightp->tag==TEXPR &&
922	p->b_expr.rightp->b_expr.opcode==OPCONCAT )
923	p3 = putcat(p->b_expr.leftp, p->b_expr.rightp);
924	else if( ISONE(p->b_expr.leftp->vleng) &&
925	ISONE(p->b_expr.rightp->vleng) ) {
926	p1 = putaddr( putch1(p->b_expr.leftp) , YES );
927	p2 = putaddr( putch1(p->b_expr.rightp) , YES );
928	p3 = mkbinode(ASSIGN, p1, p2, CHAR);
929	} else
930	p3 = putx(call2(TYINT, "s_copy",
931	p->b_expr.leftp, p->b_expr.rightp));
932
933	frexpr(p->vleng);
934	ckfree(p);
935	return p3;
936	}
937
938
939
940	/*
941	* Compare character(s) code.
942	*/
943	LOCAL NODE *
944	putchcmp(struct bigblock *p)
945	{
946	NODE p1, p2, *p3;
947
948	if(ISONE(p->b_expr.leftp->vleng) && ISONE(p->b_expr.rightp->vleng) ) {
949	p1 = putaddr( putch1(p->b_expr.leftp) , YES );
950	p2 = putaddr( putch1(p->b_expr.rightp) , YES );
951	p3 = mkbinode(ops2[p->b_expr.opcode], p1, p2, CHAR);
952	ckfree(p);
953	} else {
954	p->b_expr.leftp = call2(TYINT,"s_cmp",
955	p->b_expr.leftp, p->b_expr.rightp);
956	p->b_expr.rightp = MKICON(0);
957	p3 = putop(p);
958	}
959	return p3;
960	}
961
962	LOCAL NODE *
963	putcat(bigptr lhs, bigptr rhs)
964	{
965	NODE *p3;
966	int n;
967	struct bigblock lp, cp;
968
969	n = ncat(rhs);
970	lp = mktmpn(n, TYLENG, NULL);
971	cp = mktmpn(n, TYADDR, NULL);
972
973	n = 0;
974	putct1(rhs, lp, cp, &n);
975
976	p3 = putx( call4(TYSUBR, "s_cat", lhs, cp, lp, MKICON(n) ) );
977	return p3;
978	}
979
980	LOCAL int
981	ncat(bigptr p)
982	{
983	if(p->tag==TEXPR && p->b_expr.opcode==OPCONCAT)
984	return( ncat(p->b_expr.leftp) + ncat(p->b_expr.rightp) );
985	else
986	return(1);
987	}
988
989	LOCAL void
990	putct1(bigptr q, bigptr lp, bigptr cp, int *ip)
991	{
992	NODE *p;
993	int i;
994	struct bigblock lp1, cp1;
995
996	if(q->tag==TEXPR && q->b_expr.opcode==OPCONCAT) {
997	putct1(q->b_expr.leftp, lp, cp, ip);
998	putct1(q->b_expr.rightp, lp, cp , ip);
999	frexpr(q->vleng);
1000	ckfree(q);
1001	} else {
1002	i = (*ip)++;
1003	lp1 = cpexpr(lp);
1004	lp1->b_addr.memoffset =
1005	mkexpr(OPPLUS, lp1->b_addr.memoffset, MKICON(i*FSZLENG));
1006	cp1 = cpexpr(cp);
1007	cp1->b_addr.memoffset =
1008	mkexpr(OPPLUS, cp1->b_addr.memoffset, MKICON(i*FSZADDR));
1009	p = putassign( lp1, cpexpr(q->vleng) );
1010	sendp2(p);
1011	p = putassign( cp1, addrof(putch1(q)) );
1012	sendp2(p);
1013	}
1014	}
1015
1016	/*
1017	* Create a tree that can later be converted to an OREG.
1018	*/
1019	static NODE *
1020	oregtree(int off, int reg, int type)
1021	{
1022	NODE p, q;
1023
1024	p = mklnode(REG, 0, reg, INCREF(type));
1025	q = mklnode(ICON, off, 0, INT);
1026	return mkunode(UMUL, mkbinode(PLUS, p, q, INCREF(type)), 0, type);
1027	}
1028
1029	static NODE *
1030	putaddr(bigptr q, int indir)
1031	{
1032	int type, type2, funct;
1033	NODE p, p1, *p2;
1034	ftnint offset;
1035	bigptr offp;
1036
1037	p = p1 = p2 = NULL; /* XXX */
1038
1039	type = q->vtype;
1040	type2 = types2[type];
1041	funct = (q->vclass==CLPROC ? FTN<<TSHIFT : 0);
1042
1043	offp = (q->b_addr.memoffset ? cpexpr(q->b_addr.memoffset) : NULL);
1044
1045	offset = simoffset(&offp);
1046	if(offp)
1047	offp = mkconv(TYINT, offp);
1048
1049	switch(q->vstg) {
1050	case STGAUTO:
1051	if(indir && !offp) {
1052	p = oregtree(offset, AUTOREG, type2);
1053	break;
1054	}
1055
1056	if(!indir && !offp && !offset) {
1057	p = mklnode(REG, 0, AUTOREG, INCREF(type2));
1058	break;
1059	}
1060
1061	p = mklnode(REG, 0, AUTOREG, INCREF(type2));
1062	if(offp) {
1063	p1 = putx(offp);
1064	if(offset)
1065	p2 = mklnode(ICON, offset, 0, INT);
1066	} else
1067	p1 = mklnode(ICON, offset, 0, INT);
1068	if (offp && offset)
1069	p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
1070	p = mkbinode(PLUS, p, p1, INCREF(type2));
1071	if (indir)
1072	p = mkunode(UMUL, p, 0, type2);
1073	break;
1074
1075	case STGARG:
1076	p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
1077	ARGREG, INCREF(type2)\|funct);
1078
1079	if (offp)
1080	p1 = putx(offp);
1081	if (offset)
1082	p2 = mklnode(ICON, offset, 0, INT);
1083	if (offp && offset)
1084	p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
1085	else if (offset)
1086	p1 = p2;
1087	if (offp \|\| offset)
1088	p = mkbinode(PLUS, p, p1, INCREF(type2));
1089	if (indir)
1090	p = mkunode(UMUL, p, 0, type2);
1091	break;
1092
1093	case STGLENG:
1094	if(indir) {
1095	p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
1096	ARGREG, INCREF(type2)\|funct);
1097	} else {
1098	fatal1("faddrnode: STGLENG: fixme!");
1099	#if 0
1100	p2op(P2PLUS, types2[TYLENG] \| P2PTR );
1101	p2reg(ARGREG, types2[TYLENG] \| P2PTR );
1102	p2icon( ARGOFFSET +
1103	(ftnint) (FUDGEOFFSET*p->b_addr.memno), P2INT);
1104	#endif
1105	}
1106	break;
1107
1108
1109	case STGBSS:
1110	case STGINIT:
1111	case STGEXT:
1112	case STGCOMMON:
1113	case STGEQUIV:
1114	case STGCONST:
1115	if(offp) {
1116	p1 = putx(offp);
1117	p2 = putmem(q, ICON, offset);
1118	p = mkbinode(PLUS, p1, p2, INCREF(type2));
1119	if(indir)
1120	p = mkunode(UMUL, p, 0, type2);
1121	} else
1122	p = putmem(q, (indir ? NAME : ICON), offset);
1123	break;
1124
1125	case STGREG:
1126	if(indir)
1127	p = mklnode(REG, 0, q->b_addr.memno, type2);
1128	else
1129	fatal("attempt to take address of a register");
1130	break;
1131
1132	default:
1133	fatal1("putaddr: invalid vstg %d", q->vstg);
1134	}
1135	frexpr(q);
1136	return p;
1137	}
1138
1139	NODE *
1140	putmem(bigptr q, int class, ftnint offset)
1141	{
1142	NODE *p;
1143	int type2;
1144
1145	type2 = types2[q->vtype];
1146	if(q->vclass == CLPROC)
1147	type2 \|= (FTN<<TSHIFT);
1148	if (class == ICON)
1149	type2 \|= PTR;
1150	p = mklnode(class, offset, 0, type2);
1151	p->n_name = copys(memname(q->vstg, q->b_addr.memno));
1152	return p;
1153	}
1154
1155
1156
1157
1158	LOCAL struct bigblock *
1159	putcall(struct bigblock *qq)
1160	{
1161	chainp arglist, charsp, cp;
1162	int n, first;
1163	struct bigblock *t;
1164	struct bigblock *q;
1165	struct bigblock *fval;
1166	int type, type2, ctype, indir;
1167	NODE lp, p1, *p2;
1168
1169	lp = p2 = NULL; /* XXX */
1170
1171	type2 = types2[type = qq->vtype];
1172	charsp = NULL;
1173	indir = (qq->b_expr.opcode == OPCCALL);
1174	n = 0;
1175	first = YES;
1176
1177	if(qq->b_expr.rightp) {
1178	arglist = qq->b_expr.rightp->b_list.listp;
1179	ckfree(qq->b_expr.rightp);
1180	} else
1181	arglist = NULL;
1182
1183	for(cp = arglist ; cp ; cp = cp->chain.nextp)
1184	if(indir) {
1185	++n;
1186	} else {
1187	q = cp->chain.datap;
1188	if(q->tag == TCONST)
1189	cp->chain.datap = q = putconst(q);
1190	if( ISCHAR(q) ) {
1191	charsp = hookup(charsp,
1192	mkchain(cpexpr(q->vleng), 0) );
1193	n += 2;
1194	} else if(q->vclass == CLPROC) {
1195	charsp = hookup(charsp,
1196	mkchain( MKICON(0) , 0));
1197	n += 2;
1198	} else
1199	n += 1;
1200	}
1201
1202	if(type == TYCHAR) {
1203	if( ISICON(qq->vleng) ) {
1204	fval = fmktemp(TYCHAR, qq->vleng);
1205	n += 2;
1206	} else {
1207	err("adjustable character function");
1208	return NULL;
1209	}
1210	} else if(ISCOMPLEX(type)) {
1211	fval = fmktemp(type, NULL);
1212	n += 1;
1213	} else
1214	fval = NULL;
1215
1216	ctype = (fval ? P2INT : type2);
1217	p1 = putaddr(qq->b_expr.leftp, NO);
1218
1219	if(fval) {
1220	first = NO;
1221	lp = putaddr( cpexpr(fval), NO);
1222	if(type==TYCHAR)
1223	lp = mkbinode(CM, lp, putx(cpexpr(qq->vleng)), INT);
1224	}
1225
1226	for(cp = arglist ; cp ; cp = cp->chain.nextp) {
1227	q = cp->chain.datap;
1228	if(q->tag==TADDR && (indir \|\| q->vstg!=STGREG) )
1229	p2 = putaddr(q, indir && q->vtype!=TYCHAR);
1230	else if( ISCOMPLEX(q->vtype) )
1231	p2 = putcxop(q);
1232	else if (ISCHAR(q) ) {
1233	p2 = putchop(q);
1234	} else if( ! ISERROR(q) ) {
1235	if(indir)
1236	p2 = putx(q);
1237	else {
1238	t = fmktemp(q->vtype, q->vleng);
1239	p2 = putassign( cpexpr(t), q );
1240	sendp2(p2);
1241	p2 = putaddr(t, NO);
1242	}
1243	}
1244	if(first) {
1245	first = NO;
1246	lp = p2;
1247	} else
1248	lp = mkbinode(CM, lp, p2, INT);
1249	}
1250
1251	if(arglist)
1252	frchain(&arglist);
1253	for(cp = charsp ; cp ; cp = cp->chain.nextp) {
1254	p2 = putx( mkconv(TYLENG,cp->chain.datap) );
1255	lp = mkbinode(CM, lp, p2, INT);
1256	}
1257	frchain(&charsp);
1258	if (n > 0)
1259	callval = mkbinode(CALL, p1, lp, ctype);
1260	else
1261	callval = mkunode(UCALL, p1, 0, ctype);
1262	ckfree(qq);
1263	return(fval);
1264	}
1265
1266	/*
1267	* Write out code to do min/max calculations.
1268	* Note that these operators may have multiple arguments in fortran.
1269	*/
1270	LOCAL NODE *
1271	putmnmx(struct bigblock *p)
1272	{
1273	NODE n1, n2;
1274	int op, type, lab;
1275	chainp p0, p1;
1276	struct bigblock *tp;
1277
1278	type = p->vtype;
1279	op = (p->b_expr.opcode==OPMIN ? LT : GT );
1280	p0 = p->b_expr.leftp->b_list.listp;
1281	ckfree(p->b_expr.leftp);
1282	ckfree(p);
1283
1284	/*
1285	* Store first value in a temporary, then compare it with
1286	* each following value and save that if needed.
1287	*/
1288	tp = fmktemp(type, NULL);
1289	sendp2(putassign(cpexpr(tp), p0->chain.datap));
1290
1291	for(p1 = p0->chain.nextp ; p1 ; p1 = p1->chain.nextp) {
1292	n1 = putx(cpexpr(tp));
1293	n2 = putx(cpexpr(p1->chain.datap));
1294	lab = newlabel();
1295	sendp2(mkbinode(CBRANCH, mkbinode(op, n1, n2, INT),
1296	mklnode(ICON, lab, 0, INT), INT));
1297	sendp2(putassign(cpexpr(tp), p1->chain.datap));
1298	putlabel(lab);
1299	}
1300	return putx(tp);
1301	}
1302
1303	ftnint
1304	simoffset(bigptr *p0)
1305	{
1306	ftnint offset, prod;
1307	bigptr p, lp, rp;
1308
1309	offset = 0;
1310	p = *p0;
1311	if(p == NULL)
1312	return(0);
1313
1314	if( ! ISINT(p->vtype) )
1315	return(0);
1316
1317	if(p->tag==TEXPR && p->b_expr.opcode==OPSTAR) {
1318	lp = p->b_expr.leftp;
1319	rp = p->b_expr.rightp;
1320	if(ISICON(rp) && lp->tag==TEXPR &&
1321	lp->b_expr.opcode==OPPLUS && ISICON(lp->b_expr.rightp)) {
1322	p->b_expr.opcode = OPPLUS;
1323	lp->b_expr.opcode = OPSTAR;
1324	prod = rp->b_const.fconst.ci *
1325	lp->b_expr.rightp->b_const.fconst.ci;
1326	lp->b_expr.rightp->b_const.fconst.ci =
1327	rp->b_const.fconst.ci;
1328	rp->b_const.fconst.ci = prod;
1329	}
1330	}
1331
1332	if(p->tag==TEXPR && p->b_expr.opcode==OPPLUS &&
1333	ISICON(p->b_expr.rightp)) {
1334	rp = p->b_expr.rightp;
1335	lp = p->b_expr.leftp;
1336	offset += rp->b_const.fconst.ci;
1337	frexpr(rp);
1338	ckfree(p);
1339	*p0 = lp;
1340	}
1341
1342	if(p->tag == TCONST) {
1343	offset += p->b_const.fconst.ci;
1344	frexpr(p);
1345	*p0 = NULL;
1346	}
1347
1348	return(offset);
1349	}
1350
1351	/*
1352	* F77 uses ckalloc() (malloc) for NODEs.
1353	*/
1354	NODE *
1355	talloc()
1356	{
1357	NODE *p = ckalloc(sizeof(NODE));
1358	p->n_name = "";
1359	return p;
1360	}
1361
1362	#ifdef PCC_DEBUG
1363	static char *tagnam[] = {
1364	"NONE", "NAME", "CONST", "EXPR", "ADDR", "PRIM", "LIST", "IMPLDO", "ERROR",
1365	};
1366	static char *typnam[] = {
1367	"unknown", "addr", "short", "long", "real", "dreal", "complex", "dcomplex",
1368	"logical", "char", "subr", "error",
1369	};
1370	static char *classnam[] = {
1371	"unknown", "param", "var", "entry", "main", "block", "proc",
1372	};
1373	static char *stgnam[] = {
1374	"unknown", "arg", "auto", "bss", "init", "const", "intr", "stfunct",
1375	"common", "equiv", "reg", "leng",
1376	};
1377
1378
1379	/*
1380	* Print out a f77 tree, for diagnostic purposes.
1381	*/
1382	void
1383	fprint(bigptr p, int indx)
1384	{
1385	extern char *ops[];
1386	int x = indx;
1387	bigptr lp, rp;
1388	struct chain *bp;
1389
1390	if (p == NULL)
1391	return;
1392
1393	while (x >= 2) {
1394	putchar('\t');
1395	x -= 2;
1396	}
1397	if (x--)
1398	printf(" " );
1399	printf("%p) %s, ", p, tagnam[p->tag]);
1400	if (p->vtype)
1401	printf("type=%s, ", typnam[p->vtype]);
1402	if (p->vclass)
1403	printf("class=%s, ", classnam[p->vclass]);
1404	if (p->vstg)
1405	printf("stg=%s, ", stgnam[p->vstg]);
1406
1407	lp = rp = NULL;
1408	switch (p->tag) {
1409	case TEXPR:
1410	printf("OP %s\n", ops[p->b_expr.opcode]);
1411	lp = p->b_expr.leftp;
1412	rp = p->b_expr.rightp;
1413	break;
1414	case TADDR:
1415	printf("memno=%d\n", p->b_addr.memno);
1416	lp = p->vleng;
1417	rp = p->b_addr.memoffset;
1418	break;
1419	case TCONST:
1420	switch (p->vtype) {
1421	case TYSHORT:
1422	case TYLONG:
1423	case TYLOGICAL:
1424	case TYADDR:
1425	printf("val=%ld\n", p->b_const.fconst.ci);
1426	break;
1427	case TYCHAR:
1428	lp = p->vleng;
1429	printf("\n");
1430	break;
1431	}
1432	break;
1433	case TPRIM:
1434	lp = p->b_prim.namep;
1435	rp = p->b_prim.argsp;
1436	printf("fcharp=%p, lcharp=%p\n", p->b_prim.fcharp, p->b_prim.lcharp);
1437	break;
1438	case TNAME:
1439	printf("name=%s\n", p->b_name.varname);
1440	break;
1441	case TLIST:
1442	printf("\n");
1443	for (bp = &p->b_list.listp->chain; bp; bp = &bp->nextp->chain)
1444	fprint(bp->datap, indx+1);
1445	break;
1446	default:
1447	printf("\n");
1448	}
1449
1450	fprint(lp, indx+1);
1451	fprint(rp, indx+1);
1452	}
1453	#endif

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

Download in other formats: