1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcproc.c 1.7 10/23/81"; 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 TINT: 427 if (fmt == 'f') { 428 typ = TDOUBLE; 429 goto tdouble; 430 } 431 if (fmtspec == NIL) { 432 if (fmt == 'D') 433 field = 10; 434 else if (fmt == 'X') 435 field = 8; 436 else if (fmt == 'O') 437 field = 11; 438 else 439 panic("fmt1"); 440 fmtspec = CONWIDTH; 441 } 442 break; 443 case TCHAR: 444 tchar: 445 fmt = 'c'; 446 break; 447 case TSCAL: 448 warning(); 449 if (opt('s')) { 450 standard(); 451 } 452 error("Writing scalars to text files is non-standard"); 453 case TBOOL: 454 fmt = 's'; 455 break; 456 case TDOUBLE: 457 tdouble: 458 switch (fmtspec) { 459 case NIL: 460 field = 21; 461 prec = 14; 462 fmt = 'e'; 463 fmtspec = CONWIDTH + CONPREC; 464 break; 465 case CONWIDTH: 466 if (--field < 1) 467 field = 1; 468 prec = field - 7; 469 if (prec < 1) 470 prec = 1; 471 fmtspec += CONPREC; 472 fmt = 'e'; 473 break; 474 case VARWIDTH: 475 fmtspec += VARPREC; 476 fmt = 'e'; 477 break; 478 case CONWIDTH + CONPREC: 479 case CONWIDTH + VARPREC: 480 if (--field < 1) 481 field = 1; 482 } 483 format[0] = ' '; 484 fmtstart = 0; 485 break; 486 case TSTR: 487 constval( alv ); 488 switch ( classify( con.ctype ) ) { 489 case TCHAR: 490 typ = TCHAR; 491 goto tchar; 492 case TSTR: 493 strptr = con.cpval; 494 for (strnglen = 0; *strptr++; strnglen++) /* void */; 495 strptr = con.cpval; 496 break; 497 default: 498 strnglen = width(ap); 499 break; 500 } 501 fmt = 's'; 502 strfmt = fmtspec; 503 if (fmtspec == NIL) { 504 fmtspec = SKIP; 505 break; 506 } 507 if (fmtspec & CONWIDTH) { 508 if (field <= strnglen) 509 fmtspec = SKIP; 510 else 511 field -= strnglen; 512 } 513 break; 514 default: 515 error("Can't write %ss to a text file", clnames[typ]); 516 continue; 517 } 518 /* 519 * Generate the format string 520 */ 521 switch (fmtspec) { 522 default: 523 panic("fmt2"); 524 case NIL: 525 if (fmt == 'c') { 526 if ( opt( 't' ) ) { 527 putleaf( P2ICON , 0 , 0 528 , ADDTYPE( P2FTN|P2INT , P2PTR ) 529 , "_WRITEC" ); 530 putRV( 0 , cbn , CURFILEOFFSET , 531 NLOCAL , P2PTR|P2STRTY ); 532 stkrval( alv , NIL , RREQ ); 533 putop( P2LISTOP , P2INT ); 534 } else { 535 putleaf( P2ICON , 0 , 0 536 , ADDTYPE( P2FTN|P2INT , P2PTR ) 537 , "_fputc" ); 538 stkrval( alv , NIL , RREQ ); 539 } 540 putleaf( P2ICON , 0 , 0 541 , ADDTYPE( P2FTN | P2INT , P2PTR ) 542 , "_ACTFILE" ); 543 putRV( 0, cbn , CURFILEOFFSET , 544 NLOCAL , P2PTR|P2STRTY ); 545 putop( P2CALL , P2INT ); 546 putop( P2LISTOP , P2INT ); 547 putop( P2CALL , P2INT ); 548 putdot( filename , line ); 549 } else { 550 sprintf(&format[1], "%%%c", fmt); 551 goto fmtgen; 552 } 553 case SKIP: 554 break; 555 case CONWIDTH: 556 sprintf(&format[1], "%%%1D%c", field, fmt); 557 goto fmtgen; 558 case VARWIDTH: 559 sprintf(&format[1], "%%*%c", fmt); 560 goto fmtgen; 561 case CONWIDTH + CONPREC: 562 sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt); 563 goto fmtgen; 564 case CONWIDTH + VARPREC: 565 sprintf(&format[1], "%%%1D.*%c", field, fmt); 566 goto fmtgen; 567 case VARWIDTH + CONPREC: 568 sprintf(&format[1], "%%*.%1D%c", prec, fmt); 569 goto fmtgen; 570 case VARWIDTH + VARPREC: 571 sprintf(&format[1], "%%*.*%c", fmt); 572 fmtgen: 573 if ( opt( 't' ) ) { 574 putleaf( P2ICON , 0 , 0 575 , ADDTYPE( P2FTN | P2INT , P2PTR ) 576 , "_WRITEF" ); 577 putRV( 0 , cbn , CURFILEOFFSET , 578 NLOCAL , P2PTR|P2STRTY ); 579 putleaf( P2ICON , 0 , 0 580 , ADDTYPE( P2FTN | P2INT , P2PTR ) 581 , "_ACTFILE" ); 582 putRV( 0 , cbn , CURFILEOFFSET , 583 NLOCAL , P2PTR|P2STRTY ); 584 putop( P2CALL , P2INT ); 585 putop( P2LISTOP , P2INT ); 586 } else { 587 putleaf( P2ICON , 0 , 0 588 , ADDTYPE( P2FTN | P2INT , P2PTR ) 589 , "_fprintf" ); 590 putleaf( P2ICON , 0 , 0 591 , ADDTYPE( P2FTN | P2INT , P2PTR ) 592 , "_ACTFILE" ); 593 putRV( 0 , cbn , CURFILEOFFSET , 594 NLOCAL , P2PTR|P2STRTY ); 595 putop( P2CALL , P2INT ); 596 } 597 putCONG( &format[ fmtstart ] 598 , strlen( &format[ fmtstart ] ) 599 , LREQ ); 600 putop( P2LISTOP , P2INT ); 601 if ( fmtspec & VARWIDTH ) { 602 /* 603 * either 604 * ,(temp=width,MAX(temp,...)), 605 * or 606 * , MAX( width , ... ) , 607 */ 608 if ( ( typ == TDOUBLE && al[3] == NIL ) 609 || typ == TSTR ) { 610 soffset = sizes[cbn].curtmps; 611 tempnlp = tmpalloc(sizeof(long), 612 nl+T4INT, REGOK); 613 putRV( 0 , cbn , 614 tempnlp -> value[ NL_OFFS ] , 615 tempnlp -> extra_flags , P2INT ); 616 ap = stkrval( al[2] , NIL , RREQ ); 617 putop( P2ASSIGN , P2INT ); 618 putleaf( P2ICON , 0 , 0 619 , ADDTYPE( P2FTN | P2INT , P2PTR ) 620 , "_MAX" ); 621 putRV( 0 , cbn , 622 tempnlp -> value[ NL_OFFS ] , 623 tempnlp -> extra_flags , P2INT ); 624 } else { 625 if (opt('t') 626 || typ == TSTR || typ == TDOUBLE) { 627 putleaf( P2ICON , 0 , 0 628 ,ADDTYPE( P2FTN | P2INT, P2PTR ) 629 ,"_MAX" ); 630 } 631 ap = stkrval( al[2] , NIL , RREQ ); 632 } 633 if (ap == NIL) 634 continue; 635 if (isnta(ap,"i")) { 636 error("First write width must be integer, not %s", nameof(ap)); 637 continue; 638 } 639 switch ( typ ) { 640 case TDOUBLE: 641 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 642 putop( P2LISTOP , P2INT ); 643 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 644 putop( P2LISTOP , P2INT ); 645 putop( P2CALL , P2INT ); 646 if ( al[3] == NIL ) { 647 /* 648 * finish up the comma op 649 */ 650 putop( P2COMOP , P2INT ); 651 fmtspec &= ~VARPREC; 652 putop( P2LISTOP , P2INT ); 653 putleaf( P2ICON , 0 , 0 654 , ADDTYPE( P2FTN | P2INT , P2PTR ) 655 , "_MAX" ); 656 putRV( 0 , cbn , 657 tempnlp -> value[ NL_OFFS ] , 658 tempnlp -> extra_flags , 659 P2INT ); 660 tmpfree(&soffset); 661 putleaf( P2ICON , 8 , 0 , P2INT , 0 ); 662 putop( P2LISTOP , P2INT ); 663 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 664 putop( P2LISTOP , P2INT ); 665 putop( P2CALL , P2INT ); 666 } 667 putop( P2LISTOP , P2INT ); 668 break; 669 case TSTR: 670 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 671 putop( P2LISTOP , P2INT ); 672 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 673 putop( P2LISTOP , P2INT ); 674 putop( P2CALL , P2INT ); 675 putop( P2COMOP , P2INT ); 676 putop( P2LISTOP , P2INT ); 677 break; 678 default: 679 if (opt('t')) { 680 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 681 putop( P2LISTOP , P2INT ); 682 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 683 putop( P2LISTOP , P2INT ); 684 putop( P2CALL , P2INT ); 685 } 686 putop( P2LISTOP , P2INT ); 687 break; 688 } 689 } 690 /* 691 * If there is a variable precision, 692 * evaluate it 693 */ 694 if (fmtspec & VARPREC) { 695 if (opt('t')) { 696 putleaf( P2ICON , 0 , 0 697 , ADDTYPE( P2FTN | P2INT , P2PTR ) 698 , "_MAX" ); 699 } 700 ap = stkrval( al[3] , NIL , RREQ ); 701 if (ap == NIL) 702 continue; 703 if (isnta(ap,"i")) { 704 error("Second write width must be integer, not %s", nameof(ap)); 705 continue; 706 } 707 if (opt('t')) { 708 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 709 putop( P2LISTOP , P2INT ); 710 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 711 putop( P2LISTOP , P2INT ); 712 putop( P2CALL , P2INT ); 713 } 714 putop( P2LISTOP , P2INT ); 715 } 716 /* 717 * evaluate the thing we want printed. 718 */ 719 switch ( typ ) { 720 case TCHAR: 721 case TINT: 722 stkrval( alv , NIL , RREQ ); 723 putop( P2LISTOP , P2INT ); 724 break; 725 case TDOUBLE: 726 ap = stkrval( alv , NIL , RREQ ); 727 if ( isnta( ap , "d" ) ) { 728 putop( P2SCONV , P2DOUBLE ); 729 } 730 putop( P2LISTOP , P2INT ); 731 break; 732 case TSCAL: 733 case TBOOL: 734 putleaf( P2ICON , 0 , 0 735 , ADDTYPE( P2FTN | P2INT , P2PTR ) 736 , "_NAM" ); 737 ap = stkrval( alv , NIL , RREQ ); 738 sprintf( format , PREFIXFORMAT , LABELPREFIX 739 , listnames( ap ) ); 740 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 741 , format ); 742 putop( P2LISTOP , P2INT ); 743 putop( P2CALL , P2INT ); 744 putop( P2LISTOP , P2INT ); 745 break; 746 case TSTR: 747 putCONG( "" , 0 , LREQ ); 748 putop( P2LISTOP , P2INT ); 749 break; 750 } 751 putop( P2CALL , P2INT ); 752 putdot( filename , line ); 753 } 754 /* 755 * Write the string after its blank padding 756 */ 757 if (typ == TSTR ) { 758 if ( opt( 't' ) ) { 759 putleaf( P2ICON , 0 , 0 760 , ADDTYPE( P2FTN | P2INT , P2PTR ) 761 , "_WRITES" ); 762 putRV( 0 , cbn , CURFILEOFFSET , 763 NLOCAL , P2PTR|P2STRTY ); 764 ap = stkrval(alv, NIL , RREQ ); 765 putop( P2LISTOP , P2INT ); 766 } else { 767 putleaf( P2ICON , 0 , 0 768 , ADDTYPE( P2FTN | P2INT , P2PTR ) 769 , "_fwrite" ); 770 ap = stkrval(alv, NIL , RREQ ); 771 } 772 if (strfmt & VARWIDTH) { 773 /* 774 * min, inline expanded as 775 * temp < len ? temp : len 776 */ 777 putRV( 0 , cbn , 778 tempnlp -> value[ NL_OFFS ] , 779 tempnlp -> extra_flags , P2INT ); 780 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 781 putop( P2LT , P2INT ); 782 putRV( 0 , cbn , 783 tempnlp -> value[ NL_OFFS ] , 784 tempnlp -> extra_flags , P2INT ); 785 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 786 putop( P2COLON , P2INT ); 787 putop( P2QUEST , P2INT ); 788 tmpfree(&soffset); 789 } else { 790 if ( ( fmtspec & SKIP ) 791 && ( strfmt & CONWIDTH ) ) { 792 strnglen = field; 793 } 794 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 795 } 796 putop( P2LISTOP , P2INT ); 797 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 798 putop( P2LISTOP , P2INT ); 799 putleaf( P2ICON , 0 , 0 800 , ADDTYPE( P2FTN | P2INT , P2PTR ) 801 , "_ACTFILE" ); 802 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 803 P2PTR|P2STRTY ); 804 putop( P2CALL , P2INT ); 805 putop( P2LISTOP , P2INT ); 806 putop( P2CALL , P2INT ); 807 putdot( filename , line ); 808 } 809 } 810 /* 811 * Done with arguments. 812 * Handle writeln and 813 * insufficent number of args. 814 */ 815 switch (p->value[0] &~ NSTAND) { 816 case O_WRITEF: 817 if (argc == 0) 818 error("Write requires an argument"); 819 break; 820 case O_MESSAGE: 821 if (argc == 0) 822 error("Message requires an argument"); 823 case O_WRITLN: 824 if (filetype != nl+T1CHAR) 825 error("Can't 'writeln' a non text file"); 826 if ( opt( 't' ) ) { 827 putleaf( P2ICON , 0 , 0 828 , ADDTYPE( P2FTN | P2INT , P2PTR ) 829 , "_WRITLN" ); 830 putRV( 0 , cbn , CURFILEOFFSET , 831 NLOCAL , P2PTR|P2STRTY ); 832 } else { 833 putleaf( P2ICON , 0 , 0 834 , ADDTYPE( P2FTN | P2INT , P2PTR ) 835 , "_fputc" ); 836 putleaf( P2ICON , '\n' , 0 , P2CHAR , 0 ); 837 putleaf( P2ICON , 0 , 0 838 , ADDTYPE( P2FTN | P2INT , P2PTR ) 839 , "_ACTFILE" ); 840 putRV( 0 , cbn , CURFILEOFFSET , 841 NLOCAL , P2PTR|P2STRTY ); 842 putop( P2CALL , P2INT ); 843 putop( P2LISTOP , P2INT ); 844 } 845 putop( P2CALL , P2INT ); 846 putdot( filename , line ); 847 break; 848 } 849 return; 850 851 case O_READ4: 852 case O_READLN: 853 /* 854 * Set up default 855 * file "input". 856 */ 857 file = NIL; 858 filetype = nl+T1CHAR; 859 /* 860 * Determine the file implied 861 * for the read and generate 862 * code to make it the active file. 863 */ 864 if (argv != NIL) { 865 codeoff(); 866 ap = stkrval(argv[1], NIL , RREQ ); 867 codeon(); 868 if (ap == NIL) 869 argv = argv[2]; 870 if (ap != NIL && ap->class == FILET) { 871 /* 872 * Got "read(f, ...", make 873 * f the active file, and save 874 * it and its type for use in 875 * processing the rest of the 876 * arguments to read. 877 */ 878 file = argv[1]; 879 filetype = ap->type; 880 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 881 P2PTR|P2STRTY ); 882 putleaf( P2ICON , 0 , 0 883 , ADDTYPE( P2FTN | P2INT , P2PTR ) 884 , "_UNIT" ); 885 stklval(argv[1], NOFLAGS); 886 putop( P2CALL , P2INT ); 887 putop( P2ASSIGN , P2PTR|P2STRTY ); 888 putdot( filename , line ); 889 argv = argv[2]; 890 argc--; 891 } else { 892 /* 893 * Default is read from 894 * standard input. 895 */ 896 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 897 P2PTR|P2STRTY ); 898 putLV( "_input" , 0 , 0 , NGLOBAL , 899 P2PTR|P2STRTY ); 900 putop( P2ASSIGN , P2PTR|P2STRTY ); 901 putdot( filename , line ); 902 input->nl_flags |= NUSED; 903 } 904 } else { 905 putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 906 P2PTR|P2STRTY ); 907 putLV( "_input" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 908 putop( P2ASSIGN , P2PTR|P2STRTY ); 909 putdot( filename , line ); 910 input->nl_flags |= NUSED; 911 } 912 /* 913 * Loop and process each 914 * of the arguments. 915 */ 916 for (; argv != NIL; argv = argv[2]) { 917 /* 918 * Get the address of the target 919 * on the stack. 920 */ 921 al = argv[1]; 922 if (al == NIL) 923 continue; 924 if (al[0] != T_VAR) { 925 error("Arguments to %s must be variables, not expressions", p->symbol); 926 continue; 927 } 928 codeoff(); 929 ap = stklval(al, MOD|ASGN|NOUSE); 930 codeon(); 931 if (ap == NIL) 932 continue; 933 if (filetype != nl+T1CHAR) { 934 /* 935 * Generalized read, i.e. 936 * from a non-textfile. 937 */ 938 if (incompat(filetype, ap, argv[1] )) { 939 error("Type mismatch in read from non-text file"); 940 continue; 941 } 942 /* 943 * var := file ^; 944 */ 945 ap = lvalue( al , MOD | ASGN | NOUSE , RREQ ); 946 if ( isa( ap , "bsci" ) ) { 947 precheck( ap , "_RANG4" , "_RSNG4" ); 948 } 949 putleaf( P2ICON , 0 , 0 950 , ADDTYPE( 951 ADDTYPE( 952 ADDTYPE( 953 p2type( filetype ) , P2PTR ) 954 , P2FTN ) 955 , P2PTR ) 956 , "_FNIL" ); 957 if (file != NIL) 958 stklval(file, NOFLAGS); 959 else /* Magic */ 960 putRV( "_input" , 0 , 0 , NGLOBAL , 961 P2PTR | P2STRTY ); 962 putop( P2CALL , P2INT ); 963 switch ( classify( filetype ) ) { 964 case TBOOL: 965 case TCHAR: 966 case TINT: 967 case TSCAL: 968 case TDOUBLE: 969 case TPTR: 970 putop( P2UNARY P2MUL 971 , p2type( filetype ) ); 972 } 973 switch ( classify( filetype ) ) { 974 case TBOOL: 975 case TCHAR: 976 case TINT: 977 case TSCAL: 978 postcheck( ap ); 979 /* and fall through */ 980 case TDOUBLE: 981 case TPTR: 982 putop( P2ASSIGN , p2type( ap ) ); 983 putdot( filename , line ); 984 break; 985 default: 986 putstrop( P2STASG 987 , p2type( ap ) 988 , lwidth( ap ) 989 , align( ap ) ); 990 putdot( filename , line ); 991 break; 992 } 993 /* 994 * get(file); 995 */ 996 putleaf( P2ICON , 0 , 0 997 , ADDTYPE( P2FTN | P2INT , P2PTR ) 998 , "_GET" ); 999 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1000 P2PTR|P2STRTY ); 1001 putop( P2CALL , P2INT ); 1002 putdot( filename , line ); 1003 continue; 1004 } 1005 /* 1006 * if you get to here, you are reading from 1007 * a text file. only possiblities are: 1008 * character, integer, real, or scalar. 1009 * read( f , foo , ... ) is done as 1010 * foo := read( f ) with rangechecking 1011 * if appropriate. 1012 */ 1013 typ = classify(ap); 1014 op = rdops(typ); 1015 if (op == NIL) { 1016 error("Can't read %ss from a text file", clnames[typ]); 1017 continue; 1018 } 1019 /* 1020 * left hand side of foo := read( f ) 1021 */ 1022 ap = lvalue( al , MOD|ASGN|NOUSE , RREQ ); 1023 if ( isa( ap , "bsci" ) ) { 1024 precheck( ap , "_RANG4" , "_RSNG4" ); 1025 } 1026 switch ( op ) { 1027 case O_READC: 1028 readname = "_READC"; 1029 readtype = P2INT; 1030 break; 1031 case O_READ4: 1032 readname = "_READ4"; 1033 readtype = P2INT; 1034 break; 1035 case O_READ8: 1036 readname = "_READ8"; 1037 readtype = P2DOUBLE; 1038 break; 1039 case O_READE: 1040 readname = "_READE"; 1041 readtype = P2INT; 1042 break; 1043 } 1044 putleaf( P2ICON , 0 , 0 1045 , ADDTYPE( P2FTN | readtype , P2PTR ) 1046 , readname ); 1047 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1048 P2PTR|P2STRTY ); 1049 if ( op == O_READE ) { 1050 sprintf( format , PREFIXFORMAT , LABELPREFIX 1051 , listnames( ap ) ); 1052 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 1053 , format ); 1054 putop( P2LISTOP , P2INT ); 1055 warning(); 1056 if (opt('s')) { 1057 standard(); 1058 } 1059 error("Reading scalars from text files is non-standard"); 1060 } 1061 putop( P2CALL , readtype ); 1062 if ( isa( ap , "bcsi" ) ) { 1063 postcheck( ap ); 1064 } 1065 putop( P2ASSIGN , p2type( ap ) ); 1066 putdot( filename , line ); 1067 } 1068 /* 1069 * Done with arguments. 1070 * Handle readln and 1071 * insufficient number of args. 1072 */ 1073 if (p->value[0] == O_READLN) { 1074 if (filetype != nl+T1CHAR) 1075 error("Can't 'readln' a non text file"); 1076 putleaf( P2ICON , 0 , 0 1077 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1078 , "_READLN" ); 1079 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1080 P2PTR|P2STRTY ); 1081 putop( P2CALL , P2INT ); 1082 putdot( filename , line ); 1083 } else if (argc == 0) 1084 error("read requires an argument"); 1085 return; 1086 1087 case O_GET: 1088 case O_PUT: 1089 if (argc != 1) { 1090 error("%s expects one argument", p->symbol); 1091 return; 1092 } 1093 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1094 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1095 , "_UNIT" ); 1096 ap = stklval(argv[1], NOFLAGS); 1097 if (ap == NIL) 1098 return; 1099 if (ap->class != FILET) { 1100 error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1101 return; 1102 } 1103 putop( P2CALL , P2INT ); 1104 putop( P2ASSIGN , P2PTR|P2STRTY ); 1105 putdot( filename , line ); 1106 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1107 , op == O_GET ? "_GET" : "_PUT" ); 1108 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1109 putop( P2CALL , P2INT ); 1110 putdot( filename , line ); 1111 return; 1112 1113 case O_RESET: 1114 case O_REWRITE: 1115 if (argc == 0 || argc > 2) { 1116 error("%s expects one or two arguments", p->symbol); 1117 return; 1118 } 1119 if (opt('s') && argc == 2) { 1120 standard(); 1121 error("Two argument forms of reset and rewrite are non-standard"); 1122 } 1123 putleaf( P2ICON , 0 , 0 , P2INT 1124 , op == O_RESET ? "_RESET" : "_REWRITE" ); 1125 ap = stklval(argv[1], MOD|NOUSE); 1126 if (ap == NIL) 1127 return; 1128 if (ap->class != FILET) { 1129 error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1130 return; 1131 } 1132 if (argc == 2) { 1133 /* 1134 * Optional second argument 1135 * is a string name of a 1136 * UNIX (R) file to be associated. 1137 */ 1138 al = argv[2]; 1139 al = stkrval(al[1], NOFLAGS , RREQ ); 1140 if (al == NIL) 1141 return; 1142 if (classify(al) != TSTR) { 1143 error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); 1144 return; 1145 } 1146 strnglen = width(al); 1147 } else { 1148 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 1149 strnglen = 0; 1150 } 1151 putop( P2LISTOP , P2INT ); 1152 putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 1153 putop( P2LISTOP , P2INT ); 1154 putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 ); 1155 putop( P2LISTOP , P2INT ); 1156 putop( P2CALL , P2INT ); 1157 putdot( filename , line ); 1158 return; 1159 1160 case O_NEW: 1161 case O_DISPOSE: 1162 if (argc == 0) { 1163 error("%s expects at least one argument", p->symbol); 1164 return; 1165 } 1166 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1167 , op == O_DISPOSE ? "_DISPOSE" : 1168 opt('t') ? "_NEWZ" : "_NEW" ); 1169 ap = stklval(argv[1], op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1170 if (ap == NIL) 1171 return; 1172 if (ap->class != PTR) { 1173 error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1174 return; 1175 } 1176 ap = ap->type; 1177 if (ap == NIL) 1178 return; 1179 argv = argv[2]; 1180 if (argv != NIL) { 1181 if (ap->class != RECORD) { 1182 error("Record required when specifying variant tags"); 1183 return; 1184 } 1185 for (; argv != NIL; argv = argv[2]) { 1186 if (ap->ptr[NL_VARNT] == NIL) { 1187 error("Too many tag fields"); 1188 return; 1189 } 1190 if (!isconst(argv[1])) { 1191 error("Second and successive arguments to %s must be constants", p->symbol); 1192 return; 1193 } 1194 gconst(argv[1]); 1195 if (con.ctype == NIL) 1196 return; 1197 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 1198 cerror("Specified tag constant type clashed with variant case selector type"); 1199 return; 1200 } 1201 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1202 if (ap->range[0] == con.crval) 1203 break; 1204 if (ap == NIL) { 1205 error("No variant case label value equals specified constant value"); 1206 return; 1207 } 1208 ap = ap->ptr[NL_VTOREC]; 1209 } 1210 } 1211 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1212 putop( P2LISTOP , P2INT ); 1213 putop( P2CALL , P2INT ); 1214 putdot( filename , line ); 1215 return; 1216 1217 case O_DATE: 1218 case O_TIME: 1219 if (argc != 1) { 1220 error("%s expects one argument", p->symbol); 1221 return; 1222 } 1223 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1224 , op == O_DATE ? "_DATE" : "_TIME" ); 1225 ap = stklval(argv[1], MOD|NOUSE); 1226 if (ap == NIL) 1227 return; 1228 if (classify(ap) != TSTR || width(ap) != 10) { 1229 error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1230 return; 1231 } 1232 putop( P2CALL , P2INT ); 1233 putdot( filename , line ); 1234 return; 1235 1236 case O_HALT: 1237 if (argc != 0) { 1238 error("halt takes no arguments"); 1239 return; 1240 } 1241 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1242 , "_HALT" ); 1243 1244 putop( P2UNARY P2CALL , P2INT ); 1245 putdot( filename , line ); 1246 noreach = 1; 1247 return; 1248 1249 case O_ARGV: 1250 if (argc != 2) { 1251 error("argv takes two arguments"); 1252 return; 1253 } 1254 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1255 , "_ARGV" ); 1256 ap = stkrval(argv[1], NIL , RREQ ); 1257 if (ap == NIL) 1258 return; 1259 if (isnta(ap, "i")) { 1260 error("argv's first argument must be an integer, not %s", nameof(ap)); 1261 return; 1262 } 1263 al = argv[2]; 1264 ap = stklval(al[1], MOD|NOUSE); 1265 if (ap == NIL) 1266 return; 1267 if (classify(ap) != TSTR) { 1268 error("argv's second argument must be a string, not %s", nameof(ap)); 1269 return; 1270 } 1271 putop( P2LISTOP , P2INT ); 1272 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1273 putop( P2LISTOP , P2INT ); 1274 putop( P2CALL , P2INT ); 1275 putdot( filename , line ); 1276 return; 1277 1278 case O_STLIM: 1279 if (argc != 1) { 1280 error("stlimit requires one argument"); 1281 return; 1282 } 1283 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1284 , "_STLIM" ); 1285 ap = stkrval(argv[1], NIL , RREQ ); 1286 if (ap == NIL) 1287 return; 1288 if (isnta(ap, "i")) { 1289 error("stlimit's argument must be an integer, not %s", nameof(ap)); 1290 return; 1291 } 1292 putop( P2CALL , P2INT ); 1293 putdot( filename , line ); 1294 return; 1295 1296 case O_REMOVE: 1297 if (argc != 1) { 1298 error("remove expects one argument"); 1299 return; 1300 } 1301 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1302 , "_REMOVE" ); 1303 ap = stkrval(argv[1], NOFLAGS , RREQ ); 1304 if (ap == NIL) 1305 return; 1306 if (classify(ap) != TSTR) { 1307 error("remove's argument must be a string, not %s", nameof(ap)); 1308 return; 1309 } 1310 putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1311 putop( P2LISTOP , P2INT ); 1312 putop( P2CALL , P2INT ); 1313 putdot( filename , line ); 1314 return; 1315 1316 case O_LLIMIT: 1317 if (argc != 2) { 1318 error("linelimit expects two arguments"); 1319 return; 1320 } 1321 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1322 , "_LLIMIT" ); 1323 ap = stklval(argv[1], NOFLAGS|NOUSE); 1324 if (ap == NIL) 1325 return; 1326 if (!text(ap)) { 1327 error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1328 return; 1329 } 1330 al = argv[2]; 1331 ap = stkrval(al[1], NIL , RREQ ); 1332 if (ap == NIL) 1333 return; 1334 if (isnta(ap, "i")) { 1335 error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1336 return; 1337 } 1338 putop( P2LISTOP , P2INT ); 1339 putop( P2CALL , P2INT ); 1340 putdot( filename , line ); 1341 return; 1342 case O_PAGE: 1343 if (argc != 1) { 1344 error("page expects one argument"); 1345 return; 1346 } 1347 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1348 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1349 , "_UNIT" ); 1350 ap = stklval(argv[1], NOFLAGS); 1351 if (ap == NIL) 1352 return; 1353 if (!text(ap)) { 1354 error("Argument to page must be a text file, not %s", nameof(ap)); 1355 return; 1356 } 1357 putop( P2CALL , P2INT ); 1358 putop( P2ASSIGN , P2PTR|P2STRTY ); 1359 putdot( filename , line ); 1360 if ( opt( 't' ) ) { 1361 putleaf( P2ICON , 0 , 0 1362 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1363 , "_PAGE" ); 1364 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1365 } else { 1366 putleaf( P2ICON , 0 , 0 1367 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1368 , "_fputc" ); 1369 putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 ); 1370 putleaf( P2ICON , 0 , 0 1371 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1372 , "_ACTFILE" ); 1373 putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1374 putop( P2CALL , P2INT ); 1375 putop( P2LISTOP , P2INT ); 1376 } 1377 putop( P2CALL , P2INT ); 1378 putdot( filename , line ); 1379 return; 1380 1381 case O_PACK: 1382 if (argc != 3) { 1383 error("pack expects three arguments"); 1384 return; 1385 } 1386 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1387 , "_PACK" ); 1388 pu = "pack(a,i,z)"; 1389 pua = (al = argv)[1]; 1390 pui = (al = al[2])[1]; 1391 puz = (al = al[2])[1]; 1392 goto packunp; 1393 case O_UNPACK: 1394 if (argc != 3) { 1395 error("unpack expects three arguments"); 1396 return; 1397 } 1398 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1399 , "_UNPACK" ); 1400 pu = "unpack(z,a,i)"; 1401 puz = (al = argv)[1]; 1402 pua = (al = al[2])[1]; 1403 pui = (al = al[2])[1]; 1404 packunp: 1405 ap = stkrval((int *) pui, NLNIL , RREQ ); 1406 if (ap == NIL) 1407 return; 1408 ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1409 if (ap == NIL) 1410 return; 1411 if (ap->class != ARRAY) { 1412 error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1413 return; 1414 } 1415 putop( P2LISTOP , P2INT ); 1416 al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1417 if (al->class != ARRAY) { 1418 error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1419 return; 1420 } 1421 if (al->type == NIL || ap->type == NIL) 1422 return; 1423 if (al->type != ap->type) { 1424 error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1425 return; 1426 } 1427 putop( P2LISTOP , P2INT ); 1428 k = width(al); 1429 itemwidth = width(ap->type); 1430 ap = ap->chain; 1431 al = al->chain; 1432 if (ap->chain != NIL || al->chain != NIL) { 1433 error("%s requires a and z to be single dimension arrays", pu); 1434 return; 1435 } 1436 if (ap == NIL || al == NIL) 1437 return; 1438 /* 1439 * al is the range for z i.e. u..v 1440 * ap is the range for a i.e. m..n 1441 * i will be n-m+1 1442 * j will be v-u+1 1443 */ 1444 i = ap->range[1] - ap->range[0] + 1; 1445 j = al->range[1] - al->range[0] + 1; 1446 if (i < j) { 1447 error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1448 return; 1449 } 1450 /* 1451 * get n-m-(v-u) and m for the interpreter 1452 */ 1453 i -= j; 1454 j = ap->range[0]; 1455 putleaf( P2ICON , itemwidth , 0 , P2INT , 0 ); 1456 putop( P2LISTOP , P2INT ); 1457 putleaf( P2ICON , j , 0 , P2INT , 0 ); 1458 putop( P2LISTOP , P2INT ); 1459 putleaf( P2ICON , i , 0 , P2INT , 0 ); 1460 putop( P2LISTOP , P2INT ); 1461 putleaf( P2ICON , k , 0 , P2INT , 0 ); 1462 putop( P2LISTOP , P2INT ); 1463 putop( P2CALL , P2INT ); 1464 putdot( filename , line ); 1465 return; 1466 case 0: 1467 error("%s is an unimplemented 6400 extension", p->symbol); 1468 return; 1469 1470 default: 1471 panic("proc case"); 1472 } 1473 } 1474 #endif PC 1475