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