4.1cBSD/usr/src/ucb/dbx/pascal.c
/* Copyright (c) 1982 Regents of the University of California */
static char sccsid[] = "@(#)pascal.c 1.2 12/15/82";
/*
* 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 */
}
}