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