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