![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pascal.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / dbx|
Return to pascal.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / dbx |
1.1 root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.