pascal.c

<B>Digital的Unix操作系统VAX 4.2源码</B>

/*
 * Print out the declaration of a range type.
 */

private printRangeDecl (t)
Symbol t;
{
    long r0, r1;

    r0 = t->symvalue.rangev.lower;
    r1 = t->symvalue.rangev.upper;
    if (t == t_char or istypename(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);
    }
}

/*
 * Print out an enumeration declaration.
 */

private printEnumDecl (e, n)
Symbol e;
int n;
{
    Symbol t;

    printf("(");
    t = e->chain;
    if (t != nil) {
	printf("%s", symname(t));
	t = t->chain;
	while (t != nil) {
	    printf(", %s", symname(t));
	    t = t->chain;
	}
    }
    printf(")");
}

/*
 * 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 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;
{
    prval(s, size(s));
}

private prval (s, n)
Symbol s;
integer n;
{
    Symbol t;
    Address a;
    integer len;
    double r;
    integer i;

    if (s->class == TYPEREF) {
	resolveRef(s);
    }
    switch (s->class) {
	case CONST:
	case TYPE:
	case REF:
	case VAR:
	case FVAR:
	case TAG:
	    prval(s->type, n);
	    break;

	case FIELD:
		prval(s->type, n);
	    break;

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

	case RECORD:
	    printrecord(s);
	    break;

	case VARNT:
	    printf("[variant]");
	    break;

	case RANGE:
	    printrange(s, n);
	    break;

	case FILET:
	    a = pop(Address);
	    if (a == 0) {
		printf("nil");
	    } else {
		printf("0x%x", a);
	    }
	    break;

	case PTR:
	    a = pop(Address);
	    if (a == 0) {
		printf("nil");
	    } else {
		printf("0x%x", a);
	    }
	    break;

	case SCAL:
	    i = 0;
	    popn(n, &i);
	    if (s->symvalue.iconval < 256) {
		i &= 0xff;
	    } else if (s->symvalue.iconval < 65536) {
		i &= 0xffff;
	    }
	    printEnum(i, s);
	    break;

	case FPROC:
	case FFUNC:
	    a = pop(long);
	    t = whatblock(a);
	    if (t == nil) {
		printf("(proc 0x%x)", a);
	    } else {
		printf("%s", symname(t));
	    }
	    break;

	case SET:
	    printSet(s);
	    break;

	default:
	    if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
		panic("printval: bad class %d", ord(s->class));
	    }
	    printf("[%s]", classname(s));
	    break;
    }
}

/*
 * Print out the value of a scalar (non-enumeration) type.
 */

private printrange (s, n)
Symbol s;
integer n;
{
    double d;
    float f;
    integer i;

    if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
	if (n == sizeof(float)) {
	    popn(n, &f);
	    d = f;
	} else {
	    popn(n, &d);
	}
	prtreal(d);
    } else {
	i = 0;
	popn(n, &i);
	printRangeVal(i, s);
    }
}

/*
 * Print out a set.
 */

private printSet (s)
Symbol s;
{
    Symbol t;
    integer nbytes;

    nbytes = size(s);
    t = rtype(s->type);
    printf("[");
    sp -= nbytes;
    if (t->class == SCAL) {
	printSetOfEnum(t);
    } else if (t->class == RANGE) {
	printSetOfRange(t);
    } else {
	error("internal error: expected range or enumerated base type for set");
    }
    printf("]");
}

/*
 * Print out a set of an enumeration.
 */

private printSetOfEnum (t)
Symbol t;
{
    register Symbol e;
    register integer i, j, *p;
    boolean first;

    p = (int *) sp;
    i = *p;
    j = 0;
    e = t->chain;
    first = true;
    while (e != nil) {
	if ((i&1) == 1) {
	    if (first) {
		first = false;
		printf("%s", symname(e));
	    } else {
		printf(", %s", symname(e));
	    }
	}
	i >>= 1;
	++j;
	if (j >= sizeof(integer)*BITSPERBYTE) {
	    j = 0;
	    ++p;
	    i = *p;
	}
	e = e->chain;
    }
}

