Return to pascal.c CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / dbx

Annotation of 42BSD/ucb/dbx/pascal.c, revision 1.1

1.1     ! root        1: /* Copyright (c) 1982 Regents of the University of California */
        !             2: 
        !             3: static char sccsid[] = "@(#)pascal.c 1.2 12/15/82";
        !             4: 
        !             5: /*
        !             6:  * Pascal-dependent symbol routines.
        !             7:  */
        !             8: 
        !             9: #include "defs.h"
        !            10: #include "symbols.h"
        !            11: #include "pascal.h"
        !            12: #include "languages.h"
        !            13: #include "tree.h"
        !            14: #include "eval.h"
        !            15: #include "mappings.h"
        !            16: #include "process.h"
        !            17: #include "runtime.h"
        !            18: #include "machine.h"
        !            19: 
        !            20: #ifndef public
        !            21: #endif
        !            22: 
        !            23: /*
        !            24:  * Initialize Pascal information.
        !            25:  */
        !            26: 
        !            27: public pascal_init()
        !            28: {
        !            29:     Language lang;
        !            30: 
        !            31:     lang = language_define("pascal", ".p");
        !            32:     language_setop(lang, L_PRINTDECL, pascal_printdecl);
        !            33:     language_setop(lang, L_PRINTVAL, pascal_printval);
        !            34:     language_setop(lang, L_TYPEMATCH, pascal_typematch);
        !            35: }
        !            36: 
        !            37: /*
        !            38:  * Compatible tests if two types are compatible.  The issue
        !            39:  * is complicated a bit by ranges.
        !            40:  *
        !            41:  * Integers and reals are not compatible since they cannot always be mixed.
        !            42:  */
        !            43: 
        !            44: public Boolean pascal_typematch(type1, type2)
        !            45: Symbol type1, type2;
        !            46: {
        !            47:     Boolean b;
        !            48:     register Symbol t1, t2;
        !            49: 
        !            50:     t1 = rtype(t1);
        !            51:     t2 = rtype(t2);
        !            52:     b = (Boolean)
        !            53:        (t1->type == t2->type and (
        !            54:            (t1->class == RANGE and t2->class == RANGE) or
        !            55:            (t1->class == SCAL and t2->class == CONST) or
        !            56:            (t1->class == CONST and t2->class == SCAL) or
        !            57:            (t1->type == t_char and t1->class == ARRAY and t2->class == ARRAY)
        !            58:        ) or
        !            59:        (t1 == t_nil and t2->class == PTR) or
        !            60:        (t1->class == PTR and t2 == t_nil)
        !            61:     );
        !            62:     return b;
        !            63: }
        !            64: 
        !            65: public pascal_printdecl(s)
        !            66: Symbol s;
        !            67: {
        !            68:     register Symbol t;
        !            69:     Boolean semicolon;
        !            70: 
        !            71:     semicolon = true;
        !            72:     switch (s->class) {
        !            73:        case CONST:
        !            74:            if (s->type->class == SCAL) {
        !            75:                printf("(enumeration constant, ord %ld)",
        !            76:                    s->symvalue.iconval);
        !            77:            } else {
        !            78:                printf("const %s = ", symname(s));
        !            79:                printval(s);
        !            80:            }
        !            81:            break;
        !            82: 
        !            83:        case TYPE:
        !            84:            printf("type %s = ", symname(s));
        !            85:            printtype(s, s->type);
        !            86:            break;
        !            87: 
        !            88:        case VAR:
        !            89:            if (isparam(s)) {
        !            90:                printf("(parameter) %s : ", symname(s));
        !            91:            } else {
        !            92:                printf("var %s : ", symname(s));
        !            93:            }
        !            94:            printtype(s, s->type);
        !            95:            break;
        !            96: 
        !            97:        case REF:
        !            98:            printf("(var parameter) %s : ", symname(s));
        !            99:            printtype(s, s->type);
        !           100:            break;
        !           101: 
        !           102:        case RANGE:
        !           103:        case ARRAY:
        !           104:        case RECORD:
        !           105:        case VARNT:
        !           106:        case PTR:
        !           107:            printtype(s, s);
        !           108:            semicolon = false;
        !           109:            break;
        !           110: 
        !           111:        case FVAR:
        !           112:            printf("(function variable) %s : ", symname(s));
        !           113:            printtype(s, s->type);
        !           114:            break;
        !           115: 
        !           116:        case FIELD:
        !           117:            printf("(field) %s : ", symname(s));
        !           118:            printtype(s, s->type);
        !           119:            break;
        !           120: 
        !           121:        case PROC:
        !           122:            printf("procedure %s", symname(s));
        !           123:            listparams(s);
        !           124:            break;
        !           125: 
        !           126:        case PROG:
        !           127:            printf("program %s", symname(s));
        !           128:            t = s->chain;
        !           129:            if (t != nil) {
        !           130:                printf("(%s", symname(t));
        !           131:                for (t = t->chain; t != nil; t = t->chain) {
        !           132:                    printf(", %s", symname(t));
        !           133:                }
        !           134:                printf(")");
        !           135:            }
        !           136:            break;
        !           137: 
        !           138:        case FUNC:
        !           139:            printf("function %s", symname(s));
        !           140:            listparams(s);
        !           141:            printf(" : ");
        !           142:            printtype(s, s->type);
        !           143:            break;
        !           144: 
        !           145:        default:
        !           146:            error("class %s in printdecl", classname(s));
        !           147:     }
        !           148:     if (semicolon) {
        !           149:        putchar(';');
        !           150:     }
        !           151:     putchar('\n');
        !           152: }
        !           153: 
        !           154: /*
        !           155:  * Recursive whiz-bang procedure to print the type portion
        !           156:  * of a declaration.  Doesn't work quite right for variant records.
        !           157:  *
        !           158:  * The symbol associated with the type is passed to allow
        !           159:  * searching for type names without getting "type blah = blah".
        !           160:  */
        !           161: 
        !           162: private printtype(s, t)
        !           163: Symbol s;
        !           164: Symbol t;
        !           165: {
        !           166:     register Symbol tmp;
        !           167: 
        !           168:     switch (t->class) {
        !           169:        case VAR:
        !           170:        case CONST:
        !           171:        case FUNC:
        !           172:        case PROC:
        !           173:            panic("printtype: class %s", classname(t));
        !           174:            break;
        !           175: 
        !           176:        case ARRAY:
        !           177:            printf("array[");
        !           178:            tmp = t->chain;
        !           179:            if (tmp != nil) {
        !           180:                for (;;) {
        !           181:                    printtype(tmp, tmp);
        !           182:                    tmp = tmp->chain;
        !           183:                    if (tmp == nil) {
        !           184:                        break;
        !           185:                    }
        !           186:                    printf(", ");
        !           187:                }
        !           188:            }
        !           189:            printf("] of ");
        !           190:            printtype(t, t->type);
        !           191:            break;
        !           192: 
        !           193:        case RECORD:
        !           194:            printf("record\n");
        !           195:            if (t->chain != nil) {
        !           196:                printtype(t->chain, t->chain);
        !           197:            }
        !           198:            printf("end");
        !           199:            break;
        !           200: 
        !           201:        case FIELD:
        !           202:            if (t->chain != nil) {
        !           203:                printtype(t->chain, t->chain);
        !           204:            }
        !           205:            printf("\t%s : ", symname(t));
        !           206:            printtype(t, t->type);
        !           207:            printf(";\n");
        !           208:            break;
        !           209: 
        !           210:        case RANGE: {
        !           211:            long r0, r1;
        !           212: 
        !           213:            r0 = t->symvalue.rangev.lower;
        !           214:            r1 = t->symvalue.rangev.upper;
        !           215:            if (t == t_char) {
        !           216:                if (r0 < 0x20 or r0 > 0x7e) {
        !           217:                    printf("%ld..", r0);
        !           218:                } else {
        !           219:                    printf("'%c'..", (char) r0);
        !           220:                }
        !           221:                if (r1 < 0x20 or r1 > 0x7e) {
        !           222:                    printf("\\%lo", r1);
        !           223:                } else {
        !           224:                    printf("'%c'", (char) r1);
        !           225:                }
        !           226:            } else if (r0 > 0 and r1 == 0) {
        !           227:                printf("%ld byte real", r0);
        !           228:            } else if (r0 >= 0) {
        !           229:                printf("%lu..%lu", r0, r1);
        !           230:            } else {
        !           231:                printf("%ld..%ld", r0, r1);
        !           232:            }
        !           233:            break;
        !           234:        }
        !           235: 
        !           236:        case PTR:
        !           237:            putchar('*');
        !           238:            printtype(t, t->type);
        !           239:            break;
        !           240: 
        !           241:        case TYPE:
        !           242:            if (symname(t) != nil) {
        !           243:                printf("%s", symname(t));
        !           244:            } else {
        !           245:                printtype(t, t->type);
        !           246:            }
        !           247:            break;
        !           248: 
        !           249:        case SCAL:
        !           250:            printf("(");
        !           251:            t = t->type->chain;
        !           252:            if (t != nil) {
        !           253:                printf("%s", symname(t));
        !           254:                t = t->chain;
        !           255:                while (t != nil) {
        !           256:                    printf(", %s", symname(t));
        !           257:                    t = t->chain;
        !           258:                }
        !           259:            } else {
        !           260:                panic("empty enumeration");
        !           261:            }
        !           262:            printf(")");
        !           263:            break;
        !           264: 
        !           265:        default:
        !           266:            printf("(class %d)", t->class);
        !           267:            break;
        !           268:     }
        !           269: }
        !           270: 
        !           271: /*
        !           272:  * List the parameters of a procedure or function.
        !           273:  * No attempt is made to combine like types.
        !           274:  */
        !           275: 
        !           276: private listparams(s)
        !           277: Symbol s;
        !           278: {
        !           279:     Symbol t;
        !           280: 
        !           281:     if (s->chain != nil) {
        !           282:        putchar('(');
        !           283:        for (t = s->chain; t != nil; t = t->chain) {
        !           284:            switch (t->class) {
        !           285:                case REF:
        !           286:                    printf("var ");
        !           287:                    break;
        !           288: 
        !           289:                case FPROC:
        !           290:                    printf("procedure ");
        !           291:                    break;
        !           292: 
        !           293:                case FFUNC:
        !           294:                    printf("function ");
        !           295:                    break;
        !           296: 
        !           297:                case VAR:
        !           298:                    break;
        !           299: 
        !           300:                default:
        !           301:                    panic("unexpected class %d for parameter", t->class);
        !           302:            }
        !           303:            printf("%s : ", symname(t));
        !           304:            printtype(t, t->type);
        !           305:            if (t->chain != nil) {
        !           306:                printf("; ");
        !           307:            }
        !           308:        }
        !           309:        putchar(')');
        !           310:     }
        !           311: }
        !           312: 
        !           313: /*
        !           314:  * Print out the value on the top of the expression stack
        !           315:  * in the format for the type of the given symbol.
        !           316:  */
        !           317: 
        !           318: public pascal_printval(s)
        !           319: Symbol s;
        !           320: {
        !           321:     Symbol t;
        !           322:     Address a;
        !           323:     int len;
        !           324:     double r;
        !           325: 
        !           326:     if (s->class == REF) {
        !           327:        s = s->type;
        !           328:     }
        !           329:     switch (s->class) {
        !           330:        case TYPE:
        !           331:            pascal_printval(s->type);
        !           332:            break;
        !           333: 
        !           334:        case ARRAY:
        !           335:            t = rtype(s->type);
        !           336:            if (t==t_char or (t->class==RANGE and t->type==t_char)) {
        !           337:                len = size(s);
        !           338:                sp -= len;
        !           339:                printf("'%.*s'", len, sp);
        !           340:                break;
        !           341:            } else {
        !           342:                printarray(s);
        !           343:            }
        !           344:            break;
        !           345: 
        !           346:        case RECORD:
        !           347:            printrecord(s);
        !           348:            break;
        !           349: 
        !           350:        case VARNT:
        !           351:            error("can't print out variant records");
        !           352:            break;
        !           353: 
        !           354: 
        !           355:        case RANGE:
        !           356:            if (s == t_boolean) {
        !           357:                printf(((Boolean) popsmall(s)) == true ? "true" : "false");
        !           358:            } else if (s == t_char) {
        !           359:                printf("'%c'", pop(char));
        !           360:            } else if (s->symvalue.rangev.upper == 0 and
        !           361:                        s->symvalue.rangev.lower > 0) {
        !           362:                switch (s->symvalue.rangev.lower) {
        !           363:                    case sizeof(float):
        !           364:                        prtreal(pop(float));
        !           365:                        break;
        !           366: 
        !           367:                    case sizeof(double):
        !           368:                        prtreal(pop(double));
        !           369:                        break;
        !           370: 
        !           371:                    default:
        !           372:                        panic("bad real size %d", s->symvalue.rangev.lower);
        !           373:                        break;
        !           374:                }
        !           375:            } else if (s->symvalue.rangev.lower >= 0) {
        !           376:                printf("%lu", popsmall(s));
        !           377:            } else {
        !           378:                printf("%ld", popsmall(s));
        !           379:            }
        !           380:            break;
        !           381: 
        !           382:        case FILET:
        !           383:        case PTR: {
        !           384:            Address addr;
        !           385: 
        !           386:            addr = pop(Address);
        !           387:            if (addr == 0) {
        !           388:                printf("0, (nil)");
        !           389:            } else {
        !           390:                printf("0x%x, 0%o", addr, addr);
        !           391:            }
        !           392:            break;
        !           393:        }
        !           394: 
        !           395:        case FIELD:
        !           396:            error("missing record specification");
        !           397:            break;
        !           398: 
        !           399:        case SCAL: {
        !           400:            int scalar;
        !           401:            Boolean found;
        !           402: 
        !           403:            scalar = popsmall(s);
        !           404:            found = false;
        !           405:            for (t = s->chain; t != nil; t = t->chain) {
        !           406:                if (t->symvalue.iconval == scalar) {
        !           407:                    printf("%s", symname(t));
        !           408:                    found = true;
        !           409:                    break;
        !           410:                }
        !           411:            }
        !           412:            if (not found) {
        !           413:                printf("(scalar = %d)", scalar);
        !           414:            }
        !           415:            break;
        !           416:        }
        !           417: 
        !           418:        case FPROC:
        !           419:        case FFUNC:
        !           420:        {
        !           421:            Address a;
        !           422: 
        !           423:            a = fparamaddr(pop(long));
        !           424:            t = whatblock(a);
        !           425:            if (t == nil) {
        !           426:                printf("(proc %d)", a);
        !           427:            } else {
        !           428:                printf("%s", symname(t));
        !           429:            }
        !           430:            break;
        !           431:        }
        !           432: 
        !           433:        default:
        !           434:            if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
        !           435:                panic("printval: bad class %d", ord(s->class));
        !           436:            }
        !           437:            error("don't know how to print a %s", classname(s));
        !           438:            /* NOTREACHED */
        !           439:     }
        !           440: }

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