Commit | Line | Data |
---|---|---|
5214d9da ML |
1 | /* Copyright (c) 1982 Regents of the University of California */ |
2 | ||
e1f4dbca | 3 | static char sccsid[] = "@(#)pascal.c 1.3 (Berkeley) %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 | ||
2fd0f574 SL |
23 | private Language pasc; |
24 | ||
5214d9da ML |
25 | /* |
26 | * Initialize Pascal information. | |
27 | */ | |
28 | ||
29 | public pascal_init() | |
30 | { | |
2fd0f574 SL |
31 | pasc = language_define("pascal", ".p"); |
32 | language_setop(pasc, L_PRINTDECL, pascal_printdecl); | |
33 | language_setop(pasc, L_PRINTVAL, pascal_printval); | |
34 | language_setop(pasc, L_TYPEMATCH, pascal_typematch); | |
35 | language_setop(pasc, L_BUILDAREF, pascal_buildaref); | |
36 | language_setop(pasc, L_EVALAREF, pascal_evalaref); | |
37 | language_setop(pasc, L_MODINIT, pascal_modinit); | |
38 | language_setop(pasc, L_HASMODULES, pascal_hasmodules); | |
39 | language_setop(pasc, L_PASSADDR, pascal_passaddr); | |
40 | initTypes(); | |
5214d9da ML |
41 | } |
42 | ||
43 | /* | |
44 | * Compatible tests if two types are compatible. The issue | |
45 | * is complicated a bit by ranges. | |
46 | * | |
47 | * Integers and reals are not compatible since they cannot always be mixed. | |
48 | */ | |
49 | ||
50 | public Boolean pascal_typematch(type1, type2) | |
51 | Symbol type1, type2; | |
52 | { | |
53 | Boolean b; | |
54 | register Symbol t1, t2; | |
55 | ||
56 | t1 = rtype(t1); | |
57 | t2 = rtype(t2); | |
58 | b = (Boolean) | |
59 | (t1->type == t2->type and ( | |
60 | (t1->class == RANGE and t2->class == RANGE) or | |
61 | (t1->class == SCAL and t2->class == CONST) or | |
62 | (t1->class == CONST and t2->class == SCAL) or | |
63 | (t1->type == t_char and t1->class == ARRAY and t2->class == ARRAY) | |
64 | ) or | |
65 | (t1 == t_nil and t2->class == PTR) or | |
66 | (t1->class == PTR and t2 == t_nil) | |
67 | ); | |
68 | return b; | |
69 | } | |
70 | ||
71 | public pascal_printdecl(s) | |
72 | Symbol s; | |
73 | { | |
74 | register Symbol t; | |
75 | Boolean semicolon; | |
76 | ||
77 | semicolon = true; | |
78 | switch (s->class) { | |
79 | case CONST: | |
80 | if (s->type->class == SCAL) { | |
81 | printf("(enumeration constant, ord %ld)", | |
82 | s->symvalue.iconval); | |
83 | } else { | |
84 | printf("const %s = ", symname(s)); | |
85 | printval(s); | |
86 | } | |
87 | break; | |
88 | ||
89 | case TYPE: | |
90 | printf("type %s = ", symname(s)); | |
91 | printtype(s, s->type); | |
92 | break; | |
93 | ||
94 | case VAR: | |
95 | if (isparam(s)) { | |
96 | printf("(parameter) %s : ", symname(s)); | |
97 | } else { | |
98 | printf("var %s : ", symname(s)); | |
99 | } | |
100 | printtype(s, s->type); | |
101 | break; | |
102 | ||
103 | case REF: | |
104 | printf("(var parameter) %s : ", symname(s)); | |
105 | printtype(s, s->type); | |
106 | break; | |
107 | ||
108 | case RANGE: | |
109 | case ARRAY: | |
110 | case RECORD: | |
111 | case VARNT: | |
112 | case PTR: | |
113 | printtype(s, s); | |
114 | semicolon = false; | |
115 | break; | |
116 | ||
117 | case FVAR: | |
118 | printf("(function variable) %s : ", symname(s)); | |
119 | printtype(s, s->type); | |
120 | break; | |
121 | ||
122 | case FIELD: | |
123 | printf("(field) %s : ", symname(s)); | |
124 | printtype(s, s->type); | |
125 | break; | |
126 | ||
127 | case PROC: | |
128 | printf("procedure %s", symname(s)); | |
129 | listparams(s); | |
130 | break; | |
131 | ||
132 | case PROG: | |
133 | printf("program %s", symname(s)); | |
134 | t = s->chain; | |
135 | if (t != nil) { | |
136 | printf("(%s", symname(t)); | |
137 | for (t = t->chain; t != nil; t = t->chain) { | |
138 | printf(", %s", symname(t)); | |
139 | } | |
140 | printf(")"); | |
141 | } | |
142 | break; | |
143 | ||
144 | case FUNC: | |
145 | printf("function %s", symname(s)); | |
146 | listparams(s); | |
147 | printf(" : "); | |
148 | printtype(s, s->type); | |
149 | break; | |
150 | ||
151 | default: | |
152 | error("class %s in printdecl", classname(s)); | |
153 | } | |
154 | if (semicolon) { | |
155 | putchar(';'); | |
156 | } | |
157 | putchar('\n'); | |
158 | } | |
159 | ||
160 | /* | |
161 | * Recursive whiz-bang procedure to print the type portion | |
162 | * of a declaration. Doesn't work quite right for variant records. | |
163 | * | |
164 | * The symbol associated with the type is passed to allow | |
165 | * searching for type names without getting "type blah = blah". | |
166 | */ | |
167 | ||
168 | private printtype(s, t) | |
169 | Symbol s; | |
170 | Symbol t; | |
171 | { | |
172 | register Symbol tmp; | |
173 | ||
174 | switch (t->class) { | |
175 | case VAR: | |
176 | case CONST: | |
177 | case FUNC: | |
178 | case PROC: | |
179 | panic("printtype: class %s", classname(t)); | |
180 | break; | |
181 | ||
182 | case ARRAY: | |
183 | printf("array["); | |
184 | tmp = t->chain; | |
185 | if (tmp != nil) { | |
186 | for (;;) { | |
187 | printtype(tmp, tmp); | |
188 | tmp = tmp->chain; | |
189 | if (tmp == nil) { | |
190 | break; | |
191 | } | |
192 | printf(", "); | |
193 | } | |
194 | } | |
195 | printf("] of "); | |
196 | printtype(t, t->type); | |
197 | break; | |
198 | ||
199 | case RECORD: | |
200 | printf("record\n"); | |
201 | if (t->chain != nil) { | |
202 | printtype(t->chain, t->chain); | |
203 | } | |
204 | printf("end"); | |
205 | break; | |
206 | ||
207 | case FIELD: | |
208 | if (t->chain != nil) { | |
209 | printtype(t->chain, t->chain); | |
210 | } | |
211 | printf("\t%s : ", symname(t)); | |
212 | printtype(t, t->type); | |
213 | printf(";\n"); | |
214 | break; | |
215 | ||
216 | case RANGE: { | |
217 | long r0, r1; | |
218 | ||
219 | r0 = t->symvalue.rangev.lower; | |
220 | r1 = t->symvalue.rangev.upper; | |
2fd0f574 | 221 | if (t == t_char or istypename(t,"char")) { |
5214d9da ML |
222 | if (r0 < 0x20 or r0 > 0x7e) { |
223 | printf("%ld..", r0); | |
224 | } else { | |
225 | printf("'%c'..", (char) r0); | |
226 | } | |
227 | if (r1 < 0x20 or r1 > 0x7e) { | |
228 | printf("\\%lo", r1); | |
229 | } else { | |
230 | printf("'%c'", (char) r1); | |
231 | } | |
232 | } else if (r0 > 0 and r1 == 0) { | |
233 | printf("%ld byte real", r0); | |
234 | } else if (r0 >= 0) { | |
235 | printf("%lu..%lu", r0, r1); | |
236 | } else { | |
237 | printf("%ld..%ld", r0, r1); | |
238 | } | |
239 | break; | |
240 | } | |
241 | ||
242 | case PTR: | |
243 | putchar('*'); | |
244 | printtype(t, t->type); | |
245 | break; | |
246 | ||
247 | case TYPE: | |
248 | if (symname(t) != nil) { | |
249 | printf("%s", symname(t)); | |
250 | } else { | |
251 | printtype(t, t->type); | |
252 | } | |
253 | break; | |
254 | ||
255 | case SCAL: | |
256 | printf("("); | |
2fd0f574 | 257 | t = t->chain; |
5214d9da ML |
258 | if (t != nil) { |
259 | printf("%s", symname(t)); | |
260 | t = t->chain; | |
261 | while (t != nil) { | |
262 | printf(", %s", symname(t)); | |
263 | t = t->chain; | |
264 | } | |
265 | } else { | |
266 | panic("empty enumeration"); | |
267 | } | |
268 | printf(")"); | |
269 | break; | |
270 | ||
271 | default: | |
272 | printf("(class %d)", t->class); | |
273 | break; | |
274 | } | |
275 | } | |
276 | ||
277 | /* | |
278 | * List the parameters of a procedure or function. | |
279 | * No attempt is made to combine like types. | |
280 | */ | |
281 | ||
282 | private listparams(s) | |
283 | Symbol s; | |
284 | { | |
285 | Symbol t; | |
286 | ||
287 | if (s->chain != nil) { | |
288 | putchar('('); | |
289 | for (t = s->chain; t != nil; t = t->chain) { | |
290 | switch (t->class) { | |
291 | case REF: | |
292 | printf("var "); | |
293 | break; | |
294 | ||
295 | case FPROC: | |
296 | printf("procedure "); | |
297 | break; | |
298 | ||
299 | case FFUNC: | |
300 | printf("function "); | |
301 | break; | |
302 | ||
303 | case VAR: | |
304 | break; | |
305 | ||
306 | default: | |
307 | panic("unexpected class %d for parameter", t->class); | |
308 | } | |
309 | printf("%s : ", symname(t)); | |
310 | printtype(t, t->type); | |
311 | if (t->chain != nil) { | |
312 | printf("; "); | |
313 | } | |
314 | } | |
315 | putchar(')'); | |
316 | } | |
317 | } | |
318 | ||
319 | /* | |
320 | * Print out the value on the top of the expression stack | |
321 | * in the format for the type of the given symbol. | |
322 | */ | |
323 | ||
324 | public pascal_printval(s) | |
325 | Symbol s; | |
326 | { | |
327 | Symbol t; | |
328 | Address a; | |
329 | int len; | |
330 | double r; | |
331 | ||
5214d9da | 332 | switch (s->class) { |
2fd0f574 | 333 | case CONST: |
5214d9da | 334 | case TYPE: |
2fd0f574 SL |
335 | case VAR: |
336 | case REF: | |
337 | case FVAR: | |
338 | case TAG: | |
339 | case FIELD: | |
5214d9da ML |
340 | pascal_printval(s->type); |
341 | break; | |
342 | ||
343 | case ARRAY: | |
344 | t = rtype(s->type); | |
2fd0f574 | 345 | if (t->class==RANGE and istypename(t->type,"char")) { |
5214d9da ML |
346 | len = size(s); |
347 | sp -= len; | |
348 | printf("'%.*s'", len, sp); | |
349 | break; | |
350 | } else { | |
351 | printarray(s); | |
352 | } | |
353 | break; | |
354 | ||
355 | case RECORD: | |
356 | printrecord(s); | |
357 | break; | |
358 | ||
359 | case VARNT: | |
360 | error("can't print out variant records"); | |
361 | break; | |
362 | ||
363 | ||
364 | case RANGE: | |
365 | if (s == t_boolean) { | |
366 | printf(((Boolean) popsmall(s)) == true ? "true" : "false"); | |
2fd0f574 | 367 | } else if (s == t_char or istypename(s,"char")) { |
5214d9da ML |
368 | printf("'%c'", pop(char)); |
369 | } else if (s->symvalue.rangev.upper == 0 and | |
370 | s->symvalue.rangev.lower > 0) { | |
371 | switch (s->symvalue.rangev.lower) { | |
372 | case sizeof(float): | |
373 | prtreal(pop(float)); | |
374 | break; | |
375 | ||
376 | case sizeof(double): | |
377 | prtreal(pop(double)); | |
378 | break; | |
379 | ||
380 | default: | |
381 | panic("bad real size %d", s->symvalue.rangev.lower); | |
382 | break; | |
383 | } | |
384 | } else if (s->symvalue.rangev.lower >= 0) { | |
385 | printf("%lu", popsmall(s)); | |
386 | } else { | |
387 | printf("%ld", popsmall(s)); | |
388 | } | |
389 | break; | |
390 | ||
391 | case FILET: | |
392 | case PTR: { | |
393 | Address addr; | |
394 | ||
395 | addr = pop(Address); | |
396 | if (addr == 0) { | |
397 | printf("0, (nil)"); | |
398 | } else { | |
399 | printf("0x%x, 0%o", addr, addr); | |
400 | } | |
401 | break; | |
402 | } | |
403 | ||
5214d9da ML |
404 | |
405 | case SCAL: { | |
406 | int scalar; | |
407 | Boolean found; | |
408 | ||
409 | scalar = popsmall(s); | |
410 | found = false; | |
411 | for (t = s->chain; t != nil; t = t->chain) { | |
412 | if (t->symvalue.iconval == scalar) { | |
413 | printf("%s", symname(t)); | |
414 | found = true; | |
415 | break; | |
416 | } | |
417 | } | |
418 | if (not found) { | |
419 | printf("(scalar = %d)", scalar); | |
420 | } | |
421 | break; | |
422 | } | |
423 | ||
424 | case FPROC: | |
425 | case FFUNC: | |
426 | { | |
427 | Address a; | |
428 | ||
429 | a = fparamaddr(pop(long)); | |
430 | t = whatblock(a); | |
431 | if (t == nil) { | |
432 | printf("(proc %d)", a); | |
433 | } else { | |
434 | printf("%s", symname(t)); | |
435 | } | |
436 | break; | |
437 | } | |
438 | ||
439 | default: | |
440 | if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) { | |
441 | panic("printval: bad class %d", ord(s->class)); | |
442 | } | |
443 | error("don't know how to print a %s", classname(s)); | |
444 | /* NOTREACHED */ | |
445 | } | |
446 | } | |
2fd0f574 SL |
447 | |
448 | /* | |
449 | * Construct a node for subscripting. | |
450 | */ | |
451 | ||
452 | public Node pascal_buildaref (a, slist) | |
453 | Node a, slist; | |
454 | { | |
455 | register Symbol t; | |
456 | register Node p; | |
457 | Symbol etype, atype, eltype; | |
458 | Node esub, r; | |
459 | ||
460 | r = a; | |
461 | t = rtype(a->nodetype); | |
462 | eltype = t->type; | |
463 | if (t->class != ARRAY) { | |
464 | beginerrmsg(); | |
465 | prtree(stderr, a); | |
466 | fprintf(stderr, " is not an array"); | |
467 | enderrmsg(); | |
468 | } else { | |
469 | p = slist; | |
470 | t = t->chain; | |
471 | for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) { | |
472 | esub = p->value.arg[0]; | |
473 | etype = rtype(esub->nodetype); | |
474 | atype = rtype(t); | |
475 | if (not compatible(atype, etype)) { | |
476 | beginerrmsg(); | |
477 | fprintf(stderr, "subscript "); | |
478 | prtree(stderr, esub); | |
479 | fprintf(stderr, " is the wrong type"); | |
480 | enderrmsg(); | |
481 | } | |
482 | r = build(O_INDEX, r, esub); | |
483 | r->nodetype = eltype; | |
484 | } | |
485 | if (p != nil or t != nil) { | |
486 | beginerrmsg(); | |
487 | if (p != nil) { | |
488 | fprintf(stderr, "too many subscripts for "); | |
489 | } else { | |
490 | fprintf(stderr, "not enough subscripts for "); | |
491 | } | |
492 | prtree(stderr, a); | |
493 | enderrmsg(); | |
494 | } | |
495 | } | |
496 | return r; | |
497 | } | |
498 | ||
499 | /* | |
500 | * Evaluate a subscript index. | |
501 | */ | |
502 | ||
503 | public int pascal_evalaref (s, i) | |
504 | Symbol s; | |
505 | long i; | |
506 | { | |
507 | long lb, ub; | |
508 | ||
509 | s = rtype(rtype(s)->chain); | |
510 | lb = s->symvalue.rangev.lower; | |
511 | ub = s->symvalue.rangev.upper; | |
512 | if (i < lb or i > ub) { | |
513 | error("subscript %d out of range [%d..%d]", i, lb, ub); | |
514 | } | |
515 | return (i - lb); | |
516 | } | |
517 | ||
518 | /* | |
519 | * Initial Pascal type information. | |
520 | */ | |
521 | ||
522 | #define NTYPES 4 | |
523 | ||
524 | private Symbol inittype[NTYPES]; | |
525 | private integer count; | |
526 | ||
527 | private addType (s, lower, upper) | |
528 | String s; | |
529 | long lower, upper; | |
530 | { | |
531 | register Symbol t; | |
532 | ||
533 | if (count > NTYPES) { | |
534 | panic("too many initial types"); | |
535 | } | |
536 | t = maketype(s, lower, upper); | |
537 | t->language = pasc; | |
538 | inittype[count] = t; | |
539 | ++count; | |
540 | } | |
541 | ||
542 | private initTypes () | |
543 | { | |
544 | count = 1; | |
545 | addType("integer", 0x80000000L, 0x7fffffffL); | |
546 | addType("char", 0L, 255L); | |
547 | addType("boolean", 0L, 1L); | |
548 | addType("real", 4L, 0L); | |
549 | } | |
550 | ||
551 | /* | |
552 | * Initialize typetable. | |
553 | */ | |
554 | ||
555 | public pascal_modinit (typetable) | |
556 | Symbol typetable[]; | |
557 | { | |
558 | register integer i; | |
559 | ||
560 | for (i = 1; i < NTYPES; i++) { | |
561 | typetable[i] = inittype[i]; | |
562 | } | |
563 | } | |
564 | ||
565 | public boolean pascal_hasmodules () | |
566 | { | |
567 | return false; | |
568 | } | |
569 | ||
570 | public boolean pascal_passaddr (param, exprtype) | |
571 | Symbol param, exprtype; | |
572 | { | |
573 | return false; | |
574 | } |