1: /* 2: * Copyright (c) 1983 Regents of the University of California. 3: * All rights reserved. The Berkeley software License Agreement 4: * specifies the terms and conditions for redistribution. 5: */ 6: 7: #ifndef lint 8: static char sccsid[] = "@(#)pascal.c 5.1 (Berkeley) 5/31/85"; 9: #endif not lint 10: 11: static char rcsid[] = "$Header: pascal.c,v 1.5 84/12/26 10:41:18 linton Exp $"; 12: 13: /* 14: * Pascal-dependent symbol routines. 15: */ 16: 17: #include "defs.h" 18: #include "symbols.h" 19: #include "pascal.h" 20: #include "languages.h" 21: #include "tree.h" 22: #include "eval.h" 23: #include "mappings.h" 24: #include "process.h" 25: #include "runtime.h" 26: #include "machine.h" 27: 28: #ifndef public 29: #endif 30: 31: private Language pasc; 32: private boolean initialized; 33: 34: /* 35: * Initialize Pascal information. 36: */ 37: 38: public pascal_init() 39: { 40: pasc = language_define("pascal", ".p"); 41: language_setop(pasc, L_PRINTDECL, pascal_printdecl); 42: language_setop(pasc, L_PRINTVAL, pascal_printval); 43: language_setop(pasc, L_TYPEMATCH, pascal_typematch); 44: language_setop(pasc, L_BUILDAREF, pascal_buildaref); 45: language_setop(pasc, L_EVALAREF, pascal_evalaref); 46: language_setop(pasc, L_MODINIT, pascal_modinit); 47: language_setop(pasc, L_HASMODULES, pascal_hasmodules); 48: language_setop(pasc, L_PASSADDR, pascal_passaddr); 49: initialized = false; 50: } 51: 52: /* 53: * Typematch tests if two types are compatible. The issue 54: * is a bit complicated, so several subfunctions are used for 55: * various kinds of compatibility. 56: */ 57: 58: private boolean builtinmatch (t1, t2) 59: register Symbol t1, t2; 60: { 61: boolean b; 62: 63: b = (boolean) ( 64: ( 65: t2 == t_int->type and 66: t1->class == RANGE and istypename(t1->type, "integer") 67: ) or ( 68: t2 == t_char->type and 69: t1->class == RANGE and istypename(t1->type, "char") 70: ) or ( 71: t2 == t_real->type and 72: t1->class == RANGE and istypename(t1->type, "real") 73: ) or ( 74: t2 == t_boolean->type and 75: t1->class == RANGE and istypename(t1->type, "boolean") 76: ) 77: ); 78: return b; 79: } 80: 81: private boolean rangematch (t1, t2) 82: register Symbol t1, t2; 83: { 84: boolean b; 85: register Symbol rt1, rt2; 86: 87: if (t1->class == RANGE and t2->class == RANGE) { 88: rt1 = rtype(t1->type); 89: rt2 = rtype(t2->type); 90: b = (boolean) (rt1->type == rt2->type); 91: } else { 92: b = false; 93: } 94: return b; 95: } 96: 97: private boolean nilMatch (t1, t2) 98: register Symbol t1, t2; 99: { 100: boolean b; 101: 102: b = (boolean) ( 103: (t1 == t_nil and t2->class == PTR) or 104: (t1->class == PTR and t2 == t_nil) 105: ); 106: return b; 107: } 108: 109: private boolean enumMatch (t1, t2) 110: register Symbol t1, t2; 111: { 112: boolean b; 113: 114: b = (boolean) ( 115: (t1->class == SCAL and t2->class == CONST and t2->type == t1) or 116: (t1->class == CONST and t2->class == SCAL and t1->type == t2) 117: ); 118: return b; 119: } 120: 121: private boolean isConstString (t) 122: register Symbol t; 123: { 124: boolean b; 125: 126: b = (boolean) ( 127: t->language == primlang and t->class == ARRAY and t->type == t_char 128: ); 129: return b; 130: } 131: 132: private boolean stringArrayMatch (t1, t2) 133: register Symbol t1, t2; 134: { 135: boolean b; 136: 137: b = (boolean) ( 138: ( 139: isConstString(t1) and 140: t2->class == ARRAY and compatible(t2->type, t_char->type) 141: ) or ( 142: isConstString(t2) and 143: t1->class == ARRAY and compatible(t1->type, t_char->type) 144: ) 145: ); 146: return b; 147: } 148: 149: public boolean pascal_typematch (type1, type2) 150: Symbol type1, type2; 151: { 152: boolean b; 153: Symbol t1, t2, tmp; 154: 155: t1 = rtype(type1); 156: t2 = rtype(type2); 157: if (t1 == t2) { 158: b = true; 159: } else { 160: if (t1 == t_char->type or t1 == t_int->type or 161: t1 == t_real->type or t1 == t_boolean->type 162: ) { 163: tmp = t1; 164: t1 = t2; 165: t2 = tmp; 166: } 167: b = (Boolean) ( 168: builtinmatch(t1, t2) or rangematch(t1, t2) or 169: nilMatch(t1, t2) or enumMatch(t1, t2) or 170: stringArrayMatch(t1, t2) 171: ); 172: } 173: return b; 174: } 175: 176: /* 177: * Indent n spaces. 178: */ 179: 180: private indent (n) 181: int n; 182: { 183: if (n > 0) { 184: printf("%*c", n, ' '); 185: } 186: } 187: 188: public pascal_printdecl (s) 189: Symbol s; 190: { 191: register Symbol t; 192: Boolean semicolon; 193: 194: semicolon = true; 195: if (s->class == TYPEREF) { 196: resolveRef(t); 197: } 198: switch (s->class) { 199: case CONST: 200: if (s->type->class == SCAL) { 201: semicolon = false; 202: printf("enum constant, ord "); 203: eval(s->symvalue.constval); 204: pascal_printval(s); 205: } else { 206: printf("const %s = ", symname(s)); 207: eval(s->symvalue.constval); 208: pascal_printval(s); 209: } 210: break; 211: 212: case TYPE: 213: printf("type %s = ", symname(s)); 214: printtype(s, s->type, 0); 215: break; 216: 217: case TYPEREF: 218: printf("type %s", symname(s)); 219: break; 220: 221: case VAR: 222: if (isparam(s)) { 223: printf("(parameter) %s : ", symname(s)); 224: } else { 225: printf("var %s : ", symname(s)); 226: } 227: printtype(s, s->type, 0); 228: break; 229: 230: case REF: 231: printf("(var parameter) %s : ", symname(s)); 232: printtype(s, s->type, 0); 233: break; 234: 235: case RANGE: 236: case ARRAY: 237: case RECORD: 238: case VARNT: 239: case PTR: 240: case FILET: 241: printtype(s, s, 0); 242: semicolon = false; 243: break; 244: 245: case FVAR: 246: printf("(function variable) %s : ", symname(s)); 247: printtype(s, s->type, 0); 248: break; 249: 250: case FIELD: 251: printf("(field) %s : ", symname(s)); 252: printtype(s, s->type, 0); 253: break; 254: 255: case PROC: 256: printf("procedure %s", symname(s)); 257: listparams(s); 258: break; 259: 260: case PROG: 261: printf("program %s", symname(s)); 262: listparams(s); 263: break; 264: 265: case FUNC: 266: printf("function %s", symname(s)); 267: listparams(s); 268: printf(" : "); 269: printtype(s, s->type, 0); 270: break; 271: 272: case MODULE: 273: printf("module %s", symname(s)); 274: break; 275: 276: /* 277: * the parameter list of the following should be printed 278: * eventually 279: */ 280: case FPROC: 281: printf("procedure %s()", symname(s)); 282: break; 283: 284: case FFUNC: 285: printf("function %s()", symname(s)); 286: break; 287: 288: default: 289: printf("%s : (class %s)", symname(s), classname(s)); 290: break; 291: } 292: if (semicolon) { 293: putchar(';'); 294: } 295: putchar('\n'); 296: } 297: 298: /* 299: * Recursive whiz-bang procedure to print the type portion 300: * of a declaration. 301: * 302: * The symbol associated with the type is passed to allow 303: * searching for type names without getting "type blah = blah". 304: */ 305: 306: private printtype (s, t, n) 307: Symbol s; 308: Symbol t; 309: int n; 310: { 311: register Symbol tmp; 312: 313: if (t->class == TYPEREF) { 314: resolveRef(t); 315: } 316: switch (t->class) { 317: case VAR: 318: case CONST: 319: case FUNC: 320: case PROC: 321: panic("printtype: class %s", classname(t)); 322: break; 323: 324: case ARRAY: 325: printf("array["); 326: tmp = t->chain; 327: if (tmp != nil) { 328: for (;;) { 329: printtype(tmp, tmp, n); 330: tmp = tmp->chain; 331: if (tmp == nil) { 332: break; 333: } 334: printf(", "); 335: } 336: } 337: printf("] of "); 338: printtype(t, t->type, n); 339: break; 340: 341: case RECORD: 342: printRecordDecl(t, n); 343: break; 344: 345: case FIELD: 346: if (t->chain != nil) { 347: printtype(t->chain, t->chain, n); 348: } 349: printf("\t%s : ", symname(t)); 350: printtype(t, t->type, n); 351: printf(";\n"); 352: break; 353: 354: case RANGE: 355: printRangeDecl(t); 356: break; 357: 358: case PTR: 359: printf("^"); 360: printtype(t, t->type, n); 361: break; 362: 363: case TYPE: 364: if (t->name != nil and ident(t->name)[0] != '\0') { 365: printname(stdout, t); 366: } else { 367: printtype(t, t->type, n); 368: } 369: break; 370: 371: case SCAL: 372: printEnumDecl(t, n); 373: break; 374: 375: case SET: 376: printf("set of "); 377: printtype(t, t->type, n); 378: break; 379: 380: case FILET: 381: printf("file of "); 382: printtype(t, t->type, n); 383: break; 384: 385: case TYPEREF: 386: break; 387: 388: case FPROC: 389: printf("procedure"); 390: break; 391: 392: case FFUNC: 393: printf("function"); 394: break; 395: 396: default: 397: printf("(class %d)", t->class); 398: break; 399: } 400: } 401: 402: /* 403: * Print out a record declaration. 404: */ 405: 406: private printRecordDecl (t, n) 407: Symbol t; 408: int n; 409: { 410: register Symbol f; 411: 412: if (t->chain == nil) { 413: printf("record end"); 414: } else { 415: printf("record\n"); 416: for (f = t->chain; f != nil; f = f->chain) { 417: indent(n+4); 418: printf("%s : ", symname(f)); 419: printtype(f->type, f->type, n+4); 420: printf(";\n"); 421: } 422: indent(n); 423: printf("end"); 424: } 425: } 426: 427: /* 428: * Print out the declaration of a range type. 429: */ 430: 431: private printRangeDecl (t) 432: Symbol t; 433: { 434: long r0, r1; 435: 436: r0 = t->symvalue.rangev.lower; 437: r1 = t->symvalue.rangev.upper; 438: if (t == t_char or istypename(t, "char")) { 439: if (r0 < 0x20 or r0 > 0x7e) { 440: printf("%ld..", r0); 441: } else { 442: printf("'%c'..", (char) r0); 443: } 444: if (r1 < 0x20 or r1 > 0x7e) { 445: printf("\\%lo", r1); 446: } else { 447: printf("'%c'", (char) r1); 448: } 449: } else if (r0 > 0 and r1 == 0) { 450: printf("%ld byte real", r0); 451: } else if (r0 >= 0) { 452: printf("%lu..%lu", r0, r1); 453: } else { 454: printf("%ld..%ld", r0, r1); 455: } 456: } 457: 458: /* 459: * Print out an enumeration declaration. 460: */ 461: 462: private printEnumDecl (e, n) 463: Symbol e; 464: int n; 465: { 466: Symbol t; 467: 468: printf("("); 469: t = e->chain; 470: if (t != nil) { 471: printf("%s", symname(t)); 472: t = t->chain; 473: while (t != nil) { 474: printf(", %s", symname(t)); 475: t = t->chain; 476: } 477: } 478: printf(")"); 479: } 480: 481: /* 482: * List the parameters of a procedure or function. 483: * No attempt is made to combine like types. 484: */ 485: 486: private listparams(s) 487: Symbol s; 488: { 489: Symbol t; 490: 491: if (s->chain != nil) { 492: putchar('('); 493: for (t = s->chain; t != nil; t = t->chain) { 494: switch (t->class) { 495: case REF: 496: printf("var "); 497: break; 498: 499: case VAR: 500: break; 501: 502: default: 503: panic("unexpected class %d for parameter", t->class); 504: } 505: printf("%s : ", symname(t)); 506: printtype(t, t->type); 507: if (t->chain != nil) { 508: printf("; "); 509: } 510: } 511: putchar(')'); 512: } 513: } 514: 515: /* 516: * Print out the value on the top of the expression stack 517: * in the format for the type of the given symbol. 518: */ 519: 520: public pascal_printval (s) 521: Symbol s; 522: { 523: prval(s, size(s)); 524: } 525: 526: private prval (s, n) 527: Symbol s; 528: integer n; 529: { 530: Symbol t; 531: Address a; 532: integer len; 533: double r; 534: integer i; 535: 536: if (s->class == TYPEREF) { 537: resolveRef(s); 538: } 539: switch (s->class) { 540: case CONST: 541: case TYPE: 542: case REF: 543: case VAR: 544: case FVAR: 545: case TAG: 546: prval(s->type, n); 547: break; 548: 549: case FIELD: 550: prval(s->type, n); 551: break; 552: 553: case ARRAY: 554: t = rtype(s->type); 555: if (t == t_char->type or 556: (t->class == RANGE and istypename(t->type, "char")) 557: ) { 558: len = size(s); 559: sp -= len; 560: printf("'%.*s'", len, sp); 561: break; 562: } else { 563: printarray(s); 564: } 565: break; 566: 567: case RECORD: 568: printrecord(s); 569: break; 570: 571: case VARNT: 572: printf("[variant]"); 573: break; 574: 575: case RANGE: 576: printrange(s, n); 577: break; 578: 579: case FILET: 580: a = pop(Address); 581: if (a == 0) { 582: printf("nil"); 583: } else { 584: printf("0x%x", a); 585: } 586: break; 587: 588: case PTR: 589: a = pop(Address); 590: if (a == 0) { 591: printf("nil"); 592: } else { 593: printf("0x%x", a); 594: } 595: break; 596: 597: case SCAL: 598: i = 0; 599: popn(n, &i); 600: if (s->symvalue.iconval < 256) { 601: i &= 0xff; 602: } else if (s->symvalue.iconval < 65536) { 603: i &= 0xffff; 604: } 605: printEnum(i, s); 606: break; 607: 608: case FPROC: 609: case FFUNC: 610: a = pop(long); 611: t = whatblock(a); 612: if (t == nil) { 613: printf("(proc 0x%x)", a); 614: } else { 615: printf("%s", symname(t)); 616: } 617: break; 618: 619: case SET: 620: printSet(s); 621: break; 622: 623: default: 624: if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) { 625: panic("printval: bad class %d", ord(s->class)); 626: } 627: printf("[%s]", classname(s)); 628: break; 629: } 630: } 631: 632: /* 633: * Print out the value of a scalar (non-enumeration) type. 634: */ 635: 636: private printrange (s, n) 637: Symbol s; 638: integer n; 639: { 640: double d; 641: float f; 642: integer i; 643: 644: if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) { 645: if (n == sizeof(float)) { 646: popn(n, &f); 647: d = f; 648: } else { 649: popn(n, &d); 650: } 651: prtreal(d); 652: } else { 653: i = 0; 654: popn(n, &i); 655: printRangeVal(i, s); 656: } 657: } 658: 659: /* 660: * Print out a set. 661: */ 662: 663: private printSet (s) 664: Symbol s; 665: { 666: Symbol t; 667: integer nbytes; 668: 669: nbytes = size(s); 670: t = rtype(s->type); 671: printf("["); 672: sp -= nbytes; 673: if (t->class == SCAL) { 674: printSetOfEnum(t); 675: } else if (t->class == RANGE) { 676: printSetOfRange(t); 677: } else { 678: error("internal error: expected range or enumerated base type for set"); 679: } 680: printf("]"); 681: } 682: 683: /* 684: * Print out a set of an enumeration. 685: */ 686: 687: private printSetOfEnum (t) 688: Symbol t; 689: { 690: register Symbol e; 691: register integer i, j, *p; 692: boolean first; 693: 694: p = (int *) sp; 695: i = *p; 696: j = 0; 697: e = t->chain; 698: first = true; 699: while (e != nil) { 700: if ((i&1) == 1) { 701: if (first) { 702: first = false; 703: printf("%s", symname(e)); 704: } else { 705: printf(", %s", symname(e)); 706: } 707: } 708: i >>= 1; 709: ++j; 710: if (j >= sizeof(integer)*BITSPERBYTE) { 711: j = 0; 712: ++p; 713: i = *p; 714: } 715: e = e->chain; 716: } 717: } 718: 719: /* 720: * Print out a set of a subrange type. 721: */ 722: 723: private printSetOfRange (t) 724: Symbol t; 725: { 726: register integer i, j, *p; 727: long v; 728: boolean first; 729: 730: p = (int *) sp; 731: i = *p; 732: j = 0; 733: v = t->symvalue.rangev.lower; 734: first = true; 735: while (v <= t->symvalue.rangev.upper) { 736: if ((i&1) == 1) { 737: if (first) { 738: first = false; 739: printf("%ld", v); 740: } else { 741: printf(", %ld", v); 742: } 743: } 744: i >>= 1; 745: ++j; 746: if (j >= sizeof(integer)*BITSPERBYTE) { 747: j = 0; 748: ++p; 749: i = *p; 750: } 751: ++v; 752: } 753: } 754: 755: /* 756: * Construct a node for subscripting. 757: */ 758: 759: public Node pascal_buildaref (a, slist) 760: Node a, slist; 761: { 762: register Symbol t; 763: register Node p; 764: Symbol etype, atype, eltype; 765: Node esub, r; 766: 767: t = rtype(a->nodetype); 768: if (t->class != ARRAY) { 769: beginerrmsg(); 770: prtree(stderr, a); 771: fprintf(stderr, " is not an array"); 772: enderrmsg(); 773: } else { 774: r = a; 775: eltype = t->type; 776: p = slist; 777: t = t->chain; 778: for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) { 779: esub = p->value.arg[0]; 780: etype = rtype(esub->nodetype); 781: atype = rtype(t); 782: if (not compatible(atype, etype)) { 783: beginerrmsg(); 784: fprintf(stderr, "subscript "); 785: prtree(stderr, esub); 786: fprintf(stderr, " is the wrong type"); 787: enderrmsg(); 788: } 789: r = build(O_INDEX, r, esub); 790: r->nodetype = eltype; 791: } 792: if (p != nil or t != nil) { 793: beginerrmsg(); 794: if (p != nil) { 795: fprintf(stderr, "too many subscripts for "); 796: } else { 797: fprintf(stderr, "not enough subscripts for "); 798: } 799: prtree(stderr, a); 800: enderrmsg(); 801: } 802: } 803: return r; 804: } 805: 806: /* 807: * Evaluate a subscript index. 808: */ 809: 810: public pascal_evalaref (s, base, i) 811: Symbol s; 812: Address base; 813: long i; 814: { 815: Symbol t; 816: long lb, ub; 817: 818: t = rtype(s); 819: s = rtype(t->chain); 820: findbounds(s, &lb, &ub); 821: if (i < lb or i > ub) { 822: error("subscript %d out of range [%d..%d]", i, lb, ub); 823: } 824: push(long, base + (i - lb) * size(t->type)); 825: } 826: 827: /* 828: * Initial Pascal type information. 829: */ 830: 831: #define NTYPES 4 832: 833: private Symbol inittype[NTYPES + 1]; 834: 835: private addType (n, s, lower, upper) 836: integer n; 837: String s; 838: long lower, upper; 839: { 840: register Symbol t; 841: 842: if (n > NTYPES) { 843: panic("initial Pascal type number too large for '%s'", s); 844: } 845: t = insert(identname(s, true)); 846: t->language = pasc; 847: t->class = TYPE; 848: t->type = newSymbol(nil, 0, RANGE, t, nil); 849: t->type->symvalue.rangev.lower = lower; 850: t->type->symvalue.rangev.upper = upper; 851: t->type->language = pasc; 852: inittype[n] = t; 853: } 854: 855: private initTypes () 856: { 857: addType(1, "boolean", 0L, 1L); 858: addType(2, "char", 0L, 255L); 859: addType(3, "integer", 0x80000000L, 0x7fffffffL); 860: addType(4, "real", 8L, 0L); 861: initialized = true; 862: } 863: 864: /* 865: * Initialize typetable. 866: */ 867: 868: public pascal_modinit (typetable) 869: Symbol typetable[]; 870: { 871: register integer i; 872: 873: if (not initialized) { 874: initTypes(); 875: initialized = true; 876: } 877: for (i = 1; i <= NTYPES; i++) { 878: typetable[i] = inittype[i]; 879: } 880: } 881: 882: public boolean pascal_hasmodules () 883: { 884: return false; 885: } 886: 887: public boolean pascal_passaddr (param, exprtype) 888: Symbol param, exprtype; 889: { 890: return false; 891: }