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