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