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