Return to modula-2.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / dbx

Annotation of 43BSDTahoe/ucb/dbx/modula-2.c, revision 1.1

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.2 (Berkeley) 1/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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.