[unix-history] / usr / src / old / dbx / pascal.c

/* Copyright (c) 1982 Regents of the University of California */

static char sccsid[] = "@(#)pascal.c 1.2 %G%";

/*
 * Pascal-dependent symbol routines.
 */

#include "defs.h"
#include "symbols.h"
#include "pascal.h"
#include "languages.h"
#include "tree.h"
#include "eval.h"
#include "mappings.h"
#include "process.h"
#include "runtime.h"
#include "machine.h"

#ifndef public
#endif

/*
 * Initialize Pascal information.
 */

public pascal_init()
{
    Language lang;

    lang = language_define("pascal", ".p");
    language_setop(lang, L_PRINTDECL, pascal_printdecl);
    language_setop(lang, L_PRINTVAL, pascal_printval);
    language_setop(lang, L_TYPEMATCH, pascal_typematch);
}

/*
 * Compatible tests if two types are compatible.  The issue
 * is complicated a bit by ranges.
 *
 * Integers and reals are not compatible since they cannot always be mixed.
 */

public Boolean pascal_typematch(type1, type2)
Symbol type1, type2;
{
    Boolean b;
    register Symbol t1, t2;

    t1 = rtype(t1);
    t2 = rtype(t2);
    b = (Boolean)
	(t1->type == t2->type and (
	    (t1->class == RANGE and t2->class == RANGE) or
	    (t1->class == SCAL and t2->class == CONST) or
	    (t1->class == CONST and t2->class == SCAL) or
	    (t1->type == t_char and t1->class == ARRAY and t2->class == ARRAY)
	) or
	(t1 == t_nil and t2->class == PTR) or
	(t1->class == PTR and t2 == t_nil)
    );
    return b;
}

public pascal_printdecl(s)
Symbol s;
{
    register Symbol t;
    Boolean semicolon;

    semicolon = true;
    switch (s->class) {
	case CONST:
	    if (s->type->class == SCAL) {
		printf("(enumeration constant, ord %ld)",
		    s->symvalue.iconval);
	    } else {
		printf("const %s = ", symname(s));
		printval(s);
	    }
	    break;

	case TYPE:
	    printf("type %s = ", symname(s));
	    printtype(s, s->type);
	    break;

	case VAR:
	    if (isparam(s)) {
		printf("(parameter) %s : ", symname(s));
	    } else {
		printf("var %s : ", symname(s));
	    }
	    printtype(s, s->type);
	    break;

	case REF:
	    printf("(var parameter) %s : ", symname(s));
	    printtype(s, s->type);
	    break;

	case RANGE:
	case ARRAY:
	case RECORD:
	case VARNT:
	case PTR:
	    printtype(s, s);
	    semicolon = false;
	    break;

	case FVAR:
	    printf("(function variable) %s : ", symname(s));
	    printtype(s, s->type);
	    break;

	case FIELD:
	    printf("(field) %s : ", symname(s));
	    printtype(s, s->type);
	    break;

	case PROC:
	    printf("procedure %s", symname(s));
	    listparams(s);
	    break;

	case PROG:
	    printf("program %s", symname(s));
	    t = s->chain;
	    if (t != nil) {
		printf("(%s", symname(t));
		for (t = t->chain; t != nil; t = t->chain) {
		    printf(", %s", symname(t));
		}
		printf(")");
	    }
	    break;

	case FUNC:
	    printf("function %s", symname(s));
	    listparams(s);
	    printf(" : ");
	    printtype(s, s->type);
	    break;

	default:
	    error("class %s in printdecl", classname(s));
    }
    if (semicolon) {
	putchar(';');
    }
    putchar('\n');
}

/*
 * Recursive whiz-bang procedure to print the type portion
 * of a declaration.  Doesn't work quite right for variant records.
 *
 * The symbol associated with the type is passed to allow
 * searching for type names without getting "type blah = blah".
 */

