![[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] / 3BSD / cmd / pi|
Return to conv.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / pi |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2: #
3: /*
4: * pi - Pascal interpreter code translator
5: *
6: * Charles Haley, Bill Joy UCB
7: * Version 1.2 November 1978
8: */
9:
10: #include "whoami"
11: #ifdef PI
12: #include "0.h"
13: #include "opcode.h"
14:
15: #ifndef PI0
16: /*
17: * Convert a p1 into a p2.
18: * Mostly used for different
19: * length integers and "to real" conversions.
20: */
21: convert(p1, p2)
22: struct nl *p1, *p2;
23: {
24: if (p1 == NIL || p2 == NIL)
25: return;
26: switch (width(p1) - width(p2)) {
27: case -7:
28: case -6:
29: put1(O_STOD);
30: return;
31: case -4:
32: put1(O_ITOD);
33: return;
34: case -3:
35: case -2:
36: put1(O_STOI);
37: return;
38: case -1:
39: case 0:
40: case 1:
41: return;
42: case 2:
43: case 3:
44: put1(O_ITOS);
45: return;
46: default:
47: panic("convert");
48: }
49: }
50: #endif
51:
52: /*
53: * Compat tells whether
54: * p1 and p2 are compatible
55: * types for an assignment like
56: * context, i.e. value parameters,
57: * indicies for 'in', etc.
58: */
59: compat(p1, p2, t)
60: struct nl *p1, *p2;
61: {
62: register c1, c2;
63:
64: c1 = classify(p1);
65: if (c1 == NIL)
66: return (NIL);
67: c2 = classify(p2);
68: if (c2 == NIL)
69: return (NIL);
70: switch (c1) {
71: case TBOOL:
72: case TCHAR:
73: if (c1 == c2)
74: return (1);
75: break;
76: case TINT:
77: if (c2 == TINT)
78: return (1);
79: case TDOUBLE:
80: if (c2 == TDOUBLE)
81: return (1);
82: #ifndef PI0
83: if (c2 == TINT && divflg == 0) {
84: divchk= 1;
85: c1 = classify(rvalue(t, NLNIL));
86: divchk = NIL;
87: if (c1 == TINT) {
88: error("Type clash: real is incompatible with integer");
89: cerror("This resulted because you used '/' which always returns real rather");
90: cerror("than 'div' which divides integers and returns integers");
91: divflg = 1;
92: return (NIL);
93: }
94: }
95: #endif
96: break;
97: case TSCAL:
98: if (c2 != TSCAL)
99: break;
100: if (scalar(p1) != scalar(p2)) {
101: derror("Type clash: non-identical scalar types");
102: return (NIL);
103: }
104: return (1);
105: case TSTR:
106: if (c2 != TSTR)
107: break;
108: if (width(p1) != width(p2)) {
109: derror("Type clash: unequal length strings");
110: return (NIL);
111: }
112: return (1);
113: case TNIL:
114: if (c2 != TPTR)
115: break;
116: return (1);
117: case TFILE:
118: if (c1 != c2)
119: break;
120: derror("Type clash: files not allowed in this context");
121: return (NIL);
122: default:
123: if (c1 != c2)
124: break;
125: if (p1 != p2) {
126: derror("Type clash: non-identical %s types", clnames[c1]);
127: return (NIL);
128: }
129: if (p1->nl_flags & NFILES) {
130: derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
131: return (NIL);
132: }
133: return (1);
134: }
135: derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
136: return (NIL);
137: }
138:
139: #ifndef PI0
140: /*
141: * Rangechk generates code to
142: * check if the type p on top
143: * of the stack is in range for
144: * assignment to a variable
145: * of type q.
146: */
147: rangechk(p, q)
148: struct nl *p, *q;
149: {
150: register struct nl *rp;
151: register op;
152: int wq, wrp;
153:
154: if (opt('t') == 0)
155: return;
156: rp = p;
157: if (rp == NIL)
158: return;
159: if (q == NIL)
160: return;
161: /*
162: * When op is 1 we are checking length
163: * 4 numbers against length 2 bounds,
164: * and adding it to the opcode forces
165: * generation of appropriate tests.
166: */
167: op = 0;
168: wq = width(q);
169: wrp = width(rp);
170: op = wq != wrp && (wq == 4 || wrp == 4);
171: if (rp->class == TYPE)
172: rp = rp->type;
173: switch (rp->class) {
174: case RANGE:
175: if (rp->range[0] != 0) {
176: # ifndef DEBUG
177: if (wrp <= 2)
178: put3(O_RANG2+op, ( short ) rp->range[0],
179: ( short ) rp->range[1]);
180: else if (rp != nl+T4INT)
181: put(5, O_RANG4+op, rp->range[0], rp->range[1] );
182: # else
183: if (!hp21mx) {
184: if (wrp <= 2)
185: put3(O_RANG2+op,( short ) rp->range[0],
186: ( short ) rp->range[1]);
187: else if (rp != nl+T4INT)
188: put(5,O_RANG4+op,rp->range[0],
189: rp->range[1]);
190: } else
191: if (rp != nl+T2INT && rp != nl+T4INT)
192: put3(O_RANG2+op,( short ) rp->range[0],
193: ( short ) rp->range[1]);
194: # endif
195: break;
196: }
197: /*
198: * Range whose lower bounds are
199: * zero can be treated as scalars.
200: */
201: case SCAL:
202: if (wrp <= 2)
203: put2(O_RSNG2+op, ( short ) rp->range[1]);
204: else
205: put( 3 , O_RSNG4+op, rp->range[1]);
206: break;
207: default:
208: panic("rangechk");
209: }
210: }
211: #endif
212: #endif
213:
214: #ifdef DEBUG
215: conv(dub)
216: int *dub;
217: {
218: int newfp[2];
219: double *dp = dub;
220: long *lp = dub;
221: register int exp;
222: long mant;
223:
224: newfp[0] = dub[0] & 0100000;
225: newfp[1] = 0;
226: if (*dp == 0.0)
227: goto ret;
228: exp = ((dub[0] >> 7) & 0377) - 0200;
229: if (exp < 0) {
230: newfp[1] = 1;
231: exp = -exp;
232: }
233: if (exp > 63)
234: exp = 63;
235: dub[0] &= ~0177600;
236: dub[0] |= 0200;
237: mant = *lp;
238: mant <<= 8;
239: if (newfp[0])
240: mant = -mant;
241: newfp[0] |= (mant >> 17) & 077777;
242: newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1);
243: ret:
244: dub[0] = newfp[0];
245: dub[1] = newfp[1];
246: }
247: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.