xref: /netbsd/external/bsd/pcc/dist/pcc/f77/fcom/put.c (revision 6550d01e)
1 /*	Id: put.c,v 1.17 2008/05/11 15:28:03 ragge Exp 	*/
2 /*	$NetBSD: put.c,v 1.1.1.2 2010/06/03 18:57:51 plunky Exp $	*/
3 /*
4  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
5  *
6  * Redistribution and use in source and binary forms, with or without
7  * modification, are permitted provided that the following conditions
8  * are met:
9  *
10  * Redistributions of source code and documentation must retain the above
11  * copyright notice, this list of conditions and the following disclaimer.
12  * Redistributions in binary form must reproduce the above copyright
13  * notice, this list of conditions and the following disclaimer in the
14  * documentation and/or other materials provided with the distribution.
15  * All advertising materials mentioning features or use of this software
16  * must display the following acknowledgement:
17  * 	This product includes software developed or owned by Caldera
18  *	International, Inc.
19  * Neither the name of Caldera International, Inc. nor the names of other
20  * contributors may be used to endorse or promote products derived from
21  * this software without specific prior written permission.
22  *
23  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
24  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
25  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
28  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
32  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
33  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34  * POSSIBILITY OF SUCH DAMAGE.
35  */
36 /*
37  * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
38  * JOHNSON AND RITCHIE FAMILIES OF SECOND PASSES
39 */
40 
41 #include "defines.h"
42 #include "defs.h"
43 
44 #include "scjdefs.h"
45 
46 char *ops [ ] =
47 	{
48 	"??", "+", "-", "*", "/", "**", "-",
49 	"OR", "AND", "EQV", "NEQV", "NOT",
50 	"CONCAT",
51 	"<", "==", ">", "<=", "!=", ">=",
52 	" of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
53 	" , ", " ? ", " : "
54 	" abs ", " min ", " max ", " addr ", " indirect ",
55 	" bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
56 	};
57 
58 /*
59  * The index position here matches tho OPx numbers in defines.h.
60  * Do not change!
61  */
62 int ops2 [ ] =
63 	{
64 	P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
65 	P2BAD, P2BAD, P2EQ, P2NE, P2BAD,
66 	P2BAD,
67 	P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
68 	P2CALL, P2CALL, P2ASSIGN, P2BAD, P2BAD, P2CONV, P2LSHIFT, P2MOD,
69 	P2BAD, P2BAD, P2BAD,
70 	P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
71 	P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT
72 	};
73 
74 
75 int types2 [ ] =
76 	{
77 	P2BAD, INT|PTR, SHORT, LONG, FLOAT, DOUBLE,
78 	FLOAT, DOUBLE, LONG, CHAR, INT, P2BAD
79 	};
80 
81 void
82 setlog()
83 {
84 types2[TYLOGICAL] = types2[tylogical];
85 }
86 
87 NODE *
88 putex1(bigptr q)
89 {
90 	NODE *p;
91 	q = fixtype(q);
92 	p = putx(q);
93 	templist = hookup(templist, holdtemps);
94 	holdtemps = NULL;
95 	return p;
96 }
97 
98 /*
99  * Print out an assignment.
100  */
101 void
102 puteq(bigptr lp, bigptr rp)
103 {
104 	putexpr(mkexpr(OPASSIGN, lp, rp));
105 }
106 
107 /*
108  * Return a copied node of the real part of an expression.
109  */
110 struct bigblock *
111 realpart(struct bigblock *p)
112 {
113 	struct bigblock *q;
114 
115 	q = cpexpr(p);
116 	if( ISCOMPLEX(p->vtype) )
117 		q->vtype += (TYREAL-TYCOMPLEX);
118 	return(q);
119 }
120 
121 /*
122  * Return a copied node of the imaginary part of an expression.
123  */
124 struct bigblock *
125 imagpart(struct bigblock *p)
126 {
127 	struct bigblock *q;
128 
129 	if( ISCOMPLEX(p->vtype) ) {
130 		q = cpexpr(p);
131 		q->vtype += (TYREAL-TYCOMPLEX);
132 		q->b_addr.memoffset = mkexpr(OPPLUS, q->b_addr.memoffset,
133 		    MKICON(typesize[q->vtype]));
134 	} else
135 		q = mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , 0.0);
136 	return(q);
137 }
138 
139 struct bigblock *
140 putconst(struct bigblock *p)
141 {
142 	struct bigblock *q;
143 	struct literal *litp, *lastlit;
144 	int i, k, type;
145 	int litflavor;
146 
147 	if( ! ISCONST(p) )
148 		fatal1("putconst: bad tag %d", p->tag);
149 
150 	q = BALLO();
151 	q->tag = TADDR;
152 	type = p->vtype;
153 	q->vtype = ( type==TYADDR ? TYINT : type );
154 	q->vleng = cpexpr(p->vleng);
155 	q->vstg = STGCONST;
156 	q->b_addr.memno = newlabel();
157 	q->b_addr.memoffset = MKICON(0);
158 
159 	/* check for value in literal pool, and update pool if necessary */
160 
161 	switch(type = p->vtype) {
162 	case TYCHAR:
163 		if(p->vleng->b_const.fconst.ci > XL)
164 			break;	/* too long for literal table */
165 		litflavor = 1;
166 		goto loop;
167 
168 	case TYREAL:
169 	case TYDREAL:
170 		litflavor = 2;
171 		goto loop;
172 
173 	case TYLOGICAL:
174 		type = tylogical;
175 	case TYSHORT:
176 	case TYLONG:
177 		litflavor = 3;
178 
179 	loop:
180 		lastlit = litpool + nliterals;
181 		for(litp = litpool ; litp<lastlit ; ++litp)
182 			if(type == litp->littype)
183 			    switch(litflavor) {
184 			case 1:
185 				if(p->vleng->b_const.fconst.ci !=
186 				    litp->litval.litcval.litclen)
187 					break;
188 				if(!eqn((int)p->vleng->b_const.fconst.ci,
189 				    p->b_const.fconst.ccp,
190 					litp->litval.litcval.litcstr) )
191 						break;
192 			ret:
193 				q->b_addr.memno = litp->litnum;
194 				frexpr(p);
195 				return(q);
196 
197 			case 2:
198 				if(p->b_const.fconst.cd[0] ==
199 				    litp->litval.litdval)
200 					goto ret;
201 				break;
202 
203 			case 3:
204 				if(p->b_const.fconst.ci == litp->litval.litival)
205 					goto ret;
206 				break;
207 			}
208 		if(nliterals < MAXLITERALS) {
209 			++nliterals;
210 			litp->littype = type;
211 			litp->litnum = q->b_addr.memno;
212 			switch(litflavor) {
213 			case 1:
214 				litp->litval.litcval.litclen =
215 				    p->vleng->b_const.fconst.ci;
216 				cpn( (int) litp->litval.litcval.litclen,
217 					p->b_const.fconst.ccp,
218 					litp->litval.litcval.litcstr);
219 				break;
220 
221 			case 2:
222 				litp->litval.litdval = p->b_const.fconst.cd[0];
223 				break;
224 
225 			case 3:
226 				litp->litval.litival = p->b_const.fconst.ci;
227 				break;
228 			}
229 		}
230 	default:
231 		break;
232 	}
233 
234 	preven(typealign[ type==TYCHAR ? TYLONG : type ]);
235 	prlabel(q->b_addr.memno);
236 
237 	k = 1;
238 	switch(type) {
239 	case TYLOGICAL:
240 	case TYSHORT:
241 	case TYLONG:
242 		prconi(stdout, type, p->b_const.fconst.ci);
243 		break;
244 
245 	case TYCOMPLEX:
246 		k = 2;
247 	case TYREAL:
248 		type = TYREAL;
249 		goto flpt;
250 
251 	case TYDCOMPLEX:
252 		k = 2;
253 	case TYDREAL:
254 		type = TYDREAL;
255 
256 	flpt:
257 		for(i = 0 ; i < k ; ++i)
258 			prconr(stdout, type, p->b_const.fconst.cd[i]);
259 		break;
260 
261 	case TYCHAR:
262 		putstr(p->b_const.fconst.ccp,
263 		    p->vleng->b_const.fconst.ci);
264 		break;
265 
266 	case TYADDR:
267 		prcona(p->b_const.fconst.ci);
268 		break;
269 
270 	default:
271 		fatal1("putconst: bad type %d", p->vtype);
272 	}
273 
274 	frexpr(p);
275 	return( q );
276 }
277 
278 /*
279  * put out a character string constant.  begin every one on
280  * a long integer boundary, and pad with nulls
281  */
282 void
283 putstr(char *s, ftnint n)
284 {
285 	int b[FSZSHORT];
286 	int i;
287 
288 	i = 0;
289 	while(--n >= 0) {
290 		b[i++] = *s++;
291 		if(i == FSZSHORT) {
292 			prchars(b);
293 			i = 0;
294 		}
295 	}
296 
297 	while(i < FSZSHORT)
298 		b[i++] = '\0';
299 	prchars(b);
300 }
301