1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcproc.c 1.15 11/16/82"; 4 5 #include "whoami.h" 6 #ifdef PC 7 /* 8 * and to the end of the file 9 */ 10 #include "0.h" 11 #include "tree.h" 12 #include "opcode.h" 13 #include "pc.h" 14 #include "pcops.h" 15 16 /* 17 * The constant REALSPC defines the amount of forced padding preceeding 18 * real numbers when they are printed. If REALSPC == 0, then no padding 19 * is added, REALSPC == 1 adds one extra blank irregardless of the width 20 * specified by the user. 21 * 22 * N.B. - Values greater than one require program mods. 23 */ 24 #define REALSPC 0 25 26 /* 27 * The following array is used to determine which classes may be read 28 * from textfiles. It is indexed by the return value from classify. 29 */ 30 #define rdops(x) rdxxxx[(x)-(TFIRST)] 31 32 int rdxxxx[] = { 33 0, /* -7 file types */ 34 0, /* -6 record types */ 35 0, /* -5 array types */ 36 O_READE, /* -4 scalar types */ 37 0, /* -3 pointer types */ 38 0, /* -2 set types */ 39 0, /* -1 string types */ 40 0, /* 0 nil, no type */ 41 O_READE, /* 1 boolean */ 42 O_READC, /* 2 character */ 43 O_READ4, /* 3 integer */ 44 O_READ8 /* 4 real */ 45 }; 46 47 /* 48 * Proc handles procedure calls. 49 * Non-builtin procedures are "buck-passed" to func (with a flag 50 * indicating that they are actually procedures. 51 * builtin procedures are handled here. 52 */ 53 pcproc(r) 54 int *r; 55 { 56 register struct nl *p; 57 register int *alv, *al, op; 58 struct nl *filetype, *ap; 59 int argc, *argv, typ, fmtspec, strfmt, stkcnt, *file; 60 char fmt, format[20], *strptr, *cmd; 61 int prec, field, strnglen, fmtlen, fmtstart, pu; 62 int *pua, *pui, *puz; 63 int i, j, k; 64 int itemwidth; 65 char *readname; 66 struct nl *tempnlp; 67 long readtype; 68 struct tmps soffset; 69 70 #define CONPREC 4 71 #define VARPREC 8 72 #define CONWIDTH 1 73 #define VARWIDTH 2 74 #define SKIP 16 75 76 /* 77 * Verify that the name is 78 * defined and is that of a 79 * procedure. 80 */ 81 p = lookup(r[2]); 82 if (p == NIL) { 83 rvlist(r[3]); 84 return; 85 } 86 if (p->class != PROC && p->class != FPROC) { 87 error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); 88 rvlist(r[3]); 89 return; 90 } 91 argv = r[3]; 92 93 /* 94 * Call handles user defined 95 * procedures and functions. 96 */ 97 if (bn != 0) { 98 call(p, argv, PROC, bn); 99 return; 100 } 101 102 /* 103 * Call to built-in procedure. 104 * Count the arguments. 105 */ 106 argc = 0; 107 for (al = argv; al != NIL; al = al[2]) 108 argc++; 109 110 /* 111 * Switch on the operator 112 * associated with the built-in 113 * procedure in the namelist 114 */ 115 op = p->value[0] &~ NSTAND; 116 if (opt('s') && (p->value[0] & NSTAND)) { 117 standard(); 118 error("%s is a nonstandard procedure", p->symbol); 119 } 120 switch (op) { 121 122 case O_ABORT: 123 if (argc != 0) 124 error("null takes no arguments"); 125 return; 126 127 case O_FLUSH: 128 if (argc == 0) { 129 putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" ); 130 putop( P2UNARY P2CALL , P2INT ); 131 putdot( filename , line ); 132 return; 133 } 134 if (argc != 1) { 135 error("flush takes at most one argument"); 136 return; 137 } 138 putleaf( P2ICON , 0 , 0 139 , ADDTYPE( P2FTN | P2INT , P2PTR ) 140 , "_FLUSH" ); 141 ap = stklval(argv[1], NOFLAGS); 142 if (ap == NIL) 143 return; 144 if (ap->class != FILET) { 145 error("flush's argument must be a file, not %s", nameof(ap)); 146 return; 147 } 148 putop( P2CALL , P2INT ); 149 putdot( filename , line ); 150 return; 151 152 case O_MESSAGE: 153 case O_WRITEF: 154 case O_WRITLN: 155 /* 156 * Set up default file "output"'s type 157 */ 158 file = NIL; 159 filetype = nl+T1CHAR; 160 /* 161 * Determine the file implied 162 * for the write and generate 163 * code to make it the active file. 164 */ 165 if (op == O_MESSAGE) { 166 /* 167 * For message, all that matters 168 * is that the filetype is 169 * a character file. 170 * Thus "output" will suit us fine. 171 */ 172 putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" ); 173 putop( P2UNARY P2CALL , P2INT ); 174 putdot( filename , line ); 175 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 176 P2PTR|P2STRTY ); 177 putLV( "__err" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 178 putop( P2ASSIGN , P2PTR|P2STRTY ); 179 putdot( filename , line ); 180 } else if (argv != NIL && (al = argv[1])[0] != 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[1], NIL , RREQ ); 188 codeon(); 189 if (ap == NIL) 190 argv = argv[2]; 191 if (ap != NIL && 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 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 200 P2PTR|P2STRTY ); 201 putleaf( P2ICON , 0 , 0 202 , ADDTYPE( P2FTN | P2INT , P2PTR ) 203 , "_UNIT" ); 204 file = argv[1]; 205 filetype = ap->type; 206 stklval(argv[1], NOFLAGS); 207 putop( P2CALL , P2INT ); 208 putop( P2ASSIGN , P2PTR|P2STRTY ); 209 putdot( filename , line ); 210 /* 211 * Skip over the first argument 212 */ 213 argv = argv[2]; 214 argc--; 215 } else { 216 /* 217 * Set up for writing on 218 * standard output. 219 */ 220 putRV( 0, cbn , CURFILEOFFSET , 221 NLOCAL , P2PTR|P2STRTY ); 222 putLV( "_output" , 0 , 0 , NGLOBAL , 223 P2PTR|P2STRTY ); 224 putop( P2ASSIGN , P2PTR|P2STRTY ); 225 putdot( filename , line ); 226 output->nl_flags |= NUSED; 227 } 228 } else { 229 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 230 P2PTR|P2STRTY ); 231 putLV( "_output" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 232 putop( P2ASSIGN , P2PTR|P2STRTY ); 233 putdot( filename , line ); 234 output->nl_flags |= NUSED; 235 } 236 /* 237 * Loop and process each 238 * of the arguments. 239 */ 240 for (; argv != NIL; argv = argv[2]) { 241 /* 242 * fmtspec indicates the type (CONstant or VARiable) 243 * and number (none, WIDTH, and/or PRECision) 244 * of the fields in the printf format for this 245 * output variable. 246 * stkcnt is the number of longs pushed on the stack 247 * fmt is the format output indicator (D, E, F, O, X, S) 248 * fmtstart = 0 for leading blank; = 1 for no blank 249 */ 250 fmtspec = NIL; 251 stkcnt = 0; 252 fmt = 'D'; 253 fmtstart = 1; 254 al = argv[1]; 255 if (al == NIL) 256 continue; 257 if (al[0] == T_WEXP) 258 alv = al[1]; 259 else 260 alv = al; 261 if (alv == NIL) 262 continue; 263 codeoff(); 264 ap = stkrval(alv, NIL , RREQ ); 265 codeon(); 266 if (ap == NIL) 267 continue; 268 typ = classify(ap); 269 if (al[0] == T_WEXP) { 270 /* 271 * Handle width expressions. 272 * The basic game here is that width 273 * expressions get evaluated. If they 274 * are constant, the value is placed 275 * directly in the format string. 276 * Otherwise the value is pushed onto 277 * the stack and an indirection is 278 * put into the format string. 279 */ 280 if (al[3] == OCT) 281 fmt = 'O'; 282 else if (al[3] == HEX) 283 fmt = 'X'; 284 else if (al[3] != NIL) { 285 /* 286 * Evaluate second format spec 287 */ 288 if ( constval(al[3]) 289 && isa( con.ctype , "i" ) ) { 290 fmtspec += CONPREC; 291 prec = con.crval; 292 } else { 293 fmtspec += VARPREC; 294 } 295 fmt = 'f'; 296 switch ( typ ) { 297 case TINT: 298 if ( opt( 's' ) ) { 299 standard(); 300 error("Writing %ss with two write widths is non-standard", clnames[typ]); 301 } 302 /* and fall through */ 303 case TDOUBLE: 304 break; 305 default: 306 error("Cannot write %ss with two write widths", clnames[typ]); 307 continue; 308 } 309 } 310 /* 311 * Evaluate first format spec 312 */ 313 if (al[2] != NIL) { 314 if ( constval(al[2]) 315 && isa( con.ctype , "i" ) ) { 316 fmtspec += CONWIDTH; 317 field = con.crval; 318 } else { 319 fmtspec += VARWIDTH; 320 } 321 } 322 if ((fmtspec & CONPREC) && prec < 0 || 323 (fmtspec & CONWIDTH) && field < 0) { 324 error("Negative widths are not allowed"); 325 continue; 326 } 327 if ( opt('s') && 328 ((fmtspec & CONPREC) && prec == 0 || 329 (fmtspec & CONWIDTH) && field == 0)) { 330 standard(); 331 error("Zero widths are non-standard"); 332 } 333 } 334 if (filetype != nl+T1CHAR) { 335 if (fmt == 'O' || fmt == 'X') { 336 error("Oct/hex allowed only on text files"); 337 continue; 338 } 339 if (fmtspec) { 340 error("Write widths allowed only on text files"); 341 continue; 342 } 343 /* 344 * Generalized write, i.e. 345 * to a non-textfile. 346 */ 347 putleaf( P2ICON , 0 , 0 348 , ADDTYPE( 349 ADDTYPE( 350 ADDTYPE( p2type( filetype ) 351 , P2PTR ) 352 , P2FTN ) 353 , P2PTR ) 354 , "_FNIL" ); 355 stklval(file, NOFLAGS); 356 putop( P2CALL 357 , ADDTYPE( p2type( filetype ) , P2PTR ) ); 358 putop( P2UNARY P2MUL , p2type( filetype ) ); 359 /* 360 * file^ := ... 361 */ 362 switch ( classify( filetype ) ) { 363 case TBOOL: 364 case TCHAR: 365 case TINT: 366 case TSCAL: 367 precheck( filetype , "_RANG4" , "_RSNG4" ); 368 /* and fall through */ 369 case TDOUBLE: 370 case TPTR: 371 ap = rvalue( argv[1] , filetype , RREQ ); 372 break; 373 default: 374 ap = rvalue( argv[1] , filetype , LREQ ); 375 break; 376 } 377 if (ap == NIL) 378 continue; 379 if (incompat(ap, filetype, argv[1])) { 380 cerror("Type mismatch in write to non-text file"); 381 continue; 382 } 383 switch ( classify( filetype ) ) { 384 case TBOOL: 385 case TCHAR: 386 case TINT: 387 case TSCAL: 388 postcheck( filetype ); 389 /* and fall through */ 390 case TDOUBLE: 391 case TPTR: 392 putop( P2ASSIGN , p2type( filetype ) ); 393 putdot( filename , line ); 394 break; 395 default: 396 putstrop( P2STASG 397 , p2type( filetype ) 398 , lwidth( filetype ) 399 , align( filetype ) ); 400 putdot( filename , line ); 401 break; 402 } 403 /* 404 * put(file) 405 */ 406 putleaf( P2ICON , 0 , 0 407 , ADDTYPE( P2FTN | P2INT , P2PTR ) 408 , "_PUT" ); 409 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 410 P2PTR|P2STRTY ); 411 putop( P2CALL , P2INT ); 412 putdot( filename , line ); 413 continue; 414 } 415 /* 416 * Write to a textfile 417 * 418 * Evaluate the expression 419 * to be written. 420 */ 421 if (fmt == 'O' || fmt == 'X') { 422 if (opt('s')) { 423 standard(); 424 error("Oct and hex are non-standard"); 425 } 426 if (typ == TSTR || typ == TDOUBLE) { 427 error("Can't write %ss with oct/hex", clnames[typ]); 428 continue; 429 } 430 if (typ == TCHAR || typ == TBOOL) 431 typ = TINT; 432 } 433 /* 434 * If there is no format specified by the programmer, 435 * implement the default. 436 */ 437 switch (typ) { 438 case TPTR: 439 warning(); 440 if (opt('s')) { 441 standard(); 442 } 443 error("Writing %ss to text files is non-standard", 444 clnames[typ]); 445 /* and fall through */ 446 case TINT: 447 if (fmt == 'f') { 448 typ = TDOUBLE; 449 goto tdouble; 450 } 451 if (fmtspec == NIL) { 452 if (fmt == 'D') 453 field = 10; 454 else if (fmt == 'X') 455 field = 8; 456 else if (fmt == 'O') 457 field = 11; 458 else 459 panic("fmt1"); 460 fmtspec = CONWIDTH; 461 } 462 break; 463 case TCHAR: 464 tchar: 465 fmt = 'c'; 466 break; 467 case TSCAL: 468 warning(); 469 if (opt('s')) { 470 standard(); 471 } 472 error("Writing %ss to text files is non-standard", 473 clnames[typ]); 474 case TBOOL: 475 fmt = 's'; 476 break; 477 case TDOUBLE: 478 tdouble: 479 switch (fmtspec) { 480 case NIL: 481 field = 21; 482 prec = 14; 483 fmt = 'e'; 484 fmtspec = CONWIDTH + CONPREC; 485 break; 486 case CONWIDTH: 487 field -= REALSPC; 488 if (field < 1) 489 field = 1; 490 prec = field - 7; 491 if (prec < 1) 492 prec = 1; 493 fmtspec += CONPREC; 494 fmt = 'e'; 495 break; 496 case VARWIDTH: 497 fmtspec += VARPREC; 498 fmt = 'e'; 499 break; 500 case CONWIDTH + CONPREC: 501 case CONWIDTH + VARPREC: 502 field -= REALSPC; 503 if (field < 1) 504 field = 1; 505 } 506 format[0] = ' '; 507 fmtstart = 1 - REALSPC; 508 break; 509 case TSTR: 510 constval( alv ); 511 switch ( classify( con.ctype ) ) { 512 case TCHAR: 513 typ = TCHAR; 514 goto tchar; 515 case TSTR: 516 strptr = con.cpval; 517 for (strnglen = 0; *strptr++; strnglen++) /* void */; 518 strptr = con.cpval; 519 break; 520 default: 521 strnglen = width(ap); 522 break; 523 } 524 fmt = 's'; 525 strfmt = fmtspec; 526 if (fmtspec == NIL) { 527 fmtspec = SKIP; 528 break; 529 } 530 if (fmtspec & CONWIDTH) { 531 if (field <= strnglen) 532 fmtspec = SKIP; 533 else 534 field -= strnglen; 535 } 536 break; 537 default: 538 error("Can't write %ss to a text file", clnames[typ]); 539 continue; 540 } 541 /* 542 * Generate the format string 543 */ 544 switch (fmtspec) { 545 default: 546 panic("fmt2"); 547 case NIL: 548 if (fmt == 'c') { 549 if ( opt( 't' ) ) { 550 putleaf( P2ICON , 0 , 0 551 , ADDTYPE( P2FTN|P2INT , P2PTR ) 552 , "_WRITEC" ); 553 putRV( 0 , cbn , CURFILEOFFSET , 554 NLOCAL , P2PTR|P2STRTY ); 555 stkrval( alv , NIL , RREQ ); 556 putop( P2LISTOP , P2INT ); 557 } else { 558 putleaf( P2ICON , 0 , 0 559 , ADDTYPE( P2FTN|P2INT , P2PTR ) 560 , "_fputc" ); 561 stkrval( alv , NIL , RREQ ); 562 } 563 putleaf( P2ICON , 0 , 0 564 , ADDTYPE( P2FTN | P2INT , P2PTR ) 565 , "_ACTFILE" ); 566 putRV( 0, cbn , CURFILEOFFSET , 567 NLOCAL , P2PTR|P2STRTY ); 568 putop( P2CALL , P2INT ); 569 putop( P2LISTOP , P2INT ); 570 putop( P2CALL , P2INT ); 571 putdot( filename , line ); 572 } else { 573 sprintf(&format[1], "%%%c", fmt); 574 goto fmtgen; 575 } 576 case SKIP: 577 break; 578 case CONWIDTH: 579 sprintf(&format[1], "%%%1D%c", field, fmt); 580 goto fmtgen; 581 case VARWIDTH: 582 sprintf(&format[1], "%%*%c", fmt); 583 goto fmtgen; 584 case CONWIDTH + CONPREC: 585 sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt); 586 goto fmtgen; 587 case CONWIDTH + VARPREC: 588 sprintf(&format[1], "%%%1D.*%c", field, fmt); 589 goto fmtgen; 590 case VARWIDTH + CONPREC: 591 sprintf(&format[1], "%%*.%1D%c", prec, fmt); 592 goto fmtgen; 593 case VARWIDTH + VARPREC: 594 sprintf(&format[1], "%%*.*%c", fmt); 595 fmtgen: 596 if ( opt( 't' ) ) { 597 putleaf( P2ICON , 0 , 0 598 , ADDTYPE( P2FTN | P2INT , P2PTR ) 599 , "_WRITEF" ); 600 putRV( 0 , cbn , CURFILEOFFSET , 601 NLOCAL , P2PTR|P2STRTY ); 602 putleaf( P2ICON , 0 , 0 603 , ADDTYPE( P2FTN | P2INT , P2PTR ) 604 , "_ACTFILE" ); 605 putRV( 0 , cbn , CURFILEOFFSET , 606 NLOCAL , P2PTR|P2STRTY ); 607 putop( P2CALL , P2INT ); 608 putop( P2LISTOP , P2INT ); 609 } else { 610 putleaf( P2ICON , 0 , 0 611 , ADDTYPE( P2FTN | P2INT , P2PTR ) 612 , "_fprintf" ); 613 putleaf( P2ICON , 0 , 0 614 , ADDTYPE( P2FTN | P2INT , P2PTR ) 615 , "_ACTFILE" ); 616 putRV( 0 , cbn , CURFILEOFFSET , 617 NLOCAL , P2PTR|P2STRTY ); 618 putop( P2CALL , P2INT ); 619 } 620 putCONG( &format[ fmtstart ] 621 , strlen( &format[ fmtstart ] ) 622 , LREQ ); 623 putop( P2LISTOP , P2INT ); 624 if ( fmtspec & VARWIDTH ) { 625 /* 626 * either 627 * ,(temp=width,MAX(temp,...)), 628 * or 629 * , MAX( width , ... ) , 630 */ 631 if ( ( typ == TDOUBLE && al[3] == NIL ) 632 || typ == TSTR ) { 633 soffset = sizes[cbn].curtmps; 634 tempnlp = tmpalloc(sizeof(long), 635 nl+T4INT, REGOK); 636 putRV( 0 , cbn , 637 tempnlp -> value[ NL_OFFS ] , 638 tempnlp -> extra_flags , P2INT ); 639 ap = stkrval( al[2] , NIL , RREQ ); 640 putop( P2ASSIGN , P2INT ); 641 putleaf( P2ICON , 0 , 0 642 , ADDTYPE( P2FTN | P2INT , P2PTR ) 643 , "_MAX" ); 644 putRV( 0 , cbn , 645 tempnlp -> value[ NL_OFFS ] , 646 tempnlp -> extra_flags , P2INT ); 647 } else { 648 if (opt('t') 649 || typ == TSTR || typ == TDOUBLE) { 650 putleaf( P2ICON , 0 , 0 651 ,ADDTYPE( P2FTN | P2INT, P2PTR ) 652 ,"_MAX" ); 653 } 654 ap = stkrval( al[2] , NIL , RREQ ); 655 } 656 if (ap == NIL) 657 continue; 658 if (isnta(ap,"i")) { 659 error("First write width must be integer, not %s", nameof(ap)); 660 continue; 661 } 662 switch ( typ ) { 663 case TDOUBLE: 664 putleaf( P2ICON , REALSPC , 0 , P2INT , 0 ); 665 putop( P2LISTOP , P2INT ); 666 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 667 putop( P2LISTOP , P2INT ); 668 putop( P2CALL , P2INT ); 669 if ( al[3] == NIL ) { 670 /* 671 * finish up the comma op 672 */ 673 putop( P2COMOP , P2INT ); 674 fmtspec &= ~VARPREC; 675 putop( P2LISTOP , P2INT ); 676 putleaf( P2ICON , 0 , 0 677 , ADDTYPE( P2FTN | P2INT , P2PTR ) 678 , "_MAX" ); 679 putRV( 0 , cbn , 680 tempnlp -> value[ NL_OFFS ] , 681 tempnlp -> extra_flags , 682 P2INT ); 683 tmpfree(&soffset); 684 putleaf( P2ICON , 7 + REALSPC , 0 , P2INT , 0 ); 685 putop( P2LISTOP , P2INT ); 686 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 687 putop( P2LISTOP , P2INT ); 688 putop( P2CALL , P2INT ); 689 } 690 putop( P2LISTOP , P2INT ); 691 break; 692 case TSTR: 693 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 694 putop( P2LISTOP , P2INT ); 695 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 696 putop( P2LISTOP , P2INT ); 697 putop( P2CALL , P2INT ); 698 putop( P2COMOP , P2INT ); 699 putop( P2LISTOP , P2INT ); 700 break; 701 default: 702 if (opt('t')) { 703 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 704 putop( P2LISTOP , P2INT ); 705 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 706 putop( P2LISTOP , P2INT ); 707 putop( P2CALL , P2INT ); 708 } 709 putop( P2LISTOP , P2INT ); 710 break; 711 } 712 } 713 /* 714 * If there is a variable precision, 715 * evaluate it 716 */ 717 if (fmtspec & VARPREC) { 718 if (opt('t')) { 719 putleaf( P2ICON , 0 , 0 720 , ADDTYPE( P2FTN | P2INT , P2PTR ) 721 , "_MAX" ); 722 } 723 ap = stkrval( al[3] , NIL , RREQ ); 724 if (ap == NIL) 725 continue; 726 if (isnta(ap,"i")) { 727 error("Second write width must be integer, not %s", nameof(ap)); 728 continue; 729 } 730 if (opt('t')) { 731 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 732 putop( P2LISTOP , P2INT ); 733 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 734 putop( P2LISTOP , P2INT ); 735 putop( P2CALL , P2INT ); 736 } 737 putop( P2LISTOP , P2INT ); 738 } 739 /* 740 * evaluate the thing we want printed. 741 */ 742 switch ( typ ) { 743 case TPTR: 744 case TCHAR: 745 case TINT: 746 stkrval( alv , NIL , RREQ ); 747 putop( P2LISTOP , P2INT ); 748 break; 749 case TDOUBLE: 750 ap = stkrval( alv , NIL , RREQ ); 751 if ( isnta( ap , "d" ) ) { 752 putop( P2SCONV , P2DOUBLE ); 753 } 754 putop( P2LISTOP , P2INT ); 755 break; 756 case TSCAL: 757 case TBOOL: 758 putleaf( P2ICON , 0 , 0 759 , ADDTYPE( P2FTN | P2INT , P2PTR ) 760 , "_NAM" ); 761 ap = stkrval( alv , NIL , RREQ ); 762 sprintf( format , PREFIXFORMAT , LABELPREFIX 763 , listnames( ap ) ); 764 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 765 , format ); 766 putop( P2LISTOP , P2INT ); 767 putop( P2CALL , P2INT ); 768 putop( P2LISTOP , P2INT ); 769 break; 770 case TSTR: 771 putCONG( "" , 0 , LREQ ); 772 putop( P2LISTOP , P2INT ); 773 break; 774 default: 775 panic("fmt3"); 776 break; 777 } 778 putop( P2CALL , P2INT ); 779 putdot( filename , line ); 780 } 781 /* 782 * Write the string after its blank padding 783 */ 784 if (typ == TSTR ) { 785 if ( opt( 't' ) ) { 786 putleaf( P2ICON , 0 , 0 787 , ADDTYPE( P2FTN | P2INT , P2PTR ) 788 , "_WRITES" ); 789 putRV( 0 , cbn , CURFILEOFFSET , 790 NLOCAL , P2PTR|P2STRTY ); 791 ap = stkrval(alv, NIL , RREQ ); 792 putop( P2LISTOP , P2INT ); 793 } else { 794 putleaf( P2ICON , 0 , 0 795 , ADDTYPE( P2FTN | P2INT , P2PTR ) 796 , "_fwrite" ); 797 ap = stkrval(alv, NIL , RREQ ); 798 } 799 if (strfmt & VARWIDTH) { 800 /* 801 * min, inline expanded as 802 * temp < len ? temp : len 803 */ 804 putRV( 0 , cbn , 805 tempnlp -> value[ NL_OFFS ] , 806 tempnlp -> extra_flags , P2INT ); 807 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 808 putop( P2LT , P2INT ); 809 putRV( 0 , cbn , 810 tempnlp -> value[ NL_OFFS ] , 811 tempnlp -> extra_flags , P2INT ); 812 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 813 putop( P2COLON , P2INT ); 814 putop( P2QUEST , P2INT ); 815 tmpfree(&soffset); 816 } else { 817 if ( ( fmtspec & SKIP ) 818 && ( strfmt & CONWIDTH ) ) { 819 strnglen = field; 820 } 821 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 822 } 823 putop( P2LISTOP , P2INT ); 824 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 825 putop( P2LISTOP , P2INT ); 826 putleaf( P2ICON , 0 , 0 827 , ADDTYPE( P2FTN | P2INT , P2PTR ) 828 , "_ACTFILE" ); 829 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 830 P2PTR|P2STRTY ); 831 putop( P2CALL , P2INT ); 832 putop( P2LISTOP , P2INT ); 833 putop( P2CALL , P2INT ); 834 putdot( filename , line ); 835 } 836 } 837 /* 838 * Done with arguments. 839 * Handle writeln and 840 * insufficent number of args. 841 */ 842 switch (p->value[0] &~ NSTAND) { 843 case O_WRITEF: 844 if (argc == 0) 845 error("Write requires an argument"); 846 break; 847 case O_MESSAGE: 848 if (argc == 0) 849 error("Message requires an argument"); 850 case O_WRITLN: 851 if (filetype != nl+T1CHAR) 852 error("Can't 'writeln' a non text file"); 853 if ( opt( 't' ) ) { 854 putleaf( P2ICON , 0 , 0 855 , ADDTYPE( P2FTN | P2INT , P2PTR ) 856 , "_WRITLN" ); 857 putRV( 0 , cbn , CURFILEOFFSET , 858 NLOCAL , P2PTR|P2STRTY ); 859 } else { 860 putleaf( P2ICON , 0 , 0 861 , ADDTYPE( P2FTN | P2INT , P2PTR ) 862 , "_fputc" ); 863 putleaf( P2ICON , '\n' , 0 , P2CHAR , 0 ); 864 putleaf( P2ICON , 0 , 0 865 , ADDTYPE( P2FTN | P2INT , P2PTR ) 866 , "_ACTFILE" ); 867 putRV( 0 , cbn , CURFILEOFFSET , 868 NLOCAL , P2PTR|P2STRTY ); 869 putop( P2CALL , P2INT ); 870 putop( P2LISTOP , P2INT ); 871 } 872 putop( P2CALL , P2INT ); 873 putdot( filename , line ); 874 break; 875 } 876 return; 877 878 case O_READ4: 879 case O_READLN: 880 /* 881 * Set up default 882 * file "input". 883 */ 884 file = NIL; 885 filetype = nl+T1CHAR; 886 /* 887 * Determine the file implied 888 * for the read and generate 889 * code to make it the active file. 890 */ 891 if (argv != NIL) { 892 codeoff(); 893 ap = stkrval(argv[1], NIL , RREQ ); 894 codeon(); 895 if (ap == NIL) 896 argv = argv[2]; 897 if (ap != NIL && ap->class == FILET) { 898 /* 899 * Got "read(f, ...", make 900 * f the active file, and save 901 * it and its type for use in 902 * processing the rest of the 903 * arguments to read. 904 */ 905 file = argv[1]; 906 filetype = ap->type; 907 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 908 P2PTR|P2STRTY ); 909 putleaf( P2ICON , 0 , 0 910 , ADDTYPE( P2FTN | P2INT , P2PTR ) 911 , "_UNIT" ); 912 stklval(argv[1], NOFLAGS); 913 putop( P2CALL , P2INT ); 914 putop( P2ASSIGN , P2PTR|P2STRTY ); 915 putdot( filename , line ); 916 argv = argv[2]; 917 argc--; 918 } else { 919 /* 920 * Default is read from 921 * standard input. 922 */ 923 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 924 P2PTR|P2STRTY ); 925 putLV( "_input" , 0 , 0 , NGLOBAL , 926 P2PTR|P2STRTY ); 927 putop( P2ASSIGN , P2PTR|P2STRTY ); 928 putdot( filename , line ); 929 input->nl_flags |= NUSED; 930 } 931 } else { 932 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 933 P2PTR|P2STRTY ); 934 putLV( "_input" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 935 putop( P2ASSIGN , P2PTR|P2STRTY ); 936 putdot( filename , line ); 937 input->nl_flags |= NUSED; 938 } 939 /* 940 * Loop and process each 941 * of the arguments. 942 */ 943 for (; argv != NIL; argv = argv[2]) { 944 /* 945 * Get the address of the target 946 * on the stack. 947 */ 948 al = argv[1]; 949 if (al == NIL) 950 continue; 951 if (al[0] != T_VAR) { 952 error("Arguments to %s must be variables, not expressions", p->symbol); 953 continue; 954 } 955 codeoff(); 956 ap = stklval(al, MOD|ASGN|NOUSE); 957 codeon(); 958 if (ap == NIL) 959 continue; 960 if (filetype != nl+T1CHAR) { 961 /* 962 * Generalized read, i.e. 963 * from a non-textfile. 964 */ 965 if (incompat(filetype, ap, argv[1] )) { 966 error("Type mismatch in read from non-text file"); 967 continue; 968 } 969 /* 970 * var := file ^; 971 */ 972 ap = lvalue( al , MOD | ASGN | NOUSE , RREQ ); 973 if ( isa( ap , "bsci" ) ) { 974 precheck( ap , "_RANG4" , "_RSNG4" ); 975 } 976 putleaf( P2ICON , 0 , 0 977 , ADDTYPE( 978 ADDTYPE( 979 ADDTYPE( 980 p2type( filetype ) , P2PTR ) 981 , P2FTN ) 982 , P2PTR ) 983 , "_FNIL" ); 984 if (file != NIL) 985 stklval(file, NOFLAGS); 986 else /* Magic */ 987 putRV( "_input" , 0 , 0 , NGLOBAL , 988 P2PTR | P2STRTY ); 989 putop( P2CALL , P2INT ); 990 switch ( classify( filetype ) ) { 991 case TBOOL: 992 case TCHAR: 993 case TINT: 994 case TSCAL: 995 case TDOUBLE: 996 case TPTR: 997 putop( P2UNARY P2MUL 998 , p2type( filetype ) ); 999 } 1000 switch ( classify( filetype ) ) { 1001 case TBOOL: 1002 case TCHAR: 1003 case TINT: 1004 case TSCAL: 1005 postcheck( ap ); 1006 /* and fall through */ 1007 case TDOUBLE: 1008 case TPTR: 1009 putop( P2ASSIGN , p2type( ap ) ); 1010 putdot( filename , line ); 1011 break; 1012 default: 1013 putstrop( P2STASG 1014 , p2type( ap ) 1015 , lwidth( ap ) 1016 , align( ap ) ); 1017 putdot( filename , line ); 1018 break; 1019 } 1020 /* 1021 * get(file); 1022 */ 1023 putleaf( P2ICON , 0 , 0 1024 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1025 , "_GET" ); 1026 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1027 P2PTR|P2STRTY ); 1028 putop( P2CALL , P2INT ); 1029 putdot( filename , line ); 1030 continue; 1031 } 1032 /* 1033 * if you get to here, you are reading from 1034 * a text file. only possiblities are: 1035 * character, integer, real, or scalar. 1036 * read( f , foo , ... ) is done as 1037 * foo := read( f ) with rangechecking 1038 * if appropriate. 1039 */ 1040 typ = classify(ap); 1041 op = rdops(typ); 1042 if (op == NIL) { 1043 error("Can't read %ss from a text file", clnames[typ]); 1044 continue; 1045 } 1046 /* 1047 * left hand side of foo := read( f ) 1048 */ 1049 ap = lvalue( al , MOD|ASGN|NOUSE , RREQ ); 1050 if ( isa( ap , "bsci" ) ) { 1051 precheck( ap , "_RANG4" , "_RSNG4" ); 1052 } 1053 switch ( op ) { 1054 case O_READC: 1055 readname = "_READC"; 1056 readtype = P2INT; 1057 break; 1058 case O_READ4: 1059 readname = "_READ4"; 1060 readtype = P2INT; 1061 break; 1062 case O_READ8: 1063 readname = "_READ8"; 1064 readtype = P2DOUBLE; 1065 break; 1066 case O_READE: 1067 readname = "_READE"; 1068 readtype = P2INT; 1069 break; 1070 } 1071 putleaf( P2ICON , 0 , 0 1072 , ADDTYPE( P2FTN | readtype , P2PTR ) 1073 , readname ); 1074 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1075 P2PTR|P2STRTY ); 1076 if ( op == O_READE ) { 1077 sprintf( format , PREFIXFORMAT , LABELPREFIX 1078 , listnames( ap ) ); 1079 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 1080 , format ); 1081 putop( P2LISTOP , P2INT ); 1082 warning(); 1083 if (opt('s')) { 1084 standard(); 1085 } 1086 error("Reading scalars from text files is non-standard"); 1087 } 1088 putop( P2CALL , readtype ); 1089 if ( isa( ap , "bcsi" ) ) { 1090 postcheck( ap ); 1091 } 1092 putop( P2ASSIGN , p2type( ap ) ); 1093 putdot( filename , line ); 1094 } 1095 /* 1096 * Done with arguments. 1097 * Handle readln and 1098 * insufficient number of args. 1099 */ 1100 if (p->value[0] == O_READLN) { 1101 if (filetype != nl+T1CHAR) 1102 error("Can't 'readln' a non text file"); 1103 putleaf( P2ICON , 0 , 0 1104 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1105 , "_READLN" ); 1106 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1107 P2PTR|P2STRTY ); 1108 putop( P2CALL , P2INT ); 1109 putdot( filename , line ); 1110 } else if (argc == 0) 1111 error("read requires an argument"); 1112 return; 1113 1114 case O_GET: 1115 case O_PUT: 1116 if (argc != 1) { 1117 error("%s expects one argument", p->symbol); 1118 return; 1119 } 1120 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1121 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1122 , "_UNIT" ); 1123 ap = stklval(argv[1], NOFLAGS); 1124 if (ap == NIL) 1125 return; 1126 if (ap->class != FILET) { 1127 error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1128 return; 1129 } 1130 putop( P2CALL , P2INT ); 1131 putop( P2ASSIGN , P2PTR|P2STRTY ); 1132 putdot( filename , line ); 1133 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1134 , op == O_GET ? "_GET" : "_PUT" ); 1135 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1136 putop( P2CALL , P2INT ); 1137 putdot( filename , line ); 1138 return; 1139 1140 case O_RESET: 1141 case O_REWRITE: 1142 if (argc == 0 || argc > 2) { 1143 error("%s expects one or two arguments", p->symbol); 1144 return; 1145 } 1146 if (opt('s') && argc == 2) { 1147 standard(); 1148 error("Two argument forms of reset and rewrite are non-standard"); 1149 } 1150 putleaf( P2ICON , 0 , 0 , P2INT 1151 , op == O_RESET ? "_RESET" : "_REWRITE" ); 1152 ap = stklval(argv[1], MOD|NOUSE); 1153 if (ap == NIL) 1154 return; 1155 if (ap->class != FILET) { 1156 error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1157 return; 1158 } 1159 if (argc == 2) { 1160 /* 1161 * Optional second argument 1162 * is a string name of a 1163 * UNIX (R) file to be associated. 1164 */ 1165 al = argv[2]; 1166 al = stkrval(al[1], NOFLAGS , RREQ ); 1167 if (al == NIL) 1168 return; 1169 if (classify(al) != TSTR) { 1170 error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); 1171 return; 1172 } 1173 strnglen = width(al); 1174 } else { 1175 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 1176 strnglen = 0; 1177 } 1178 putop( P2LISTOP , P2INT ); 1179 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 1180 putop( P2LISTOP , P2INT ); 1181 putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 ); 1182 putop( P2LISTOP , P2INT ); 1183 putop( P2CALL , P2INT ); 1184 putdot( filename , line ); 1185 return; 1186 1187 case O_NEW: 1188 case O_DISPOSE: 1189 if (argc == 0) { 1190 error("%s expects at least one argument", p->symbol); 1191 return; 1192 } 1193 alv = argv[1]; 1194 codeoff(); 1195 ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1196 codeon(); 1197 if (ap == NIL) 1198 return; 1199 if (ap->class != PTR) { 1200 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1201 return; 1202 } 1203 ap = ap->type; 1204 if (ap == NIL) 1205 return; 1206 if (op == O_NEW) 1207 cmd = "_NEW"; 1208 else /* op == O_DISPOSE */ 1209 if ((ap->nl_flags & NFILES) != 0) 1210 cmd = "_DFDISPOSE"; 1211 else 1212 cmd = "_DISPOSE"; 1213 putleaf( P2ICON, 0, 0, ADDTYPE( P2FTN | P2INT , P2PTR ), cmd); 1214 stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1215 argv = argv[2]; 1216 if (argv != NIL) { 1217 if (ap->class != RECORD) { 1218 error("Record required when specifying variant tags"); 1219 return; 1220 } 1221 for (; argv != NIL; argv = argv[2]) { 1222 if (ap->ptr[NL_VARNT] == NIL) { 1223 error("Too many tag fields"); 1224 return; 1225 } 1226 if (!isconst(argv[1])) { 1227 error("Second and successive arguments to %s must be constants", p->symbol); 1228 return; 1229 } 1230 gconst(argv[1]); 1231 if (con.ctype == NIL) 1232 return; 1233 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 1234 cerror("Specified tag constant type clashed with variant case selector type"); 1235 return; 1236 } 1237 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1238 if (ap->range[0] == con.crval) 1239 break; 1240 if (ap == NIL) { 1241 error("No variant case label value equals specified constant value"); 1242 return; 1243 } 1244 ap = ap->ptr[NL_VTOREC]; 1245 } 1246 } 1247 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1248 putop( P2LISTOP , P2INT ); 1249 putop( P2CALL , P2INT ); 1250 putdot( filename , line ); 1251 if (opt('t') && op == O_NEW) { 1252 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1253 , "_blkclr" ); 1254 stkrval(alv, NIL , RREQ ); 1255 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1256 putop( P2LISTOP , P2INT ); 1257 putop( P2CALL , P2INT ); 1258 putdot( filename , line ); 1259 } 1260 return; 1261 1262 case O_DATE: 1263 case O_TIME: 1264 if (argc != 1) { 1265 error("%s expects one argument", p->symbol); 1266 return; 1267 } 1268 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1269 , op == O_DATE ? "_DATE" : "_TIME" ); 1270 ap = stklval(argv[1], MOD|NOUSE); 1271 if (ap == NIL) 1272 return; 1273 if (classify(ap) != TSTR || width(ap) != 10) { 1274 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1275 return; 1276 } 1277 putop( P2CALL , P2INT ); 1278 putdot( filename , line ); 1279 return; 1280 1281 case O_HALT: 1282 if (argc != 0) { 1283 error("halt takes no arguments"); 1284 return; 1285 } 1286 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1287 , "_HALT" ); 1288 1289 putop( P2UNARY P2CALL , P2INT ); 1290 putdot( filename , line ); 1291 noreach = 1; 1292 return; 1293 1294 case O_ARGV: 1295 if (argc != 2) { 1296 error("argv takes two arguments"); 1297 return; 1298 } 1299 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1300 , "_ARGV" ); 1301 ap = stkrval(argv[1], NIL , RREQ ); 1302 if (ap == NIL) 1303 return; 1304 if (isnta(ap, "i")) { 1305 error("argv's first argument must be an integer, not %s", nameof(ap)); 1306 return; 1307 } 1308 al = argv[2]; 1309 ap = stklval(al[1], MOD|NOUSE); 1310 if (ap == NIL) 1311 return; 1312 if (classify(ap) != TSTR) { 1313 error("argv's second argument must be a string, not %s", nameof(ap)); 1314 return; 1315 } 1316 putop( P2LISTOP , P2INT ); 1317 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1318 putop( P2LISTOP , P2INT ); 1319 putop( P2CALL , P2INT ); 1320 putdot( filename , line ); 1321 return; 1322 1323 case O_STLIM: 1324 if (argc != 1) { 1325 error("stlimit requires one argument"); 1326 return; 1327 } 1328 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1329 , "_STLIM" ); 1330 ap = stkrval(argv[1], NIL , RREQ ); 1331 if (ap == NIL) 1332 return; 1333 if (isnta(ap, "i")) { 1334 error("stlimit's argument must be an integer, not %s", nameof(ap)); 1335 return; 1336 } 1337 putop( P2CALL , P2INT ); 1338 putdot( filename , line ); 1339 return; 1340 1341 case O_REMOVE: 1342 if (argc != 1) { 1343 error("remove expects one argument"); 1344 return; 1345 } 1346 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1347 , "_REMOVE" ); 1348 ap = stkrval(argv[1], NOFLAGS , RREQ ); 1349 if (ap == NIL) 1350 return; 1351 if (classify(ap) != TSTR) { 1352 error("remove's argument must be a string, not %s", nameof(ap)); 1353 return; 1354 } 1355 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1356 putop( P2LISTOP , P2INT ); 1357 putop( P2CALL , P2INT ); 1358 putdot( filename , line ); 1359 return; 1360 1361 case O_LLIMIT: 1362 if (argc != 2) { 1363 error("linelimit expects two arguments"); 1364 return; 1365 } 1366 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1367 , "_LLIMIT" ); 1368 ap = stklval(argv[1], NOFLAGS|NOUSE); 1369 if (ap == NIL) 1370 return; 1371 if (!text(ap)) { 1372 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1373 return; 1374 } 1375 al = argv[2]; 1376 ap = stkrval(al[1], NIL , RREQ ); 1377 if (ap == NIL) 1378 return; 1379 if (isnta(ap, "i")) { 1380 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1381 return; 1382 } 1383 putop( P2LISTOP , P2INT ); 1384 putop( P2CALL , P2INT ); 1385 putdot( filename , line ); 1386 return; 1387 case O_PAGE: 1388 if (argc != 1) { 1389 error("page expects one argument"); 1390 return; 1391 } 1392 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1393 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1394 , "_UNIT" ); 1395 ap = stklval(argv[1], NOFLAGS); 1396 if (ap == NIL) 1397 return; 1398 if (!text(ap)) { 1399 error("Argument to page must be a text file, not %s", nameof(ap)); 1400 return; 1401 } 1402 putop( P2CALL , P2INT ); 1403 putop( P2ASSIGN , P2PTR|P2STRTY ); 1404 putdot( filename , line ); 1405 if ( opt( 't' ) ) { 1406 putleaf( P2ICON , 0 , 0 1407 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1408 , "_PAGE" ); 1409 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1410 } else { 1411 putleaf( P2ICON , 0 , 0 1412 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1413 , "_fputc" ); 1414 putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 ); 1415 putleaf( P2ICON , 0 , 0 1416 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1417 , "_ACTFILE" ); 1418 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1419 putop( P2CALL , P2INT ); 1420 putop( P2LISTOP , P2INT ); 1421 } 1422 putop( P2CALL , P2INT ); 1423 putdot( filename , line ); 1424 return; 1425 1426 case O_ASRT: 1427 if (!opt('t')) 1428 return; 1429 if (argc == 0 || argc > 2) { 1430 error("Assert expects one or two arguments"); 1431 return; 1432 } 1433 if (argc == 2) 1434 cmd = "_ASRTS"; 1435 else 1436 cmd = "_ASRT"; 1437 putleaf( P2ICON , 0 , 0 1438 , ADDTYPE( P2FTN | P2INT , P2PTR ) , cmd ); 1439 ap = stkrval(argv[1], NIL , RREQ ); 1440 if (ap == NIL) 1441 return; 1442 if (isnta(ap, "b")) 1443 error("Assert expression must be Boolean, not %ss", nameof(ap)); 1444 if (argc == 2) { 1445 /* 1446 * Optional second argument is a string specifying 1447 * why the assertion failed. 1448 */ 1449 al = argv[2]; 1450 al = stkrval(al[1], NIL , RREQ ); 1451 if (al == NIL) 1452 return; 1453 if (classify(al) != TSTR) { 1454 error("Second argument to assert must be a string, not %s", nameof(al)); 1455 return; 1456 } 1457 putop( P2LISTOP , P2INT ); 1458 } 1459 putop( P2CALL , P2INT ); 1460 putdot( filename , line ); 1461 return; 1462 1463 case O_PACK: 1464 if (argc != 3) { 1465 error("pack expects three arguments"); 1466 return; 1467 } 1468 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1469 , "_PACK" ); 1470 pu = "pack(a,i,z)"; 1471 pua = (al = argv)[1]; 1472 pui = (al = al[2])[1]; 1473 puz = (al = al[2])[1]; 1474 goto packunp; 1475 case O_UNPACK: 1476 if (argc != 3) { 1477 error("unpack expects three arguments"); 1478 return; 1479 } 1480 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1481 , "_UNPACK" ); 1482 pu = "unpack(z,a,i)"; 1483 puz = (al = argv)[1]; 1484 pua = (al = al[2])[1]; 1485 pui = (al = al[2])[1]; 1486 packunp: 1487 ap = stkrval((int *) pui, NLNIL , RREQ ); 1488 if (ap == NIL) 1489 return; 1490 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1491 if (ap == NIL) 1492 return; 1493 if (ap->class != ARRAY) { 1494 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1495 return; 1496 } 1497 putop( P2LISTOP , P2INT ); 1498 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1499 if (al->class != ARRAY) { 1500 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1501 return; 1502 } 1503 if (al->type == NIL || ap->type == NIL) 1504 return; 1505 if (al->type != ap->type) { 1506 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1507 return; 1508 } 1509 putop( P2LISTOP , P2INT ); 1510 k = width(al); 1511 itemwidth = width(ap->type); 1512 ap = ap->chain; 1513 al = al->chain; 1514 if (ap->chain != NIL || al->chain != NIL) { 1515 error("%s requires a and z to be single dimension arrays", pu); 1516 return; 1517 } 1518 if (ap == NIL || al == NIL) 1519 return; 1520 /* 1521 * al is the range for z i.e. u..v 1522 * ap is the range for a i.e. m..n 1523 * i will be n-m+1 1524 * j will be v-u+1 1525 */ 1526 i = ap->range[1] - ap->range[0] + 1; 1527 j = al->range[1] - al->range[0] + 1; 1528 if (i < j) { 1529 error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1530 return; 1531 } 1532 /* 1533 * get n-m-(v-u) and m for the interpreter 1534 */ 1535 i -= j; 1536 j = ap->range[0]; 1537 putleaf( P2ICON , itemwidth , 0 , P2INT , 0 ); 1538 putop( P2LISTOP , P2INT ); 1539 putleaf( P2ICON , j , 0 , P2INT , 0 ); 1540 putop( P2LISTOP , P2INT ); 1541 putleaf( P2ICON , i , 0 , P2INT , 0 ); 1542 putop( P2LISTOP , P2INT ); 1543 putleaf( P2ICON , k , 0 , P2INT , 0 ); 1544 putop( P2LISTOP , P2INT ); 1545 putop( P2CALL , P2INT ); 1546 putdot( filename , line ); 1547 return; 1548 case 0: 1549 error("%s is an unimplemented extension", p->symbol); 1550 return; 1551 1552 default: 1553 panic("proc case"); 1554 } 1555 } 1556 #endif PC 1557