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