Return to pascal.c CVS log

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

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

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