1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)proc.c 2.2 04/26/84"; 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 if (isa(filetype, "bcsi")) { 743 int filewidth = width(filetype); 744 745 switch (filewidth) { 746 case 4: 747 (void) put(1, O_IND4); 748 break; 749 case 2: 750 (void) put(1, O_IND2); 751 break; 752 case 1: 753 (void) put(1, O_IND1); 754 break; 755 default: 756 (void) put(2, O_IND, filewidth); 757 } 758 convert(filetype, ap); 759 rangechk(ap, ap); 760 (void) gen(O_AS2, O_AS2, 761 filewidth, width(ap)); 762 } else { 763 (void) put(2, O_IND, width(filetype)); 764 convert(filetype, ap); 765 (void) put(2, O_AS, width(ap)); 766 } 767 /* 768 * get(file); 769 */ 770 (void) put(1, O_GET); 771 continue; 772 } 773 typ = classify(ap); 774 op = rdops(typ); 775 if (op == NIL) { 776 error("Can't read %ss from a text file", clnames[typ]); 777 continue; 778 } 779 if (op != O_READE) 780 (void) put(1, op); 781 else { 782 (void) put(2, op, (long)listnames(ap)); 783 warning(); 784 if (opt('s')) { 785 standard(); 786 } 787 error("Reading scalars from text files is non-standard"); 788 } 789 /* 790 * Data read is on the stack. 791 * Assign it. 792 */ 793 if (op != O_READ8 && op != O_READE) 794 rangechk(ap, op == O_READC ? ap : nl+T4INT); 795 (void) gen(O_AS2, O_AS2, width(ap), 796 op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2); 797 } 798 /* 799 * Done with arguments. 800 * Handle readln and 801 * insufficient number of args. 802 */ 803 if (p->value[0] == O_READLN) { 804 if (filetype != nl+T1CHAR) 805 error("Can't 'readln' a non text file"); 806 (void) put(1, O_READLN); 807 } 808 else if (argc == 0) 809 error("read requires an argument"); 810 return; 811 812 case O_GET: 813 case O_PUT: 814 if (argc != 1) { 815 error("%s expects one argument", p->symbol); 816 return; 817 } 818 ap = stklval(argv->list_node.list, NIL ); 819 if (ap == NLNIL) 820 return; 821 if (ap->class != FILET) { 822 error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 823 return; 824 } 825 (void) put(1, O_UNIT); 826 (void) put(1, op); 827 return; 828 829 case O_RESET: 830 case O_REWRITE: 831 if (argc == 0 || argc > 2) { 832 error("%s expects one or two arguments", p->symbol); 833 return; 834 } 835 if (opt('s') && argc == 2) { 836 standard(); 837 error("Two argument forms of reset and rewrite are non-standard"); 838 } 839 codeoff(); 840 ap = stklval(argv->list_node.list, MOD|NOUSE); 841 codeon(); 842 if (ap == NLNIL) 843 return; 844 if (ap->class != FILET) { 845 error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 846 return; 847 } 848 (void) put(2, O_CON24, text(ap) ? 0: width(ap->type)); 849 if (argc == 2) { 850 /* 851 * Optional second argument 852 * is a string name of a 853 * UNIX (R) file to be associated. 854 */ 855 al = argv->list_node.next; 856 codeoff(); 857 al = (struct tnode *) stkrval(al->list_node.list, 858 (struct nl *) NOFLAGS , (long) RREQ ); 859 codeon(); 860 if (al == TR_NIL) 861 return; 862 if (classify((struct nl *) al) != TSTR) { 863 error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al)); 864 return; 865 } 866 (void) put(2, O_CON24, width((struct nl *) al)); 867 al = argv->list_node.next; 868 al = (struct tnode *) stkrval(al->list_node.list, 869 (struct nl *) NOFLAGS , (long) RREQ ); 870 } else { 871 (void) put(2, O_CON24, 0); 872 (void) put(2, PTR_CON, NIL); 873 } 874 ap = stklval(argv->list_node.list, MOD|NOUSE); 875 (void) put(1, op); 876 return; 877 878 case O_NEW: 879 case O_DISPOSE: 880 if (argc == 0) { 881 error("%s expects at least one argument", p->symbol); 882 return; 883 } 884 ap = stklval(argv->list_node.list, 885 op == O_NEW ? ( MOD | NOUSE ) : MOD ); 886 if (ap == NLNIL) 887 return; 888 if (ap->class != PTR) { 889 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 890 return; 891 } 892 ap = ap->type; 893 if (ap == NIL) 894 return; 895 if ((ap->nl_flags & NFILES) && op == O_DISPOSE) 896 op = O_DFDISP; 897 argv = argv->list_node.next; 898 if (argv != TR_NIL) { 899 if (ap->class != RECORD) { 900 error("Record required when specifying variant tags"); 901 return; 902 } 903 for (; argv != TR_NIL; argv = argv->list_node.next) { 904 if (ap->ptr[NL_VARNT] == NIL) { 905 error("Too many tag fields"); 906 return; 907 } 908 if (!isconst(argv->list_node.list)) { 909 error("Second and successive arguments to %s must be constants", p->symbol); 910 return; 911 } 912 gconst(argv->list_node.list); 913 if (con.ctype == NIL) 914 return; 915 if (incompat(con.ctype, ( 916 ap->ptr[NL_TAG])->type , TR_NIL )) { 917 cerror("Specified tag constant type clashed with variant case selector type"); 918 return; 919 } 920 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 921 if (ap->range[0] == con.crval) 922 break; 923 if (ap == NIL) { 924 error("No variant case label value equals specified constant value"); 925 return; 926 } 927 ap = ap->ptr[NL_VTOREC]; 928 } 929 } 930 (void) put(2, op, width(ap)); 931 return; 932 933 case O_DATE: 934 case O_TIME: 935 if (argc != 1) { 936 error("%s expects one argument", p->symbol); 937 return; 938 } 939 ap = stklval(argv->list_node.list, MOD|NOUSE); 940 if (ap == NLNIL) 941 return; 942 if (classify(ap) != TSTR || width(ap) != 10) { 943 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 944 return; 945 } 946 (void) put(1, op); 947 return; 948 949 case O_HALT: 950 if (argc != 0) { 951 error("halt takes no arguments"); 952 return; 953 } 954 (void) put(1, op); 955 noreach = TRUE; /* used to be 1 */ 956 return; 957 958 case O_ARGV: 959 if (argc != 2) { 960 error("argv takes two arguments"); 961 return; 962 } 963 ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 964 if (ap == NLNIL) 965 return; 966 if (isnta(ap, "i")) { 967 error("argv's first argument must be an integer, not %s", nameof(ap)); 968 return; 969 } 970 al = argv->list_node.next; 971 ap = stklval(al->list_node.list, MOD|NOUSE); 972 if (ap == NLNIL) 973 return; 974 if (classify(ap) != TSTR) { 975 error("argv's second argument must be a string, not %s", nameof(ap)); 976 return; 977 } 978 (void) put(2, op, width(ap)); 979 return; 980 981 case O_STLIM: 982 if (argc != 1) { 983 error("stlimit requires one argument"); 984 return; 985 } 986 ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 987 if (ap == NLNIL) 988 return; 989 if (isnta(ap, "i")) { 990 error("stlimit's argument must be an integer, not %s", nameof(ap)); 991 return; 992 } 993 if (width(ap) != 4) 994 (void) put(1, O_STOI); 995 (void) put(1, op); 996 return; 997 998 case O_REMOVE: 999 if (argc != 1) { 1000 error("remove expects one argument"); 1001 return; 1002 } 1003 codeoff(); 1004 ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS, 1005 (long) RREQ ); 1006 codeon(); 1007 if (ap == NLNIL) 1008 return; 1009 if (classify(ap) != TSTR) { 1010 error("remove's argument must be a string, not %s", nameof(ap)); 1011 return; 1012 } 1013 (void) put(2, O_CON24, width(ap)); 1014 ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS, 1015 (long) RREQ ); 1016 (void) put(1, op); 1017 return; 1018 1019 case O_LLIMIT: 1020 if (argc != 2) { 1021 error("linelimit expects two arguments"); 1022 return; 1023 } 1024 al = argv->list_node.next; 1025 ap = stkrval(al->list_node.list, NLNIL , (long) RREQ ); 1026 if (ap == NIL) 1027 return; 1028 if (isnta(ap, "i")) { 1029 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1030 return; 1031 } 1032 ap = stklval(argv->list_node.list, NOFLAGS|NOUSE); 1033 if (ap == NLNIL) 1034 return; 1035 if (!text(ap)) { 1036 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1037 return; 1038 } 1039 (void) put(1, op); 1040 return; 1041 case O_PAGE: 1042 if (argc != 1) { 1043 error("page expects one argument"); 1044 return; 1045 } 1046 ap = stklval(argv->list_node.list, NIL ); 1047 if (ap == NLNIL) 1048 return; 1049 if (!text(ap)) { 1050 error("Argument to page must be a text file, not %s", nameof(ap)); 1051 return; 1052 } 1053 (void) put(1, O_UNIT); 1054 (void) put(1, op); 1055 return; 1056 1057 case O_ASRT: 1058 if (!opt('t')) 1059 return; 1060 if (argc == 0 || argc > 2) { 1061 error("Assert expects one or two arguments"); 1062 return; 1063 } 1064 if (argc == 2) { 1065 /* 1066 * Optional second argument is a string specifying 1067 * why the assertion failed. 1068 */ 1069 al = argv->list_node.next; 1070 al1 = stkrval(al->list_node.list, NLNIL , (long) RREQ ); 1071 if (al1 == NIL) 1072 return; 1073 if (classify(al1) != TSTR) { 1074 error("Second argument to assert must be a string, not %s", nameof(al1)); 1075 return; 1076 } 1077 } else { 1078 (void) put(2, PTR_CON, NIL); 1079 } 1080 ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 1081 if (ap == NIL) 1082 return; 1083 if (isnta(ap, "b")) 1084 error("Assert expression must be Boolean, not %ss", nameof(ap)); 1085 (void) put(1, O_ASRT); 1086 return; 1087 1088 case O_PACK: 1089 if (argc != 3) { 1090 error("pack expects three arguments"); 1091 return; 1092 } 1093 pu = "pack(a,i,z)"; 1094 pua = argv->list_node.list; 1095 al = argv->list_node.next; 1096 pui = al->list_node.list; 1097 alv = al->list_node.next; 1098 puz = alv->list_node.list; 1099 goto packunp; 1100 case O_UNPACK: 1101 if (argc != 3) { 1102 error("unpack expects three arguments"); 1103 return; 1104 } 1105 pu = "unpack(z,a,i)"; 1106 puz = argv->list_node.list; 1107 al = argv->list_node.next; 1108 pua = al->list_node.list; 1109 alv = al->list_node.next; 1110 pui = alv->list_node.list; 1111 packunp: 1112 codeoff(); 1113 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1114 al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1115 codeon(); 1116 if (ap == NIL) 1117 return; 1118 if (ap->class != ARRAY) { 1119 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1120 return; 1121 } 1122 if (al1->class != ARRAY) { 1123 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1124 return; 1125 } 1126 if (al1->type == NIL || ap->type == NIL) 1127 return; 1128 if (al1->type != ap->type) { 1129 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1130 return; 1131 } 1132 k = width(al1); 1133 itemwidth = width(ap->type); 1134 ap = ap->chain; 1135 al1 = al1->chain; 1136 if (ap->chain != NIL || al1->chain != NIL) { 1137 error("%s requires a and z to be single dimension arrays", pu); 1138 return; 1139 } 1140 if (ap == NIL || al1 == NIL) 1141 return; 1142 /* 1143 * al1 is the range for z i.e. u..v 1144 * ap is the range for a i.e. m..n 1145 * i will be n-m+1 1146 * j will be v-u+1 1147 */ 1148 i = ap->range[1] - ap->range[0] + 1; 1149 j = al1->range[1] - al1->range[0] + 1; 1150 if (i < j) { 1151 error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i); 1152 return; 1153 } 1154 /* 1155 * get n-m-(v-u) and m for the interpreter 1156 */ 1157 i -= j; 1158 j = ap->range[0]; 1159 (void) put(2, O_CON24, k); 1160 (void) put(2, O_CON24, i); 1161 (void) put(2, O_CON24, j); 1162 (void) put(2, O_CON24, itemwidth); 1163 al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1164 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1165 ap = stkrval(pui, NLNIL , (long) RREQ ); 1166 if (ap == NIL) 1167 return; 1168 (void) put(1, op); 1169 return; 1170 case 0: 1171 error("%s is an unimplemented extension", p->symbol); 1172 return; 1173 1174 default: 1175 panic("proc case"); 1176 } 1177 } 1178 #endif OBJ 1179