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