/*
 * Print out a set of a subrange type.
 */

private printSetOfRange (t)
Symbol t;
{
    register integer i, j, *p;
    long v;
    boolean first;

    p = (int *) sp;
    i = *p;
    j = 0;
    v = t->symvalue.rangev.lower;
    first = true;
    while (v <= t->symvalue.rangev.upper) {
	if ((i&1) == 1) {
	    if (first) {
		first = false;
		printf("%ld", v);
	    } else {
		printf(", %ld", v);
	    }
	}
	i >>= 1;
	++j;
	if (j >= sizeof(integer)*BITSPERBYTE) {
	    j = 0;
	    ++p;
	    i = *p;
	}
	++v;
    }
}

/*
 * Construct a node for subscripting.
 */

public Node pascal_buildaref (a, slist)
Node a, slist;
{
    register Symbol t;
    register Node p;
    Symbol etype, atype, eltype;
    Node esub, r;

    t = rtype(a->nodetype);
    if (t->class != ARRAY) {
	beginerrmsg();
	prtree(stderr, a);
	fprintf(stderr, " is not an array");
	enderrmsg();
    } else {
	r = a;
	eltype = t->type;
	p = slist;
	t = t->chain;
	for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) {
	    esub = p->value.arg[0];
	    etype = rtype(esub->nodetype);
	    atype = rtype(t);
	    if (not compatible(atype, etype)) {
		beginerrmsg();
		fprintf(stderr, "subscript ");
		prtree(stderr, esub);
		fprintf(stderr, " is the wrong type");
		enderrmsg();
	    }
	    r = build(O_INDEX, r, esub);
	    r->nodetype = eltype;
	}
	if (p != nil or t != nil) {
	    beginerrmsg();
	    if (p != nil) {
		fprintf(stderr, "too many subscripts for ");
	    } else {
		fprintf(stderr, "not enough subscripts for ");
	    }
	    prtree(stderr, a);
	    enderrmsg();
	}
    }
    return r;
}

/*
 * Evaluate a subscript index.
 */

public pascal_evalaref (s, base, i)
Symbol s;
Address base;
long i;
{
    Symbol t;
    long lb, ub;

    t = rtype(s);
    s = rtype(t->chain);
    findbounds(s, &lb, &ub);
    if (i < lb or i > ub) {
	error("subscript %d out of range [%d..%d]", i, lb, ub);
    }
    push(long, base + (i - lb) * size(t->type));
}

/*
 * Initial Pascal type information.
 */

#define NTYPES 4

private Symbol inittype[NTYPES + 1];

private addType (n, s, lower, upper)
integer n;
String s;
long lower, upper;
{
    register Symbol t;

    if (n > NTYPES) {
	panic("initial Pascal type number too large for '%s'", s);
    }
    t = insert(identname(s, true));
    t->language = pasc;
    t->class = TYPE;
    t->type = newSymbol(nil, 0, RANGE, t, nil);
    t->type->symvalue.rangev.lower = lower;
    t->type->symvalue.rangev.upper = upper;
    t->type->language = pasc;
    inittype[n] = t;
}

private initTypes ()
{
    addType(1, "boolean", 0L, 1L);
    addType(2, "char", 0L, 255L);
    addType(3, "integer", 0x80000000L, 0x7fffffffL);
    addType(4, "real", 8L, 0L);
    initialized = true;
}

/*
 * Initialize typetable.
 */

public pascal_modinit (typetable)
Symbol typetable[];
{
    register integer i;

    if (not initialized) {
	initTypes();
	initialized = true;
    }
    for (i = 1; i <= NTYPES; i++) {
	typetable[i] = inittype[i];
    }
}

public boolean pascal_hasmodules ()
{
    return false;
}

public boolean pascal_passaddr (param, exprtype)
Symbol param, exprtype;
{
    return false;
}

public Node pascal_printf(p, argv)
Node p;
char **argv;
{
	return p;
}