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