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

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
CONWIDTH defined in line 83; used 11 times
EXPOSIZE defined in line 34; used 4 times
REALSPC defined in line 35; used 5 times
SKIP defined in line 85; used 4 times
VARPREC defined in line 82; used 3 times
VARWIDTH defined in line 84; used 7 times
rdops defined in line 41; used 1 times
Last modified: 1985-06-05
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 5104
Valid CSS Valid XHTML 1.0 Strict