xref: /original-bsd/old/dbx/pascal.c (revision f0fd5f8a) 
1 /* Copyright (c) 1982 Regents of the University of California */
2 
3 static char sccsid[] = "@(#)pascal.c 1.2 12/15/82";
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 }
441