![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to put.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to put.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: /*
25: * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
26: * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
27: */
28:
29: #include "defs.h"
30: #include "names.h" /* For LOCAL_CONST_NAME */
31: #include "pccdefs.h"
32: #include "p1defs.h"
33:
34: /* Definitions for putconst() */
35:
36: #define LIT_CHAR 1
37: #define LIT_FLOAT 2
38: #define LIT_INT 3
39:
40:
41: /*
42: char *ops [ ] =
43: {
44: "??", "+", "-", "*", "/", "**", "-",
45: "OR", "AND", "EQV", "NEQV", "NOT",
46: "CONCAT",
47: "<", "==", ">", "<=", "!=", ">=",
48: " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
49: " , ", " ? ", " : "
50: " abs ", " min ", " max ", " addr ", " indirect ",
51: " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
52: };
53: */
54:
55: /* Each of these values is defined in pccdefs */
56:
57: int ops2 [ ] =
58: {
59: P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
60: P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
61: P2BAD,
62: P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
63: P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
64: P2COMOP, P2QUEST, P2COLON,
65: 1, P2BAD, P2BAD, P2BAD, P2BAD,
66: P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
67: P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
68: P2BAD, P2BAD, P2BAD, P2BAD,
69: 1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
70: 1,1,1,1 /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
71: };
72:
73:
74: setlog()
75: {
76: typesize[TYLOGICAL] = typesize[tylogical];
77: typealign[TYLOGICAL] = typealign[tylogical];
78: }
79:
80:
81: putexpr(p)
82: expptr p;
83: {
84: /* Write the expression to the p1 file */
85:
86: p = (expptr) putx (fixtype (p));
87: p1_expr (p);
88: }
89:
90:
91:
92:
93:
94: expptr putassign(lp, rp)
95: expptr lp, rp;
96: {
97: return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
98: }
99:
100:
101:
102:
103: void puteq(lp, rp)
104: expptr lp, rp;
105: {
106: putexpr(mkexpr(OPASSIGN, lp, rp) );
107: }
108:
109:
110:
111:
112: /* put code for a *= b */
113:
114: expptr putsteq(a, b)
115: Addrp a, b;
116: {
117: return putx( fixexpr((Exprp)
118: mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
119: }
120:
121:
122:
123:
124: Addrp mkfield(res, f, ty)
125: register Addrp res;
126: char *f;
127: int ty;
128: {
129: res -> vtype = ty;
130: res -> Field = f;
131: return res;
132: } /* mkfield */
133:
134:
135: Addrp realpart(p)
136: register Addrp p;
137: {
138: register Addrp q;
139: expptr mkrealcon();
140:
141: if (p->tag == TADDR
142: && p->uname_tag == UNAM_CONST
143: && ISCOMPLEX (p->vtype))
144: return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
145: p->user.kludge.vstg1 ? p->user.Const.cds[0]
146: : cds(dtos(p->user.Const.cd[0]),CNULL));
147:
148: q = (Addrp) cpexpr((expptr) p);
149: if( ISCOMPLEX(p->vtype) )
150: q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
151:
152: return(q);
153: }
154:
155:
156:
157:
158: expptr imagpart(p)
159: register Addrp p;
160: {
161: register Addrp q;
162: expptr mkrealcon();
163:
164: if( ISCOMPLEX(p->vtype) )
165: {
166: if (p->tag == TADDR && p->uname_tag == UNAM_CONST)
167: return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
168: p->user.kludge.vstg1 ? p->user.Const.cds[1]
169: : cds(dtos(p->user.Const.cd[1]),CNULL));
170: q = (Addrp) cpexpr((expptr) p);
171: q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
172: return( (expptr) q );
173: }
174: else
175:
176: /* Cast an integer type onto a Double Real type */
177:
178: return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
179: }
180:
181:
182:
183:
184:
185: /* ncat -- computes the number of adjacent concatenation operations */
186:
187: ncat(p)
188: register expptr p;
189: {
190: if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
191: return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
192: else return(1);
193: }
194:
195:
196:
197:
198: /* lencat -- returns the length of the concatenated string. Each
199: substring must have a static (i.e. compile-time) fixed length */
200:
201: ftnint lencat(p)
202: register expptr p;
203: {
204: if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
205: return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
206: else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
207: return(p->headblock.vleng->constblock.Const.ci);
208: else if(p->tag==TADDR && p->addrblock.varleng!=0)
209: return(p->addrblock.varleng);
210: else
211: {
212: err("impossible element in concatenation");
213: return(0);
214: }
215: }
216:
217: /* putconst -- Creates a new Addrp value which maps onto the input
218: constant value. The Addrp doesn't retain the value of the constant,
219: instead that value is copied into a table of constants (called
220: litpool, for pool of literal values). The only way to retrieve the
221: actual value of the constant is to look at the memno field of the
222: Addrp result. You know that the associated literal is the one referred
223: to by q when (q -> memno == litp -> litnum).
224: */
225:
226: Addrp putconst(p)
227: register Constp p;
228: {
229: register Addrp q;
230: struct Literal *litp, *lastlit;
231: int k, len, type;
232: int litflavor;
233: double cd[2];
234: ftnint nblanks;
235: char *strp;
236: char cdsbuf0[64], cdsbuf1[64], *ds[2];
237:
238: if (p->tag != TCONST)
239: badtag("putconst", p->tag);
240:
241: q = ALLOC(Addrblock);
242: q->tag = TADDR;
243: type = p->vtype;
244: q->vtype = ( type==TYADDR ? tyint : type );
245: q->vleng = (expptr) cpexpr(p->vleng);
246: q->vstg = STGCONST;
247:
248: /* Create the new label for the constant. This is wasteful of labels
249: because when the constant value already exists in the literal pool,
250: this label gets thrown away and is never reclaimed. It might be
251: cleaner to move this down past the first switch() statement below */
252:
253: q->memno = newlabel();
254: q->memoffset = ICON(0);
255: q -> uname_tag = UNAM_CONST;
256:
257: /* Copy the constant info into the Addrblock; do this by copying the
258: largest storage elts */
259:
260: q -> user.Const = p -> Const;
261: q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
262:
263: /* check for value in literal pool, and update pool if necessary */
264:
265: k = 1;
266: switch(type)
267: {
268: case TYCHAR:
269: if (halign) {
270: strp = p->Const.ccp;
271: nblanks = p->Const.ccp1.blanks;
272: len = p->vleng->constblock.Const.ci;
273: litflavor = LIT_CHAR;
274: goto loop;
275: }
276: else
277: q->memno = BAD_MEMNO;
278: break;
279: case TYCOMPLEX:
280: case TYDCOMPLEX:
281: k = 2;
282: if (p->vstg)
283: cd[1] = atof(ds[1] = p->Const.cds[1]);
284: else
285: ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
286: case TYREAL:
287: case TYDREAL:
288: litflavor = LIT_FLOAT;
289: if (p->vstg)
290: cd[0] = atof(ds[0] = p->Const.cds[0]);
291: else
292: ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
293: goto loop;
294:
295: case TYLOGICAL1:
296: case TYLOGICAL2:
297: case TYLOGICAL:
298: type = tylogical;
299: goto lit_int_flavor;
300: case TYLONG:
301: type = tyint;
302: case TYSHORT:
303: case TYINT1:
304: #ifdef TYQUAD
305: case TYQUAD:
306: #endif
307: lit_int_flavor:
308: litflavor = LIT_INT;
309:
310: /* Scan the literal pool for this constant value. If this same constant
311: has been assigned before, use the same label. Note that this routine
312: does NOT consider two differently-typed constants with the same bit
313: pattern to be the same constant */
314:
315: loop:
316: lastlit = litpool + nliterals;
317: for(litp = litpool ; litp<lastlit ; ++litp)
318:
319: /* Remove this type checking to ensure that all bit patterns are reused */
320:
321: if(type == litp->littype) switch(litflavor)
322: {
323: case LIT_CHAR:
324: if (len == (int)litp->litval.litival2[0]
325: && nblanks == litp->litval.litival2[1]
326: && !memcmp(strp, litp->cds[0], len)) {
327: q->memno = litp->litnum;
328: frexpr((expptr)p);
329: q->user.Const.ccp1.ccp0 = litp->cds[0];
330: return(q);
331: }
332: break;
333: case LIT_FLOAT:
334: if(cd[0] == litp->litval.litdval[0]
335: && !strcmp(ds[0], litp->cds[0])
336: && (k == 1 ||
337: cd[1] == litp->litval.litdval[1]
338: && !strcmp(ds[1], litp->cds[1]))) {
339: ret:
340: q->memno = litp->litnum;
341: frexpr((expptr)p);
342: return(q);
343: }
344: break;
345:
346: case LIT_INT:
347: if(p->Const.ci == litp->litval.litival)
348: goto ret;
349: break;
350: }
351:
352: /* If there's room in the literal pool, add this new value to the pool */
353:
354: if(nliterals < maxliterals)
355: {
356: ++nliterals;
357:
358: /* litp now points to the next free elt */
359:
360: litp->littype = type;
361: litp->litnum = q->memno;
362: switch(litflavor)
363: {
364: case LIT_CHAR:
365: litp->litval.litival2[0] = len;
366: litp->litval.litival2[1] = nblanks;
367: q->user.Const.ccp = litp->cds[0] =
368: memcpy(gmem(len,0), strp, len);
369: break;
370:
371: case LIT_FLOAT:
372: litp->litval.litdval[0] = cd[0];
373: litp->cds[0] = copys(ds[0]);
374: if (k == 2) {
375: litp->litval.litdval[1] = cd[1];
376: litp->cds[1] = copys(ds[1]);
377: }
378: break;
379:
380: case LIT_INT:
381: litp->litval.litival = p->Const.ci;
382: break;
383: } /* switch (litflavor) */
384: }
385: else
386: many("literal constants", 'L', maxliterals);
387:
388: break;
389: case TYADDR:
390: break;
391: default:
392: badtype ("putconst", p -> vtype);
393: break;
394: } /* switch */
395:
396: if (type != TYCHAR || halign)
397: frexpr((expptr)p);
398: return( q );
399: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.