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