+ 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];
projects / unix-history / blobdiff