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% 6d5132383Sdist */ 7abb72cc5Speter 83920fdb9Smckusick #ifndef lint 9*6e17b0ceSbostic static char sccsid[] = "@(#)pcproc.c 8.1 (Berkeley) 06/06/93"; 10b85afe43Sbostic #endif /* not lint */ 11abb72cc5Speter 12abb72cc5Speter #include "whoami.h" 13abb72cc5Speter #ifdef PC 14abb72cc5Speter /* 15abb72cc5Speter * and to the end of the file 16abb72cc5Speter */ 17abb72cc5Speter #include "0.h" 18abb72cc5Speter #include "tree.h" 198074ecd3Speter #include "objfmt.h" 20abb72cc5Speter #include "opcode.h" 21abb72cc5Speter #include "pc.h" 2293ae45d0Sralph #include <pcc.h> 23d83b6980Speter #include "tmps.h" 243920fdb9Smckusick #include "tree_ty.h" 25abb72cc5Speter 26abb72cc5Speter /* 27a40a5705Smckusick * The constant EXPOSIZE specifies the number of digits in the exponent 28a40a5705Smckusick * of real numbers. 29a40a5705Smckusick * 30888c82dfSmckusick * The constant REALSPC defines the amount of forced padding preceeding 31888c82dfSmckusick * real numbers when they are printed. If REALSPC == 0, then no padding 32888c82dfSmckusick * is added, REALSPC == 1 adds one extra blank irregardless of the width 33888c82dfSmckusick * specified by the user. 34888c82dfSmckusick * 35888c82dfSmckusick * N.B. - Values greater than one require program mods. 36888c82dfSmckusick */ 37a40a5705Smckusick #define EXPOSIZE 2 38888c82dfSmckusick #define REALSPC 0 39888c82dfSmckusick 40888c82dfSmckusick /* 41abb72cc5Speter * The following array is used to determine which classes may be read 42abb72cc5Speter * from textfiles. It is indexed by the return value from classify. 43abb72cc5Speter */ 44abb72cc5Speter #define rdops(x) rdxxxx[(x)-(TFIRST)] 45abb72cc5Speter 46abb72cc5Speter int rdxxxx[] = { 47abb72cc5Speter 0, /* -7 file types */ 48abb72cc5Speter 0, /* -6 record types */ 49abb72cc5Speter 0, /* -5 array types */ 50abb72cc5Speter O_READE, /* -4 scalar types */ 51abb72cc5Speter 0, /* -3 pointer types */ 52abb72cc5Speter 0, /* -2 set types */ 53abb72cc5Speter 0, /* -1 string types */ 54abb72cc5Speter 0, /* 0 nil, no type */ 55abb72cc5Speter O_READE, /* 1 boolean */ 56abb72cc5Speter O_READC, /* 2 character */ 57abb72cc5Speter O_READ4, /* 3 integer */ 58abb72cc5Speter O_READ8 /* 4 real */ 59abb72cc5Speter }; 60abb72cc5Speter 61abb72cc5Speter /* 62abb72cc5Speter * Proc handles procedure calls. 63abb72cc5Speter * Non-builtin procedures are "buck-passed" to func (with a flag 64abb72cc5Speter * indicating that they are actually procedures. 65abb72cc5Speter * builtin procedures are handled here. 66abb72cc5Speter */ 67abb72cc5Speter pcproc(r) 683920fdb9Smckusick struct tnode *r; /* T_PCALL */ 69abb72cc5Speter { 70abb72cc5Speter register struct nl *p; 713920fdb9Smckusick register struct tnode *alv, *al; 723920fdb9Smckusick register op; 73abb72cc5Speter struct nl *filetype, *ap; 743920fdb9Smckusick int argc, typ, fmtspec, strfmt; 753920fdb9Smckusick struct tnode *argv, *file; 762b1313dbSmckusick char fmt, format[20], *strptr, *cmd; 773920fdb9Smckusick int prec, field, strnglen, fmtstart; 783920fdb9Smckusick char *pu; 793920fdb9Smckusick struct tnode *pua, *pui, *puz; 80abb72cc5Speter int i, j, k; 81abb72cc5Speter int itemwidth; 82abb72cc5Speter char *readname; 83d8325541Speter struct nl *tempnlp; 84abb72cc5Speter long readtype; 8540960f52Smckusic struct tmps soffset; 861e7f77a5Smckusick bool soffset_flag; 87abb72cc5Speter 88abb72cc5Speter #define CONPREC 4 89abb72cc5Speter #define VARPREC 8 90abb72cc5Speter #define CONWIDTH 1 91abb72cc5Speter #define VARWIDTH 2 92abb72cc5Speter #define SKIP 16 93abb72cc5Speter 94abb72cc5Speter /* 95abb72cc5Speter * Verify that the name is 96abb72cc5Speter * defined and is that of a 97abb72cc5Speter * procedure. 98abb72cc5Speter */ 993920fdb9Smckusick p = lookup(r->pcall_node.proc_id); 1003920fdb9Smckusick if (p == NLNIL) { 1013920fdb9Smckusick rvlist(r->pcall_node.arg); 102abb72cc5Speter return; 103abb72cc5Speter } 104fa12adeaSpeter if (p->class != PROC && p->class != FPROC) { 105abb72cc5Speter error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); 1063920fdb9Smckusick rvlist(r->pcall_node.arg); 107abb72cc5Speter return; 108abb72cc5Speter } 1093920fdb9Smckusick argv = r->pcall_node.arg; 110abb72cc5Speter 111abb72cc5Speter /* 112abb72cc5Speter * Call handles user defined 113abb72cc5Speter * procedures and functions. 114abb72cc5Speter */ 115abb72cc5Speter if (bn != 0) { 1163920fdb9Smckusick (void) call(p, argv, PROC, bn); 117abb72cc5Speter return; 118abb72cc5Speter } 119abb72cc5Speter 120abb72cc5Speter /* 121abb72cc5Speter * Call to built-in procedure. 122abb72cc5Speter * Count the arguments. 123abb72cc5Speter */ 124abb72cc5Speter argc = 0; 1253920fdb9Smckusick for (al = argv; al != TR_NIL; al = al->list_node.next) 126abb72cc5Speter argc++; 127abb72cc5Speter 128abb72cc5Speter /* 129abb72cc5Speter * Switch on the operator 130abb72cc5Speter * associated with the built-in 131abb72cc5Speter * procedure in the namelist 132abb72cc5Speter */ 133abb72cc5Speter op = p->value[0] &~ NSTAND; 134abb72cc5Speter if (opt('s') && (p->value[0] & NSTAND)) { 135abb72cc5Speter standard(); 136abb72cc5Speter error("%s is a nonstandard procedure", p->symbol); 137abb72cc5Speter } 138abb72cc5Speter switch (op) { 139abb72cc5Speter 140abb72cc5Speter case O_ABORT: 141abb72cc5Speter if (argc != 0) 142abb72cc5Speter error("null takes no arguments"); 143abb72cc5Speter return; 144abb72cc5Speter 145abb72cc5Speter case O_FLUSH: 146abb72cc5Speter if (argc == 0) { 14793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , "_PFLUSH" ); 14893ae45d0Sralph putop( PCCOM_UNARY PCC_CALL , PCCT_INT ); 149abb72cc5Speter putdot( filename , line ); 150abb72cc5Speter return; 151abb72cc5Speter } 152abb72cc5Speter if (argc != 1) { 153abb72cc5Speter error("flush takes at most one argument"); 154abb72cc5Speter return; 155abb72cc5Speter } 15693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 15793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 158abb72cc5Speter , "_FLUSH" ); 1593920fdb9Smckusick ap = stklval(argv->list_node.list, NOFLAGS); 1603920fdb9Smckusick if (ap == NLNIL) 161abb72cc5Speter return; 162abb72cc5Speter if (ap->class != FILET) { 163abb72cc5Speter error("flush's argument must be a file, not %s", nameof(ap)); 164abb72cc5Speter return; 165abb72cc5Speter } 16693ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 167abb72cc5Speter putdot( filename , line ); 168abb72cc5Speter return; 169abb72cc5Speter 170abb72cc5Speter case O_MESSAGE: 171abb72cc5Speter case O_WRITEF: 172abb72cc5Speter case O_WRITLN: 173abb72cc5Speter /* 174abb72cc5Speter * Set up default file "output"'s type 175abb72cc5Speter */ 176abb72cc5Speter file = NIL; 177abb72cc5Speter filetype = nl+T1CHAR; 178abb72cc5Speter /* 179abb72cc5Speter * Determine the file implied 180abb72cc5Speter * for the write and generate 181abb72cc5Speter * code to make it the active file. 182abb72cc5Speter */ 183abb72cc5Speter if (op == O_MESSAGE) { 184abb72cc5Speter /* 185abb72cc5Speter * For message, all that matters 186abb72cc5Speter * is that the filetype is 187abb72cc5Speter * a character file. 188abb72cc5Speter * Thus "output" will suit us fine. 189abb72cc5Speter */ 19093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , "_PFLUSH" ); 19193ae45d0Sralph putop( PCCOM_UNARY PCC_CALL , PCCT_INT ); 192abb72cc5Speter putdot( filename , line ); 1933920fdb9Smckusick putRV( (char *) 0 , cbn , CURFILEOFFSET , NLOCAL , 19493ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 19593ae45d0Sralph putLV( "__err" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY ); 19693ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 197abb72cc5Speter putdot( filename , line ); 1983920fdb9Smckusick } else if (argv != TR_NIL && (al = argv->list_node.list)->tag != 1993920fdb9Smckusick T_WEXP) { 200abb72cc5Speter /* 201abb72cc5Speter * If there is a first argument which has 202abb72cc5Speter * no write widths, then it is potentially 203abb72cc5Speter * a file name. 204abb72cc5Speter */ 205abb72cc5Speter codeoff(); 2063920fdb9Smckusick ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ ); 207abb72cc5Speter codeon(); 2083920fdb9Smckusick if (ap == NLNIL) 2093920fdb9Smckusick argv = argv->list_node.next; 210abb72cc5Speter if (ap != NIL && ap->class == FILET) { 211abb72cc5Speter /* 212abb72cc5Speter * Got "write(f, ...", make 213abb72cc5Speter * f the active file, and save 214abb72cc5Speter * it and its type for use in 215abb72cc5Speter * processing the rest of the 216abb72cc5Speter * arguments to write. 217abb72cc5Speter */ 2183920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , 21993ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 22093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 22193ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 222abb72cc5Speter , "_UNIT" ); 2233920fdb9Smckusick file = argv->list_node.list; 224abb72cc5Speter filetype = ap->type; 2253920fdb9Smckusick (void) stklval(argv->list_node.list, NOFLAGS); 22693ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 22793ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 228abb72cc5Speter putdot( filename , line ); 229abb72cc5Speter /* 230abb72cc5Speter * Skip over the first argument 231abb72cc5Speter */ 2323920fdb9Smckusick argv = argv->list_node.next; 233abb72cc5Speter argc--; 234abb72cc5Speter } else { 235abb72cc5Speter /* 236abb72cc5Speter * Set up for writing on 237abb72cc5Speter * standard output. 238abb72cc5Speter */ 2393920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , 24093ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 241d8325541Speter putLV( "_output" , 0 , 0 , NGLOBAL , 24293ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 24393ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 244abb72cc5Speter putdot( filename , line ); 245fb503f1eSpeter output->nl_flags |= NUSED; 246abb72cc5Speter } 247abb72cc5Speter } else { 2483920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL , 24993ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 25093ae45d0Sralph putLV( "_output" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY ); 25193ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 252abb72cc5Speter putdot( filename , line ); 253fb503f1eSpeter output->nl_flags |= NUSED; 254abb72cc5Speter } 255abb72cc5Speter /* 256abb72cc5Speter * Loop and process each 257abb72cc5Speter * of the arguments. 258abb72cc5Speter */ 2593920fdb9Smckusick for (; argv != TR_NIL; argv = argv->list_node.next) { 2601e7f77a5Smckusick soffset_flag = FALSE; 261abb72cc5Speter /* 262abb72cc5Speter * fmtspec indicates the type (CONstant or VARiable) 263abb72cc5Speter * and number (none, WIDTH, and/or PRECision) 264abb72cc5Speter * of the fields in the printf format for this 265abb72cc5Speter * output variable. 266abb72cc5Speter * fmt is the format output indicator (D, E, F, O, X, S) 267abb72cc5Speter * fmtstart = 0 for leading blank; = 1 for no blank 268abb72cc5Speter */ 269abb72cc5Speter fmtspec = NIL; 270abb72cc5Speter fmt = 'D'; 271abb72cc5Speter fmtstart = 1; 2723920fdb9Smckusick al = argv->list_node.list; 273abb72cc5Speter if (al == NIL) 274abb72cc5Speter continue; 2753920fdb9Smckusick if (al->tag == T_WEXP) 2763920fdb9Smckusick alv = al->wexpr_node.expr1; 277abb72cc5Speter else 278abb72cc5Speter alv = al; 2793920fdb9Smckusick if (alv == TR_NIL) 280abb72cc5Speter continue; 281abb72cc5Speter codeoff(); 2823920fdb9Smckusick ap = stkrval(alv, NLNIL , (long) RREQ ); 283abb72cc5Speter codeon(); 2843920fdb9Smckusick if (ap == NLNIL) 285abb72cc5Speter continue; 286abb72cc5Speter typ = classify(ap); 2873920fdb9Smckusick if (al->tag == T_WEXP) { 288abb72cc5Speter /* 289abb72cc5Speter * Handle width expressions. 290abb72cc5Speter * The basic game here is that width 291abb72cc5Speter * expressions get evaluated. If they 292abb72cc5Speter * are constant, the value is placed 293abb72cc5Speter * directly in the format string. 294abb72cc5Speter * Otherwise the value is pushed onto 295abb72cc5Speter * the stack and an indirection is 296abb72cc5Speter * put into the format string. 297abb72cc5Speter */ 2983920fdb9Smckusick if (al->wexpr_node.expr3 == 2993920fdb9Smckusick (struct tnode *) OCT) 300abb72cc5Speter fmt = 'O'; 3013920fdb9Smckusick else if (al->wexpr_node.expr3 == 3023920fdb9Smckusick (struct tnode *) HEX) 303abb72cc5Speter fmt = 'X'; 3043920fdb9Smckusick else if (al->wexpr_node.expr3 != TR_NIL) { 305abb72cc5Speter /* 306abb72cc5Speter * Evaluate second format spec 307abb72cc5Speter */ 3083920fdb9Smckusick if ( constval(al->wexpr_node.expr3) 309abb72cc5Speter && isa( con.ctype , "i" ) ) { 310abb72cc5Speter fmtspec += CONPREC; 311abb72cc5Speter prec = con.crval; 312abb72cc5Speter } else { 313abb72cc5Speter fmtspec += VARPREC; 314abb72cc5Speter } 315abb72cc5Speter fmt = 'f'; 316abb72cc5Speter switch ( typ ) { 317abb72cc5Speter case TINT: 318abb72cc5Speter if ( opt( 's' ) ) { 319abb72cc5Speter standard(); 320abb72cc5Speter error("Writing %ss with two write widths is non-standard", clnames[typ]); 321abb72cc5Speter } 322abb72cc5Speter /* and fall through */ 323abb72cc5Speter case TDOUBLE: 324abb72cc5Speter break; 325abb72cc5Speter default: 326abb72cc5Speter error("Cannot write %ss with two write widths", clnames[typ]); 327abb72cc5Speter continue; 328abb72cc5Speter } 329abb72cc5Speter } 330abb72cc5Speter /* 331abb72cc5Speter * Evaluate first format spec 332abb72cc5Speter */ 3333920fdb9Smckusick if (al->wexpr_node.expr2 != TR_NIL) { 3343920fdb9Smckusick if ( constval(al->wexpr_node.expr2) 335abb72cc5Speter && isa( con.ctype , "i" ) ) { 336abb72cc5Speter fmtspec += CONWIDTH; 337abb72cc5Speter field = con.crval; 338abb72cc5Speter } else { 339abb72cc5Speter fmtspec += VARWIDTH; 340abb72cc5Speter } 341abb72cc5Speter } 342abb72cc5Speter if ((fmtspec & CONPREC) && prec < 0 || 343abb72cc5Speter (fmtspec & CONWIDTH) && field < 0) { 344abb72cc5Speter error("Negative widths are not allowed"); 345abb72cc5Speter continue; 346abb72cc5Speter } 3470432a991Smckusic if ( opt('s') && 3480432a991Smckusic ((fmtspec & CONPREC) && prec == 0 || 3490432a991Smckusic (fmtspec & CONWIDTH) && field == 0)) { 3500432a991Smckusic standard(); 3510432a991Smckusic error("Zero widths are non-standard"); 3520432a991Smckusic } 353abb72cc5Speter } 354abb72cc5Speter if (filetype != nl+T1CHAR) { 355abb72cc5Speter if (fmt == 'O' || fmt == 'X') { 356abb72cc5Speter error("Oct/hex allowed only on text files"); 357abb72cc5Speter continue; 358abb72cc5Speter } 359abb72cc5Speter if (fmtspec) { 360abb72cc5Speter error("Write widths allowed only on text files"); 361abb72cc5Speter continue; 362abb72cc5Speter } 363abb72cc5Speter /* 364abb72cc5Speter * Generalized write, i.e. 365abb72cc5Speter * to a non-textfile. 366abb72cc5Speter */ 36793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 36893ae45d0Sralph , (int) (PCCM_ADDTYPE( 36993ae45d0Sralph PCCM_ADDTYPE( 37093ae45d0Sralph PCCM_ADDTYPE( p2type( filetype ) 37193ae45d0Sralph , PCCTM_PTR ) 37293ae45d0Sralph , PCCTM_FTN ) 37393ae45d0Sralph , PCCTM_PTR )) 374abb72cc5Speter , "_FNIL" ); 3753920fdb9Smckusick (void) stklval(file, NOFLAGS); 37693ae45d0Sralph putop( PCC_CALL 37793ae45d0Sralph , PCCM_ADDTYPE( p2type( filetype ) , PCCTM_PTR ) ); 37893ae45d0Sralph putop( PCCOM_UNARY PCC_MUL , p2type( filetype ) ); 379abb72cc5Speter /* 380abb72cc5Speter * file^ := ... 381abb72cc5Speter */ 382abb72cc5Speter switch ( classify( filetype ) ) { 383abb72cc5Speter case TBOOL: 384abb72cc5Speter case TCHAR: 385abb72cc5Speter case TINT: 386abb72cc5Speter case TSCAL: 387716c00f4Speter precheck( filetype , "_RANG4" , "_RSNG4" ); 388abb72cc5Speter /* and fall through */ 389abb72cc5Speter case TDOUBLE: 390abb72cc5Speter case TPTR: 3913920fdb9Smckusick ap = rvalue( argv->list_node.list , filetype , RREQ ); 392abb72cc5Speter break; 393abb72cc5Speter default: 3943920fdb9Smckusick ap = rvalue( argv->list_node.list , filetype , LREQ ); 395abb72cc5Speter break; 396abb72cc5Speter } 397abb72cc5Speter if (ap == NIL) 398abb72cc5Speter continue; 3993920fdb9Smckusick if (incompat(ap, filetype, argv->list_node.list)) { 400abb72cc5Speter cerror("Type mismatch in write to non-text file"); 401abb72cc5Speter continue; 402abb72cc5Speter } 403abb72cc5Speter switch ( classify( filetype ) ) { 404abb72cc5Speter case TBOOL: 405abb72cc5Speter case TCHAR: 406abb72cc5Speter case TINT: 407abb72cc5Speter case TSCAL: 408d0dbf57bSpeter postcheck(filetype, ap); 409d0dbf57bSpeter sconv(p2type(ap), p2type(filetype)); 410abb72cc5Speter /* and fall through */ 411abb72cc5Speter case TDOUBLE: 412abb72cc5Speter case TPTR: 41393ae45d0Sralph putop( PCC_ASSIGN , p2type( filetype ) ); 414abb72cc5Speter putdot( filename , line ); 415abb72cc5Speter break; 416abb72cc5Speter default: 41793ae45d0Sralph putstrop(PCC_STASG, 41893ae45d0Sralph PCCM_ADDTYPE(p2type(filetype), 41993ae45d0Sralph PCCTM_PTR), 4203920fdb9Smckusick (int) lwidth(filetype), 4219423b04dSpeter align(filetype)); 422abb72cc5Speter putdot( filename , line ); 423abb72cc5Speter break; 424abb72cc5Speter } 425abb72cc5Speter /* 426abb72cc5Speter * put(file) 427abb72cc5Speter */ 42893ae45d0Sralph putleaf( PCC_ICON , 0 , 0 42993ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 430abb72cc5Speter , "_PUT" ); 4313920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , 43293ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 43393ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 434abb72cc5Speter putdot( filename , line ); 435abb72cc5Speter continue; 436abb72cc5Speter } 437abb72cc5Speter /* 438abb72cc5Speter * Write to a textfile 439abb72cc5Speter * 440abb72cc5Speter * Evaluate the expression 441abb72cc5Speter * to be written. 442abb72cc5Speter */ 443abb72cc5Speter if (fmt == 'O' || fmt == 'X') { 444abb72cc5Speter if (opt('s')) { 445abb72cc5Speter standard(); 446abb72cc5Speter error("Oct and hex are non-standard"); 447abb72cc5Speter } 448abb72cc5Speter if (typ == TSTR || typ == TDOUBLE) { 449abb72cc5Speter error("Can't write %ss with oct/hex", clnames[typ]); 450abb72cc5Speter continue; 451abb72cc5Speter } 452abb72cc5Speter if (typ == TCHAR || typ == TBOOL) 453abb72cc5Speter typ = TINT; 454abb72cc5Speter } 455abb72cc5Speter /* 456abb72cc5Speter * If there is no format specified by the programmer, 457abb72cc5Speter * implement the default. 458abb72cc5Speter */ 459abb72cc5Speter switch (typ) { 4609a1d991fSmckusick case TPTR: 4619a1d991fSmckusick warning(); 4629a1d991fSmckusick if (opt('s')) { 4639a1d991fSmckusick standard(); 4649a1d991fSmckusick } 4659a1d991fSmckusick error("Writing %ss to text files is non-standard", 4669a1d991fSmckusick clnames[typ]); 4679a1d991fSmckusick /* and fall through */ 468abb72cc5Speter case TINT: 469abb72cc5Speter if (fmt == 'f') { 470abb72cc5Speter typ = TDOUBLE; 471abb72cc5Speter goto tdouble; 472abb72cc5Speter } 473abb72cc5Speter if (fmtspec == NIL) { 474abb72cc5Speter if (fmt == 'D') 475abb72cc5Speter field = 10; 476abb72cc5Speter else if (fmt == 'X') 477abb72cc5Speter field = 8; 478abb72cc5Speter else if (fmt == 'O') 479abb72cc5Speter field = 11; 480abb72cc5Speter else 481abb72cc5Speter panic("fmt1"); 482abb72cc5Speter fmtspec = CONWIDTH; 483abb72cc5Speter } 484abb72cc5Speter break; 485abb72cc5Speter case TCHAR: 486abb72cc5Speter tchar: 487abb72cc5Speter fmt = 'c'; 488abb72cc5Speter break; 489abb72cc5Speter case TSCAL: 4909275f63aSpeter warning(); 491abb72cc5Speter if (opt('s')) { 492abb72cc5Speter standard(); 493abb72cc5Speter } 4949a1d991fSmckusick error("Writing %ss to text files is non-standard", 4959a1d991fSmckusick clnames[typ]); 496abb72cc5Speter case TBOOL: 497abb72cc5Speter fmt = 's'; 498abb72cc5Speter break; 499abb72cc5Speter case TDOUBLE: 500abb72cc5Speter tdouble: 501abb72cc5Speter switch (fmtspec) { 502abb72cc5Speter case NIL: 503a40a5705Smckusick field = 14 + (5 + EXPOSIZE); 504a40a5705Smckusick prec = field - (5 + EXPOSIZE); 50540960f52Smckusic fmt = 'e'; 506abb72cc5Speter fmtspec = CONWIDTH + CONPREC; 507abb72cc5Speter break; 508abb72cc5Speter case CONWIDTH: 509888c82dfSmckusick field -= REALSPC; 510888c82dfSmckusick if (field < 1) 511abb72cc5Speter field = 1; 512a40a5705Smckusick prec = field - (5 + EXPOSIZE); 513abb72cc5Speter if (prec < 1) 514abb72cc5Speter prec = 1; 515abb72cc5Speter fmtspec += CONPREC; 51640960f52Smckusic fmt = 'e'; 517abb72cc5Speter break; 518abb72cc5Speter case VARWIDTH: 519abb72cc5Speter fmtspec += VARPREC; 52040960f52Smckusic fmt = 'e'; 521abb72cc5Speter break; 522abb72cc5Speter case CONWIDTH + CONPREC: 523abb72cc5Speter case CONWIDTH + VARPREC: 524888c82dfSmckusick field -= REALSPC; 525888c82dfSmckusick if (field < 1) 526abb72cc5Speter field = 1; 527abb72cc5Speter } 528abb72cc5Speter format[0] = ' '; 529888c82dfSmckusick fmtstart = 1 - REALSPC; 530abb72cc5Speter break; 531abb72cc5Speter case TSTR: 5323920fdb9Smckusick (void) constval( alv ); 533abb72cc5Speter switch ( classify( con.ctype ) ) { 534abb72cc5Speter case TCHAR: 535abb72cc5Speter typ = TCHAR; 536abb72cc5Speter goto tchar; 537abb72cc5Speter case TSTR: 538abb72cc5Speter strptr = con.cpval; 539abb72cc5Speter for (strnglen = 0; *strptr++; strnglen++) /* void */; 540abb72cc5Speter strptr = con.cpval; 541abb72cc5Speter break; 542abb72cc5Speter default: 543abb72cc5Speter strnglen = width(ap); 544abb72cc5Speter break; 545abb72cc5Speter } 546abb72cc5Speter fmt = 's'; 547abb72cc5Speter strfmt = fmtspec; 548abb72cc5Speter if (fmtspec == NIL) { 549abb72cc5Speter fmtspec = SKIP; 550abb72cc5Speter break; 551abb72cc5Speter } 552abb72cc5Speter if (fmtspec & CONWIDTH) { 553abb72cc5Speter if (field <= strnglen) 554abb72cc5Speter fmtspec = SKIP; 555abb72cc5Speter else 556abb72cc5Speter field -= strnglen; 557abb72cc5Speter } 558abb72cc5Speter break; 559abb72cc5Speter default: 560abb72cc5Speter error("Can't write %ss to a text file", clnames[typ]); 561abb72cc5Speter continue; 562abb72cc5Speter } 563abb72cc5Speter /* 564abb72cc5Speter * Generate the format string 565abb72cc5Speter */ 566abb72cc5Speter switch (fmtspec) { 567abb72cc5Speter default: 568abb72cc5Speter panic("fmt2"); 569abb72cc5Speter case NIL: 570abb72cc5Speter if (fmt == 'c') { 571abb72cc5Speter if ( opt( 't' ) ) { 57293ae45d0Sralph putleaf( PCC_ICON , 0 , 0 57393ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN|PCCT_INT , PCCTM_PTR ) 574abb72cc5Speter , "_WRITEC" ); 5753920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 57693ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 5773920fdb9Smckusick (void) stkrval( alv , NLNIL , (long) RREQ ); 57893ae45d0Sralph putop( PCC_CM , PCCT_INT ); 579abb72cc5Speter } else { 58093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 58193ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN|PCCT_INT , PCCTM_PTR ) 582abb72cc5Speter , "_fputc" ); 5833920fdb9Smckusick (void) stkrval( alv , NLNIL , 5843920fdb9Smckusick (long) RREQ ); 585abb72cc5Speter } 58693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 58793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 588abb72cc5Speter , "_ACTFILE" ); 5893920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , 59093ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 59193ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 59293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 59393ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 594abb72cc5Speter putdot( filename , line ); 595abb72cc5Speter } else { 596abb72cc5Speter sprintf(&format[1], "%%%c", fmt); 597abb72cc5Speter goto fmtgen; 598abb72cc5Speter } 599abb72cc5Speter case SKIP: 600abb72cc5Speter break; 601abb72cc5Speter case CONWIDTH: 602abb72cc5Speter sprintf(&format[1], "%%%1D%c", field, fmt); 603abb72cc5Speter goto fmtgen; 604abb72cc5Speter case VARWIDTH: 605abb72cc5Speter sprintf(&format[1], "%%*%c", fmt); 606abb72cc5Speter goto fmtgen; 607abb72cc5Speter case CONWIDTH + CONPREC: 608abb72cc5Speter sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt); 609abb72cc5Speter goto fmtgen; 610abb72cc5Speter case CONWIDTH + VARPREC: 611abb72cc5Speter sprintf(&format[1], "%%%1D.*%c", field, fmt); 612abb72cc5Speter goto fmtgen; 613abb72cc5Speter case VARWIDTH + CONPREC: 614abb72cc5Speter sprintf(&format[1], "%%*.%1D%c", prec, fmt); 615abb72cc5Speter goto fmtgen; 616abb72cc5Speter case VARWIDTH + VARPREC: 617abb72cc5Speter sprintf(&format[1], "%%*.*%c", fmt); 618abb72cc5Speter fmtgen: 619abb72cc5Speter if ( opt( 't' ) ) { 62093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 62193ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 622abb72cc5Speter , "_WRITEF" ); 6233920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 62493ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 62593ae45d0Sralph putleaf( PCC_ICON , 0 , 0 62693ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 627abb72cc5Speter , "_ACTFILE" ); 6283920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 62993ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 63093ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 63193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 632abb72cc5Speter } else { 63393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 63493ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 635abb72cc5Speter , "_fprintf" ); 63693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 63793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 638abb72cc5Speter , "_ACTFILE" ); 6393920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 64093ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 64193ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 642abb72cc5Speter } 643abb72cc5Speter putCONG( &format[ fmtstart ] 644abb72cc5Speter , strlen( &format[ fmtstart ] ) 645abb72cc5Speter , LREQ ); 64693ae45d0Sralph putop( PCC_CM , PCCT_INT ); 647abb72cc5Speter if ( fmtspec & VARWIDTH ) { 648abb72cc5Speter /* 649abb72cc5Speter * either 650abb72cc5Speter * ,(temp=width,MAX(temp,...)), 651abb72cc5Speter * or 652abb72cc5Speter * , MAX( width , ... ) , 653abb72cc5Speter */ 6543920fdb9Smckusick if ( ( typ == TDOUBLE && 6553920fdb9Smckusick al->wexpr_node.expr3 == TR_NIL ) 656abb72cc5Speter || typ == TSTR ) { 6571e7f77a5Smckusick soffset_flag = TRUE; 65840960f52Smckusic soffset = sizes[cbn].curtmps; 6593920fdb9Smckusick tempnlp = tmpalloc((long) (sizeof(long)), 66040960f52Smckusic nl+T4INT, REGOK); 6613920fdb9Smckusick putRV((char *) 0 , cbn , 662d8325541Speter tempnlp -> value[ NL_OFFS ] , 66393ae45d0Sralph tempnlp -> extra_flags , PCCT_INT ); 6643920fdb9Smckusick ap = stkrval( al->wexpr_node.expr2 , 6653920fdb9Smckusick NLNIL , (long) RREQ ); 66693ae45d0Sralph putop( PCC_ASSIGN , PCCT_INT ); 66793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 66893ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 669abb72cc5Speter , "_MAX" ); 6703920fdb9Smckusick putRV((char *) 0 , cbn , 671d8325541Speter tempnlp -> value[ NL_OFFS ] , 67293ae45d0Sralph tempnlp -> extra_flags , PCCT_INT ); 673abb72cc5Speter } else { 674abb72cc5Speter if (opt('t') 675abb72cc5Speter || typ == TSTR || typ == TDOUBLE) { 67693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 67793ae45d0Sralph ,PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT, PCCTM_PTR ) 678abb72cc5Speter ,"_MAX" ); 679abb72cc5Speter } 6803920fdb9Smckusick ap = stkrval( al->wexpr_node.expr2, 6813920fdb9Smckusick NLNIL , (long) RREQ ); 682abb72cc5Speter } 6833920fdb9Smckusick if (ap == NLNIL) 684abb72cc5Speter continue; 685abb72cc5Speter if (isnta(ap,"i")) { 686abb72cc5Speter error("First write width must be integer, not %s", nameof(ap)); 687abb72cc5Speter continue; 688abb72cc5Speter } 689abb72cc5Speter switch ( typ ) { 690abb72cc5Speter case TDOUBLE: 69193ae45d0Sralph putleaf( PCC_ICON , REALSPC , 0 , PCCT_INT , (char *) 0 ); 69293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 69393ae45d0Sralph putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 69493ae45d0Sralph putop( PCC_CM , PCCT_INT ); 69593ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 6963920fdb9Smckusick if ( al->wexpr_node.expr3 == TR_NIL ) { 697abb72cc5Speter /* 698abb72cc5Speter * finish up the comma op 699abb72cc5Speter */ 70093ae45d0Sralph putop( PCC_COMOP , PCCT_INT ); 701abb72cc5Speter fmtspec &= ~VARPREC; 70293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 70393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 70493ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 705abb72cc5Speter , "_MAX" ); 7063920fdb9Smckusick putRV((char *) 0 , cbn , 707d8325541Speter tempnlp -> value[ NL_OFFS ] , 708d8325541Speter tempnlp -> extra_flags , 70993ae45d0Sralph PCCT_INT ); 71093ae45d0Sralph putleaf( PCC_ICON , 711a40a5705Smckusick 5 + EXPOSIZE + REALSPC , 71293ae45d0Sralph 0 , PCCT_INT , (char *) 0 ); 71393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 71493ae45d0Sralph putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 71593ae45d0Sralph putop( PCC_CM , PCCT_INT ); 71693ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 717abb72cc5Speter } 71893ae45d0Sralph putop( PCC_CM , PCCT_INT ); 719abb72cc5Speter break; 720abb72cc5Speter case TSTR: 72193ae45d0Sralph putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 ); 72293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 72393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 72493ae45d0Sralph putop( PCC_CM , PCCT_INT ); 72593ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 72693ae45d0Sralph putop( PCC_COMOP , PCCT_INT ); 72793ae45d0Sralph putop( PCC_CM , PCCT_INT ); 728abb72cc5Speter break; 729abb72cc5Speter default: 730abb72cc5Speter if (opt('t')) { 73193ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 73293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 73393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 73493ae45d0Sralph putop( PCC_CM , PCCT_INT ); 73593ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 736abb72cc5Speter } 73793ae45d0Sralph putop( PCC_CM , PCCT_INT ); 738abb72cc5Speter break; 739abb72cc5Speter } 740abb72cc5Speter } 741abb72cc5Speter /* 742abb72cc5Speter * If there is a variable precision, 743abb72cc5Speter * evaluate it 744abb72cc5Speter */ 745abb72cc5Speter if (fmtspec & VARPREC) { 746abb72cc5Speter if (opt('t')) { 74793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 74893ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 749abb72cc5Speter , "_MAX" ); 750abb72cc5Speter } 7513920fdb9Smckusick ap = stkrval( al->wexpr_node.expr3 , 7523920fdb9Smckusick NLNIL , (long) RREQ ); 753abb72cc5Speter if (ap == NIL) 754abb72cc5Speter continue; 755abb72cc5Speter if (isnta(ap,"i")) { 756abb72cc5Speter error("Second write width must be integer, not %s", nameof(ap)); 757abb72cc5Speter continue; 758abb72cc5Speter } 759abb72cc5Speter if (opt('t')) { 76093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 76193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 76293ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 76393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 76493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 765abb72cc5Speter } 76693ae45d0Sralph putop( PCC_CM , PCCT_INT ); 767abb72cc5Speter } 768abb72cc5Speter /* 769abb72cc5Speter * evaluate the thing we want printed. 770abb72cc5Speter */ 771abb72cc5Speter switch ( typ ) { 7729a1d991fSmckusick case TPTR: 773abb72cc5Speter case TCHAR: 774abb72cc5Speter case TINT: 7753920fdb9Smckusick (void) stkrval( alv , NLNIL , (long) RREQ ); 77693ae45d0Sralph putop( PCC_CM , PCCT_INT ); 777abb72cc5Speter break; 778abb72cc5Speter case TDOUBLE: 7793920fdb9Smckusick ap = stkrval( alv , NLNIL , (long) RREQ ); 780abb72cc5Speter if (isnta(ap, "d")) { 78193ae45d0Sralph sconv(p2type(ap), PCCT_DOUBLE); 782abb72cc5Speter } 78393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 784abb72cc5Speter break; 785abb72cc5Speter case TSCAL: 786abb72cc5Speter case TBOOL: 78793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 78893ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 789abb72cc5Speter , "_NAM" ); 7903920fdb9Smckusick ap = stkrval( alv , NLNIL , (long) RREQ ); 791abb72cc5Speter sprintf( format , PREFIXFORMAT , LABELPREFIX 792abb72cc5Speter , listnames( ap ) ); 79393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , 79493ae45d0Sralph (int) (PCCTM_PTR | PCCT_CHAR), format ); 79593ae45d0Sralph putop( PCC_CM , PCCT_INT ); 79693ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 79793ae45d0Sralph putop( PCC_CM , PCCT_INT ); 798abb72cc5Speter break; 799abb72cc5Speter case TSTR: 800abb72cc5Speter putCONG( "" , 0 , LREQ ); 80193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 802abb72cc5Speter break; 8039a1d991fSmckusick default: 8049a1d991fSmckusick panic("fmt3"); 8059a1d991fSmckusick break; 806abb72cc5Speter } 80793ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 808abb72cc5Speter putdot( filename , line ); 809abb72cc5Speter } 810abb72cc5Speter /* 811abb72cc5Speter * Write the string after its blank padding 812abb72cc5Speter */ 813abb72cc5Speter if (typ == TSTR ) { 814abb72cc5Speter if ( opt( 't' ) ) { 81593ae45d0Sralph putleaf( PCC_ICON , 0 , 0 81693ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 817abb72cc5Speter , "_WRITES" ); 8183920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 81993ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 8203920fdb9Smckusick ap = stkrval(alv, NLNIL , (long) RREQ ); 82193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 822abb72cc5Speter } else { 82393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 82493ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 825abb72cc5Speter , "_fwrite" ); 8263920fdb9Smckusick ap = stkrval(alv, NLNIL , (long) RREQ ); 827abb72cc5Speter } 828abb72cc5Speter if (strfmt & VARWIDTH) { 829abb72cc5Speter /* 830abb72cc5Speter * min, inline expanded as 831abb72cc5Speter * temp < len ? temp : len 832abb72cc5Speter */ 8333920fdb9Smckusick putRV((char *) 0 , cbn , 834d8325541Speter tempnlp -> value[ NL_OFFS ] , 83593ae45d0Sralph tempnlp -> extra_flags , PCCT_INT ); 83693ae45d0Sralph putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 ); 83793ae45d0Sralph putop( PCC_LT , PCCT_INT ); 8383920fdb9Smckusick putRV((char *) 0 , cbn , 839d8325541Speter tempnlp -> value[ NL_OFFS ] , 84093ae45d0Sralph tempnlp -> extra_flags , PCCT_INT ); 84193ae45d0Sralph putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 ); 84293ae45d0Sralph putop( PCC_COLON , PCCT_INT ); 84393ae45d0Sralph putop( PCC_QUEST , PCCT_INT ); 844abb72cc5Speter } else { 845abb72cc5Speter if ( ( fmtspec & SKIP ) 846abb72cc5Speter && ( strfmt & CONWIDTH ) ) { 847abb72cc5Speter strnglen = field; 848abb72cc5Speter } 84993ae45d0Sralph putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 ); 850abb72cc5Speter } 85193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 85293ae45d0Sralph putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 85393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 85493ae45d0Sralph putleaf( PCC_ICON , 0 , 0 85593ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 856abb72cc5Speter , "_ACTFILE" ); 8573920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL , 85893ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 85993ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 86093ae45d0Sralph putop( PCC_CM , PCCT_INT ); 86193ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 862abb72cc5Speter putdot( filename , line ); 863abb72cc5Speter } 8641e7f77a5Smckusick if (soffset_flag) { 8651e7f77a5Smckusick tmpfree(&soffset); 8661e7f77a5Smckusick soffset_flag = FALSE; 8671e7f77a5Smckusick } 868abb72cc5Speter } 869abb72cc5Speter /* 870abb72cc5Speter * Done with arguments. 871abb72cc5Speter * Handle writeln and 872abb72cc5Speter * insufficent number of args. 873abb72cc5Speter */ 874abb72cc5Speter switch (p->value[0] &~ NSTAND) { 875abb72cc5Speter case O_WRITEF: 876abb72cc5Speter if (argc == 0) 877abb72cc5Speter error("Write requires an argument"); 878abb72cc5Speter break; 879abb72cc5Speter case O_MESSAGE: 880abb72cc5Speter if (argc == 0) 881abb72cc5Speter error("Message requires an argument"); 882abb72cc5Speter case O_WRITLN: 883abb72cc5Speter if (filetype != nl+T1CHAR) 884abb72cc5Speter error("Can't 'writeln' a non text file"); 885abb72cc5Speter if ( opt( 't' ) ) { 88693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 88793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 888abb72cc5Speter , "_WRITLN" ); 8893920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 89093ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 891abb72cc5Speter } else { 89293ae45d0Sralph putleaf( PCC_ICON , 0 , 0 89393ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 894abb72cc5Speter , "_fputc" ); 89593ae45d0Sralph putleaf( PCC_ICON , '\n' , 0 , (int) PCCT_CHAR , (char *) 0 ); 89693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 89793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 898abb72cc5Speter , "_ACTFILE" ); 8993920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , 90093ae45d0Sralph NLOCAL , PCCTM_PTR|PCCT_STRTY ); 90193ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 90293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 903abb72cc5Speter } 90493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 905abb72cc5Speter putdot( filename , line ); 906abb72cc5Speter break; 907abb72cc5Speter } 908abb72cc5Speter return; 909abb72cc5Speter 910abb72cc5Speter case O_READ4: 911abb72cc5Speter case O_READLN: 912abb72cc5Speter /* 913abb72cc5Speter * Set up default 914abb72cc5Speter * file "input". 915abb72cc5Speter */ 916abb72cc5Speter file = NIL; 917abb72cc5Speter filetype = nl+T1CHAR; 918abb72cc5Speter /* 919abb72cc5Speter * Determine the file implied 920abb72cc5Speter * for the read and generate 921abb72cc5Speter * code to make it the active file. 922abb72cc5Speter */ 9233920fdb9Smckusick if (argv != TR_NIL) { 924abb72cc5Speter codeoff(); 9253920fdb9Smckusick ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ ); 926abb72cc5Speter codeon(); 9273920fdb9Smckusick if (ap == NLNIL) 9283920fdb9Smckusick argv = argv->list_node.next; 9293920fdb9Smckusick if (ap != NLNIL && ap->class == FILET) { 930abb72cc5Speter /* 931abb72cc5Speter * Got "read(f, ...", make 932abb72cc5Speter * f the active file, and save 933abb72cc5Speter * it and its type for use in 934abb72cc5Speter * processing the rest of the 935abb72cc5Speter * arguments to read. 936abb72cc5Speter */ 9373920fdb9Smckusick file = argv->list_node.list; 938abb72cc5Speter filetype = ap->type; 9393920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL , 94093ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 94193ae45d0Sralph putleaf( PCC_ICON , 0 , 0 94293ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 943abb72cc5Speter , "_UNIT" ); 9443920fdb9Smckusick (void) stklval(argv->list_node.list, NOFLAGS); 94593ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 94693ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 947abb72cc5Speter putdot( filename , line ); 9483920fdb9Smckusick argv = argv->list_node.next; 949abb72cc5Speter argc--; 950abb72cc5Speter } else { 951abb72cc5Speter /* 952abb72cc5Speter * Default is read from 953abb72cc5Speter * standard input. 954abb72cc5Speter */ 9553920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL , 95693ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 957d8325541Speter putLV( "_input" , 0 , 0 , NGLOBAL , 95893ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 95993ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 960abb72cc5Speter putdot( filename , line ); 961abb72cc5Speter input->nl_flags |= NUSED; 962abb72cc5Speter } 963abb72cc5Speter } else { 9643920fdb9Smckusick putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL , 96593ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 96693ae45d0Sralph putLV( "_input" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY ); 96793ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 968abb72cc5Speter putdot( filename , line ); 969abb72cc5Speter input->nl_flags |= NUSED; 970abb72cc5Speter } 971abb72cc5Speter /* 972abb72cc5Speter * Loop and process each 973abb72cc5Speter * of the arguments. 974abb72cc5Speter */ 9753920fdb9Smckusick for (; argv != TR_NIL; argv = argv->list_node.next) { 976abb72cc5Speter /* 977abb72cc5Speter * Get the address of the target 978abb72cc5Speter * on the stack. 979abb72cc5Speter */ 9803920fdb9Smckusick al = argv->list_node.list; 9813920fdb9Smckusick if (al == TR_NIL) 982abb72cc5Speter continue; 9833920fdb9Smckusick if (al->tag != T_VAR) { 984abb72cc5Speter error("Arguments to %s must be variables, not expressions", p->symbol); 985abb72cc5Speter continue; 986abb72cc5Speter } 987abb72cc5Speter codeoff(); 988abb72cc5Speter ap = stklval(al, MOD|ASGN|NOUSE); 989abb72cc5Speter codeon(); 9903920fdb9Smckusick if (ap == NLNIL) 991abb72cc5Speter continue; 992abb72cc5Speter if (filetype != nl+T1CHAR) { 993abb72cc5Speter /* 994abb72cc5Speter * Generalized read, i.e. 995abb72cc5Speter * from a non-textfile. 996abb72cc5Speter */ 9973920fdb9Smckusick if (incompat(filetype, ap, argv->list_node.list )) { 998abb72cc5Speter error("Type mismatch in read from non-text file"); 999abb72cc5Speter continue; 1000abb72cc5Speter } 1001abb72cc5Speter /* 1002abb72cc5Speter * var := file ^; 1003abb72cc5Speter */ 1004abb72cc5Speter ap = lvalue( al , MOD | ASGN | NOUSE , RREQ ); 1005abb72cc5Speter if ( isa( ap , "bsci" ) ) { 1006abb72cc5Speter precheck( ap , "_RANG4" , "_RSNG4" ); 1007abb72cc5Speter } 100893ae45d0Sralph putleaf( PCC_ICON , 0 , 0 100993ae45d0Sralph , (int) (PCCM_ADDTYPE( 101093ae45d0Sralph PCCM_ADDTYPE( 101193ae45d0Sralph PCCM_ADDTYPE( 101293ae45d0Sralph p2type( filetype ) , PCCTM_PTR ) 101393ae45d0Sralph , PCCTM_FTN ) 101493ae45d0Sralph , PCCTM_PTR )) 1015abb72cc5Speter , "_FNIL" ); 1016abb72cc5Speter if (file != NIL) 10173920fdb9Smckusick (void) stklval(file, NOFLAGS); 1018abb72cc5Speter else /* Magic */ 1019d8325541Speter putRV( "_input" , 0 , 0 , NGLOBAL , 102093ae45d0Sralph PCCTM_PTR | PCCT_STRTY ); 102193ae45d0Sralph putop(PCC_CALL, PCCM_ADDTYPE(p2type(filetype), PCCTM_PTR)); 1022abb72cc5Speter switch ( classify( filetype ) ) { 1023abb72cc5Speter case TBOOL: 1024abb72cc5Speter case TCHAR: 1025abb72cc5Speter case TINT: 1026abb72cc5Speter case TSCAL: 1027abb72cc5Speter case TDOUBLE: 1028abb72cc5Speter case TPTR: 102993ae45d0Sralph putop( PCCOM_UNARY PCC_MUL 1030abb72cc5Speter , p2type( filetype ) ); 1031abb72cc5Speter } 1032abb72cc5Speter switch ( classify( filetype ) ) { 1033abb72cc5Speter case TBOOL: 1034abb72cc5Speter case TCHAR: 1035abb72cc5Speter case TINT: 1036abb72cc5Speter case TSCAL: 1037d0dbf57bSpeter postcheck(ap, filetype); 1038d0dbf57bSpeter sconv(p2type(filetype), p2type(ap)); 1039abb72cc5Speter /* and fall through */ 1040abb72cc5Speter case TDOUBLE: 1041abb72cc5Speter case TPTR: 104293ae45d0Sralph putop( PCC_ASSIGN , p2type( ap ) ); 1043abb72cc5Speter putdot( filename , line ); 1044abb72cc5Speter break; 1045abb72cc5Speter default: 104693ae45d0Sralph putstrop(PCC_STASG, 104793ae45d0Sralph PCCM_ADDTYPE(p2type(ap), PCCTM_PTR), 10483920fdb9Smckusick (int) lwidth(ap), 10499423b04dSpeter align(ap)); 1050abb72cc5Speter putdot( filename , line ); 1051abb72cc5Speter break; 1052abb72cc5Speter } 1053abb72cc5Speter /* 1054abb72cc5Speter * get(file); 1055abb72cc5Speter */ 105693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 105793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1058abb72cc5Speter , "_GET" ); 10593920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , 106093ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 106193ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1062abb72cc5Speter putdot( filename , line ); 1063abb72cc5Speter continue; 1064abb72cc5Speter } 1065abb72cc5Speter /* 1066abb72cc5Speter * if you get to here, you are reading from 1067abb72cc5Speter * a text file. only possiblities are: 1068abb72cc5Speter * character, integer, real, or scalar. 1069abb72cc5Speter * read( f , foo , ... ) is done as 1070abb72cc5Speter * foo := read( f ) with rangechecking 1071abb72cc5Speter * if appropriate. 1072abb72cc5Speter */ 1073abb72cc5Speter typ = classify(ap); 1074abb72cc5Speter op = rdops(typ); 1075abb72cc5Speter if (op == NIL) { 1076abb72cc5Speter error("Can't read %ss from a text file", clnames[typ]); 1077abb72cc5Speter continue; 1078abb72cc5Speter } 1079abb72cc5Speter /* 1080abb72cc5Speter * left hand side of foo := read( f ) 1081abb72cc5Speter */ 1082abb72cc5Speter ap = lvalue( al , MOD|ASGN|NOUSE , RREQ ); 1083abb72cc5Speter if ( isa( ap , "bsci" ) ) { 1084abb72cc5Speter precheck( ap , "_RANG4" , "_RSNG4" ); 1085abb72cc5Speter } 1086abb72cc5Speter switch ( op ) { 1087abb72cc5Speter case O_READC: 1088abb72cc5Speter readname = "_READC"; 108993ae45d0Sralph readtype = PCCT_INT; 1090abb72cc5Speter break; 1091abb72cc5Speter case O_READ4: 1092abb72cc5Speter readname = "_READ4"; 109393ae45d0Sralph readtype = PCCT_INT; 1094abb72cc5Speter break; 1095abb72cc5Speter case O_READ8: 1096abb72cc5Speter readname = "_READ8"; 109793ae45d0Sralph readtype = PCCT_DOUBLE; 1098abb72cc5Speter break; 1099abb72cc5Speter case O_READE: 1100abb72cc5Speter readname = "_READE"; 110193ae45d0Sralph readtype = PCCT_INT; 1102abb72cc5Speter break; 1103abb72cc5Speter } 110493ae45d0Sralph putleaf( PCC_ICON , 0 , 0 110593ae45d0Sralph , (int) PCCM_ADDTYPE( PCCTM_FTN | readtype , PCCTM_PTR ) 1106abb72cc5Speter , readname ); 11073920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , 110893ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 1109abb72cc5Speter if ( op == O_READE ) { 1110abb72cc5Speter sprintf( format , PREFIXFORMAT , LABELPREFIX 1111abb72cc5Speter , listnames( ap ) ); 111293ae45d0Sralph putleaf( PCC_ICON , 0, 0, (int) (PCCTM_PTR | PCCT_CHAR), 11133920fdb9Smckusick format ); 111493ae45d0Sralph putop( PCC_CM , PCCT_INT ); 11159275f63aSpeter warning(); 1116abb72cc5Speter if (opt('s')) { 1117abb72cc5Speter standard(); 1118abb72cc5Speter } 11199275f63aSpeter error("Reading scalars from text files is non-standard"); 1120abb72cc5Speter } 112193ae45d0Sralph putop( PCC_CALL , (int) readtype ); 1122abb72cc5Speter if ( isa( ap , "bcsi" ) ) { 112393ae45d0Sralph postcheck(ap, readtype==PCCT_INT?nl+T4INT:nl+TDOUBLE); 1124abb72cc5Speter } 11253920fdb9Smckusick sconv((int) readtype, p2type(ap)); 112693ae45d0Sralph putop( PCC_ASSIGN , p2type( ap ) ); 1127abb72cc5Speter putdot( filename , line ); 1128abb72cc5Speter } 1129abb72cc5Speter /* 1130abb72cc5Speter * Done with arguments. 1131abb72cc5Speter * Handle readln and 1132abb72cc5Speter * insufficient number of args. 1133abb72cc5Speter */ 1134abb72cc5Speter if (p->value[0] == O_READLN) { 1135abb72cc5Speter if (filetype != nl+T1CHAR) 1136abb72cc5Speter error("Can't 'readln' a non text file"); 113793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 113893ae45d0Sralph , (int) PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1139abb72cc5Speter , "_READLN" ); 11403920fdb9Smckusick putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , 114193ae45d0Sralph PCCTM_PTR|PCCT_STRTY ); 114293ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1143abb72cc5Speter putdot( filename , line ); 1144abb72cc5Speter } else if (argc == 0) 1145abb72cc5Speter error("read requires an argument"); 1146abb72cc5Speter return; 1147abb72cc5Speter 1148abb72cc5Speter case O_GET: 1149abb72cc5Speter case O_PUT: 1150abb72cc5Speter if (argc != 1) { 1151abb72cc5Speter error("%s expects one argument", p->symbol); 1152abb72cc5Speter return; 1153abb72cc5Speter } 115493ae45d0Sralph putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY ); 115593ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1156abb72cc5Speter , "_UNIT" ); 11573920fdb9Smckusick ap = stklval(argv->list_node.list, NOFLAGS); 11583920fdb9Smckusick if (ap == NLNIL) 1159abb72cc5Speter return; 1160abb72cc5Speter if (ap->class != FILET) { 1161abb72cc5Speter error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1162abb72cc5Speter return; 1163abb72cc5Speter } 116493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 116593ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 1166abb72cc5Speter putdot( filename , line ); 116793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1168abb72cc5Speter , op == O_GET ? "_GET" : "_PUT" ); 116993ae45d0Sralph putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY ); 117093ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1171abb72cc5Speter putdot( filename , line ); 1172abb72cc5Speter return; 1173abb72cc5Speter 1174abb72cc5Speter case O_RESET: 1175abb72cc5Speter case O_REWRITE: 1176abb72cc5Speter if (argc == 0 || argc > 2) { 1177abb72cc5Speter error("%s expects one or two arguments", p->symbol); 1178abb72cc5Speter return; 1179abb72cc5Speter } 1180abb72cc5Speter if (opt('s') && argc == 2) { 1181abb72cc5Speter standard(); 1182abb72cc5Speter error("Two argument forms of reset and rewrite are non-standard"); 1183abb72cc5Speter } 118493ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT 1185abb72cc5Speter , op == O_RESET ? "_RESET" : "_REWRITE" ); 11863920fdb9Smckusick ap = stklval(argv->list_node.list, MOD|NOUSE); 11873920fdb9Smckusick if (ap == NLNIL) 1188abb72cc5Speter return; 1189abb72cc5Speter if (ap->class != FILET) { 1190abb72cc5Speter error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1191abb72cc5Speter return; 1192abb72cc5Speter } 1193abb72cc5Speter if (argc == 2) { 1194abb72cc5Speter /* 1195abb72cc5Speter * Optional second argument 1196abb72cc5Speter * is a string name of a 1197abb72cc5Speter * UNIX (R) file to be associated. 1198abb72cc5Speter */ 11993920fdb9Smckusick al = argv->list_node.next; 12003920fdb9Smckusick al = (struct tnode *) stkrval(al->list_node.list, 12013920fdb9Smckusick NLNIL , (long) RREQ ); 12023920fdb9Smckusick if (al == TR_NIL) 1203abb72cc5Speter return; 12043920fdb9Smckusick if (classify((struct nl *) al) != TSTR) { 12053920fdb9Smckusick error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al)); 1206abb72cc5Speter return; 1207abb72cc5Speter } 12083920fdb9Smckusick strnglen = width((struct nl *) al); 1209abb72cc5Speter } else { 121093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 1211abb72cc5Speter strnglen = 0; 1212abb72cc5Speter } 121393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 121493ae45d0Sralph putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 ); 121593ae45d0Sralph putop( PCC_CM , PCCT_INT ); 121693ae45d0Sralph putleaf( PCC_ICON , text(ap) ? 0: width(ap->type) , 0 , PCCT_INT , (char *) 0 ); 121793ae45d0Sralph putop( PCC_CM , PCCT_INT ); 121893ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1219abb72cc5Speter putdot( filename , line ); 1220abb72cc5Speter return; 1221abb72cc5Speter 1222abb72cc5Speter case O_NEW: 1223abb72cc5Speter case O_DISPOSE: 1224abb72cc5Speter if (argc == 0) { 1225abb72cc5Speter error("%s expects at least one argument", p->symbol); 1226abb72cc5Speter return; 1227abb72cc5Speter } 12283920fdb9Smckusick alv = argv->list_node.list; 12292b1313dbSmckusick codeoff(); 1230195d91f7Smckusick ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 12312b1313dbSmckusick codeon(); 12323920fdb9Smckusick if (ap == NLNIL) 1233abb72cc5Speter return; 1234abb72cc5Speter if (ap->class != PTR) { 1235abb72cc5Speter error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1236abb72cc5Speter return; 1237abb72cc5Speter } 1238abb72cc5Speter ap = ap->type; 12393920fdb9Smckusick if (ap == NLNIL) 1240abb72cc5Speter return; 1241195d91f7Smckusick if (op == O_NEW) 1242195d91f7Smckusick cmd = "_NEW"; 1243195d91f7Smckusick else /* op == O_DISPOSE */ 12442b1313dbSmckusick if ((ap->nl_flags & NFILES) != 0) 12452b1313dbSmckusick cmd = "_DFDISPOSE"; 12462b1313dbSmckusick else 12472b1313dbSmckusick cmd = "_DISPOSE"; 124893ae45d0Sralph putleaf( PCC_ICON, 0, 0, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ), cmd); 12493920fdb9Smckusick (void) stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 12503920fdb9Smckusick argv = argv->list_node.next; 12513920fdb9Smckusick if (argv != TR_NIL) { 1252abb72cc5Speter if (ap->class != RECORD) { 1253abb72cc5Speter error("Record required when specifying variant tags"); 1254abb72cc5Speter return; 1255abb72cc5Speter } 12563920fdb9Smckusick for (; argv != TR_NIL; argv = argv->list_node.next) { 1257abb72cc5Speter if (ap->ptr[NL_VARNT] == NIL) { 1258abb72cc5Speter error("Too many tag fields"); 1259abb72cc5Speter return; 1260abb72cc5Speter } 12613920fdb9Smckusick if (!isconst(argv->list_node.list)) { 1262abb72cc5Speter error("Second and successive arguments to %s must be constants", p->symbol); 1263abb72cc5Speter return; 1264abb72cc5Speter } 12653920fdb9Smckusick gconst(argv->list_node.list); 1266abb72cc5Speter if (con.ctype == NIL) 1267abb72cc5Speter return; 12683920fdb9Smckusick if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , TR_NIL )) { 1269abb72cc5Speter cerror("Specified tag constant type clashed with variant case selector type"); 1270abb72cc5Speter return; 1271abb72cc5Speter } 1272abb72cc5Speter for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1273abb72cc5Speter if (ap->range[0] == con.crval) 1274abb72cc5Speter break; 1275abb72cc5Speter if (ap == NIL) { 1276abb72cc5Speter error("No variant case label value equals specified constant value"); 1277abb72cc5Speter return; 1278abb72cc5Speter } 1279abb72cc5Speter ap = ap->ptr[NL_VTOREC]; 1280abb72cc5Speter } 1281abb72cc5Speter } 128293ae45d0Sralph putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 ); 128393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 128493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1285abb72cc5Speter putdot( filename , line ); 1286195d91f7Smckusick if (opt('t') && op == O_NEW) { 128793ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1288195d91f7Smckusick , "_blkclr" ); 12893920fdb9Smckusick (void) stkrval(alv, NLNIL , (long) RREQ ); 129093ae45d0Sralph putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 ); 129193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 129293ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1293195d91f7Smckusick putdot( filename , line ); 1294195d91f7Smckusick } 1295abb72cc5Speter return; 1296abb72cc5Speter 1297abb72cc5Speter case O_DATE: 1298abb72cc5Speter case O_TIME: 1299abb72cc5Speter if (argc != 1) { 1300abb72cc5Speter error("%s expects one argument", p->symbol); 1301abb72cc5Speter return; 1302abb72cc5Speter } 130393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1304abb72cc5Speter , op == O_DATE ? "_DATE" : "_TIME" ); 13053920fdb9Smckusick ap = stklval(argv->list_node.list, MOD|NOUSE); 1306abb72cc5Speter if (ap == NIL) 1307abb72cc5Speter return; 1308abb72cc5Speter if (classify(ap) != TSTR || width(ap) != 10) { 1309abb72cc5Speter error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1310abb72cc5Speter return; 1311abb72cc5Speter } 131293ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1313abb72cc5Speter putdot( filename , line ); 1314abb72cc5Speter return; 1315abb72cc5Speter 1316abb72cc5Speter case O_HALT: 1317abb72cc5Speter if (argc != 0) { 1318abb72cc5Speter error("halt takes no arguments"); 1319abb72cc5Speter return; 1320abb72cc5Speter } 132193ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1322abb72cc5Speter , "_HALT" ); 1323abb72cc5Speter 132493ae45d0Sralph putop( PCCOM_UNARY PCC_CALL , PCCT_INT ); 1325abb72cc5Speter putdot( filename , line ); 13263920fdb9Smckusick noreach = TRUE; 1327abb72cc5Speter return; 1328abb72cc5Speter 1329abb72cc5Speter case O_ARGV: 1330abb72cc5Speter if (argc != 2) { 1331abb72cc5Speter error("argv takes two arguments"); 1332abb72cc5Speter return; 1333abb72cc5Speter } 133493ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1335abb72cc5Speter , "_ARGV" ); 13363920fdb9Smckusick ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 13373920fdb9Smckusick if (ap == NLNIL) 1338abb72cc5Speter return; 1339abb72cc5Speter if (isnta(ap, "i")) { 1340abb72cc5Speter error("argv's first argument must be an integer, not %s", nameof(ap)); 1341abb72cc5Speter return; 1342abb72cc5Speter } 13433920fdb9Smckusick al = argv->list_node.next; 13443920fdb9Smckusick ap = stklval(al->list_node.list, MOD|NOUSE); 13453920fdb9Smckusick if (ap == NLNIL) 1346abb72cc5Speter return; 1347abb72cc5Speter if (classify(ap) != TSTR) { 1348abb72cc5Speter error("argv's second argument must be a string, not %s", nameof(ap)); 1349abb72cc5Speter return; 1350abb72cc5Speter } 135193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 135293ae45d0Sralph putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 ); 135393ae45d0Sralph putop( PCC_CM , PCCT_INT ); 135493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1355abb72cc5Speter putdot( filename , line ); 1356abb72cc5Speter return; 1357abb72cc5Speter 1358abb72cc5Speter case O_STLIM: 1359abb72cc5Speter if (argc != 1) { 1360abb72cc5Speter error("stlimit requires one argument"); 1361abb72cc5Speter return; 1362abb72cc5Speter } 136393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1364abb72cc5Speter , "_STLIM" ); 13653920fdb9Smckusick ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 13663920fdb9Smckusick if (ap == NLNIL) 1367abb72cc5Speter return; 1368abb72cc5Speter if (isnta(ap, "i")) { 1369abb72cc5Speter error("stlimit's argument must be an integer, not %s", nameof(ap)); 1370abb72cc5Speter return; 1371abb72cc5Speter } 137293ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1373abb72cc5Speter putdot( filename , line ); 1374abb72cc5Speter return; 1375abb72cc5Speter 1376abb72cc5Speter case O_REMOVE: 1377abb72cc5Speter if (argc != 1) { 1378abb72cc5Speter error("remove expects one argument"); 1379abb72cc5Speter return; 1380abb72cc5Speter } 138193ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1382abb72cc5Speter , "_REMOVE" ); 13833920fdb9Smckusick ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ ); 13843920fdb9Smckusick if (ap == NLNIL) 1385abb72cc5Speter return; 1386abb72cc5Speter if (classify(ap) != TSTR) { 1387abb72cc5Speter error("remove's argument must be a string, not %s", nameof(ap)); 1388abb72cc5Speter return; 1389abb72cc5Speter } 139093ae45d0Sralph putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 ); 139193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 139293ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1393abb72cc5Speter putdot( filename , line ); 1394abb72cc5Speter return; 1395abb72cc5Speter 1396abb72cc5Speter case O_LLIMIT: 1397abb72cc5Speter if (argc != 2) { 1398abb72cc5Speter error("linelimit expects two arguments"); 1399abb72cc5Speter return; 1400abb72cc5Speter } 140193ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1402abb72cc5Speter , "_LLIMIT" ); 14033920fdb9Smckusick ap = stklval(argv->list_node.list, NOFLAGS|NOUSE); 14043920fdb9Smckusick if (ap == NLNIL) 1405abb72cc5Speter return; 1406abb72cc5Speter if (!text(ap)) { 1407abb72cc5Speter error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1408abb72cc5Speter return; 1409abb72cc5Speter } 14103920fdb9Smckusick al = argv->list_node.next; 14113920fdb9Smckusick ap = stkrval(al->list_node.list, NLNIL , (long) RREQ ); 14123920fdb9Smckusick if (ap == NLNIL) 1413abb72cc5Speter return; 1414abb72cc5Speter if (isnta(ap, "i")) { 1415abb72cc5Speter error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1416abb72cc5Speter return; 1417abb72cc5Speter } 141893ae45d0Sralph putop( PCC_CM , PCCT_INT ); 141993ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1420abb72cc5Speter putdot( filename , line ); 1421abb72cc5Speter return; 1422abb72cc5Speter case O_PAGE: 1423abb72cc5Speter if (argc != 1) { 1424abb72cc5Speter error("page expects one argument"); 1425abb72cc5Speter return; 1426abb72cc5Speter } 142793ae45d0Sralph putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY ); 142893ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1429abb72cc5Speter , "_UNIT" ); 14303920fdb9Smckusick ap = stklval(argv->list_node.list, NOFLAGS); 14313920fdb9Smckusick if (ap == NLNIL) 1432abb72cc5Speter return; 1433abb72cc5Speter if (!text(ap)) { 1434abb72cc5Speter error("Argument to page must be a text file, not %s", nameof(ap)); 1435abb72cc5Speter return; 1436abb72cc5Speter } 143793ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 143893ae45d0Sralph putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY ); 1439abb72cc5Speter putdot( filename , line ); 1440abb72cc5Speter if ( opt( 't' ) ) { 144193ae45d0Sralph putleaf( PCC_ICON , 0 , 0 144293ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1443abb72cc5Speter , "_PAGE" ); 144493ae45d0Sralph putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY ); 1445abb72cc5Speter } else { 144693ae45d0Sralph putleaf( PCC_ICON , 0 , 0 144793ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1448abb72cc5Speter , "_fputc" ); 144993ae45d0Sralph putleaf( PCC_ICON , '\f' , 0 , (int) PCCT_CHAR , (char *) 0 ); 145093ae45d0Sralph putleaf( PCC_ICON , 0 , 0 145193ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1452abb72cc5Speter , "_ACTFILE" ); 145393ae45d0Sralph putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY ); 145493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 145593ae45d0Sralph putop( PCC_CM , PCCT_INT ); 1456abb72cc5Speter } 145793ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1458abb72cc5Speter putdot( filename , line ); 1459abb72cc5Speter return; 1460abb72cc5Speter 14618c0920b2Smckusick case O_ASRT: 14628c0920b2Smckusick if (!opt('t')) 14638c0920b2Smckusick return; 14648c0920b2Smckusick if (argc == 0 || argc > 2) { 14658c0920b2Smckusick error("Assert expects one or two arguments"); 14668c0920b2Smckusick return; 14678c0920b2Smckusick } 1468195d91f7Smckusick if (argc == 2) 1469195d91f7Smckusick cmd = "_ASRTS"; 1470195d91f7Smckusick else 1471195d91f7Smckusick cmd = "_ASRT"; 147293ae45d0Sralph putleaf( PCC_ICON , 0 , 0 147393ae45d0Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , cmd ); 14743920fdb9Smckusick ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ ); 14753920fdb9Smckusick if (ap == NLNIL) 14768c0920b2Smckusick return; 14778c0920b2Smckusick if (isnta(ap, "b")) 14788c0920b2Smckusick error("Assert expression must be Boolean, not %ss", nameof(ap)); 14798c0920b2Smckusick if (argc == 2) { 14808c0920b2Smckusick /* 14818c0920b2Smckusick * Optional second argument is a string specifying 14828c0920b2Smckusick * why the assertion failed. 14838c0920b2Smckusick */ 14843920fdb9Smckusick al = argv->list_node.next; 14853920fdb9Smckusick al = (struct tnode *) stkrval(al->list_node.list, NLNIL , (long) RREQ ); 14863920fdb9Smckusick if (al == TR_NIL) 14878c0920b2Smckusick return; 14883920fdb9Smckusick if (classify((struct nl *) al) != TSTR) { 14893920fdb9Smckusick error("Second argument to assert must be a string, not %s", nameof((struct nl *) al)); 14908c0920b2Smckusick return; 14918c0920b2Smckusick } 149293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 1493195d91f7Smckusick } 149493ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 14958c0920b2Smckusick putdot( filename , line ); 14968c0920b2Smckusick return; 14978c0920b2Smckusick 1498abb72cc5Speter case O_PACK: 1499abb72cc5Speter if (argc != 3) { 1500abb72cc5Speter error("pack expects three arguments"); 1501abb72cc5Speter return; 1502abb72cc5Speter } 150393ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1504abb72cc5Speter , "_PACK" ); 1505abb72cc5Speter pu = "pack(a,i,z)"; 15063920fdb9Smckusick pua = (al = argv)->list_node.list; 15073920fdb9Smckusick pui = (al = al->list_node.next)->list_node.list; 15083920fdb9Smckusick puz = (al = al->list_node.next)->list_node.list; 1509abb72cc5Speter goto packunp; 1510abb72cc5Speter case O_UNPACK: 1511abb72cc5Speter if (argc != 3) { 1512abb72cc5Speter error("unpack expects three arguments"); 1513abb72cc5Speter return; 1514abb72cc5Speter } 151593ae45d0Sralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 1516abb72cc5Speter , "_UNPACK" ); 1517abb72cc5Speter pu = "unpack(z,a,i)"; 15183920fdb9Smckusick puz = (al = argv)->list_node.list; 15193920fdb9Smckusick pua = (al = al->list_node.next)->list_node.list; 15203920fdb9Smckusick pui = (al = al->list_node.next)->list_node.list; 1521abb72cc5Speter packunp: 15223920fdb9Smckusick ap = stkrval(pui, NLNIL , (long) RREQ ); 1523abb72cc5Speter if (ap == NIL) 1524abb72cc5Speter return; 1525abb72cc5Speter ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1526abb72cc5Speter if (ap == NIL) 1527abb72cc5Speter return; 1528abb72cc5Speter if (ap->class != ARRAY) { 1529abb72cc5Speter error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1530abb72cc5Speter return; 1531abb72cc5Speter } 153293ae45d0Sralph putop( PCC_CM , PCCT_INT ); 15333920fdb9Smckusick al = (struct tnode *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 15343920fdb9Smckusick if (((struct nl *) al)->class != ARRAY) { 1535abb72cc5Speter error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1536abb72cc5Speter return; 1537abb72cc5Speter } 15383920fdb9Smckusick if (((struct nl *) al)->type == NIL || 15393920fdb9Smckusick ((struct nl *) ap)->type == NIL) 1540abb72cc5Speter return; 15413920fdb9Smckusick if (((struct nl *) al)->type != ((struct nl *) ap)->type) { 1542abb72cc5Speter error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1543abb72cc5Speter return; 1544abb72cc5Speter } 154593ae45d0Sralph putop( PCC_CM , PCCT_INT ); 15463920fdb9Smckusick k = width((struct nl *) al); 1547abb72cc5Speter itemwidth = width(ap->type); 1548abb72cc5Speter ap = ap->chain; 15493920fdb9Smckusick al = ((struct tnode *) ((struct nl *) al)->chain); 15503920fdb9Smckusick if (ap->chain != NIL || ((struct nl *) al)->chain != NIL) { 1551abb72cc5Speter error("%s requires a and z to be single dimension arrays", pu); 1552abb72cc5Speter return; 1553abb72cc5Speter } 1554abb72cc5Speter if (ap == NIL || al == NIL) 1555abb72cc5Speter return; 1556abb72cc5Speter /* 1557abb72cc5Speter * al is the range for z i.e. u..v 1558abb72cc5Speter * ap is the range for a i.e. m..n 1559abb72cc5Speter * i will be n-m+1 1560abb72cc5Speter * j will be v-u+1 1561abb72cc5Speter */ 1562abb72cc5Speter i = ap->range[1] - ap->range[0] + 1; 15633920fdb9Smckusick j = ((struct nl *) al)->range[1] - 15643920fdb9Smckusick ((struct nl *) al)->range[0] + 1; 1565abb72cc5Speter if (i < j) { 15663920fdb9Smckusick error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i); 1567abb72cc5Speter return; 1568abb72cc5Speter } 1569abb72cc5Speter /* 1570abb72cc5Speter * get n-m-(v-u) and m for the interpreter 1571abb72cc5Speter */ 1572abb72cc5Speter i -= j; 1573abb72cc5Speter j = ap->range[0]; 157493ae45d0Sralph putleaf( PCC_ICON , itemwidth , 0 , PCCT_INT , (char *) 0 ); 157593ae45d0Sralph putop( PCC_CM , PCCT_INT ); 157693ae45d0Sralph putleaf( PCC_ICON , j , 0 , PCCT_INT , (char *) 0 ); 157793ae45d0Sralph putop( PCC_CM , PCCT_INT ); 157893ae45d0Sralph putleaf( PCC_ICON , i , 0 , PCCT_INT , (char *) 0 ); 157993ae45d0Sralph putop( PCC_CM , PCCT_INT ); 158093ae45d0Sralph putleaf( PCC_ICON , k , 0 , PCCT_INT , (char *) 0 ); 158193ae45d0Sralph putop( PCC_CM , PCCT_INT ); 158293ae45d0Sralph putop( PCC_CALL , PCCT_INT ); 1583abb72cc5Speter putdot( filename , line ); 1584abb72cc5Speter return; 1585abb72cc5Speter case 0: 15868c0920b2Smckusick error("%s is an unimplemented extension", p->symbol); 1587abb72cc5Speter return; 1588abb72cc5Speter 1589abb72cc5Speter default: 1590abb72cc5Speter panic("proc case"); 1591abb72cc5Speter } 1592abb72cc5Speter } 1593abb72cc5Speter #endif PC 1594