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