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