![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pcproc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / src|
Return to pcproc.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / src |
1.1 ! root 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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.