![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to conv.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / pi|
Return to conv.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / pi |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2:
3: static char sccsid[] = "@(#)conv.c 1.1 8/27/80";
4:
5: #include "whoami.h"
6: #ifdef PI
7: #include "0.h"
8: #include "opcode.h"
9: #ifdef PC
10: # include "pcops.h"
11: #endif PC
12:
13: #ifndef PI0
14: /*
15: * Convert a p1 into a p2.
16: * Mostly used for different
17: * length integers and "to real" conversions.
18: */
19: convert(p1, p2)
20: struct nl *p1, *p2;
21: {
22: if (p1 == NIL || p2 == NIL)
23: return;
24: switch (width(p1) - width(p2)) {
25: case -7:
26: case -6:
27: put1(O_STOD);
28: return;
29: case -4:
30: put1(O_ITOD);
31: return;
32: case -3:
33: case -2:
34: put1(O_STOI);
35: return;
36: case -1:
37: case 0:
38: case 1:
39: return;
40: case 2:
41: case 3:
42: put1(O_ITOS);
43: return;
44: default:
45: panic("convert");
46: }
47: }
48: #endif
49:
50: /*
51: * Compat tells whether
52: * p1 and p2 are compatible
53: * types for an assignment like
54: * context, i.e. value parameters,
55: * indicies for 'in', etc.
56: */
57: compat(p1, p2, t)
58: struct nl *p1, *p2;
59: {
60: register c1, c2;
61:
62: c1 = classify(p1);
63: if (c1 == NIL)
64: return (NIL);
65: c2 = classify(p2);
66: if (c2 == NIL)
67: return (NIL);
68: switch (c1) {
69: case TBOOL:
70: case TCHAR:
71: if (c1 == c2)
72: return (1);
73: break;
74: case TINT:
75: if (c2 == TINT)
76: return (1);
77: case TDOUBLE:
78: if (c2 == TDOUBLE)
79: return (1);
80: #ifndef PI0
81: if (c2 == TINT && divflg == 0 && t != NIL ) {
82: divchk= 1;
83: c1 = classify(rvalue(t, NLNIL , RREQ ));
84: divchk = NIL;
85: if (c1 == TINT) {
86: error("Type clash: real is incompatible with integer");
87: cerror("This resulted because you used '/' which always returns real rather");
88: cerror("than 'div' which divides integers and returns integers");
89: divflg = 1;
90: return (NIL);
91: }
92: }
93: #endif
94: break;
95: case TSCAL:
96: if (c2 != TSCAL)
97: break;
98: if (scalar(p1) != scalar(p2)) {
99: derror("Type clash: non-identical scalar types");
100: return (NIL);
101: }
102: return (1);
103: case TSTR:
104: if (c2 != TSTR)
105: break;
106: if (width(p1) != width(p2)) {
107: derror("Type clash: unequal length strings");
108: return (NIL);
109: }
110: return (1);
111: case TNIL:
112: if (c2 != TPTR)
113: break;
114: return (1);
115: case TFILE:
116: if (c1 != c2)
117: break;
118: derror("Type clash: files not allowed in this context");
119: return (NIL);
120: default:
121: if (c1 != c2)
122: break;
123: if (p1 != p2) {
124: derror("Type clash: non-identical %s types", clnames[c1]);
125: return (NIL);
126: }
127: if (p1->nl_flags & NFILES) {
128: derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
129: return (NIL);
130: }
131: return (1);
132: }
133: derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
134: return (NIL);
135: }
136:
137: #ifndef PI0
138: /*
139: * Rangechk generates code to
140: * check if the type p on top
141: * of the stack is in range for
142: * assignment to a variable
143: * of type q.
144: */
145: rangechk(p, q)
146: struct nl *p, *q;
147: {
148: register struct nl *rp;
149: register op;
150: int wq, wrp;
151:
152: if (opt('t') == 0)
153: return;
154: rp = p;
155: if (rp == NIL)
156: return;
157: if (q == NIL)
158: return;
159: # ifdef OBJ
160: /*
161: * When op is 1 we are checking length
162: * 4 numbers against length 2 bounds,
163: * and adding it to the opcode forces
164: * generation of appropriate tests.
165: */
166: op = 0;
167: wq = width(q);
168: wrp = width(rp);
169: op = wq != wrp && (wq == 4 || wrp == 4);
170: if (rp->class == TYPE)
171: rp = rp->type;
172: switch (rp->class) {
173: case RANGE:
174: if (rp->range[0] != 0) {
175: # ifndef DEBUG
176: if (wrp <= 2)
177: put(3, O_RANG2+op, ( short ) rp->range[0],
178: ( short ) rp->range[1]);
179: else if (rp != nl+T4INT)
180: put(3, O_RANG4+op, rp->range[0], rp->range[1] );
181: # else
182: if (!hp21mx) {
183: if (wrp <= 2)
184: put(3, O_RANG2+op,( short ) rp->range[0],
185: ( short ) rp->range[1]);
186: else if (rp != nl+T4INT)
187: put(3, O_RANG4+op,rp->range[0],
188: rp->range[1]);
189: } else
190: if (rp != nl+T2INT && rp != nl+T4INT)
191: put(3, O_RANG2+op,( short ) rp->range[0],
192: ( short ) rp->range[1]);
193: # endif
194: break;
195: }
196: /*
197: * Range whose lower bounds are
198: * zero can be treated as scalars.
199: */
200: case SCAL:
201: if (wrp <= 2)
202: put(2, O_RSNG2+op, ( short ) rp->range[1]);
203: else
204: put( 2 , O_RSNG4+op, rp->range[1]);
205: break;
206: default:
207: panic("rangechk");
208: }
209: # endif OBJ
210: # ifdef PC
211: /*
212: * what i want to do is make this and some other stuff
213: * arguments to a function call, which will do the rangecheck,
214: * and return the value of the current expression, or abort
215: * if the rangecheck fails.
216: * probably i need one rangecheck routine to return each c-type
217: * of value.
218: * also, i haven't figured out what the `other stuff' is.
219: */
220: putprintf( "# call rangecheck" , 0 );
221: # endif PC
222: }
223: #endif
224: #endif
225:
226: #ifdef PC
227: /*
228: * if type p requires a range check,
229: * then put out the name of the checking function
230: * for the beginning of a function call which is completed by postcheck.
231: * (name1 is for a full check; name2 assumes a lower bound of zero)
232: */
233: precheck( p , name1 , name2 )
234: struct nl *p;
235: char *name1 , *name2;
236: {
237:
238: if ( opt( 't' ) == 0 ) {
239: return;
240: }
241: if ( p == NIL ) {
242: return;
243: }
244: if ( p -> class == TYPE ) {
245: p = p -> type;
246: }
247: switch ( p -> class ) {
248: case RANGE:
249: if ( p != nl + T4INT ) {
250: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
251: , p -> range[0] != 0 ? name1 : name2 );
252: }
253: break;
254: case SCAL:
255: /*
256: * how could a scalar ever be out of range?
257: */
258: break;
259: default:
260: panic( "precheck" );
261: break;
262: }
263: }
264:
265: /*
266: * if type p requires a range check,
267: * then put out the rest of the arguments of to the checking function
268: * a call to which was started by precheck.
269: * the first argument is what is being rangechecked (put out by rvalue),
270: * the second argument is the lower bound of the range,
271: * the third argument is the upper bound of the range.
272: */
273: postcheck( p )
274: struct nl *p;
275: {
276:
277: if ( opt( 't' ) == 0 ) {
278: return;
279: }
280: if ( p == NIL ) {
281: return;
282: }
283: if ( p -> class == TYPE ) {
284: p = p -> type;
285: }
286: switch ( p -> class ) {
287: case RANGE:
288: if ( p != nl + T4INT ) {
289: if (p -> range[0] != 0 ) {
290: putleaf( P2ICON , p -> range[0] , 0 , P2INT , 0 );
291: putop( P2LISTOP , P2INT );
292: }
293: putleaf( P2ICON , p -> range[1] , 0 , P2INT , 0 );
294: putop( P2LISTOP , P2INT );
295: putop( P2CALL , P2INT );
296: }
297: break;
298: case SCAL:
299: break;
300: default:
301: panic( "postcheck" );
302: break;
303: }
304: }
305: #endif PC
306:
307: #ifdef DEBUG
308: conv(dub)
309: int *dub;
310: {
311: int newfp[2];
312: double *dp = dub;
313: long *lp = dub;
314: register int exp;
315: long mant;
316:
317: newfp[0] = dub[0] & 0100000;
318: newfp[1] = 0;
319: if (*dp == 0.0)
320: goto ret;
321: exp = ((dub[0] >> 7) & 0377) - 0200;
322: if (exp < 0) {
323: newfp[1] = 1;
324: exp = -exp;
325: }
326: if (exp > 63)
327: exp = 63;
328: dub[0] &= ~0177600;
329: dub[0] |= 0200;
330: mant = *lp;
331: mant <<= 8;
332: if (newfp[0])
333: mant = -mant;
334: newfp[0] |= (mant >> 17) & 077777;
335: newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1);
336: ret:
337: dub[0] = newfp[0];
338: dub[1] = newfp[1];
339: }
340: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.