Return to proc.c CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / pi

Annotation of 3BSD/cmd/pi/proc.c, revision 1.1

1.1     ! root        1: /* Copyright (c) 1979 Regents of the University of California */
        !             2: #
        !             3: /*
        !             4:  * pi - Pascal interpreter code translator
        !             5:  *
        !             6:  * Charles Haley, Bill Joy UCB
        !             7:  * Version 1.2 November 1978
        !             8:  */
        !             9: 
        !            10: #include "whoami"
        !            11: #include "0.h"
        !            12: #include "tree.h"
        !            13: #include "opcode.h"
        !            14: 
        !            15: /*
        !            16:  * The following arrays are used to determine which classes may be
        !            17:  * read and written to/from text files.
        !            18:  * They are indexed by the return types from classify.
        !            19:  */
        !            20: #define rdops(x) rdxxxx[(x)-(TFIRST)]
        !            21: #define wrops(x) wrxxxx[(x)-(TFIRST)]
        !            22: 
        !            23: int rdxxxx[] = {
        !            24:        0,              /* -7  file types */
        !            25:        0,              /* -6  record types */
        !            26:        0,              /* -5  array types */
        !            27:        0,              /* -4  scalar types */
        !            28:        0,              /* -3  pointer types */
        !            29:        0,              /* -2  set types */
        !            30:        0,              /* -1  string types */
        !            31:        0,              /*  0  nil - i.e. no type */
        !            32:        0,              /*  1  booleans */
        !            33:        O_READC,        /*  2  character */
        !            34:        O_READ4,        /*  3  integer */
        !            35:        O_READ8         /*  4  real */
        !            36: };
        !            37: 
        !            38: int wrxxxx[] = {
        !            39:        0,              /* -7  file types */
        !            40:        0,              /* -6  record types */
        !            41:        0,              /* -5  array types */
        !            42:        0,              /* -4  scalar types */
        !            43:        0,              /* -3  pointer types */
        !            44:        0,              /* -2  set types */
        !            45:        O_WRITG,        /* -1  string types */
        !            46:        0,              /*  0  nil - i.e. no type */
        !            47:        O_WRITB,        /*  1  booleans */
        !            48:        O_WRITC,        /*  2  character */
        !            49:        O_WRIT4,        /*  3  integer */
        !            50:        O_WRIT8,        /*  4  real */
        !            51: };
        !            52: 
        !            53: /*
        !            54:  * Proc handles procedure calls.
        !            55:  * Non-builtin procedures are "buck-passed" to func (with a flag
        !            56:  * indicating that they are actually procedures.
        !            57:  * builtin procedures are handled here.
        !            58:  */
        !            59: proc(r)
        !            60:        int *r;
        !            61: {
        !            62:        register struct nl *p;
        !            63:        register int *al, op;
        !            64:        struct nl *filetype, *ap;
        !            65:        int argc, *argv, c, two, oct, hex, *file;
        !            66:        int pu;
        !            67:        int *pua, *pui, *puz;
        !            68:        int i, j, k;
        !            69: 
        !            70:        /*
        !            71:         * Verify that the name is
        !            72:         * defined and is that of a
        !            73:         * procedure.
        !            74:         */
        !            75:        p = lookup(r[2]);
        !            76:        if (p == NIL) {
        !            77:                rvlist(r[3]);
        !            78:                return;
        !            79:        }
        !            80:        if (p->class != PROC) {
        !            81:                error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
        !            82:                rvlist(r[3]);
        !            83:                return;
        !            84:        }
        !            85:        argv = r[3];
        !            86: 
        !            87:        /*
        !            88:         * Call handles user defined
        !            89:         * procedures and functions.
        !            90:         */
        !            91:        if (bn != 0) {
        !            92:                call(p, argv, PROC, bn);
        !            93:                return;
        !            94:        }
        !            95: 
        !            96:        /*
        !            97:         * Call to built-in procedure.
        !            98:         * Count the arguments.
        !            99:         */
        !           100:        argc = 0;
        !           101:        for (al = argv; al != NIL; al = al[2])
        !           102:                argc++;
        !           103: 
        !           104:        /*
        !           105:         * Switch on the operator
        !           106:         * associated with the built-in
        !           107:         * procedure in the namelist
        !           108:         */
        !           109:        op = p->value[0] &~ NSTAND;
        !           110:        if (opt('s') && (p->value[0] & NSTAND)) {
        !           111:                standard();
        !           112:                error("%s is a nonstandard procedure", p->symbol);
        !           113:        }
        !           114:        switch (op) {
        !           115: 
        !           116:        case O_NULL:
        !           117:                if (argc != 0)
        !           118:                        error("null takes no arguments");
        !           119:                return;
        !           120: 
        !           121:        case O_FLUSH:
        !           122:                if (argc == 0) {
        !           123:                        put1(O_MESSAGE);
        !           124:                        return;
        !           125:                }
        !           126:                if (argc != 1) {
        !           127:                        error("flush takes at most one argument");
        !           128:                        return;
        !           129:                }
        !           130:                ap = rvalue(argv[1], NIL);
        !           131:                if (ap == NIL)
        !           132:                        return;
        !           133:                if (ap->class != FILET) {
        !           134:                        error("flush's argument must be a file, not %s", nameof(ap));
        !           135:                        return;
        !           136:                }
        !           137:                put1(op);
        !           138:                return;
        !           139: 
        !           140:        case O_MESSAGE:
        !           141:        case O_WRIT2:
        !           142:        case O_WRITLN:
        !           143:                /*
        !           144:                 * Set up default file "output"'s type
        !           145:                 */
        !           146:                file = NIL;
        !           147:                filetype = nl+T1CHAR;
        !           148:                /*
        !           149:                 * Determine the file implied
        !           150:                 * for the write and generate
        !           151:                 * code to make it the active file.
        !           152:                 */
        !           153:                if (op == O_MESSAGE) {
        !           154:                        /*
        !           155:                         * For message, all that matters
        !           156:                         * is that the filetype is
        !           157:                         * a character file.
        !           158:                         * Thus "output" will suit us fine.
        !           159:                         */
        !           160:                        put1(O_MESSAGE);
        !           161:                } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) {
        !           162:                        /*
        !           163:                         * If there is a first argument which has
        !           164:                         * no write widths, then it is potentially
        !           165:                         * a file name.
        !           166:                         */
        !           167:                        codeoff();
        !           168:                        ap = rvalue(argv[1], NIL);
        !           169:                        codeon();
        !           170:                        if (ap == NIL)
        !           171:                                argv = argv[2];
        !           172:                        if (ap != NIL && ap->class == FILET) {
        !           173:                                /*
        !           174:                                 * Got "write(f, ...", make
        !           175:                                 * f the active file, and save
        !           176:                                 * it and its type for use in
        !           177:                                 * processing the rest of the
        !           178:                                 * arguments to write.
        !           179:                                 */
        !           180:                                file = argv[1];
        !           181:                                filetype = ap->type;
        !           182:                                rvalue(argv[1], NIL);
        !           183:                                put1(O_UNIT);
        !           184:                                /*
        !           185:                                 * Skip over the first argument
        !           186:                                 */
        !           187:                                argv = argv[2];
        !           188:                                argc--;
        !           189:                        } else
        !           190:                                /*
        !           191:                                 * Set up for writing on 
        !           192:                                 * standard output.
        !           193:                                 */
        !           194:                                put1(O_UNITOUT);
        !           195:                } else
        !           196:                        put1(O_UNITOUT);
        !           197:                /*
        !           198:                 * Loop and process each
        !           199:                 * of the arguments.
        !           200:                 */
        !           201:                for (; argv != NIL; argv = argv[2]) {
        !           202:                        al = argv[1];
        !           203:                        if (al == NIL)
        !           204:                                continue;
        !           205:                        /*
        !           206:                         * Op will be used to
        !           207:                         * accumulate width information,
        !           208:                         * and two records the fact
        !           209:                         * that we saw two write widths
        !           210:                         */
        !           211:                        op = 0;
        !           212:                        two = 0;
        !           213:                        oct = 0;
        !           214:                        hex = 0;
        !           215:                        if (al[0] == T_WEXP) {
        !           216:                                if (filetype != nl+T1CHAR) {
        !           217:                                        error("Write widths allowed only with text files");
        !           218:                                        continue;
        !           219:                                }
        !           220:                                /*
        !           221:                                 * Handle width expressions.
        !           222:                                 * The basic game here is that width
        !           223:                                 * expressions get evaluated and left
        !           224:                                 * on the stack and their width's get
        !           225:                                 * packed into the high byte of the
        !           226:                                 * affected opcode (subop).
        !           227:                                 */
        !           228:                                if (al[3] == OCT) 
        !           229:                                        oct++;
        !           230:                                else if (al[3] == HEX)
        !           231:                                        hex++;
        !           232:                                else if (al[3] != NIL) {
        !           233:                                        two++;
        !           234:                                        /*
        !           235:                                         * Arrange for the write
        !           236:                                         * opcode that takes two widths
        !           237:                                         */
        !           238:                                        op |= O_WRIT82-O_WRIT8;
        !           239:                                        ap = rvalue(al[3], NIL);
        !           240:                                        if (ap == NIL)
        !           241:                                                continue;
        !           242:                                        if (isnta(ap, "i")) {
        !           243:                                                error("Second write width must be integer, not %s", nameof(ap));
        !           244:                                                continue;
        !           245:                                        }
        !           246:                                        op |= even(width(ap)) << 11;
        !           247:                                }
        !           248:                                if (al[2] != NIL) {
        !           249:                                        ap = rvalue(al[2], NIL);
        !           250:                                        if (ap == NIL)
        !           251:                                                continue;
        !           252:                                        if (isnta(ap, "i")) {
        !           253:                                                error("First write width must be integer, not %s", nameof(ap));
        !           254:                                                continue;
        !           255:                                        }
        !           256:                                        op |= even(width(ap)) << 8;
        !           257:                                }
        !           258:                                al = al[1];
        !           259:                                if (al == NIL)
        !           260:                                        continue;
        !           261:                        }
        !           262:                        if (filetype != nl+T1CHAR) {
        !           263:                                if (oct || hex) {
        !           264:                                        error("Oct/hex allowed only on text files");
        !           265:                                        continue;
        !           266:                                }
        !           267:                                if (op) {
        !           268:                                        error("Write widths allowed only on text files");
        !           269:                                        continue;
        !           270:                                }
        !           271:                                /*
        !           272:                                 * Generalized write, i.e.
        !           273:                                 * to a non-textfile.
        !           274:                                 */
        !           275:                                rvalue(file, NIL);
        !           276:                                put1(O_FNIL);
        !           277:                                /*
        !           278:                                 * file^ := ...
        !           279:                                 */
        !           280:                                ap = rvalue(argv[1], NIL);
        !           281:                                if (ap == NIL)
        !           282:                                        continue;
        !           283:                                if (incompat(ap, filetype, argv[1])) {
        !           284:                                        cerror("Type mismatch in write to non-text file");
        !           285:                                        continue;
        !           286:                                }
        !           287:                                convert(ap, filetype);
        !           288:                                put2(O_AS, width(filetype));
        !           289:                                /*
        !           290:                                 * put(file)
        !           291:                                 */
        !           292:                                put1(O_PUT);
        !           293:                                continue;
        !           294:                        }
        !           295:                        /*
        !           296:                         * Write to a textfile
        !           297:                         *
        !           298:                         * Evaluate the expression
        !           299:                         * to be written.
        !           300:                         */
        !           301:                        ap = rvalue(al, NIL);
        !           302:                        if (ap == NIL)
        !           303:                                continue;
        !           304:                        c = classify(ap);
        !           305:                        if (two && c != TDOUBLE) {
        !           306:                                if (isnta(ap, "i")) {
        !           307:                                        error("Only reals can have two write widths");
        !           308:                                        continue;
        !           309:                                }
        !           310:                                convert(ap, nl+TDOUBLE);
        !           311:                                c = TDOUBLE;
        !           312:                        }
        !           313:                        if (oct || hex) {
        !           314:                                if (opt('s')) {
        !           315:                                        standard();
        !           316:                                        error("Oct and hex are non-standard");
        !           317:                                }
        !           318:                                switch (c) {
        !           319:                                        case TREC:
        !           320:                                        case TARY:
        !           321:                                        case TFILE:
        !           322:                                        case TSTR:
        !           323:                                        case TSET:
        !           324:                                        case TDOUBLE:
        !           325:                                                error("Can't write %ss with oct/hex", clnames[c]);
        !           326:                                                continue;
        !           327:                                }
        !           328:                                put1(op | (oct ? O_WROCT2 : O_WRHEX2) | (width(ap) >> 2));
        !           329:                                continue;
        !           330:                        }
        !           331:                        if (wrops(c) == NIL) {
        !           332:                                error("Can't write %ss to a text file", clnames[c]);
        !           333:                                continue;
        !           334:                        }
        !           335:                        if (c == TINT && width(ap) != 4)
        !           336:                                op |= O_WRIT2;
        !           337:                        else
        !           338:                                op |= wrops(c);
        !           339:                        if (c == TSTR)
        !           340:                                put2(op, width(ap));
        !           341:                        else
        !           342:                                put1(op);
        !           343:                }
        !           344:                /*
        !           345:                 * Done with arguments.
        !           346:                 * Handle writeln and
        !           347:                 * insufficent number of args.
        !           348:                 */
        !           349:                switch (p->value[0] &~ NSTAND) {
        !           350:                        case O_WRIT2:
        !           351:                                if (argc == 0)
        !           352:                                        error("Write requires an argument");
        !           353:                                break;
        !           354:                        case O_MESSAGE:
        !           355:                                if (argc == 0)
        !           356:                                        error("Message requires an argument");
        !           357:                        case O_WRITLN:
        !           358:                                if (filetype != nl+T1CHAR)
        !           359:                                        error("Can't 'writeln' a non text file");
        !           360:                                put1(O_WRITLN);
        !           361:                                break;
        !           362:                }
        !           363:                return;
        !           364: 
        !           365:        case O_READ4:
        !           366:        case O_READLN:
        !           367:                /*
        !           368:                 * Set up default
        !           369:                 * file "input".
        !           370:                 */
        !           371:                file = NIL;
        !           372:                filetype = nl+T1CHAR;
        !           373:                /*
        !           374:                 * Determine the file implied
        !           375:                 * for the read and generate
        !           376:                 * code to make it the active file.
        !           377:                 */
        !           378:                if (argv != NIL) {
        !           379:                        codeoff();
        !           380:                        ap = rvalue(argv[1], NIL);
        !           381:                        codeon();
        !           382:                        if (ap == NIL)
        !           383:                                argv = argv[2];
        !           384:                        if (ap != NIL && ap->class == FILET) {
        !           385:                                /*
        !           386:                                 * Got "read(f, ...", make
        !           387:                                 * f the active file, and save
        !           388:                                 * it and its type for use in
        !           389:                                 * processing the rest of the
        !           390:                                 * arguments to read.
        !           391:                                 */
        !           392:                                file = argv[1];
        !           393:                                filetype = ap->type;
        !           394:                                rvalue(argv[1], NIL);
        !           395:                                put1(O_UNIT);
        !           396:                                argv = argv[2];
        !           397:                                argc--;
        !           398:                        } else {
        !           399:                                /*
        !           400:                                 * Default is read from
        !           401:                                 * standard input.
        !           402:                                 */
        !           403:                                put1(O_UNITINP);
        !           404:                                input->nl_flags |= NUSED;
        !           405:                        }
        !           406:                } else {
        !           407:                        put1(O_UNITINP);
        !           408:                        input->nl_flags |= NUSED;
        !           409:                }
        !           410:                /*
        !           411:                 * Loop and process each
        !           412:                 * of the arguments.
        !           413:                 */
        !           414:                for (; argv != NIL; argv = argv[2]) {
        !           415:                        /*
        !           416:                         * Get the address of the target
        !           417:                         * on the stack.
        !           418:                         */
        !           419:                        al = argv[1];
        !           420:                        if (al == NIL)
        !           421:                                continue;
        !           422:                        if (al[0] != T_VAR) {
        !           423:                                error("Arguments to %s must be variables, not expressions", p->symbol);
        !           424:                                continue;
        !           425:                        }
        !           426:                        ap = lvalue(al, MOD|ASGN|NOUSE);
        !           427:                        if (ap == NIL)
        !           428:                                continue;
        !           429:                        if (filetype != nl+T1CHAR) {
        !           430:                                /*
        !           431:                                 * Generalized read, i.e.
        !           432:                                 * from a non-textfile.
        !           433:                                 */
        !           434:                                if (incompat(filetype, ap, NIL)) {
        !           435:                                        error("Type mismatch in read from non-text file");
        !           436:                                        continue;
        !           437:                                }
        !           438:                                /*
        !           439:                                 * var := file ^;
        !           440:                                 */
        !           441:                                if (file != NIL)
        !           442:                                        rvalue(file, NIL);
        !           443:                                else /* Magic */
        !           444:                                        put2(O_RV2, input->value[0]);
        !           445:                                put1(O_FNIL);
        !           446:                                put2(O_IND, width(filetype));
        !           447:                                convert(filetype, ap);
        !           448:                                if (isa(ap, "bsci"))
        !           449:                                        rangechk(ap, ap);
        !           450:                                put2(O_AS, width(ap));
        !           451:                                /*
        !           452:                                 * get(file);
        !           453:                                 */
        !           454:                                put1(O_GET);
        !           455:                                continue;
        !           456:                        }
        !           457:                        c = classify(ap);
        !           458:                        op = rdops(c);
        !           459:                        if (op == NIL) {
        !           460:                                error("Can't read %ss from a text file", clnames[c]);
        !           461:                                continue;
        !           462:                        }
        !           463:                        put1(op);
        !           464:                        /*
        !           465:                         * Data read is on the stack.
        !           466:                         * Assign it.
        !           467:                         */
        !           468:                        if (op != O_READ8)
        !           469:                                rangechk(ap, op == O_READC ? ap : nl+T4INT);
        !           470:                        gen(O_AS2, O_AS2, width(ap),
        !           471:                                op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2);
        !           472:                }
        !           473:                /*
        !           474:                 * Done with arguments.
        !           475:                 * Handle readln and
        !           476:                 * insufficient number of args.
        !           477:                 */
        !           478:                if (p->value[0] == O_READLN) {
        !           479:                        if (filetype != nl+T1CHAR)
        !           480:                                error("Can't 'readln' a non text file");
        !           481:                        put1(O_READLN);
        !           482:                }
        !           483:                else if (argc == 0)
        !           484:                        error("read requires an argument");
        !           485:                return;
        !           486: 
        !           487:        case O_GET:
        !           488:        case O_PUT:
        !           489:                if (argc != 1) {
        !           490:                        error("%s expects one argument", p->symbol);
        !           491:                        return;
        !           492:                }
        !           493:                ap = rvalue(argv[1], NIL);
        !           494:                if (ap == NIL)
        !           495:                        return;
        !           496:                if (ap->class != FILET) {
        !           497:                        error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
        !           498:                        return;
        !           499:                }
        !           500:                put1(O_UNIT);
        !           501:                put1(op);
        !           502:                return;
        !           503: 
        !           504:        case O_RESET:
        !           505:        case O_REWRITE:
        !           506:                if (argc == 0 || argc > 2) {
        !           507:                        error("%s expects one or two arguments", p->symbol);
        !           508:                        return;
        !           509:                }
        !           510:                if (opt('s') && argc == 2) {
        !           511:                        standard();
        !           512:                        error("Two argument forms of reset and rewrite are non-standard");
        !           513:                }
        !           514:                ap = lvalue(argv[1], MOD|NOUSE);
        !           515:                if (ap == NIL)
        !           516:                        return;
        !           517:                if (ap->class != FILET) {
        !           518:                        error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
        !           519:                        return;
        !           520:                }
        !           521:                if (argc == 2) {
        !           522:                        /*
        !           523:                         * Optional second argument
        !           524:                         * is a string name of a
        !           525:                         * UNIX (R) file to be associated.
        !           526:                         */
        !           527:                        al = argv[2];
        !           528:                        al = rvalue(al[1], NIL);
        !           529:                        if (al == NIL)
        !           530:                                return;
        !           531:                        if (classify(al) != TSTR) {
        !           532:                                error("Second argument to %s must be a string, not %s", p->symbol, nameof(al));
        !           533:                                return;
        !           534:                        }
        !           535:                        c = width(al);
        !           536:                } else
        !           537:                        c = 0;
        !           538:                if (c > 127) {
        !           539:                        error("File name too long");
        !           540:                        return;
        !           541:                }
        !           542:                put2(op | c << 8, text(ap) ? 0: width(ap->type));
        !           543:                return;
        !           544: 
        !           545:        case O_NEW:
        !           546:        case O_DISPOSE:
        !           547:                if (argc == 0) {
        !           548:                        error("%s expects at least one argument", p->symbol);
        !           549:                        return;
        !           550:                }
        !           551:                ap = lvalue(argv[1], MOD|NOUSE);
        !           552:                if (ap == NIL)
        !           553:                        return;
        !           554:                if (ap->class != PTR) {
        !           555:                        error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
        !           556:                        return;
        !           557:                }
        !           558:                ap = ap->type;
        !           559:                if (ap == NIL)
        !           560:                        return;
        !           561:                argv = argv[2];
        !           562:                if (argv != NIL) {
        !           563:                        if (ap->class != RECORD) {
        !           564:                                error("Record required when specifying variant tags");
        !           565:                                return;
        !           566:                        }
        !           567:                        for (; argv != NIL; argv = argv[2]) {
        !           568:                                if (ap->ptr[NL_VARNT] == NIL) {
        !           569:                                        error("Too many tag fields");
        !           570:                                        return;
        !           571:                                }
        !           572:                                if (!isconst(argv[1])) {
        !           573:                                        error("Second and successive arguments to %s must be constants", p->symbol);
        !           574:                                        return;
        !           575:                                }
        !           576:                                gconst(argv[1]);
        !           577:                                if (con.ctype == NIL)
        !           578:                                        return;
        !           579:                                if (incompat(con.ctype, (ap->ptr[NL_TAG])->type)) {
        !           580:                                        cerror("Specified tag constant type clashed with variant case selector type");
        !           581:                                        return;
        !           582:                                }
        !           583:                                for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
        !           584:                                        if (ap->range[0] == con.crval)
        !           585:                                                break;
        !           586:                                if (ap == NIL) {
        !           587:                                        error("No variant case label value equals specified constant value");
        !           588:                                        return;
        !           589:                                }
        !           590:                                ap = ap->ptr[NL_VTOREC];
        !           591:                        }
        !           592:                }
        !           593:                put2(op, width(ap));
        !           594:                return;
        !           595: 
        !           596:        case O_DATE:
        !           597:        case O_TIME:
        !           598:                if (argc != 1) {
        !           599:                        error("%s expects one argument", p->symbol);
        !           600:                        return;
        !           601:                }
        !           602:                ap = lvalue(argv[1], MOD|NOUSE);
        !           603:                if (ap == NIL)
        !           604:                        return;
        !           605:                if (classify(ap) != TSTR || width(ap) != 10) {
        !           606:                        error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
        !           607:                        return;
        !           608:                }
        !           609:                put1(op);
        !           610:                return;
        !           611: 
        !           612:        case O_HALT:
        !           613:                if (argc != 0) {
        !           614:                        error("halt takes no arguments");
        !           615:                        return;
        !           616:                }
        !           617:                put1(op);
        !           618:                noreach = 1;
        !           619:                return;
        !           620: 
        !           621:        case O_ARGV:
        !           622:                if (argc != 2) {
        !           623:                        error("argv takes two arguments");
        !           624:                        return;
        !           625:                }
        !           626:                ap = rvalue(argv[1], NIL);
        !           627:                if (ap == NIL)
        !           628:                        return;
        !           629:                if (isnta(ap, "i")) {
        !           630:                        error("argv's first argument must be an integer, not %s", nameof(ap));
        !           631:                        return;
        !           632:                }
        !           633:                convert(ap, nl+T2INT);
        !           634:                al = argv[2];
        !           635:                ap = lvalue(al[1], MOD|NOUSE);
        !           636:                if (ap == NIL)
        !           637:                        return;
        !           638:                if (classify(ap) != TSTR) {
        !           639:                        error("argv's second argument must be a string, not %s", nameof(ap));
        !           640:                        return;
        !           641:                }
        !           642:                put2(op, width(ap));
        !           643:                return;
        !           644: 
        !           645:        case O_STLIM:
        !           646:                if (argc != 1) {
        !           647:                        error("stlimit requires one argument");
        !           648:                        return;
        !           649:                }
        !           650:                ap = rvalue(argv[1], NIL);
        !           651:                if (ap == NIL)
        !           652:                        return;
        !           653:                if (isnta(ap, "i")) {
        !           654:                        error("stlimit's argument must be an integer, not %s", nameof(ap));
        !           655:                        return;
        !           656:                }
        !           657:                if (width(ap) != 4)
        !           658:                        put1(O_STOI);
        !           659:                put1(op);
        !           660:                return;
        !           661: 
        !           662:        case O_REMOVE:
        !           663:                if (argc != 1) {
        !           664:                        error("remove expects one argument");
        !           665:                        return;
        !           666:                }
        !           667:                ap = rvalue(argv[1], NIL);
        !           668:                if (ap == NIL)
        !           669:                        return;
        !           670:                if (classify(ap) != TSTR) {
        !           671:                        error("remove's argument must be a string, not %s", nameof(ap));
        !           672:                        return;
        !           673:                }
        !           674:                put2(op, width(ap));
        !           675:                return;
        !           676: 
        !           677:        case O_LLIMIT:
        !           678:                if (argc != 2) {
        !           679:                        error("linelimit expects two arguments");
        !           680:                        return;
        !           681:                }
        !           682:                ap = lvalue(argv[1], NOMOD|NOUSE);
        !           683:                if (ap == NIL)
        !           684:                        return;
        !           685:                if (!text(ap)) {
        !           686:                        error("linelimit's first argument must be a text file, not %s", nameof(ap));
        !           687:                        return;
        !           688:                }
        !           689:                al = argv[2];
        !           690:                ap = rvalue(al[1], NIL);
        !           691:                if (ap == NIL)
        !           692:                        return;
        !           693:                if (isnta(ap, "i")) {
        !           694:                        error("linelimit's second argument must be an integer, not %s", nameof(ap));
        !           695:                        return;
        !           696:                }
        !           697:                convert(ap, nl+T4INT);
        !           698:                put1(op);
        !           699:                return;
        !           700:        case O_PAGE:
        !           701:                if (argc != 1) {
        !           702:                        error("page expects one argument");
        !           703:                        return;
        !           704:                }
        !           705:                ap = rvalue(argv[1], NIL);
        !           706:                if (ap == NIL)
        !           707:                        return;
        !           708:                if (!text(ap)) {
        !           709:                        error("Argument to page must be a text file, not %s", nameof(ap));
        !           710:                        return;
        !           711:                }
        !           712:                put1(O_UNIT);
        !           713:                put1(op);
        !           714:                return;
        !           715: 
        !           716:        case O_PACK:
        !           717:                if (argc != 3) {
        !           718:                        error("pack expects three arguments");
        !           719:                        return;
        !           720:                }
        !           721:                pu = "pack(a,i,z)";
        !           722:                pua = (al = argv)[1];
        !           723:                pui = (al = al[2])[1];
        !           724:                puz = (al = al[2])[1];
        !           725:                goto packunp;
        !           726:        case O_UNPACK:
        !           727:                if (argc != 3) {
        !           728:                        error("unpack expects three arguments");
        !           729:                        return;
        !           730:                }
        !           731:                pu = "unpack(z,a,i)";
        !           732:                puz = (al = argv)[1];
        !           733:                pua = (al = al[2])[1];
        !           734:                pui = (al = al[2])[1];
        !           735: packunp:
        !           736:                ap = rvalue((int *) pui, NLNIL);
        !           737:                if (ap == NIL)
        !           738:                        return;
        !           739:                if (width(ap) == 4)
        !           740:                        put1(O_ITOS);
        !           741:                ap = lvalue(pua, op == O_PACK ? NOMOD : MOD|NOUSE);
        !           742:                if (ap == NIL)
        !           743:                        return;
        !           744:                if (ap->class != ARRAY) {
        !           745:                        error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
        !           746:                        return;
        !           747:                }
        !           748:                al = (struct nl *) lvalue(puz, op == O_UNPACK ? NOMOD : MOD|NOUSE);
        !           749:                if (al->class != ARRAY) {
        !           750:                        error("%s requires z to be a packed array, not %s", pu, nameof(ap));
        !           751:                        return;
        !           752:                }
        !           753:                if (al->type == NIL || ap->type == NIL)
        !           754:                        return;
        !           755:                if (al->type != ap->type) {
        !           756:                        error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
        !           757:                        return;
        !           758:                }
        !           759:                k = width(al);
        !           760:                ap = ap->chain;
        !           761:                al = al->chain;
        !           762:                if (ap->chain != NIL || al->chain != NIL) {
        !           763:                        error("%s requires a and z to be single dimension arrays", pu);
        !           764:                        return;
        !           765:                }
        !           766:                if (ap == NIL || al == NIL)
        !           767:                        return;
        !           768:                /*
        !           769:                 * al is the range for z i.e. u..v
        !           770:                 * ap is the range for a i.e. m..n
        !           771:                 * i will be n-m+1
        !           772:                 * j will be v-u+1
        !           773:                 */
        !           774:                i = ap->range[1] - ap->range[0] + 1;
        !           775:                j = al->range[1] - al->range[0] + 1;
        !           776:                if (i < j) {
        !           777:                        error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i);
        !           778:                        return;
        !           779:                }
        !           780:                /*
        !           781:                 * get n-m-(v-u) and m for the interpreter
        !           782:                 */
        !           783:                i -= j;
        !           784:                j = ap->range[0];
        !           785:                put(5, op, width(ap), j, i, k);
        !           786:                return;
        !           787:        case 0:
        !           788:                error("%s is an unimplemented 6400 extension", p->symbol);
        !           789:                return;
        !           790: 
        !           791:        default:
        !           792:                panic("proc case");
        !           793:        }
        !           794: }

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