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