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