xref: /csrg-svn/old/dbx/pascal.c (revision 16633) 
1 /* Copyright (c) 1982 Regents of the University of California */
2 
3 static	char sccsid[] = "@(#)pascal.c	1.3 (Berkeley) 06/23/84";
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 private Language pasc;
24 
25 /*
26  * Initialize Pascal information.
27  */
28 
29 public pascal_init()
30 {
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();
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;
221 	    if (t == t_char or istypename(t,"char")) {
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("(");
257 	    t = t->chain;
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 
332     switch (s->class) {
333 	case CONST:
334 	case TYPE:
335 	case VAR:
336 	case REF:
337 	case FVAR:
338 	case TAG:
339 	case FIELD:
340 	    pascal_printval(s->type);
341 	    break;
342 
343 	case ARRAY:
344 	    t = rtype(s->type);
345 	    if (t->class==RANGE and istypename(t->type,"char")) {
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");
367 	    } else if (s == t_char or istypename(s,"char")) {
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 
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 }
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 }
575