Return to pascal.c CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / dbx

Annotation of 43BSDReno/pgrm/dbx/pascal.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * Copyright (c) 1983 The Regents of the University of California.
        !             3:  * All rights reserved.
        !             4:  *
        !             5:  * Redistribution and use in source and binary forms are permitted
        !             6:  * provided that: (1) source distributions retain this entire copyright
        !             7:  * notice and comment, and (2) distributions including binaries display
        !             8:  * the following acknowledgement:  ``This product includes software
        !             9:  * developed by the University of California, Berkeley and its contributors''
        !            10:  * in the documentation or other materials provided with the distribution
        !            11:  * and in all advertising materials mentioning features or use of this
        !            12:  * software. Neither the name of the University nor the names of its
        !            13:  * contributors may be used to endorse or promote products derived
        !            14:  * from this software without specific prior written permission.
        !            15:  * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
        !            16:  * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
        !            17:  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
        !            18:  */
        !            19: 
        !            20: #ifndef lint
        !            21: static char sccsid[] = "@(#)pascal.c   5.3 (Berkeley) 6/1/90";
        !            22: #endif /* not lint */
        !            23: 
        !            24: /*
        !            25:  * Pascal-dependent symbol routines.
        !            26:  */
        !            27: 
        !            28: #include "defs.h"
        !            29: #include "symbols.h"
        !            30: #include "pascal.h"
        !            31: #include "languages.h"
        !            32: #include "tree.h"
        !            33: #include "eval.h"
        !            34: #include "mappings.h"
        !            35: #include "process.h"
        !            36: #include "runtime.h"
        !            37: #include "machine.h"
        !            38: 
        !            39: #ifndef public
        !            40: #endif
        !            41: 
        !            42: private Language pasc;
        !            43: private boolean initialized;
        !            44: 
        !            45: /*
        !            46:  * Initialize Pascal information.
        !            47:  */
        !            48: 
        !            49: public pascal_init()
        !            50: {
        !            51:     pasc = language_define("pascal", ".p");
        !            52:     language_setop(pasc, L_PRINTDECL, pascal_printdecl);
        !            53:     language_setop(pasc, L_PRINTVAL, pascal_printval);
        !            54:     language_setop(pasc, L_TYPEMATCH, pascal_typematch);
        !            55:     language_setop(pasc, L_BUILDAREF, pascal_buildaref);
        !            56:     language_setop(pasc, L_EVALAREF, pascal_evalaref);
        !            57:     language_setop(pasc, L_MODINIT, pascal_modinit);
        !            58:     language_setop(pasc, L_HASMODULES, pascal_hasmodules);
        !            59:     language_setop(pasc, L_PASSADDR, pascal_passaddr);
        !            60:     initialized = false;
        !            61: }
        !            62: 
        !            63: /*
        !            64:  * Typematch tests if two types are compatible.  The issue
        !            65:  * is a bit complicated, so several subfunctions are used for
        !            66:  * various kinds of compatibility.
        !            67:  */
        !            68: 
        !            69: private boolean builtinmatch (t1, t2)
        !            70: register Symbol t1, t2;
        !            71: {
        !            72:     boolean b;
        !            73: 
        !            74:     b = (boolean) (
        !            75:        (
        !            76:            t2 == t_int->type and
        !            77:            t1->class == RANGE and istypename(t1->type, "integer")
        !            78:        ) or (
        !            79:            t2 == t_char->type and
        !            80:            t1->class == RANGE and istypename(t1->type, "char")
        !            81:        ) or (
        !            82:            t2 == t_real->type and
        !            83:            t1->class == RANGE and istypename(t1->type, "real")
        !            84:        ) or (
        !            85:            t2 == t_boolean->type and
        !            86:            t1->class == RANGE and istypename(t1->type, "boolean")
        !            87:        )
        !            88:     );
        !            89:     return b;
        !            90: }
        !            91: 
        !            92: private boolean rangematch (t1, t2)
        !            93: register Symbol t1, t2;
        !            94: {
        !            95:     boolean b;
        !            96:     register Symbol rt1, rt2;
        !            97: 
        !            98:     if (t1->class == RANGE and t2->class == RANGE) {
        !            99:        rt1 = rtype(t1->type);
        !           100:        rt2 = rtype(t2->type);
        !           101:        b = (boolean) (rt1->type == rt2->type);
        !           102:     } else {
        !           103:        b = false;
        !           104:     }
        !           105:     return b;
        !           106: }
        !           107: 
        !           108: private boolean nilMatch (t1, t2)
        !           109: register Symbol t1, t2;
        !           110: {
        !           111:     boolean b;
        !           112: 
        !           113:     b = (boolean) (
        !           114:        (t1 == t_nil and t2->class == PTR) or
        !           115:        (t1->class == PTR and t2 == t_nil)
        !           116:     );
        !           117:     return b;
        !           118: }
        !           119: 
        !           120: private boolean enumMatch (t1, t2)
        !           121: register Symbol t1, t2;
        !           122: {
        !           123:     boolean b;
        !           124: 
        !           125:     b = (boolean) (
        !           126:        (t1->class == SCAL and t2->class == CONST and t2->type == t1) or
        !           127:        (t1->class == CONST and t2->class == SCAL and t1->type == t2)
        !           128:     );
        !           129:     return b;
        !           130: }
        !           131: 
        !           132: private boolean isConstString (t)
        !           133: register Symbol t;
        !           134: {
        !           135:     boolean b;
        !           136: 
        !           137:     b = (boolean) (
        !           138:        t->language == primlang and t->class == ARRAY and t->type == t_char
        !           139:     );
        !           140:     return b;
        !           141: }
        !           142: 
        !           143: private boolean stringArrayMatch (t1, t2)
        !           144: register Symbol t1, t2;
        !           145: {
        !           146:     boolean b;
        !           147: 
        !           148:     b = (boolean) (
        !           149:        (
        !           150:            isConstString(t1) and
        !           151:            t2->class == ARRAY and compatible(t2->type, t_char->type)
        !           152:        ) or (
        !           153:            isConstString(t2) and
        !           154:            t1->class == ARRAY and compatible(t1->type, t_char->type)
        !           155:        )
        !           156:     );
        !           157:     return b;
        !           158: }
        !           159: 
        !           160: public boolean pascal_typematch (type1, type2)
        !           161: Symbol type1, type2;
        !           162: {
        !           163:     boolean b;
        !           164:     Symbol t1, t2, tmp;
        !           165: 
        !           166:     t1 = rtype(type1);
        !           167:     t2 = rtype(type2);
        !           168:     if (t1 == t2) {
        !           169:        b = true;
        !           170:     } else {
        !           171:        if (t1 == t_char->type or t1 == t_int->type or
        !           172:            t1 == t_real->type or t1 == t_boolean->type
        !           173:        ) {
        !           174:            tmp = t1;
        !           175:            t1 = t2;
        !           176:            t2 = tmp;
        !           177:        }
        !           178:        b = (Boolean) (
        !           179:            builtinmatch(t1, t2) or rangematch(t1, t2) or
        !           180:            nilMatch(t1, t2) or enumMatch(t1, t2) or
        !           181:            stringArrayMatch(t1, t2)
        !           182:        );
        !           183:     }
        !           184:     return b;
        !           185: }
        !           186: 
        !           187: /*
        !           188:  * Indent n spaces.
        !           189:  */
        !           190: 
        !           191: private indent (n)
        !           192: int n;
        !           193: {
        !           194:     if (n > 0) {
        !           195:        printf("%*c", n, ' ');
        !           196:     }
        !           197: }
        !           198: 
        !           199: public pascal_printdecl (s)
        !           200: Symbol s;
        !           201: {
        !           202:     register Symbol t;
        !           203:     Boolean semicolon;
        !           204: 
        !           205:     semicolon = true;
        !           206:     if (s->class == TYPEREF) {
        !           207:        resolveRef(t);
        !           208:     }
        !           209:     switch (s->class) {
        !           210:        case CONST:
        !           211:            if (s->type->class == SCAL) {
        !           212:                semicolon = false;
        !           213:                printf("enum constant, ord ");
        !           214:                eval(s->symvalue.constval);
        !           215:                pascal_printval(s);
        !           216:            } else {
        !           217:                printf("const %s = ", symname(s));
        !           218:                eval(s->symvalue.constval);
        !           219:                pascal_printval(s);
        !           220:            }
        !           221:            break;
        !           222: 
        !           223:        case TYPE:
        !           224:            printf("type %s = ", symname(s));
        !           225:            printtype(s, s->type, 0);
        !           226:            break;
        !           227: 
        !           228:        case TYPEREF:
        !           229:            printf("type %s", symname(s));
        !           230:            break;
        !           231: 
        !           232:        case VAR:
        !           233:            if (isparam(s)) {
        !           234:                printf("(parameter) %s : ", symname(s));
        !           235:            } else {
        !           236:                printf("var %s : ", symname(s));
        !           237:            }
        !           238:            printtype(s, s->type, 0);
        !           239:            break;
        !           240: 
        !           241:        case REF:
        !           242:            printf("(var parameter) %s : ", symname(s));
        !           243:            printtype(s, s->type, 0);
        !           244:            break;
        !           245: 
        !           246:        case RANGE:
        !           247:        case ARRAY:
        !           248:        case RECORD:
        !           249:        case VARNT:
        !           250:        case PTR:
        !           251:        case FILET:
        !           252:            printtype(s, s, 0);
        !           253:            semicolon = false;
        !           254:            break;
        !           255: 
        !           256:        case FVAR:
        !           257:            printf("(function variable) %s : ", symname(s));
        !           258:            printtype(s, s->type, 0);
        !           259:            break;
        !           260: 
        !           261:        case FIELD:
        !           262:            printf("(field) %s : ", symname(s));
        !           263:            printtype(s, s->type, 0);
        !           264:            break;
        !           265: 
        !           266:        case PROC:
        !           267:            printf("procedure %s", symname(s));
        !           268:            listparams(s);
        !           269:            break;
        !           270: 
        !           271:        case PROG:
        !           272:            printf("program %s", symname(s));
        !           273:            listparams(s);
        !           274:            break;
        !           275: 
        !           276:        case FUNC:
        !           277:            printf("function %s", symname(s));
        !           278:            listparams(s);
        !           279:            printf(" : ");
        !           280:            printtype(s, s->type, 0);
        !           281:            break;
        !           282: 
        !           283:        case MODULE:
        !           284:            printf("module %s", symname(s));
        !           285:            break;
        !           286: 
        !           287:          /*
        !           288:           * the parameter list of the following should be printed
        !           289:           * eventually
        !           290:           */
        !           291:        case  FPROC:
        !           292:            printf("procedure %s()", symname(s));
        !           293:            break;
        !           294:        
        !           295:        case FFUNC:
        !           296:            printf("function %s()", symname(s));
        !           297:            break;
        !           298: 
        !           299:        default:
        !           300:            printf("%s : (class %s)", symname(s), classname(s));
        !           301:            break;
        !           302:     }
        !           303:     if (semicolon) {
        !           304:        putchar(';');
        !           305:     }
        !           306:     putchar('\n');
        !           307: }
        !           308: 
        !           309: /*
        !           310:  * Recursive whiz-bang procedure to print the type portion
        !           311:  * of a declaration.
        !           312:  *
        !           313:  * The symbol associated with the type is passed to allow
        !           314:  * searching for type names without getting "type blah = blah".
        !           315:  */
        !           316: 
        !           317: private printtype (s, t, n)
        !           318: Symbol s;
        !           319: Symbol t;
        !           320: int n;
        !           321: {
        !           322:     register Symbol tmp;
        !           323: 
        !           324:     if (t->class == TYPEREF) {
        !           325:        resolveRef(t);
        !           326:     }
        !           327:     switch (t->class) {
        !           328:        case VAR:
        !           329:        case CONST:
        !           330:        case FUNC:
        !           331:        case PROC:
        !           332:            panic("printtype: class %s", classname(t));
        !           333:            break;
        !           334: 
        !           335:        case ARRAY:
        !           336:            printf("array[");
        !           337:            tmp = t->chain;
        !           338:            if (tmp != nil) {
        !           339:                for (;;) {
        !           340:                    printtype(tmp, tmp, n);
        !           341:                    tmp = tmp->chain;
        !           342:                    if (tmp == nil) {
        !           343:                        break;
        !           344:                    }
        !           345:                    printf(", ");
        !           346:                }
        !           347:            }
        !           348:            printf("] of ");
        !           349:            printtype(t, t->type, n);
        !           350:            break;
        !           351: 
        !           352:        case RECORD:
        !           353:            printRecordDecl(t, n);
        !           354:            break;
        !           355: 
        !           356:        case FIELD:
        !           357:            if (t->chain != nil) {
        !           358:                printtype(t->chain, t->chain, n);
        !           359:            }
        !           360:            printf("\t%s : ", symname(t));
        !           361:            printtype(t, t->type, n);
        !           362:            printf(";\n");
        !           363:            break;
        !           364: 
        !           365:        case RANGE:
        !           366:            printRangeDecl(t);
        !           367:            break;
        !           368: 
        !           369:        case PTR:
        !           370:            printf("^");
        !           371:            printtype(t, t->type, n);
        !           372:            break;
        !           373: 
        !           374:        case TYPE:
        !           375:            if (t->name != nil and ident(t->name)[0] != '\0') {
        !           376:                printname(stdout, t);
        !           377:            } else {
        !           378:                printtype(t, t->type, n);
        !           379:            }
        !           380:            break;
        !           381: 
        !           382:        case SCAL:
        !           383:            printEnumDecl(t, n);
        !           384:            break;
        !           385: 
        !           386:        case SET:
        !           387:            printf("set of ");
        !           388:            printtype(t, t->type, n);
        !           389:            break;
        !           390: 
        !           391:        case FILET:
        !           392:            printf("file of ");
        !           393:            printtype(t, t->type, n);
        !           394:            break;
        !           395: 
        !           396:        case TYPEREF:
        !           397:            break;
        !           398:        
        !           399:        case FPROC:
        !           400:            printf("procedure");
        !           401:            break;
        !           402:            
        !           403:        case FFUNC:
        !           404:            printf("function");
        !           405:            break;
        !           406: 
        !           407:        default:
        !           408:            printf("(class %d)", t->class);
        !           409:            break;
        !           410:     }
        !           411: }
        !           412: 
        !           413: /*
        !           414:  * Print out a record declaration.
        !           415:  */
        !           416: 
        !           417: private printRecordDecl (t, n)
        !           418: Symbol t;
        !           419: int n;
        !           420: {
        !           421:     register Symbol f;
        !           422: 
        !           423:     if (t->chain == nil) {
        !           424:        printf("record end");
        !           425:     } else {
        !           426:        printf("record\n");
        !           427:        for (f = t->chain; f != nil; f = f->chain) {
        !           428:            indent(n+4);
        !           429:            printf("%s : ", symname(f));
        !           430:            printtype(f->type, f->type, n+4);
        !           431:            printf(";\n");
        !           432:        }
        !           433:        indent(n);
        !           434:        printf("end");
        !           435:     }
        !           436: }
        !           437: 
        !           438: /*
        !           439:  * Print out the declaration of a range type.
        !           440:  */
        !           441: 
        !           442: private printRangeDecl (t)
        !           443: Symbol t;
        !           444: {
        !           445:     long r0, r1;
        !           446: 
        !           447:     r0 = t->symvalue.rangev.lower;
        !           448:     r1 = t->symvalue.rangev.upper;
        !           449:     if (t == t_char or istypename(t, "char")) {
        !           450:        if (r0 < 0x20 or r0 > 0x7e) {
        !           451:            printf("%ld..", r0);
        !           452:        } else {
        !           453:            printf("'%c'..", (char) r0);
        !           454:        }
        !           455:        if (r1 < 0x20 or r1 > 0x7e) {
        !           456:            printf("\\%lo", r1);
        !           457:        } else {
        !           458:            printf("'%c'", (char) r1);
        !           459:        }
        !           460:     } else if (r0 > 0 and r1 == 0) {
        !           461:        printf("%ld byte real", r0);
        !           462:     } else if (r0 >= 0) {
        !           463:        printf("%lu..%lu", r0, r1);
        !           464:     } else {
        !           465:        printf("%ld..%ld", r0, r1);
        !           466:     }
        !           467: }
        !           468: 
        !           469: /*
        !           470:  * Print out an enumeration declaration.
        !           471:  */
        !           472: 
        !           473: private printEnumDecl (e, n)
        !           474: Symbol e;
        !           475: int n;
        !           476: {
        !           477:     Symbol t;
        !           478: 
        !           479:     printf("(");
        !           480:     t = e->chain;
        !           481:     if (t != nil) {
        !           482:        printf("%s", symname(t));
        !           483:        t = t->chain;
        !           484:        while (t != nil) {
        !           485:            printf(", %s", symname(t));
        !           486:            t = t->chain;
        !           487:        }
        !           488:     }
        !           489:     printf(")");
        !           490: }
        !           491: 
        !           492: /*
        !           493:  * List the parameters of a procedure or function.
        !           494:  * No attempt is made to combine like types.
        !           495:  */
        !           496: 
        !           497: private listparams(s)
        !           498: Symbol s;
        !           499: {
        !           500:     Symbol t;
        !           501: 
        !           502:     if (s->chain != nil) {
        !           503:        putchar('(');
        !           504:        for (t = s->chain; t != nil; t = t->chain) {
        !           505:            switch (t->class) {
        !           506:                case REF:
        !           507:                    printf("var ");
        !           508:                    break;
        !           509: 
        !           510:                case VAR:
        !           511:                    break;
        !           512: 
        !           513:                default:
        !           514:                    panic("unexpected class %d for parameter", t->class);
        !           515:            }
        !           516:            printf("%s : ", symname(t));
        !           517:            printtype(t, t->type);
        !           518:            if (t->chain != nil) {
        !           519:                printf("; ");
        !           520:            }
        !           521:        }
        !           522:        putchar(')');
        !           523:     }
        !           524: }
        !           525: 
        !           526: /*
        !           527:  * Print out the value on the top of the expression stack
        !           528:  * in the format for the type of the given symbol.
        !           529:  */
        !           530: 
        !           531: public pascal_printval (s)
        !           532: Symbol s;
        !           533: {
        !           534:     prval(s, size(s));
        !           535: }
        !           536: 
        !           537: private prval (s, n)
        !           538: Symbol s;
        !           539: integer n;
        !           540: {
        !           541:     Symbol t;
        !           542:     Address a;
        !           543:     integer len;
        !           544:     double r;
        !           545:     integer i;
        !           546: 
        !           547:     if (s->class == TYPEREF) {
        !           548:        resolveRef(s);
        !           549:     }
        !           550:     switch (s->class) {
        !           551:        case CONST:
        !           552:        case TYPE:
        !           553:        case REF:
        !           554:        case VAR:
        !           555:        case FVAR:
        !           556:        case TAG:
        !           557:            prval(s->type, n);
        !           558:            break;
        !           559: 
        !           560:        case FIELD:
        !           561:                prval(s->type, n);
        !           562:            break;
        !           563: 
        !           564:        case ARRAY:
        !           565:            t = rtype(s->type);
        !           566:            if (t == t_char->type or
        !           567:                (t->class == RANGE and istypename(t->type, "char"))
        !           568:            ) {
        !           569:                len = size(s);
        !           570:                sp -= len;
        !           571:                printf("'%.*s'", len, sp);
        !           572:                break;
        !           573:            } else {
        !           574:                printarray(s);
        !           575:            }
        !           576:            break;
        !           577: 
        !           578:        case RECORD:
        !           579:            printrecord(s);
        !           580:            break;
        !           581: 
        !           582:        case VARNT:
        !           583:            printf("[variant]");
        !           584:            break;
        !           585: 
        !           586:        case RANGE:
        !           587:            printrange(s, n);
        !           588:            break;
        !           589: 
        !           590:        case FILET:
        !           591:            a = pop(Address);
        !           592:            if (a == 0) {
        !           593:                printf("nil");
        !           594:            } else {
        !           595:                printf("0x%x", a);
        !           596:            }
        !           597:            break;
        !           598: 
        !           599:        case PTR:
        !           600:            a = pop(Address);
        !           601:            if (a == 0) {
        !           602:                printf("nil");
        !           603:            } else {
        !           604:                printf("0x%x", a);
        !           605:            }
        !           606:            break;
        !           607: 
        !           608:        case SCAL:
        !           609:            i = 0;
        !           610:            popn(n, &i);
        !           611:            if (s->symvalue.iconval < 256) {
        !           612:                i &= 0xff;
        !           613:            } else if (s->symvalue.iconval < 65536) {
        !           614:                i &= 0xffff;
        !           615:            }
        !           616:            printEnum(i, s);
        !           617:            break;
        !           618: 
        !           619:        case FPROC:
        !           620:        case FFUNC:
        !           621:            a = pop(long);
        !           622:            t = whatblock(a);
        !           623:            if (t == nil) {
        !           624:                printf("(proc 0x%x)", a);
        !           625:            } else {
        !           626:                printf("%s", symname(t));
        !           627:            }
        !           628:            break;
        !           629: 
        !           630:        case SET:
        !           631:            printSet(s);
        !           632:            break;
        !           633: 
        !           634:        default:
        !           635:            if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
        !           636:                panic("printval: bad class %d", ord(s->class));
        !           637:            }
        !           638:            printf("[%s]", classname(s));
        !           639:            break;
        !           640:     }
        !           641: }
        !           642: 
        !           643: /*
        !           644:  * Print out the value of a scalar (non-enumeration) type.
        !           645:  */
        !           646: 
        !           647: private printrange (s, n)
        !           648: Symbol s;
        !           649: integer n;
        !           650: {
        !           651:     double d;
        !           652:     float f;
        !           653:     integer i;
        !           654: 
        !           655:     if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
        !           656:        if (n == sizeof(float)) {
        !           657:            popn(n, &f);
        !           658:            d = f;
        !           659:        } else {
        !           660:            popn(n, &d);
        !           661:        }
        !           662:        prtreal(d);
        !           663:     } else {
        !           664:        i = 0;
        !           665:        popn(n, &i);
        !           666:        printRangeVal(i, s);
        !           667:     }
        !           668: }
        !           669: 
        !           670: /*
        !           671:  * Print out a set.
        !           672:  */
        !           673: 
        !           674: private printSet (s)
        !           675: Symbol s;
        !           676: {
        !           677:     Symbol t;
        !           678:     integer nbytes;
        !           679: 
        !           680:     nbytes = size(s);
        !           681:     t = rtype(s->type);
        !           682:     printf("[");
        !           683:     sp -= nbytes;
        !           684:     if (t->class == SCAL) {
        !           685:        printSetOfEnum(t);
        !           686:     } else if (t->class == RANGE) {
        !           687:        printSetOfRange(t);
        !           688:     } else {
        !           689:        error("internal error: expected range or enumerated base type for set");
        !           690:     }
        !           691:     printf("]");
        !           692: }
        !           693: 
        !           694: /*
        !           695:  * Print out a set of an enumeration.
        !           696:  */
        !           697: 
        !           698: private printSetOfEnum (t)
        !           699: Symbol t;
        !           700: {
        !           701:     register Symbol e;
        !           702:     register integer i, j, *p;
        !           703:     boolean first;
        !           704: 
        !           705:     p = (int *) sp;
        !           706:     i = *p;
        !           707:     j = 0;
        !           708:     e = t->chain;
        !           709:     first = true;
        !           710:     while (e != nil) {
        !           711:        if ((i&1) == 1) {
        !           712:            if (first) {
        !           713:                first = false;
        !           714:                printf("%s", symname(e));
        !           715:            } else {
        !           716:                printf(", %s", symname(e));
        !           717:            }
        !           718:        }
        !           719:        i >>= 1;
        !           720:        ++j;
        !           721:        if (j >= sizeof(integer)*BITSPERBYTE) {
        !           722:            j = 0;
        !           723:            ++p;
        !           724:            i = *p;
        !           725:        }
        !           726:        e = e->chain;
        !           727:     }
        !           728: }
        !           729: 
        !           730: /*
        !           731:  * Print out a set of a subrange type.
        !           732:  */
        !           733: 
        !           734: private printSetOfRange (t)
        !           735: Symbol t;
        !           736: {
        !           737:     register integer i, j, *p;
        !           738:     long v;
        !           739:     boolean first;
        !           740: 
        !           741:     p = (int *) sp;
        !           742:     i = *p;
        !           743:     j = 0;
        !           744:     v = t->symvalue.rangev.lower;
        !           745:     first = true;
        !           746:     while (v <= t->symvalue.rangev.upper) {
        !           747:        if ((i&1) == 1) {
        !           748:            if (first) {
        !           749:                first = false;
        !           750:                printf("%ld", v);
        !           751:            } else {
        !           752:                printf(", %ld", v);
        !           753:            }
        !           754:        }
        !           755:        i >>= 1;
        !           756:        ++j;
        !           757:        if (j >= sizeof(integer)*BITSPERBYTE) {
        !           758:            j = 0;
        !           759:            ++p;
        !           760:            i = *p;
        !           761:        }
        !           762:        ++v;
        !           763:     }
        !           764: }
        !           765: 
        !           766: /*
        !           767:  * Construct a node for subscripting.
        !           768:  */
        !           769: 
        !           770: public Node pascal_buildaref (a, slist)
        !           771: Node a, slist;
        !           772: {
        !           773:     register Symbol t;
        !           774:     register Node p;
        !           775:     Symbol etype, atype, eltype;
        !           776:     Node esub, r;
        !           777: 
        !           778:     t = rtype(a->nodetype);
        !           779:     if (t->class != ARRAY) {
        !           780:        beginerrmsg();
        !           781:        prtree(stderr, a);
        !           782:        fprintf(stderr, " is not an array");
        !           783:        enderrmsg();
        !           784:     } else {
        !           785:        r = a;
        !           786:        eltype = t->type;
        !           787:        p = slist;
        !           788:        t = t->chain;
        !           789:        for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) {
        !           790:            esub = p->value.arg[0];
        !           791:            etype = rtype(esub->nodetype);
        !           792:            atype = rtype(t);
        !           793:            if (not compatible(atype, etype)) {
        !           794:                beginerrmsg();
        !           795:                fprintf(stderr, "subscript ");
        !           796:                prtree(stderr, esub);
        !           797:                fprintf(stderr, " is the wrong type");
        !           798:                enderrmsg();
        !           799:            }
        !           800:            r = build(O_INDEX, r, esub);
        !           801:            r->nodetype = eltype;
        !           802:        }
        !           803:        if (p != nil or t != nil) {
        !           804:            beginerrmsg();
        !           805:            if (p != nil) {
        !           806:                fprintf(stderr, "too many subscripts for ");
        !           807:            } else {
        !           808:                fprintf(stderr, "not enough subscripts for ");
        !           809:            }
        !           810:            prtree(stderr, a);
        !           811:            enderrmsg();
        !           812:        }
        !           813:     }
        !           814:     return r;
        !           815: }
        !           816: 
        !           817: /*
        !           818:  * Evaluate a subscript index.
        !           819:  */
        !           820: 
        !           821: public pascal_evalaref (s, base, i)
        !           822: Symbol s;
        !           823: Address base;
        !           824: long i;
        !           825: {
        !           826:     Symbol t;
        !           827:     long lb, ub;
        !           828: 
        !           829:     t = rtype(s);
        !           830:     s = rtype(t->chain);
        !           831:     findbounds(s, &lb, &ub);
        !           832:     if (i < lb or i > ub) {
        !           833:        error("subscript %d out of range [%d..%d]", i, lb, ub);
        !           834:     }
        !           835:     push(long, base + (i - lb) * size(t->type));
        !           836: }
        !           837: 
        !           838: /*
        !           839:  * Initial Pascal type information.
        !           840:  */
        !           841: 
        !           842: #define NTYPES 4
        !           843: 
        !           844: private Symbol inittype[NTYPES + 1];
        !           845: 
        !           846: private addType (n, s, lower, upper)
        !           847: integer n;
        !           848: String s;
        !           849: long lower, upper;
        !           850: {
        !           851:     register Symbol t;
        !           852: 
        !           853:     if (n > NTYPES) {
        !           854:        panic("initial Pascal type number too large for '%s'", s);
        !           855:     }
        !           856:     t = insert(identname(s, true));
        !           857:     t->language = pasc;
        !           858:     t->class = TYPE;
        !           859:     t->type = newSymbol(nil, 0, RANGE, t, nil);
        !           860:     t->type->symvalue.rangev.lower = lower;
        !           861:     t->type->symvalue.rangev.upper = upper;
        !           862:     t->type->language = pasc;
        !           863:     inittype[n] = t;
        !           864: }
        !           865: 
        !           866: private initTypes ()
        !           867: {
        !           868:     addType(1, "boolean", 0L, 1L);
        !           869:     addType(2, "char", 0L, 255L);
        !           870:     addType(3, "integer", 0x80000000L, 0x7fffffffL);
        !           871:     addType(4, "real", 8L, 0L);
        !           872:     initialized = true;
        !           873: }
        !           874: 
        !           875: /*
        !           876:  * Initialize typetable.
        !           877:  */
        !           878: 
        !           879: public pascal_modinit (typetable)
        !           880: Symbol typetable[];
        !           881: {
        !           882:     register integer i;
        !           883: 
        !           884:     if (not initialized) {
        !           885:        initTypes();
        !           886:        initialized = true;
        !           887:     }
        !           888:     for (i = 1; i <= NTYPES; i++) {
        !           889:        typetable[i] = inittype[i];
        !           890:     }
        !           891: }
        !           892: 
        !           893: public boolean pascal_hasmodules ()
        !           894: {
        !           895:     return false;
        !           896: }
        !           897: 
        !           898: public boolean pascal_passaddr (param, exprtype)
        !           899: Symbol param, exprtype;
        !           900: {
        !           901:     return false;
        !           902: }

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