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