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