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