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