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