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