modula-2.c

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

public modula2_printval (s)
Symbol s;
{
    prval(s, size(s));
}

/*
 * Print out the value on the top of the expression stack
 * in the format for the type of the given symbol, assuming
 * the size of the object is n bytes.
 */

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:
	    if (isbitfield(s)) {
		i = 0;
		popn(size(s), &i);
		i >>= (s->symvalue.field.offset mod BITSPERBYTE);
		i &= ((1 << s->symvalue.field.length) - 1);
		t = rtype(s->type);
		if (t->class == SCAL) {
		    printEnum(i, t);
		} else {
		    printRangeVal(i, t);
		}
	    } else {
	    prval(s->type, n);
	    }
	    break;

	case ARRAY:
	    t = rtype(s->type);
	    if (ischar(t)) {
		len = size(s);
		sp -= len;
		printf("\"%.*s\"", len, sp);
		break;
	    } else {
		printarray(s);
	    }
	    break;

	case DYNARRAY:
	    printDynarray(s);
	    break;

	case SUBARRAY:
	    printSubarray(s);
	    break;

	case RECORD:
	    printrecord(s);
	    break;

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

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

	/*
	 * Unresolved opaque type.
	 * Probably a pointer.
	 */
	case TYPEREF:
	    a = pop(Address);
	    printf("@%x", a);
	    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 if (isCstring(s->type)) {
		printString(a, true);
	    } else {
		printf("0x%x", a);
	    }
	    break;

	case SCAL:
	    i = 0;
	    popn(n, &i);
	    printEnum(i, s);
		    break;

	case FPROC:
	case FFUNC:
	    a = pop(long);
	    t = whatblock(a);
	    if (t == nil) {
		printf("0x%x", a);
	    } else {
		printname(stdout, 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 a dynamic array.
 */

private Address printDynSlice();

private printDynarray (t)
Symbol t;
{
    Address base;
    integer n;
    Stack *savesp, *newsp;
    Symbol eltype;

    savesp = sp;
    sp -= (t->symvalue.ndims * sizeof(Word));
    base = pop(Address);
    newsp = sp;
    sp = savesp;
    eltype = rtype(t->type);
    if (t->symvalue.ndims == 0) {
	if (ischar(eltype)) {
	    printString(base, true);
	} else {
	    printf("[dynarray @nocount]");
	}
    } else {
	n = ((long *) sp)[-(t->symvalue.ndims)];
	base = printDynSlice(base, n, t->symvalue.ndims, eltype, size(eltype));
    }
    sp = newsp;
}

/*
 * Print out one dimension of a multi-dimension dynamic array.
 *
 * Return the address of the element that follows the printed elements.
 */

private Address printDynSlice (base, count, ndims, eltype, elsize)
Address base;
integer count, ndims;
Symbol eltype;
integer elsize;
{
    Address b;
    integer i, n;
    char *slice;
    Stack *savesp;

    b = base;
    if (ndims > 1) {
	n = ((long *) sp)[-ndims + 1];
    }
    if (ndims == 1 and ischar(eltype)) {
	slice = newarr(char, count);
	dread(slice, b, count);
	printf("\"%.*s\"", count, slice);
	dispose(slice);
	b += count;
    } else {
	printf("(");
	for (i = 0; i < count; i++) {
	    if (i != 0) {
		printf(", ");
	    }
	    if (ndims == 1) {
		slice = newarr(char, elsize);
		dread(slice, b, elsize);
		savesp = sp;
		sp = slice + elsize;
		printval(eltype);
		sp = savesp;
		dispose(slice);
		b += elsize;
	    } else {
		b = printDynSlice(b, n, ndims - 1, eltype, elsize);
	    }
	}
	printf(")");
    }
    return b;
}

private printSubarray (t)
Symbol t;
{
    printf("[subarray]");
}

/*
 * 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 {
	panic("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 a dynamic or subarray.
 * The list of indices is left for processing in evalaref,
 * unlike normal subscripting in which the list is expanded
 * across individual INDEX nodes.
 */

private Node dynref (a, t, slist)
Node a;
Symbol t;
Node slist;
{
    Node p, r;
    integer n;

    p = slist;
    n = 0;
    while (p != nil) {
	if (not compatible(p->value.arg[0]->nodetype, t_int)) {
	    suberror("subscript \"", p->value.arg[0], "\" is the wrong type");
	}
	++n;
	p = p->value.arg[1];
    }
    if (n > t->symvalue.ndims and (t->symvalue.ndims != 0 or n != 1)) {
	suberror("too many subscripts for ", a, nil);
    } else if (n < t->symvalue.ndims) {
	suberror("not enough subscripts for ", a, nil);
    }
    r = build(O_INDEX, a, slist);
    r->nodetype = rtype(t->type);
    return r;
}

/*
 * Construct a node for subscripting.
 */

public Node modula2_buildaref (a, slist)
Node a, slist;
{
    register Symbol t;
    register Node p;
    Symbol eltype;
    Node esub, r;
    integer n;

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

/*
 * Subscript usage error reporting.
 */

private suberror (s1, e1, s2)
String s1, s2;
Node e1;
{
    beginerrmsg();
    if (s1 != nil) {
	fprintf(stderr, s1);
    }
    if (e1 != nil) {
	prtree(stderr, e1);
    }
    if (s2 != nil) {
	fprintf(stderr, s2);
    }
	    enderrmsg();
}

/*
 * Check that a subscript value is in the appropriate range.
 */

private subchk (value, lower, upper)
long value, lower, upper;
{
    if (value < lower or value > upper) {
	error("subscript value %d out of range [%d..%d]", value, lower, upper);
	}
}

/*
 * Compute the offset for subscripting a dynamic array.
 */

private getdynoff (ndims, sub)
integer ndims;
long *sub;
{
    long k, off, *count;

    count = (long *) sp;
    off = 0;
    for (k = 0; k < ndims - 1; k++) {
	subchk(sub[k], 0, count[k] - 1);
	off += (sub[k] * count[k+1]);
    }
    subchk(sub[ndims - 1], 0, count[ndims - 1] - 1);
    return off + sub[ndims - 1];
}

/*
 * Compute the offset associated with a subarray.
 */

private getsuboff (ndims, sub)
integer ndims;
long *sub;
{
    long k, off;
    struct subarrayinfo {
	long count;
	long mult;
    } *info;

    info = (struct subarrayinfo *) sp;
    off = 0;
    for (k = 0; k < ndims; k++) {
	subchk(sub[k], 0, info[k].count - 1);
	off += sub[k] * info[k].mult;
    }
    return off;
}

/*
 * Evaluate a subscript index.
 */

public modula2_evalaref (s, base, i)
Symbol s;
Address base;
long i;
{
    Symbol t;
    long lb, ub, off;
    long *sub;
    Address b;

    t = rtype(s);
    if (t->class == ARRAY) {
	findbounds(rtype(t->chain), &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));
    } else if (t->class == DYNARRAY and t->symvalue.ndims == 0) {
	push(long, base + i * size(t->type));
    } else if (t->class == DYNARRAY or t->class == SUBARRAY) {
	push(long, i);
	sub = (long *) (sp - (t->symvalue.ndims * sizeof(long)));
	rpush(base, size(t));
	sp -= (t->symvalue.ndims * sizeof(long));
	b = pop(Address);
	sp += sizeof(Address);
	if (t->class == SUBARRAY) {
	    off = getsuboff(t->symvalue.ndims, sub);
	} else {
	    off = getdynoff(t->symvalue.ndims, sub);
	}
	sp = (Stack *) sub;
	push(long, b + off * size(t->type));
    } else {
	error("[internal error: expected array in evalaref]");
    }
}

/*
 * Initial Modula-2 type information.
 */

#define NTYPES 12

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 Modula-2 type number too large for '%s'", s);
    }
    t = insert(identname(s, true));
    t->language = mod2;
    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 = mod2;
    inittype[n] = t;
}

private initModTypes ()
{
    addType(1, "integer", 0x80000000L, 0x7fffffffL);
    addType(2, "char", 0L, 255L);
    addType(3, "boolean", 0L, 1L);
    addType(4, "unsigned", 0L, 0xffffffffL);
    addType(5, "real", 4L, 0L);
    addType(6, "longreal", 8L, 0L);
    addType(7, "word", 0L, 0xffffffffL);
    addType(8, "byte", 0L, 255L);
    addType(9, "address", 0L, 0xffffffffL);
    addType(10, "file", 0L, 0xffffffffL);
    addType(11, "process", 0L, 0xffffffffL);
    addType(12, "cardinal", 0L, 0x7fffffffL);
}

/*
 * Initialize typetable.
 */

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

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

public boolean modula2_hasmodules ()
{
    return true;
}

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