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