1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcproc.c 1.10 08/29/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; 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 = 0; 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 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1182 , op == O_DISPOSE ? "_DISPOSE" : 1183 opt('t') ? "_NEWZ" : "_NEW" ); 1184 ap = stklval(argv[1], op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1185 if (ap == NIL) 1186 return; 1187 if (ap->class != PTR) { 1188 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1189 return; 1190 } 1191 ap = ap->type; 1192 if (ap == NIL) 1193 return; 1194 argv = argv[2]; 1195 if (argv != NIL) { 1196 if (ap->class != RECORD) { 1197 error("Record required when specifying variant tags"); 1198 return; 1199 } 1200 for (; argv != NIL; argv = argv[2]) { 1201 if (ap->ptr[NL_VARNT] == NIL) { 1202 error("Too many tag fields"); 1203 return; 1204 } 1205 if (!isconst(argv[1])) { 1206 error("Second and successive arguments to %s must be constants", p->symbol); 1207 return; 1208 } 1209 gconst(argv[1]); 1210 if (con.ctype == NIL) 1211 return; 1212 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 1213 cerror("Specified tag constant type clashed with variant case selector type"); 1214 return; 1215 } 1216 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1217 if (ap->range[0] == con.crval) 1218 break; 1219 if (ap == NIL) { 1220 error("No variant case label value equals specified constant value"); 1221 return; 1222 } 1223 ap = ap->ptr[NL_VTOREC]; 1224 } 1225 } 1226 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1227 putop( P2LISTOP , P2INT ); 1228 putop( P2CALL , P2INT ); 1229 putdot( filename , line ); 1230 return; 1231 1232 case O_DATE: 1233 case O_TIME: 1234 if (argc != 1) { 1235 error("%s expects one argument", p->symbol); 1236 return; 1237 } 1238 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1239 , op == O_DATE ? "_DATE" : "_TIME" ); 1240 ap = stklval(argv[1], MOD|NOUSE); 1241 if (ap == NIL) 1242 return; 1243 if (classify(ap) != TSTR || width(ap) != 10) { 1244 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1245 return; 1246 } 1247 putop( P2CALL , P2INT ); 1248 putdot( filename , line ); 1249 return; 1250 1251 case O_HALT: 1252 if (argc != 0) { 1253 error("halt takes no arguments"); 1254 return; 1255 } 1256 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1257 , "_HALT" ); 1258 1259 putop( P2UNARY P2CALL , P2INT ); 1260 putdot( filename , line ); 1261 noreach = 1; 1262 return; 1263 1264 case O_ARGV: 1265 if (argc != 2) { 1266 error("argv takes two arguments"); 1267 return; 1268 } 1269 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1270 , "_ARGV" ); 1271 ap = stkrval(argv[1], NIL , RREQ ); 1272 if (ap == NIL) 1273 return; 1274 if (isnta(ap, "i")) { 1275 error("argv's first argument must be an integer, not %s", nameof(ap)); 1276 return; 1277 } 1278 al = argv[2]; 1279 ap = stklval(al[1], MOD|NOUSE); 1280 if (ap == NIL) 1281 return; 1282 if (classify(ap) != TSTR) { 1283 error("argv's second argument must be a string, not %s", nameof(ap)); 1284 return; 1285 } 1286 putop( P2LISTOP , P2INT ); 1287 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1288 putop( P2LISTOP , P2INT ); 1289 putop( P2CALL , P2INT ); 1290 putdot( filename , line ); 1291 return; 1292 1293 case O_STLIM: 1294 if (argc != 1) { 1295 error("stlimit requires one argument"); 1296 return; 1297 } 1298 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1299 , "_STLIM" ); 1300 ap = stkrval(argv[1], NIL , RREQ ); 1301 if (ap == NIL) 1302 return; 1303 if (isnta(ap, "i")) { 1304 error("stlimit's argument must be an integer, not %s", nameof(ap)); 1305 return; 1306 } 1307 putop( P2CALL , P2INT ); 1308 putdot( filename , line ); 1309 return; 1310 1311 case O_REMOVE: 1312 if (argc != 1) { 1313 error("remove expects one argument"); 1314 return; 1315 } 1316 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1317 , "_REMOVE" ); 1318 ap = stkrval(argv[1], NOFLAGS , RREQ ); 1319 if (ap == NIL) 1320 return; 1321 if (classify(ap) != TSTR) { 1322 error("remove's argument must be a string, not %s", nameof(ap)); 1323 return; 1324 } 1325 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1326 putop( P2LISTOP , P2INT ); 1327 putop( P2CALL , P2INT ); 1328 putdot( filename , line ); 1329 return; 1330 1331 case O_LLIMIT: 1332 if (argc != 2) { 1333 error("linelimit expects two arguments"); 1334 return; 1335 } 1336 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1337 , "_LLIMIT" ); 1338 ap = stklval(argv[1], NOFLAGS|NOUSE); 1339 if (ap == NIL) 1340 return; 1341 if (!text(ap)) { 1342 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1343 return; 1344 } 1345 al = argv[2]; 1346 ap = stkrval(al[1], NIL , RREQ ); 1347 if (ap == NIL) 1348 return; 1349 if (isnta(ap, "i")) { 1350 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1351 return; 1352 } 1353 putop( P2LISTOP , P2INT ); 1354 putop( P2CALL , P2INT ); 1355 putdot( filename , line ); 1356 return; 1357 case O_PAGE: 1358 if (argc != 1) { 1359 error("page expects one argument"); 1360 return; 1361 } 1362 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1363 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1364 , "_UNIT" ); 1365 ap = stklval(argv[1], NOFLAGS); 1366 if (ap == NIL) 1367 return; 1368 if (!text(ap)) { 1369 error("Argument to page must be a text file, not %s", nameof(ap)); 1370 return; 1371 } 1372 putop( P2CALL , P2INT ); 1373 putop( P2ASSIGN , P2PTR|P2STRTY ); 1374 putdot( filename , line ); 1375 if ( opt( 't' ) ) { 1376 putleaf( P2ICON , 0 , 0 1377 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1378 , "_PAGE" ); 1379 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1380 } else { 1381 putleaf( P2ICON , 0 , 0 1382 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1383 , "_fputc" ); 1384 putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 ); 1385 putleaf( P2ICON , 0 , 0 1386 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1387 , "_ACTFILE" ); 1388 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1389 putop( P2CALL , P2INT ); 1390 putop( P2LISTOP , P2INT ); 1391 } 1392 putop( P2CALL , P2INT ); 1393 putdot( filename , line ); 1394 return; 1395 1396 case O_ASRT: 1397 if (!opt('t')) 1398 return; 1399 if (argc == 0 || argc > 2) { 1400 error("Assert expects one or two arguments"); 1401 return; 1402 } 1403 putleaf( P2ICON , 0 , 0 1404 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_ASRT" ); 1405 ap = stkrval(argv[1], NIL , RREQ ); 1406 if (ap == NIL) 1407 return; 1408 if (isnta(ap, "b")) 1409 error("Assert expression must be Boolean, not %ss", nameof(ap)); 1410 if (argc == 2) { 1411 /* 1412 * Optional second argument is a string specifying 1413 * why the assertion failed. 1414 */ 1415 al = argv[2]; 1416 al = stkrval(al[1], NIL , RREQ ); 1417 if (al == NIL) 1418 return; 1419 if (classify(al) != TSTR) { 1420 error("Second argument to assert must be a string, not %s", nameof(al)); 1421 return; 1422 } 1423 } else { 1424 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 1425 } 1426 putop( P2LISTOP , P2INT ); 1427 putop( P2CALL , P2INT ); 1428 putdot( filename , line ); 1429 return; 1430 1431 case O_PACK: 1432 if (argc != 3) { 1433 error("pack expects three arguments"); 1434 return; 1435 } 1436 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1437 , "_PACK" ); 1438 pu = "pack(a,i,z)"; 1439 pua = (al = argv)[1]; 1440 pui = (al = al[2])[1]; 1441 puz = (al = al[2])[1]; 1442 goto packunp; 1443 case O_UNPACK: 1444 if (argc != 3) { 1445 error("unpack expects three arguments"); 1446 return; 1447 } 1448 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1449 , "_UNPACK" ); 1450 pu = "unpack(z,a,i)"; 1451 puz = (al = argv)[1]; 1452 pua = (al = al[2])[1]; 1453 pui = (al = al[2])[1]; 1454 packunp: 1455 ap = stkrval((int *) pui, NLNIL , RREQ ); 1456 if (ap == NIL) 1457 return; 1458 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1459 if (ap == NIL) 1460 return; 1461 if (ap->class != ARRAY) { 1462 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1463 return; 1464 } 1465 putop( P2LISTOP , P2INT ); 1466 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1467 if (al->class != ARRAY) { 1468 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1469 return; 1470 } 1471 if (al->type == NIL || ap->type == NIL) 1472 return; 1473 if (al->type != ap->type) { 1474 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1475 return; 1476 } 1477 putop( P2LISTOP , P2INT ); 1478 k = width(al); 1479 itemwidth = width(ap->type); 1480 ap = ap->chain; 1481 al = al->chain; 1482 if (ap->chain != NIL || al->chain != NIL) { 1483 error("%s requires a and z to be single dimension arrays", pu); 1484 return; 1485 } 1486 if (ap == NIL || al == NIL) 1487 return; 1488 /* 1489 * al is the range for z i.e. u..v 1490 * ap is the range for a i.e. m..n 1491 * i will be n-m+1 1492 * j will be v-u+1 1493 */ 1494 i = ap->range[1] - ap->range[0] + 1; 1495 j = al->range[1] - al->range[0] + 1; 1496 if (i < j) { 1497 error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1498 return; 1499 } 1500 /* 1501 * get n-m-(v-u) and m for the interpreter 1502 */ 1503 i -= j; 1504 j = ap->range[0]; 1505 putleaf( P2ICON , itemwidth , 0 , P2INT , 0 ); 1506 putop( P2LISTOP , P2INT ); 1507 putleaf( P2ICON , j , 0 , P2INT , 0 ); 1508 putop( P2LISTOP , P2INT ); 1509 putleaf( P2ICON , i , 0 , P2INT , 0 ); 1510 putop( P2LISTOP , P2INT ); 1511 putleaf( P2ICON , k , 0 , P2INT , 0 ); 1512 putop( P2LISTOP , P2INT ); 1513 putop( P2CALL , P2INT ); 1514 putdot( filename , line ); 1515 return; 1516 case 0: 1517 error("%s is an unimplemented extension", p->symbol); 1518 return; 1519 1520 default: 1521 panic("proc case"); 1522 } 1523 } 1524 #endif PC 1525