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