1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)proc.c 1.6 03/10/81"; 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 = stklval(argv[1], NIL , LREQ ); 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 stklval(argv[1], NIL , LREQ ); 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 bytes 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 stklval(file, NIL , LREQ ); 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 += sizeof(long); 341 } else { 342 ap = stkrval(alv, NIL , RREQ ); 343 put(1, O_ITOD); 344 stkcnt += sizeof(double); 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 if (fmtspec == NIL) { 363 put(1, O_FILE); 364 ap = stkrval(alv, NIL , RREQ ); 365 convert(nl + T4INT, INT_TYP); 366 put(2, O_WRITEC, 367 sizeof(char *) + sizeof(int)); 368 fmtspec = SKIP; 369 break; 370 } 371 ap = stkrval(alv, NIL , RREQ ); 372 convert(nl + T4INT, INT_TYP); 373 stkcnt += sizeof(int); 374 fmt = 'c'; 375 break; 376 case TSCAL: 377 warning(); 378 if (opt('s')) { 379 standard(); 380 } 381 error("Writing scalars to text files is non-standard"); 382 case TBOOL: 383 stkrval(alv, NIL , RREQ ); 384 put(2, O_NAM, (long)listnames(ap)); 385 stkcnt += sizeof(char *); 386 fmt = 's'; 387 break; 388 case TDOUBLE: 389 ap = stkrval(alv, TDOUBLE , RREQ ); 390 stkcnt += sizeof(double); 391 tdouble: 392 switch (fmtspec) { 393 case NIL: 394 # ifdef DEC11 395 field = 21; 396 # else 397 field = 22; 398 # endif DEC11 399 prec = 14; 400 fmt = 'e'; 401 fmtspec = CONWIDTH + CONPREC; 402 break; 403 case CONWIDTH: 404 if (--field < 1) 405 field = 1; 406 # ifdef DEC11 407 prec = field - 7; 408 # else 409 prec = field - 8; 410 # endif DEC11 411 if (prec < 1) 412 prec = 1; 413 fmtspec += CONPREC; 414 fmt = 'e'; 415 break; 416 case CONWIDTH + CONPREC: 417 case CONWIDTH + VARPREC: 418 if (--field < 1) 419 field = 1; 420 } 421 format[0] = ' '; 422 fmtstart = 0; 423 break; 424 case TSTR: 425 constval( alv ); 426 switch ( classify( con.ctype ) ) { 427 case TCHAR: 428 typ = TCHAR; 429 goto tchar; 430 case TSTR: 431 strptr = con.cpval; 432 for (strnglen = 0; *strptr++; strnglen++) /* void */; 433 strptr = con.cpval; 434 break; 435 default: 436 strnglen = width(ap); 437 break; 438 } 439 fmt = 's'; 440 strfmt = fmtspec; 441 if (fmtspec == NIL) { 442 fmtspec = SKIP; 443 break; 444 } 445 if (fmtspec & CONWIDTH) { 446 if (field <= strnglen) { 447 fmtspec = SKIP; 448 break; 449 } else 450 field -= strnglen; 451 } 452 /* 453 * push string to implement leading blank padding 454 */ 455 put(2, O_LVCON, 2); 456 putstr("", 0); 457 stkcnt += sizeof(char *); 458 break; 459 default: 460 error("Can't write %ss to a text file", clnames[typ]); 461 continue; 462 } 463 /* 464 * If there is a variable precision, evaluate it onto 465 * the stack 466 */ 467 if (fmtspec & VARPREC) { 468 ap = stkrval(al[3], NIL , RREQ ); 469 if (ap == NIL) 470 continue; 471 if (isnta(ap,"i")) { 472 error("Second write width must be integer, not %s", nameof(ap)); 473 continue; 474 } 475 if ( opt( 't' ) ) { 476 put(3, O_MAX, 0, 0); 477 } 478 convert(nl+T4INT, INT_TYP); 479 stkcnt += sizeof(int); 480 } 481 /* 482 * If there is a variable width, evaluate it onto 483 * the stack 484 */ 485 if (fmtspec & VARWIDTH) { 486 if ( ( typ == TDOUBLE && fmtspec == VARWIDTH ) 487 || typ == TSTR ) { 488 i = sizes[cbn].om_off -= sizeof(long); 489 if (i < sizes[cbn].om_max) 490 sizes[cbn].om_max = i; 491 put(2, O_LV | cbn << 8 + INDX, i); 492 } 493 ap = stkrval(al[2], NIL , RREQ ); 494 if (ap == NIL) 495 continue; 496 if (isnta(ap,"i")) { 497 error("First write width must be integer, not %s", nameof(ap)); 498 continue; 499 } 500 /* 501 * Perform special processing on widths based 502 * on data type 503 */ 504 switch (typ) { 505 case TDOUBLE: 506 if (fmtspec == VARWIDTH) { 507 fmt = 'e'; 508 put(1, O_AS4); 509 put(2, O_RV4 | cbn << 8 + INDX, i); 510 # ifdef DEC11 511 put(3, O_MAX, 8, 1); 512 # else 513 put(3, O_MAX, 9, 1); 514 # endif DEC11 515 convert(nl+T4INT, INT_TYP); 516 stkcnt += sizeof(int); 517 put(2, O_RV4 | cbn << 8 + INDX, i); 518 fmtspec += VARPREC; 519 } 520 put(3, O_MAX, 1, 1); 521 break; 522 case TSTR: 523 put(1, O_AS4); 524 put(2, O_RV4 | cbn << 8 + INDX, i); 525 put(3, O_MAX, strnglen, 0); 526 break; 527 default: 528 if ( opt( 't' ) ) { 529 put(3, O_MAX, 0, 0); 530 } 531 break; 532 } 533 convert(nl+T4INT, INT_TYP); 534 stkcnt += sizeof(int); 535 } 536 /* 537 * Generate the format string 538 */ 539 switch (fmtspec) { 540 default: 541 panic("fmt2"); 542 case SKIP: 543 break; 544 case NIL: 545 sprintf(&format[1], "%%%c", fmt); 546 goto fmtgen; 547 case CONWIDTH: 548 sprintf(&format[1], "%%%d%c", field, fmt); 549 goto fmtgen; 550 case VARWIDTH: 551 sprintf(&format[1], "%%*%c", fmt); 552 goto fmtgen; 553 case CONWIDTH + CONPREC: 554 sprintf(&format[1], "%%%d.%d%c", field, prec, fmt); 555 goto fmtgen; 556 case CONWIDTH + VARPREC: 557 sprintf(&format[1], "%%%d.*%c", field, fmt); 558 goto fmtgen; 559 case VARWIDTH + CONPREC: 560 sprintf(&format[1], "%%*.%d%c", prec, fmt); 561 goto fmtgen; 562 case VARWIDTH + VARPREC: 563 sprintf(&format[1], "%%*.*%c", fmt); 564 fmtgen: 565 fmtlen = lenstr(&format[fmtstart], 0); 566 put(2, O_LVCON, fmtlen); 567 putstr(&format[fmtstart], 0); 568 put(1, O_FILE); 569 stkcnt += 2 * sizeof(char *); 570 put(2, O_WRITEF, stkcnt); 571 } 572 /* 573 * Write the string after its blank padding 574 */ 575 if (typ == TSTR) { 576 put(1, O_FILE); 577 put(2, CON_INT, 1); 578 if (strfmt & VARWIDTH) { 579 put(2, O_RV4 | cbn << 8 + INDX , i ); 580 put(2, O_MIN, strnglen); 581 convert(nl+T4INT, INT_TYP); 582 } else { 583 if ((fmtspec & SKIP) && 584 (strfmt & CONWIDTH)) { 585 strnglen = field; 586 } 587 put(2, CON_INT, strnglen); 588 } 589 ap = stkrval(alv, NIL , RREQ ); 590 put(2, O_WRITES, 591 2 * sizeof(char *) + 2 * sizeof(int)); 592 } 593 } 594 /* 595 * Done with arguments. 596 * Handle writeln and 597 * insufficent number of args. 598 */ 599 switch (p->value[0] &~ NSTAND) { 600 case O_WRITEF: 601 if (argc == 0) 602 error("Write requires an argument"); 603 break; 604 case O_MESSAGE: 605 if (argc == 0) 606 error("Message requires an argument"); 607 case O_WRITLN: 608 if (filetype != nl+T1CHAR) 609 error("Can't 'writeln' a non text file"); 610 put(1, O_WRITLN); 611 break; 612 } 613 return; 614 615 case O_READ4: 616 case O_READLN: 617 /* 618 * Set up default 619 * file "input". 620 */ 621 file = NIL; 622 filetype = nl+T1CHAR; 623 /* 624 * Determine the file implied 625 * for the read and generate 626 * code to make it the active file. 627 */ 628 if (argv != NIL) { 629 codeoff(); 630 ap = stkrval(argv[1], NIL , RREQ ); 631 codeon(); 632 if (ap == NIL) 633 argv = argv[2]; 634 if (ap != NIL && ap->class == FILET) { 635 /* 636 * Got "read(f, ...", make 637 * f the active file, and save 638 * it and its type for use in 639 * processing the rest of the 640 * arguments to read. 641 */ 642 file = argv[1]; 643 filetype = ap->type; 644 stklval(argv[1], NIL , LREQ ); 645 put(1, O_UNIT); 646 argv = argv[2]; 647 argc--; 648 } else { 649 /* 650 * Default is read from 651 * standard input. 652 */ 653 put(1, O_UNITINP); 654 input->nl_flags |= NUSED; 655 } 656 } else { 657 put(1, O_UNITINP); 658 input->nl_flags |= NUSED; 659 } 660 /* 661 * Loop and process each 662 * of the arguments. 663 */ 664 for (; argv != NIL; argv = argv[2]) { 665 /* 666 * Get the address of the target 667 * on the stack. 668 */ 669 al = argv[1]; 670 if (al == NIL) 671 continue; 672 if (al[0] != T_VAR) { 673 error("Arguments to %s must be variables, not expressions", p->symbol); 674 continue; 675 } 676 ap = stklval(al, MOD|ASGN|NOUSE); 677 if (ap == NIL) 678 continue; 679 if (filetype != nl+T1CHAR) { 680 /* 681 * Generalized read, i.e. 682 * from a non-textfile. 683 */ 684 if (incompat(filetype, ap, argv[1] )) { 685 error("Type mismatch in read from non-text file"); 686 continue; 687 } 688 /* 689 * var := file ^; 690 */ 691 if (file != NIL) 692 stklval(file, NIL , LREQ ); 693 else /* Magic */ 694 put(2, PTR_RV, (int)input->value[0]); 695 put(1, O_FNIL); 696 put(2, O_IND, width(filetype)); 697 convert(filetype, ap); 698 if (isa(ap, "bsci")) 699 rangechk(ap, ap); 700 put(2, O_AS, width(ap)); 701 /* 702 * get(file); 703 */ 704 put(1, O_GET); 705 continue; 706 } 707 typ = classify(ap); 708 op = rdops(typ); 709 if (op == NIL) { 710 error("Can't read %ss from a text file", clnames[typ]); 711 continue; 712 } 713 if (op != O_READE) 714 put(1, op); 715 else { 716 put(2, op, (long)listnames(ap)); 717 warning(); 718 if (opt('s')) { 719 standard(); 720 } 721 error("Reading scalars from text files is non-standard"); 722 } 723 /* 724 * Data read is on the stack. 725 * Assign it. 726 */ 727 if (op != O_READ8 && op != O_READE) 728 rangechk(ap, op == O_READC ? ap : nl+T4INT); 729 gen(O_AS2, O_AS2, width(ap), 730 op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2); 731 } 732 /* 733 * Done with arguments. 734 * Handle readln and 735 * insufficient number of args. 736 */ 737 if (p->value[0] == O_READLN) { 738 if (filetype != nl+T1CHAR) 739 error("Can't 'readln' a non text file"); 740 put(1, O_READLN); 741 } 742 else if (argc == 0) 743 error("read requires an argument"); 744 return; 745 746 case O_GET: 747 case O_PUT: 748 if (argc != 1) { 749 error("%s expects one argument", p->symbol); 750 return; 751 } 752 ap = stklval(argv[1], NIL , LREQ ); 753 if (ap == NIL) 754 return; 755 if (ap->class != FILET) { 756 error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 757 return; 758 } 759 put(1, O_UNIT); 760 put(1, op); 761 return; 762 763 case O_RESET: 764 case O_REWRITE: 765 if (argc == 0 || argc > 2) { 766 error("%s expects one or two arguments", p->symbol); 767 return; 768 } 769 if (opt('s') && argc == 2) { 770 standard(); 771 error("Two argument forms of reset and rewrite are non-standard"); 772 } 773 codeoff(); 774 ap = stklval(argv[1], MOD|NOUSE); 775 codeon(); 776 if (ap == NIL) 777 return; 778 if (ap->class != FILET) { 779 error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 780 return; 781 } 782 put(2, O_CON24, text(ap) ? 0: width(ap->type)); 783 if (argc == 2) { 784 /* 785 * Optional second argument 786 * is a string name of a 787 * UNIX (R) file to be associated. 788 */ 789 al = argv[2]; 790 codeoff(); 791 al = stkrval(al[1], NOFLAGS , RREQ ); 792 codeon(); 793 if (al == NIL) 794 return; 795 if (classify(al) != TSTR) { 796 error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); 797 return; 798 } 799 put(2, O_CON24, width(al)); 800 al = argv[2]; 801 al = stkrval(al[1], NOFLAGS , RREQ ); 802 } else { 803 put(2, O_CON24, 0); 804 put(2, PTR_CON, NIL); 805 } 806 ap = stklval(argv[1], MOD|NOUSE); 807 put(1, op); 808 return; 809 810 case O_NEW: 811 case O_DISPOSE: 812 if (argc == 0) { 813 error("%s expects at least one argument", p->symbol); 814 return; 815 } 816 ap = stklval(argv[1], op == O_NEW ? ( MOD | NOUSE ) : MOD ); 817 if (ap == NIL) 818 return; 819 if (ap->class != PTR) { 820 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 821 return; 822 } 823 ap = ap->type; 824 if (ap == NIL) 825 return; 826 argv = argv[2]; 827 if (argv != NIL) { 828 if (ap->class != RECORD) { 829 error("Record required when specifying variant tags"); 830 return; 831 } 832 for (; argv != NIL; argv = argv[2]) { 833 if (ap->ptr[NL_VARNT] == NIL) { 834 error("Too many tag fields"); 835 return; 836 } 837 if (!isconst(argv[1])) { 838 error("Second and successive arguments to %s must be constants", p->symbol); 839 return; 840 } 841 gconst(argv[1]); 842 if (con.ctype == NIL) 843 return; 844 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 845 cerror("Specified tag constant type clashed with variant case selector type"); 846 return; 847 } 848 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 849 if (ap->range[0] == con.crval) 850 break; 851 if (ap == NIL) { 852 error("No variant case label value equals specified constant value"); 853 return; 854 } 855 ap = ap->ptr[NL_VTOREC]; 856 } 857 } 858 put(2, op, width(ap)); 859 return; 860 861 case O_DATE: 862 case O_TIME: 863 if (argc != 1) { 864 error("%s expects one argument", p->symbol); 865 return; 866 } 867 ap = stklval(argv[1], MOD|NOUSE); 868 if (ap == NIL) 869 return; 870 if (classify(ap) != TSTR || width(ap) != 10) { 871 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 872 return; 873 } 874 put(1, op); 875 return; 876 877 case O_HALT: 878 if (argc != 0) { 879 error("halt takes no arguments"); 880 return; 881 } 882 put(1, op); 883 noreach = 1; 884 return; 885 886 case O_ARGV: 887 if (argc != 2) { 888 error("argv takes two arguments"); 889 return; 890 } 891 ap = stkrval(argv[1], NIL , RREQ ); 892 if (ap == NIL) 893 return; 894 if (isnta(ap, "i")) { 895 error("argv's first argument must be an integer, not %s", nameof(ap)); 896 return; 897 } 898 al = argv[2]; 899 ap = stklval(al[1], MOD|NOUSE); 900 if (ap == NIL) 901 return; 902 if (classify(ap) != TSTR) { 903 error("argv's second argument must be a string, not %s", nameof(ap)); 904 return; 905 } 906 put(2, op, width(ap)); 907 return; 908 909 case O_STLIM: 910 if (argc != 1) { 911 error("stlimit requires one argument"); 912 return; 913 } 914 ap = stkrval(argv[1], NIL , RREQ ); 915 if (ap == NIL) 916 return; 917 if (isnta(ap, "i")) { 918 error("stlimit's argument must be an integer, not %s", nameof(ap)); 919 return; 920 } 921 if (width(ap) != 4) 922 put(1, O_STOI); 923 put(1, op); 924 return; 925 926 case O_REMOVE: 927 if (argc != 1) { 928 error("remove expects one argument"); 929 return; 930 } 931 codeoff(); 932 ap = stkrval(argv[1], NOFLAGS , RREQ ); 933 codeon(); 934 if (ap == NIL) 935 return; 936 if (classify(ap) != TSTR) { 937 error("remove's argument must be a string, not %s", nameof(ap)); 938 return; 939 } 940 put(2, O_CON24, width(ap)); 941 ap = stkrval(argv[1], NOFLAGS , RREQ ); 942 put(1, op); 943 return; 944 945 case O_LLIMIT: 946 if (argc != 2) { 947 error("linelimit expects two arguments"); 948 return; 949 } 950 al = argv[2]; 951 ap = stkrval(al[1], NIL , RREQ ); 952 if (ap == NIL) 953 return; 954 if (isnta(ap, "i")) { 955 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 956 return; 957 } 958 ap = stklval(argv[1], NOFLAGS|NOUSE); 959 if (ap == NIL) 960 return; 961 if (!text(ap)) { 962 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 963 return; 964 } 965 put(1, op); 966 return; 967 case O_PAGE: 968 if (argc != 1) { 969 error("page expects one argument"); 970 return; 971 } 972 ap = stklval(argv[1], NIL , LREQ ); 973 if (ap == NIL) 974 return; 975 if (!text(ap)) { 976 error("Argument to page must be a text file, not %s", nameof(ap)); 977 return; 978 } 979 put(1, O_UNIT); 980 put(1, op); 981 return; 982 983 case O_PACK: 984 if (argc != 3) { 985 error("pack expects three arguments"); 986 return; 987 } 988 pu = "pack(a,i,z)"; 989 pua = argv[1]; 990 al = argv[2]; 991 pui = al[1]; 992 alv = al[2]; 993 puz = alv[1]; 994 goto packunp; 995 case O_UNPACK: 996 if (argc != 3) { 997 error("unpack expects three arguments"); 998 return; 999 } 1000 pu = "unpack(z,a,i)"; 1001 puz = argv[1]; 1002 al = argv[2]; 1003 pua = al[1]; 1004 alv = al[2]; 1005 pui = alv[1]; 1006 packunp: 1007 codeoff(); 1008 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1009 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1010 codeon(); 1011 if (ap == NIL) 1012 return; 1013 if (ap->class != ARRAY) { 1014 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1015 return; 1016 } 1017 if (al->class != ARRAY) { 1018 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1019 return; 1020 } 1021 if (al->type == NIL || ap->type == NIL) 1022 return; 1023 if (al->type != ap->type) { 1024 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1025 return; 1026 } 1027 k = width(al); 1028 itemwidth = width(ap->type); 1029 ap = ap->chain; 1030 al = al->chain; 1031 if (ap->chain != NIL || al->chain != NIL) { 1032 error("%s requires a and z to be single dimension arrays", pu); 1033 return; 1034 } 1035 if (ap == NIL || al == NIL) 1036 return; 1037 /* 1038 * al is the range for z i.e. u..v 1039 * ap is the range for a i.e. m..n 1040 * i will be n-m+1 1041 * j will be v-u+1 1042 */ 1043 i = ap->range[1] - ap->range[0] + 1; 1044 j = al->range[1] - al->range[0] + 1; 1045 if (i < j) { 1046 error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1047 return; 1048 } 1049 /* 1050 * get n-m-(v-u) and m for the interpreter 1051 */ 1052 i -= j; 1053 j = ap->range[0]; 1054 put(2, O_CON24, k); 1055 put(2, O_CON24, i); 1056 put(2, O_CON24, j); 1057 put(2, O_CON24, itemwidth); 1058 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1059 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1060 ap = stkrval((int *) pui, NLNIL , RREQ ); 1061 if (ap == NIL) 1062 return; 1063 put(1, op); 1064 return; 1065 case 0: 1066 error("%s is an unimplemented 6400 extension", p->symbol); 1067 return; 1068 1069 default: 1070 panic("proc case"); 1071 } 1072 } 1073 #endif OBJ 1074