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