# 2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/proc.c

##### Functions

    proc              X

##### Variables

    rdxxxx            X

##### Macros

    CONPREC           X
    CONWIDTH          X
    EXPOSIZE          X
    REALSPC           X
    SKIP              X
    VARPREC           X
    VARWIDTH          X
    rdops             X

       1: /*
       2:  * Copyright (c) 1980 Regents of the University of California.
       3:  * All rights reserved.  The Berkeley software License Agreement
       4:  * specifies the terms and conditions for redistribution.
       5:  */
       6:
       7: #ifndef lint
       8: static char sccsid[] = "@(#)proc.c	5.1 (Berkeley) 6/5/85";
       9: #endif not lint
      10:
      11: #include "whoami.h"
      12: #ifdef OBJ
      13:     /*
      14:      *	and the rest of the file
      15:      */
      16: #include "0.h"
      17: #include "tree.h"
      18: #include "opcode.h"
      19: #include "objfmt.h"
      20: #include "tmps.h"
      21: #include "tree_ty.h"
      22:
      23: /*
      24:  * The constant EXPOSIZE specifies the number of digits in the exponent
      25:  * of real numbers.
      26:  *
      27:  * The constant REALSPC defines the amount of forced padding preceeding
      28:  * real numbers when they are printed. If REALSPC == 0, then no padding
      29:  * is added, REALSPC == 1 adds one extra blank irregardless of the width
      30:  * specified by the user.
      31:  *
      32:  * N.B. - Values greater than one require program mods.
      33:  */
      34: #define EXPOSIZE    2
      35: #define REALSPC     0
      36:
      37: /*
      38:  * The following array is used to determine which classes may be read
      39:  * from textfiles. It is indexed by the return value from classify.
      40:  */
      41: #define rdops(x) rdxxxx[(x)-(TFIRST)]
      42:
      43: int rdxxxx[] = {
      44:     0,      /* -7 file types */
      45:     0,      /* -6 record types */
      46:     0,      /* -5 array types */
      47:     O_READE,    /* -4 scalar types */
      48:     0,      /* -3 pointer types */
      49:     0,      /* -2 set types */
      50:     0,      /* -1 string types */
      51:     0,      /*  0 nil, no type */
      52:     O_READE,    /*  1 boolean */
      53:     O_READC,    /*  2 character */
      54:     O_READ4,    /*  3 integer */
      55:     O_READ8     /*  4 real */
      56: };
      57:
      58: /*
      59:  * Proc handles procedure calls.
      60:  * Non-builtin procedures are "buck-passed" to func (with a flag
      61:  * indicating that they are actually procedures.
      62:  * builtin procedures are handled here.
      63:  */
      64: proc(r)
      65:     struct tnode *r;
      66: {
      67:     register struct nl *p;
      68:     register struct tnode *alv, *al;
      69:     register int op;
      70:     struct nl *filetype, *ap, *al1;
      71:     int argc, typ, fmtspec, strfmt, stkcnt;
      72:     struct tnode *argv;
      73:     char fmt, format[20], *strptr, *pu;
      74:     int prec, field, strnglen, fmtlen, fmtstart;
      75:     struct tnode *pua, *pui, *puz, *file;
      76:     int i, j, k;
      77:     int itemwidth;
      78:     struct tmps soffset;
      79:     struct nl   *tempnlp;
      80:
      81: #define CONPREC 4
      82: #define VARPREC 8
      83: #define CONWIDTH 1
      84: #define VARWIDTH 2
      85: #define SKIP 16
      86:
      87:     /*
      88: 	 * Verify that the name is
      89: 	 * defined and is that of a
      90: 	 * procedure.
      91: 	 */
      92:     p = lookup(r->pcall_node.proc_id);
      93:     if (p == NIL) {
      94:         rvlist(r->pcall_node.arg);
      95:         return;
      96:     }
      97:     if (p->class != PROC && p->class != FPROC) {
      98:         error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
      99:         rvlist(r->pcall_node.arg);
     100:         return;
     101:     }
     102:     argv = r->pcall_node.arg;
     103:
     104:     /*
     105: 	 * Call handles user defined
     106: 	 * procedures and functions.
     107: 	 */
     108:     if (bn != 0) {
     109:         (void) call(p, argv, PROC, bn);
     110:         return;
     111:     }
     112:
     113:     /*
     114: 	 * Call to built-in procedure.
     115: 	 * Count the arguments.
     116: 	 */
     117:     argc = 0;
     118:     for (al = argv; al != TR_NIL; al = al->list_node.next)
     119:         argc++;
     120:
     121:     /*
     122: 	 * Switch on the operator
     123: 	 * associated with the built-in
     124: 	 * procedure in the namelist
     125: 	 */
     126:     op = p->value[0] &~ NSTAND;
     127:     if (opt('s') && (p->value[0] & NSTAND)) {
     128:         standard();
     129:         error("%s is a nonstandard procedure", p->symbol);
     130:     }
     131:     switch (op) {
     132:
     133:     case O_ABORT:
     134:         if (argc != 0)
     135:             error("null takes no arguments");
     136:         return;
     137:
     138:     case O_FLUSH:
     139:         if (argc == 0) {
     140:             (void) put(1, O_MESSAGE);
     141:             return;
     142:         }
     143:         if (argc != 1) {
     144:             error("flush takes at most one argument");
     145:             return;
     146:         }
     147:         ap = stklval(argv->list_node.list, NIL );
     148:         if (ap == NLNIL)
     149:             return;
     150:         if (ap->class != FILET) {
     151:             error("flush's argument must be a file, not %s", nameof(ap));
     152:             return;
     153:         }
     154:         (void) put(1, op);
     155:         return;
     156:
     157:     case O_MESSAGE:
     158:     case O_WRITEF:
     159:     case O_WRITLN:
     160:         /*
     161: 		 * Set up default file "output"'s type
     162: 		 */
     163:         file = NIL;
     164:         filetype = nl+T1CHAR;
     165:         /*
     166: 		 * Determine the file implied
     167: 		 * for the write and generate
     168: 		 * code to make it the active file.
     169: 		 */
     170:         if (op == O_MESSAGE) {
     171:             /*
     172: 			 * For message, all that matters
     173: 			 * is that the filetype is
     174: 			 * a character file.
     175: 			 * Thus "output" will suit us fine.
     176: 			 */
     177:             (void) put(1, O_MESSAGE);
     178:         } else if (argv != TR_NIL && (al = argv->list_node.list)->tag !=
     179:                     T_WEXP) {
     180:             /*
     181: 			 * If there is a first argument which has
     182: 			 * no write widths, then it is potentially
     183: 			 * a file name.
     184: 			 */
     185:             codeoff();
     186:             ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
     187:             codeon();
     188:             if (ap == NLNIL)
     189:                 argv = argv->list_node.next;
     190:             if (ap != NLNIL && ap->class == FILET) {
     191:                 /*
     192: 				 * Got "write(f, ...", make
     193: 				 * f the active file, and save
     194: 				 * it and its type for use in
     195: 				 * processing the rest of the
     196: 				 * arguments to write.
     197: 				 */
     198:                 file = argv->list_node.list;
     199:                 filetype = ap->type;
     200:                 (void) stklval(argv->list_node.list, NIL );
     201:                 (void) put(1, O_UNIT);
     202:                 /*
     203: 				 * Skip over the first argument
     204: 				 */
     205:                 argv = argv->list_node.next;
     206:                 argc--;
     207:             } else {
     208:                 /*
     209: 				 * Set up for writing on
     210: 				 * standard output.
     211: 				 */
     212:                 (void) put(1, O_UNITOUT);
     213:                 output->nl_flags |= NUSED;
     214:             }
     215:         } else {
     216:             (void) put(1, O_UNITOUT);
     217:             output->nl_flags |= NUSED;
     218:         }
     219:         /*
     220: 		 * Loop and process each
     221: 		 * of the arguments.
     222: 		 */
     223:         for (; argv != TR_NIL; argv = argv->list_node.next) {
     224:             /*
     225: 			 * fmtspec indicates the type (CONstant or VARiable)
     226: 			 *	and number (none, WIDTH, and/or PRECision)
     227: 			 *	of the fields in the printf format for this
     228: 			 *	output variable.
     229: 			 * stkcnt is the number of bytes pushed on the stack
     230: 			 * fmt is the format output indicator (D, E, F, O, X, S)
     231: 			 * fmtstart = 0 for leading blank; = 1 for no blank
     232: 			 */
     233:             fmtspec = NIL;
     234:             stkcnt = 0;
     235:             fmt = 'D';
     236:             fmtstart = 1;
     237:             al = argv->list_node.list;
     238:             if (al == TR_NIL)
     239:                 continue;
     240:             if (al->tag == T_WEXP)
     241:                 alv = al->wexpr_node.expr1;
     242:             else
     243:                 alv = al;
     244:             if (alv == TR_NIL)
     245:                 continue;
     246:             codeoff();
     247:             ap = stkrval(alv, NLNIL , (long) RREQ );
     248:             codeon();
     249:             if (ap == NLNIL)
     250:                 continue;
     251:             typ = classify(ap);
     252:             if (al->tag == T_WEXP) {
     253:                 /*
     254: 				 * Handle width expressions.
     255: 				 * The basic game here is that width
     256: 				 * expressions get evaluated. If they
     257: 				 * are constant, the value is placed
     258: 				 * directly in the format string.
     259: 				 * Otherwise the value is pushed onto
     260: 				 * the stack and an indirection is
     261: 				 * put into the format string.
     262: 				 */
     263:                 if (al->wexpr_node.expr3 ==
     264:                         (struct tnode *) OCT)
     265:                     fmt = 'O';
     266:                 else if (al->wexpr_node.expr3 ==
     267:                         (struct tnode *) HEX)
     268:                     fmt = 'X';
     269:                 else if (al->wexpr_node.expr3 != TR_NIL) {
     270:                     /*
     271: 					 * Evaluate second format spec
     272: 					 */
     273:                     if ( constval(al->wexpr_node.expr3)
     274:                         && isa( con.ctype , "i" ) ) {
     275:                         fmtspec += CONPREC;
     276:                         prec = con.crval;
     277:                     } else {
     278:                         fmtspec += VARPREC;
     279:                     }
     280:                     fmt = 'f';
     281:                     switch ( typ ) {
     282:                     case TINT:
     283:                         if ( opt( 's' ) ) {
     284:                             standard();
     285:                             error("Writing %ss with two write widths is non-standard", clnames[typ]);
     286:                         }
     287:                         /* and fall through */
     288:                     case TDOUBLE:
     289:                         break;
     290:                     default:
     291:                         error("Cannot write %ss with two write widths", clnames[typ]);
     292:                         continue;
     293:                     }
     294:                 }
     295:                 /*
     296: 				 * Evaluate first format spec
     297: 				 */
     298:                 if (al->wexpr_node.expr2 != TR_NIL) {
     299:                     if ( constval(al->wexpr_node.expr2)
     300:                         && isa( con.ctype , "i" ) ) {
     301:                         fmtspec += CONWIDTH;
     302:                         field = con.crval;
     303:                     } else {
     304:                         fmtspec += VARWIDTH;
     305:                     }
     306:                 }
     307:                 if ((fmtspec & CONPREC) && prec < 0 ||
     308:                     (fmtspec & CONWIDTH) && field < 0) {
     309:                     error("Negative widths are not allowed");
     310:                     continue;
     311:                 }
     312:                 if ( opt('s') &&
     313:                     ((fmtspec & CONPREC) && prec == 0 ||
     314:                     (fmtspec & CONWIDTH) && field == 0)) {
     315:                     standard();
     316:                     error("Zero widths are non-standard");
     317:                 }
     318:             }
     319:             if (filetype != nl+T1CHAR) {
     320:                 if (fmt == 'O' || fmt == 'X') {
     321:                     error("Oct/hex allowed only on text files");
     322:                     continue;
     323:                 }
     324:                 if (fmtspec) {
     325:                     error("Write widths allowed only on text files");
     326:                     continue;
     327:                 }
     328:                 /*
     329: 				 * Generalized write, i.e.
     330: 				 * to a non-textfile.
     331: 				 */
     332:                 (void) stklval(file, NIL );
     333:                 (void) put(1, O_FNIL);
     334:                 /*
     335: 				 * file^ := ...
     336: 				 */
     337:                 ap = rvalue(argv->list_node.list, NLNIL, LREQ);
     338:                 if (ap == NLNIL)
     339:                     continue;
     340:                 if (incompat(ap, filetype,
     341:                         argv->list_node.list)) {
     342:                     cerror("Type mismatch in write to non-text file");
     343:                     continue;
     344:                 }
     345:                 convert(ap, filetype);
     346:                 (void) put(2, O_AS, width(filetype));
     347:                 /*
     348: 				 * put(file)
     349: 				 */
     350:                 (void) put(1, O_PUT);
     351:                 continue;
     352:             }
     353:             /*
     354: 			 * Write to a textfile
     355: 			 *
     356: 			 * Evaluate the expression
     357: 			 * to be written.
     358: 			 */
     359:             if (fmt == 'O' || fmt == 'X') {
     360:                 if (opt('s')) {
     361:                     standard();
     362:                     error("Oct and hex are non-standard");
     363:                 }
     364:                 if (typ == TSTR || typ == TDOUBLE) {
     365:                     error("Can't write %ss with oct/hex", clnames[typ]);
     366:                     continue;
     367:                 }
     368:                 if (typ == TCHAR || typ == TBOOL)
     369:                     typ = TINT;
     370:             }
     371:             /*
     372: 			 * Place the arguement on the stack. If there is
     373: 			 * no format specified by the programmer, implement
     374: 			 * the default.
     375: 			 */
     376:             switch (typ) {
     377:             case TPTR:
     378:                 warning();
     379:                 if (opt('s')) {
     380:                     standard();
     381:                 }
     382:                 error("Writing %ss to text files is non-standard",
     383:                     clnames[typ]);
     384:                 /* and fall through */
     385:             case TINT:
     386:                 if (fmt != 'f') {
     387:                     ap = stkrval(alv, NLNIL, (long) RREQ );
     388:                     stkcnt += sizeof(long);
     389:                 } else {
     390:                     ap = stkrval(alv, NLNIL, (long) RREQ );
     391:                     (void) put(1, O_ITOD);
     392:                     stkcnt += sizeof(double);
     393:                     typ = TDOUBLE;
     394:                     goto tdouble;
     395:                 }
     396:                 if (fmtspec == NIL) {
     397:                     if (fmt == 'D')
     398:                         field = 10;
     399:                     else if (fmt == 'X')
     400:                         field = 8;
     401:                     else if (fmt == 'O')
     402:                         field = 11;
     403:                     else
     404:                         panic("fmt1");
     405:                     fmtspec = CONWIDTH;
     406:                 }
     407:                 break;
     408:             case TCHAR:
     409:                  tchar:
     410:                 if (fmtspec == NIL) {
     411:                     (void) put(1, O_FILE);
     412:                     ap = stkrval(alv, NLNIL, (long) RREQ );
     413:                     convert(nl + T4INT, INT_TYP);
     414:                     (void) put(2, O_WRITEC,
     415:                         sizeof(char *) + sizeof(int));
     416:                     fmtspec = SKIP;
     417:                     break;
     418:                 }
     419:                 ap = stkrval(alv, NLNIL , (long) RREQ );
     420:                 convert(nl + T4INT, INT_TYP);
     421:                 stkcnt += sizeof(int);
     422:                 fmt = 'c';
     423:                 break;
     424:             case TSCAL:
     425:                 warning();
     426:                 if (opt('s')) {
     427:                     standard();
     428:                 }
     429:                 error("Writing %ss to text files is non-standard",
     430:                     clnames[typ]);
     431:                 /* and fall through */
     432:             case TBOOL:
     433:                 (void) stkrval(alv, NLNIL , (long) RREQ );
     434:                 (void) put(2, O_NAM, (long)listnames(ap));
     435:                 stkcnt += sizeof(char *);
     436:                 fmt = 's';
     437:                 break;
     438:             case TDOUBLE:
     439:                 ap = stkrval(alv, (struct nl *) TDOUBLE , (long) RREQ );
     440:                 stkcnt += sizeof(double);
     441:                  tdouble:
     442:                 switch (fmtspec) {
     443:                 case NIL:
     444:                     field = 14 + (5 + EXPOSIZE);
     445:                         prec = field - (5 + EXPOSIZE);
     446:                     fmt = 'e';
     447:                     fmtspec = CONWIDTH + CONPREC;
     448:                     break;
     449:                 case CONWIDTH:
     450:                     field -= REALSPC;
     451:                     if (field < 1)
     452:                         field = 1;
     453:                         prec = field - (5 + EXPOSIZE);
     454:                     if (prec < 1)
     455:                         prec = 1;
     456:                     fmtspec += CONPREC;
     457:                     fmt = 'e';
     458:                     break;
     459:                 case CONWIDTH + CONPREC:
     460:                 case CONWIDTH + VARPREC:
     461:                     field -= REALSPC;
     462:                     if (field < 1)
     463:                         field = 1;
     464:                 }
     465:                 format[0] = ' ';
     466:                 fmtstart = 1 - REALSPC;
     467:                 break;
     468:             case TSTR:
     469:                 (void) constval( alv );
     470:                 switch ( classify( con.ctype ) ) {
     471:                     case TCHAR:
     472:                     typ = TCHAR;
     473:                     goto tchar;
     474:                     case TSTR:
     475:                     strptr = con.cpval;
     476:                     for (strnglen = 0;  *strptr++;  strnglen++) /* void */;
     477:                     strptr = con.cpval;
     478:                     break;
     479:                     default:
     480:                     strnglen = width(ap);
     481:                     break;
     482:                 }
     483:                 fmt = 's';
     484:                 strfmt = fmtspec;
     485:                 if (fmtspec == NIL) {
     486:                     fmtspec = SKIP;
     487:                     break;
     488:                 }
     489:                 if (fmtspec & CONWIDTH) {
     490:                     if (field <= strnglen) {
     491:                         fmtspec = SKIP;
     492:                         break;
     493:                     } else
     494:                         field -= strnglen;
     495:                 }
     496:                 /*
     497: 				 * push string to implement leading blank padding
     498: 				 */
     499:                 (void) put(2, O_LVCON, 2);
     500:                 putstr("", 0);
     501:                 stkcnt += sizeof(char *);
     502:                 break;
     503:             default:
     504:                 error("Can't write %ss to a text file", clnames[typ]);
     505:                 continue;
     506:             }
     507:             /*
     508: 			 * If there is a variable precision, evaluate it onto
     509: 			 * the stack
     510: 			 */
     511:             if (fmtspec & VARPREC) {
     512:                 ap = stkrval(al->wexpr_node.expr3, NLNIL ,
     513:                         (long) RREQ );
     514:                 if (ap == NIL)
     515:                     continue;
     516:                 if (isnta(ap,"i")) {
     517:                     error("Second write width must be integer, not %s", nameof(ap));
     518:                     continue;
     519:                 }
     520:                 if ( opt( 't' ) ) {
     521:                     (void) put(3, O_MAX, 0, 0);
     522:                 }
     523:                 convert(nl+T4INT, INT_TYP);
     524:                 stkcnt += sizeof(int);
     525:             }
     526:             /*
     527: 			 * If there is a variable width, evaluate it onto
     528: 			 * the stack
     529: 			 */
     530:             if (fmtspec & VARWIDTH) {
     531:                 if ( ( typ == TDOUBLE && fmtspec == VARWIDTH )
     532:                     || typ == TSTR ) {
     533:                     soffset = sizes[cbn].curtmps;
     534:                     tempnlp = tmpalloc((long) (sizeof(long)),
     535:                         nl+T4INT, REGOK);
     536:                     (void) put(2, O_LV | cbn << 8 + INDX,
     537:                         tempnlp -> value[ NL_OFFS ] );
     538:                 }
     539:                 ap = stkrval(al->wexpr_node.expr2, NLNIL, (long) RREQ );
     540:                 if (ap == NIL)
     541:                     continue;
     542:                 if (isnta(ap,"i")) {
     543:                     error("First write width must be integer, not %s", nameof(ap));
     544:                     continue;
     545:                 }
     546:                 /*
     547: 				 * Perform special processing on widths based
     548: 				 * on data type
     549: 				 */
     550:                 switch (typ) {
     551:                 case TDOUBLE:
     552:                     if (fmtspec == VARWIDTH) {
     553:                         fmt = 'e';
     554:                         (void) put(1, O_AS4);
     555:                         (void) put(2, O_RV4 | cbn << 8 + INDX,
     556:                             tempnlp -> value[NL_OFFS] );
     557:                             (void) put(3, O_MAX,
     558:                             5 + EXPOSIZE + REALSPC, 1);
     559:                         convert(nl+T4INT, INT_TYP);
     560:                         stkcnt += sizeof(int);
     561:                         (void) put(2, O_RV4 | cbn << 8 + INDX,
     562:                             tempnlp->value[NL_OFFS] );
     563:                         fmtspec += VARPREC;
     564:                         tmpfree(&soffset);
     565:                     }
     566:                     (void) put(3, O_MAX, REALSPC, 1);
     567:                     break;
     568:                 case TSTR:
     569:                     (void) put(1, O_AS4);
     570:                     (void) put(2, O_RV4 | cbn << 8 + INDX,
     571:                         tempnlp -> value[ NL_OFFS ] );
     572:                     (void) put(3, O_MAX, strnglen, 0);
     573:                     break;
     574:                 default:
     575:                     if ( opt( 't' ) ) {
     576:                         (void) put(3, O_MAX, 0, 0);
     577:                     }
     578:                     break;
     579:                 }
     580:                 convert(nl+T4INT, INT_TYP);
     581:                 stkcnt += sizeof(int);
     582:             }
     583:             /*
     584: 			 * Generate the format string
     585: 			 */
     586:             switch (fmtspec) {
     587:             default:
     588:                 panic("fmt2");
     589:             case SKIP:
     590:                 break;
     591:             case NIL:
     592:                 sprintf(&format[1], "%%%c", fmt);
     593:                 goto fmtgen;
     594:             case CONWIDTH:
     595:                 sprintf(&format[1], "%%%d%c", field, fmt);
     596:                 goto fmtgen;
     597:             case VARWIDTH:
     598:                 sprintf(&format[1], "%%*%c", fmt);
     599:                 goto fmtgen;
     600:             case CONWIDTH + CONPREC:
     601:                 sprintf(&format[1], "%%%d.%d%c", field, prec, fmt);
     602:                 goto fmtgen;
     603:             case CONWIDTH + VARPREC:
     604:                 sprintf(&format[1], "%%%d.*%c", field, fmt);
     605:                 goto fmtgen;
     606:             case VARWIDTH + CONPREC:
     607:                 sprintf(&format[1], "%%*.%d%c", prec, fmt);
     608:                 goto fmtgen;
     609:             case VARWIDTH + VARPREC:
     610:                 sprintf(&format[1], "%%*.*%c", fmt);
     611:             fmtgen:
     612:                 fmtlen = lenstr(&format[fmtstart], 0);
     613:                 (void) put(2, O_LVCON, fmtlen);
     614:                 putstr(&format[fmtstart], 0);
     615:                 (void) put(1, O_FILE);
     616:                 stkcnt += 2 * sizeof(char *);
     617:                 (void) put(2, O_WRITEF, stkcnt);
     618:             }
     619:             /*
     620: 			 * Write the string after its blank padding
     621: 			 */
     622:             if (typ == TSTR) {
     623:                 (void) put(1, O_FILE);
     624:                 (void) put(2, CON_INT, 1);
     625:                 if (strfmt & VARWIDTH) {
     626:                     (void) put(2, O_RV4 | cbn << 8 + INDX ,
     627:                         tempnlp -> value[ NL_OFFS ] );
     628:                     (void) put(2, O_MIN, strnglen);
     629:                     convert(nl+T4INT, INT_TYP);
     630:                     tmpfree(&soffset);
     631:                 } else {
     632:                     if ((fmtspec & SKIP) &&
     633:                        (strfmt & CONWIDTH)) {
     634:                         strnglen = field;
     635:                     }
     636:                     (void) put(2, CON_INT, strnglen);
     637:                 }
     638:                 ap = stkrval(alv, NLNIL , (long) RREQ );
     639:                 (void) put(2, O_WRITES,
     640:                     2 * sizeof(char *) + 2 * sizeof(int));
     641:             }
     642:         }
     643:         /*
     644: 		 * Done with arguments.
     645: 		 * Handle writeln and
     646: 		 * insufficent number of args.
     647: 		 */
     648:         switch (p->value[0] &~ NSTAND) {
     649:             case O_WRITEF:
     650:                 if (argc == 0)
     651:                     error("Write requires an argument");
     652:                 break;
     653:             case O_MESSAGE:
     654:                 if (argc == 0)
     655:                     error("Message requires an argument");
     656:             case O_WRITLN:
     657:                 if (filetype != nl+T1CHAR)
     658:                     error("Can't 'writeln' a non text file");
     659:                 (void) put(1, O_WRITLN);
     660:                 break;
     661:         }
     662:         return;
     663:
     664:     case O_READ4:
     665:     case O_READLN:
     666:         /*
     667: 		 * Set up default
     668: 		 * file "input".
     669: 		 */
     670:         file = NIL;
     671:         filetype = nl+T1CHAR;
     672:         /*
     673: 		 * Determine the file implied
     674: 		 * for the read and generate
     675: 		 * code to make it the active file.
     676: 		 */
     677:         if (argv != TR_NIL) {
     678:             codeoff();
     679:             ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
     680:             codeon();
     681:             if (ap == NLNIL)
     682:                 argv = argv->list_node.next;
     683:             if (ap != NLNIL && ap->class == FILET) {
     684:                 /*
     685: 				 * Got "read(f, ...", make
     686: 				 * f the active file, and save
     687: 				 * it and its type for use in
     688: 				 * processing the rest of the
     689: 				 * arguments to read.
     690: 				 */
     691:                 file = argv->list_node.list;
     692:                 filetype = ap->type;
     693:                 (void) stklval(argv->list_node.list, NIL );
     694:                 (void) put(1, O_UNIT);
     695:                 argv = argv->list_node.next;
     696:                 argc--;
     697:             } else {
     698:                 /*
     699: 				 * Default is read from
     700: 				 * standard input.
     701: 				 */
     702:                 (void) put(1, O_UNITINP);
     703:                 input->nl_flags |= NUSED;
     704:             }
     705:         } else {
     706:             (void) put(1, O_UNITINP);
     707:             input->nl_flags |= NUSED;
     708:         }
     709:         /*
     710: 		 * Loop and process each
     711: 		 * of the arguments.
     712: 		 */
     713:         for (; argv != TR_NIL; argv = argv->list_node.next) {
     714:             /*
     715: 			 * Get the address of the target
     716: 			 * on the stack.
     717: 			 */
     718:             al = argv->list_node.list;
     719:             if (al == TR_NIL)
     720:                 continue;
     721:             if (al->tag != T_VAR) {
     722:                 error("Arguments to %s must be variables, not expressions", p->symbol);
     723:                 continue;
     724:             }
     725:             ap = stklval(al, MOD|ASGN|NOUSE);
     726:             if (ap == NLNIL)
     727:                 continue;
     728:             if (filetype != nl+T1CHAR) {
     729:                 /*
     730: 				 * Generalized read, i.e.
     731: 				 * from a non-textfile.
     732: 				 */
     733:                 if (incompat(filetype, ap,
     734:                     argv->list_node.list )) {
     735:                     error("Type mismatch in read from non-text file");
     736:                     continue;
     737:                 }
     738:                 /*
     739: 				 * var := file ^;
     740: 				 */
     741:                 if (file != NIL)
     742:                     (void) stklval(file, NIL);
     743:                 else /* Magic */
     744:                     (void) put(2, PTR_RV, (int)input->value[0]);
     745:                 (void) put(1, O_FNIL);
     746:                 if (isa(filetype, "bcsi")) {
     747:                     int filewidth = width(filetype);
     748:
     749:                     switch (filewidth) {
     750:                     case 4:
     751:                         (void) put(1, O_IND4);
     752:                         break;
     753:                     case 2:
     754:                         (void) put(1, O_IND2);
     755:                         break;
     756:                     case 1:
     757:                         (void) put(1, O_IND1);
     758:                         break;
     759:                     default:
     760:                         (void) put(2, O_IND, filewidth);
     761:                     }
     762:                     convert(filetype, ap);
     763:                     rangechk(ap, ap);
     764:                     (void) gen(O_AS2, O_AS2,
     765:                         filewidth, width(ap));
     766:                 } else {
     767:                     (void) put(2, O_IND, width(filetype));
     768:                     convert(filetype, ap);
     769:                     (void) put(2, O_AS, width(ap));
     770:                 }
     771:                 /*
     772: 				 * get(file);
     773: 				 */
     774:                 (void) put(1, O_GET);
     775:                 continue;
     776:             }
     777:             typ = classify(ap);
     778:             op = rdops(typ);
     779:             if (op == NIL) {
     780:                 error("Can't read %ss from a text file", clnames[typ]);
     781:                 continue;
     782:             }
     783:             if (op != O_READE)
     784:                 (void) put(1, op);
     785:             else {
     786:                 (void) put(2, op, (long)listnames(ap));
     787:                 warning();
     788:                 if (opt('s')) {
     789:                     standard();
     790:                 }
     791:                 error("Reading scalars from text files is non-standard");
     792:             }
     793:             /*
     794: 			 * Data read is on the stack.
     795: 			 * Assign it.
     796: 			 */
     797:             if (op != O_READ8 && op != O_READE)
     798:                 rangechk(ap, op == O_READC ? ap : nl+T4INT);
     799:             (void) gen(O_AS2, O_AS2, width(ap),
     800:                 op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2);
     801:         }
     802:         /*
     803: 		 * Done with arguments.
     804: 		 * Handle readln and
     805: 		 * insufficient number of args.
     806: 		 */
     807:         if (p->value[0] == O_READLN) {
     808:             if (filetype != nl+T1CHAR)
     809:                 error("Can't 'readln' a non text file");
     810:             (void) put(1, O_READLN);
     811:         }
     812:         else if (argc == 0)
     813:             error("read requires an argument");
     814:         return;
     815:
     816:     case O_GET:
     817:     case O_PUT:
     818:         if (argc != 1) {
     819:             error("%s expects one argument", p->symbol);
     820:             return;
     821:         }
     822:         ap = stklval(argv->list_node.list, NIL );
     823:         if (ap == NLNIL)
     824:             return;
     825:         if (ap->class != FILET) {
     826:             error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
     827:             return;
     828:         }
     829:         (void) put(1, O_UNIT);
     830:         (void) put(1, op);
     831:         return;
     832:
     833:     case O_RESET:
     834:     case O_REWRITE:
     835:         if (argc == 0 || argc > 2) {
     836:             error("%s expects one or two arguments", p->symbol);
     837:             return;
     838:         }
     839:         if (opt('s') && argc == 2) {
     840:             standard();
     841:             error("Two argument forms of reset and rewrite are non-standard");
     842:         }
     843:         codeoff();
     844:         ap = stklval(argv->list_node.list, MOD|NOUSE);
     845:         codeon();
     846:         if (ap == NLNIL)
     847:             return;
     848:         if (ap->class != FILET) {
     849:             error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
     850:             return;
     851:         }
     852:         (void) put(2, O_CON24, text(ap) ? 0: width(ap->type));
     853:         if (argc == 2) {
     854:             /*
     855: 			 * Optional second argument
     856: 			 * is a string name of a
     857: 			 * UNIX (R) file to be associated.
     858: 			 */
     859:             al = argv->list_node.next;
     860:             codeoff();
     861:             al = (struct tnode *) stkrval(al->list_node.list,
     862:                     (struct nl *) NOFLAGS , (long) RREQ );
     863:             codeon();
     864:             if (al == TR_NIL)
     865:                 return;
     866:             if (classify((struct nl *) al) != TSTR) {
     867:                 error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al));
     868:                 return;
     869:             }
     870:             (void) put(2, O_CON24, width((struct nl *) al));
     871:             al = argv->list_node.next;
     872:             al = (struct tnode *) stkrval(al->list_node.list,
     873:                     (struct nl *) NOFLAGS , (long) RREQ );
     874:         } else {
     875:             (void) put(2, O_CON24, 0);
     876:             (void) put(2, PTR_CON, NIL);
     877:         }
     878:         ap = stklval(argv->list_node.list, MOD|NOUSE);
     879:         (void) put(1, op);
     880:         return;
     881:
     882:     case O_NEW:
     883:     case O_DISPOSE:
     884:         if (argc == 0) {
     885:             error("%s expects at least one argument", p->symbol);
     886:             return;
     887:         }
     888:         ap = stklval(argv->list_node.list,
     889:                 op == O_NEW ? ( MOD | NOUSE ) : MOD );
     890:         if (ap == NLNIL)
     891:             return;
     892:         if (ap->class != PTR) {
     893:             error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
     894:             return;
     895:         }
     896:         ap = ap->type;
     897:         if (ap == NIL)
     898:             return;
     899:         if ((ap->nl_flags & NFILES) && op == O_DISPOSE)
     900:             op = O_DFDISP;
     901:         argv = argv->list_node.next;
     902:         if (argv != TR_NIL) {
     903:             if (ap->class != RECORD) {
     904:                 error("Record required when specifying variant tags");
     905:                 return;
     906:             }
     907:             for (; argv != TR_NIL; argv = argv->list_node.next) {
     908:                 if (ap->ptr[NL_VARNT] == NIL) {
     909:                     error("Too many tag fields");
     910:                     return;
     911:                 }
     912:                 if (!isconst(argv->list_node.list)) {
     913:                     error("Second and successive arguments to %s must be constants", p->symbol);
     914:                     return;
     915:                 }
     916:                 gconst(argv->list_node.list);
     917:                 if (con.ctype == NIL)
     918:                     return;
     919:                 if (incompat(con.ctype, (
     920:                     ap->ptr[NL_TAG])->type , TR_NIL )) {
     921:                     cerror("Specified tag constant type clashed with variant case selector type");
     922:                     return;
     923:                 }
     924:                 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
     925:                     if (ap->range[0] == con.crval)
     926:                         break;
     927:                 if (ap == NIL) {
     928:                     error("No variant case label value equals specified constant value");
     929:                     return;
     930:                 }
     931:                 ap = ap->ptr[NL_VTOREC];
     932:             }
     933:         }
     934:         (void) put(2, op, width(ap));
     935:         return;
     936:
     937:     case O_DATE:
     938:     case O_TIME:
     939:         if (argc != 1) {
     940:             error("%s expects one argument", p->symbol);
     941:             return;
     942:         }
     943:         ap = stklval(argv->list_node.list, MOD|NOUSE);
     944:         if (ap == NLNIL)
     945:             return;
     946:         if (classify(ap) != TSTR || width(ap) != 10) {
     947:             error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
     948:             return;
     949:         }
     950:         (void) put(1, op);
     951:         return;
     952:
     953:     case O_HALT:
     954:         if (argc != 0) {
     955:             error("halt takes no arguments");
     956:             return;
     957:         }
     958:         (void) put(1, op);
     959:         noreach = TRUE; /* used to be 1 */
     960:         return;
     961:
     962:     case O_ARGV:
     963:         if (argc != 2) {
     964:             error("argv takes two arguments");
     965:             return;
     966:         }
     967:         ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
     968:         if (ap == NLNIL)
     969:             return;
     970:         if (isnta(ap, "i")) {
     971:             error("argv's first argument must be an integer, not %s", nameof(ap));
     972:             return;
     973:         }
     974:         al = argv->list_node.next;
     975:         ap = stklval(al->list_node.list, MOD|NOUSE);
     976:         if (ap == NLNIL)
     977:             return;
     978:         if (classify(ap) != TSTR) {
     979:             error("argv's second argument must be a string, not %s", nameof(ap));
     980:             return;
     981:         }
     982:         (void) put(2, op, width(ap));
     983:         return;
     984:
     985:     case O_STLIM:
     986:         if (argc != 1) {
     987:             error("stlimit requires one argument");
     988:             return;
     989:         }
     990:         ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
     991:         if (ap == NLNIL)
     992:             return;
     993:         if (isnta(ap, "i")) {
     994:             error("stlimit's argument must be an integer, not %s", nameof(ap));
     995:             return;
     996:         }
     997:         if (width(ap) != 4)
     998:             (void) put(1, O_STOI);
     999:         (void) put(1, op);
    1000:         return;
    1001:
    1002:     case O_REMOVE:
    1003:         if (argc != 1) {
    1004:             error("remove expects one argument");
    1005:             return;
    1006:         }
    1007:         codeoff();
    1008:         ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS,
    1009:                 (long) RREQ );
    1010:         codeon();
    1011:         if (ap == NLNIL)
    1012:             return;
    1013:         if (classify(ap) != TSTR) {
    1014:             error("remove's argument must be a string, not %s", nameof(ap));
    1015:             return;
    1016:         }
    1017:         (void) put(2, O_CON24, width(ap));
    1018:         ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS,
    1019:                 (long) RREQ );
    1020:         (void) put(1, op);
    1021:         return;
    1022:
    1023:     case O_LLIMIT:
    1024:         if (argc != 2) {
    1025:             error("linelimit expects two arguments");
    1026:             return;
    1027:         }
    1028:         al = argv->list_node.next;
    1029:         ap = stkrval(al->list_node.list, NLNIL , (long) RREQ );
    1030:         if (ap == NIL)
    1031:             return;
    1032:         if (isnta(ap, "i")) {
    1033:             error("linelimit's second argument must be an integer, not %s", nameof(ap));
    1034:             return;
    1035:         }
    1036:         ap = stklval(argv->list_node.list, NOFLAGS|NOUSE);
    1037:         if (ap == NLNIL)
    1038:             return;
    1039:         if (!text(ap)) {
    1040:             error("linelimit's first argument must be a text file, not %s", nameof(ap));
    1041:             return;
    1042:         }
    1043:         (void) put(1, op);
    1044:         return;
    1045:     case O_PAGE:
    1046:         if (argc != 1) {
    1047:             error("page expects one argument");
    1048:             return;
    1049:         }
    1050:         ap = stklval(argv->list_node.list, NIL );
    1051:         if (ap == NLNIL)
    1052:             return;
    1053:         if (!text(ap)) {
    1054:             error("Argument to page must be a text file, not %s", nameof(ap));
    1055:             return;
    1056:         }
    1057:         (void) put(1, O_UNIT);
    1058:         (void) put(1, op);
    1059:         return;
    1060:
    1061:     case O_ASRT:
    1062:         if (!opt('t'))
    1063:             return;
    1064:         if (argc == 0 || argc > 2) {
    1065:             error("Assert expects one or two arguments");
    1066:             return;
    1067:         }
    1068:         if (argc == 2) {
    1069:             /*
    1070: 			 * Optional second argument is a string specifying
    1071: 			 * why the assertion failed.
    1072: 			 */
    1073:             al = argv->list_node.next;
    1074:             al1 =  stkrval(al->list_node.list, NLNIL , (long) RREQ );
    1075:             if (al1 == NIL)
    1076:                 return;
    1077:             if (classify(al1) != TSTR) {
    1078:                 error("Second argument to assert must be a string, not %s", nameof(al1));
    1079:                 return;
    1080:             }
    1081:         } else {
    1082:             (void) put(2, PTR_CON, NIL);
    1083:         }
    1084:         ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
    1085:         if (ap == NIL)
    1086:             return;
    1087:         if (isnta(ap, "b"))
    1088:             error("Assert expression must be Boolean, not %ss", nameof(ap));
    1089:         (void) put(1, O_ASRT);
    1090:         return;
    1091:
    1092:     case O_PACK:
    1093:         if (argc != 3) {
    1094:             error("pack expects three arguments");
    1095:             return;
    1096:         }
    1097:         pu = "pack(a,i,z)";
    1098:         pua = argv->list_node.list;
    1099:         al = argv->list_node.next;
    1100:         pui = al->list_node.list;
    1101:         alv = al->list_node.next;
    1102:         puz = alv->list_node.list;
    1103:         goto packunp;
    1104:     case O_UNPACK:
    1105:         if (argc != 3) {
    1106:             error("unpack expects three arguments");
    1107:             return;
    1108:         }
    1109:         pu = "unpack(z,a,i)";
    1110:         puz = argv->list_node.list;
    1111:         al = argv->list_node.next;
    1112:         pua = al->list_node.list;
    1113:         alv = al->list_node.next;
    1114:         pui = alv->list_node.list;
    1115: packunp:
    1116:         codeoff();
    1117:         ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
    1118:         al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
    1119:         codeon();
    1120:         if (ap == NIL)
    1121:             return;
    1122:         if (ap->class != ARRAY) {
    1123:             error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
    1124:             return;
    1125:         }
    1126:         if (al1->class != ARRAY) {
    1127:             error("%s requires z to be a packed array, not %s", pu, nameof(ap));
    1128:             return;
    1129:         }
    1130:         if (al1->type == NIL || ap->type == NIL)
    1131:             return;
    1132:         if (al1->type != ap->type) {
    1133:             error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
    1134:             return;
    1135:         }
    1136:         k = width(al1);
    1137:         itemwidth = width(ap->type);
    1138:         ap = ap->chain;
    1139:         al1 = al1->chain;
    1140:         if (ap->chain != NIL || al1->chain != NIL) {
    1141:             error("%s requires a and z to be single dimension arrays", pu);
    1142:             return;
    1143:         }
    1144:         if (ap == NIL || al1 == NIL)
    1145:             return;
    1146:         /*
    1147: 		 * al1 is the range for z i.e. u..v
    1148: 		 * ap is the range for a i.e. m..n
    1149: 		 * i will be n-m+1
    1150: 		 * j will be v-u+1
    1151: 		 */
    1152:         i = ap->range[1] - ap->range[0] + 1;
    1153:         j = al1->range[1] - al1->range[0] + 1;
    1154:         if (i < j) {
    1155:             error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i);
    1156:             return;
    1157:         }
    1158:         /*
    1159: 		 * get n-m-(v-u) and m for the interpreter
    1160: 		 */
    1161:         i -= j;
    1162:         j = ap->range[0];
    1163:         (void) put(2, O_CON24, k);
    1164:         (void) put(2, O_CON24, i);
    1165:         (void) put(2, O_CON24, j);
    1166:         (void) put(2, O_CON24, itemwidth);
    1167:         al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
    1168:         ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
    1169:         ap = stkrval(pui, NLNIL , (long) RREQ );
    1170:         if (ap == NIL)
    1171:             return;
    1172:         (void) put(1, op);
    1173:         return;
    1174:     case 0:
    1175:         error("%s is an unimplemented extension", p->symbol);
    1176:         return;
    1177:
    1178:     default:
    1179:         panic("proc case");
    1180:     }
    1181: }
    1182: #endif OBJ

#### Defined functions

proc defined in line 64; used 1 times

- in /usr/src/ucb/PORT/pascal/src/stat.c line 75

#### Defined variables

rdxxxx defined in line 43; used 1 times

- in line 41

sccsid defined in line 8; never used

#### Defined macros

CONPREC defined in line 81; used 5 times

- in line 275, 307, 313, 447, 456

CONWIDTH defined in line 83; used 11 times

- in line 301, 308, 314, 405, 447, 459-460(2), 489, 600-603(2), 633

EXPOSIZE defined in line 34; used 4 times

- in line 444-445(2), 453, 558

REALSPC defined in line 35; used 5 times

- in line 450, 461-466(2), 558, 566

SKIP defined in line 85; used 4 times

- in line 416, 486-491(2), 632

VARPREC defined in line 82; used 3 times

- in line 278, 511, 563

VARWIDTH defined in line 84; used 7 times

- in line 304, 530-531(2), 552, 606-609(2), 625

rdops defined in line 41; used 1 times

- in line 778

Last modified: 1985-06-05 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 2643 |