Commit | Line | Data |
---|---|---|
1bbf66cf CH |
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 |