source: mainline/uspace/app/pcc/f77/fcom/put.c@ 5974661

lfn serial ticket/834-toolchain-update topic/msim-upgrade topic/simplify-dev-export
Last change on this file since 5974661 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: 6.6 KB
RevLine 
[a7de7182]1/* $Id: put.c,v 1.17 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 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/*
36 * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
37 * JOHNSON AND RITCHIE FAMILIES OF SECOND PASSES
38*/
39
40#include "defines.h"
41#include "defs.h"
42
43#include "scjdefs.h"
44
45char *ops [ ] =
46 {
47 "??", "+", "-", "*", "/", "**", "-",
48 "OR", "AND", "EQV", "NEQV", "NOT",
49 "CONCAT",
50 "<", "==", ">", "<=", "!=", ">=",
51 " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
52 " , ", " ? ", " : "
53 " abs ", " min ", " max ", " addr ", " indirect ",
54 " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
55 };
56
57/*
58 * The index position here matches tho OPx numbers in defines.h.
59 * Do not change!
60 */
61int ops2 [ ] =
62 {
63 P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
64 P2BAD, P2BAD, P2EQ, P2NE, P2BAD,
65 P2BAD,
66 P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
67 P2CALL, P2CALL, P2ASSIGN, P2BAD, P2BAD, P2CONV, P2LSHIFT, P2MOD,
68 P2BAD, P2BAD, P2BAD,
69 P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
70 P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT
71 };
72
73
74int types2 [ ] =
75 {
76 P2BAD, INT|PTR, SHORT, LONG, FLOAT, DOUBLE,
77 FLOAT, DOUBLE, LONG, CHAR, INT, P2BAD
78 };
79
80void
81setlog()
82{
83types2[TYLOGICAL] = types2[tylogical];
84}
85
86NODE *
87putex1(bigptr q)
88{
89 NODE *p;
90 q = fixtype(q);
91 p = putx(q);
92 templist = hookup(templist, holdtemps);
93 holdtemps = NULL;
94 return p;
95}
96
97/*
98 * Print out an assignment.
99 */
100void
101puteq(bigptr lp, bigptr rp)
102{
103 putexpr(mkexpr(OPASSIGN, lp, rp));
104}
105
106/*
107 * Return a copied node of the real part of an expression.
108 */
109struct bigblock *
110realpart(struct bigblock *p)
111{
112 struct bigblock *q;
113
114 q = cpexpr(p);
115 if( ISCOMPLEX(p->vtype) )
116 q->vtype += (TYREAL-TYCOMPLEX);
117 return(q);
118}
119
120/*
121 * Return a copied node of the imaginary part of an expression.
122 */
123struct bigblock *
124imagpart(struct bigblock *p)
125{
126 struct bigblock *q;
127
128 if( ISCOMPLEX(p->vtype) ) {
129 q = cpexpr(p);
130 q->vtype += (TYREAL-TYCOMPLEX);
131 q->b_addr.memoffset = mkexpr(OPPLUS, q->b_addr.memoffset,
132 MKICON(typesize[q->vtype]));
133 } else
134 q = mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , 0.0);
135 return(q);
136}
137
138struct bigblock *
139putconst(struct bigblock *p)
140{
141 struct bigblock *q;
142 struct literal *litp, *lastlit;
143 int i, k, type;
144 int litflavor;
145
146 if( ! ISCONST(p) )
147 fatal1("putconst: bad tag %d", p->tag);
148
149 q = BALLO();
150 q->tag = TADDR;
151 type = p->vtype;
152 q->vtype = ( type==TYADDR ? TYINT : type );
153 q->vleng = cpexpr(p->vleng);
154 q->vstg = STGCONST;
155 q->b_addr.memno = newlabel();
156 q->b_addr.memoffset = MKICON(0);
157
158 /* check for value in literal pool, and update pool if necessary */
159
160 switch(type = p->vtype) {
161 case TYCHAR:
162 if(p->vleng->b_const.fconst.ci > XL)
163 break; /* too long for literal table */
164 litflavor = 1;
165 goto loop;
166
167 case TYREAL:
168 case TYDREAL:
169 litflavor = 2;
170 goto loop;
171
172 case TYLOGICAL:
173 type = tylogical;
174 case TYSHORT:
175 case TYLONG:
176 litflavor = 3;
177
178 loop:
179 lastlit = litpool + nliterals;
180 for(litp = litpool ; litp<lastlit ; ++litp)
181 if(type == litp->littype)
182 switch(litflavor) {
183 case 1:
184 if(p->vleng->b_const.fconst.ci !=
185 litp->litval.litcval.litclen)
186 break;
187 if(!eqn((int)p->vleng->b_const.fconst.ci,
188 p->b_const.fconst.ccp,
189 litp->litval.litcval.litcstr) )
190 break;
191 ret:
192 q->b_addr.memno = litp->litnum;
193 frexpr(p);
194 return(q);
195
196 case 2:
197 if(p->b_const.fconst.cd[0] ==
198 litp->litval.litdval)
199 goto ret;
200 break;
201
202 case 3:
203 if(p->b_const.fconst.ci == litp->litval.litival)
204 goto ret;
205 break;
206 }
207 if(nliterals < MAXLITERALS) {
208 ++nliterals;
209 litp->littype = type;
210 litp->litnum = q->b_addr.memno;
211 switch(litflavor) {
212 case 1:
213 litp->litval.litcval.litclen =
214 p->vleng->b_const.fconst.ci;
215 cpn( (int) litp->litval.litcval.litclen,
216 p->b_const.fconst.ccp,
217 litp->litval.litcval.litcstr);
218 break;
219
220 case 2:
221 litp->litval.litdval = p->b_const.fconst.cd[0];
222 break;
223
224 case 3:
225 litp->litval.litival = p->b_const.fconst.ci;
226 break;
227 }
228 }
229 default:
230 break;
231 }
232
233 preven(typealign[ type==TYCHAR ? TYLONG : type ]);
234 prlabel(q->b_addr.memno);
235
236 k = 1;
237 switch(type) {
238 case TYLOGICAL:
239 case TYSHORT:
240 case TYLONG:
241 prconi(stdout, type, p->b_const.fconst.ci);
242 break;
243
244 case TYCOMPLEX:
245 k = 2;
246 case TYREAL:
247 type = TYREAL;
248 goto flpt;
249
250 case TYDCOMPLEX:
251 k = 2;
252 case TYDREAL:
253 type = TYDREAL;
254
255 flpt:
256 for(i = 0 ; i < k ; ++i)
257 prconr(stdout, type, p->b_const.fconst.cd[i]);
258 break;
259
260 case TYCHAR:
261 putstr(p->b_const.fconst.ccp,
262 p->vleng->b_const.fconst.ci);
263 break;
264
265 case TYADDR:
266 prcona(p->b_const.fconst.ci);
267 break;
268
269 default:
270 fatal1("putconst: bad type %d", p->vtype);
271 }
272
273 frexpr(p);
274 return( q );
275}
276
277/*
278 * put out a character string constant. begin every one on
279 * a long integer boundary, and pad with nulls
280 */
281void
282putstr(char *s, ftnint n)
283{
284 int b[FSZSHORT];
285 int i;
286
287 i = 0;
288 while(--n >= 0) {
289 b[i++] = *s++;
290 if(i == FSZSHORT) {
291 prchars(b);
292 i = 0;
293 }
294 }
295
296 while(i < FSZSHORT)
297 b[i++] = '\0';
298 prchars(b);
299}
Note: See TracBrowser for help on using the repository browser.