19675Slinton /* Copyright (c) 1982 Regents of the University of California */ 29675Slinton 3*9689Slinton static char sccsid[] = "@(#)pascal.c 1.2 12/15/82"; 49675Slinton 59675Slinton /* 69675Slinton * Pascal-dependent symbol routines. 79675Slinton */ 89675Slinton 99675Slinton #include "defs.h" 109675Slinton #include "symbols.h" 119675Slinton #include "pascal.h" 129675Slinton #include "languages.h" 139675Slinton #include "tree.h" 149675Slinton #include "eval.h" 159675Slinton #include "mappings.h" 169675Slinton #include "process.h" 179675Slinton #include "runtime.h" 189675Slinton #include "machine.h" 199675Slinton 209675Slinton #ifndef public 219675Slinton #endif 229675Slinton 239675Slinton /* 249675Slinton * Initialize Pascal information. 259675Slinton */ 269675Slinton 279675Slinton public pascal_init() 289675Slinton { 299675Slinton Language lang; 309675Slinton 319675Slinton lang = language_define("pascal", ".p"); 329675Slinton language_setop(lang, L_PRINTDECL, pascal_printdecl); 339675Slinton language_setop(lang, L_PRINTVAL, pascal_printval); 349675Slinton language_setop(lang, L_TYPEMATCH, pascal_typematch); 359675Slinton } 369675Slinton 379675Slinton /* 389675Slinton * Compatible tests if two types are compatible. The issue 399675Slinton * is complicated a bit by ranges. 409675Slinton * 419675Slinton * Integers and reals are not compatible since they cannot always be mixed. 429675Slinton */ 439675Slinton 449675Slinton public Boolean pascal_typematch(type1, type2) 459675Slinton Symbol type1, type2; 469675Slinton { 479675Slinton Boolean b; 489675Slinton register Symbol t1, t2; 499675Slinton 509675Slinton t1 = rtype(t1); 519675Slinton t2 = rtype(t2); 529675Slinton b = (Boolean) 539675Slinton (t1->type == t2->type and ( 549675Slinton (t1->class == RANGE and t2->class == RANGE) or 559675Slinton (t1->class == SCAL and t2->class == CONST) or 569675Slinton (t1->class == CONST and t2->class == SCAL) or 579675Slinton (t1->type == t_char and t1->class == ARRAY and t2->class == ARRAY) 589675Slinton ) or 599675Slinton (t1 == t_nil and t2->class == PTR) or 609675Slinton (t1->class == PTR and t2 == t_nil) 619675Slinton ); 629675Slinton return b; 639675Slinton } 649675Slinton 659675Slinton public pascal_printdecl(s) 669675Slinton Symbol s; 679675Slinton { 689675Slinton register Symbol t; 699675Slinton Boolean semicolon; 709675Slinton 719675Slinton semicolon = true; 729675Slinton switch (s->class) { 739675Slinton case CONST: 749675Slinton if (s->type->class == SCAL) { 759675Slinton printf("(enumeration constant, ord %ld)", 769675Slinton s->symvalue.iconval); 779675Slinton } else { 789675Slinton printf("const %s = ", symname(s)); 799675Slinton printval(s); 809675Slinton } 819675Slinton break; 829675Slinton 839675Slinton case TYPE: 849675Slinton printf("type %s = ", symname(s)); 859675Slinton printtype(s, s->type); 869675Slinton break; 879675Slinton 889675Slinton case VAR: 899675Slinton if (isparam(s)) { 909675Slinton printf("(parameter) %s : ", symname(s)); 919675Slinton } else { 929675Slinton printf("var %s : ", symname(s)); 939675Slinton } 949675Slinton printtype(s, s->type); 959675Slinton break; 969675Slinton 979675Slinton case REF: 989675Slinton printf("(var parameter) %s : ", symname(s)); 999675Slinton printtype(s, s->type); 1009675Slinton break; 1019675Slinton 1029675Slinton case RANGE: 1039675Slinton case ARRAY: 1049675Slinton case RECORD: 1059675Slinton case VARNT: 1069675Slinton case PTR: 1079675Slinton printtype(s, s); 1089675Slinton semicolon = false; 1099675Slinton break; 1109675Slinton 1119675Slinton case FVAR: 1129675Slinton printf("(function variable) %s : ", symname(s)); 1139675Slinton printtype(s, s->type); 1149675Slinton break; 1159675Slinton 1169675Slinton case FIELD: 1179675Slinton printf("(field) %s : ", symname(s)); 1189675Slinton printtype(s, s->type); 1199675Slinton break; 1209675Slinton 1219675Slinton case PROC: 1229675Slinton printf("procedure %s", symname(s)); 1239675Slinton listparams(s); 1249675Slinton break; 1259675Slinton 1269675Slinton case PROG: 1279675Slinton printf("program %s", symname(s)); 1289675Slinton t = s->chain; 1299675Slinton if (t != nil) { 1309675Slinton printf("(%s", symname(t)); 1319675Slinton for (t = t->chain; t != nil; t = t->chain) { 1329675Slinton printf(", %s", symname(t)); 1339675Slinton } 1349675Slinton printf(")"); 1359675Slinton } 1369675Slinton break; 1379675Slinton 1389675Slinton case FUNC: 1399675Slinton printf("function %s", symname(s)); 1409675Slinton listparams(s); 1419675Slinton printf(" : "); 1429675Slinton printtype(s, s->type); 1439675Slinton break; 1449675Slinton 1459675Slinton default: 1469675Slinton error("class %s in printdecl", classname(s)); 1479675Slinton } 1489675Slinton if (semicolon) { 1499675Slinton putchar(';'); 1509675Slinton } 1519675Slinton putchar('\n'); 1529675Slinton } 1539675Slinton 1549675Slinton /* 1559675Slinton * Recursive whiz-bang procedure to print the type portion 1569675Slinton * of a declaration. Doesn't work quite right for variant records. 1579675Slinton * 1589675Slinton * The symbol associated with the type is passed to allow 1599675Slinton * searching for type names without getting "type blah = blah". 1609675Slinton */ 1619675Slinton 1629675Slinton private printtype(s, t) 1639675Slinton Symbol s; 1649675Slinton Symbol t; 1659675Slinton { 1669675Slinton register Symbol tmp; 1679675Slinton 1689675Slinton switch (t->class) { 1699675Slinton case VAR: 1709675Slinton case CONST: 1719675Slinton case FUNC: 1729675Slinton case PROC: 1739675Slinton panic("printtype: class %s", classname(t)); 1749675Slinton break; 1759675Slinton 1769675Slinton case ARRAY: 1779675Slinton printf("array["); 1789675Slinton tmp = t->chain; 1799675Slinton if (tmp != nil) { 1809675Slinton for (;;) { 1819675Slinton printtype(tmp, tmp); 1829675Slinton tmp = tmp->chain; 1839675Slinton if (tmp == nil) { 1849675Slinton break; 1859675Slinton } 1869675Slinton printf(", "); 1879675Slinton } 1889675Slinton } 1899675Slinton printf("] of "); 1909675Slinton printtype(t, t->type); 1919675Slinton break; 1929675Slinton 1939675Slinton case RECORD: 1949675Slinton printf("record\n"); 1959675Slinton if (t->chain != nil) { 1969675Slinton printtype(t->chain, t->chain); 1979675Slinton } 1989675Slinton printf("end"); 1999675Slinton break; 2009675Slinton 2019675Slinton case FIELD: 2029675Slinton if (t->chain != nil) { 2039675Slinton printtype(t->chain, t->chain); 2049675Slinton } 2059675Slinton printf("\t%s : ", symname(t)); 2069675Slinton printtype(t, t->type); 2079675Slinton printf(";\n"); 2089675Slinton break; 2099675Slinton 2109675Slinton case RANGE: { 2119675Slinton long r0, r1; 2129675Slinton 2139675Slinton r0 = t->symvalue.rangev.lower; 2149675Slinton r1 = t->symvalue.rangev.upper; 2159675Slinton if (t == t_char) { 2169675Slinton if (r0 < 0x20 or r0 > 0x7e) { 2179675Slinton printf("%ld..", r0); 2189675Slinton } else { 2199675Slinton printf("'%c'..", (char) r0); 2209675Slinton } 2219675Slinton if (r1 < 0x20 or r1 > 0x7e) { 2229675Slinton printf("\\%lo", r1); 2239675Slinton } else { 2249675Slinton printf("'%c'", (char) r1); 2259675Slinton } 2269675Slinton } else if (r0 > 0 and r1 == 0) { 2279675Slinton printf("%ld byte real", r0); 2289675Slinton } else if (r0 >= 0) { 2299675Slinton printf("%lu..%lu", r0, r1); 2309675Slinton } else { 2319675Slinton printf("%ld..%ld", r0, r1); 2329675Slinton } 2339675Slinton break; 2349675Slinton } 2359675Slinton 2369675Slinton case PTR: 2379675Slinton putchar('*'); 2389675Slinton printtype(t, t->type); 2399675Slinton break; 2409675Slinton 2419675Slinton case TYPE: 2429675Slinton if (symname(t) != nil) { 2439675Slinton printf("%s", symname(t)); 2449675Slinton } else { 2459675Slinton printtype(t, t->type); 2469675Slinton } 2479675Slinton break; 2489675Slinton 2499675Slinton case SCAL: 2509675Slinton printf("("); 2519675Slinton t = t->type->chain; 2529675Slinton if (t != nil) { 2539675Slinton printf("%s", symname(t)); 2549675Slinton t = t->chain; 2559675Slinton while (t != nil) { 2569675Slinton printf(", %s", symname(t)); 2579675Slinton t = t->chain; 2589675Slinton } 2599675Slinton } else { 2609675Slinton panic("empty enumeration"); 2619675Slinton } 2629675Slinton printf(")"); 2639675Slinton break; 2649675Slinton 2659675Slinton default: 2669675Slinton printf("(class %d)", t->class); 2679675Slinton break; 2689675Slinton } 2699675Slinton } 2709675Slinton 2719675Slinton /* 2729675Slinton * List the parameters of a procedure or function. 2739675Slinton * No attempt is made to combine like types. 2749675Slinton */ 2759675Slinton 2769675Slinton private listparams(s) 2779675Slinton Symbol s; 2789675Slinton { 2799675Slinton Symbol t; 2809675Slinton 2819675Slinton if (s->chain != nil) { 2829675Slinton putchar('('); 2839675Slinton for (t = s->chain; t != nil; t = t->chain) { 2849675Slinton switch (t->class) { 2859675Slinton case REF: 2869675Slinton printf("var "); 2879675Slinton break; 2889675Slinton 2899675Slinton case FPROC: 2909675Slinton printf("procedure "); 2919675Slinton break; 2929675Slinton 2939675Slinton case FFUNC: 2949675Slinton printf("function "); 2959675Slinton break; 2969675Slinton 2979675Slinton case VAR: 2989675Slinton break; 2999675Slinton 3009675Slinton default: 3019675Slinton panic("unexpected class %d for parameter", t->class); 3029675Slinton } 3039675Slinton printf("%s : ", symname(t)); 3049675Slinton printtype(t, t->type); 3059675Slinton if (t->chain != nil) { 3069675Slinton printf("; "); 3079675Slinton } 3089675Slinton } 3099675Slinton putchar(')'); 3109675Slinton } 3119675Slinton } 3129675Slinton 3139675Slinton /* 3149675Slinton * Print out the value on the top of the expression stack 3159675Slinton * in the format for the type of the given symbol. 3169675Slinton */ 3179675Slinton 3189675Slinton public pascal_printval(s) 3199675Slinton Symbol s; 3209675Slinton { 3219675Slinton Symbol t; 3229675Slinton Address a; 3239675Slinton int len; 3249675Slinton double r; 3259675Slinton 3269675Slinton if (s->class == REF) { 3279675Slinton s = s->type; 3289675Slinton } 3299675Slinton switch (s->class) { 3309675Slinton case TYPE: 3319675Slinton pascal_printval(s->type); 3329675Slinton break; 3339675Slinton 3349675Slinton case ARRAY: 3359675Slinton t = rtype(s->type); 3369675Slinton if (t==t_char or (t->class==RANGE and t->type==t_char)) { 3379675Slinton len = size(s); 3389675Slinton sp -= len; 3399675Slinton printf("'%.*s'", len, sp); 3409675Slinton break; 3419675Slinton } else { 3429675Slinton printarray(s); 3439675Slinton } 3449675Slinton break; 3459675Slinton 3469675Slinton case RECORD: 3479675Slinton printrecord(s); 3489675Slinton break; 3499675Slinton 3509675Slinton case VARNT: 3519675Slinton error("can't print out variant records"); 3529675Slinton break; 3539675Slinton 3549675Slinton 3559675Slinton case RANGE: 3569675Slinton if (s == t_boolean) { 3579675Slinton printf(((Boolean) popsmall(s)) == true ? "true" : "false"); 3589675Slinton } else if (s == t_char) { 3599675Slinton printf("'%c'", pop(char)); 3609675Slinton } else if (s->symvalue.rangev.upper == 0 and 3619675Slinton s->symvalue.rangev.lower > 0) { 3629675Slinton switch (s->symvalue.rangev.lower) { 3639675Slinton case sizeof(float): 3649675Slinton prtreal(pop(float)); 3659675Slinton break; 3669675Slinton 3679675Slinton case sizeof(double): 3689675Slinton prtreal(pop(double)); 3699675Slinton break; 3709675Slinton 3719675Slinton default: 3729675Slinton panic("bad real size %d", s->symvalue.rangev.lower); 3739675Slinton break; 3749675Slinton } 3759675Slinton } else if (s->symvalue.rangev.lower >= 0) { 3769675Slinton printf("%lu", popsmall(s)); 3779675Slinton } else { 3789675Slinton printf("%ld", popsmall(s)); 3799675Slinton } 3809675Slinton break; 3819675Slinton 3829675Slinton case FILET: 3839675Slinton case PTR: { 3849675Slinton Address addr; 3859675Slinton 3869675Slinton addr = pop(Address); 3879675Slinton if (addr == 0) { 3889675Slinton printf("0, (nil)"); 3899675Slinton } else { 3909675Slinton printf("0x%x, 0%o", addr, addr); 3919675Slinton } 3929675Slinton break; 3939675Slinton } 3949675Slinton 3959675Slinton case FIELD: 3969675Slinton error("missing record specification"); 3979675Slinton break; 3989675Slinton 3999675Slinton case SCAL: { 4009675Slinton int scalar; 4019675Slinton Boolean found; 4029675Slinton 4039675Slinton scalar = popsmall(s); 4049675Slinton found = false; 4059675Slinton for (t = s->chain; t != nil; t = t->chain) { 4069675Slinton if (t->symvalue.iconval == scalar) { 4079675Slinton printf("%s", symname(t)); 4089675Slinton found = true; 4099675Slinton break; 4109675Slinton } 4119675Slinton } 4129675Slinton if (not found) { 4139675Slinton printf("(scalar = %d)", scalar); 4149675Slinton } 4159675Slinton break; 4169675Slinton } 4179675Slinton 4189675Slinton case FPROC: 4199675Slinton case FFUNC: 4209675Slinton { 4219675Slinton Address a; 4229675Slinton 4239675Slinton a = fparamaddr(pop(long)); 4249675Slinton t = whatblock(a); 4259675Slinton if (t == nil) { 4269675Slinton printf("(proc %d)", a); 4279675Slinton } else { 4289675Slinton printf("%s", symname(t)); 4299675Slinton } 4309675Slinton break; 4319675Slinton } 4329675Slinton 4339675Slinton default: 4349675Slinton if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) { 4359675Slinton panic("printval: bad class %d", ord(s->class)); 4369675Slinton } 4379675Slinton error("don't know how to print a %s", classname(s)); 4389675Slinton /* NOTREACHED */ 4399675Slinton } 4409675Slinton } 441