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[] = "@(#)modula-2.c 5.4 (Berkeley) 06/01/90"; 10 #endif /* not lint */ 11 12 /* 13 * Modula-2 specific symbol routines. 14 */ 15 16 #include "defs.h" 17 #include "symbols.h" 18 #include "modula-2.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 mod2; 31 private boolean initialized; 32 33 34 #define ischar(t) ( \ 35 (t) == t_char->type or \ 36 ((t)->class == RANGE and istypename((t)->type, "char")) \ 37 ) 38 39 /* 40 * Initialize Modula-2 information. 41 */ 42 43 public modula2_init () 44 { 45 mod2 = language_define("modula-2", ".mod"); 46 language_setop(mod2, L_PRINTDECL, modula2_printdecl); 47 language_setop(mod2, L_PRINTVAL, modula2_printval); 48 language_setop(mod2, L_TYPEMATCH, modula2_typematch); 49 language_setop(mod2, L_BUILDAREF, modula2_buildaref); 50 language_setop(mod2, L_EVALAREF, modula2_evalaref); 51 language_setop(mod2, L_MODINIT, modula2_modinit); 52 language_setop(mod2, L_HASMODULES, modula2_hasmodules); 53 language_setop(mod2, L_PASSADDR, modula2_passaddr); 54 initialized = false; 55 } 56 57 /* 58 * Typematch tests if two types are compatible. The issue 59 * is a bit complicated, so several subfunctions are used for 60 * various kinds of compatibility. 61 */ 62 63 private boolean builtinmatch (t1, t2) 64 register Symbol t1, t2; 65 { 66 boolean b; 67 68 b = (boolean) ( 69 ( 70 t2 == t_int->type and t1->class == RANGE and 71 ( 72 istypename(t1->type, "integer") or 73 istypename(t1->type, "cardinal") 74 ) 75 ) or ( 76 t2 == t_char->type and 77 t1->class == RANGE and istypename(t1->type, "char") 78 ) or ( 79 t2 == t_real->type and 80 t1->class == RANGE and ( 81 istypename(t1->type, "real") or 82 istypename(t1->type, "longreal") 83 ) 84 ) or ( 85 t2 == t_boolean->type and 86 t1->class == RANGE and istypename(t1->type, "boolean") 87 ) 88 ); 89 return b; 90 } 91 92 private boolean nilMatch (t1, t2) 93 register Symbol t1, t2; 94 { 95 boolean b; 96 97 b = (boolean) ( 98 (t1 == t_nil and t2->class == PTR) or 99 (t1->class == PTR and t2 == t_nil) 100 ); 101 return b; 102 } 103 104 private boolean enumMatch (t1, t2) 105 register Symbol t1, t2; 106 { 107 boolean b; 108 109 b = (boolean) ( 110 (t1->class == SCAL and t2->class == CONST and t2->type == t1) or 111 (t1->class == CONST and t2->class == SCAL and t1->type == t2) 112 ); 113 return b; 114 } 115 116 private boolean openArrayMatch (t1, t2) 117 register Symbol t1, t2; 118 { 119 boolean b; 120 121 b = (boolean) ( 122 ( 123 t1->class == OPENARRAY and t1->symvalue.ndims == 1 and 124 t2->class == ARRAY and 125 compatible(rtype(t2->chain)->type, t_int) and 126 compatible(t1->type, t2->type) 127 ) or ( 128 t2->class == OPENARRAY and t2->symvalue.ndims == 1 and 129 t1->class == ARRAY and 130 compatible(rtype(t1->chain)->type, t_int) and 131 compatible(t1->type, t2->type) 132 ) 133 ); 134 return b; 135 } 136 137 private boolean isConstString (t) 138 register Symbol t; 139 { 140 boolean b; 141 142 b = (boolean) ( 143 t->language == primlang and t->class == ARRAY and t->type == t_char 144 ); 145 return b; 146 } 147 148 private boolean stringArrayMatch (t1, t2) 149 register Symbol t1, t2; 150 { 151 boolean b; 152 153 b = (boolean) ( 154 ( 155 isConstString(t1) and 156 t2->class == ARRAY and compatible(t2->type, t_char->type) 157 ) or ( 158 isConstString(t2) and 159 t1->class == ARRAY and compatible(t1->type, t_char->type) 160 ) 161 ); 162 return b; 163 } 164 165 public boolean modula2_typematch (type1, type2) 166 Symbol type1, type2; 167 { 168 boolean b; 169 Symbol t1, t2, tmp; 170 171 t1 = rtype(type1); 172 t2 = rtype(type2); 173 if (t1 == t2) { 174 b = true; 175 } else { 176 if (t1 == t_char->type or t1 == t_int->type or 177 t1 == t_real->type or t1 == t_boolean->type 178 ) { 179 tmp = t1; 180 t1 = t2; 181 t2 = tmp; 182 } 183 b = (Boolean) ( 184 builtinmatch(t1, t2) or 185 nilMatch(t1, t2) or enumMatch(t1, t2) or 186 openArrayMatch(t1, t2) or stringArrayMatch(t1, t2) 187 ); 188 } 189 return b; 190 } 191 192 /* 193 * Indent n spaces. 194 */ 195 196 private indent (n) 197 int n; 198 { 199 if (n > 0) { 200 printf("%*c", n, ' '); 201 } 202 } 203 204 public modula2_printdecl (s) 205 Symbol s; 206 { 207 register Symbol t; 208 Boolean semicolon; 209 210 semicolon = true; 211 if (s->class == TYPEREF) { 212 resolveRef(t); 213 } 214 switch (s->class) { 215 case CONST: 216 if (s->type->class == SCAL) { 217 semicolon = false; 218 printf("enumeration constant with value "); 219 eval(s->symvalue.constval); 220 modula2_printval(s); 221 } else { 222 printf("const %s = ", symname(s)); 223 eval(s->symvalue.constval); 224 modula2_printval(s); 225 } 226 break; 227 228 case TYPE: 229 printf("type %s = ", symname(s)); 230 printtype(s, s->type, 0); 231 break; 232 233 case TYPEREF: 234 printf("type %s", symname(s)); 235 break; 236 237 case VAR: 238 if (isparam(s)) { 239 printf("(parameter) %s : ", symname(s)); 240 } else { 241 printf("var %s : ", symname(s)); 242 } 243 printtype(s, s->type, 0); 244 break; 245 246 case REF: 247 printf("(var parameter) %s : ", symname(s)); 248 printtype(s, s->type, 0); 249 break; 250 251 case RANGE: 252 case ARRAY: 253 case OPENARRAY: 254 case DYNARRAY: 255 case SUBARRAY: 256 case RECORD: 257 case VARNT: 258 case PTR: 259 printtype(s, s, 0); 260 semicolon = false; 261 break; 262 263 case FVAR: 264 printf("(function variable) %s : ", symname(s)); 265 printtype(s, s->type, 0); 266 break; 267 268 case FIELD: 269 printf("(field) %s : ", symname(s)); 270 printtype(s, s->type, 0); 271 break; 272 273 case PROC: 274 printf("procedure %s", symname(s)); 275 listparams(s); 276 break; 277 278 case PROG: 279 printf("program %s", symname(s)); 280 listparams(s); 281 break; 282 283 case FUNC: 284 printf("procedure %s", symname(s)); 285 listparams(s); 286 printf(" : "); 287 printtype(s, s->type, 0); 288 break; 289 290 case MODULE: 291 printf("module %s", symname(s)); 292 break; 293 294 default: 295 printf("[%s]", classname(s)); 296 break; 297 } 298 if (semicolon) { 299 putchar(';'); 300 } 301 putchar('\n'); 302 } 303 304 /* 305 * Recursive whiz-bang procedure to print the type portion 306 * of a declaration. 307 * 308 * The symbol associated with the type is passed to allow 309 * searching for type names without getting "type blah = blah". 310 */ 311 312 private printtype (s, t, n) 313 Symbol s; 314 Symbol t; 315 int n; 316 { 317 Symbol tmp; 318 int i; 319 320 if (t->class == TYPEREF) { 321 resolveRef(t); 322 } 323 switch (t->class) { 324 case VAR: 325 case CONST: 326 case FUNC: 327 case PROC: 328 panic("printtype: class %s", classname(t)); 329 break; 330 331 case ARRAY: 332 printf("array["); 333 tmp = t->chain; 334 if (tmp != nil) { 335 for (;;) { 336 printtype(tmp, tmp, n); 337 tmp = tmp->chain; 338 if (tmp == nil) { 339 break; 340 } 341 printf(", "); 342 } 343 } 344 printf("] of "); 345 printtype(t, t->type, n); 346 break; 347 348 case OPENARRAY: 349 printf("array of "); 350 for (i = 1; i < t->symvalue.ndims; i++) { 351 printf("array of "); 352 } 353 printtype(t, t->type, n); 354 break; 355 356 case DYNARRAY: 357 printf("dynarray of "); 358 for (i = 1; i < t->symvalue.ndims; i++) { 359 printf("array of "); 360 } 361 printtype(t, t->type, n); 362 break; 363 364 case SUBARRAY: 365 printf("subarray of "); 366 for (i = 1; i < t->symvalue.ndims; i++) { 367 printf("array of "); 368 } 369 printtype(t, t->type, n); 370 break; 371 372 case RECORD: 373 printRecordDecl(t, n); 374 break; 375 376 case FIELD: 377 if (t->chain != nil) { 378 printtype(t->chain, t->chain, n); 379 } 380 printf("\t%s : ", symname(t)); 381 printtype(t, t->type, n); 382 printf(";\n"); 383 break; 384 385 case RANGE: 386 printRangeDecl(t); 387 break; 388 389 case PTR: 390 printf("pointer to "); 391 printtype(t, t->type, n); 392 break; 393 394 case TYPE: 395 if (t->name != nil and ident(t->name)[0] != '\0') { 396 printname(stdout, t); 397 } else { 398 printtype(t, t->type, n); 399 } 400 break; 401 402 case SCAL: 403 printEnumDecl(t, n); 404 break; 405 406 case SET: 407 printf("set of "); 408 printtype(t, t->type, n); 409 break; 410 411 case TYPEREF: 412 break; 413 414 case FPROC: 415 case FFUNC: 416 printf("procedure"); 417 break; 418 419 default: 420 printf("[%s]", classname(t)); 421 break; 422 } 423 } 424 425 /* 426 * Print out a record declaration. 427 */ 428 429 private printRecordDecl (t, n) 430 Symbol t; 431 int n; 432 { 433 register Symbol f; 434 435 if (t->chain == nil) { 436 printf("record end"); 437 } else { 438 printf("record\n"); 439 for (f = t->chain; f != nil; f = f->chain) { 440 indent(n+4); 441 printf("%s : ", symname(f)); 442 printtype(f->type, f->type, n+4); 443 printf(";\n"); 444 } 445 indent(n); 446 printf("end"); 447 } 448 } 449 450 /* 451 * Print out the declaration of a range type. 452 */ 453 454 private printRangeDecl (t) 455 Symbol t; 456 { 457 long r0, r1; 458 459 r0 = t->symvalue.rangev.lower; 460 r1 = t->symvalue.rangev.upper; 461 if (ischar(t)) { 462 if (r0 < 0x20 or r0 > 0x7e) { 463 printf("%ld..", r0); 464 } else { 465 printf("'%c'..", (char) r0); 466 } 467 if (r1 < 0x20 or r1 > 0x7e) { 468 printf("\\%lo", r1); 469 } else { 470 printf("'%c'", (char) r1); 471 } 472 } else if (r0 > 0 and r1 == 0) { 473 printf("%ld byte real", r0); 474 } else if (r0 >= 0) { 475 printf("%lu..%lu", r0, r1); 476 } else { 477 printf("%ld..%ld", r0, r1); 478 } 479 } 480 481 /* 482 * Print out an enumeration declaration. 483 */ 484 485 private printEnumDecl (e, n) 486 Symbol e; 487 int n; 488 { 489 Symbol t; 490 491 printf("("); 492 t = e->chain; 493 if (t != nil) { 494 printf("%s", symname(t)); 495 t = t->chain; 496 while (t != nil) { 497 printf(", %s", symname(t)); 498 t = t->chain; 499 } 500 } 501 printf(")"); 502 } 503 504 /* 505 * List the parameters of a procedure or function. 506 * No attempt is made to combine like types. 507 */ 508 509 private listparams (s) 510 Symbol s; 511 { 512 Symbol t; 513 514 if (s->chain != nil) { 515 putchar('('); 516 for (t = s->chain; t != nil; t = t->chain) { 517 switch (t->class) { 518 case REF: 519 printf("var "); 520 break; 521 522 case FPROC: 523 case FFUNC: 524 printf("procedure "); 525 break; 526 527 case VAR: 528 break; 529 530 default: 531 panic("unexpected class %d for parameter", t->class); 532 } 533 printf("%s", symname(t)); 534 if (s->class == PROG) { 535 printf(", "); 536 } else { 537 printf(" : "); 538 printtype(t, t->type, 0); 539 if (t->chain != nil) { 540 printf("; "); 541 } 542 } 543 } 544 putchar(')'); 545 } 546 } 547 548 /* 549 * Test if a pointer type should be treated as a null-terminated string. 550 * The type given is the type that is pointed to. 551 */ 552 553 private boolean isCstring (type) 554 Symbol type; 555 { 556 boolean b; 557 register Symbol a, t; 558 559 a = rtype(type); 560 if (a->class == ARRAY) { 561 t = rtype(a->chain); 562 b = (boolean) ( 563 t->class == RANGE and istypename(a->type, "char") and 564 (t->symvalue.rangev.upper - t->symvalue.rangev.lower + 1) <= 0 565 ); 566 } else { 567 b = false; 568 } 569 return b; 570 } 571 572 /* 573 * Modula 2 interface to printval. 574 */ 575 576 public modula2_printval (s) 577 Symbol s; 578 { 579 prval(s, size(s)); 580 } 581 582 /* 583 * Print out the value on the top of the expression stack 584 * in the format for the type of the given symbol, assuming 585 * the size of the object is n bytes. 586 */ 587 588 private prval (s, n) 589 Symbol s; 590 integer n; 591 { 592 Symbol t; 593 Address a; 594 integer len; 595 double r; 596 integer i; 597 598 if (s->class == TYPEREF) { 599 resolveRef(s); 600 } 601 switch (s->class) { 602 case CONST: 603 case TYPE: 604 case REF: 605 case VAR: 606 case FVAR: 607 case TAG: 608 prval(s->type, n); 609 break; 610 611 case FIELD: 612 if (isbitfield(s)) { 613 i = extractField(s); 614 t = rtype(s->type); 615 if (t->class == SCAL) { 616 printEnum(i, t); 617 } else { 618 printRangeVal(i, t); 619 } 620 } else { 621 prval(s->type, n); 622 } 623 break; 624 625 case ARRAY: 626 t = rtype(s->type); 627 if (ischar(t)) { 628 len = size(s); 629 sp -= len; 630 printf("\"%.*s\"", len, sp); 631 break; 632 } else { 633 printarray(s); 634 } 635 break; 636 637 case OPENARRAY: 638 case DYNARRAY: 639 printDynarray(s); 640 break; 641 642 case SUBARRAY: 643 printSubarray(s); 644 break; 645 646 case RECORD: 647 printrecord(s); 648 break; 649 650 case VARNT: 651 printf("[variant]"); 652 break; 653 654 case RANGE: 655 printrange(s, n); 656 break; 657 658 /* 659 * Unresolved opaque type. 660 * Probably a pointer. 661 */ 662 case TYPEREF: 663 a = pop(Address); 664 printf("@%x", a); 665 break; 666 667 case FILET: 668 a = pop(Address); 669 if (a == 0) { 670 printf("nil"); 671 } else { 672 printf("0x%x", a); 673 } 674 break; 675 676 case PTR: 677 a = pop(Address); 678 if (a == 0) { 679 printf("nil"); 680 } else if (isCstring(s->type)) { 681 printString(a, true); 682 } else { 683 printf("0x%x", a); 684 } 685 break; 686 687 case SCAL: 688 i = 0; 689 popn(n, &i); 690 printEnum(i, s); 691 break; 692 693 case FPROC: 694 case FFUNC: 695 a = pop(long); 696 t = whatblock(a); 697 if (t == nil) { 698 printf("0x%x", a); 699 } else { 700 printname(stdout, t); 701 } 702 break; 703 704 case SET: 705 printSet(s); 706 break; 707 708 default: 709 if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) { 710 panic("printval: bad class %d", ord(s->class)); 711 } 712 printf("[%s]", classname(s)); 713 break; 714 } 715 } 716 717 /* 718 * Print out a dynamic array. 719 */ 720 721 private Address printDynSlice(); 722 723 private printDynarray (t) 724 Symbol t; 725 { 726 Address base; 727 integer n; 728 Stack *savesp, *newsp; 729 Symbol eltype; 730 731 savesp = sp; 732 sp -= (t->symvalue.ndims * sizeof(Word)); 733 base = pop(Address); 734 newsp = sp; 735 sp = savesp; 736 eltype = rtype(t->type); 737 if (t->symvalue.ndims == 0) { 738 if (ischar(eltype)) { 739 printString(base, true); 740 } else { 741 printf("[dynarray @nocount]"); 742 } 743 } else { 744 n = ((long *) sp)[-(t->symvalue.ndims)]; 745 base = printDynSlice(base, n, t->symvalue.ndims, eltype, size(eltype)); 746 } 747 sp = newsp; 748 } 749 750 /* 751 * Print out one dimension of a multi-dimension dynamic array. 752 * 753 * Return the address of the element that follows the printed elements. 754 */ 755 756 private Address printDynSlice (base, count, ndims, eltype, elsize) 757 Address base; 758 integer count, ndims; 759 Symbol eltype; 760 integer elsize; 761 { 762 Address b; 763 integer i, n; 764 char *slice; 765 Stack *savesp; 766 767 b = base; 768 if (ndims > 1) { 769 n = ((long *) sp)[-ndims + 1]; 770 } 771 if (ndims == 1 and ischar(eltype)) { 772 slice = newarr(char, count); 773 dread(slice, b, count); 774 printf("\"%.*s\"", count, slice); 775 dispose(slice); 776 b += count; 777 } else { 778 printf("("); 779 for (i = 0; i < count; i++) { 780 if (i != 0) { 781 printf(", "); 782 } 783 if (ndims == 1) { 784 slice = newarr(char, elsize); 785 dread(slice, b, elsize); 786 savesp = sp; 787 sp = slice + elsize; 788 printval(eltype); 789 sp = savesp; 790 dispose(slice); 791 b += elsize; 792 } else { 793 b = printDynSlice(b, n, ndims - 1, eltype, elsize); 794 } 795 } 796 printf(")"); 797 } 798 return b; 799 } 800 801 private printSubarray (t) 802 Symbol t; 803 { 804 printf("[subarray]"); 805 } 806 807 /* 808 * Print out the value of a scalar (non-enumeration) type. 809 */ 810 811 private printrange (s, n) 812 Symbol s; 813 integer n; 814 { 815 double d; 816 float f; 817 integer i; 818 819 if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) { 820 if (n == sizeof(float)) { 821 popn(n, &f); 822 d = f; 823 } else { 824 popn(n, &d); 825 } 826 prtreal(d); 827 } else { 828 i = 0; 829 popn(n, &i); 830 printRangeVal(i, s); 831 } 832 } 833 834 /* 835 * Print out a set. 836 */ 837 838 private printSet (s) 839 Symbol s; 840 { 841 Symbol t; 842 integer nbytes; 843 844 nbytes = size(s); 845 t = rtype(s->type); 846 printf("{"); 847 sp -= nbytes; 848 if (t->class == SCAL) { 849 printSetOfEnum(t); 850 } else if (t->class == RANGE) { 851 printSetOfRange(t); 852 } else { 853 panic("expected range or enumerated base type for set"); 854 } 855 printf("}"); 856 } 857 858 /* 859 * Print out a set of an enumeration. 860 */ 861 862 private printSetOfEnum (t) 863 Symbol t; 864 { 865 register Symbol e; 866 register integer i, j, *p; 867 boolean first; 868 869 p = (int *) sp; 870 i = *p; 871 j = 0; 872 e = t->chain; 873 first = true; 874 while (e != nil) { 875 if ((i&1) == 1) { 876 if (first) { 877 first = false; 878 printf("%s", symname(e)); 879 } else { 880 printf(", %s", symname(e)); 881 } 882 } 883 i >>= 1; 884 ++j; 885 if (j >= sizeof(integer)*BITSPERBYTE) { 886 j = 0; 887 ++p; 888 i = *p; 889 } 890 e = e->chain; 891 } 892 } 893 894 /* 895 * Print out a set of a subrange type. 896 */ 897 898 private printSetOfRange (t) 899 Symbol t; 900 { 901 register integer i, j, *p; 902 long v; 903 boolean first; 904 905 p = (int *) sp; 906 i = *p; 907 j = 0; 908 v = t->symvalue.rangev.lower; 909 first = true; 910 while (v <= t->symvalue.rangev.upper) { 911 if ((i&1) == 1) { 912 if (first) { 913 first = false; 914 printf("%ld", v); 915 } else { 916 printf(", %ld", v); 917 } 918 } 919 i >>= 1; 920 ++j; 921 if (j >= sizeof(integer)*BITSPERBYTE) { 922 j = 0; 923 ++p; 924 i = *p; 925 } 926 ++v; 927 } 928 } 929 930 /* 931 * Construct a node for subscripting a dynamic or subarray. 932 * The list of indices is left for processing in evalaref, 933 * unlike normal subscripting in which the list is expanded 934 * across individual INDEX nodes. 935 */ 936 937 private Node dynref (a, t, slist) 938 Node a; 939 Symbol t; 940 Node slist; 941 { 942 Node p, r; 943 integer n; 944 945 p = slist; 946 n = 0; 947 while (p != nil) { 948 if (not compatible(p->value.arg[0]->nodetype, t_int)) { 949 suberror("subscript \"", p->value.arg[0], "\" is the wrong type"); 950 } 951 ++n; 952 p = p->value.arg[1]; 953 } 954 if (n > t->symvalue.ndims and (t->symvalue.ndims != 0 or n != 1)) { 955 suberror("too many subscripts for ", a, nil); 956 } else if (n < t->symvalue.ndims) { 957 suberror("not enough subscripts for ", a, nil); 958 } 959 r = build(O_INDEX, a, slist); 960 r->nodetype = rtype(t->type); 961 return r; 962 } 963 964 /* 965 * Construct a node for subscripting. 966 */ 967 968 public Node modula2_buildaref (a, slist) 969 Node a, slist; 970 { 971 register Symbol t; 972 register Node p; 973 Symbol eltype; 974 Node esub, r; 975 integer n; 976 977 t = rtype(a->nodetype); 978 switch (t->class) { 979 case OPENARRAY: 980 case DYNARRAY: 981 case SUBARRAY: 982 r = dynref(a, t, slist); 983 break; 984 985 case ARRAY: 986 r = a; 987 eltype = rtype(t->type); 988 p = slist; 989 t = t->chain; 990 while (p != nil and t != nil) { 991 esub = p->value.arg[0]; 992 if (not compatible(rtype(t), rtype(esub->nodetype))) { 993 suberror("subscript \"", esub, "\" is the wrong type"); 994 } 995 r = build(O_INDEX, r, esub); 996 r->nodetype = eltype; 997 p = p->value.arg[1]; 998 t = t->chain; 999 } 1000 if (p != nil) { 1001 suberror("too many subscripts for ", a, nil); 1002 } else if (t != nil) { 1003 suberror("not enough subscripts for ", a, nil); 1004 } 1005 break; 1006 1007 default: 1008 suberror("\"", a, "\" is not an array"); 1009 break; 1010 } 1011 return r; 1012 } 1013 1014 /* 1015 * Subscript usage error reporting. 1016 */ 1017 1018 private suberror (s1, e1, s2) 1019 String s1, s2; 1020 Node e1; 1021 { 1022 beginerrmsg(); 1023 if (s1 != nil) { 1024 fprintf(stderr, s1); 1025 } 1026 if (e1 != nil) { 1027 prtree(stderr, e1); 1028 } 1029 if (s2 != nil) { 1030 fprintf(stderr, s2); 1031 } 1032 enderrmsg(); 1033 } 1034 1035 /* 1036 * Check that a subscript value is in the appropriate range. 1037 */ 1038 1039 private subchk (value, lower, upper) 1040 long value, lower, upper; 1041 { 1042 if (value < lower or value > upper) { 1043 error("subscript value %d out of range [%d..%d]", value, lower, upper); 1044 } 1045 } 1046 1047 /* 1048 * Compute the offset for subscripting a dynamic array. 1049 */ 1050 1051 private getdynoff (ndims, sub) 1052 integer ndims; 1053 long *sub; 1054 { 1055 long k, off, *count; 1056 1057 count = (long *) sp; 1058 off = 0; 1059 for (k = 0; k < ndims - 1; k++) { 1060 subchk(sub[k], 0, count[k] - 1); 1061 off += (sub[k] * count[k+1]); 1062 } 1063 subchk(sub[ndims - 1], 0, count[ndims - 1] - 1); 1064 return off + sub[ndims - 1]; 1065 } 1066 1067 /* 1068 * Compute the offset associated with a subarray. 1069 */ 1070 1071 private getsuboff (ndims, sub) 1072 integer ndims; 1073 long *sub; 1074 { 1075 long k, off; 1076 struct subarrayinfo { 1077 long count; 1078 long mult; 1079 } *info; 1080 1081 info = (struct subarrayinfo *) sp; 1082 off = 0; 1083 for (k = 0; k < ndims; k++) { 1084 subchk(sub[k], 0, info[k].count - 1); 1085 off += sub[k] * info[k].mult; 1086 } 1087 return off; 1088 } 1089 1090 /* 1091 * Evaluate a subscript index. 1092 */ 1093 1094 public modula2_evalaref (s, base, i) 1095 Symbol s; 1096 Address base; 1097 long i; 1098 { 1099 Symbol t; 1100 long lb, ub, off; 1101 long *sub; 1102 Address b; 1103 1104 t = rtype(s); 1105 if (t->class == ARRAY) { 1106 findbounds(rtype(t->chain), &lb, &ub); 1107 if (i < lb or i > ub) { 1108 error("subscript %d out of range [%d..%d]", i, lb, ub); 1109 } 1110 push(long, base + (i - lb) * size(t->type)); 1111 } else if ((t->class == OPENARRAY or t->class == DYNARRAY) and 1112 t->symvalue.ndims == 0 1113 ) { 1114 push(long, base + i * size(t->type)); 1115 } else if (t->class == OPENARRAY or t->class == DYNARRAY or 1116 t->class == SUBARRAY 1117 ) { 1118 push(long, i); 1119 sub = (long *) (sp - (t->symvalue.ndims * sizeof(long))); 1120 rpush(base, size(t)); 1121 sp -= (t->symvalue.ndims * sizeof(long)); 1122 b = pop(Address); 1123 sp += sizeof(Address); 1124 if (t->class == SUBARRAY) { 1125 off = getsuboff(t->symvalue.ndims, sub); 1126 } else { 1127 off = getdynoff(t->symvalue.ndims, sub); 1128 } 1129 sp = (Stack *) sub; 1130 push(long, b + off * size(t->type)); 1131 } else { 1132 error("[internal error: expected array in evalaref]"); 1133 } 1134 } 1135 1136 /* 1137 * Initial Modula-2 type information. 1138 */ 1139 1140 #define NTYPES 12 1141 1142 private Symbol inittype[NTYPES + 1]; 1143 1144 private addType (n, s, lower, upper) 1145 integer n; 1146 String s; 1147 long lower, upper; 1148 { 1149 register Symbol t; 1150 1151 if (n > NTYPES) { 1152 panic("initial Modula-2 type number too large for '%s'", s); 1153 } 1154 t = insert(identname(s, true)); 1155 t->language = mod2; 1156 t->class = TYPE; 1157 t->type = newSymbol(nil, 0, RANGE, t, nil); 1158 t->type->symvalue.rangev.lower = lower; 1159 t->type->symvalue.rangev.upper = upper; 1160 t->type->language = mod2; 1161 inittype[n] = t; 1162 } 1163 1164 private initModTypes () 1165 { 1166 addType(1, "integer", 0x80000000L, 0x7fffffffL); 1167 addType(2, "char", 0L, 255L); 1168 addType(3, "boolean", 0L, 1L); 1169 addType(4, "unsigned", 0L, 0xffffffffL); 1170 addType(5, "real", 4L, 0L); 1171 addType(6, "longreal", 8L, 0L); 1172 addType(7, "word", 0L, 0xffffffffL); 1173 addType(8, "byte", 0L, 255L); 1174 addType(9, "address", 0L, 0xffffffffL); 1175 addType(10, "file", 0L, 0xffffffffL); 1176 addType(11, "process", 0L, 0xffffffffL); 1177 addType(12, "cardinal", 0L, 0x7fffffffL); 1178 } 1179 1180 /* 1181 * Initialize typetable. 1182 */ 1183 1184 public modula2_modinit (typetable) 1185 Symbol typetable[]; 1186 { 1187 register integer i; 1188 1189 if (not initialized) { 1190 initModTypes(); 1191 initialized = true; 1192 } 1193 for (i = 1; i <= NTYPES; i++) { 1194 typetable[i] = inittype[i]; 1195 } 1196 } 1197 1198 public boolean modula2_hasmodules () 1199 { 1200 return true; 1201 } 1202 1203 public boolean modula2_passaddr (param, exprtype) 1204 Symbol param, exprtype; 1205 { 1206 return false; 1207 } 1208