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