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