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