1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcproc.c 1.16 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 "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, ap); 389 sconv(p2type(ap), p2type(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 sconv(p2type(ap), 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, filetype); 1007 sconv(p2type(filetype), p2type(ap)); 1008 /* and fall through */ 1009 case TDOUBLE: 1010 case TPTR: 1011 putop( P2ASSIGN , p2type( ap ) ); 1012 putdot( filename , line ); 1013 break; 1014 default: 1015 putstrop( P2STASG 1016 , p2type( ap ) 1017 , lwidth( ap ) 1018 , align( ap ) ); 1019 putdot( filename , line ); 1020 break; 1021 } 1022 /* 1023 * get(file); 1024 */ 1025 putleaf( P2ICON , 0 , 0 1026 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1027 , "_GET" ); 1028 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1029 P2PTR|P2STRTY ); 1030 putop( P2CALL , P2INT ); 1031 putdot( filename , line ); 1032 continue; 1033 } 1034 /* 1035 * if you get to here, you are reading from 1036 * a text file. only possiblities are: 1037 * character, integer, real, or scalar. 1038 * read( f , foo , ... ) is done as 1039 * foo := read( f ) with rangechecking 1040 * if appropriate. 1041 */ 1042 typ = classify(ap); 1043 op = rdops(typ); 1044 if (op == NIL) { 1045 error("Can't read %ss from a text file", clnames[typ]); 1046 continue; 1047 } 1048 /* 1049 * left hand side of foo := read( f ) 1050 */ 1051 ap = lvalue( al , MOD|ASGN|NOUSE , RREQ ); 1052 if ( isa( ap , "bsci" ) ) { 1053 precheck( ap , "_RANG4" , "_RSNG4" ); 1054 } 1055 switch ( op ) { 1056 case O_READC: 1057 readname = "_READC"; 1058 readtype = P2INT; 1059 break; 1060 case O_READ4: 1061 readname = "_READ4"; 1062 readtype = P2INT; 1063 break; 1064 case O_READ8: 1065 readname = "_READ8"; 1066 readtype = P2DOUBLE; 1067 break; 1068 case O_READE: 1069 readname = "_READE"; 1070 readtype = P2INT; 1071 break; 1072 } 1073 putleaf( P2ICON , 0 , 0 1074 , ADDTYPE( P2FTN | readtype , P2PTR ) 1075 , readname ); 1076 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1077 P2PTR|P2STRTY ); 1078 if ( op == O_READE ) { 1079 sprintf( format , PREFIXFORMAT , LABELPREFIX 1080 , listnames( ap ) ); 1081 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 1082 , format ); 1083 putop( P2LISTOP , P2INT ); 1084 warning(); 1085 if (opt('s')) { 1086 standard(); 1087 } 1088 error("Reading scalars from text files is non-standard"); 1089 } 1090 putop( P2CALL , readtype ); 1091 if ( isa( ap , "bcsi" ) ) { 1092 postcheck(ap, readtype==P2INT?nl+T4INT:nl+TDOUBLE); 1093 } 1094 sconv(readtype, p2type(ap)); 1095 putop( P2ASSIGN , p2type( ap ) ); 1096 putdot( filename , line ); 1097 } 1098 /* 1099 * Done with arguments. 1100 * Handle readln and 1101 * insufficient number of args. 1102 */ 1103 if (p->value[0] == O_READLN) { 1104 if (filetype != nl+T1CHAR) 1105 error("Can't 'readln' a non text file"); 1106 putleaf( P2ICON , 0 , 0 1107 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1108 , "_READLN" ); 1109 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1110 P2PTR|P2STRTY ); 1111 putop( P2CALL , P2INT ); 1112 putdot( filename , line ); 1113 } else if (argc == 0) 1114 error("read requires an argument"); 1115 return; 1116 1117 case O_GET: 1118 case O_PUT: 1119 if (argc != 1) { 1120 error("%s expects one argument", p->symbol); 1121 return; 1122 } 1123 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1124 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1125 , "_UNIT" ); 1126 ap = stklval(argv[1], NOFLAGS); 1127 if (ap == NIL) 1128 return; 1129 if (ap->class != FILET) { 1130 error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1131 return; 1132 } 1133 putop( P2CALL , P2INT ); 1134 putop( P2ASSIGN , P2PTR|P2STRTY ); 1135 putdot( filename , line ); 1136 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1137 , op == O_GET ? "_GET" : "_PUT" ); 1138 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1139 putop( P2CALL , P2INT ); 1140 putdot( filename , line ); 1141 return; 1142 1143 case O_RESET: 1144 case O_REWRITE: 1145 if (argc == 0 || argc > 2) { 1146 error("%s expects one or two arguments", p->symbol); 1147 return; 1148 } 1149 if (opt('s') && argc == 2) { 1150 standard(); 1151 error("Two argument forms of reset and rewrite are non-standard"); 1152 } 1153 putleaf( P2ICON , 0 , 0 , P2INT 1154 , op == O_RESET ? "_RESET" : "_REWRITE" ); 1155 ap = stklval(argv[1], MOD|NOUSE); 1156 if (ap == NIL) 1157 return; 1158 if (ap->class != FILET) { 1159 error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1160 return; 1161 } 1162 if (argc == 2) { 1163 /* 1164 * Optional second argument 1165 * is a string name of a 1166 * UNIX (R) file to be associated. 1167 */ 1168 al = argv[2]; 1169 al = stkrval(al[1], NOFLAGS , RREQ ); 1170 if (al == NIL) 1171 return; 1172 if (classify(al) != TSTR) { 1173 error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); 1174 return; 1175 } 1176 strnglen = width(al); 1177 } else { 1178 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 1179 strnglen = 0; 1180 } 1181 putop( P2LISTOP , P2INT ); 1182 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 1183 putop( P2LISTOP , P2INT ); 1184 putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 ); 1185 putop( P2LISTOP , P2INT ); 1186 putop( P2CALL , P2INT ); 1187 putdot( filename , line ); 1188 return; 1189 1190 case O_NEW: 1191 case O_DISPOSE: 1192 if (argc == 0) { 1193 error("%s expects at least one argument", p->symbol); 1194 return; 1195 } 1196 alv = argv[1]; 1197 codeoff(); 1198 ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1199 codeon(); 1200 if (ap == NIL) 1201 return; 1202 if (ap->class != PTR) { 1203 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1204 return; 1205 } 1206 ap = ap->type; 1207 if (ap == NIL) 1208 return; 1209 if (op == O_NEW) 1210 cmd = "_NEW"; 1211 else /* op == O_DISPOSE */ 1212 if ((ap->nl_flags & NFILES) != 0) 1213 cmd = "_DFDISPOSE"; 1214 else 1215 cmd = "_DISPOSE"; 1216 putleaf( P2ICON, 0, 0, ADDTYPE( P2FTN | P2INT , P2PTR ), cmd); 1217 stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1218 argv = argv[2]; 1219 if (argv != NIL) { 1220 if (ap->class != RECORD) { 1221 error("Record required when specifying variant tags"); 1222 return; 1223 } 1224 for (; argv != NIL; argv = argv[2]) { 1225 if (ap->ptr[NL_VARNT] == NIL) { 1226 error("Too many tag fields"); 1227 return; 1228 } 1229 if (!isconst(argv[1])) { 1230 error("Second and successive arguments to %s must be constants", p->symbol); 1231 return; 1232 } 1233 gconst(argv[1]); 1234 if (con.ctype == NIL) 1235 return; 1236 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 1237 cerror("Specified tag constant type clashed with variant case selector type"); 1238 return; 1239 } 1240 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1241 if (ap->range[0] == con.crval) 1242 break; 1243 if (ap == NIL) { 1244 error("No variant case label value equals specified constant value"); 1245 return; 1246 } 1247 ap = ap->ptr[NL_VTOREC]; 1248 } 1249 } 1250 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1251 putop( P2LISTOP , P2INT ); 1252 putop( P2CALL , P2INT ); 1253 putdot( filename , line ); 1254 if (opt('t') && op == O_NEW) { 1255 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1256 , "_blkclr" ); 1257 stkrval(alv, NIL , RREQ ); 1258 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1259 putop( P2LISTOP , P2INT ); 1260 putop( P2CALL , P2INT ); 1261 putdot( filename , line ); 1262 } 1263 return; 1264 1265 case O_DATE: 1266 case O_TIME: 1267 if (argc != 1) { 1268 error("%s expects one argument", p->symbol); 1269 return; 1270 } 1271 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1272 , op == O_DATE ? "_DATE" : "_TIME" ); 1273 ap = stklval(argv[1], MOD|NOUSE); 1274 if (ap == NIL) 1275 return; 1276 if (classify(ap) != TSTR || width(ap) != 10) { 1277 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1278 return; 1279 } 1280 putop( P2CALL , P2INT ); 1281 putdot( filename , line ); 1282 return; 1283 1284 case O_HALT: 1285 if (argc != 0) { 1286 error("halt takes no arguments"); 1287 return; 1288 } 1289 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1290 , "_HALT" ); 1291 1292 putop( P2UNARY P2CALL , P2INT ); 1293 putdot( filename , line ); 1294 noreach = 1; 1295 return; 1296 1297 case O_ARGV: 1298 if (argc != 2) { 1299 error("argv takes two arguments"); 1300 return; 1301 } 1302 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1303 , "_ARGV" ); 1304 ap = stkrval(argv[1], NIL , RREQ ); 1305 if (ap == NIL) 1306 return; 1307 if (isnta(ap, "i")) { 1308 error("argv's first argument must be an integer, not %s", nameof(ap)); 1309 return; 1310 } 1311 al = argv[2]; 1312 ap = stklval(al[1], MOD|NOUSE); 1313 if (ap == NIL) 1314 return; 1315 if (classify(ap) != TSTR) { 1316 error("argv's second argument must be a string, not %s", nameof(ap)); 1317 return; 1318 } 1319 putop( P2LISTOP , P2INT ); 1320 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1321 putop( P2LISTOP , P2INT ); 1322 putop( P2CALL , P2INT ); 1323 putdot( filename , line ); 1324 return; 1325 1326 case O_STLIM: 1327 if (argc != 1) { 1328 error("stlimit requires one argument"); 1329 return; 1330 } 1331 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1332 , "_STLIM" ); 1333 ap = stkrval(argv[1], NIL , RREQ ); 1334 if (ap == NIL) 1335 return; 1336 if (isnta(ap, "i")) { 1337 error("stlimit's argument must be an integer, not %s", nameof(ap)); 1338 return; 1339 } 1340 putop( P2CALL , P2INT ); 1341 putdot( filename , line ); 1342 return; 1343 1344 case O_REMOVE: 1345 if (argc != 1) { 1346 error("remove expects one argument"); 1347 return; 1348 } 1349 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1350 , "_REMOVE" ); 1351 ap = stkrval(argv[1], NOFLAGS , RREQ ); 1352 if (ap == NIL) 1353 return; 1354 if (classify(ap) != TSTR) { 1355 error("remove's argument must be a string, not %s", nameof(ap)); 1356 return; 1357 } 1358 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1359 putop( P2LISTOP , P2INT ); 1360 putop( P2CALL , P2INT ); 1361 putdot( filename , line ); 1362 return; 1363 1364 case O_LLIMIT: 1365 if (argc != 2) { 1366 error("linelimit expects two arguments"); 1367 return; 1368 } 1369 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1370 , "_LLIMIT" ); 1371 ap = stklval(argv[1], NOFLAGS|NOUSE); 1372 if (ap == NIL) 1373 return; 1374 if (!text(ap)) { 1375 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1376 return; 1377 } 1378 al = argv[2]; 1379 ap = stkrval(al[1], NIL , RREQ ); 1380 if (ap == NIL) 1381 return; 1382 if (isnta(ap, "i")) { 1383 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1384 return; 1385 } 1386 putop( P2LISTOP , P2INT ); 1387 putop( P2CALL , P2INT ); 1388 putdot( filename , line ); 1389 return; 1390 case O_PAGE: 1391 if (argc != 1) { 1392 error("page expects one argument"); 1393 return; 1394 } 1395 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1396 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1397 , "_UNIT" ); 1398 ap = stklval(argv[1], NOFLAGS); 1399 if (ap == NIL) 1400 return; 1401 if (!text(ap)) { 1402 error("Argument to page must be a text file, not %s", nameof(ap)); 1403 return; 1404 } 1405 putop( P2CALL , P2INT ); 1406 putop( P2ASSIGN , P2PTR|P2STRTY ); 1407 putdot( filename , line ); 1408 if ( opt( 't' ) ) { 1409 putleaf( P2ICON , 0 , 0 1410 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1411 , "_PAGE" ); 1412 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1413 } else { 1414 putleaf( P2ICON , 0 , 0 1415 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1416 , "_fputc" ); 1417 putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 ); 1418 putleaf( P2ICON , 0 , 0 1419 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1420 , "_ACTFILE" ); 1421 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1422 putop( P2CALL , P2INT ); 1423 putop( P2LISTOP , P2INT ); 1424 } 1425 putop( P2CALL , P2INT ); 1426 putdot( filename , line ); 1427 return; 1428 1429 case O_ASRT: 1430 if (!opt('t')) 1431 return; 1432 if (argc == 0 || argc > 2) { 1433 error("Assert expects one or two arguments"); 1434 return; 1435 } 1436 if (argc == 2) 1437 cmd = "_ASRTS"; 1438 else 1439 cmd = "_ASRT"; 1440 putleaf( P2ICON , 0 , 0 1441 , ADDTYPE( P2FTN | P2INT , P2PTR ) , cmd ); 1442 ap = stkrval(argv[1], NIL , RREQ ); 1443 if (ap == NIL) 1444 return; 1445 if (isnta(ap, "b")) 1446 error("Assert expression must be Boolean, not %ss", nameof(ap)); 1447 if (argc == 2) { 1448 /* 1449 * Optional second argument is a string specifying 1450 * why the assertion failed. 1451 */ 1452 al = argv[2]; 1453 al = stkrval(al[1], NIL , RREQ ); 1454 if (al == NIL) 1455 return; 1456 if (classify(al) != TSTR) { 1457 error("Second argument to assert must be a string, not %s", nameof(al)); 1458 return; 1459 } 1460 putop( P2LISTOP , P2INT ); 1461 } 1462 putop( P2CALL , P2INT ); 1463 putdot( filename , line ); 1464 return; 1465 1466 case O_PACK: 1467 if (argc != 3) { 1468 error("pack expects three arguments"); 1469 return; 1470 } 1471 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1472 , "_PACK" ); 1473 pu = "pack(a,i,z)"; 1474 pua = (al = argv)[1]; 1475 pui = (al = al[2])[1]; 1476 puz = (al = al[2])[1]; 1477 goto packunp; 1478 case O_UNPACK: 1479 if (argc != 3) { 1480 error("unpack expects three arguments"); 1481 return; 1482 } 1483 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1484 , "_UNPACK" ); 1485 pu = "unpack(z,a,i)"; 1486 puz = (al = argv)[1]; 1487 pua = (al = al[2])[1]; 1488 pui = (al = al[2])[1]; 1489 packunp: 1490 ap = stkrval((int *) pui, NLNIL , RREQ ); 1491 if (ap == NIL) 1492 return; 1493 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1494 if (ap == NIL) 1495 return; 1496 if (ap->class != ARRAY) { 1497 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1498 return; 1499 } 1500 putop( P2LISTOP , P2INT ); 1501 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1502 if (al->class != ARRAY) { 1503 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1504 return; 1505 } 1506 if (al->type == NIL || ap->type == NIL) 1507 return; 1508 if (al->type != ap->type) { 1509 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1510 return; 1511 } 1512 putop( P2LISTOP , P2INT ); 1513 k = width(al); 1514 itemwidth = width(ap->type); 1515 ap = ap->chain; 1516 al = al->chain; 1517 if (ap->chain != NIL || al->chain != NIL) { 1518 error("%s requires a and z to be single dimension arrays", pu); 1519 return; 1520 } 1521 if (ap == NIL || al == NIL) 1522 return; 1523 /* 1524 * al is the range for z i.e. u..v 1525 * ap is the range for a i.e. m..n 1526 * i will be n-m+1 1527 * j will be v-u+1 1528 */ 1529 i = ap->range[1] - ap->range[0] + 1; 1530 j = al->range[1] - al->range[0] + 1; 1531 if (i < j) { 1532 error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1533 return; 1534 } 1535 /* 1536 * get n-m-(v-u) and m for the interpreter 1537 */ 1538 i -= j; 1539 j = ap->range[0]; 1540 putleaf( P2ICON , itemwidth , 0 , P2INT , 0 ); 1541 putop( P2LISTOP , P2INT ); 1542 putleaf( P2ICON , j , 0 , P2INT , 0 ); 1543 putop( P2LISTOP , P2INT ); 1544 putleaf( P2ICON , i , 0 , P2INT , 0 ); 1545 putop( P2LISTOP , P2INT ); 1546 putleaf( P2ICON , k , 0 , P2INT , 0 ); 1547 putop( P2LISTOP , P2INT ); 1548 putop( P2CALL , P2INT ); 1549 putdot( filename , line ); 1550 return; 1551 case 0: 1552 error("%s is an unimplemented extension", p->symbol); 1553 return; 1554 1555 default: 1556 panic("proc case"); 1557 } 1558 } 1559 #endif PC 1560