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