1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcproc.c 1.17 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, ap); 390 sconv(p2type(ap), p2type(filetype)); 391 /* and fall through */ 392 case TDOUBLE: 393 case TPTR: 394 putop( P2ASSIGN , p2type( filetype ) ); 395 putdot( filename , line ); 396 break; 397 default: 398 putstrop( P2STASG 399 , p2type( filetype ) 400 , lwidth( filetype ) 401 , align( filetype ) ); 402 putdot( filename , line ); 403 break; 404 } 405 /* 406 * put(file) 407 */ 408 putleaf( P2ICON , 0 , 0 409 , ADDTYPE( P2FTN | P2INT , P2PTR ) 410 , "_PUT" ); 411 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 412 P2PTR|P2STRTY ); 413 putop( P2CALL , P2INT ); 414 putdot( filename , line ); 415 continue; 416 } 417 /* 418 * Write to a textfile 419 * 420 * Evaluate the expression 421 * to be written. 422 */ 423 if (fmt == 'O' || fmt == 'X') { 424 if (opt('s')) { 425 standard(); 426 error("Oct and hex are non-standard"); 427 } 428 if (typ == TSTR || typ == TDOUBLE) { 429 error("Can't write %ss with oct/hex", clnames[typ]); 430 continue; 431 } 432 if (typ == TCHAR || typ == TBOOL) 433 typ = TINT; 434 } 435 /* 436 * If there is no format specified by the programmer, 437 * implement the default. 438 */ 439 switch (typ) { 440 case TPTR: 441 warning(); 442 if (opt('s')) { 443 standard(); 444 } 445 error("Writing %ss to text files is non-standard", 446 clnames[typ]); 447 /* and fall through */ 448 case TINT: 449 if (fmt == 'f') { 450 typ = TDOUBLE; 451 goto tdouble; 452 } 453 if (fmtspec == NIL) { 454 if (fmt == 'D') 455 field = 10; 456 else if (fmt == 'X') 457 field = 8; 458 else if (fmt == 'O') 459 field = 11; 460 else 461 panic("fmt1"); 462 fmtspec = CONWIDTH; 463 } 464 break; 465 case TCHAR: 466 tchar: 467 fmt = 'c'; 468 break; 469 case TSCAL: 470 warning(); 471 if (opt('s')) { 472 standard(); 473 } 474 error("Writing %ss to text files is non-standard", 475 clnames[typ]); 476 case TBOOL: 477 fmt = 's'; 478 break; 479 case TDOUBLE: 480 tdouble: 481 switch (fmtspec) { 482 case NIL: 483 field = 21; 484 prec = 14; 485 fmt = 'e'; 486 fmtspec = CONWIDTH + CONPREC; 487 break; 488 case CONWIDTH: 489 field -= REALSPC; 490 if (field < 1) 491 field = 1; 492 prec = field - 7; 493 if (prec < 1) 494 prec = 1; 495 fmtspec += CONPREC; 496 fmt = 'e'; 497 break; 498 case VARWIDTH: 499 fmtspec += VARPREC; 500 fmt = 'e'; 501 break; 502 case CONWIDTH + CONPREC: 503 case CONWIDTH + VARPREC: 504 field -= REALSPC; 505 if (field < 1) 506 field = 1; 507 } 508 format[0] = ' '; 509 fmtstart = 1 - REALSPC; 510 break; 511 case TSTR: 512 constval( alv ); 513 switch ( classify( con.ctype ) ) { 514 case TCHAR: 515 typ = TCHAR; 516 goto tchar; 517 case TSTR: 518 strptr = con.cpval; 519 for (strnglen = 0; *strptr++; strnglen++) /* void */; 520 strptr = con.cpval; 521 break; 522 default: 523 strnglen = width(ap); 524 break; 525 } 526 fmt = 's'; 527 strfmt = fmtspec; 528 if (fmtspec == NIL) { 529 fmtspec = SKIP; 530 break; 531 } 532 if (fmtspec & CONWIDTH) { 533 if (field <= strnglen) 534 fmtspec = SKIP; 535 else 536 field -= strnglen; 537 } 538 break; 539 default: 540 error("Can't write %ss to a text file", clnames[typ]); 541 continue; 542 } 543 /* 544 * Generate the format string 545 */ 546 switch (fmtspec) { 547 default: 548 panic("fmt2"); 549 case NIL: 550 if (fmt == 'c') { 551 if ( opt( 't' ) ) { 552 putleaf( P2ICON , 0 , 0 553 , ADDTYPE( P2FTN|P2INT , P2PTR ) 554 , "_WRITEC" ); 555 putRV( 0 , cbn , CURFILEOFFSET , 556 NLOCAL , P2PTR|P2STRTY ); 557 stkrval( alv , NIL , RREQ ); 558 putop( P2LISTOP , P2INT ); 559 } else { 560 putleaf( P2ICON , 0 , 0 561 , ADDTYPE( P2FTN|P2INT , P2PTR ) 562 , "_fputc" ); 563 stkrval( alv , NIL , RREQ ); 564 } 565 putleaf( P2ICON , 0 , 0 566 , ADDTYPE( P2FTN | P2INT , P2PTR ) 567 , "_ACTFILE" ); 568 putRV( 0, cbn , CURFILEOFFSET , 569 NLOCAL , P2PTR|P2STRTY ); 570 putop( P2CALL , P2INT ); 571 putop( P2LISTOP , P2INT ); 572 putop( P2CALL , P2INT ); 573 putdot( filename , line ); 574 } else { 575 sprintf(&format[1], "%%%c", fmt); 576 goto fmtgen; 577 } 578 case SKIP: 579 break; 580 case CONWIDTH: 581 sprintf(&format[1], "%%%1D%c", field, fmt); 582 goto fmtgen; 583 case VARWIDTH: 584 sprintf(&format[1], "%%*%c", fmt); 585 goto fmtgen; 586 case CONWIDTH + CONPREC: 587 sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt); 588 goto fmtgen; 589 case CONWIDTH + VARPREC: 590 sprintf(&format[1], "%%%1D.*%c", field, fmt); 591 goto fmtgen; 592 case VARWIDTH + CONPREC: 593 sprintf(&format[1], "%%*.%1D%c", prec, fmt); 594 goto fmtgen; 595 case VARWIDTH + VARPREC: 596 sprintf(&format[1], "%%*.*%c", fmt); 597 fmtgen: 598 if ( opt( 't' ) ) { 599 putleaf( P2ICON , 0 , 0 600 , ADDTYPE( P2FTN | P2INT , P2PTR ) 601 , "_WRITEF" ); 602 putRV( 0 , cbn , CURFILEOFFSET , 603 NLOCAL , P2PTR|P2STRTY ); 604 putleaf( P2ICON , 0 , 0 605 , ADDTYPE( P2FTN | P2INT , P2PTR ) 606 , "_ACTFILE" ); 607 putRV( 0 , cbn , CURFILEOFFSET , 608 NLOCAL , P2PTR|P2STRTY ); 609 putop( P2CALL , P2INT ); 610 putop( P2LISTOP , P2INT ); 611 } else { 612 putleaf( P2ICON , 0 , 0 613 , ADDTYPE( P2FTN | P2INT , P2PTR ) 614 , "_fprintf" ); 615 putleaf( P2ICON , 0 , 0 616 , ADDTYPE( P2FTN | P2INT , P2PTR ) 617 , "_ACTFILE" ); 618 putRV( 0 , cbn , CURFILEOFFSET , 619 NLOCAL , P2PTR|P2STRTY ); 620 putop( P2CALL , P2INT ); 621 } 622 putCONG( &format[ fmtstart ] 623 , strlen( &format[ fmtstart ] ) 624 , LREQ ); 625 putop( P2LISTOP , P2INT ); 626 if ( fmtspec & VARWIDTH ) { 627 /* 628 * either 629 * ,(temp=width,MAX(temp,...)), 630 * or 631 * , MAX( width , ... ) , 632 */ 633 if ( ( typ == TDOUBLE && al[3] == NIL ) 634 || typ == TSTR ) { 635 soffset = sizes[cbn].curtmps; 636 tempnlp = tmpalloc(sizeof(long), 637 nl+T4INT, REGOK); 638 putRV( 0 , cbn , 639 tempnlp -> value[ NL_OFFS ] , 640 tempnlp -> extra_flags , P2INT ); 641 ap = stkrval( al[2] , NIL , RREQ ); 642 putop( P2ASSIGN , P2INT ); 643 putleaf( P2ICON , 0 , 0 644 , ADDTYPE( P2FTN | P2INT , P2PTR ) 645 , "_MAX" ); 646 putRV( 0 , cbn , 647 tempnlp -> value[ NL_OFFS ] , 648 tempnlp -> extra_flags , P2INT ); 649 } else { 650 if (opt('t') 651 || typ == TSTR || typ == TDOUBLE) { 652 putleaf( P2ICON , 0 , 0 653 ,ADDTYPE( P2FTN | P2INT, P2PTR ) 654 ,"_MAX" ); 655 } 656 ap = stkrval( al[2] , NIL , RREQ ); 657 } 658 if (ap == NIL) 659 continue; 660 if (isnta(ap,"i")) { 661 error("First write width must be integer, not %s", nameof(ap)); 662 continue; 663 } 664 switch ( typ ) { 665 case TDOUBLE: 666 putleaf( P2ICON , REALSPC , 0 , P2INT , 0 ); 667 putop( P2LISTOP , P2INT ); 668 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 669 putop( P2LISTOP , P2INT ); 670 putop( P2CALL , P2INT ); 671 if ( al[3] == NIL ) { 672 /* 673 * finish up the comma op 674 */ 675 putop( P2COMOP , P2INT ); 676 fmtspec &= ~VARPREC; 677 putop( P2LISTOP , P2INT ); 678 putleaf( P2ICON , 0 , 0 679 , ADDTYPE( P2FTN | P2INT , P2PTR ) 680 , "_MAX" ); 681 putRV( 0 , cbn , 682 tempnlp -> value[ NL_OFFS ] , 683 tempnlp -> extra_flags , 684 P2INT ); 685 tmpfree(&soffset); 686 putleaf( P2ICON , 7 + REALSPC , 0 , P2INT , 0 ); 687 putop( P2LISTOP , P2INT ); 688 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 689 putop( P2LISTOP , P2INT ); 690 putop( P2CALL , P2INT ); 691 } 692 putop( P2LISTOP , P2INT ); 693 break; 694 case TSTR: 695 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 696 putop( P2LISTOP , P2INT ); 697 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 698 putop( P2LISTOP , P2INT ); 699 putop( P2CALL , P2INT ); 700 putop( P2COMOP , P2INT ); 701 putop( P2LISTOP , P2INT ); 702 break; 703 default: 704 if (opt('t')) { 705 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 706 putop( P2LISTOP , P2INT ); 707 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 708 putop( P2LISTOP , P2INT ); 709 putop( P2CALL , P2INT ); 710 } 711 putop( P2LISTOP , P2INT ); 712 break; 713 } 714 } 715 /* 716 * If there is a variable precision, 717 * evaluate it 718 */ 719 if (fmtspec & VARPREC) { 720 if (opt('t')) { 721 putleaf( P2ICON , 0 , 0 722 , ADDTYPE( P2FTN | P2INT , P2PTR ) 723 , "_MAX" ); 724 } 725 ap = stkrval( al[3] , NIL , RREQ ); 726 if (ap == NIL) 727 continue; 728 if (isnta(ap,"i")) { 729 error("Second write width must be integer, not %s", nameof(ap)); 730 continue; 731 } 732 if (opt('t')) { 733 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 734 putop( P2LISTOP , P2INT ); 735 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 736 putop( P2LISTOP , P2INT ); 737 putop( P2CALL , P2INT ); 738 } 739 putop( P2LISTOP , P2INT ); 740 } 741 /* 742 * evaluate the thing we want printed. 743 */ 744 switch ( typ ) { 745 case TPTR: 746 case TCHAR: 747 case TINT: 748 stkrval( alv , NIL , RREQ ); 749 putop( P2LISTOP , P2INT ); 750 break; 751 case TDOUBLE: 752 ap = stkrval( alv , NIL , RREQ ); 753 if (isnta(ap, "d")) { 754 sconv(p2type(ap), P2DOUBLE); 755 } 756 putop( P2LISTOP , P2INT ); 757 break; 758 case TSCAL: 759 case TBOOL: 760 putleaf( P2ICON , 0 , 0 761 , ADDTYPE( P2FTN | P2INT , P2PTR ) 762 , "_NAM" ); 763 ap = stkrval( alv , NIL , RREQ ); 764 sprintf( format , PREFIXFORMAT , LABELPREFIX 765 , listnames( ap ) ); 766 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 767 , format ); 768 putop( P2LISTOP , P2INT ); 769 putop( P2CALL , P2INT ); 770 putop( P2LISTOP , P2INT ); 771 break; 772 case TSTR: 773 putCONG( "" , 0 , LREQ ); 774 putop( P2LISTOP , P2INT ); 775 break; 776 default: 777 panic("fmt3"); 778 break; 779 } 780 putop( P2CALL , P2INT ); 781 putdot( filename , line ); 782 } 783 /* 784 * Write the string after its blank padding 785 */ 786 if (typ == TSTR ) { 787 if ( opt( 't' ) ) { 788 putleaf( P2ICON , 0 , 0 789 , ADDTYPE( P2FTN | P2INT , P2PTR ) 790 , "_WRITES" ); 791 putRV( 0 , cbn , CURFILEOFFSET , 792 NLOCAL , P2PTR|P2STRTY ); 793 ap = stkrval(alv, NIL , RREQ ); 794 putop( P2LISTOP , P2INT ); 795 } else { 796 putleaf( P2ICON , 0 , 0 797 , ADDTYPE( P2FTN | P2INT , P2PTR ) 798 , "_fwrite" ); 799 ap = stkrval(alv, NIL , RREQ ); 800 } 801 if (strfmt & VARWIDTH) { 802 /* 803 * min, inline expanded as 804 * temp < len ? temp : len 805 */ 806 putRV( 0 , cbn , 807 tempnlp -> value[ NL_OFFS ] , 808 tempnlp -> extra_flags , P2INT ); 809 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 810 putop( P2LT , P2INT ); 811 putRV( 0 , cbn , 812 tempnlp -> value[ NL_OFFS ] , 813 tempnlp -> extra_flags , P2INT ); 814 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 815 putop( P2COLON , P2INT ); 816 putop( P2QUEST , P2INT ); 817 tmpfree(&soffset); 818 } else { 819 if ( ( fmtspec & SKIP ) 820 && ( strfmt & CONWIDTH ) ) { 821 strnglen = field; 822 } 823 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 824 } 825 putop( P2LISTOP , P2INT ); 826 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 827 putop( P2LISTOP , P2INT ); 828 putleaf( P2ICON , 0 , 0 829 , ADDTYPE( P2FTN | P2INT , P2PTR ) 830 , "_ACTFILE" ); 831 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 832 P2PTR|P2STRTY ); 833 putop( P2CALL , P2INT ); 834 putop( P2LISTOP , P2INT ); 835 putop( P2CALL , P2INT ); 836 putdot( filename , line ); 837 } 838 } 839 /* 840 * Done with arguments. 841 * Handle writeln and 842 * insufficent number of args. 843 */ 844 switch (p->value[0] &~ NSTAND) { 845 case O_WRITEF: 846 if (argc == 0) 847 error("Write requires an argument"); 848 break; 849 case O_MESSAGE: 850 if (argc == 0) 851 error("Message requires an argument"); 852 case O_WRITLN: 853 if (filetype != nl+T1CHAR) 854 error("Can't 'writeln' a non text file"); 855 if ( opt( 't' ) ) { 856 putleaf( P2ICON , 0 , 0 857 , ADDTYPE( P2FTN | P2INT , P2PTR ) 858 , "_WRITLN" ); 859 putRV( 0 , cbn , CURFILEOFFSET , 860 NLOCAL , P2PTR|P2STRTY ); 861 } else { 862 putleaf( P2ICON , 0 , 0 863 , ADDTYPE( P2FTN | P2INT , P2PTR ) 864 , "_fputc" ); 865 putleaf( P2ICON , '\n' , 0 , P2CHAR , 0 ); 866 putleaf( P2ICON , 0 , 0 867 , ADDTYPE( P2FTN | P2INT , P2PTR ) 868 , "_ACTFILE" ); 869 putRV( 0 , cbn , CURFILEOFFSET , 870 NLOCAL , P2PTR|P2STRTY ); 871 putop( P2CALL , P2INT ); 872 putop( P2LISTOP , P2INT ); 873 } 874 putop( P2CALL , P2INT ); 875 putdot( filename , line ); 876 break; 877 } 878 return; 879 880 case O_READ4: 881 case O_READLN: 882 /* 883 * Set up default 884 * file "input". 885 */ 886 file = NIL; 887 filetype = nl+T1CHAR; 888 /* 889 * Determine the file implied 890 * for the read and generate 891 * code to make it the active file. 892 */ 893 if (argv != NIL) { 894 codeoff(); 895 ap = stkrval(argv[1], NIL , RREQ ); 896 codeon(); 897 if (ap == NIL) 898 argv = argv[2]; 899 if (ap != NIL && ap->class == FILET) { 900 /* 901 * Got "read(f, ...", make 902 * f the active file, and save 903 * it and its type for use in 904 * processing the rest of the 905 * arguments to read. 906 */ 907 file = argv[1]; 908 filetype = ap->type; 909 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 910 P2PTR|P2STRTY ); 911 putleaf( P2ICON , 0 , 0 912 , ADDTYPE( P2FTN | P2INT , P2PTR ) 913 , "_UNIT" ); 914 stklval(argv[1], NOFLAGS); 915 putop( P2CALL , P2INT ); 916 putop( P2ASSIGN , P2PTR|P2STRTY ); 917 putdot( filename , line ); 918 argv = argv[2]; 919 argc--; 920 } else { 921 /* 922 * Default is read from 923 * standard input. 924 */ 925 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 926 P2PTR|P2STRTY ); 927 putLV( "_input" , 0 , 0 , NGLOBAL , 928 P2PTR|P2STRTY ); 929 putop( P2ASSIGN , P2PTR|P2STRTY ); 930 putdot( filename , line ); 931 input->nl_flags |= NUSED; 932 } 933 } else { 934 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 935 P2PTR|P2STRTY ); 936 putLV( "_input" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 937 putop( P2ASSIGN , P2PTR|P2STRTY ); 938 putdot( filename , line ); 939 input->nl_flags |= NUSED; 940 } 941 /* 942 * Loop and process each 943 * of the arguments. 944 */ 945 for (; argv != NIL; argv = argv[2]) { 946 /* 947 * Get the address of the target 948 * on the stack. 949 */ 950 al = argv[1]; 951 if (al == NIL) 952 continue; 953 if (al[0] != T_VAR) { 954 error("Arguments to %s must be variables, not expressions", p->symbol); 955 continue; 956 } 957 codeoff(); 958 ap = stklval(al, MOD|ASGN|NOUSE); 959 codeon(); 960 if (ap == NIL) 961 continue; 962 if (filetype != nl+T1CHAR) { 963 /* 964 * Generalized read, i.e. 965 * from a non-textfile. 966 */ 967 if (incompat(filetype, ap, argv[1] )) { 968 error("Type mismatch in read from non-text file"); 969 continue; 970 } 971 /* 972 * var := file ^; 973 */ 974 ap = lvalue( al , MOD | ASGN | NOUSE , RREQ ); 975 if ( isa( ap , "bsci" ) ) { 976 precheck( ap , "_RANG4" , "_RSNG4" ); 977 } 978 putleaf( P2ICON , 0 , 0 979 , ADDTYPE( 980 ADDTYPE( 981 ADDTYPE( 982 p2type( filetype ) , P2PTR ) 983 , P2FTN ) 984 , P2PTR ) 985 , "_FNIL" ); 986 if (file != NIL) 987 stklval(file, NOFLAGS); 988 else /* Magic */ 989 putRV( "_input" , 0 , 0 , NGLOBAL , 990 P2PTR | P2STRTY ); 991 putop( P2CALL , P2INT ); 992 switch ( classify( filetype ) ) { 993 case TBOOL: 994 case TCHAR: 995 case TINT: 996 case TSCAL: 997 case TDOUBLE: 998 case TPTR: 999 putop( P2UNARY P2MUL 1000 , p2type( filetype ) ); 1001 } 1002 switch ( classify( filetype ) ) { 1003 case TBOOL: 1004 case TCHAR: 1005 case TINT: 1006 case TSCAL: 1007 postcheck(ap, filetype); 1008 sconv(p2type(filetype), p2type(ap)); 1009 /* and fall through */ 1010 case TDOUBLE: 1011 case TPTR: 1012 putop( P2ASSIGN , p2type( ap ) ); 1013 putdot( filename , line ); 1014 break; 1015 default: 1016 putstrop( P2STASG 1017 , p2type( ap ) 1018 , lwidth( ap ) 1019 , align( ap ) ); 1020 putdot( filename , line ); 1021 break; 1022 } 1023 /* 1024 * get(file); 1025 */ 1026 putleaf( P2ICON , 0 , 0 1027 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1028 , "_GET" ); 1029 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1030 P2PTR|P2STRTY ); 1031 putop( P2CALL , P2INT ); 1032 putdot( filename , line ); 1033 continue; 1034 } 1035 /* 1036 * if you get to here, you are reading from 1037 * a text file. only possiblities are: 1038 * character, integer, real, or scalar. 1039 * read( f , foo , ... ) is done as 1040 * foo := read( f ) with rangechecking 1041 * if appropriate. 1042 */ 1043 typ = classify(ap); 1044 op = rdops(typ); 1045 if (op == NIL) { 1046 error("Can't read %ss from a text file", clnames[typ]); 1047 continue; 1048 } 1049 /* 1050 * left hand side of foo := read( f ) 1051 */ 1052 ap = lvalue( al , MOD|ASGN|NOUSE , RREQ ); 1053 if ( isa( ap , "bsci" ) ) { 1054 precheck( ap , "_RANG4" , "_RSNG4" ); 1055 } 1056 switch ( op ) { 1057 case O_READC: 1058 readname = "_READC"; 1059 readtype = P2INT; 1060 break; 1061 case O_READ4: 1062 readname = "_READ4"; 1063 readtype = P2INT; 1064 break; 1065 case O_READ8: 1066 readname = "_READ8"; 1067 readtype = P2DOUBLE; 1068 break; 1069 case O_READE: 1070 readname = "_READE"; 1071 readtype = P2INT; 1072 break; 1073 } 1074 putleaf( P2ICON , 0 , 0 1075 , ADDTYPE( P2FTN | readtype , P2PTR ) 1076 , readname ); 1077 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1078 P2PTR|P2STRTY ); 1079 if ( op == O_READE ) { 1080 sprintf( format , PREFIXFORMAT , LABELPREFIX 1081 , listnames( ap ) ); 1082 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 1083 , format ); 1084 putop( P2LISTOP , P2INT ); 1085 warning(); 1086 if (opt('s')) { 1087 standard(); 1088 } 1089 error("Reading scalars from text files is non-standard"); 1090 } 1091 putop( P2CALL , readtype ); 1092 if ( isa( ap , "bcsi" ) ) { 1093 postcheck(ap, readtype==P2INT?nl+T4INT:nl+TDOUBLE); 1094 } 1095 sconv(readtype, p2type(ap)); 1096 putop( P2ASSIGN , p2type( ap ) ); 1097 putdot( filename , line ); 1098 } 1099 /* 1100 * Done with arguments. 1101 * Handle readln and 1102 * insufficient number of args. 1103 */ 1104 if (p->value[0] == O_READLN) { 1105 if (filetype != nl+T1CHAR) 1106 error("Can't 'readln' a non text file"); 1107 putleaf( P2ICON , 0 , 0 1108 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1109 , "_READLN" ); 1110 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1111 P2PTR|P2STRTY ); 1112 putop( P2CALL , P2INT ); 1113 putdot( filename , line ); 1114 } else if (argc == 0) 1115 error("read requires an argument"); 1116 return; 1117 1118 case O_GET: 1119 case O_PUT: 1120 if (argc != 1) { 1121 error("%s expects one argument", p->symbol); 1122 return; 1123 } 1124 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1125 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1126 , "_UNIT" ); 1127 ap = stklval(argv[1], NOFLAGS); 1128 if (ap == NIL) 1129 return; 1130 if (ap->class != FILET) { 1131 error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1132 return; 1133 } 1134 putop( P2CALL , P2INT ); 1135 putop( P2ASSIGN , P2PTR|P2STRTY ); 1136 putdot( filename , line ); 1137 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1138 , op == O_GET ? "_GET" : "_PUT" ); 1139 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1140 putop( P2CALL , P2INT ); 1141 putdot( filename , line ); 1142 return; 1143 1144 case O_RESET: 1145 case O_REWRITE: 1146 if (argc == 0 || argc > 2) { 1147 error("%s expects one or two arguments", p->symbol); 1148 return; 1149 } 1150 if (opt('s') && argc == 2) { 1151 standard(); 1152 error("Two argument forms of reset and rewrite are non-standard"); 1153 } 1154 putleaf( P2ICON , 0 , 0 , P2INT 1155 , op == O_RESET ? "_RESET" : "_REWRITE" ); 1156 ap = stklval(argv[1], MOD|NOUSE); 1157 if (ap == NIL) 1158 return; 1159 if (ap->class != FILET) { 1160 error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1161 return; 1162 } 1163 if (argc == 2) { 1164 /* 1165 * Optional second argument 1166 * is a string name of a 1167 * UNIX (R) file to be associated. 1168 */ 1169 al = argv[2]; 1170 al = stkrval(al[1], NOFLAGS , RREQ ); 1171 if (al == NIL) 1172 return; 1173 if (classify(al) != TSTR) { 1174 error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); 1175 return; 1176 } 1177 strnglen = width(al); 1178 } else { 1179 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 1180 strnglen = 0; 1181 } 1182 putop( P2LISTOP , P2INT ); 1183 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 1184 putop( P2LISTOP , P2INT ); 1185 putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 ); 1186 putop( P2LISTOP , P2INT ); 1187 putop( P2CALL , P2INT ); 1188 putdot( filename , line ); 1189 return; 1190 1191 case O_NEW: 1192 case O_DISPOSE: 1193 if (argc == 0) { 1194 error("%s expects at least one argument", p->symbol); 1195 return; 1196 } 1197 alv = argv[1]; 1198 codeoff(); 1199 ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1200 codeon(); 1201 if (ap == NIL) 1202 return; 1203 if (ap->class != PTR) { 1204 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1205 return; 1206 } 1207 ap = ap->type; 1208 if (ap == NIL) 1209 return; 1210 if (op == O_NEW) 1211 cmd = "_NEW"; 1212 else /* op == O_DISPOSE */ 1213 if ((ap->nl_flags & NFILES) != 0) 1214 cmd = "_DFDISPOSE"; 1215 else 1216 cmd = "_DISPOSE"; 1217 putleaf( P2ICON, 0, 0, ADDTYPE( P2FTN | P2INT , P2PTR ), cmd); 1218 stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1219 argv = argv[2]; 1220 if (argv != NIL) { 1221 if (ap->class != RECORD) { 1222 error("Record required when specifying variant tags"); 1223 return; 1224 } 1225 for (; argv != NIL; argv = argv[2]) { 1226 if (ap->ptr[NL_VARNT] == NIL) { 1227 error("Too many tag fields"); 1228 return; 1229 } 1230 if (!isconst(argv[1])) { 1231 error("Second and successive arguments to %s must be constants", p->symbol); 1232 return; 1233 } 1234 gconst(argv[1]); 1235 if (con.ctype == NIL) 1236 return; 1237 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 1238 cerror("Specified tag constant type clashed with variant case selector type"); 1239 return; 1240 } 1241 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1242 if (ap->range[0] == con.crval) 1243 break; 1244 if (ap == NIL) { 1245 error("No variant case label value equals specified constant value"); 1246 return; 1247 } 1248 ap = ap->ptr[NL_VTOREC]; 1249 } 1250 } 1251 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1252 putop( P2LISTOP , P2INT ); 1253 putop( P2CALL , P2INT ); 1254 putdot( filename , line ); 1255 if (opt('t') && op == O_NEW) { 1256 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1257 , "_blkclr" ); 1258 stkrval(alv, NIL , RREQ ); 1259 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1260 putop( P2LISTOP , P2INT ); 1261 putop( P2CALL , P2INT ); 1262 putdot( filename , line ); 1263 } 1264 return; 1265 1266 case O_DATE: 1267 case O_TIME: 1268 if (argc != 1) { 1269 error("%s expects one argument", p->symbol); 1270 return; 1271 } 1272 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1273 , op == O_DATE ? "_DATE" : "_TIME" ); 1274 ap = stklval(argv[1], MOD|NOUSE); 1275 if (ap == NIL) 1276 return; 1277 if (classify(ap) != TSTR || width(ap) != 10) { 1278 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1279 return; 1280 } 1281 putop( P2CALL , P2INT ); 1282 putdot( filename , line ); 1283 return; 1284 1285 case O_HALT: 1286 if (argc != 0) { 1287 error("halt takes no arguments"); 1288 return; 1289 } 1290 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1291 , "_HALT" ); 1292 1293 putop( P2UNARY P2CALL , P2INT ); 1294 putdot( filename , line ); 1295 noreach = 1; 1296 return; 1297 1298 case O_ARGV: 1299 if (argc != 2) { 1300 error("argv takes two arguments"); 1301 return; 1302 } 1303 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1304 , "_ARGV" ); 1305 ap = stkrval(argv[1], NIL , RREQ ); 1306 if (ap == NIL) 1307 return; 1308 if (isnta(ap, "i")) { 1309 error("argv's first argument must be an integer, not %s", nameof(ap)); 1310 return; 1311 } 1312 al = argv[2]; 1313 ap = stklval(al[1], MOD|NOUSE); 1314 if (ap == NIL) 1315 return; 1316 if (classify(ap) != TSTR) { 1317 error("argv's second argument must be a string, not %s", nameof(ap)); 1318 return; 1319 } 1320 putop( P2LISTOP , P2INT ); 1321 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1322 putop( P2LISTOP , P2INT ); 1323 putop( P2CALL , P2INT ); 1324 putdot( filename , line ); 1325 return; 1326 1327 case O_STLIM: 1328 if (argc != 1) { 1329 error("stlimit requires one argument"); 1330 return; 1331 } 1332 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1333 , "_STLIM" ); 1334 ap = stkrval(argv[1], NIL , RREQ ); 1335 if (ap == NIL) 1336 return; 1337 if (isnta(ap, "i")) { 1338 error("stlimit's argument must be an integer, not %s", nameof(ap)); 1339 return; 1340 } 1341 putop( P2CALL , P2INT ); 1342 putdot( filename , line ); 1343 return; 1344 1345 case O_REMOVE: 1346 if (argc != 1) { 1347 error("remove expects one argument"); 1348 return; 1349 } 1350 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1351 , "_REMOVE" ); 1352 ap = stkrval(argv[1], NOFLAGS , RREQ ); 1353 if (ap == NIL) 1354 return; 1355 if (classify(ap) != TSTR) { 1356 error("remove's argument must be a string, not %s", nameof(ap)); 1357 return; 1358 } 1359 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1360 putop( P2LISTOP , P2INT ); 1361 putop( P2CALL , P2INT ); 1362 putdot( filename , line ); 1363 return; 1364 1365 case O_LLIMIT: 1366 if (argc != 2) { 1367 error("linelimit expects two arguments"); 1368 return; 1369 } 1370 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1371 , "_LLIMIT" ); 1372 ap = stklval(argv[1], NOFLAGS|NOUSE); 1373 if (ap == NIL) 1374 return; 1375 if (!text(ap)) { 1376 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1377 return; 1378 } 1379 al = argv[2]; 1380 ap = stkrval(al[1], NIL , RREQ ); 1381 if (ap == NIL) 1382 return; 1383 if (isnta(ap, "i")) { 1384 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1385 return; 1386 } 1387 putop( P2LISTOP , P2INT ); 1388 putop( P2CALL , P2INT ); 1389 putdot( filename , line ); 1390 return; 1391 case O_PAGE: 1392 if (argc != 1) { 1393 error("page expects one argument"); 1394 return; 1395 } 1396 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1397 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1398 , "_UNIT" ); 1399 ap = stklval(argv[1], NOFLAGS); 1400 if (ap == NIL) 1401 return; 1402 if (!text(ap)) { 1403 error("Argument to page must be a text file, not %s", nameof(ap)); 1404 return; 1405 } 1406 putop( P2CALL , P2INT ); 1407 putop( P2ASSIGN , P2PTR|P2STRTY ); 1408 putdot( filename , line ); 1409 if ( opt( 't' ) ) { 1410 putleaf( P2ICON , 0 , 0 1411 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1412 , "_PAGE" ); 1413 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1414 } else { 1415 putleaf( P2ICON , 0 , 0 1416 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1417 , "_fputc" ); 1418 putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 ); 1419 putleaf( P2ICON , 0 , 0 1420 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1421 , "_ACTFILE" ); 1422 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1423 putop( P2CALL , P2INT ); 1424 putop( P2LISTOP , P2INT ); 1425 } 1426 putop( P2CALL , P2INT ); 1427 putdot( filename , line ); 1428 return; 1429 1430 case O_ASRT: 1431 if (!opt('t')) 1432 return; 1433 if (argc == 0 || argc > 2) { 1434 error("Assert expects one or two arguments"); 1435 return; 1436 } 1437 if (argc == 2) 1438 cmd = "_ASRTS"; 1439 else 1440 cmd = "_ASRT"; 1441 putleaf( P2ICON , 0 , 0 1442 , ADDTYPE( P2FTN | P2INT , P2PTR ) , cmd ); 1443 ap = stkrval(argv[1], NIL , RREQ ); 1444 if (ap == NIL) 1445 return; 1446 if (isnta(ap, "b")) 1447 error("Assert expression must be Boolean, not %ss", nameof(ap)); 1448 if (argc == 2) { 1449 /* 1450 * Optional second argument is a string specifying 1451 * why the assertion failed. 1452 */ 1453 al = argv[2]; 1454 al = stkrval(al[1], NIL , RREQ ); 1455 if (al == NIL) 1456 return; 1457 if (classify(al) != TSTR) { 1458 error("Second argument to assert must be a string, not %s", nameof(al)); 1459 return; 1460 } 1461 putop( P2LISTOP , P2INT ); 1462 } 1463 putop( P2CALL , P2INT ); 1464 putdot( filename , line ); 1465 return; 1466 1467 case O_PACK: 1468 if (argc != 3) { 1469 error("pack expects three arguments"); 1470 return; 1471 } 1472 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1473 , "_PACK" ); 1474 pu = "pack(a,i,z)"; 1475 pua = (al = argv)[1]; 1476 pui = (al = al[2])[1]; 1477 puz = (al = al[2])[1]; 1478 goto packunp; 1479 case O_UNPACK: 1480 if (argc != 3) { 1481 error("unpack expects three arguments"); 1482 return; 1483 } 1484 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1485 , "_UNPACK" ); 1486 pu = "unpack(z,a,i)"; 1487 puz = (al = argv)[1]; 1488 pua = (al = al[2])[1]; 1489 pui = (al = al[2])[1]; 1490 packunp: 1491 ap = stkrval((int *) pui, NLNIL , RREQ ); 1492 if (ap == NIL) 1493 return; 1494 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1495 if (ap == NIL) 1496 return; 1497 if (ap->class != ARRAY) { 1498 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1499 return; 1500 } 1501 putop( P2LISTOP , P2INT ); 1502 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1503 if (al->class != ARRAY) { 1504 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1505 return; 1506 } 1507 if (al->type == NIL || ap->type == NIL) 1508 return; 1509 if (al->type != ap->type) { 1510 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1511 return; 1512 } 1513 putop( P2LISTOP , P2INT ); 1514 k = width(al); 1515 itemwidth = width(ap->type); 1516 ap = ap->chain; 1517 al = al->chain; 1518 if (ap->chain != NIL || al->chain != NIL) { 1519 error("%s requires a and z to be single dimension arrays", pu); 1520 return; 1521 } 1522 if (ap == NIL || al == NIL) 1523 return; 1524 /* 1525 * al is the range for z i.e. u..v 1526 * ap is the range for a i.e. m..n 1527 * i will be n-m+1 1528 * j will be v-u+1 1529 */ 1530 i = ap->range[1] - ap->range[0] + 1; 1531 j = al->range[1] - al->range[0] + 1; 1532 if (i < j) { 1533 error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1534 return; 1535 } 1536 /* 1537 * get n-m-(v-u) and m for the interpreter 1538 */ 1539 i -= j; 1540 j = ap->range[0]; 1541 putleaf( P2ICON , itemwidth , 0 , P2INT , 0 ); 1542 putop( P2LISTOP , P2INT ); 1543 putleaf( P2ICON , j , 0 , P2INT , 0 ); 1544 putop( P2LISTOP , P2INT ); 1545 putleaf( P2ICON , i , 0 , P2INT , 0 ); 1546 putop( P2LISTOP , P2INT ); 1547 putleaf( P2ICON , k , 0 , P2INT , 0 ); 1548 putop( P2LISTOP , P2INT ); 1549 putop( P2CALL , P2INT ); 1550 putdot( filename , line ); 1551 return; 1552 case 0: 1553 error("%s is an unimplemented extension", p->symbol); 1554 return; 1555 1556 default: 1557 panic("proc case"); 1558 } 1559 } 1560 #endif PC 1561