![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to proc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / pascal / src|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / pascal / src |
1.1 ! root 1: /* Copyright (c) 1979 Regents of the University of California */ ! 2: ! 3: static char sccsid[] = "@(#)proc.c 1.18 4/8/83"; ! 4: ! 5: #include "whoami.h" ! 6: #ifdef OBJ ! 7: /* ! 8: * and the rest of the file ! 9: */ ! 10: #include "0.h" ! 11: #include "tree.h" ! 12: #include "opcode.h" ! 13: #include "objfmt.h" ! 14: #include "tmps.h" ! 15: ! 16: /* ! 17: * The constant EXPOSIZE specifies the number of digits in the exponent ! 18: * of real numbers. ! 19: * ! 20: * The constant REALSPC defines the amount of forced padding preceeding ! 21: * real numbers when they are printed. If REALSPC == 0, then no padding ! 22: * is added, REALSPC == 1 adds one extra blank irregardless of the width ! 23: * specified by the user. ! 24: * ! 25: * N.B. - Values greater than one require program mods. ! 26: */ ! 27: #define EXPOSIZE 2 ! 28: #define REALSPC 0 ! 29: ! 30: /* ! 31: * The following array is used to determine which classes may be read ! 32: * from textfiles. It is indexed by the return value from classify. ! 33: */ ! 34: #define rdops(x) rdxxxx[(x)-(TFIRST)] ! 35: ! 36: int rdxxxx[] = { ! 37: 0, /* -7 file types */ ! 38: 0, /* -6 record types */ ! 39: 0, /* -5 array types */ ! 40: O_READE, /* -4 scalar types */ ! 41: 0, /* -3 pointer types */ ! 42: 0, /* -2 set types */ ! 43: 0, /* -1 string types */ ! 44: 0, /* 0 nil, no type */ ! 45: O_READE, /* 1 boolean */ ! 46: O_READC, /* 2 character */ ! 47: O_READ4, /* 3 integer */ ! 48: O_READ8 /* 4 real */ ! 49: }; ! 50: ! 51: /* ! 52: * Proc handles procedure calls. ! 53: * Non-builtin procedures are "buck-passed" to func (with a flag ! 54: * indicating that they are actually procedures. ! 55: * builtin procedures are handled here. ! 56: */ ! 57: proc(r) ! 58: int *r; ! 59: { ! 60: register struct nl *p; ! 61: register int *alv, *al, op; ! 62: struct nl *filetype, *ap; ! 63: int argc, *argv, typ, fmtspec, strfmt, stkcnt, *file; ! 64: char fmt, format[20], *strptr; ! 65: int prec, field, strnglen, fmtlen, fmtstart, pu; ! 66: int *pua, *pui, *puz; ! 67: int i, j, k; ! 68: int itemwidth; ! 69: struct tmps soffset; ! 70: struct nl *tempnlp; ! 71: ! 72: #define CONPREC 4 ! 73: #define VARPREC 8 ! 74: #define CONWIDTH 1 ! 75: #define VARWIDTH 2 ! 76: #define SKIP 16 ! 77: ! 78: /* ! 79: * Verify that the name is ! 80: * defined and is that of a ! 81: * procedure. ! 82: */ ! 83: p = lookup(r[2]); ! 84: if (p == NIL) { ! 85: rvlist(r[3]); ! 86: return; ! 87: } ! 88: if (p->class != PROC && p->class != FPROC) { ! 89: error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); ! 90: rvlist(r[3]); ! 91: return; ! 92: } ! 93: argv = r[3]; ! 94: ! 95: /* ! 96: * Call handles user defined ! 97: * procedures and functions. ! 98: */ ! 99: if (bn != 0) { ! 100: call(p, argv, PROC, bn); ! 101: return; ! 102: } ! 103: ! 104: /* ! 105: * Call to built-in procedure. ! 106: * Count the arguments. ! 107: */ ! 108: argc = 0; ! 109: for (al = argv; al != NIL; al = al[2]) ! 110: argc++; ! 111: ! 112: /* ! 113: * Switch on the operator ! 114: * associated with the built-in ! 115: * procedure in the namelist ! 116: */ ! 117: op = p->value[0] &~ NSTAND; ! 118: if (opt('s') && (p->value[0] & NSTAND)) { ! 119: standard(); ! 120: error("%s is a nonstandard procedure", p->symbol); ! 121: } ! 122: switch (op) { ! 123: ! 124: case O_ABORT: ! 125: if (argc != 0) ! 126: error("null takes no arguments"); ! 127: return; ! 128: ! 129: case O_FLUSH: ! 130: if (argc == 0) { ! 131: put(1, O_MESSAGE); ! 132: return; ! 133: } ! 134: if (argc != 1) { ! 135: error("flush takes at most one argument"); ! 136: return; ! 137: } ! 138: ap = stklval(argv[1], NIL , LREQ ); ! 139: if (ap == NIL) ! 140: return; ! 141: if (ap->class != FILET) { ! 142: error("flush's argument must be a file, not %s", nameof(ap)); ! 143: return; ! 144: } ! 145: put(1, op); ! 146: return; ! 147: ! 148: case O_MESSAGE: ! 149: case O_WRITEF: ! 150: case O_WRITLN: ! 151: /* ! 152: * Set up default file "output"'s type ! 153: */ ! 154: file = NIL; ! 155: filetype = nl+T1CHAR; ! 156: /* ! 157: * Determine the file implied ! 158: * for the write and generate ! 159: * code to make it the active file. ! 160: */ ! 161: if (op == O_MESSAGE) { ! 162: /* ! 163: * For message, all that matters ! 164: * is that the filetype is ! 165: * a character file. ! 166: * Thus "output" will suit us fine. ! 167: */ ! 168: put(1, O_MESSAGE); ! 169: } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) { ! 170: /* ! 171: * If there is a first argument which has ! 172: * no write widths, then it is potentially ! 173: * a file name. ! 174: */ ! 175: codeoff(); ! 176: ap = stkrval(argv[1], NIL , RREQ ); ! 177: codeon(); ! 178: if (ap == NIL) ! 179: argv = argv[2]; ! 180: if (ap != NIL && ap->class == FILET) { ! 181: /* ! 182: * Got "write(f, ...", make ! 183: * f the active file, and save ! 184: * it and its type for use in ! 185: * processing the rest of the ! 186: * arguments to write. ! 187: */ ! 188: file = argv[1]; ! 189: filetype = ap->type; ! 190: stklval(argv[1], NIL , LREQ ); ! 191: put(1, O_UNIT); ! 192: /* ! 193: * Skip over the first argument ! 194: */ ! 195: argv = argv[2]; ! 196: argc--; ! 197: } else { ! 198: /* ! 199: * Set up for writing on ! 200: * standard output. ! 201: */ ! 202: put(1, O_UNITOUT); ! 203: output->nl_flags |= NUSED; ! 204: } ! 205: } else { ! 206: put(1, O_UNITOUT); ! 207: output->nl_flags |= NUSED; ! 208: } ! 209: /* ! 210: * Loop and process each ! 211: * of the arguments. ! 212: */ ! 213: for (; argv != NIL; argv = argv[2]) { ! 214: /* ! 215: * fmtspec indicates the type (CONstant or VARiable) ! 216: * and number (none, WIDTH, and/or PRECision) ! 217: * of the fields in the printf format for this ! 218: * output variable. ! 219: * stkcnt is the number of bytes pushed on the stack ! 220: * fmt is the format output indicator (D, E, F, O, X, S) ! 221: * fmtstart = 0 for leading blank; = 1 for no blank ! 222: */ ! 223: fmtspec = NIL; ! 224: stkcnt = 0; ! 225: fmt = 'D'; ! 226: fmtstart = 1; ! 227: al = argv[1]; ! 228: if (al == NIL) ! 229: continue; ! 230: if (al[0] == T_WEXP) ! 231: alv = al[1]; ! 232: else ! 233: alv = al; ! 234: if (alv == NIL) ! 235: continue; ! 236: codeoff(); ! 237: ap = stkrval(alv, NIL , RREQ ); ! 238: codeon(); ! 239: if (ap == NIL) ! 240: continue; ! 241: typ = classify(ap); ! 242: if (al[0] == T_WEXP) { ! 243: /* ! 244: * Handle width expressions. ! 245: * The basic game here is that width ! 246: * expressions get evaluated. If they ! 247: * are constant, the value is placed ! 248: * directly in the format string. ! 249: * Otherwise the value is pushed onto ! 250: * the stack and an indirection is ! 251: * put into the format string. ! 252: */ ! 253: if (al[3] == OCT) ! 254: fmt = 'O'; ! 255: else if (al[3] == HEX) ! 256: fmt = 'X'; ! 257: else if (al[3] != NIL) { ! 258: /* ! 259: * Evaluate second format spec ! 260: */ ! 261: if ( constval(al[3]) ! 262: && isa( con.ctype , "i" ) ) { ! 263: fmtspec += CONPREC; ! 264: prec = con.crval; ! 265: } else { ! 266: fmtspec += VARPREC; ! 267: } ! 268: fmt = 'f'; ! 269: switch ( typ ) { ! 270: case TINT: ! 271: if ( opt( 's' ) ) { ! 272: standard(); ! 273: error("Writing %ss with two write widths is non-standard", clnames[typ]); ! 274: } ! 275: /* and fall through */ ! 276: case TDOUBLE: ! 277: break; ! 278: default: ! 279: error("Cannot write %ss with two write widths", clnames[typ]); ! 280: continue; ! 281: } ! 282: } ! 283: /* ! 284: * Evaluate first format spec ! 285: */ ! 286: if (al[2] != NIL) { ! 287: if ( constval(al[2]) ! 288: && isa( con.ctype , "i" ) ) { ! 289: fmtspec += CONWIDTH; ! 290: field = con.crval; ! 291: } else { ! 292: fmtspec += VARWIDTH; ! 293: } ! 294: } ! 295: if ((fmtspec & CONPREC) && prec < 0 || ! 296: (fmtspec & CONWIDTH) && field < 0) { ! 297: error("Negative widths are not allowed"); ! 298: continue; ! 299: } ! 300: if ( opt('s') && ! 301: ((fmtspec & CONPREC) && prec == 0 || ! 302: (fmtspec & CONWIDTH) && field == 0)) { ! 303: standard(); ! 304: error("Zero widths are non-standard"); ! 305: } ! 306: } ! 307: if (filetype != nl+T1CHAR) { ! 308: if (fmt == 'O' || fmt == 'X') { ! 309: error("Oct/hex allowed only on text files"); ! 310: continue; ! 311: } ! 312: if (fmtspec) { ! 313: error("Write widths allowed only on text files"); ! 314: continue; ! 315: } ! 316: /* ! 317: * Generalized write, i.e. ! 318: * to a non-textfile. ! 319: */ ! 320: stklval(file, NIL , LREQ ); ! 321: put(1, O_FNIL); ! 322: /* ! 323: * file^ := ... ! 324: */ ! 325: ap = rvalue(argv[1], NIL); ! 326: if (ap == NIL) ! 327: continue; ! 328: if (incompat(ap, filetype, argv[1])) { ! 329: cerror("Type mismatch in write to non-text file"); ! 330: continue; ! 331: } ! 332: convert(ap, filetype); ! 333: put(2, O_AS, width(filetype)); ! 334: /* ! 335: * put(file) ! 336: */ ! 337: put(1, O_PUT); ! 338: continue; ! 339: } ! 340: /* ! 341: * Write to a textfile ! 342: * ! 343: * Evaluate the expression ! 344: * to be written. ! 345: */ ! 346: if (fmt == 'O' || fmt == 'X') { ! 347: if (opt('s')) { ! 348: standard(); ! 349: error("Oct and hex are non-standard"); ! 350: } ! 351: if (typ == TSTR || typ == TDOUBLE) { ! 352: error("Can't write %ss with oct/hex", clnames[typ]); ! 353: continue; ! 354: } ! 355: if (typ == TCHAR || typ == TBOOL) ! 356: typ = TINT; ! 357: } ! 358: /* ! 359: * Place the arguement on the stack. If there is ! 360: * no format specified by the programmer, implement ! 361: * the default. ! 362: */ ! 363: switch (typ) { ! 364: case TPTR: ! 365: warning(); ! 366: if (opt('s')) { ! 367: standard(); ! 368: } ! 369: error("Writing %ss to text files is non-standard", ! 370: clnames[typ]); ! 371: /* and fall through */ ! 372: case TINT: ! 373: if (fmt != 'f') { ! 374: ap = stkrval(alv, NIL , RREQ ); ! 375: stkcnt += sizeof(long); ! 376: } else { ! 377: ap = stkrval(alv, NIL , RREQ ); ! 378: put(1, O_ITOD); ! 379: stkcnt += sizeof(double); ! 380: typ = TDOUBLE; ! 381: goto tdouble; ! 382: } ! 383: if (fmtspec == NIL) { ! 384: if (fmt == 'D') ! 385: field = 10; ! 386: else if (fmt == 'X') ! 387: field = 8; ! 388: else if (fmt == 'O') ! 389: field = 11; ! 390: else ! 391: panic("fmt1"); ! 392: fmtspec = CONWIDTH; ! 393: } ! 394: break; ! 395: case TCHAR: ! 396: tchar: ! 397: if (fmtspec == NIL) { ! 398: put(1, O_FILE); ! 399: ap = stkrval(alv, NIL , RREQ ); ! 400: convert(nl + T4INT, INT_TYP); ! 401: put(2, O_WRITEC, ! 402: sizeof(char *) + sizeof(int)); ! 403: fmtspec = SKIP; ! 404: break; ! 405: } ! 406: ap = stkrval(alv, NIL , RREQ ); ! 407: convert(nl + T4INT, INT_TYP); ! 408: stkcnt += sizeof(int); ! 409: fmt = 'c'; ! 410: break; ! 411: case TSCAL: ! 412: warning(); ! 413: if (opt('s')) { ! 414: standard(); ! 415: } ! 416: error("Writing %ss to text files is non-standard", ! 417: clnames[typ]); ! 418: /* and fall through */ ! 419: case TBOOL: ! 420: stkrval(alv, NIL , RREQ ); ! 421: put(2, O_NAM, (long)listnames(ap)); ! 422: stkcnt += sizeof(char *); ! 423: fmt = 's'; ! 424: break; ! 425: case TDOUBLE: ! 426: ap = stkrval(alv, TDOUBLE , RREQ ); ! 427: stkcnt += sizeof(double); ! 428: tdouble: ! 429: switch (fmtspec) { ! 430: case NIL: ! 431: field = 14 + (5 + EXPOSIZE); ! 432: prec = field - (5 + EXPOSIZE); ! 433: fmt = 'e'; ! 434: fmtspec = CONWIDTH + CONPREC; ! 435: break; ! 436: case CONWIDTH: ! 437: field -= REALSPC; ! 438: if (field < 1) ! 439: field = 1; ! 440: prec = field - (5 + EXPOSIZE); ! 441: if (prec < 1) ! 442: prec = 1; ! 443: fmtspec += CONPREC; ! 444: fmt = 'e'; ! 445: break; ! 446: case CONWIDTH + CONPREC: ! 447: case CONWIDTH + VARPREC: ! 448: field -= REALSPC; ! 449: if (field < 1) ! 450: field = 1; ! 451: } ! 452: format[0] = ' '; ! 453: fmtstart = 1 - REALSPC; ! 454: break; ! 455: case TSTR: ! 456: constval( alv ); ! 457: switch ( classify( con.ctype ) ) { ! 458: case TCHAR: ! 459: typ = TCHAR; ! 460: goto tchar; ! 461: case TSTR: ! 462: strptr = con.cpval; ! 463: for (strnglen = 0; *strptr++; strnglen++) /* void */; ! 464: strptr = con.cpval; ! 465: break; ! 466: default: ! 467: strnglen = width(ap); ! 468: break; ! 469: } ! 470: fmt = 's'; ! 471: strfmt = fmtspec; ! 472: if (fmtspec == NIL) { ! 473: fmtspec = SKIP; ! 474: break; ! 475: } ! 476: if (fmtspec & CONWIDTH) { ! 477: if (field <= strnglen) { ! 478: fmtspec = SKIP; ! 479: break; ! 480: } else ! 481: field -= strnglen; ! 482: } ! 483: /* ! 484: * push string to implement leading blank padding ! 485: */ ! 486: put(2, O_LVCON, 2); ! 487: putstr("", 0); ! 488: stkcnt += sizeof(char *); ! 489: break; ! 490: default: ! 491: error("Can't write %ss to a text file", clnames[typ]); ! 492: continue; ! 493: } ! 494: /* ! 495: * If there is a variable precision, evaluate it onto ! 496: * the stack ! 497: */ ! 498: if (fmtspec & VARPREC) { ! 499: ap = stkrval(al[3], NIL , RREQ ); ! 500: if (ap == NIL) ! 501: continue; ! 502: if (isnta(ap,"i")) { ! 503: error("Second write width must be integer, not %s", nameof(ap)); ! 504: continue; ! 505: } ! 506: if ( opt( 't' ) ) { ! 507: put(3, O_MAX, 0, 0); ! 508: } ! 509: convert(nl+T4INT, INT_TYP); ! 510: stkcnt += sizeof(int); ! 511: } ! 512: /* ! 513: * If there is a variable width, evaluate it onto ! 514: * the stack ! 515: */ ! 516: if (fmtspec & VARWIDTH) { ! 517: if ( ( typ == TDOUBLE && fmtspec == VARWIDTH ) ! 518: || typ == TSTR ) { ! 519: soffset = sizes[cbn].curtmps; ! 520: tempnlp = tmpalloc(sizeof(long), ! 521: nl+T4INT, REGOK); ! 522: put(2, O_LV | cbn << 8 + INDX, ! 523: tempnlp -> value[ NL_OFFS ] ); ! 524: } ! 525: ap = stkrval(al[2], NIL , RREQ ); ! 526: if (ap == NIL) ! 527: continue; ! 528: if (isnta(ap,"i")) { ! 529: error("First write width must be integer, not %s", nameof(ap)); ! 530: continue; ! 531: } ! 532: /* ! 533: * Perform special processing on widths based ! 534: * on data type ! 535: */ ! 536: switch (typ) { ! 537: case TDOUBLE: ! 538: if (fmtspec == VARWIDTH) { ! 539: fmt = 'e'; ! 540: put(1, O_AS4); ! 541: put(2, O_RV4 | cbn << 8 + INDX, ! 542: tempnlp -> value[NL_OFFS] ); ! 543: put(3, O_MAX, ! 544: 5 + EXPOSIZE + REALSPC, 1); ! 545: convert(nl+T4INT, INT_TYP); ! 546: stkcnt += sizeof(int); ! 547: put(2, O_RV4 | cbn << 8 + INDX, ! 548: tempnlp->value[NL_OFFS] ); ! 549: fmtspec += VARPREC; ! 550: tmpfree(&soffset); ! 551: } ! 552: put(3, O_MAX, REALSPC, 1); ! 553: break; ! 554: case TSTR: ! 555: put(1, O_AS4); ! 556: put(2, O_RV4 | cbn << 8 + INDX, ! 557: tempnlp -> value[ NL_OFFS ] ); ! 558: put(3, O_MAX, strnglen, 0); ! 559: break; ! 560: default: ! 561: if ( opt( 't' ) ) { ! 562: put(3, O_MAX, 0, 0); ! 563: } ! 564: break; ! 565: } ! 566: convert(nl+T4INT, INT_TYP); ! 567: stkcnt += sizeof(int); ! 568: } ! 569: /* ! 570: * Generate the format string ! 571: */ ! 572: switch (fmtspec) { ! 573: default: ! 574: panic("fmt2"); ! 575: case SKIP: ! 576: break; ! 577: case NIL: ! 578: sprintf(&format[1], "%%%c", fmt); ! 579: goto fmtgen; ! 580: case CONWIDTH: ! 581: sprintf(&format[1], "%%%d%c", field, fmt); ! 582: goto fmtgen; ! 583: case VARWIDTH: ! 584: sprintf(&format[1], "%%*%c", fmt); ! 585: goto fmtgen; ! 586: case CONWIDTH + CONPREC: ! 587: sprintf(&format[1], "%%%d.%d%c", field, prec, fmt); ! 588: goto fmtgen; ! 589: case CONWIDTH + VARPREC: ! 590: sprintf(&format[1], "%%%d.*%c", field, fmt); ! 591: goto fmtgen; ! 592: case VARWIDTH + CONPREC: ! 593: sprintf(&format[1], "%%*.%d%c", prec, fmt); ! 594: goto fmtgen; ! 595: case VARWIDTH + VARPREC: ! 596: sprintf(&format[1], "%%*.*%c", fmt); ! 597: fmtgen: ! 598: fmtlen = lenstr(&format[fmtstart], 0); ! 599: put(2, O_LVCON, fmtlen); ! 600: putstr(&format[fmtstart], 0); ! 601: put(1, O_FILE); ! 602: stkcnt += 2 * sizeof(char *); ! 603: put(2, O_WRITEF, stkcnt); ! 604: } ! 605: /* ! 606: * Write the string after its blank padding ! 607: */ ! 608: if (typ == TSTR) { ! 609: put(1, O_FILE); ! 610: put(2, CON_INT, 1); ! 611: if (strfmt & VARWIDTH) { ! 612: put(2, O_RV4 | cbn << 8 + INDX , ! 613: tempnlp -> value[ NL_OFFS ] ); ! 614: put(2, O_MIN, strnglen); ! 615: convert(nl+T4INT, INT_TYP); ! 616: tmpfree(&soffset); ! 617: } else { ! 618: if ((fmtspec & SKIP) && ! 619: (strfmt & CONWIDTH)) { ! 620: strnglen = field; ! 621: } ! 622: put(2, CON_INT, strnglen); ! 623: } ! 624: ap = stkrval(alv, NIL , RREQ ); ! 625: put(2, O_WRITES, ! 626: 2 * sizeof(char *) + 2 * sizeof(int)); ! 627: } ! 628: } ! 629: /* ! 630: * Done with arguments. ! 631: * Handle writeln and ! 632: * insufficent number of args. ! 633: */ ! 634: switch (p->value[0] &~ NSTAND) { ! 635: case O_WRITEF: ! 636: if (argc == 0) ! 637: error("Write requires an argument"); ! 638: break; ! 639: case O_MESSAGE: ! 640: if (argc == 0) ! 641: error("Message requires an argument"); ! 642: case O_WRITLN: ! 643: if (filetype != nl+T1CHAR) ! 644: error("Can't 'writeln' a non text file"); ! 645: put(1, O_WRITLN); ! 646: break; ! 647: } ! 648: return; ! 649: ! 650: case O_READ4: ! 651: case O_READLN: ! 652: /* ! 653: * Set up default ! 654: * file "input". ! 655: */ ! 656: file = NIL; ! 657: filetype = nl+T1CHAR; ! 658: /* ! 659: * Determine the file implied ! 660: * for the read and generate ! 661: * code to make it the active file. ! 662: */ ! 663: if (argv != NIL) { ! 664: codeoff(); ! 665: ap = stkrval(argv[1], NIL , RREQ ); ! 666: codeon(); ! 667: if (ap == NIL) ! 668: argv = argv[2]; ! 669: if (ap != NIL && ap->class == FILET) { ! 670: /* ! 671: * Got "read(f, ...", make ! 672: * f the active file, and save ! 673: * it and its type for use in ! 674: * processing the rest of the ! 675: * arguments to read. ! 676: */ ! 677: file = argv[1]; ! 678: filetype = ap->type; ! 679: stklval(argv[1], NIL , LREQ ); ! 680: put(1, O_UNIT); ! 681: argv = argv[2]; ! 682: argc--; ! 683: } else { ! 684: /* ! 685: * Default is read from ! 686: * standard input. ! 687: */ ! 688: put(1, O_UNITINP); ! 689: input->nl_flags |= NUSED; ! 690: } ! 691: } else { ! 692: put(1, O_UNITINP); ! 693: input->nl_flags |= NUSED; ! 694: } ! 695: /* ! 696: * Loop and process each ! 697: * of the arguments. ! 698: */ ! 699: for (; argv != NIL; argv = argv[2]) { ! 700: /* ! 701: * Get the address of the target ! 702: * on the stack. ! 703: */ ! 704: al = argv[1]; ! 705: if (al == NIL) ! 706: continue; ! 707: if (al[0] != T_VAR) { ! 708: error("Arguments to %s must be variables, not expressions", p->symbol); ! 709: continue; ! 710: } ! 711: ap = stklval(al, MOD|ASGN|NOUSE); ! 712: if (ap == NIL) ! 713: continue; ! 714: if (filetype != nl+T1CHAR) { ! 715: /* ! 716: * Generalized read, i.e. ! 717: * from a non-textfile. ! 718: */ ! 719: if (incompat(filetype, ap, argv[1] )) { ! 720: error("Type mismatch in read from non-text file"); ! 721: continue; ! 722: } ! 723: /* ! 724: * var := file ^; ! 725: */ ! 726: if (file != NIL) ! 727: stklval(file, NIL , LREQ ); ! 728: else /* Magic */ ! 729: put(2, PTR_RV, (int)input->value[0]); ! 730: put(1, O_FNIL); ! 731: put(2, O_IND, width(filetype)); ! 732: convert(filetype, ap); ! 733: if (isa(ap, "bsci")) ! 734: rangechk(ap, ap); ! 735: put(2, O_AS, width(ap)); ! 736: /* ! 737: * get(file); ! 738: */ ! 739: put(1, O_GET); ! 740: continue; ! 741: } ! 742: typ = classify(ap); ! 743: op = rdops(typ); ! 744: if (op == NIL) { ! 745: error("Can't read %ss from a text file", clnames[typ]); ! 746: continue; ! 747: } ! 748: if (op != O_READE) ! 749: put(1, op); ! 750: else { ! 751: put(2, op, (long)listnames(ap)); ! 752: warning(); ! 753: if (opt('s')) { ! 754: standard(); ! 755: } ! 756: error("Reading scalars from text files is non-standard"); ! 757: } ! 758: /* ! 759: * Data read is on the stack. ! 760: * Assign it. ! 761: */ ! 762: if (op != O_READ8 && op != O_READE) ! 763: rangechk(ap, op == O_READC ? ap : nl+T4INT); ! 764: gen(O_AS2, O_AS2, width(ap), ! 765: op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2); ! 766: } ! 767: /* ! 768: * Done with arguments. ! 769: * Handle readln and ! 770: * insufficient number of args. ! 771: */ ! 772: if (p->value[0] == O_READLN) { ! 773: if (filetype != nl+T1CHAR) ! 774: error("Can't 'readln' a non text file"); ! 775: put(1, O_READLN); ! 776: } ! 777: else if (argc == 0) ! 778: error("read requires an argument"); ! 779: return; ! 780: ! 781: case O_GET: ! 782: case O_PUT: ! 783: if (argc != 1) { ! 784: error("%s expects one argument", p->symbol); ! 785: return; ! 786: } ! 787: ap = stklval(argv[1], NIL , LREQ ); ! 788: if (ap == NIL) ! 789: return; ! 790: if (ap->class != FILET) { ! 791: error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); ! 792: return; ! 793: } ! 794: put(1, O_UNIT); ! 795: put(1, op); ! 796: return; ! 797: ! 798: case O_RESET: ! 799: case O_REWRITE: ! 800: if (argc == 0 || argc > 2) { ! 801: error("%s expects one or two arguments", p->symbol); ! 802: return; ! 803: } ! 804: if (opt('s') && argc == 2) { ! 805: standard(); ! 806: error("Two argument forms of reset and rewrite are non-standard"); ! 807: } ! 808: codeoff(); ! 809: ap = stklval(argv[1], MOD|NOUSE); ! 810: codeon(); ! 811: if (ap == NIL) ! 812: return; ! 813: if (ap->class != FILET) { ! 814: error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); ! 815: return; ! 816: } ! 817: put(2, O_CON24, text(ap) ? 0: width(ap->type)); ! 818: if (argc == 2) { ! 819: /* ! 820: * Optional second argument ! 821: * is a string name of a ! 822: * UNIX (R) file to be associated. ! 823: */ ! 824: al = argv[2]; ! 825: codeoff(); ! 826: al = stkrval(al[1], NOFLAGS , RREQ ); ! 827: codeon(); ! 828: if (al == NIL) ! 829: return; ! 830: if (classify(al) != TSTR) { ! 831: error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); ! 832: return; ! 833: } ! 834: put(2, O_CON24, width(al)); ! 835: al = argv[2]; ! 836: al = stkrval(al[1], NOFLAGS , RREQ ); ! 837: } else { ! 838: put(2, O_CON24, 0); ! 839: put(2, PTR_CON, NIL); ! 840: } ! 841: ap = stklval(argv[1], MOD|NOUSE); ! 842: put(1, op); ! 843: return; ! 844: ! 845: case O_NEW: ! 846: case O_DISPOSE: ! 847: if (argc == 0) { ! 848: error("%s expects at least one argument", p->symbol); ! 849: return; ! 850: } ! 851: ap = stklval(argv[1], op == O_NEW ? ( MOD | NOUSE ) : MOD ); ! 852: if (ap == NIL) ! 853: return; ! 854: if (ap->class != PTR) { ! 855: error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); ! 856: return; ! 857: } ! 858: ap = ap->type; ! 859: if (ap == NIL) ! 860: return; ! 861: if ((ap->nl_flags & NFILES) && op == O_DISPOSE) ! 862: op = O_DFDISP; ! 863: argv = argv[2]; ! 864: if (argv != NIL) { ! 865: if (ap->class != RECORD) { ! 866: error("Record required when specifying variant tags"); ! 867: return; ! 868: } ! 869: for (; argv != NIL; argv = argv[2]) { ! 870: if (ap->ptr[NL_VARNT] == NIL) { ! 871: error("Too many tag fields"); ! 872: return; ! 873: } ! 874: if (!isconst(argv[1])) { ! 875: error("Second and successive arguments to %s must be constants", p->symbol); ! 876: return; ! 877: } ! 878: gconst(argv[1]); ! 879: if (con.ctype == NIL) ! 880: return; ! 881: if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { ! 882: cerror("Specified tag constant type clashed with variant case selector type"); ! 883: return; ! 884: } ! 885: for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) ! 886: if (ap->range[0] == con.crval) ! 887: break; ! 888: if (ap == NIL) { ! 889: error("No variant case label value equals specified constant value"); ! 890: return; ! 891: } ! 892: ap = ap->ptr[NL_VTOREC]; ! 893: } ! 894: } ! 895: put(2, op, width(ap)); ! 896: return; ! 897: ! 898: case O_DATE: ! 899: case O_TIME: ! 900: if (argc != 1) { ! 901: error("%s expects one argument", p->symbol); ! 902: return; ! 903: } ! 904: ap = stklval(argv[1], MOD|NOUSE); ! 905: if (ap == NIL) ! 906: return; ! 907: if (classify(ap) != TSTR || width(ap) != 10) { ! 908: error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); ! 909: return; ! 910: } ! 911: put(1, op); ! 912: return; ! 913: ! 914: case O_HALT: ! 915: if (argc != 0) { ! 916: error("halt takes no arguments"); ! 917: return; ! 918: } ! 919: put(1, op); ! 920: noreach = 1; ! 921: return; ! 922: ! 923: case O_ARGV: ! 924: if (argc != 2) { ! 925: error("argv takes two arguments"); ! 926: return; ! 927: } ! 928: ap = stkrval(argv[1], NIL , RREQ ); ! 929: if (ap == NIL) ! 930: return; ! 931: if (isnta(ap, "i")) { ! 932: error("argv's first argument must be an integer, not %s", nameof(ap)); ! 933: return; ! 934: } ! 935: al = argv[2]; ! 936: ap = stklval(al[1], MOD|NOUSE); ! 937: if (ap == NIL) ! 938: return; ! 939: if (classify(ap) != TSTR) { ! 940: error("argv's second argument must be a string, not %s", nameof(ap)); ! 941: return; ! 942: } ! 943: put(2, op, width(ap)); ! 944: return; ! 945: ! 946: case O_STLIM: ! 947: if (argc != 1) { ! 948: error("stlimit requires one argument"); ! 949: return; ! 950: } ! 951: ap = stkrval(argv[1], NIL , RREQ ); ! 952: if (ap == NIL) ! 953: return; ! 954: if (isnta(ap, "i")) { ! 955: error("stlimit's argument must be an integer, not %s", nameof(ap)); ! 956: return; ! 957: } ! 958: if (width(ap) != 4) ! 959: put(1, O_STOI); ! 960: put(1, op); ! 961: return; ! 962: ! 963: case O_REMOVE: ! 964: if (argc != 1) { ! 965: error("remove expects one argument"); ! 966: return; ! 967: } ! 968: codeoff(); ! 969: ap = stkrval(argv[1], NOFLAGS , RREQ ); ! 970: codeon(); ! 971: if (ap == NIL) ! 972: return; ! 973: if (classify(ap) != TSTR) { ! 974: error("remove's argument must be a string, not %s", nameof(ap)); ! 975: return; ! 976: } ! 977: put(2, O_CON24, width(ap)); ! 978: ap = stkrval(argv[1], NOFLAGS , RREQ ); ! 979: put(1, op); ! 980: return; ! 981: ! 982: case O_LLIMIT: ! 983: if (argc != 2) { ! 984: error("linelimit expects two arguments"); ! 985: return; ! 986: } ! 987: al = argv[2]; ! 988: ap = stkrval(al[1], NIL , RREQ ); ! 989: if (ap == NIL) ! 990: return; ! 991: if (isnta(ap, "i")) { ! 992: error("linelimit's second argument must be an integer, not %s", nameof(ap)); ! 993: return; ! 994: } ! 995: ap = stklval(argv[1], NOFLAGS|NOUSE); ! 996: if (ap == NIL) ! 997: return; ! 998: if (!text(ap)) { ! 999: error("linelimit's first argument must be a text file, not %s", nameof(ap)); ! 1000: return; ! 1001: } ! 1002: put(1, op); ! 1003: return; ! 1004: case O_PAGE: ! 1005: if (argc != 1) { ! 1006: error("page expects one argument"); ! 1007: return; ! 1008: } ! 1009: ap = stklval(argv[1], NIL , LREQ ); ! 1010: if (ap == NIL) ! 1011: return; ! 1012: if (!text(ap)) { ! 1013: error("Argument to page must be a text file, not %s", nameof(ap)); ! 1014: return; ! 1015: } ! 1016: put(1, O_UNIT); ! 1017: put(1, op); ! 1018: return; ! 1019: ! 1020: case O_ASRT: ! 1021: if (!opt('t')) ! 1022: return; ! 1023: if (argc == 0 || argc > 2) { ! 1024: error("Assert expects one or two arguments"); ! 1025: return; ! 1026: } ! 1027: if (argc == 2) { ! 1028: /* ! 1029: * Optional second argument is a string specifying ! 1030: * why the assertion failed. ! 1031: */ ! 1032: al = argv[2]; ! 1033: al = stkrval(al[1], NIL , RREQ ); ! 1034: if (al == NIL) ! 1035: return; ! 1036: if (classify(al) != TSTR) { ! 1037: error("Second argument to assert must be a string, not %s", nameof(al)); ! 1038: return; ! 1039: } ! 1040: } else { ! 1041: put(2, PTR_CON, NIL); ! 1042: } ! 1043: ap = stkrval(argv[1], NIL , RREQ ); ! 1044: if (ap == NIL) ! 1045: return; ! 1046: if (isnta(ap, "b")) ! 1047: error("Assert expression must be Boolean, not %ss", nameof(ap)); ! 1048: put(1, O_ASRT); ! 1049: return; ! 1050: ! 1051: case O_PACK: ! 1052: if (argc != 3) { ! 1053: error("pack expects three arguments"); ! 1054: return; ! 1055: } ! 1056: pu = "pack(a,i,z)"; ! 1057: pua = argv[1]; ! 1058: al = argv[2]; ! 1059: pui = al[1]; ! 1060: alv = al[2]; ! 1061: puz = alv[1]; ! 1062: goto packunp; ! 1063: case O_UNPACK: ! 1064: if (argc != 3) { ! 1065: error("unpack expects three arguments"); ! 1066: return; ! 1067: } ! 1068: pu = "unpack(z,a,i)"; ! 1069: puz = argv[1]; ! 1070: al = argv[2]; ! 1071: pua = al[1]; ! 1072: alv = al[2]; ! 1073: pui = alv[1]; ! 1074: packunp: ! 1075: codeoff(); ! 1076: ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); ! 1077: al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); ! 1078: codeon(); ! 1079: if (ap == NIL) ! 1080: return; ! 1081: if (ap->class != ARRAY) { ! 1082: error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); ! 1083: return; ! 1084: } ! 1085: if (al->class != ARRAY) { ! 1086: error("%s requires z to be a packed array, not %s", pu, nameof(ap)); ! 1087: return; ! 1088: } ! 1089: if (al->type == NIL || ap->type == NIL) ! 1090: return; ! 1091: if (al->type != ap->type) { ! 1092: error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); ! 1093: return; ! 1094: } ! 1095: k = width(al); ! 1096: itemwidth = width(ap->type); ! 1097: ap = ap->chain; ! 1098: al = al->chain; ! 1099: if (ap->chain != NIL || al->chain != NIL) { ! 1100: error("%s requires a and z to be single dimension arrays", pu); ! 1101: return; ! 1102: } ! 1103: if (ap == NIL || al == NIL) ! 1104: return; ! 1105: /* ! 1106: * al is the range for z i.e. u..v ! 1107: * ap is the range for a i.e. m..n ! 1108: * i will be n-m+1 ! 1109: * j will be v-u+1 ! 1110: */ ! 1111: i = ap->range[1] - ap->range[0] + 1; ! 1112: j = al->range[1] - al->range[0] + 1; ! 1113: if (i < j) { ! 1114: error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); ! 1115: return; ! 1116: } ! 1117: /* ! 1118: * get n-m-(v-u) and m for the interpreter ! 1119: */ ! 1120: i -= j; ! 1121: j = ap->range[0]; ! 1122: put(2, O_CON24, k); ! 1123: put(2, O_CON24, i); ! 1124: put(2, O_CON24, j); ! 1125: put(2, O_CON24, itemwidth); ! 1126: al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); ! 1127: ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); ! 1128: ap = stkrval((int *) pui, NLNIL , RREQ ); ! 1129: if (ap == NIL) ! 1130: return; ! 1131: put(1, op); ! 1132: return; ! 1133: case 0: ! 1134: error("%s is an unimplemented extension", p->symbol); ! 1135: return; ! 1136: ! 1137: default: ! 1138: panic("proc case"); ! 1139: } ! 1140: } ! 1141: #endif OBJ
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.