1b85afe43Sbostic /*- 2*6e17b0ceSbostic * Copyright (c) 1980, 1993 3*6e17b0ceSbostic * The Regents of the University of California. All rights reserved. 4b85afe43Sbostic * 5b85afe43Sbostic * %sccs.include.redist.c% 67d66fe03Sdist */ 74e68de40Speter 88093a2efSthien #ifndef lint 9*6e17b0ceSbostic static char sccsid[] = "@(#)proc.c 8.1 (Berkeley) 06/06/93"; 10b85afe43Sbostic #endif /* not lint */ 114e68de40Speter 124e68de40Speter #include "whoami.h" 134e68de40Speter #ifdef OBJ 144e68de40Speter /* 154e68de40Speter * and the rest of the file 164e68de40Speter */ 174e68de40Speter #include "0.h" 184e68de40Speter #include "tree.h" 194e68de40Speter #include "opcode.h" 204e68de40Speter #include "objfmt.h" 21ec0ac83fSpeter #include "tmps.h" 228093a2efSthien #include "tree_ty.h" 234e68de40Speter 244e68de40Speter /* 254c48cfe5Smckusick * The constant EXPOSIZE specifies the number of digits in the exponent 264c48cfe5Smckusick * of real numbers. 274c48cfe5Smckusick * 28b27bae58Smckusick * The constant REALSPC defines the amount of forced padding preceeding 29b27bae58Smckusick * real numbers when they are printed. If REALSPC == 0, then no padding 30b27bae58Smckusick * is added, REALSPC == 1 adds one extra blank irregardless of the width 31b27bae58Smckusick * specified by the user. 32b27bae58Smckusick * 33b27bae58Smckusick * N.B. - Values greater than one require program mods. 34b27bae58Smckusick */ 354c48cfe5Smckusick #define EXPOSIZE 2 36b27bae58Smckusick #define REALSPC 0 37b27bae58Smckusick 38b27bae58Smckusick /* 394e68de40Speter * The following array is used to determine which classes may be read 404e68de40Speter * from textfiles. It is indexed by the return value from classify. 414e68de40Speter */ 424e68de40Speter #define rdops(x) rdxxxx[(x)-(TFIRST)] 434e68de40Speter 444e68de40Speter int rdxxxx[] = { 454e68de40Speter 0, /* -7 file types */ 464e68de40Speter 0, /* -6 record types */ 474e68de40Speter 0, /* -5 array types */ 484e68de40Speter O_READE, /* -4 scalar types */ 494e68de40Speter 0, /* -3 pointer types */ 504e68de40Speter 0, /* -2 set types */ 514e68de40Speter 0, /* -1 string types */ 524e68de40Speter 0, /* 0 nil, no type */ 534e68de40Speter O_READE, /* 1 boolean */ 544e68de40Speter O_READC, /* 2 character */ 554e68de40Speter O_READ4, /* 3 integer */ 564e68de40Speter O_READ8 /* 4 real */ 574e68de40Speter }; 584e68de40Speter 594e68de40Speter /* 604e68de40Speter * Proc handles procedure calls. 614e68de40Speter * Non-builtin procedures are "buck-passed" to func (with a flag 624e68de40Speter * indicating that they are actually procedures. 634e68de40Speter * builtin procedures are handled here. 644e68de40Speter */ 654e68de40Speter proc(r) 668093a2efSthien struct tnode *r; 674e68de40Speter { 684e68de40Speter register struct nl *p; 698093a2efSthien register struct tnode *alv, *al; 708093a2efSthien register int op; 718093a2efSthien struct nl *filetype, *ap, *al1; 728093a2efSthien int argc, typ, fmtspec, strfmt, stkcnt; 738093a2efSthien struct tnode *argv; 748093a2efSthien char fmt, format[20], *strptr, *pu; 758093a2efSthien int prec, field, strnglen, fmtlen, fmtstart; 768093a2efSthien struct tnode *pua, *pui, *puz, *file; 774e68de40Speter int i, j, k; 784e68de40Speter int itemwidth; 79fb3c87b5Smckusic struct tmps soffset; 80b987e5f4Speter struct nl *tempnlp; 814e68de40Speter 824e68de40Speter #define CONPREC 4 834e68de40Speter #define VARPREC 8 844e68de40Speter #define CONWIDTH 1 854e68de40Speter #define VARWIDTH 2 864e68de40Speter #define SKIP 16 874e68de40Speter 884e68de40Speter /* 894e68de40Speter * Verify that the name is 904e68de40Speter * defined and is that of a 914e68de40Speter * procedure. 924e68de40Speter */ 938093a2efSthien p = lookup(r->pcall_node.proc_id); 944e68de40Speter if (p == NIL) { 958093a2efSthien rvlist(r->pcall_node.arg); 964e68de40Speter return; 974e68de40Speter } 98449129dfSpeter if (p->class != PROC && p->class != FPROC) { 994e68de40Speter error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); 1008093a2efSthien rvlist(r->pcall_node.arg); 1014e68de40Speter return; 1024e68de40Speter } 1038093a2efSthien argv = r->pcall_node.arg; 1044e68de40Speter 1054e68de40Speter /* 1064e68de40Speter * Call handles user defined 1074e68de40Speter * procedures and functions. 1084e68de40Speter */ 1094e68de40Speter if (bn != 0) { 1108093a2efSthien (void) call(p, argv, PROC, bn); 1114e68de40Speter return; 1124e68de40Speter } 1134e68de40Speter 1144e68de40Speter /* 1154e68de40Speter * Call to built-in procedure. 1164e68de40Speter * Count the arguments. 1174e68de40Speter */ 1184e68de40Speter argc = 0; 1198093a2efSthien for (al = argv; al != TR_NIL; al = al->list_node.next) 1204e68de40Speter argc++; 1214e68de40Speter 1224e68de40Speter /* 1234e68de40Speter * Switch on the operator 1244e68de40Speter * associated with the built-in 1254e68de40Speter * procedure in the namelist 1264e68de40Speter */ 1274e68de40Speter op = p->value[0] &~ NSTAND; 1284e68de40Speter if (opt('s') && (p->value[0] & NSTAND)) { 1294e68de40Speter standard(); 1304e68de40Speter error("%s is a nonstandard procedure", p->symbol); 1314e68de40Speter } 1324e68de40Speter switch (op) { 1334e68de40Speter 1344e68de40Speter case O_ABORT: 1354e68de40Speter if (argc != 0) 1364e68de40Speter error("null takes no arguments"); 1374e68de40Speter return; 1384e68de40Speter 1394e68de40Speter case O_FLUSH: 1404e68de40Speter if (argc == 0) { 1418093a2efSthien (void) put(1, O_MESSAGE); 1424e68de40Speter return; 1434e68de40Speter } 1444e68de40Speter if (argc != 1) { 1454e68de40Speter error("flush takes at most one argument"); 1464e68de40Speter return; 1474e68de40Speter } 1488093a2efSthien ap = stklval(argv->list_node.list, NIL ); 1498093a2efSthien if (ap == NLNIL) 1504e68de40Speter return; 1514e68de40Speter if (ap->class != FILET) { 1524e68de40Speter error("flush's argument must be a file, not %s", nameof(ap)); 1534e68de40Speter return; 1544e68de40Speter } 1558093a2efSthien (void) put(1, op); 1564e68de40Speter return; 1574e68de40Speter 1584e68de40Speter case O_MESSAGE: 1594e68de40Speter case O_WRITEF: 1604e68de40Speter case O_WRITLN: 1614e68de40Speter /* 1624e68de40Speter * Set up default file "output"'s type 1634e68de40Speter */ 1644e68de40Speter file = NIL; 1654e68de40Speter filetype = nl+T1CHAR; 1664e68de40Speter /* 1674e68de40Speter * Determine the file implied 1684e68de40Speter * for the write and generate 1694e68de40Speter * code to make it the active file. 1704e68de40Speter */ 1714e68de40Speter if (op == O_MESSAGE) { 1724e68de40Speter /* 1734e68de40Speter * For message, all that matters 1744e68de40Speter * is that the filetype is 1754e68de40Speter * a character file. 1764e68de40Speter * Thus "output" will suit us fine. 1774e68de40Speter */ 1788093a2efSthien (void) put(1, O_MESSAGE); 1798093a2efSthien } else if (argv != TR_NIL && (al = argv->list_node.list)->tag != 1808093a2efSthien T_WEXP) { 1814e68de40Speter /* 1824e68de40Speter * If there is a first argument which has 1834e68de40Speter * no write widths, then it is potentially 1844e68de40Speter * a file name. 1854e68de40Speter */ 1864e68de40Speter codeoff(); 1878093a2efSthien ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ ); 1884e68de40Speter codeon(); 1898093a2efSthien if (ap == NLNIL) 1908093a2efSthien argv = argv->list_node.next; 1918093a2efSthien if (ap != NLNIL && ap->class == FILET) { 1924e68de40Speter /* 1934e68de40Speter * Got "write(f, ...", make 1944e68de40Speter * f the active file, and save 1954e68de40Speter * it and its type for use in 1964e68de40Speter * processing the rest of the 1974e68de40Speter * arguments to write. 1984e68de40Speter */ 1998093a2efSthien file = argv->list_node.list; 2004e68de40Speter filetype = ap->type; 2018093a2efSthien (void) stklval(argv->list_node.list, NIL ); 2028093a2efSthien (void) put(1, O_UNIT); 2034e68de40Speter /* 2044e68de40Speter * Skip over the first argument 2054e68de40Speter */ 2068093a2efSthien argv = argv->list_node.next; 2074e68de40Speter argc--; 208d73f1dabSpeter } else { 2094e68de40Speter /* 2104e68de40Speter * Set up for writing on 2114e68de40Speter * standard output. 2124e68de40Speter */ 2138093a2efSthien (void) put(1, O_UNITOUT); 2145d79f55fSpeter output->nl_flags |= NUSED; 215d73f1dabSpeter } 216d73f1dabSpeter } else { 2178093a2efSthien (void) put(1, O_UNITOUT); 2185d79f55fSpeter output->nl_flags |= NUSED; 219d73f1dabSpeter } 2204e68de40Speter /* 2214e68de40Speter * Loop and process each 2224e68de40Speter * of the arguments. 2234e68de40Speter */ 2248093a2efSthien for (; argv != TR_NIL; argv = argv->list_node.next) { 2254e68de40Speter /* 2264e68de40Speter * fmtspec indicates the type (CONstant or VARiable) 2274e68de40Speter * and number (none, WIDTH, and/or PRECision) 2284e68de40Speter * of the fields in the printf format for this 2294e68de40Speter * output variable. 23062e0e0a8Smckusic * stkcnt is the number of bytes pushed on the stack 2314e68de40Speter * fmt is the format output indicator (D, E, F, O, X, S) 2324e68de40Speter * fmtstart = 0 for leading blank; = 1 for no blank 2334e68de40Speter */ 2344e68de40Speter fmtspec = NIL; 2354e68de40Speter stkcnt = 0; 2364e68de40Speter fmt = 'D'; 2374e68de40Speter fmtstart = 1; 2388093a2efSthien al = argv->list_node.list; 2398093a2efSthien if (al == TR_NIL) 2404e68de40Speter continue; 2418093a2efSthien if (al->tag == T_WEXP) 2428093a2efSthien alv = al->wexpr_node.expr1; 2434e68de40Speter else 2444e68de40Speter alv = al; 2458093a2efSthien if (alv == TR_NIL) 2464e68de40Speter continue; 2474e68de40Speter codeoff(); 2488093a2efSthien ap = stkrval(alv, NLNIL , (long) RREQ ); 2494e68de40Speter codeon(); 2508093a2efSthien if (ap == NLNIL) 2514e68de40Speter continue; 2524e68de40Speter typ = classify(ap); 2538093a2efSthien if (al->tag == T_WEXP) { 2544e68de40Speter /* 2554e68de40Speter * Handle width expressions. 2564e68de40Speter * The basic game here is that width 2574e68de40Speter * expressions get evaluated. If they 2584e68de40Speter * are constant, the value is placed 2594e68de40Speter * directly in the format string. 2604e68de40Speter * Otherwise the value is pushed onto 2614e68de40Speter * the stack and an indirection is 2624e68de40Speter * put into the format string. 2634e68de40Speter */ 2648093a2efSthien if (al->wexpr_node.expr3 == 2658093a2efSthien (struct tnode *) OCT) 2664e68de40Speter fmt = 'O'; 2678093a2efSthien else if (al->wexpr_node.expr3 == 2688093a2efSthien (struct tnode *) HEX) 2694e68de40Speter fmt = 'X'; 2708093a2efSthien else if (al->wexpr_node.expr3 != TR_NIL) { 2714e68de40Speter /* 2724e68de40Speter * Evaluate second format spec 2734e68de40Speter */ 2748093a2efSthien if ( constval(al->wexpr_node.expr3) 2754e68de40Speter && isa( con.ctype , "i" ) ) { 2764e68de40Speter fmtspec += CONPREC; 2774e68de40Speter prec = con.crval; 2784e68de40Speter } else { 2794e68de40Speter fmtspec += VARPREC; 2804e68de40Speter } 2814e68de40Speter fmt = 'f'; 2824e68de40Speter switch ( typ ) { 2834e68de40Speter case TINT: 2844e68de40Speter if ( opt( 's' ) ) { 2854e68de40Speter standard(); 2864e68de40Speter error("Writing %ss with two write widths is non-standard", clnames[typ]); 2874e68de40Speter } 2884e68de40Speter /* and fall through */ 2894e68de40Speter case TDOUBLE: 2904e68de40Speter break; 2914e68de40Speter default: 2924e68de40Speter error("Cannot write %ss with two write widths", clnames[typ]); 2934e68de40Speter continue; 2944e68de40Speter } 2954e68de40Speter } 2964e68de40Speter /* 2974e68de40Speter * Evaluate first format spec 2984e68de40Speter */ 2998093a2efSthien if (al->wexpr_node.expr2 != TR_NIL) { 3008093a2efSthien if ( constval(al->wexpr_node.expr2) 3014e68de40Speter && isa( con.ctype , "i" ) ) { 3024e68de40Speter fmtspec += CONWIDTH; 3034e68de40Speter field = con.crval; 3044e68de40Speter } else { 3054e68de40Speter fmtspec += VARWIDTH; 3064e68de40Speter } 3074e68de40Speter } 3084e68de40Speter if ((fmtspec & CONPREC) && prec < 0 || 3094e68de40Speter (fmtspec & CONWIDTH) && field < 0) { 3104e68de40Speter error("Negative widths are not allowed"); 3114e68de40Speter continue; 3124e68de40Speter } 313a97d02a6Smckusic if ( opt('s') && 314a97d02a6Smckusic ((fmtspec & CONPREC) && prec == 0 || 315a97d02a6Smckusic (fmtspec & CONWIDTH) && field == 0)) { 316a97d02a6Smckusic standard(); 317a97d02a6Smckusic error("Zero widths are non-standard"); 318a97d02a6Smckusic } 3194e68de40Speter } 3204e68de40Speter if (filetype != nl+T1CHAR) { 3214e68de40Speter if (fmt == 'O' || fmt == 'X') { 3224e68de40Speter error("Oct/hex allowed only on text files"); 3234e68de40Speter continue; 3244e68de40Speter } 3254e68de40Speter if (fmtspec) { 3264e68de40Speter error("Write widths allowed only on text files"); 3274e68de40Speter continue; 3284e68de40Speter } 3294e68de40Speter /* 3304e68de40Speter * Generalized write, i.e. 3314e68de40Speter * to a non-textfile. 3324e68de40Speter */ 3338093a2efSthien (void) stklval(file, NIL ); 3348093a2efSthien (void) put(1, O_FNIL); 3354e68de40Speter /* 3364e68de40Speter * file^ := ... 3374e68de40Speter */ 3388093a2efSthien ap = rvalue(argv->list_node.list, NLNIL, LREQ); 3398093a2efSthien if (ap == NLNIL) 3404e68de40Speter continue; 3418093a2efSthien if (incompat(ap, filetype, 3428093a2efSthien argv->list_node.list)) { 3434e68de40Speter cerror("Type mismatch in write to non-text file"); 3444e68de40Speter continue; 3454e68de40Speter } 3464e68de40Speter convert(ap, filetype); 3478093a2efSthien (void) put(2, O_AS, width(filetype)); 3484e68de40Speter /* 3494e68de40Speter * put(file) 3504e68de40Speter */ 3518093a2efSthien (void) put(1, O_PUT); 3524e68de40Speter continue; 3534e68de40Speter } 3544e68de40Speter /* 3554e68de40Speter * Write to a textfile 3564e68de40Speter * 3574e68de40Speter * Evaluate the expression 3584e68de40Speter * to be written. 3594e68de40Speter */ 3604e68de40Speter if (fmt == 'O' || fmt == 'X') { 3614e68de40Speter if (opt('s')) { 3624e68de40Speter standard(); 3634e68de40Speter error("Oct and hex are non-standard"); 3644e68de40Speter } 3654e68de40Speter if (typ == TSTR || typ == TDOUBLE) { 3664e68de40Speter error("Can't write %ss with oct/hex", clnames[typ]); 3674e68de40Speter continue; 3684e68de40Speter } 3694e68de40Speter if (typ == TCHAR || typ == TBOOL) 3704e68de40Speter typ = TINT; 3714e68de40Speter } 3724e68de40Speter /* 3734e68de40Speter * Place the arguement on the stack. If there is 3744e68de40Speter * no format specified by the programmer, implement 3754e68de40Speter * the default. 3764e68de40Speter */ 3774e68de40Speter switch (typ) { 37887da4626Smckusick case TPTR: 37987da4626Smckusick warning(); 38087da4626Smckusick if (opt('s')) { 38187da4626Smckusick standard(); 38287da4626Smckusick } 38387da4626Smckusick error("Writing %ss to text files is non-standard", 38487da4626Smckusick clnames[typ]); 38587da4626Smckusick /* and fall through */ 3864e68de40Speter case TINT: 3874e68de40Speter if (fmt != 'f') { 3888093a2efSthien ap = stkrval(alv, NLNIL, (long) RREQ ); 38962e0e0a8Smckusic stkcnt += sizeof(long); 3904e68de40Speter } else { 3918093a2efSthien ap = stkrval(alv, NLNIL, (long) RREQ ); 3928093a2efSthien (void) put(1, O_ITOD); 39362e0e0a8Smckusic stkcnt += sizeof(double); 3944e68de40Speter typ = TDOUBLE; 3954e68de40Speter goto tdouble; 3964e68de40Speter } 3974e68de40Speter if (fmtspec == NIL) { 3984e68de40Speter if (fmt == 'D') 3994e68de40Speter field = 10; 4004e68de40Speter else if (fmt == 'X') 4014e68de40Speter field = 8; 4024e68de40Speter else if (fmt == 'O') 4034e68de40Speter field = 11; 4044e68de40Speter else 4054e68de40Speter panic("fmt1"); 4064e68de40Speter fmtspec = CONWIDTH; 4074e68de40Speter } 4084e68de40Speter break; 4094e68de40Speter case TCHAR: 4104e68de40Speter tchar: 4117bfefa1bSmckusic if (fmtspec == NIL) { 4128093a2efSthien (void) put(1, O_FILE); 4138093a2efSthien ap = stkrval(alv, NLNIL, (long) RREQ ); 41462e0e0a8Smckusic convert(nl + T4INT, INT_TYP); 4158093a2efSthien (void) put(2, O_WRITEC, 41662e0e0a8Smckusic sizeof(char *) + sizeof(int)); 4177bfefa1bSmckusic fmtspec = SKIP; 4187bfefa1bSmckusic break; 4197bfefa1bSmckusic } 4208093a2efSthien ap = stkrval(alv, NLNIL , (long) RREQ ); 42162e0e0a8Smckusic convert(nl + T4INT, INT_TYP); 42262e0e0a8Smckusic stkcnt += sizeof(int); 4234e68de40Speter fmt = 'c'; 4244e68de40Speter break; 4254e68de40Speter case TSCAL: 4261743f6c7Speter warning(); 4274e68de40Speter if (opt('s')) { 4284e68de40Speter standard(); 4294e68de40Speter } 43087da4626Smckusick error("Writing %ss to text files is non-standard", 43187da4626Smckusick clnames[typ]); 43287da4626Smckusick /* and fall through */ 4334e68de40Speter case TBOOL: 4348093a2efSthien (void) stkrval(alv, NLNIL , (long) RREQ ); 4358093a2efSthien (void) put(2, O_NAM, (long)listnames(ap)); 43662e0e0a8Smckusic stkcnt += sizeof(char *); 4374e68de40Speter fmt = 's'; 4384e68de40Speter break; 4394e68de40Speter case TDOUBLE: 4408093a2efSthien ap = stkrval(alv, (struct nl *) TDOUBLE , (long) RREQ ); 44162e0e0a8Smckusic stkcnt += sizeof(double); 4424e68de40Speter tdouble: 4434e68de40Speter switch (fmtspec) { 4444e68de40Speter case NIL: 4454c48cfe5Smckusick field = 14 + (5 + EXPOSIZE); 4464c48cfe5Smckusick prec = field - (5 + EXPOSIZE); 4475c67c127Smckusic fmt = 'e'; 4484e68de40Speter fmtspec = CONWIDTH + CONPREC; 4494e68de40Speter break; 4504e68de40Speter case CONWIDTH: 451b27bae58Smckusick field -= REALSPC; 452b27bae58Smckusick if (field < 1) 4534e68de40Speter field = 1; 4544c48cfe5Smckusick prec = field - (5 + EXPOSIZE); 4554e68de40Speter if (prec < 1) 4564e68de40Speter prec = 1; 4574e68de40Speter fmtspec += CONPREC; 4585c67c127Smckusic fmt = 'e'; 4594e68de40Speter break; 4604e68de40Speter case CONWIDTH + CONPREC: 4614e68de40Speter case CONWIDTH + VARPREC: 462b27bae58Smckusick field -= REALSPC; 463b27bae58Smckusick if (field < 1) 4644e68de40Speter field = 1; 4654e68de40Speter } 4664e68de40Speter format[0] = ' '; 467b27bae58Smckusick fmtstart = 1 - REALSPC; 4684e68de40Speter break; 4694e68de40Speter case TSTR: 4708093a2efSthien (void) constval( alv ); 4714e68de40Speter switch ( classify( con.ctype ) ) { 4724e68de40Speter case TCHAR: 4734e68de40Speter typ = TCHAR; 4744e68de40Speter goto tchar; 4754e68de40Speter case TSTR: 4764e68de40Speter strptr = con.cpval; 4774e68de40Speter for (strnglen = 0; *strptr++; strnglen++) /* void */; 4784e68de40Speter strptr = con.cpval; 4794e68de40Speter break; 4804e68de40Speter default: 4814e68de40Speter strnglen = width(ap); 4824e68de40Speter break; 4834e68de40Speter } 4844e68de40Speter fmt = 's'; 4854e68de40Speter strfmt = fmtspec; 4864e68de40Speter if (fmtspec == NIL) { 4874e68de40Speter fmtspec = SKIP; 4884e68de40Speter break; 4894e68de40Speter } 4904e68de40Speter if (fmtspec & CONWIDTH) { 4914e68de40Speter if (field <= strnglen) { 4924e68de40Speter fmtspec = SKIP; 4934e68de40Speter break; 4944e68de40Speter } else 4954e68de40Speter field -= strnglen; 4964e68de40Speter } 4974e68de40Speter /* 4984e68de40Speter * push string to implement leading blank padding 4994e68de40Speter */ 5008093a2efSthien (void) put(2, O_LVCON, 2); 5014e68de40Speter putstr("", 0); 50262e0e0a8Smckusic stkcnt += sizeof(char *); 5034e68de40Speter break; 5044e68de40Speter default: 5054e68de40Speter error("Can't write %ss to a text file", clnames[typ]); 5064e68de40Speter continue; 5074e68de40Speter } 5084e68de40Speter /* 5094e68de40Speter * If there is a variable precision, evaluate it onto 5104e68de40Speter * the stack 5114e68de40Speter */ 5124e68de40Speter if (fmtspec & VARPREC) { 5138093a2efSthien ap = stkrval(al->wexpr_node.expr3, NLNIL , 5148093a2efSthien (long) RREQ ); 5154e68de40Speter if (ap == NIL) 5164e68de40Speter continue; 5174e68de40Speter if (isnta(ap,"i")) { 5184e68de40Speter error("Second write width must be integer, not %s", nameof(ap)); 5194e68de40Speter continue; 5204e68de40Speter } 5214e68de40Speter if ( opt( 't' ) ) { 5228093a2efSthien (void) put(3, O_MAX, 0, 0); 5234e68de40Speter } 52462e0e0a8Smckusic convert(nl+T4INT, INT_TYP); 52562e0e0a8Smckusic stkcnt += sizeof(int); 5264e68de40Speter } 5274e68de40Speter /* 5284e68de40Speter * If there is a variable width, evaluate it onto 5294e68de40Speter * the stack 5304e68de40Speter */ 5314e68de40Speter if (fmtspec & VARWIDTH) { 5324e68de40Speter if ( ( typ == TDOUBLE && fmtspec == VARWIDTH ) 5334e68de40Speter || typ == TSTR ) { 534fb3c87b5Smckusic soffset = sizes[cbn].curtmps; 5358093a2efSthien tempnlp = tmpalloc((long) (sizeof(long)), 536fb3c87b5Smckusic nl+T4INT, REGOK); 5378093a2efSthien (void) put(2, O_LV | cbn << 8 + INDX, 538b987e5f4Speter tempnlp -> value[ NL_OFFS ] ); 5394e68de40Speter } 5408093a2efSthien ap = stkrval(al->wexpr_node.expr2, NLNIL, (long) RREQ ); 5414e68de40Speter if (ap == NIL) 5424e68de40Speter continue; 5434e68de40Speter if (isnta(ap,"i")) { 5444e68de40Speter error("First write width must be integer, not %s", nameof(ap)); 5454e68de40Speter continue; 5464e68de40Speter } 5474e68de40Speter /* 5484e68de40Speter * Perform special processing on widths based 5494e68de40Speter * on data type 5504e68de40Speter */ 5514e68de40Speter switch (typ) { 5524e68de40Speter case TDOUBLE: 5534e68de40Speter if (fmtspec == VARWIDTH) { 5545c67c127Smckusic fmt = 'e'; 5558093a2efSthien (void) put(1, O_AS4); 5568093a2efSthien (void) put(2, O_RV4 | cbn << 8 + INDX, 557b987e5f4Speter tempnlp -> value[NL_OFFS] ); 5588093a2efSthien (void) put(3, O_MAX, 5594c48cfe5Smckusick 5 + EXPOSIZE + REALSPC, 1); 56062e0e0a8Smckusic convert(nl+T4INT, INT_TYP); 56162e0e0a8Smckusic stkcnt += sizeof(int); 5628093a2efSthien (void) put(2, O_RV4 | cbn << 8 + INDX, 563b987e5f4Speter tempnlp->value[NL_OFFS] ); 5644e68de40Speter fmtspec += VARPREC; 565fb3c87b5Smckusic tmpfree(&soffset); 5664e68de40Speter } 5678093a2efSthien (void) put(3, O_MAX, REALSPC, 1); 5684e68de40Speter break; 5694e68de40Speter case TSTR: 5708093a2efSthien (void) put(1, O_AS4); 5718093a2efSthien (void) put(2, O_RV4 | cbn << 8 + INDX, 572b987e5f4Speter tempnlp -> value[ NL_OFFS ] ); 5738093a2efSthien (void) put(3, O_MAX, strnglen, 0); 5744e68de40Speter break; 5754e68de40Speter default: 5764e68de40Speter if ( opt( 't' ) ) { 5778093a2efSthien (void) put(3, O_MAX, 0, 0); 5784e68de40Speter } 5794e68de40Speter break; 5804e68de40Speter } 58162e0e0a8Smckusic convert(nl+T4INT, INT_TYP); 58262e0e0a8Smckusic stkcnt += sizeof(int); 5834e68de40Speter } 5844e68de40Speter /* 5854e68de40Speter * Generate the format string 5864e68de40Speter */ 5874e68de40Speter switch (fmtspec) { 5884e68de40Speter default: 5894e68de40Speter panic("fmt2"); 5904e68de40Speter case SKIP: 5914e68de40Speter break; 5927bfefa1bSmckusic case NIL: 5937bfefa1bSmckusic sprintf(&format[1], "%%%c", fmt); 5947bfefa1bSmckusic goto fmtgen; 5954e68de40Speter case CONWIDTH: 5965c67c127Smckusic sprintf(&format[1], "%%%d%c", field, fmt); 5974e68de40Speter goto fmtgen; 5984e68de40Speter case VARWIDTH: 5994e68de40Speter sprintf(&format[1], "%%*%c", fmt); 6004e68de40Speter goto fmtgen; 6014e68de40Speter case CONWIDTH + CONPREC: 6025c67c127Smckusic sprintf(&format[1], "%%%d.%d%c", field, prec, fmt); 6034e68de40Speter goto fmtgen; 6044e68de40Speter case CONWIDTH + VARPREC: 6055c67c127Smckusic sprintf(&format[1], "%%%d.*%c", field, fmt); 6064e68de40Speter goto fmtgen; 6074e68de40Speter case VARWIDTH + CONPREC: 6085c67c127Smckusic sprintf(&format[1], "%%*.%d%c", prec, fmt); 6094e68de40Speter goto fmtgen; 6104e68de40Speter case VARWIDTH + VARPREC: 6114e68de40Speter sprintf(&format[1], "%%*.*%c", fmt); 6124e68de40Speter fmtgen: 6134e68de40Speter fmtlen = lenstr(&format[fmtstart], 0); 6148093a2efSthien (void) put(2, O_LVCON, fmtlen); 6154e68de40Speter putstr(&format[fmtstart], 0); 6168093a2efSthien (void) put(1, O_FILE); 61762e0e0a8Smckusic stkcnt += 2 * sizeof(char *); 6188093a2efSthien (void) put(2, O_WRITEF, stkcnt); 6194e68de40Speter } 6204e68de40Speter /* 6214e68de40Speter * Write the string after its blank padding 6224e68de40Speter */ 6234e68de40Speter if (typ == TSTR) { 6248093a2efSthien (void) put(1, O_FILE); 6258093a2efSthien (void) put(2, CON_INT, 1); 6264e68de40Speter if (strfmt & VARWIDTH) { 6278093a2efSthien (void) put(2, O_RV4 | cbn << 8 + INDX , 628b987e5f4Speter tempnlp -> value[ NL_OFFS ] ); 6298093a2efSthien (void) put(2, O_MIN, strnglen); 63062e0e0a8Smckusic convert(nl+T4INT, INT_TYP); 631fb3c87b5Smckusic tmpfree(&soffset); 6324e68de40Speter } else { 6334e68de40Speter if ((fmtspec & SKIP) && 6344e68de40Speter (strfmt & CONWIDTH)) { 6354e68de40Speter strnglen = field; 6364e68de40Speter } 6378093a2efSthien (void) put(2, CON_INT, strnglen); 6384e68de40Speter } 6398093a2efSthien ap = stkrval(alv, NLNIL , (long) RREQ ); 6408093a2efSthien (void) put(2, O_WRITES, 64162e0e0a8Smckusic 2 * sizeof(char *) + 2 * sizeof(int)); 6424e68de40Speter } 6434e68de40Speter } 6444e68de40Speter /* 6454e68de40Speter * Done with arguments. 6464e68de40Speter * Handle writeln and 6474e68de40Speter * insufficent number of args. 6484e68de40Speter */ 6494e68de40Speter switch (p->value[0] &~ NSTAND) { 6504e68de40Speter case O_WRITEF: 6514e68de40Speter if (argc == 0) 6524e68de40Speter error("Write requires an argument"); 6534e68de40Speter break; 6544e68de40Speter case O_MESSAGE: 6554e68de40Speter if (argc == 0) 6564e68de40Speter error("Message requires an argument"); 6574e68de40Speter case O_WRITLN: 6584e68de40Speter if (filetype != nl+T1CHAR) 6594e68de40Speter error("Can't 'writeln' a non text file"); 6608093a2efSthien (void) put(1, O_WRITLN); 6614e68de40Speter break; 6624e68de40Speter } 6634e68de40Speter return; 6644e68de40Speter 6654e68de40Speter case O_READ4: 6664e68de40Speter case O_READLN: 6674e68de40Speter /* 6684e68de40Speter * Set up default 6694e68de40Speter * file "input". 6704e68de40Speter */ 6714e68de40Speter file = NIL; 6724e68de40Speter filetype = nl+T1CHAR; 6734e68de40Speter /* 6744e68de40Speter * Determine the file implied 6754e68de40Speter * for the read and generate 6764e68de40Speter * code to make it the active file. 6774e68de40Speter */ 6788093a2efSthien if (argv != TR_NIL) { 6794e68de40Speter codeoff(); 6808093a2efSthien ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ ); 6814e68de40Speter codeon(); 6828093a2efSthien if (ap == NLNIL) 6838093a2efSthien argv = argv->list_node.next; 6848093a2efSthien if (ap != NLNIL && ap->class == FILET) { 6854e68de40Speter /* 6864e68de40Speter * Got "read(f, ...", make 6874e68de40Speter * f the active file, and save 6884e68de40Speter * it and its type for use in 6894e68de40Speter * processing the rest of the 6904e68de40Speter * arguments to read. 6914e68de40Speter */ 6928093a2efSthien file = argv->list_node.list; 6934e68de40Speter filetype = ap->type; 6948093a2efSthien (void) stklval(argv->list_node.list, NIL ); 6958093a2efSthien (void) put(1, O_UNIT); 6968093a2efSthien argv = argv->list_node.next; 6974e68de40Speter argc--; 6984e68de40Speter } else { 6994e68de40Speter /* 7004e68de40Speter * Default is read from 7014e68de40Speter * standard input. 7024e68de40Speter */ 7038093a2efSthien (void) put(1, O_UNITINP); 7044e68de40Speter input->nl_flags |= NUSED; 7054e68de40Speter } 7064e68de40Speter } else { 7078093a2efSthien (void) put(1, O_UNITINP); 7084e68de40Speter input->nl_flags |= NUSED; 7094e68de40Speter } 7104e68de40Speter /* 7114e68de40Speter * Loop and process each 7124e68de40Speter * of the arguments. 7134e68de40Speter */ 7148093a2efSthien for (; argv != TR_NIL; argv = argv->list_node.next) { 7154e68de40Speter /* 7164e68de40Speter * Get the address of the target 7174e68de40Speter * on the stack. 7184e68de40Speter */ 7198093a2efSthien al = argv->list_node.list; 7208093a2efSthien if (al == TR_NIL) 7214e68de40Speter continue; 7228093a2efSthien if (al->tag != T_VAR) { 7234e68de40Speter error("Arguments to %s must be variables, not expressions", p->symbol); 7244e68de40Speter continue; 7254e68de40Speter } 7264e68de40Speter ap = stklval(al, MOD|ASGN|NOUSE); 7278093a2efSthien if (ap == NLNIL) 7284e68de40Speter continue; 7294e68de40Speter if (filetype != nl+T1CHAR) { 7304e68de40Speter /* 7314e68de40Speter * Generalized read, i.e. 7324e68de40Speter * from a non-textfile. 7334e68de40Speter */ 7348093a2efSthien if (incompat(filetype, ap, 7358093a2efSthien argv->list_node.list )) { 7364e68de40Speter error("Type mismatch in read from non-text file"); 7374e68de40Speter continue; 7384e68de40Speter } 7394e68de40Speter /* 7404e68de40Speter * var := file ^; 7414e68de40Speter */ 7424e68de40Speter if (file != NIL) 7438093a2efSthien (void) stklval(file, NIL); 7444e68de40Speter else /* Magic */ 7458093a2efSthien (void) put(2, PTR_RV, (int)input->value[0]); 7468093a2efSthien (void) put(1, O_FNIL); 7472735964bSpeter if (isa(filetype, "bcsi")) { 7482735964bSpeter int filewidth = width(filetype); 7492735964bSpeter 7502735964bSpeter switch (filewidth) { 7512735964bSpeter case 4: 7522735964bSpeter (void) put(1, O_IND4); 7532735964bSpeter break; 7542735964bSpeter case 2: 7552735964bSpeter (void) put(1, O_IND2); 7562735964bSpeter break; 7572735964bSpeter case 1: 7582735964bSpeter (void) put(1, O_IND1); 7592735964bSpeter break; 7602735964bSpeter default: 7612735964bSpeter (void) put(2, O_IND, filewidth); 7622735964bSpeter } 7632735964bSpeter convert(filetype, ap); 7642735964bSpeter rangechk(ap, ap); 7652735964bSpeter (void) gen(O_AS2, O_AS2, 7662735964bSpeter filewidth, width(ap)); 7672735964bSpeter } else { 7688093a2efSthien (void) put(2, O_IND, width(filetype)); 7694e68de40Speter convert(filetype, ap); 7708093a2efSthien (void) put(2, O_AS, width(ap)); 7712735964bSpeter } 7724e68de40Speter /* 7734e68de40Speter * get(file); 7744e68de40Speter */ 7758093a2efSthien (void) put(1, O_GET); 7764e68de40Speter continue; 7774e68de40Speter } 7784e68de40Speter typ = classify(ap); 7794e68de40Speter op = rdops(typ); 7804e68de40Speter if (op == NIL) { 7814e68de40Speter error("Can't read %ss from a text file", clnames[typ]); 7824e68de40Speter continue; 7834e68de40Speter } 7844e68de40Speter if (op != O_READE) 7858093a2efSthien (void) put(1, op); 7864e68de40Speter else { 7878093a2efSthien (void) put(2, op, (long)listnames(ap)); 7881743f6c7Speter warning(); 7894e68de40Speter if (opt('s')) { 7904e68de40Speter standard(); 7914e68de40Speter } 7921743f6c7Speter error("Reading scalars from text files is non-standard"); 7934e68de40Speter } 7944e68de40Speter /* 7954e68de40Speter * Data read is on the stack. 7964e68de40Speter * Assign it. 7974e68de40Speter */ 7984e68de40Speter if (op != O_READ8 && op != O_READE) 7994e68de40Speter rangechk(ap, op == O_READC ? ap : nl+T4INT); 8008093a2efSthien (void) gen(O_AS2, O_AS2, width(ap), 8014e68de40Speter op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2); 8024e68de40Speter } 8034e68de40Speter /* 8044e68de40Speter * Done with arguments. 8054e68de40Speter * Handle readln and 8064e68de40Speter * insufficient number of args. 8074e68de40Speter */ 8084e68de40Speter if (p->value[0] == O_READLN) { 8094e68de40Speter if (filetype != nl+T1CHAR) 8104e68de40Speter error("Can't 'readln' a non text file"); 8118093a2efSthien (void) put(1, O_READLN); 8124e68de40Speter } 8134e68de40Speter else if (argc == 0) 8144e68de40Speter error("read requires an argument"); 8154e68de40Speter return; 8164e68de40Speter 8174e68de40Speter case O_GET: 8184e68de40Speter case O_PUT: 8194e68de40Speter if (argc != 1) { 8204e68de40Speter error("%s expects one argument", p->symbol); 8214e68de40Speter return; 8224e68de40Speter } 8238093a2efSthien ap = stklval(argv->list_node.list, NIL ); 8248093a2efSthien if (ap == NLNIL) 8254e68de40Speter return; 8264e68de40Speter if (ap->class != FILET) { 8274e68de40Speter error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 8284e68de40Speter return; 8294e68de40Speter } 8308093a2efSthien (void) put(1, O_UNIT); 8318093a2efSthien (void) put(1, op); 8324e68de40Speter return; 8334e68de40Speter 8344e68de40Speter case O_RESET: 8354e68de40Speter case O_REWRITE: 8364e68de40Speter if (argc == 0 || argc > 2) { 8374e68de40Speter error("%s expects one or two arguments", p->symbol); 8384e68de40Speter return; 8394e68de40Speter } 8404e68de40Speter if (opt('s') && argc == 2) { 8414e68de40Speter standard(); 8424e68de40Speter error("Two argument forms of reset and rewrite are non-standard"); 8434e68de40Speter } 8447bfefa1bSmckusic codeoff(); 8458093a2efSthien ap = stklval(argv->list_node.list, MOD|NOUSE); 8467bfefa1bSmckusic codeon(); 8478093a2efSthien if (ap == NLNIL) 8484e68de40Speter return; 8494e68de40Speter if (ap->class != FILET) { 8504e68de40Speter error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 8514e68de40Speter return; 8524e68de40Speter } 8538093a2efSthien (void) put(2, O_CON24, text(ap) ? 0: width(ap->type)); 8544e68de40Speter if (argc == 2) { 8554e68de40Speter /* 8564e68de40Speter * Optional second argument 8574e68de40Speter * is a string name of a 8584e68de40Speter * UNIX (R) file to be associated. 8594e68de40Speter */ 8608093a2efSthien al = argv->list_node.next; 8617bfefa1bSmckusic codeoff(); 8628093a2efSthien al = (struct tnode *) stkrval(al->list_node.list, 8638093a2efSthien (struct nl *) NOFLAGS , (long) RREQ ); 8647bfefa1bSmckusic codeon(); 8658093a2efSthien if (al == TR_NIL) 8664e68de40Speter return; 8678093a2efSthien if (classify((struct nl *) al) != TSTR) { 8688093a2efSthien error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al)); 8694e68de40Speter return; 8704e68de40Speter } 8718093a2efSthien (void) put(2, O_CON24, width((struct nl *) al)); 8728093a2efSthien al = argv->list_node.next; 8738093a2efSthien al = (struct tnode *) stkrval(al->list_node.list, 8748093a2efSthien (struct nl *) NOFLAGS , (long) RREQ ); 8754e68de40Speter } else { 8768093a2efSthien (void) put(2, O_CON24, 0); 8778093a2efSthien (void) put(2, PTR_CON, NIL); 8784e68de40Speter } 8798093a2efSthien ap = stklval(argv->list_node.list, MOD|NOUSE); 8808093a2efSthien (void) put(1, op); 8814e68de40Speter return; 8824e68de40Speter 8834e68de40Speter case O_NEW: 8844e68de40Speter case O_DISPOSE: 8854e68de40Speter if (argc == 0) { 8864e68de40Speter error("%s expects at least one argument", p->symbol); 8874e68de40Speter return; 8884e68de40Speter } 8898093a2efSthien ap = stklval(argv->list_node.list, 8908093a2efSthien op == O_NEW ? ( MOD | NOUSE ) : MOD ); 8918093a2efSthien if (ap == NLNIL) 8924e68de40Speter return; 8934e68de40Speter if (ap->class != PTR) { 8944e68de40Speter error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 8954e68de40Speter return; 8964e68de40Speter } 8974e68de40Speter ap = ap->type; 8984e68de40Speter if (ap == NIL) 8994e68de40Speter return; 9005690021aSmckusick if ((ap->nl_flags & NFILES) && op == O_DISPOSE) 9015690021aSmckusick op = O_DFDISP; 9028093a2efSthien argv = argv->list_node.next; 9038093a2efSthien if (argv != TR_NIL) { 9044e68de40Speter if (ap->class != RECORD) { 9054e68de40Speter error("Record required when specifying variant tags"); 9064e68de40Speter return; 9074e68de40Speter } 9088093a2efSthien for (; argv != TR_NIL; argv = argv->list_node.next) { 9094e68de40Speter if (ap->ptr[NL_VARNT] == NIL) { 9104e68de40Speter error("Too many tag fields"); 9114e68de40Speter return; 9124e68de40Speter } 9138093a2efSthien if (!isconst(argv->list_node.list)) { 9144e68de40Speter error("Second and successive arguments to %s must be constants", p->symbol); 9154e68de40Speter return; 9164e68de40Speter } 9178093a2efSthien gconst(argv->list_node.list); 9184e68de40Speter if (con.ctype == NIL) 9194e68de40Speter return; 9208093a2efSthien if (incompat(con.ctype, ( 9218093a2efSthien ap->ptr[NL_TAG])->type , TR_NIL )) { 9224e68de40Speter cerror("Specified tag constant type clashed with variant case selector type"); 9234e68de40Speter return; 9244e68de40Speter } 9254e68de40Speter for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 9264e68de40Speter if (ap->range[0] == con.crval) 9274e68de40Speter break; 9284e68de40Speter if (ap == NIL) { 9294e68de40Speter error("No variant case label value equals specified constant value"); 9304e68de40Speter return; 9314e68de40Speter } 9324e68de40Speter ap = ap->ptr[NL_VTOREC]; 9334e68de40Speter } 9344e68de40Speter } 9358093a2efSthien (void) put(2, op, width(ap)); 9364e68de40Speter return; 9374e68de40Speter 9384e68de40Speter case O_DATE: 9394e68de40Speter case O_TIME: 9404e68de40Speter if (argc != 1) { 9414e68de40Speter error("%s expects one argument", p->symbol); 9424e68de40Speter return; 9434e68de40Speter } 9448093a2efSthien ap = stklval(argv->list_node.list, MOD|NOUSE); 9458093a2efSthien if (ap == NLNIL) 9464e68de40Speter return; 9474e68de40Speter if (classify(ap) != TSTR || width(ap) != 10) { 9484e68de40Speter error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 9494e68de40Speter return; 9504e68de40Speter } 9518093a2efSthien (void) put(1, op); 9524e68de40Speter return; 9534e68de40Speter 9544e68de40Speter case O_HALT: 9554e68de40Speter if (argc != 0) { 9564e68de40Speter error("halt takes no arguments"); 9574e68de40Speter return; 9584e68de40Speter } 9598093a2efSthien (void) put(1, op); 9608093a2efSthien noreach = TRUE; /* used to be 1 */ 9614e68de40Speter return; 9624e68de40Speter 9634e68de40Speter case O_ARGV: 9644e68de40Speter if (argc != 2) { 9654e68de40Speter error("argv takes two arguments"); 9664e68de40Speter return; 9674e68de40Speter } 9688093a2efSthien ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 9698093a2efSthien if (ap == NLNIL) 9704e68de40Speter return; 9714e68de40Speter if (isnta(ap, "i")) { 9724e68de40Speter error("argv's first argument must be an integer, not %s", nameof(ap)); 9734e68de40Speter return; 9744e68de40Speter } 9758093a2efSthien al = argv->list_node.next; 9768093a2efSthien ap = stklval(al->list_node.list, MOD|NOUSE); 9778093a2efSthien if (ap == NLNIL) 9784e68de40Speter return; 9794e68de40Speter if (classify(ap) != TSTR) { 9804e68de40Speter error("argv's second argument must be a string, not %s", nameof(ap)); 9814e68de40Speter return; 9824e68de40Speter } 9838093a2efSthien (void) put(2, op, width(ap)); 9844e68de40Speter return; 9854e68de40Speter 9864e68de40Speter case O_STLIM: 9874e68de40Speter if (argc != 1) { 9884e68de40Speter error("stlimit requires one argument"); 9894e68de40Speter return; 9904e68de40Speter } 9918093a2efSthien ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 9928093a2efSthien if (ap == NLNIL) 9934e68de40Speter return; 9944e68de40Speter if (isnta(ap, "i")) { 9954e68de40Speter error("stlimit's argument must be an integer, not %s", nameof(ap)); 9964e68de40Speter return; 9974e68de40Speter } 9984e68de40Speter if (width(ap) != 4) 9998093a2efSthien (void) put(1, O_STOI); 10008093a2efSthien (void) put(1, op); 10014e68de40Speter return; 10024e68de40Speter 10034e68de40Speter case O_REMOVE: 10044e68de40Speter if (argc != 1) { 10054e68de40Speter error("remove expects one argument"); 10064e68de40Speter return; 10074e68de40Speter } 10087bfefa1bSmckusic codeoff(); 10098093a2efSthien ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS, 10108093a2efSthien (long) RREQ ); 10117bfefa1bSmckusic codeon(); 10128093a2efSthien if (ap == NLNIL) 10134e68de40Speter return; 10144e68de40Speter if (classify(ap) != TSTR) { 10154e68de40Speter error("remove's argument must be a string, not %s", nameof(ap)); 10164e68de40Speter return; 10174e68de40Speter } 10188093a2efSthien (void) put(2, O_CON24, width(ap)); 10198093a2efSthien ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS, 10208093a2efSthien (long) RREQ ); 10218093a2efSthien (void) put(1, op); 10224e68de40Speter return; 10234e68de40Speter 10244e68de40Speter case O_LLIMIT: 10254e68de40Speter if (argc != 2) { 10264e68de40Speter error("linelimit expects two arguments"); 10274e68de40Speter return; 10284e68de40Speter } 10298093a2efSthien al = argv->list_node.next; 10308093a2efSthien ap = stkrval(al->list_node.list, NLNIL , (long) RREQ ); 10314e68de40Speter if (ap == NIL) 10324e68de40Speter return; 10334e68de40Speter if (isnta(ap, "i")) { 10344e68de40Speter error("linelimit's second argument must be an integer, not %s", nameof(ap)); 10354e68de40Speter return; 10364e68de40Speter } 10378093a2efSthien ap = stklval(argv->list_node.list, NOFLAGS|NOUSE); 10388093a2efSthien if (ap == NLNIL) 10397bfefa1bSmckusic return; 10407bfefa1bSmckusic if (!text(ap)) { 10417bfefa1bSmckusic error("linelimit's first argument must be a text file, not %s", nameof(ap)); 10427bfefa1bSmckusic return; 10437bfefa1bSmckusic } 10448093a2efSthien (void) put(1, op); 10454e68de40Speter return; 10464e68de40Speter case O_PAGE: 10474e68de40Speter if (argc != 1) { 10484e68de40Speter error("page expects one argument"); 10494e68de40Speter return; 10504e68de40Speter } 10518093a2efSthien ap = stklval(argv->list_node.list, NIL ); 10528093a2efSthien if (ap == NLNIL) 10534e68de40Speter return; 10544e68de40Speter if (!text(ap)) { 10554e68de40Speter error("Argument to page must be a text file, not %s", nameof(ap)); 10564e68de40Speter return; 10574e68de40Speter } 10588093a2efSthien (void) put(1, O_UNIT); 10598093a2efSthien (void) put(1, op); 10604e68de40Speter return; 10614e68de40Speter 10628c0920b2Smckusick case O_ASRT: 10638c0920b2Smckusick if (!opt('t')) 10648c0920b2Smckusick return; 10658c0920b2Smckusick if (argc == 0 || argc > 2) { 10668c0920b2Smckusick error("Assert expects one or two arguments"); 10678c0920b2Smckusick return; 10688c0920b2Smckusick } 10698c0920b2Smckusick if (argc == 2) { 10708c0920b2Smckusick /* 10718c0920b2Smckusick * Optional second argument is a string specifying 10728c0920b2Smckusick * why the assertion failed. 10738c0920b2Smckusick */ 10748093a2efSthien al = argv->list_node.next; 10758093a2efSthien al1 = stkrval(al->list_node.list, NLNIL , (long) RREQ ); 10768093a2efSthien if (al1 == NIL) 10778c0920b2Smckusick return; 10788093a2efSthien if (classify(al1) != TSTR) { 10798093a2efSthien error("Second argument to assert must be a string, not %s", nameof(al1)); 10808c0920b2Smckusick return; 10818c0920b2Smckusick } 10828c0920b2Smckusick } else { 10838093a2efSthien (void) put(2, PTR_CON, NIL); 10848c0920b2Smckusick } 10858093a2efSthien ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 10868c0920b2Smckusick if (ap == NIL) 10878c0920b2Smckusick return; 10888c0920b2Smckusick if (isnta(ap, "b")) 10898c0920b2Smckusick error("Assert expression must be Boolean, not %ss", nameof(ap)); 10908093a2efSthien (void) put(1, O_ASRT); 10918c0920b2Smckusick return; 10928c0920b2Smckusick 10934e68de40Speter case O_PACK: 10944e68de40Speter if (argc != 3) { 10954e68de40Speter error("pack expects three arguments"); 10964e68de40Speter return; 10974e68de40Speter } 10984e68de40Speter pu = "pack(a,i,z)"; 10998093a2efSthien pua = argv->list_node.list; 11008093a2efSthien al = argv->list_node.next; 11018093a2efSthien pui = al->list_node.list; 11028093a2efSthien alv = al->list_node.next; 11038093a2efSthien puz = alv->list_node.list; 11044e68de40Speter goto packunp; 11054e68de40Speter case O_UNPACK: 11064e68de40Speter if (argc != 3) { 11074e68de40Speter error("unpack expects three arguments"); 11084e68de40Speter return; 11094e68de40Speter } 11104e68de40Speter pu = "unpack(z,a,i)"; 11118093a2efSthien puz = argv->list_node.list; 11128093a2efSthien al = argv->list_node.next; 11138093a2efSthien pua = al->list_node.list; 11148093a2efSthien alv = al->list_node.next; 11158093a2efSthien pui = alv->list_node.list; 11164e68de40Speter packunp: 11177bfefa1bSmckusic codeoff(); 11184e68de40Speter ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 11198093a2efSthien al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 11207bfefa1bSmckusic codeon(); 11214e68de40Speter if (ap == NIL) 11224e68de40Speter return; 11234e68de40Speter if (ap->class != ARRAY) { 11244e68de40Speter error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 11254e68de40Speter return; 11264e68de40Speter } 11278093a2efSthien if (al1->class != ARRAY) { 11284e68de40Speter error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 11294e68de40Speter return; 11304e68de40Speter } 11318093a2efSthien if (al1->type == NIL || ap->type == NIL) 11324e68de40Speter return; 11338093a2efSthien if (al1->type != ap->type) { 11344e68de40Speter error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 11354e68de40Speter return; 11364e68de40Speter } 11378093a2efSthien k = width(al1); 11384e68de40Speter itemwidth = width(ap->type); 11394e68de40Speter ap = ap->chain; 11408093a2efSthien al1 = al1->chain; 11418093a2efSthien if (ap->chain != NIL || al1->chain != NIL) { 11424e68de40Speter error("%s requires a and z to be single dimension arrays", pu); 11434e68de40Speter return; 11444e68de40Speter } 11458093a2efSthien if (ap == NIL || al1 == NIL) 11464e68de40Speter return; 11474e68de40Speter /* 11488093a2efSthien * al1 is the range for z i.e. u..v 11494e68de40Speter * ap is the range for a i.e. m..n 11504e68de40Speter * i will be n-m+1 11514e68de40Speter * j will be v-u+1 11524e68de40Speter */ 11534e68de40Speter i = ap->range[1] - ap->range[0] + 1; 11548093a2efSthien j = al1->range[1] - al1->range[0] + 1; 11554e68de40Speter if (i < j) { 11568093a2efSthien error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i); 11574e68de40Speter return; 11584e68de40Speter } 11594e68de40Speter /* 11604e68de40Speter * get n-m-(v-u) and m for the interpreter 11614e68de40Speter */ 11624e68de40Speter i -= j; 11634e68de40Speter j = ap->range[0]; 11648093a2efSthien (void) put(2, O_CON24, k); 11658093a2efSthien (void) put(2, O_CON24, i); 11668093a2efSthien (void) put(2, O_CON24, j); 11678093a2efSthien (void) put(2, O_CON24, itemwidth); 11688093a2efSthien al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 11697bfefa1bSmckusic ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 11708093a2efSthien ap = stkrval(pui, NLNIL , (long) RREQ ); 11717bfefa1bSmckusic if (ap == NIL) 11727bfefa1bSmckusic return; 11738093a2efSthien (void) put(1, op); 11744e68de40Speter return; 11754e68de40Speter case 0: 11768c0920b2Smckusick error("%s is an unimplemented extension", p->symbol); 11774e68de40Speter return; 11784e68de40Speter 11794e68de40Speter default: 11804e68de40Speter panic("proc case"); 11814e68de40Speter } 11824e68de40Speter } 11834e68de40Speter #endif OBJ 1184