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