Commit | Line | Data |
---|---|---|
16494185 BJ |
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 January 1979 | |
8 | */ | |
9 | ||
10 | #include "0.h" | |
11 | #include "tree.h" | |
12 | ||
13 | /* | |
14 | * Type declaration part | |
15 | */ | |
16 | typebeg() | |
17 | { | |
18 | ||
19 | #ifndef PI1 | |
20 | if (parts & VPRT) | |
21 | error("Type declarations must precede var declarations"); | |
22 | if (parts & TPRT) | |
23 | error("All types must be declared in one type part"); | |
24 | parts =| TPRT; | |
25 | #endif | |
26 | /* | |
27 | * Forechain is the head of a list of types that | |
28 | * might be self referential. We chain them up and | |
29 | * process them later. | |
30 | */ | |
31 | forechain = NIL; | |
32 | #ifdef PI0 | |
33 | send(REVTBEG); | |
34 | #endif | |
35 | } | |
36 | ||
37 | type(tline, tid, tdecl) | |
38 | int tline; | |
39 | char *tid; | |
40 | register int *tdecl; | |
41 | { | |
42 | register struct nl *np; | |
43 | ||
44 | np = gtype(tdecl); | |
45 | line = tline; | |
46 | if (np != NIL && (tdecl[0] == T_ID || tdecl[0] == T_TYID)) | |
47 | np = nlcopy(np); | |
48 | #ifndef PI0 | |
49 | enter(defnl(tid, TYPE, np, 0))->nl_flags =| NMOD; | |
50 | #else | |
51 | enter(defnl(tid, TYPE, np, 0)); | |
52 | send(REVTYPE, tline, tid, tdecl); | |
53 | #endif | |
54 | } | |
55 | ||
56 | typeend() | |
57 | { | |
58 | ||
59 | #ifdef PI0 | |
60 | send(REVTEND); | |
61 | #endif | |
62 | foredecl(); | |
63 | } | |
64 | \f | |
65 | /* | |
66 | * Return a type pointer (into the namelist) | |
67 | * from a parse tree for a type, building | |
68 | * namelist entries as needed. | |
69 | */ | |
70 | gtype(r) | |
71 | register int *r; | |
72 | { | |
73 | register struct nl *np; | |
74 | register char *cp; | |
75 | int oline; | |
76 | ||
77 | if (r == NIL) | |
78 | return (NIL); | |
79 | oline = line; | |
80 | if (r[0] != T_ID) | |
81 | oline = line = r[1]; | |
82 | switch (r[0]) { | |
83 | default: | |
84 | panic("type"); | |
85 | case T_TYID: | |
86 | r++; | |
87 | case T_ID: | |
88 | np = lookup(r[1]); | |
89 | if (np == NIL) | |
90 | break; | |
91 | if (np->class != TYPE) { | |
92 | #ifndef PI1 | |
93 | error("%s is a %s, not a type as required", r[1], classes[np->class]); | |
94 | #endif | |
95 | np = NIL; | |
96 | break; | |
97 | } | |
98 | np = np->type; | |
99 | break; | |
100 | case T_TYSCAL: | |
101 | np = tyscal(r); | |
102 | break; | |
103 | case T_TYRANG: | |
104 | np = tyrang(r); | |
105 | break; | |
106 | case T_TYPTR: | |
107 | np = defnl(0, PTR, 0, r[2]); | |
108 | np->nl_next = forechain; | |
109 | forechain = np; | |
110 | break; | |
111 | case T_TYPACK: | |
112 | np = gtype(r[2]); | |
113 | break; | |
114 | case T_TYARY: | |
115 | np = tyary(r); | |
116 | break; | |
117 | case T_TYREC: | |
118 | np = tyrec(r[2], 0); | |
119 | break; | |
120 | case T_TYFILE: | |
121 | np = gtype(r[2]); | |
122 | if (np == NIL) | |
123 | break; | |
124 | #ifndef PI1 | |
125 | if (np->nl_flags & NFILES) | |
126 | error("Files cannot be members of files"); | |
127 | #endif | |
128 | np = defnl(0, FILE, np, 0); | |
129 | np->nl_flags =| NFILES; | |
130 | break; | |
131 | case T_TYSET: | |
132 | np = gtype(r[2]); | |
133 | if (np == NIL) | |
134 | break; | |
135 | if (np->type == nl+TDOUBLE) { | |
136 | #ifndef PI1 | |
137 | error("Set of real is not allowed"); | |
138 | #endif | |
139 | np = NIL; | |
140 | break; | |
141 | } | |
142 | if (np->class != RANGE && np->class != SCAL) { | |
143 | #ifndef PI1 | |
144 | error("Set type must be range or scalar, not %s", nameof(np)); | |
145 | #endif | |
146 | np = NIL; | |
147 | break; | |
148 | } | |
149 | #ifndef PI1 | |
150 | if (width(np) > 2) | |
151 | error("Implementation restriction: sets must be indexed by 16 bit quantities"); | |
152 | #endif | |
153 | np = defnl(0, SET, np, 0); | |
154 | break; | |
155 | } | |
156 | line = oline; | |
157 | return (np); | |
158 | } | |
159 | ||
160 | /* | |
161 | * Scalar (enumerated) types | |
162 | */ | |
163 | tyscal(r) | |
164 | int *r; | |
165 | { | |
166 | register struct nl *np, *op; | |
167 | register *v; | |
168 | int i; | |
169 | ||
170 | np = defnl(0, SCAL, 0, 0); | |
171 | np->type = np; | |
172 | v = r[2]; | |
173 | if (v == NIL) | |
174 | return (NIL); | |
175 | i = -1; | |
176 | for (; v != NIL; v = v[2]) { | |
177 | op = enter(defnl(v[1], CONST, np, ++i)); | |
178 | #ifndef PI0 | |
179 | op->nl_flags =| NMOD; | |
180 | #endif | |
181 | op->value[1] = i; | |
182 | } | |
183 | np->range[1] = i; | |
184 | return (np); | |
185 | } | |
186 | ||
187 | /* | |
188 | * Declare a subrange. | |
189 | */ | |
190 | tyrang(r) | |
191 | register int *r; | |
192 | { | |
193 | register struct nl *lp, *hp; | |
194 | double high; | |
195 | int c, c1; | |
196 | ||
197 | gconst(r[3]); | |
198 | hp = con.ctype; | |
199 | high = con.crval; | |
200 | gconst(r[2]); | |
201 | lp = con.ctype; | |
202 | if (lp == NIL || hp == NIL) | |
203 | return (NIL); | |
204 | if (norange(lp) || norange(hp)) | |
205 | return (NIL); | |
206 | c = classify(lp); | |
207 | c1 = classify(hp); | |
208 | if (c != c1) { | |
209 | #ifndef PI1 | |
210 | error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp)); | |
211 | #endif | |
212 | return (NIL); | |
213 | } | |
214 | if (c == TSCAL && scalar(lp) != scalar(hp)) { | |
215 | #ifndef PI1 | |
216 | error("Scalar types must be identical in subranges"); | |
217 | #endif | |
218 | return (NIL); | |
219 | } | |
220 | if (con.crval > high) { | |
221 | #ifndef PI1 | |
222 | error("Range lower bound exceeds upper bound"); | |
223 | #endif | |
224 | return (NIL); | |
225 | } | |
226 | lp = defnl(0, RANGE, hp->type, 0); | |
227 | lp->range[0] = con.crval; | |
228 | lp->range[1] = high; | |
229 | return (lp); | |
230 | } | |
231 | ||
232 | norange(p) | |
233 | register struct nl *p; | |
234 | { | |
235 | if (isa(p, "d")) { | |
236 | #ifndef PI1 | |
237 | error("Subrange of real is not allowed"); | |
238 | #endif | |
239 | return (1); | |
240 | } | |
241 | if (isnta(p, "bcsi")) { | |
242 | #ifndef PI1 | |
243 | error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p)); | |
244 | #endif | |
245 | return (1); | |
246 | } | |
247 | return (0); | |
248 | } | |
249 | ||
250 | /* | |
251 | * Declare arrays and chain together the dimension specification | |
252 | */ | |
253 | tyary(r) | |
254 | int *r; | |
255 | { | |
256 | struct nl *np; | |
257 | register *tl; | |
258 | register struct nl *tp, *ltp; | |
259 | int i; | |
260 | ||
261 | tp = gtype(r[3]); | |
262 | if (tp == NIL) | |
263 | return (NIL); | |
264 | np = defnl(0, ARRAY, tp, 0); | |
265 | np->nl_flags =| (tp->nl_flags) & NFILES; | |
266 | ltp = np; | |
267 | i = 0; | |
268 | for (tl = r[2]; tl != NIL; tl = tl[2]) { | |
269 | tp = gtype(tl[1]); | |
270 | if (tp == NIL) { | |
271 | np = NIL; | |
272 | continue; | |
273 | } | |
274 | if (tp->class == RANGE && tp->type == nl+TDOUBLE) { | |
275 | #ifndef PI1 | |
276 | error("Index type for arrays cannot be real"); | |
277 | #endif | |
278 | np = NIL; | |
279 | continue; | |
280 | } | |
281 | if (tp->class != RANGE && tp->class != SCAL) { | |
282 | #ifndef PI1 | |
283 | error("Array index type is a %s, not a range or scalar as required", classes[tp->class]); | |
284 | #endif | |
285 | np = NIL; | |
286 | continue; | |
287 | } | |
288 | if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { | |
289 | #ifndef PI1 | |
290 | error("Value of dimension specifier too large or small for this implementation"); | |
291 | #endif | |
292 | continue; | |
293 | } | |
294 | tp = nlcopy(tp); | |
295 | i++; | |
296 | ltp->chain = tp; | |
297 | ltp = tp; | |
298 | } | |
299 | if (np != NIL) | |
300 | np->value[0] = i; | |
301 | return (np); | |
302 | } | |
303 | ||
304 | /* | |
305 | * Delayed processing for pointers to | |
306 | * allow self-referential and mutually | |
307 | * recursive pointer constructs. | |
308 | */ | |
309 | foredecl() | |
310 | { | |
311 | register struct nl *p, *q; | |
312 | ||
313 | for (p = forechain; p != NIL; p = p->nl_next) { | |
314 | if (p->class == PTR && p->value[0] != 0) | |
315 | { | |
316 | p->type = gtype(p->value[0]); | |
317 | #ifndef PI1 | |
318 | if (p->type != NIL && (p->type->nl_flags & NFILES)) | |
319 | error("Files cannot be members of dynamic structures"); | |
320 | #endif | |
321 | p->value[0] = 0; | |
322 | } | |
323 | } | |
324 | } |