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