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