Commit | Line | Data |
---|---|---|
5214d9da ML |
1 | /* Copyright (c) 1982 Regents of the University of California */ |
2 | ||
550fe947 | 3 | static char sccsid[] = "@(#)pascal.c 1.2 %G%"; |
5214d9da ML |
4 | |
5 | /* | |
6 | * Pascal-dependent symbol routines. | |
7 | */ | |
8 | ||
9 | #include "defs.h" | |
10 | #include "symbols.h" | |
11 | #include "pascal.h" | |
12 | #include "languages.h" | |
13 | #include "tree.h" | |
14 | #include "eval.h" | |
15 | #include "mappings.h" | |
16 | #include "process.h" | |
17 | #include "runtime.h" | |
18 | #include "machine.h" | |
19 | ||
20 | #ifndef public | |
21 | #endif | |
22 | ||
23 | /* | |
24 | * Initialize Pascal information. | |
25 | */ | |
26 | ||
27 | public pascal_init() | |
28 | { | |
29 | Language lang; | |
30 | ||
31 | lang = language_define("pascal", ".p"); | |
32 | language_setop(lang, L_PRINTDECL, pascal_printdecl); | |
33 | language_setop(lang, L_PRINTVAL, pascal_printval); | |
34 | language_setop(lang, L_TYPEMATCH, pascal_typematch); | |
35 | } | |
36 | ||
37 | /* | |
38 | * Compatible tests if two types are compatible. The issue | |
39 | * is complicated a bit by ranges. | |
40 | * | |
41 | * Integers and reals are not compatible since they cannot always be mixed. | |
42 | */ | |
43 | ||
44 | public Boolean pascal_typematch(type1, type2) | |
45 | Symbol type1, type2; | |
46 | { | |
47 | Boolean b; | |
48 | register Symbol t1, t2; | |
49 | ||
50 | t1 = rtype(t1); | |
51 | t2 = rtype(t2); | |
52 | b = (Boolean) | |
53 | (t1->type == t2->type and ( | |
54 | (t1->class == RANGE and t2->class == RANGE) or | |
55 | (t1->class == SCAL and t2->class == CONST) or | |
56 | (t1->class == CONST and t2->class == SCAL) or | |
57 | (t1->type == t_char and t1->class == ARRAY and t2->class == ARRAY) | |
58 | ) or | |
59 | (t1 == t_nil and t2->class == PTR) or | |
60 | (t1->class == PTR and t2 == t_nil) | |
61 | ); | |
62 | return b; | |
63 | } | |
64 | ||
65 | public pascal_printdecl(s) | |
66 | Symbol s; | |
67 | { | |
68 | register Symbol t; | |
69 | Boolean semicolon; | |
70 | ||
71 | semicolon = true; | |
72 | switch (s->class) { | |
73 | case CONST: | |
74 | if (s->type->class == SCAL) { | |
75 | printf("(enumeration constant, ord %ld)", | |
76 | s->symvalue.iconval); | |
77 | } else { | |
78 | printf("const %s = ", symname(s)); | |
79 | printval(s); | |
80 | } | |
81 | break; | |
82 | ||
83 | case TYPE: | |
84 | printf("type %s = ", symname(s)); | |
85 | printtype(s, s->type); | |
86 | break; | |
87 | ||
88 | case VAR: | |
89 | if (isparam(s)) { | |
90 | printf("(parameter) %s : ", symname(s)); | |
91 | } else { | |
92 | printf("var %s : ", symname(s)); | |
93 | } | |
94 | printtype(s, s->type); | |
95 | break; | |
96 | ||
97 | case REF: | |
98 | printf("(var parameter) %s : ", symname(s)); | |
99 | printtype(s, s->type); | |
100 | break; | |
101 | ||
102 | case RANGE: | |
103 | case ARRAY: | |
104 | case RECORD: | |
105 | case VARNT: | |
106 | case PTR: | |
107 | printtype(s, s); | |
108 | semicolon = false; | |
109 | break; | |
110 | ||
111 | case FVAR: | |
112 | printf("(function variable) %s : ", symname(s)); | |
113 | printtype(s, s->type); | |
114 | break; | |
115 | ||
116 | case FIELD: | |
117 | printf("(field) %s : ", symname(s)); | |
118 | printtype(s, s->type); | |
119 | break; | |
120 | ||
121 | case PROC: | |
122 | printf("procedure %s", symname(s)); | |
123 | listparams(s); | |
124 | break; | |
125 | ||
126 | case PROG: | |
127 | printf("program %s", symname(s)); | |
128 | t = s->chain; | |
129 | if (t != nil) { | |
130 | printf("(%s", symname(t)); | |
131 | for (t = t->chain; t != nil; t = t->chain) { | |
132 | printf(", %s", symname(t)); | |
133 | } | |
134 | printf(")"); | |
135 | } | |
136 | break; | |
137 | ||
138 | case FUNC: | |
139 | printf("function %s", symname(s)); | |
140 | listparams(s); | |
141 | printf(" : "); | |
142 | printtype(s, s->type); | |
143 | break; | |
144 | ||
145 | default: | |
146 | error("class %s in printdecl", classname(s)); | |
147 | } | |
148 | if (semicolon) { | |
149 | putchar(';'); | |
150 | } | |
151 | putchar('\n'); | |
152 | } | |
153 | ||
154 | /* | |
155 | * Recursive whiz-bang procedure to print the type portion | |
156 | * of a declaration. Doesn't work quite right for variant records. | |
157 | * | |
158 | * The symbol associated with the type is passed to allow | |
159 | * searching for type names without getting "type blah = blah". | |
160 | */ | |
161 | ||
162 | private printtype(s, t) | |
163 | Symbol s; | |
164 | Symbol t; | |
165 | { | |
166 | register Symbol tmp; | |
167 | ||
168 | switch (t->class) { | |
169 | case VAR: | |
170 | case CONST: | |
171 | case FUNC: | |
172 | case PROC: | |
173 | panic("printtype: class %s", classname(t)); | |
174 | break; | |
175 | ||
176 | case ARRAY: | |
177 | printf("array["); | |
178 | tmp = t->chain; | |
179 | if (tmp != nil) { | |
180 | for (;;) { | |
181 | printtype(tmp, tmp); | |
182 | tmp = tmp->chain; | |
183 | if (tmp == nil) { | |
184 | break; | |
185 | } | |
186 | printf(", "); | |
187 | } | |
188 | } | |
189 | printf("] of "); | |
190 | printtype(t, t->type); | |
191 | break; | |
192 | ||
193 | case RECORD: | |
194 | printf("record\n"); | |
195 | if (t->chain != nil) { | |
196 | printtype(t->chain, t->chain); | |
197 | } | |
198 | printf("end"); | |
199 | break; | |
200 | ||
201 | case FIELD: | |
202 | if (t->chain != nil) { | |
203 | printtype(t->chain, t->chain); | |
204 | } | |
205 | printf("\t%s : ", symname(t)); | |
206 | printtype(t, t->type); | |
207 | printf(";\n"); | |
208 | break; | |
209 | ||
210 | case RANGE: { | |
211 | long r0, r1; | |
212 | ||
213 | r0 = t->symvalue.rangev.lower; | |
214 | r1 = t->symvalue.rangev.upper; | |
215 | if (t == t_char) { | |
216 | if (r0 < 0x20 or r0 > 0x7e) { | |
217 | printf("%ld..", r0); | |
218 | } else { | |
219 | printf("'%c'..", (char) r0); | |
220 | } | |
221 | if (r1 < 0x20 or r1 > 0x7e) { | |
222 | printf("\\%lo", r1); | |
223 | } else { | |
224 | printf("'%c'", (char) r1); | |
225 | } | |
226 | } else if (r0 > 0 and r1 == 0) { | |
227 | printf("%ld byte real", r0); | |
228 | } else if (r0 >= 0) { | |
229 | printf("%lu..%lu", r0, r1); | |
230 | } else { | |
231 | printf("%ld..%ld", r0, r1); | |
232 | } | |
233 | break; | |
234 | } | |
235 | ||
236 | case PTR: | |
237 | putchar('*'); | |
238 | printtype(t, t->type); | |
239 | break; | |
240 | ||
241 | case TYPE: | |
242 | if (symname(t) != nil) { | |
243 | printf("%s", symname(t)); | |
244 | } else { | |
245 | printtype(t, t->type); | |
246 | } | |
247 | break; | |
248 | ||
249 | case SCAL: | |
250 | printf("("); | |
251 | t = t->type->chain; | |
252 | if (t != nil) { | |
253 | printf("%s", symname(t)); | |
254 | t = t->chain; | |
255 | while (t != nil) { | |
256 | printf(", %s", symname(t)); | |
257 | t = t->chain; | |
258 | } | |
259 | } else { | |
260 | panic("empty enumeration"); | |
261 | } | |
262 | printf(")"); | |
263 | break; | |
264 | ||
265 | default: | |
266 | printf("(class %d)", t->class); | |
267 | break; | |
268 | } | |
269 | } | |
270 | ||
271 | /* | |
272 | * List the parameters of a procedure or function. | |
273 | * No attempt is made to combine like types. | |
274 | */ | |
275 | ||
276 | private listparams(s) | |
277 | Symbol s; | |
278 | { | |
279 | Symbol t; | |
280 | ||
281 | if (s->chain != nil) { | |
282 | putchar('('); | |
283 | for (t = s->chain; t != nil; t = t->chain) { | |
284 | switch (t->class) { | |
285 | case REF: | |
286 | printf("var "); | |
287 | break; | |
288 | ||
289 | case FPROC: | |
290 | printf("procedure "); | |
291 | break; | |
292 | ||
293 | case FFUNC: | |
294 | printf("function "); | |
295 | break; | |
296 | ||
297 | case VAR: | |
298 | break; | |
299 | ||
300 | default: | |
301 | panic("unexpected class %d for parameter", t->class); | |
302 | } | |
303 | printf("%s : ", symname(t)); | |
304 | printtype(t, t->type); | |
305 | if (t->chain != nil) { | |
306 | printf("; "); | |
307 | } | |
308 | } | |
309 | putchar(')'); | |
310 | } | |
311 | } | |
312 | ||
313 | /* | |
314 | * Print out the value on the top of the expression stack | |
315 | * in the format for the type of the given symbol. | |
316 | */ | |
317 | ||
318 | public pascal_printval(s) | |
319 | Symbol s; | |
320 | { | |
321 | Symbol t; | |
322 | Address a; | |
323 | int len; | |
324 | double r; | |
325 | ||
326 | if (s->class == REF) { | |
327 | s = s->type; | |
328 | } | |
329 | switch (s->class) { | |
330 | case TYPE: | |
331 | pascal_printval(s->type); | |
332 | break; | |
333 | ||
334 | case ARRAY: | |
335 | t = rtype(s->type); | |
336 | if (t==t_char or (t->class==RANGE and t->type==t_char)) { | |
337 | len = size(s); | |
338 | sp -= len; | |
339 | printf("'%.*s'", len, sp); | |
340 | break; | |
341 | } else { | |
342 | printarray(s); | |
343 | } | |
344 | break; | |
345 | ||
346 | case RECORD: | |
347 | printrecord(s); | |
348 | break; | |
349 | ||
350 | case VARNT: | |
351 | error("can't print out variant records"); | |
352 | break; | |
353 | ||
354 | ||
355 | case RANGE: | |
356 | if (s == t_boolean) { | |
357 | printf(((Boolean) popsmall(s)) == true ? "true" : "false"); | |
358 | } else if (s == t_char) { | |
359 | printf("'%c'", pop(char)); | |
360 | } else if (s->symvalue.rangev.upper == 0 and | |
361 | s->symvalue.rangev.lower > 0) { | |
362 | switch (s->symvalue.rangev.lower) { | |
363 | case sizeof(float): | |
364 | prtreal(pop(float)); | |
365 | break; | |
366 | ||
367 | case sizeof(double): | |
368 | prtreal(pop(double)); | |
369 | break; | |
370 | ||
371 | default: | |
372 | panic("bad real size %d", s->symvalue.rangev.lower); | |
373 | break; | |
374 | } | |
375 | } else if (s->symvalue.rangev.lower >= 0) { | |
376 | printf("%lu", popsmall(s)); | |
377 | } else { | |
378 | printf("%ld", popsmall(s)); | |
379 | } | |
380 | break; | |
381 | ||
382 | case FILET: | |
383 | case PTR: { | |
384 | Address addr; | |
385 | ||
386 | addr = pop(Address); | |
387 | if (addr == 0) { | |
388 | printf("0, (nil)"); | |
389 | } else { | |
390 | printf("0x%x, 0%o", addr, addr); | |
391 | } | |
392 | break; | |
393 | } | |
394 | ||
395 | case FIELD: | |
396 | error("missing record specification"); | |
397 | break; | |
398 | ||
399 | case SCAL: { | |
400 | int scalar; | |
401 | Boolean found; | |
402 | ||
403 | scalar = popsmall(s); | |
404 | found = false; | |
405 | for (t = s->chain; t != nil; t = t->chain) { | |
406 | if (t->symvalue.iconval == scalar) { | |
407 | printf("%s", symname(t)); | |
408 | found = true; | |
409 | break; | |
410 | } | |
411 | } | |
412 | if (not found) { | |
413 | printf("(scalar = %d)", scalar); | |
414 | } | |
415 | break; | |
416 | } | |
417 | ||
418 | case FPROC: | |
419 | case FFUNC: | |
420 | { | |
421 | Address a; | |
422 | ||
423 | a = fparamaddr(pop(long)); | |
424 | t = whatblock(a); | |
425 | if (t == nil) { | |
426 | printf("(proc %d)", a); | |
427 | } else { | |
428 | printf("%s", symname(t)); | |
429 | } | |
430 | break; | |
431 | } | |
432 | ||
433 | default: | |
434 | if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) { | |
435 | panic("printval: bad class %d", ord(s->class)); | |
436 | } | |
437 | error("don't know how to print a %s", classname(s)); | |
438 | /* NOTREACHED */ | |
439 | } | |
440 | } |