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