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