Return to pcproc.c CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / pascal / src

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

1.1     ! root        1: /* Copyright (c) 1979 Regents of the University of California */
        !             2: 
        !             3: static char sccsid[] = "@(#)pcproc.c 1.21 4/8/83";
        !             4: 
        !             5: #include "whoami.h"
        !             6: #ifdef PC
        !             7:     /*
        !             8:      * and to the end of the file
        !             9:      */
        !            10: #include "0.h"
        !            11: #include "tree.h"
        !            12: #include "objfmt.h"
        !            13: #include "opcode.h"
        !            14: #include "pc.h"
        !            15: #include "pcops.h"
        !            16: #include "tmps.h"
        !            17: 
        !            18: /*
        !            19:  * The constant EXPOSIZE specifies the number of digits in the exponent
        !            20:  * of real numbers.
        !            21:  *
        !            22:  * The constant REALSPC defines the amount of forced padding preceeding
        !            23:  * real numbers when they are printed. If REALSPC == 0, then no padding
        !            24:  * is added, REALSPC == 1 adds one extra blank irregardless of the width
        !            25:  * specified by the user.
        !            26:  *
        !            27:  * N.B. - Values greater than one require program mods.
        !            28:  */
        !            29: #define EXPOSIZE       2
        !            30: #define        REALSPC         0
        !            31: 
        !            32: /*
        !            33:  * The following array is used to determine which classes may be read
        !            34:  * from textfiles. It is indexed by the return value from classify.
        !            35:  */
        !            36: #define rdops(x) rdxxxx[(x)-(TFIRST)]
        !            37: 
        !            38: int rdxxxx[] = {
        !            39:        0,              /* -7 file types */
        !            40:        0,              /* -6 record types */
        !            41:        0,              /* -5 array types */
        !            42:        O_READE,        /* -4 scalar types */
        !            43:        0,              /* -3 pointer types */
        !            44:        0,              /* -2 set types */
        !            45:        0,              /* -1 string types */
        !            46:        0,              /*  0 nil, no type */
        !            47:        O_READE,        /*  1 boolean */
        !            48:        O_READC,        /*  2 character */
        !            49:        O_READ4,        /*  3 integer */
        !            50:        O_READ8         /*  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: pcproc(r)
        !            60:        int *r;
        !            61: {
        !            62:        register struct nl *p;
        !            63:        register int *alv, *al, op;
        !            64:        struct nl *filetype, *ap;
        !            65:        int argc, *argv, typ, fmtspec, strfmt, stkcnt, *file;
        !            66:        char fmt, format[20], *strptr, *cmd;
        !            67:        int prec, field, strnglen, fmtlen, fmtstart, pu;
        !            68:        int *pua, *pui, *puz;
        !            69:        int i, j, k;
        !            70:        int itemwidth;
        !            71:        char            *readname;
        !            72:        struct nl       *tempnlp;
        !            73:        long            readtype;
        !            74:        struct tmps     soffset;
        !            75: 
        !            76: #define        CONPREC 4
        !            77: #define        VARPREC 8
        !            78: #define        CONWIDTH 1
        !            79: #define        VARWIDTH 2
        !            80: #define SKIP 16
        !            81: 
        !            82:        /*
        !            83:         * Verify that the name is
        !            84:         * defined and is that of a
        !            85:         * procedure.
        !            86:         */
        !            87:        p = lookup(r[2]);
        !            88:        if (p == NIL) {
        !            89:                rvlist(r[3]);
        !            90:                return;
        !            91:        }
        !            92:        if (p->class != PROC && p->class != FPROC) {
        !            93:                error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
        !            94:                rvlist(r[3]);
        !            95:                return;
        !            96:        }
        !            97:        argv = r[3];
        !            98: 
        !            99:        /*
        !           100:         * Call handles user defined
        !           101:         * procedures and functions.
        !           102:         */
        !           103:        if (bn != 0) {
        !           104:                call(p, argv, PROC, bn);
        !           105:                return;
        !           106:        }
        !           107: 
        !           108:        /*
        !           109:         * Call to built-in procedure.
        !           110:         * Count the arguments.
        !           111:         */
        !           112:        argc = 0;
        !           113:        for (al = argv; al != NIL; al = al[2])
        !           114:                argc++;
        !           115: 
        !           116:        /*
        !           117:         * Switch on the operator
        !           118:         * associated with the built-in
        !           119:         * procedure in the namelist
        !           120:         */
        !           121:        op = p->value[0] &~ NSTAND;
        !           122:        if (opt('s') && (p->value[0] & NSTAND)) {
        !           123:                standard();
        !           124:                error("%s is a nonstandard procedure", p->symbol);
        !           125:        }
        !           126:        switch (op) {
        !           127: 
        !           128:        case O_ABORT:
        !           129:                if (argc != 0)
        !           130:                        error("null takes no arguments");
        !           131:                return;
        !           132: 
        !           133:        case O_FLUSH:
        !           134:                if (argc == 0) {
        !           135:                        putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" );
        !           136:                        putop( P2UNARY P2CALL , P2INT );
        !           137:                        putdot( filename , line );
        !           138:                        return;
        !           139:                }
        !           140:                if (argc != 1) {
        !           141:                        error("flush takes at most one argument");
        !           142:                        return;
        !           143:                }
        !           144:                putleaf( P2ICON , 0 , 0
        !           145:                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           146:                        , "_FLUSH" );
        !           147:                ap = stklval(argv[1], NOFLAGS);
        !           148:                if (ap == NIL)
        !           149:                        return;
        !           150:                if (ap->class != FILET) {
        !           151:                        error("flush's argument must be a file, not %s", nameof(ap));
        !           152:                        return;
        !           153:                }
        !           154:                putop( P2CALL , P2INT );
        !           155:                putdot( filename , line );
        !           156:                return;
        !           157: 
        !           158:        case O_MESSAGE:
        !           159:        case O_WRITEF:
        !           160:        case O_WRITLN:
        !           161:                /*
        !           162:                 * Set up default file "output"'s type
        !           163:                 */
        !           164:                file = NIL;
        !           165:                filetype = nl+T1CHAR;
        !           166:                /*
        !           167:                 * Determine the file implied
        !           168:                 * for the write and generate
        !           169:                 * code to make it the active file.
        !           170:                 */
        !           171:                if (op == O_MESSAGE) {
        !           172:                        /*
        !           173:                         * For message, all that matters
        !           174:                         * is that the filetype is
        !           175:                         * a character file.
        !           176:                         * Thus "output" will suit us fine.
        !           177:                         */
        !           178:                        putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" );
        !           179:                        putop( P2UNARY P2CALL , P2INT );
        !           180:                        putdot( filename , line );
        !           181:                        putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
        !           182:                                P2PTR|P2STRTY );
        !           183:                        putLV( "__err" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY );
        !           184:                        putop( P2ASSIGN , P2PTR|P2STRTY );
        !           185:                        putdot( filename , line );
        !           186:                } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) {
        !           187:                        /*
        !           188:                         * If there is a first argument which has
        !           189:                         * no write widths, then it is potentially
        !           190:                         * a file name.
        !           191:                         */
        !           192:                        codeoff();
        !           193:                        ap = stkrval(argv[1], NIL , RREQ );
        !           194:                        codeon();
        !           195:                        if (ap == NIL)
        !           196:                                argv = argv[2];
        !           197:                        if (ap != NIL && ap->class == FILET) {
        !           198:                                /*
        !           199:                                 * Got "write(f, ...", make
        !           200:                                 * f the active file, and save
        !           201:                                 * it and its type for use in
        !           202:                                 * processing the rest of the
        !           203:                                 * arguments to write.
        !           204:                                 */
        !           205:                                putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
        !           206:                                        P2PTR|P2STRTY );
        !           207:                                putleaf( P2ICON , 0 , 0
        !           208:                                    , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           209:                                    , "_UNIT" );
        !           210:                                file = argv[1];
        !           211:                                filetype = ap->type;
        !           212:                                stklval(argv[1], NOFLAGS);
        !           213:                                putop( P2CALL , P2INT );
        !           214:                                putop( P2ASSIGN , P2PTR|P2STRTY );
        !           215:                                putdot( filename , line );
        !           216:                                /*
        !           217:                                 * Skip over the first argument
        !           218:                                 */
        !           219:                                argv = argv[2];
        !           220:                                argc--;
        !           221:                        } else {
        !           222:                                /*
        !           223:                                 * Set up for writing on 
        !           224:                                 * standard output.
        !           225:                                 */
        !           226:                                putRV( 0, cbn , CURFILEOFFSET ,
        !           227:                                        NLOCAL , P2PTR|P2STRTY );
        !           228:                                putLV( "_output" , 0 , 0 , NGLOBAL ,
        !           229:                                        P2PTR|P2STRTY );
        !           230:                                putop( P2ASSIGN , P2PTR|P2STRTY );
        !           231:                                putdot( filename , line );
        !           232:                                output->nl_flags |= NUSED;
        !           233:                        }
        !           234:                } else {
        !           235:                        putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
        !           236:                                P2PTR|P2STRTY );
        !           237:                        putLV( "_output" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY );
        !           238:                        putop( P2ASSIGN , P2PTR|P2STRTY );
        !           239:                        putdot( filename , line );
        !           240:                        output->nl_flags |= NUSED;
        !           241:                }
        !           242:                /*
        !           243:                 * Loop and process each
        !           244:                 * of the arguments.
        !           245:                 */
        !           246:                for (; argv != NIL; argv = argv[2]) {
        !           247:                        /*
        !           248:                         * fmtspec indicates the type (CONstant or VARiable)
        !           249:                         *      and number (none, WIDTH, and/or PRECision)
        !           250:                         *      of the fields in the printf format for this
        !           251:                         *      output variable.
        !           252:                         * stkcnt is the number of longs pushed on the stack
        !           253:                         * fmt is the format output indicator (D, E, F, O, X, S)
        !           254:                         * fmtstart = 0 for leading blank; = 1 for no blank
        !           255:                         */
        !           256:                        fmtspec = NIL;
        !           257:                        stkcnt = 0;
        !           258:                        fmt = 'D';
        !           259:                        fmtstart = 1;
        !           260:                        al = argv[1];
        !           261:                        if (al == NIL)
        !           262:                                continue;
        !           263:                        if (al[0] == T_WEXP)
        !           264:                                alv = al[1];
        !           265:                        else
        !           266:                                alv = al;
        !           267:                        if (alv == NIL)
        !           268:                                continue;
        !           269:                        codeoff();
        !           270:                        ap = stkrval(alv, NIL , RREQ );
        !           271:                        codeon();
        !           272:                        if (ap == NIL)
        !           273:                                continue;
        !           274:                        typ = classify(ap);
        !           275:                        if (al[0] == T_WEXP) {
        !           276:                                /*
        !           277:                                 * Handle width expressions.
        !           278:                                 * The basic game here is that width
        !           279:                                 * expressions get evaluated. If they
        !           280:                                 * are constant, the value is placed
        !           281:                                 * directly in the format string.
        !           282:                                 * Otherwise the value is pushed onto
        !           283:                                 * the stack and an indirection is
        !           284:                                 * put into the format string.
        !           285:                                 */
        !           286:                                if (al[3] == OCT)
        !           287:                                        fmt = 'O';
        !           288:                                else if (al[3] == HEX)
        !           289:                                        fmt = 'X';
        !           290:                                else if (al[3] != NIL) {
        !           291:                                        /*
        !           292:                                         * Evaluate second format spec
        !           293:                                         */
        !           294:                                        if ( constval(al[3])
        !           295:                                            && isa( con.ctype , "i" ) ) {
        !           296:                                                fmtspec += CONPREC;
        !           297:                                                prec = con.crval;
        !           298:                                        } else {
        !           299:                                                fmtspec += VARPREC;
        !           300:                                        }
        !           301:                                        fmt = 'f';
        !           302:                                        switch ( typ ) {
        !           303:                                        case TINT:
        !           304:                                                if ( opt( 's' ) ) {
        !           305:                                                    standard();
        !           306:                                                    error("Writing %ss with two write widths is non-standard", clnames[typ]);
        !           307:                                                }
        !           308:                                                /* and fall through */
        !           309:                                        case TDOUBLE:
        !           310:                                                break;
        !           311:                                        default:
        !           312:                                                error("Cannot write %ss with two write widths", clnames[typ]);
        !           313:                                                continue;
        !           314:                                        }
        !           315:                                }
        !           316:                                /*
        !           317:                                 * Evaluate first format spec
        !           318:                                 */
        !           319:                                if (al[2] != NIL) {
        !           320:                                        if ( constval(al[2])
        !           321:                                            && isa( con.ctype , "i" ) ) {
        !           322:                                                fmtspec += CONWIDTH;
        !           323:                                                field = con.crval;
        !           324:                                        } else {
        !           325:                                                fmtspec += VARWIDTH;
        !           326:                                        }
        !           327:                                }
        !           328:                                if ((fmtspec & CONPREC) && prec < 0 ||
        !           329:                                    (fmtspec & CONWIDTH) && field < 0) {
        !           330:                                        error("Negative widths are not allowed");
        !           331:                                        continue;
        !           332:                                }
        !           333:                                if ( opt('s') &&
        !           334:                                    ((fmtspec & CONPREC) && prec == 0 ||
        !           335:                                    (fmtspec & CONWIDTH) && field == 0)) {
        !           336:                                        standard();
        !           337:                                        error("Zero widths are non-standard");
        !           338:                                }
        !           339:                        }
        !           340:                        if (filetype != nl+T1CHAR) {
        !           341:                                if (fmt == 'O' || fmt == 'X') {
        !           342:                                        error("Oct/hex allowed only on text files");
        !           343:                                        continue;
        !           344:                                }
        !           345:                                if (fmtspec) {
        !           346:                                        error("Write widths allowed only on text files");
        !           347:                                        continue;
        !           348:                                }
        !           349:                                /*
        !           350:                                 * Generalized write, i.e.
        !           351:                                 * to a non-textfile.
        !           352:                                 */
        !           353:                                putleaf( P2ICON , 0 , 0
        !           354:                                    , ADDTYPE(
        !           355:                                        ADDTYPE(
        !           356:                                            ADDTYPE( p2type( filetype )
        !           357:                                                    , P2PTR )
        !           358:                                            , P2FTN )
        !           359:                                        , P2PTR )
        !           360:                                    , "_FNIL" );
        !           361:                                stklval(file, NOFLAGS);
        !           362:                                putop( P2CALL
        !           363:                                    , ADDTYPE( p2type( filetype ) , P2PTR ) );
        !           364:                                putop( P2UNARY P2MUL , p2type( filetype ) );
        !           365:                                /*
        !           366:                                 * file^ := ...
        !           367:                                 */
        !           368:                                switch ( classify( filetype ) ) {
        !           369:                                    case TBOOL:
        !           370:                                    case TCHAR:
        !           371:                                    case TINT:
        !           372:                                    case TSCAL:
        !           373:                                        precheck( filetype , "_RANG4"  , "_RSNG4" );
        !           374:                                            /* and fall through */
        !           375:                                    case TDOUBLE:
        !           376:                                    case TPTR:
        !           377:                                        ap = rvalue( argv[1] , filetype , RREQ );
        !           378:                                        break;
        !           379:                                    default:
        !           380:                                        ap = rvalue( argv[1] , filetype , LREQ );
        !           381:                                        break;
        !           382:                                }
        !           383:                                if (ap == NIL)
        !           384:                                        continue;
        !           385:                                if (incompat(ap, filetype, argv[1])) {
        !           386:                                        cerror("Type mismatch in write to non-text file");
        !           387:                                        continue;
        !           388:                                }
        !           389:                                switch ( classify( filetype ) ) {
        !           390:                                    case TBOOL:
        !           391:                                    case TCHAR:
        !           392:                                    case TINT:
        !           393:                                    case TSCAL:
        !           394:                                            postcheck(filetype, ap);
        !           395:                                            sconv(p2type(ap), p2type(filetype));
        !           396:                                                /* and fall through */
        !           397:                                    case TDOUBLE:
        !           398:                                    case TPTR:
        !           399:                                            putop( P2ASSIGN , p2type( filetype ) );
        !           400:                                            putdot( filename , line );
        !           401:                                            break;
        !           402:                                    default:
        !           403:                                            putstrop(P2STASG,
        !           404:                                                    ADDTYPE(p2type(filetype),
        !           405:                                                            P2PTR),
        !           406:                                                    lwidth(filetype),
        !           407:                                                    align(filetype));
        !           408:                                            putdot( filename , line );
        !           409:                                            break;
        !           410:                                }
        !           411:                                /*
        !           412:                                 * put(file)
        !           413:                                 */
        !           414:                                putleaf( P2ICON , 0 , 0
        !           415:                                    , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           416:                                    , "_PUT" );
        !           417:                                putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
        !           418:                                        P2PTR|P2STRTY );
        !           419:                                putop( P2CALL , P2INT );
        !           420:                                putdot( filename , line );
        !           421:                                continue;
        !           422:                        }
        !           423:                        /*
        !           424:                         * Write to a textfile
        !           425:                         *
        !           426:                         * Evaluate the expression
        !           427:                         * to be written.
        !           428:                         */
        !           429:                        if (fmt == 'O' || fmt == 'X') {
        !           430:                                if (opt('s')) {
        !           431:                                        standard();
        !           432:                                        error("Oct and hex are non-standard");
        !           433:                                }
        !           434:                                if (typ == TSTR || typ == TDOUBLE) {
        !           435:                                        error("Can't write %ss with oct/hex", clnames[typ]);
        !           436:                                        continue;
        !           437:                                }
        !           438:                                if (typ == TCHAR || typ == TBOOL)
        !           439:                                        typ = TINT;
        !           440:                        }
        !           441:                        /*
        !           442:                         * If there is no format specified by the programmer,
        !           443:                         * implement the default.
        !           444:                         */
        !           445:                        switch (typ) {
        !           446:                        case TPTR:
        !           447:                                warning();
        !           448:                                if (opt('s')) {
        !           449:                                        standard();
        !           450:                                }
        !           451:                                error("Writing %ss to text files is non-standard",
        !           452:                                    clnames[typ]);
        !           453:                                /* and fall through */
        !           454:                        case TINT:
        !           455:                                if (fmt == 'f') {
        !           456:                                        typ = TDOUBLE;
        !           457:                                        goto tdouble;
        !           458:                                }
        !           459:                                if (fmtspec == NIL) {
        !           460:                                        if (fmt == 'D')
        !           461:                                                field = 10;
        !           462:                                        else if (fmt == 'X')
        !           463:                                                field = 8;
        !           464:                                        else if (fmt == 'O')
        !           465:                                                field = 11;
        !           466:                                        else
        !           467:                                                panic("fmt1");
        !           468:                                        fmtspec = CONWIDTH;
        !           469:                                }
        !           470:                                break;
        !           471:                        case TCHAR:
        !           472:                             tchar:
        !           473:                                fmt = 'c';
        !           474:                                break;
        !           475:                        case TSCAL:
        !           476:                                warning();
        !           477:                                if (opt('s')) {
        !           478:                                        standard();
        !           479:                                }
        !           480:                                error("Writing %ss to text files is non-standard",
        !           481:                                    clnames[typ]);
        !           482:                        case TBOOL:
        !           483:                                fmt = 's';
        !           484:                                break;
        !           485:                        case TDOUBLE:
        !           486:                             tdouble:
        !           487:                                switch (fmtspec) {
        !           488:                                case NIL:
        !           489:                                        field = 14 + (5 + EXPOSIZE);
        !           490:                                        prec = field - (5 + EXPOSIZE);
        !           491:                                        fmt = 'e';
        !           492:                                        fmtspec = CONWIDTH + CONPREC;
        !           493:                                        break;
        !           494:                                case CONWIDTH:
        !           495:                                        field -= REALSPC;
        !           496:                                        if (field < 1)
        !           497:                                                field = 1;
        !           498:                                        prec = field - (5 + EXPOSIZE);
        !           499:                                        if (prec < 1)
        !           500:                                                prec = 1;
        !           501:                                        fmtspec += CONPREC;
        !           502:                                        fmt = 'e';
        !           503:                                        break;
        !           504:                                case VARWIDTH:
        !           505:                                        fmtspec += VARPREC;
        !           506:                                        fmt = 'e';
        !           507:                                        break;
        !           508:                                case CONWIDTH + CONPREC:
        !           509:                                case CONWIDTH + VARPREC:
        !           510:                                        field -= REALSPC;
        !           511:                                        if (field < 1)
        !           512:                                                field = 1;
        !           513:                                }
        !           514:                                format[0] = ' ';
        !           515:                                fmtstart = 1 - REALSPC;
        !           516:                                break;
        !           517:                        case TSTR:
        !           518:                                constval( alv );
        !           519:                                switch ( classify( con.ctype ) ) {
        !           520:                                    case TCHAR:
        !           521:                                        typ = TCHAR;
        !           522:                                        goto tchar;
        !           523:                                    case TSTR:
        !           524:                                        strptr = con.cpval;
        !           525:                                        for (strnglen = 0;  *strptr++;  strnglen++) /* void */;
        !           526:                                        strptr = con.cpval;
        !           527:                                        break;
        !           528:                                    default:
        !           529:                                        strnglen = width(ap);
        !           530:                                        break;
        !           531:                                }
        !           532:                                fmt = 's';
        !           533:                                strfmt = fmtspec;
        !           534:                                if (fmtspec == NIL) {
        !           535:                                        fmtspec = SKIP;
        !           536:                                        break;
        !           537:                                }
        !           538:                                if (fmtspec & CONWIDTH) {
        !           539:                                        if (field <= strnglen)
        !           540:                                                fmtspec = SKIP;
        !           541:                                        else
        !           542:                                                field -= strnglen;
        !           543:                                }
        !           544:                                break;
        !           545:                        default:
        !           546:                                error("Can't write %ss to a text file", clnames[typ]);
        !           547:                                continue;
        !           548:                        }
        !           549:                        /*
        !           550:                         * Generate the format string
        !           551:                         */
        !           552:                        switch (fmtspec) {
        !           553:                        default:
        !           554:                                panic("fmt2");
        !           555:                        case NIL:
        !           556:                                if (fmt == 'c') {
        !           557:                                        if ( opt( 't' ) ) {
        !           558:                                            putleaf( P2ICON , 0 , 0
        !           559:                                                , ADDTYPE( P2FTN|P2INT , P2PTR )
        !           560:                                                , "_WRITEC" );
        !           561:                                            putRV( 0 , cbn , CURFILEOFFSET ,
        !           562:                                                    NLOCAL , P2PTR|P2STRTY );
        !           563:                                            stkrval( alv , NIL , RREQ );
        !           564:                                            putop( P2LISTOP , P2INT );
        !           565:                                        } else {
        !           566:                                            putleaf( P2ICON , 0 , 0
        !           567:                                                , ADDTYPE( P2FTN|P2INT , P2PTR )
        !           568:                                                , "_fputc" );
        !           569:                                            stkrval( alv , NIL , RREQ );
        !           570:                                        }
        !           571:                                        putleaf( P2ICON , 0 , 0
        !           572:                                            , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           573:                                            , "_ACTFILE" );
        !           574:                                        putRV( 0, cbn , CURFILEOFFSET ,
        !           575:                                                NLOCAL , P2PTR|P2STRTY );
        !           576:                                        putop( P2CALL , P2INT );
        !           577:                                        putop( P2LISTOP , P2INT );
        !           578:                                        putop( P2CALL , P2INT );
        !           579:                                        putdot( filename , line );
        !           580:                                } else  {
        !           581:                                        sprintf(&format[1], "%%%c", fmt);
        !           582:                                        goto fmtgen;
        !           583:                                }
        !           584:                        case SKIP:
        !           585:                                break;
        !           586:                        case CONWIDTH:
        !           587:                                sprintf(&format[1], "%%%1D%c", field, fmt);
        !           588:                                goto fmtgen;
        !           589:                        case VARWIDTH:
        !           590:                                sprintf(&format[1], "%%*%c", fmt);
        !           591:                                goto fmtgen;
        !           592:                        case CONWIDTH + CONPREC:
        !           593:                                sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt);
        !           594:                                goto fmtgen;
        !           595:                        case CONWIDTH + VARPREC:
        !           596:                                sprintf(&format[1], "%%%1D.*%c", field, fmt);
        !           597:                                goto fmtgen;
        !           598:                        case VARWIDTH + CONPREC:
        !           599:                                sprintf(&format[1], "%%*.%1D%c", prec, fmt);
        !           600:                                goto fmtgen;
        !           601:                        case VARWIDTH + VARPREC:
        !           602:                                sprintf(&format[1], "%%*.*%c", fmt);
        !           603:                        fmtgen:
        !           604:                                if ( opt( 't' ) ) {
        !           605:                                    putleaf( P2ICON , 0 , 0
        !           606:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           607:                                        , "_WRITEF" );
        !           608:                                    putRV( 0 , cbn , CURFILEOFFSET ,
        !           609:                                            NLOCAL , P2PTR|P2STRTY );
        !           610:                                    putleaf( P2ICON , 0 , 0
        !           611:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           612:                                        , "_ACTFILE" );
        !           613:                                    putRV( 0 , cbn , CURFILEOFFSET ,
        !           614:                                            NLOCAL , P2PTR|P2STRTY );
        !           615:                                    putop( P2CALL , P2INT );
        !           616:                                    putop( P2LISTOP , P2INT );
        !           617:                                } else {
        !           618:                                    putleaf( P2ICON , 0 , 0
        !           619:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           620:                                        , "_fprintf" );
        !           621:                                    putleaf( P2ICON , 0 , 0
        !           622:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           623:                                        , "_ACTFILE" );
        !           624:                                    putRV( 0 , cbn , CURFILEOFFSET ,
        !           625:                                            NLOCAL , P2PTR|P2STRTY );
        !           626:                                    putop( P2CALL , P2INT );
        !           627:                                }
        !           628:                                putCONG( &format[ fmtstart ]
        !           629:                                        , strlen( &format[ fmtstart ] )
        !           630:                                        , LREQ );
        !           631:                                putop( P2LISTOP , P2INT );
        !           632:                                if ( fmtspec & VARWIDTH ) {
        !           633:                                        /*
        !           634:                                         * either
        !           635:                                         *      ,(temp=width,MAX(temp,...)),
        !           636:                                         * or
        !           637:                                         *      , MAX( width , ... ) ,
        !           638:                                         */
        !           639:                                    if ( ( typ == TDOUBLE && al[3] == NIL )
        !           640:                                        || typ == TSTR ) {
        !           641:                                        soffset = sizes[cbn].curtmps;
        !           642:                                        tempnlp = tmpalloc(sizeof(long),
        !           643:                                                nl+T4INT, REGOK);
        !           644:                                        putRV( 0 , cbn ,
        !           645:                                            tempnlp -> value[ NL_OFFS ] ,
        !           646:                                            tempnlp -> extra_flags , P2INT );
        !           647:                                        ap = stkrval( al[2] , NIL , RREQ );
        !           648:                                        putop( P2ASSIGN , P2INT );
        !           649:                                        putleaf( P2ICON , 0 , 0
        !           650:                                            , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           651:                                            , "_MAX" );
        !           652:                                        putRV( 0 , cbn ,
        !           653:                                            tempnlp -> value[ NL_OFFS ] ,
        !           654:                                            tempnlp -> extra_flags , P2INT );
        !           655:                                    } else {
        !           656:                                        if (opt('t')
        !           657:                                            || typ == TSTR || typ == TDOUBLE) {
        !           658:                                            putleaf( P2ICON , 0 , 0
        !           659:                                                ,ADDTYPE( P2FTN | P2INT, P2PTR )
        !           660:                                                ,"_MAX" );
        !           661:                                        }
        !           662:                                        ap = stkrval( al[2] , NIL , RREQ );
        !           663:                                    }
        !           664:                                    if (ap == NIL)
        !           665:                                            continue;
        !           666:                                    if (isnta(ap,"i")) {
        !           667:                                            error("First write width must be integer, not %s", nameof(ap));
        !           668:                                            continue;
        !           669:                                    }
        !           670:                                    switch ( typ ) {
        !           671:                                    case TDOUBLE:
        !           672:                                        putleaf( P2ICON , REALSPC , 0 , P2INT , 0 );
        !           673:                                        putop( P2LISTOP , P2INT );
        !           674:                                        putleaf( P2ICON , 1 , 0 , P2INT , 0 );
        !           675:                                        putop( P2LISTOP , P2INT );
        !           676:                                        putop( P2CALL , P2INT );
        !           677:                                        if ( al[3] == NIL ) {
        !           678:                                                /*
        !           679:                                                 * finish up the comma op
        !           680:                                                 */
        !           681:                                            putop( P2COMOP , P2INT );
        !           682:                                            fmtspec &= ~VARPREC;
        !           683:                                            putop( P2LISTOP , P2INT );
        !           684:                                            putleaf( P2ICON , 0 , 0
        !           685:                                                , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           686:                                                , "_MAX" );
        !           687:                                            putRV( 0 , cbn ,
        !           688:                                                tempnlp -> value[ NL_OFFS ] ,
        !           689:                                                tempnlp -> extra_flags ,
        !           690:                                                P2INT );
        !           691:                                            tmpfree(&soffset);
        !           692:                                            putleaf( P2ICON ,
        !           693:                                                5 + EXPOSIZE + REALSPC ,
        !           694:                                                0 , P2INT , 0 );
        !           695:                                            putop( P2LISTOP , P2INT );
        !           696:                                            putleaf( P2ICON , 1 , 0 , P2INT , 0 );
        !           697:                                            putop( P2LISTOP , P2INT );
        !           698:                                            putop( P2CALL , P2INT );
        !           699:                                        }
        !           700:                                        putop( P2LISTOP , P2INT );
        !           701:                                        break;
        !           702:                                    case TSTR:
        !           703:                                        putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
        !           704:                                        putop( P2LISTOP , P2INT );
        !           705:                                        putleaf( P2ICON , 0 , 0 , P2INT , 0 );
        !           706:                                        putop( P2LISTOP , P2INT );
        !           707:                                        putop( P2CALL , P2INT );
        !           708:                                        putop( P2COMOP , P2INT );
        !           709:                                        putop( P2LISTOP , P2INT );
        !           710:                                        break;
        !           711:                                    default:
        !           712:                                        if (opt('t')) {
        !           713:                                            putleaf( P2ICON , 0 , 0 , P2INT , 0 );
        !           714:                                            putop( P2LISTOP , P2INT );
        !           715:                                            putleaf( P2ICON , 0 , 0 , P2INT , 0 );
        !           716:                                            putop( P2LISTOP , P2INT );
        !           717:                                            putop( P2CALL , P2INT );
        !           718:                                        }
        !           719:                                        putop( P2LISTOP , P2INT );
        !           720:                                        break;
        !           721:                                    }
        !           722:                                }
        !           723:                                /*
        !           724:                                 * If there is a variable precision,
        !           725:                                 * evaluate it 
        !           726:                                 */
        !           727:                                if (fmtspec & VARPREC) {
        !           728:                                        if (opt('t')) {
        !           729:                                        putleaf( P2ICON , 0 , 0
        !           730:                                            , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           731:                                            , "_MAX" );
        !           732:                                        }
        !           733:                                        ap = stkrval( al[3] , NIL , RREQ );
        !           734:                                        if (ap == NIL)
        !           735:                                                continue;
        !           736:                                        if (isnta(ap,"i")) {
        !           737:                                                error("Second write width must be integer, not %s", nameof(ap));
        !           738:                                                continue;
        !           739:                                        }
        !           740:                                        if (opt('t')) {
        !           741:                                            putleaf( P2ICON , 0 , 0 , P2INT , 0 );
        !           742:                                            putop( P2LISTOP , P2INT );
        !           743:                                            putleaf( P2ICON , 0 , 0 , P2INT , 0 );
        !           744:                                            putop( P2LISTOP , P2INT );
        !           745:                                            putop( P2CALL , P2INT );
        !           746:                                        }
        !           747:                                        putop( P2LISTOP , P2INT );
        !           748:                                }
        !           749:                                /*
        !           750:                                 * evaluate the thing we want printed.
        !           751:                                 */
        !           752:                                switch ( typ ) {
        !           753:                                case TPTR:
        !           754:                                case TCHAR:
        !           755:                                case TINT:
        !           756:                                    stkrval( alv , NIL , RREQ );
        !           757:                                    putop( P2LISTOP , P2INT );
        !           758:                                    break;
        !           759:                                case TDOUBLE:
        !           760:                                    ap = stkrval( alv , NIL , RREQ );
        !           761:                                    if (isnta(ap, "d")) {
        !           762:                                        sconv(p2type(ap), P2DOUBLE);
        !           763:                                    }
        !           764:                                    putop( P2LISTOP , P2INT );
        !           765:                                    break;
        !           766:                                case TSCAL:
        !           767:                                case TBOOL:
        !           768:                                    putleaf( P2ICON , 0 , 0
        !           769:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           770:                                        , "_NAM" );
        !           771:                                    ap = stkrval( alv , NIL , RREQ );
        !           772:                                    sprintf( format , PREFIXFORMAT , LABELPREFIX
        !           773:                                            , listnames( ap ) );
        !           774:                                    putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR
        !           775:                                            , format );
        !           776:                                    putop( P2LISTOP , P2INT );
        !           777:                                    putop( P2CALL , P2INT );
        !           778:                                    putop( P2LISTOP , P2INT );
        !           779:                                    break;
        !           780:                                case TSTR:
        !           781:                                    putCONG( "" , 0 , LREQ );
        !           782:                                    putop( P2LISTOP , P2INT );
        !           783:                                    break;
        !           784:                                default:
        !           785:                                    panic("fmt3");
        !           786:                                    break;
        !           787:                                }
        !           788:                                putop( P2CALL , P2INT );
        !           789:                                putdot( filename , line );
        !           790:                        }
        !           791:                        /*
        !           792:                         * Write the string after its blank padding
        !           793:                         */
        !           794:                        if (typ == TSTR ) {
        !           795:                                if ( opt( 't' ) ) {
        !           796:                                    putleaf( P2ICON , 0 , 0
        !           797:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           798:                                        , "_WRITES" );
        !           799:                                    putRV( 0 , cbn , CURFILEOFFSET ,
        !           800:                                            NLOCAL , P2PTR|P2STRTY );
        !           801:                                    ap = stkrval(alv, NIL , RREQ );
        !           802:                                    putop( P2LISTOP , P2INT );
        !           803:                                } else {
        !           804:                                    putleaf( P2ICON , 0 , 0
        !           805:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           806:                                        , "_fwrite" );
        !           807:                                    ap = stkrval(alv, NIL , RREQ );
        !           808:                                }
        !           809:                                if (strfmt & VARWIDTH) {
        !           810:                                            /*
        !           811:                                             *  min, inline expanded as
        !           812:                                             *  temp < len ? temp : len
        !           813:                                             */
        !           814:                                        putRV( 0 , cbn ,
        !           815:                                            tempnlp -> value[ NL_OFFS ] ,
        !           816:                                            tempnlp -> extra_flags , P2INT );
        !           817:                                        putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
        !           818:                                        putop( P2LT , P2INT );
        !           819:                                        putRV( 0 , cbn ,
        !           820:                                            tempnlp -> value[ NL_OFFS ] ,
        !           821:                                            tempnlp -> extra_flags , P2INT );
        !           822:                                        putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
        !           823:                                        putop( P2COLON , P2INT );
        !           824:                                        putop( P2QUEST , P2INT );
        !           825:                                        tmpfree(&soffset);
        !           826:                                } else {
        !           827:                                        if (   ( fmtspec & SKIP )
        !           828:                                            && ( strfmt & CONWIDTH ) ) {
        !           829:                                                strnglen = field;
        !           830:                                        }
        !           831:                                        putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
        !           832:                                }
        !           833:                                putop( P2LISTOP , P2INT );
        !           834:                                putleaf( P2ICON , 1 , 0 , P2INT , 0 );
        !           835:                                putop( P2LISTOP , P2INT );
        !           836:                                putleaf( P2ICON , 0 , 0
        !           837:                                    , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           838:                                    , "_ACTFILE" );
        !           839:                                putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
        !           840:                                        P2PTR|P2STRTY );
        !           841:                                putop( P2CALL , P2INT );
        !           842:                                putop( P2LISTOP , P2INT );
        !           843:                                putop( P2CALL , P2INT );
        !           844:                                putdot( filename , line );
        !           845:                        }
        !           846:                }
        !           847:                /*
        !           848:                 * Done with arguments.
        !           849:                 * Handle writeln and
        !           850:                 * insufficent number of args.
        !           851:                 */
        !           852:                switch (p->value[0] &~ NSTAND) {
        !           853:                        case O_WRITEF:
        !           854:                                if (argc == 0)
        !           855:                                        error("Write requires an argument");
        !           856:                                break;
        !           857:                        case O_MESSAGE:
        !           858:                                if (argc == 0)
        !           859:                                        error("Message requires an argument");
        !           860:                        case O_WRITLN:
        !           861:                                if (filetype != nl+T1CHAR)
        !           862:                                        error("Can't 'writeln' a non text file");
        !           863:                                if ( opt( 't' ) ) {
        !           864:                                    putleaf( P2ICON , 0 , 0
        !           865:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           866:                                        , "_WRITLN" );
        !           867:                                    putRV( 0 , cbn , CURFILEOFFSET ,
        !           868:                                            NLOCAL , P2PTR|P2STRTY );
        !           869:                                } else {
        !           870:                                    putleaf( P2ICON , 0 , 0
        !           871:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           872:                                        , "_fputc" );
        !           873:                                    putleaf( P2ICON , '\n' , 0 , P2CHAR , 0 );
        !           874:                                    putleaf( P2ICON , 0 , 0
        !           875:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           876:                                        , "_ACTFILE" );
        !           877:                                    putRV( 0 , cbn , CURFILEOFFSET ,
        !           878:                                            NLOCAL , P2PTR|P2STRTY );
        !           879:                                    putop( P2CALL , P2INT );
        !           880:                                    putop( P2LISTOP , P2INT );
        !           881:                                }
        !           882:                                putop( P2CALL , P2INT );
        !           883:                                putdot( filename , line );
        !           884:                                break;
        !           885:                }
        !           886:                return;
        !           887: 
        !           888:        case O_READ4:
        !           889:        case O_READLN:
        !           890:                /*
        !           891:                 * Set up default
        !           892:                 * file "input".
        !           893:                 */
        !           894:                file = NIL;
        !           895:                filetype = nl+T1CHAR;
        !           896:                /*
        !           897:                 * Determine the file implied
        !           898:                 * for the read and generate
        !           899:                 * code to make it the active file.
        !           900:                 */
        !           901:                if (argv != NIL) {
        !           902:                        codeoff();
        !           903:                        ap = stkrval(argv[1], NIL , RREQ );
        !           904:                        codeon();
        !           905:                        if (ap == NIL)
        !           906:                                argv = argv[2];
        !           907:                        if (ap != NIL && ap->class == FILET) {
        !           908:                                /*
        !           909:                                 * Got "read(f, ...", make
        !           910:                                 * f the active file, and save
        !           911:                                 * it and its type for use in
        !           912:                                 * processing the rest of the
        !           913:                                 * arguments to read.
        !           914:                                 */
        !           915:                                file = argv[1];
        !           916:                                filetype = ap->type;
        !           917:                                putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
        !           918:                                        P2PTR|P2STRTY );
        !           919:                                putleaf( P2ICON , 0 , 0 
        !           920:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           921:                                        , "_UNIT" );
        !           922:                                stklval(argv[1], NOFLAGS);
        !           923:                                putop( P2CALL , P2INT );
        !           924:                                putop( P2ASSIGN , P2PTR|P2STRTY );
        !           925:                                putdot( filename , line );
        !           926:                                argv = argv[2];
        !           927:                                argc--;
        !           928:                        } else {
        !           929:                                /*
        !           930:                                 * Default is read from
        !           931:                                 * standard input.
        !           932:                                 */
        !           933:                                putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
        !           934:                                        P2PTR|P2STRTY );
        !           935:                                putLV( "_input" , 0 , 0 , NGLOBAL ,
        !           936:                                        P2PTR|P2STRTY );
        !           937:                                putop( P2ASSIGN , P2PTR|P2STRTY );
        !           938:                                putdot( filename , line );
        !           939:                                input->nl_flags |= NUSED;
        !           940:                        }
        !           941:                } else {
        !           942:                        putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
        !           943:                                P2PTR|P2STRTY );
        !           944:                        putLV( "_input" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY );
        !           945:                        putop( P2ASSIGN , P2PTR|P2STRTY );
        !           946:                        putdot( filename , line );
        !           947:                        input->nl_flags |= NUSED;
        !           948:                }
        !           949:                /*
        !           950:                 * Loop and process each
        !           951:                 * of the arguments.
        !           952:                 */
        !           953:                for (; argv != NIL; argv = argv[2]) {
        !           954:                        /*
        !           955:                         * Get the address of the target
        !           956:                         * on the stack.
        !           957:                         */
        !           958:                        al = argv[1];
        !           959:                        if (al == NIL)
        !           960:                                continue;
        !           961:                        if (al[0] != T_VAR) {
        !           962:                                error("Arguments to %s must be variables, not expressions", p->symbol);
        !           963:                                continue;
        !           964:                        }
        !           965:                        codeoff();
        !           966:                        ap = stklval(al, MOD|ASGN|NOUSE);
        !           967:                        codeon();
        !           968:                        if (ap == NIL)
        !           969:                                continue;
        !           970:                        if (filetype != nl+T1CHAR) {
        !           971:                                /*
        !           972:                                 * Generalized read, i.e.
        !           973:                                 * from a non-textfile.
        !           974:                                 */
        !           975:                                if (incompat(filetype, ap, argv[1] )) {
        !           976:                                        error("Type mismatch in read from non-text file");
        !           977:                                        continue;
        !           978:                                }
        !           979:                                /*
        !           980:                                 * var := file ^;
        !           981:                                 */
        !           982:                                ap = lvalue( al , MOD | ASGN | NOUSE , RREQ );
        !           983:                                if ( isa( ap , "bsci" ) ) {
        !           984:                                        precheck( ap , "_RANG4" , "_RSNG4" );
        !           985:                                }
        !           986:                                putleaf( P2ICON , 0 , 0
        !           987:                                    , ADDTYPE(
        !           988:                                        ADDTYPE(
        !           989:                                            ADDTYPE(
        !           990:                                                p2type( filetype ) , P2PTR )
        !           991:                                            , P2FTN )
        !           992:                                        , P2PTR )
        !           993:                                    , "_FNIL" );
        !           994:                                if (file != NIL)
        !           995:                                        stklval(file, NOFLAGS);
        !           996:                                else /* Magic */
        !           997:                                        putRV( "_input" , 0 , 0 , NGLOBAL ,
        !           998:                                                P2PTR | P2STRTY );
        !           999:                                putop(P2CALL, ADDTYPE(p2type(filetype), P2PTR));
        !          1000:                                switch ( classify( filetype ) ) {
        !          1001:                                    case TBOOL:
        !          1002:                                    case TCHAR:
        !          1003:                                    case TINT:
        !          1004:                                    case TSCAL:
        !          1005:                                    case TDOUBLE:
        !          1006:                                    case TPTR:
        !          1007:                                        putop( P2UNARY P2MUL
        !          1008:                                                , p2type( filetype ) );
        !          1009:                                }
        !          1010:                                switch ( classify( filetype ) ) {
        !          1011:                                    case TBOOL:
        !          1012:                                    case TCHAR:
        !          1013:                                    case TINT:
        !          1014:                                    case TSCAL:
        !          1015:                                            postcheck(ap, filetype);
        !          1016:                                            sconv(p2type(filetype), p2type(ap));
        !          1017:                                                /* and fall through */
        !          1018:                                    case TDOUBLE:
        !          1019:                                    case TPTR:
        !          1020:                                            putop( P2ASSIGN , p2type( ap ) );
        !          1021:                                            putdot( filename , line );
        !          1022:                                            break;
        !          1023:                                    default:
        !          1024:                                            putstrop(P2STASG,
        !          1025:                                                    ADDTYPE(p2type(ap), P2PTR),
        !          1026:                                                    lwidth(ap),
        !          1027:                                                    align(ap));
        !          1028:                                            putdot( filename , line );
        !          1029:                                            break;
        !          1030:                                }
        !          1031:                                /*
        !          1032:                                 * get(file);
        !          1033:                                 */
        !          1034:                                putleaf( P2ICON , 0 , 0 
        !          1035:                                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1036:                                        , "_GET" );
        !          1037:                                putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
        !          1038:                                        P2PTR|P2STRTY );
        !          1039:                                putop( P2CALL , P2INT );
        !          1040:                                putdot( filename , line );
        !          1041:                                continue;
        !          1042:                        }
        !          1043:                            /*
        !          1044:                             *  if you get to here, you are reading from
        !          1045:                             *  a text file.  only possiblities are:
        !          1046:                             *  character, integer, real, or scalar.
        !          1047:                             *  read( f , foo , ... ) is done as
        !          1048:                             *  foo := read( f ) with rangechecking
        !          1049:                             *  if appropriate.
        !          1050:                             */
        !          1051:                        typ = classify(ap);
        !          1052:                        op = rdops(typ);
        !          1053:                        if (op == NIL) {
        !          1054:                                error("Can't read %ss from a text file", clnames[typ]);
        !          1055:                                continue;
        !          1056:                        }
        !          1057:                            /*
        !          1058:                             *  left hand side of foo := read( f )
        !          1059:                             */
        !          1060:                        ap = lvalue( al , MOD|ASGN|NOUSE , RREQ );
        !          1061:                        if ( isa( ap , "bsci" ) ) {
        !          1062:                            precheck( ap , "_RANG4" , "_RSNG4" );
        !          1063:                        }
        !          1064:                        switch ( op ) {
        !          1065:                            case O_READC:
        !          1066:                                readname = "_READC";
        !          1067:                                readtype = P2INT;
        !          1068:                                break;
        !          1069:                            case O_READ4:
        !          1070:                                readname = "_READ4";
        !          1071:                                readtype = P2INT;
        !          1072:                                break;
        !          1073:                            case O_READ8:
        !          1074:                                readname = "_READ8";
        !          1075:                                readtype = P2DOUBLE;
        !          1076:                                break;
        !          1077:                            case O_READE:
        !          1078:                                readname = "_READE";
        !          1079:                                readtype = P2INT;
        !          1080:                                break;
        !          1081:                        }
        !          1082:                        putleaf( P2ICON , 0 , 0
        !          1083:                                , ADDTYPE( P2FTN | readtype , P2PTR )
        !          1084:                                , readname );
        !          1085:                        putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
        !          1086:                                P2PTR|P2STRTY );
        !          1087:                        if ( op == O_READE ) {
        !          1088:                                sprintf( format , PREFIXFORMAT , LABELPREFIX
        !          1089:                                        , listnames( ap ) );
        !          1090:                                putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR
        !          1091:                                        , format );
        !          1092:                                putop( P2LISTOP , P2INT );
        !          1093:                                warning();
        !          1094:                                if (opt('s')) {
        !          1095:                                        standard();
        !          1096:                                }
        !          1097:                                error("Reading scalars from text files is non-standard");
        !          1098:                        }
        !          1099:                        putop( P2CALL , readtype );
        !          1100:                        if ( isa( ap , "bcsi" ) ) {
        !          1101:                            postcheck(ap, readtype==P2INT?nl+T4INT:nl+TDOUBLE);
        !          1102:                        }
        !          1103:                        sconv(readtype, p2type(ap));
        !          1104:                        putop( P2ASSIGN , p2type( ap ) );
        !          1105:                        putdot( filename , line );
        !          1106:                }
        !          1107:                /*
        !          1108:                 * Done with arguments.
        !          1109:                 * Handle readln and
        !          1110:                 * insufficient number of args.
        !          1111:                 */
        !          1112:                if (p->value[0] == O_READLN) {
        !          1113:                        if (filetype != nl+T1CHAR)
        !          1114:                                error("Can't 'readln' a non text file");
        !          1115:                        putleaf( P2ICON , 0 , 0 
        !          1116:                                , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1117:                                , "_READLN" );
        !          1118:                        putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
        !          1119:                                P2PTR|P2STRTY );
        !          1120:                        putop( P2CALL , P2INT );
        !          1121:                        putdot( filename , line );
        !          1122:                } else if (argc == 0)
        !          1123:                        error("read requires an argument");
        !          1124:                return;
        !          1125: 
        !          1126:        case O_GET:
        !          1127:        case O_PUT:
        !          1128:                if (argc != 1) {
        !          1129:                        error("%s expects one argument", p->symbol);
        !          1130:                        return;
        !          1131:                }
        !          1132:                putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
        !          1133:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1134:                        , "_UNIT" );
        !          1135:                ap = stklval(argv[1], NOFLAGS);
        !          1136:                if (ap == NIL)
        !          1137:                        return;
        !          1138:                if (ap->class != FILET) {
        !          1139:                        error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
        !          1140:                        return;
        !          1141:                }
        !          1142:                putop( P2CALL , P2INT );
        !          1143:                putop( P2ASSIGN , P2PTR|P2STRTY );
        !          1144:                putdot( filename , line );
        !          1145:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1146:                        , op == O_GET ? "_GET" : "_PUT" );
        !          1147:                putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
        !          1148:                putop( P2CALL , P2INT );
        !          1149:                putdot( filename , line );
        !          1150:                return;
        !          1151: 
        !          1152:        case O_RESET:
        !          1153:        case O_REWRITE:
        !          1154:                if (argc == 0 || argc > 2) {
        !          1155:                        error("%s expects one or two arguments", p->symbol);
        !          1156:                        return;
        !          1157:                }
        !          1158:                if (opt('s') && argc == 2) {
        !          1159:                        standard();
        !          1160:                        error("Two argument forms of reset and rewrite are non-standard");
        !          1161:                }
        !          1162:                putleaf( P2ICON , 0 , 0 , P2INT
        !          1163:                        , op == O_RESET ? "_RESET" : "_REWRITE" );
        !          1164:                ap = stklval(argv[1], MOD|NOUSE);
        !          1165:                if (ap == NIL)
        !          1166:                        return;
        !          1167:                if (ap->class != FILET) {
        !          1168:                        error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
        !          1169:                        return;
        !          1170:                }
        !          1171:                if (argc == 2) {
        !          1172:                        /*
        !          1173:                         * Optional second argument
        !          1174:                         * is a string name of a
        !          1175:                         * UNIX (R) file to be associated.
        !          1176:                         */
        !          1177:                        al = argv[2];
        !          1178:                        al = stkrval(al[1], NOFLAGS , RREQ );
        !          1179:                        if (al == NIL)
        !          1180:                                return;
        !          1181:                        if (classify(al) != TSTR) {
        !          1182:                                error("Second argument to %s must be a string, not %s", p->symbol, nameof(al));
        !          1183:                                return;
        !          1184:                        }
        !          1185:                        strnglen = width(al);
        !          1186:                } else {
        !          1187:                        putleaf( P2ICON , 0 , 0 , P2INT , 0 );
        !          1188:                        strnglen = 0;
        !          1189:                }
        !          1190:                putop( P2LISTOP , P2INT );
        !          1191:                putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
        !          1192:                putop( P2LISTOP , P2INT );
        !          1193:                putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 );
        !          1194:                putop( P2LISTOP , P2INT );
        !          1195:                putop( P2CALL , P2INT );
        !          1196:                putdot( filename , line );
        !          1197:                return;
        !          1198: 
        !          1199:        case O_NEW:
        !          1200:        case O_DISPOSE:
        !          1201:                if (argc == 0) {
        !          1202:                        error("%s expects at least one argument", p->symbol);
        !          1203:                        return;
        !          1204:                }
        !          1205:                alv = argv[1];
        !          1206:                codeoff();
        !          1207:                ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
        !          1208:                codeon();
        !          1209:                if (ap == NIL)
        !          1210:                        return;
        !          1211:                if (ap->class != PTR) {
        !          1212:                        error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
        !          1213:                        return;
        !          1214:                }
        !          1215:                ap = ap->type;
        !          1216:                if (ap == NIL)
        !          1217:                        return;
        !          1218:                if (op == O_NEW)
        !          1219:                        cmd = "_NEW";
        !          1220:                else /* op == O_DISPOSE */
        !          1221:                        if ((ap->nl_flags & NFILES) != 0)
        !          1222:                                cmd = "_DFDISPOSE";
        !          1223:                        else
        !          1224:                                cmd = "_DISPOSE";
        !          1225:                putleaf( P2ICON, 0, 0, ADDTYPE( P2FTN | P2INT , P2PTR ), cmd);
        !          1226:                stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
        !          1227:                argv = argv[2];
        !          1228:                if (argv != NIL) {
        !          1229:                        if (ap->class != RECORD) {
        !          1230:                                error("Record required when specifying variant tags");
        !          1231:                                return;
        !          1232:                        }
        !          1233:                        for (; argv != NIL; argv = argv[2]) {
        !          1234:                                if (ap->ptr[NL_VARNT] == NIL) {
        !          1235:                                        error("Too many tag fields");
        !          1236:                                        return;
        !          1237:                                }
        !          1238:                                if (!isconst(argv[1])) {
        !          1239:                                        error("Second and successive arguments to %s must be constants", p->symbol);
        !          1240:                                        return;
        !          1241:                                }
        !          1242:                                gconst(argv[1]);
        !          1243:                                if (con.ctype == NIL)
        !          1244:                                        return;
        !          1245:                                if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) {
        !          1246:                                        cerror("Specified tag constant type clashed with variant case selector type");
        !          1247:                                        return;
        !          1248:                                }
        !          1249:                                for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
        !          1250:                                        if (ap->range[0] == con.crval)
        !          1251:                                                break;
        !          1252:                                if (ap == NIL) {
        !          1253:                                        error("No variant case label value equals specified constant value");
        !          1254:                                        return;
        !          1255:                                }
        !          1256:                                ap = ap->ptr[NL_VTOREC];
        !          1257:                        }
        !          1258:                }
        !          1259:                putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
        !          1260:                putop( P2LISTOP , P2INT );
        !          1261:                putop( P2CALL , P2INT );
        !          1262:                putdot( filename , line );
        !          1263:                if (opt('t') && op == O_NEW) {
        !          1264:                    putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1265:                            , "_blkclr" );
        !          1266:                    stkrval(alv, NIL , RREQ );
        !          1267:                    putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
        !          1268:                    putop( P2LISTOP , P2INT );
        !          1269:                    putop( P2CALL , P2INT );
        !          1270:                    putdot( filename , line );
        !          1271:                }
        !          1272:                return;
        !          1273: 
        !          1274:        case O_DATE:
        !          1275:        case O_TIME:
        !          1276:                if (argc != 1) {
        !          1277:                        error("%s expects one argument", p->symbol);
        !          1278:                        return;
        !          1279:                }
        !          1280:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1281:                        , op == O_DATE ? "_DATE" : "_TIME" );
        !          1282:                ap = stklval(argv[1], MOD|NOUSE);
        !          1283:                if (ap == NIL)
        !          1284:                        return;
        !          1285:                if (classify(ap) != TSTR || width(ap) != 10) {
        !          1286:                        error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
        !          1287:                        return;
        !          1288:                }
        !          1289:                putop( P2CALL , P2INT );
        !          1290:                putdot( filename , line );
        !          1291:                return;
        !          1292: 
        !          1293:        case O_HALT:
        !          1294:                if (argc != 0) {
        !          1295:                        error("halt takes no arguments");
        !          1296:                        return;
        !          1297:                }
        !          1298:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1299:                        , "_HALT" );
        !          1300: 
        !          1301:                putop( P2UNARY P2CALL , P2INT );
        !          1302:                putdot( filename , line );
        !          1303:                noreach = 1;
        !          1304:                return;
        !          1305: 
        !          1306:        case O_ARGV:
        !          1307:                if (argc != 2) {
        !          1308:                        error("argv takes two arguments");
        !          1309:                        return;
        !          1310:                }
        !          1311:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1312:                        , "_ARGV" );
        !          1313:                ap = stkrval(argv[1], NIL , RREQ );
        !          1314:                if (ap == NIL)
        !          1315:                        return;
        !          1316:                if (isnta(ap, "i")) {
        !          1317:                        error("argv's first argument must be an integer, not %s", nameof(ap));
        !          1318:                        return;
        !          1319:                }
        !          1320:                al = argv[2];
        !          1321:                ap = stklval(al[1], MOD|NOUSE);
        !          1322:                if (ap == NIL)
        !          1323:                        return;
        !          1324:                if (classify(ap) != TSTR) {
        !          1325:                        error("argv's second argument must be a string, not %s", nameof(ap));
        !          1326:                        return;
        !          1327:                }
        !          1328:                putop( P2LISTOP , P2INT );
        !          1329:                putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
        !          1330:                putop( P2LISTOP , P2INT );
        !          1331:                putop( P2CALL , P2INT );
        !          1332:                putdot( filename , line );
        !          1333:                return;
        !          1334: 
        !          1335:        case O_STLIM:
        !          1336:                if (argc != 1) {
        !          1337:                        error("stlimit requires one argument");
        !          1338:                        return;
        !          1339:                }
        !          1340:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1341:                        , "_STLIM" );
        !          1342:                ap = stkrval(argv[1], NIL , RREQ );
        !          1343:                if (ap == NIL)
        !          1344:                        return;
        !          1345:                if (isnta(ap, "i")) {
        !          1346:                        error("stlimit's argument must be an integer, not %s", nameof(ap));
        !          1347:                        return;
        !          1348:                }
        !          1349:                putop( P2CALL , P2INT );
        !          1350:                putdot( filename , line );
        !          1351:                return;
        !          1352: 
        !          1353:        case O_REMOVE:
        !          1354:                if (argc != 1) {
        !          1355:                        error("remove expects one argument");
        !          1356:                        return;
        !          1357:                }
        !          1358:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1359:                        , "_REMOVE" );
        !          1360:                ap = stkrval(argv[1], NOFLAGS , RREQ );
        !          1361:                if (ap == NIL)
        !          1362:                        return;
        !          1363:                if (classify(ap) != TSTR) {
        !          1364:                        error("remove's argument must be a string, not %s", nameof(ap));
        !          1365:                        return;
        !          1366:                }
        !          1367:                putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
        !          1368:                putop( P2LISTOP , P2INT );
        !          1369:                putop( P2CALL , P2INT );
        !          1370:                putdot( filename , line );
        !          1371:                return;
        !          1372: 
        !          1373:        case O_LLIMIT:
        !          1374:                if (argc != 2) {
        !          1375:                        error("linelimit expects two arguments");
        !          1376:                        return;
        !          1377:                }
        !          1378:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1379:                        , "_LLIMIT" );
        !          1380:                ap = stklval(argv[1], NOFLAGS|NOUSE);
        !          1381:                if (ap == NIL)
        !          1382:                        return;
        !          1383:                if (!text(ap)) {
        !          1384:                        error("linelimit's first argument must be a text file, not %s", nameof(ap));
        !          1385:                        return;
        !          1386:                }
        !          1387:                al = argv[2];
        !          1388:                ap = stkrval(al[1], NIL , RREQ );
        !          1389:                if (ap == NIL)
        !          1390:                        return;
        !          1391:                if (isnta(ap, "i")) {
        !          1392:                        error("linelimit's second argument must be an integer, not %s", nameof(ap));
        !          1393:                        return;
        !          1394:                }
        !          1395:                putop( P2LISTOP , P2INT );
        !          1396:                putop( P2CALL , P2INT );
        !          1397:                putdot( filename , line );
        !          1398:                return;
        !          1399:        case O_PAGE:
        !          1400:                if (argc != 1) {
        !          1401:                        error("page expects one argument");
        !          1402:                        return;
        !          1403:                }
        !          1404:                putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
        !          1405:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1406:                        , "_UNIT" );
        !          1407:                ap = stklval(argv[1], NOFLAGS);
        !          1408:                if (ap == NIL)
        !          1409:                        return;
        !          1410:                if (!text(ap)) {
        !          1411:                        error("Argument to page must be a text file, not %s", nameof(ap));
        !          1412:                        return;
        !          1413:                }
        !          1414:                putop( P2CALL , P2INT );
        !          1415:                putop( P2ASSIGN , P2PTR|P2STRTY );
        !          1416:                putdot( filename , line );
        !          1417:                if ( opt( 't' ) ) {
        !          1418:                    putleaf( P2ICON , 0 , 0
        !          1419:                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1420:                        , "_PAGE" );
        !          1421:                    putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
        !          1422:                } else {
        !          1423:                    putleaf( P2ICON , 0 , 0
        !          1424:                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1425:                        , "_fputc" );
        !          1426:                    putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 );
        !          1427:                    putleaf( P2ICON , 0 , 0
        !          1428:                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1429:                        , "_ACTFILE" );
        !          1430:                    putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
        !          1431:                    putop( P2CALL , P2INT );
        !          1432:                    putop( P2LISTOP , P2INT );
        !          1433:                }
        !          1434:                putop( P2CALL , P2INT );
        !          1435:                putdot( filename , line );
        !          1436:                return;
        !          1437: 
        !          1438:        case O_ASRT:
        !          1439:                if (!opt('t'))
        !          1440:                        return;
        !          1441:                if (argc == 0 || argc > 2) {
        !          1442:                        error("Assert expects one or two arguments");
        !          1443:                        return;
        !          1444:                }
        !          1445:                if (argc == 2)
        !          1446:                        cmd = "_ASRTS";
        !          1447:                else
        !          1448:                        cmd = "_ASRT";
        !          1449:                putleaf( P2ICON , 0 , 0
        !          1450:                    , ADDTYPE( P2FTN | P2INT , P2PTR ) , cmd );
        !          1451:                ap = stkrval(argv[1], NIL , RREQ );
        !          1452:                if (ap == NIL)
        !          1453:                        return;
        !          1454:                if (isnta(ap, "b"))
        !          1455:                        error("Assert expression must be Boolean, not %ss", nameof(ap));
        !          1456:                if (argc == 2) {
        !          1457:                        /*
        !          1458:                         * Optional second argument is a string specifying
        !          1459:                         * why the assertion failed.
        !          1460:                         */
        !          1461:                        al = argv[2];
        !          1462:                        al = stkrval(al[1], NIL , RREQ );
        !          1463:                        if (al == NIL)
        !          1464:                                return;
        !          1465:                        if (classify(al) != TSTR) {
        !          1466:                                error("Second argument to assert must be a string, not %s", nameof(al));
        !          1467:                                return;
        !          1468:                        }
        !          1469:                        putop( P2LISTOP , P2INT );
        !          1470:                }
        !          1471:                putop( P2CALL , P2INT );
        !          1472:                putdot( filename , line );
        !          1473:                return;
        !          1474: 
        !          1475:        case O_PACK:
        !          1476:                if (argc != 3) {
        !          1477:                        error("pack expects three arguments");
        !          1478:                        return;
        !          1479:                }
        !          1480:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1481:                        , "_PACK" );
        !          1482:                pu = "pack(a,i,z)";
        !          1483:                pua = (al = argv)[1];
        !          1484:                pui = (al = al[2])[1];
        !          1485:                puz = (al = al[2])[1];
        !          1486:                goto packunp;
        !          1487:        case O_UNPACK:
        !          1488:                if (argc != 3) {
        !          1489:                        error("unpack expects three arguments");
        !          1490:                        return;
        !          1491:                }
        !          1492:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
        !          1493:                        , "_UNPACK" );
        !          1494:                pu = "unpack(z,a,i)";
        !          1495:                puz = (al = argv)[1];
        !          1496:                pua = (al = al[2])[1];
        !          1497:                pui = (al = al[2])[1];
        !          1498: packunp:
        !          1499:                ap = stkrval((int *) pui, NLNIL , RREQ );
        !          1500:                if (ap == NIL)
        !          1501:                        return;
        !          1502:                ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
        !          1503:                if (ap == NIL)
        !          1504:                        return;
        !          1505:                if (ap->class != ARRAY) {
        !          1506:                        error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
        !          1507:                        return;
        !          1508:                }
        !          1509:                putop( P2LISTOP , P2INT );
        !          1510:                al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
        !          1511:                if (al->class != ARRAY) {
        !          1512:                        error("%s requires z to be a packed array, not %s", pu, nameof(ap));
        !          1513:                        return;
        !          1514:                }
        !          1515:                if (al->type == NIL || ap->type == NIL)
        !          1516:                        return;
        !          1517:                if (al->type != ap->type) {
        !          1518:                        error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
        !          1519:                        return;
        !          1520:                }
        !          1521:                putop( P2LISTOP , P2INT );
        !          1522:                k = width(al);
        !          1523:                itemwidth = width(ap->type);
        !          1524:                ap = ap->chain;
        !          1525:                al = al->chain;
        !          1526:                if (ap->chain != NIL || al->chain != NIL) {
        !          1527:                        error("%s requires a and z to be single dimension arrays", pu);
        !          1528:                        return;
        !          1529:                }
        !          1530:                if (ap == NIL || al == NIL)
        !          1531:                        return;
        !          1532:                /*
        !          1533:                 * al is the range for z i.e. u..v
        !          1534:                 * ap is the range for a i.e. m..n
        !          1535:                 * i will be n-m+1
        !          1536:                 * j will be v-u+1
        !          1537:                 */
        !          1538:                i = ap->range[1] - ap->range[0] + 1;
        !          1539:                j = al->range[1] - al->range[0] + 1;
        !          1540:                if (i < j) {
        !          1541:                        error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i);
        !          1542:                        return;
        !          1543:                }
        !          1544:                /*
        !          1545:                 * get n-m-(v-u) and m for the interpreter
        !          1546:                 */
        !          1547:                i -= j;
        !          1548:                j = ap->range[0];
        !          1549:                putleaf( P2ICON , itemwidth , 0 , P2INT , 0 );
        !          1550:                putop( P2LISTOP , P2INT );
        !          1551:                putleaf( P2ICON , j , 0 , P2INT , 0 );
        !          1552:                putop( P2LISTOP , P2INT );
        !          1553:                putleaf( P2ICON , i , 0 , P2INT , 0 );
        !          1554:                putop( P2LISTOP , P2INT );
        !          1555:                putleaf( P2ICON , k , 0 , P2INT , 0 );
        !          1556:                putop( P2LISTOP , P2INT );
        !          1557:                putop( P2CALL , P2INT );
        !          1558:                putdot( filename , line );
        !          1559:                return;
        !          1560:        case 0:
        !          1561:                error("%s is an unimplemented extension", p->symbol);
        !          1562:                return;
        !          1563: 
        !          1564:        default:
        !          1565:                panic("proc case");
        !          1566:        }
        !          1567: }
        !          1568: #endif PC

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