4.3BSD - /usr/src/ucb/dbx/modula-2.c

   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: }

Defined functions

Defined variables

Defined struct's

Defined macros