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) 05/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 } 892