private printtype(s, t)
Symbol s;
Symbol t;
{
    register Symbol tmp;

    switch (t->class) {
	case VAR:
	case CONST:
	case FUNC:
	case PROC:
	    panic("printtype: class %s", classname(t));
	    break;

	case ARRAY:
	    printf("array[");
	    tmp = t->chain;
	    if (tmp != nil) {
		for (;;) {
		    printtype(tmp, tmp);
		    tmp = tmp->chain;
		    if (tmp == nil) {
			break;
		    }
		    printf(", ");
		}
	    }
	    printf("] of ");
	    printtype(t, t->type);
	    break;

	case RECORD:
	    printf("record\n");
	    if (t->chain != nil) {
		printtype(t->chain, t->chain);
	    }
	    printf("end");
	    break;

	case FIELD:
	    if (t->chain != nil) {
		printtype(t->chain, t->chain);
	    }
	    printf("\t%s : ", symname(t));
	    printtype(t, t->type);
	    printf(";\n");
	    break;

	case RANGE: {
	    long r0, r1;

	    r0 = t->symvalue.rangev.lower;
	    r1 = t->symvalue.rangev.upper;
	    if (t == t_char) {
		if (r0 < 0x20 or r0 > 0x7e) {
		    printf("%ld..", r0);
		} else {
		    printf("'%c'..", (char) r0);
		}
		if (r1 < 0x20 or r1 > 0x7e) {
		    printf("\\%lo", r1);
		} else {
		    printf("'%c'", (char) r1);
		}
	    } else if (r0 > 0 and r1 == 0) {
		printf("%ld byte real", r0);
	    } else if (r0 >= 0) {
		printf("%lu..%lu", r0, r1);
	    } else {
		printf("%ld..%ld", r0, r1);
	    }
	    break;
	}

	case PTR:
	    putchar('*');
	    printtype(t, t->type);
	    break;

	case TYPE:
	    if (symname(t) != nil) {
		printf("%s", symname(t));
	    } else {
		printtype(t, t->type);
	    }
	    break;

	case SCAL:
	    printf("(");
	    t = t->type->chain;
	    if (t != nil) {
		printf("%s", symname(t));
		t = t->chain;
		while (t != nil) {
		    printf(", %s", symname(t));
		    t = t->chain;
		}
	    } else {
		panic("empty enumeration");
	    }
	    printf(")");
	    break;

	default:
	    printf("(class %d)", t->class);
	    break;
    }
}

/*
 * List the parameters of a procedure or function.
 * No attempt is made to combine like types.
 */

private listparams(s)
Symbol s;
{
    Symbol t;

    if (s->chain != nil) {
	putchar('(');
	for (t = s->chain; t != nil; t = t->chain) {
	    switch (t->class) {
		case REF:
		    printf("var ");
		    break;

		case FPROC:
		    printf("procedure ");
		    break;

		case FFUNC:
		    printf("function ");
		    break;

		case VAR:
		    break;

		default:
		    panic("unexpected class %d for parameter", t->class);
	    }
	    printf("%s : ", symname(t));
	    printtype(t, t->type);
	    if (t->chain != nil) {
		printf("; ");
	    }
	}
	putchar(')');
    }
}

/*
 * Print out the value on the top of the expression stack
 * in the format for the type of the given symbol.
 */

public pascal_printval(s)
Symbol s;
{
    Symbol t;
    Address a;
    int len;
    double r;

    if (s->class == REF) {
	s = s->type;
    }
    switch (s->class) {
	case TYPE:
	    pascal_printval(s->type);
	    break;

	case ARRAY:
	    t = rtype(s->type);
	    if (t==t_char or (t->class==RANGE and t->type==t_char)) {
		len = size(s);
		sp -= len;
		printf("'%.*s'", len, sp);
		break;
	    } else {
		printarray(s);
	    }
	    break;

	case RECORD:
	    printrecord(s);
	    break;

	case VARNT:
	    error("can't print out variant records");
	    break;


	case RANGE:
	    if (s == t_boolean) {
		printf(((Boolean) popsmall(s)) == true ? "true" : "false");
	    } else if (s == t_char) {
		printf("'%c'", pop(char));
	    } else if (s->symvalue.rangev.upper == 0 and
			s->symvalue.rangev.lower > 0) {
		switch (s->symvalue.rangev.lower) {
		    case sizeof(float):
			prtreal(pop(float));
			break;

		    case sizeof(double):
			prtreal(pop(double));
			break;

		    default:
			panic("bad real size %d", s->symvalue.rangev.lower);
			break;
		}
	    } else if (s->symvalue.rangev.lower >= 0) {
		printf("%lu", popsmall(s));
	    } else {
		printf("%ld", popsmall(s));
	    }
	    break;

	case FILET:
	case PTR: {
	    Address addr;

	    addr = pop(Address);
	    if (addr == 0) {
		printf("0, (nil)");
	    } else {
		printf("0x%x, 0%o", addr, addr);
	    }
	    break;
	}

	case FIELD:
	    error("missing record specification");
	    break;

	case SCAL: {
	    int scalar;
	    Boolean found;

	    scalar = popsmall(s);
	    found = false;
	    for (t = s->chain; t != nil; t = t->chain) {
		if (t->symvalue.iconval == scalar) {
		    printf("%s", symname(t));
		    found = true;
		    break;
		}
	    }
	    if (not found) {
		printf("(scalar = %d)", scalar);
	    }
	    break;
	}

	case FPROC:
	case FFUNC:
	{
	    Address a;

	    a = fparamaddr(pop(long));
	    t = whatblock(a);
	    if (t == nil) {
		printf("(proc %d)", a);
	    } else {
		printf("%s", symname(t));
	    }
	    break;
	}

	default:
	    if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
		panic("printval: bad class %d", ord(s->class));
	    }
	    error("don't know how to print a %s", classname(s));
	    /* NOTREACHED */
    }
}
Commit	Line	Data
5214d9da ML	1	/* Copyright (c) 1982 Regents of the University of California */
5214d9da ML	2
550fe947	3	static char sccsid[] = "@(#)pascal.c 1.2 %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
	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	}