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