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