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