/* Copyright (c) 1982 Regents of the University of California */ static char sccsid[] = "@(#)pascal.c 1.2 12/15/82"; static char rcsid[] = "$Header: pascal.c,v 1.3 84/03/27 10:23:04 linton Exp $"; /* * 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 private Language pasc; /* * Initialize Pascal information. */ public pascal_init() { pasc = language_define("pascal", ".p"); language_setop(pasc, L_PRINTDECL, pascal_printdecl); language_setop(pasc, L_PRINTVAL, pascal_printval); language_setop(pasc, L_TYPEMATCH, pascal_typematch); language_setop(pasc, L_BUILDAREF, pascal_buildaref); language_setop(pasc, L_EVALAREF, pascal_evalaref); language_setop(pasc, L_MODINIT, pascal_modinit); language_setop(pasc, L_HASMODULES, pascal_hasmodules); language_setop(pasc, L_PASSADDR, pascal_passaddr); initTypes(); } /* * 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 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); } 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->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; switch (s->class) { case CONST: case TYPE: case VAR: case REF: case FVAR: case TAG: case FIELD: pascal_printval(s->type); break; case ARRAY: t = rtype(s->type); if (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: 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 or istypename(s,"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 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 */ } } /* * 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; r = a; t = rtype(a->nodetype); eltype = t->type; if (t->class != ARRAY) { beginerrmsg(); prtree(stderr, a); fprintf(stderr, " is not an array"); enderrmsg(); } else { 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 int pascal_evalaref (s, i) Symbol s; long i; { long lb, ub; s = rtype(rtype(s)->chain); lb = s->symvalue.rangev.lower; ub = s->symvalue.rangev.upper; if (i < lb or i > ub) { error("subscript %d out of range [%d..%d]", i, lb, ub); } return (i - lb); } /* * Initial Pascal type information. */ #define NTYPES 4 private Symbol inittype[NTYPES]; private integer count; private addType (s, lower, upper) String s; long lower, upper; { register Symbol t; if (count > NTYPES) { panic("too many initial types"); } t = maketype(s, lower, upper); t->language = pasc; inittype[count] = t; ++count; } private initTypes () { count = 1; addType("integer", 0x80000000L, 0x7fffffffL); addType("char", 0L, 255L); addType("boolean", 0L, 1L); addType("real", 4L, 0L); } /* * Initialize typetable. */ public pascal_modinit (typetable) Symbol typetable[]; { register integer i; 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; }