1766Speter /* Copyright (c) 1979 Regents of the University of California */ 2766Speter 3*11883Smckusick static char sccsid[] = "@(#)pcproc.c 1.21 04/08/83"; 4766Speter 5766Speter #include "whoami.h" 6766Speter #ifdef PC 7766Speter /* 8766Speter * and to the end of the file 9766Speter */ 10766Speter #include "0.h" 11766Speter #include "tree.h" 1210372Speter #include "objfmt.h" 13766Speter #include "opcode.h" 1410372Speter #include "pc.h" 1510372Speter #include "pcops.h" 1611333Speter #include "tmps.h" 17766Speter 18766Speter /* 19*11883Smckusick * The constant EXPOSIZE specifies the number of digits in the exponent 20*11883Smckusick * of real numbers. 21*11883Smckusick * 229229Smckusick * The constant REALSPC defines the amount of forced padding preceeding 239229Smckusick * real numbers when they are printed. If REALSPC == 0, then no padding 249229Smckusick * is added, REALSPC == 1 adds one extra blank irregardless of the width 259229Smckusick * specified by the user. 269229Smckusick * 279229Smckusick * N.B. - Values greater than one require program mods. 289229Smckusick */ 29*11883Smckusick #define EXPOSIZE 2 30*11883Smckusick #define REALSPC 0 319229Smckusick 329229Smckusick /* 33766Speter * The following array is used to determine which classes may be read 34766Speter * from textfiles. It is indexed by the return value from classify. 35766Speter */ 36766Speter #define rdops(x) rdxxxx[(x)-(TFIRST)] 37766Speter 38766Speter int rdxxxx[] = { 39766Speter 0, /* -7 file types */ 40766Speter 0, /* -6 record types */ 41766Speter 0, /* -5 array types */ 42766Speter O_READE, /* -4 scalar types */ 43766Speter 0, /* -3 pointer types */ 44766Speter 0, /* -2 set types */ 45766Speter 0, /* -1 string types */ 46766Speter 0, /* 0 nil, no type */ 47766Speter O_READE, /* 1 boolean */ 48766Speter O_READC, /* 2 character */ 49766Speter O_READ4, /* 3 integer */ 50766Speter O_READ8 /* 4 real */ 51766Speter }; 52766Speter 53766Speter /* 54766Speter * Proc handles procedure calls. 55766Speter * Non-builtin procedures are "buck-passed" to func (with a flag 56766Speter * indicating that they are actually procedures. 57766Speter * builtin procedures are handled here. 58766Speter */ 59766Speter pcproc(r) 60766Speter int *r; 61766Speter { 62766Speter register struct nl *p; 63766Speter register int *alv, *al, op; 64766Speter struct nl *filetype, *ap; 65766Speter int argc, *argv, typ, fmtspec, strfmt, stkcnt, *file; 667967Smckusick char fmt, format[20], *strptr, *cmd; 67766Speter int prec, field, strnglen, fmtlen, fmtstart, pu; 68766Speter int *pua, *pui, *puz; 69766Speter int i, j, k; 70766Speter int itemwidth; 713833Speter char *readname; 723833Speter struct nl *tempnlp; 733833Speter long readtype; 743833Speter struct tmps soffset; 75766Speter 76766Speter #define CONPREC 4 77766Speter #define VARPREC 8 78766Speter #define CONWIDTH 1 79766Speter #define VARWIDTH 2 80766Speter #define SKIP 16 81766Speter 82766Speter /* 83766Speter * Verify that the name is 84766Speter * defined and is that of a 85766Speter * procedure. 86766Speter */ 87766Speter p = lookup(r[2]); 88766Speter if (p == NIL) { 89766Speter rvlist(r[3]); 90766Speter return; 91766Speter } 921197Speter if (p->class != PROC && p->class != FPROC) { 93766Speter error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); 94766Speter rvlist(r[3]); 95766Speter return; 96766Speter } 97766Speter argv = r[3]; 98766Speter 99766Speter /* 100766Speter * Call handles user defined 101766Speter * procedures and functions. 102766Speter */ 103766Speter if (bn != 0) { 104766Speter call(p, argv, PROC, bn); 105766Speter return; 106766Speter } 107766Speter 108766Speter /* 109766Speter * Call to built-in procedure. 110766Speter * Count the arguments. 111766Speter */ 112766Speter argc = 0; 113766Speter for (al = argv; al != NIL; al = al[2]) 114766Speter argc++; 115766Speter 116766Speter /* 117766Speter * Switch on the operator 118766Speter * associated with the built-in 119766Speter * procedure in the namelist 120766Speter */ 121766Speter op = p->value[0] &~ NSTAND; 122766Speter if (opt('s') && (p->value[0] & NSTAND)) { 123766Speter standard(); 124766Speter error("%s is a nonstandard procedure", p->symbol); 125766Speter } 126766Speter switch (op) { 127766Speter 128766Speter case O_ABORT: 129766Speter if (argc != 0) 130766Speter error("null takes no arguments"); 131766Speter return; 132766Speter 133766Speter case O_FLUSH: 134766Speter if (argc == 0) { 135766Speter putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" ); 136766Speter putop( P2UNARY P2CALL , P2INT ); 137766Speter putdot( filename , line ); 138766Speter return; 139766Speter } 140766Speter if (argc != 1) { 141766Speter error("flush takes at most one argument"); 142766Speter return; 143766Speter } 144766Speter putleaf( P2ICON , 0 , 0 145766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 146766Speter , "_FLUSH" ); 147766Speter ap = stklval(argv[1], NOFLAGS); 148766Speter if (ap == NIL) 149766Speter return; 150766Speter if (ap->class != FILET) { 151766Speter error("flush's argument must be a file, not %s", nameof(ap)); 152766Speter return; 153766Speter } 154766Speter putop( P2CALL , P2INT ); 155766Speter putdot( filename , line ); 156766Speter return; 157766Speter 158766Speter case O_MESSAGE: 159766Speter case O_WRITEF: 160766Speter case O_WRITLN: 161766Speter /* 162766Speter * Set up default file "output"'s type 163766Speter */ 164766Speter file = NIL; 165766Speter filetype = nl+T1CHAR; 166766Speter /* 167766Speter * Determine the file implied 168766Speter * for the write and generate 169766Speter * code to make it the active file. 170766Speter */ 171766Speter if (op == O_MESSAGE) { 172766Speter /* 173766Speter * For message, all that matters 174766Speter * is that the filetype is 175766Speter * a character file. 176766Speter * Thus "output" will suit us fine. 177766Speter */ 178766Speter putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" ); 179766Speter putop( P2UNARY P2CALL , P2INT ); 180766Speter putdot( filename , line ); 1813833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 1823833Speter P2PTR|P2STRTY ); 1833833Speter putLV( "__err" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 184766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 185766Speter putdot( filename , line ); 186766Speter } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) { 187766Speter /* 188766Speter * If there is a first argument which has 189766Speter * no write widths, then it is potentially 190766Speter * a file name. 191766Speter */ 192766Speter codeoff(); 193766Speter ap = stkrval(argv[1], NIL , RREQ ); 194766Speter codeon(); 195766Speter if (ap == NIL) 196766Speter argv = argv[2]; 197766Speter if (ap != NIL && ap->class == FILET) { 198766Speter /* 199766Speter * Got "write(f, ...", make 200766Speter * f the active file, and save 201766Speter * it and its type for use in 202766Speter * processing the rest of the 203766Speter * arguments to write. 204766Speter */ 2053833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 2063833Speter P2PTR|P2STRTY ); 207766Speter putleaf( P2ICON , 0 , 0 208766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 209766Speter , "_UNIT" ); 210766Speter file = argv[1]; 211766Speter filetype = ap->type; 212766Speter stklval(argv[1], NOFLAGS); 213766Speter putop( P2CALL , P2INT ); 214766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 215766Speter putdot( filename , line ); 216766Speter /* 217766Speter * Skip over the first argument 218766Speter */ 219766Speter argv = argv[2]; 220766Speter argc--; 221766Speter } else { 222766Speter /* 223766Speter * Set up for writing on 224766Speter * standard output. 225766Speter */ 2263833Speter putRV( 0, cbn , CURFILEOFFSET , 2273833Speter NLOCAL , P2PTR|P2STRTY ); 2283833Speter putLV( "_output" , 0 , 0 , NGLOBAL , 2293833Speter P2PTR|P2STRTY ); 230766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 231766Speter putdot( filename , line ); 2327954Speter output->nl_flags |= NUSED; 233766Speter } 234766Speter } else { 2353833Speter putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 2363833Speter P2PTR|P2STRTY ); 2373833Speter putLV( "_output" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 238766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 239766Speter putdot( filename , line ); 2407954Speter output->nl_flags |= NUSED; 241766Speter } 242766Speter /* 243766Speter * Loop and process each 244766Speter * of the arguments. 245766Speter */ 246766Speter for (; argv != NIL; argv = argv[2]) { 247766Speter /* 248766Speter * fmtspec indicates the type (CONstant or VARiable) 249766Speter * and number (none, WIDTH, and/or PRECision) 250766Speter * of the fields in the printf format for this 251766Speter * output variable. 252766Speter * stkcnt is the number of longs pushed on the stack 253766Speter * fmt is the format output indicator (D, E, F, O, X, S) 254766Speter * fmtstart = 0 for leading blank; = 1 for no blank 255766Speter */ 256766Speter fmtspec = NIL; 257766Speter stkcnt = 0; 258766Speter fmt = 'D'; 259766Speter fmtstart = 1; 260766Speter al = argv[1]; 261766Speter if (al == NIL) 262766Speter continue; 263766Speter if (al[0] == T_WEXP) 264766Speter alv = al[1]; 265766Speter else 266766Speter alv = al; 267766Speter if (alv == NIL) 268766Speter continue; 269766Speter codeoff(); 270766Speter ap = stkrval(alv, NIL , RREQ ); 271766Speter codeon(); 272766Speter if (ap == NIL) 273766Speter continue; 274766Speter typ = classify(ap); 275766Speter if (al[0] == T_WEXP) { 276766Speter /* 277766Speter * Handle width expressions. 278766Speter * The basic game here is that width 279766Speter * expressions get evaluated. If they 280766Speter * are constant, the value is placed 281766Speter * directly in the format string. 282766Speter * Otherwise the value is pushed onto 283766Speter * the stack and an indirection is 284766Speter * put into the format string. 285766Speter */ 286766Speter if (al[3] == OCT) 287766Speter fmt = 'O'; 288766Speter else if (al[3] == HEX) 289766Speter fmt = 'X'; 290766Speter else if (al[3] != NIL) { 291766Speter /* 292766Speter * Evaluate second format spec 293766Speter */ 294766Speter if ( constval(al[3]) 295766Speter && isa( con.ctype , "i" ) ) { 296766Speter fmtspec += CONPREC; 297766Speter prec = con.crval; 298766Speter } else { 299766Speter fmtspec += VARPREC; 300766Speter } 301766Speter fmt = 'f'; 302766Speter switch ( typ ) { 303766Speter case TINT: 304766Speter if ( opt( 's' ) ) { 305766Speter standard(); 306766Speter error("Writing %ss with two write widths is non-standard", clnames[typ]); 307766Speter } 308766Speter /* and fall through */ 309766Speter case TDOUBLE: 310766Speter break; 311766Speter default: 312766Speter error("Cannot write %ss with two write widths", clnames[typ]); 313766Speter continue; 314766Speter } 315766Speter } 316766Speter /* 317766Speter * Evaluate first format spec 318766Speter */ 319766Speter if (al[2] != NIL) { 320766Speter if ( constval(al[2]) 321766Speter && isa( con.ctype , "i" ) ) { 322766Speter fmtspec += CONWIDTH; 323766Speter field = con.crval; 324766Speter } else { 325766Speter fmtspec += VARWIDTH; 326766Speter } 327766Speter } 328766Speter if ((fmtspec & CONPREC) && prec < 0 || 329766Speter (fmtspec & CONWIDTH) && field < 0) { 330766Speter error("Negative widths are not allowed"); 331766Speter continue; 332766Speter } 3333180Smckusic if ( opt('s') && 3343180Smckusic ((fmtspec & CONPREC) && prec == 0 || 3353180Smckusic (fmtspec & CONWIDTH) && field == 0)) { 3363180Smckusic standard(); 3373180Smckusic error("Zero widths are non-standard"); 3383180Smckusic } 339766Speter } 340766Speter if (filetype != nl+T1CHAR) { 341766Speter if (fmt == 'O' || fmt == 'X') { 342766Speter error("Oct/hex allowed only on text files"); 343766Speter continue; 344766Speter } 345766Speter if (fmtspec) { 346766Speter error("Write widths allowed only on text files"); 347766Speter continue; 348766Speter } 349766Speter /* 350766Speter * Generalized write, i.e. 351766Speter * to a non-textfile. 352766Speter */ 353766Speter putleaf( P2ICON , 0 , 0 354766Speter , ADDTYPE( 355766Speter ADDTYPE( 356766Speter ADDTYPE( p2type( filetype ) 357766Speter , P2PTR ) 358766Speter , P2FTN ) 359766Speter , P2PTR ) 360766Speter , "_FNIL" ); 361766Speter stklval(file, NOFLAGS); 362766Speter putop( P2CALL 363766Speter , ADDTYPE( p2type( filetype ) , P2PTR ) ); 364766Speter putop( P2UNARY P2MUL , p2type( filetype ) ); 365766Speter /* 366766Speter * file^ := ... 367766Speter */ 368766Speter switch ( classify( filetype ) ) { 369766Speter case TBOOL: 370766Speter case TCHAR: 371766Speter case TINT: 372766Speter case TSCAL: 3734589Speter precheck( filetype , "_RANG4" , "_RSNG4" ); 374766Speter /* and fall through */ 375766Speter case TDOUBLE: 376766Speter case TPTR: 377766Speter ap = rvalue( argv[1] , filetype , RREQ ); 378766Speter break; 379766Speter default: 380766Speter ap = rvalue( argv[1] , filetype , LREQ ); 381766Speter break; 382766Speter } 383766Speter if (ap == NIL) 384766Speter continue; 385766Speter if (incompat(ap, filetype, argv[1])) { 386766Speter cerror("Type mismatch in write to non-text file"); 387766Speter continue; 388766Speter } 389766Speter switch ( classify( filetype ) ) { 390766Speter case TBOOL: 391766Speter case TCHAR: 392766Speter case TINT: 393766Speter case TSCAL: 39410373Speter postcheck(filetype, ap); 39510373Speter sconv(p2type(ap), p2type(filetype)); 396766Speter /* and fall through */ 397766Speter case TDOUBLE: 398766Speter case TPTR: 399766Speter putop( P2ASSIGN , p2type( filetype ) ); 400766Speter putdot( filename , line ); 401766Speter break; 402766Speter default: 40311856Speter putstrop(P2STASG, 40411856Speter ADDTYPE(p2type(filetype), 40511856Speter P2PTR), 40611856Speter lwidth(filetype), 40711856Speter align(filetype)); 408766Speter putdot( filename , line ); 409766Speter break; 410766Speter } 411766Speter /* 412766Speter * put(file) 413766Speter */ 414766Speter putleaf( P2ICON , 0 , 0 415766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 416766Speter , "_PUT" ); 4173833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 4183833Speter P2PTR|P2STRTY ); 419766Speter putop( P2CALL , P2INT ); 420766Speter putdot( filename , line ); 421766Speter continue; 422766Speter } 423766Speter /* 424766Speter * Write to a textfile 425766Speter * 426766Speter * Evaluate the expression 427766Speter * to be written. 428766Speter */ 429766Speter if (fmt == 'O' || fmt == 'X') { 430766Speter if (opt('s')) { 431766Speter standard(); 432766Speter error("Oct and hex are non-standard"); 433766Speter } 434766Speter if (typ == TSTR || typ == TDOUBLE) { 435766Speter error("Can't write %ss with oct/hex", clnames[typ]); 436766Speter continue; 437766Speter } 438766Speter if (typ == TCHAR || typ == TBOOL) 439766Speter typ = TINT; 440766Speter } 441766Speter /* 442766Speter * If there is no format specified by the programmer, 443766Speter * implement the default. 444766Speter */ 445766Speter switch (typ) { 4466540Smckusick case TPTR: 4476540Smckusick warning(); 4486540Smckusick if (opt('s')) { 4496540Smckusick standard(); 4506540Smckusick } 4516540Smckusick error("Writing %ss to text files is non-standard", 4526540Smckusick clnames[typ]); 4536540Smckusick /* and fall through */ 454766Speter case TINT: 455766Speter if (fmt == 'f') { 456766Speter typ = TDOUBLE; 457766Speter goto tdouble; 458766Speter } 459766Speter if (fmtspec == NIL) { 460766Speter if (fmt == 'D') 461766Speter field = 10; 462766Speter else if (fmt == 'X') 463766Speter field = 8; 464766Speter else if (fmt == 'O') 465766Speter field = 11; 466766Speter else 467766Speter panic("fmt1"); 468766Speter fmtspec = CONWIDTH; 469766Speter } 470766Speter break; 471766Speter case TCHAR: 472766Speter tchar: 473766Speter fmt = 'c'; 474766Speter break; 475766Speter case TSCAL: 4761629Speter warning(); 477766Speter if (opt('s')) { 478766Speter standard(); 479766Speter } 4806540Smckusick error("Writing %ss to text files is non-standard", 4816540Smckusick clnames[typ]); 482766Speter case TBOOL: 483766Speter fmt = 's'; 484766Speter break; 485766Speter case TDOUBLE: 486766Speter tdouble: 487766Speter switch (fmtspec) { 488766Speter case NIL: 489*11883Smckusick field = 14 + (5 + EXPOSIZE); 490*11883Smckusick prec = field - (5 + EXPOSIZE); 4913225Smckusic fmt = 'e'; 492766Speter fmtspec = CONWIDTH + CONPREC; 493766Speter break; 494766Speter case CONWIDTH: 4959229Smckusick field -= REALSPC; 4969229Smckusick if (field < 1) 497766Speter field = 1; 498*11883Smckusick prec = field - (5 + EXPOSIZE); 499766Speter if (prec < 1) 500766Speter prec = 1; 501766Speter fmtspec += CONPREC; 5023225Smckusic fmt = 'e'; 503766Speter break; 504766Speter case VARWIDTH: 505766Speter fmtspec += VARPREC; 5063225Smckusic fmt = 'e'; 507766Speter break; 508766Speter case CONWIDTH + CONPREC: 509766Speter case CONWIDTH + VARPREC: 5109229Smckusick field -= REALSPC; 5119229Smckusick if (field < 1) 512766Speter field = 1; 513766Speter } 514766Speter format[0] = ' '; 5159229Smckusick fmtstart = 1 - REALSPC; 516766Speter break; 517766Speter case TSTR: 518766Speter constval( alv ); 519766Speter switch ( classify( con.ctype ) ) { 520766Speter case TCHAR: 521766Speter typ = TCHAR; 522766Speter goto tchar; 523766Speter case TSTR: 524766Speter strptr = con.cpval; 525766Speter for (strnglen = 0; *strptr++; strnglen++) /* void */; 526766Speter strptr = con.cpval; 527766Speter break; 528766Speter default: 529766Speter strnglen = width(ap); 530766Speter break; 531766Speter } 532766Speter fmt = 's'; 533766Speter strfmt = fmtspec; 534766Speter if (fmtspec == NIL) { 535766Speter fmtspec = SKIP; 536766Speter break; 537766Speter } 538766Speter if (fmtspec & CONWIDTH) { 539766Speter if (field <= strnglen) 540766Speter fmtspec = SKIP; 541766Speter else 542766Speter field -= strnglen; 543766Speter } 544766Speter break; 545766Speter default: 546766Speter error("Can't write %ss to a text file", clnames[typ]); 547766Speter continue; 548766Speter } 549766Speter /* 550766Speter * Generate the format string 551766Speter */ 552766Speter switch (fmtspec) { 553766Speter default: 554766Speter panic("fmt2"); 555766Speter case NIL: 556766Speter if (fmt == 'c') { 557766Speter if ( opt( 't' ) ) { 558766Speter putleaf( P2ICON , 0 , 0 559766Speter , ADDTYPE( P2FTN|P2INT , P2PTR ) 560766Speter , "_WRITEC" ); 5613833Speter putRV( 0 , cbn , CURFILEOFFSET , 5623833Speter NLOCAL , P2PTR|P2STRTY ); 563766Speter stkrval( alv , NIL , RREQ ); 564766Speter putop( P2LISTOP , P2INT ); 565766Speter } else { 566766Speter putleaf( P2ICON , 0 , 0 567766Speter , ADDTYPE( P2FTN|P2INT , P2PTR ) 568766Speter , "_fputc" ); 569766Speter stkrval( alv , NIL , RREQ ); 570766Speter } 571766Speter putleaf( P2ICON , 0 , 0 572766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 573766Speter , "_ACTFILE" ); 5743833Speter putRV( 0, cbn , CURFILEOFFSET , 5753833Speter NLOCAL , P2PTR|P2STRTY ); 576766Speter putop( P2CALL , P2INT ); 577766Speter putop( P2LISTOP , P2INT ); 578766Speter putop( P2CALL , P2INT ); 579766Speter putdot( filename , line ); 580766Speter } else { 581766Speter sprintf(&format[1], "%%%c", fmt); 582766Speter goto fmtgen; 583766Speter } 584766Speter case SKIP: 585766Speter break; 586766Speter case CONWIDTH: 587766Speter sprintf(&format[1], "%%%1D%c", field, fmt); 588766Speter goto fmtgen; 589766Speter case VARWIDTH: 590766Speter sprintf(&format[1], "%%*%c", fmt); 591766Speter goto fmtgen; 592766Speter case CONWIDTH + CONPREC: 593766Speter sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt); 594766Speter goto fmtgen; 595766Speter case CONWIDTH + VARPREC: 596766Speter sprintf(&format[1], "%%%1D.*%c", field, fmt); 597766Speter goto fmtgen; 598766Speter case VARWIDTH + CONPREC: 599766Speter sprintf(&format[1], "%%*.%1D%c", prec, fmt); 600766Speter goto fmtgen; 601766Speter case VARWIDTH + VARPREC: 602766Speter sprintf(&format[1], "%%*.*%c", fmt); 603766Speter fmtgen: 604766Speter if ( opt( 't' ) ) { 605766Speter putleaf( P2ICON , 0 , 0 606766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 607766Speter , "_WRITEF" ); 6083833Speter putRV( 0 , cbn , CURFILEOFFSET , 6093833Speter NLOCAL , P2PTR|P2STRTY ); 610766Speter putleaf( P2ICON , 0 , 0 611766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 612766Speter , "_ACTFILE" ); 6133833Speter putRV( 0 , cbn , CURFILEOFFSET , 6143833Speter NLOCAL , P2PTR|P2STRTY ); 615766Speter putop( P2CALL , P2INT ); 616766Speter putop( P2LISTOP , P2INT ); 617766Speter } else { 618766Speter putleaf( P2ICON , 0 , 0 619766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 620766Speter , "_fprintf" ); 621766Speter putleaf( P2ICON , 0 , 0 622766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 623766Speter , "_ACTFILE" ); 6243833Speter putRV( 0 , cbn , CURFILEOFFSET , 6253833Speter NLOCAL , P2PTR|P2STRTY ); 626766Speter putop( P2CALL , P2INT ); 627766Speter } 628766Speter putCONG( &format[ fmtstart ] 629766Speter , strlen( &format[ fmtstart ] ) 630766Speter , LREQ ); 631766Speter putop( P2LISTOP , P2INT ); 632766Speter if ( fmtspec & VARWIDTH ) { 633766Speter /* 634766Speter * either 635766Speter * ,(temp=width,MAX(temp,...)), 636766Speter * or 637766Speter * , MAX( width , ... ) , 638766Speter */ 639766Speter if ( ( typ == TDOUBLE && al[3] == NIL ) 640766Speter || typ == TSTR ) { 6413225Smckusic soffset = sizes[cbn].curtmps; 6423833Speter tempnlp = tmpalloc(sizeof(long), 6433225Smckusic nl+T4INT, REGOK); 6443833Speter putRV( 0 , cbn , 6453833Speter tempnlp -> value[ NL_OFFS ] , 6463833Speter tempnlp -> extra_flags , P2INT ); 647766Speter ap = stkrval( al[2] , NIL , RREQ ); 648766Speter putop( P2ASSIGN , P2INT ); 649766Speter putleaf( P2ICON , 0 , 0 650766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 651766Speter , "_MAX" ); 6523833Speter putRV( 0 , cbn , 6533833Speter tempnlp -> value[ NL_OFFS ] , 6543833Speter tempnlp -> extra_flags , P2INT ); 655766Speter } else { 656766Speter if (opt('t') 657766Speter || typ == TSTR || typ == TDOUBLE) { 658766Speter putleaf( P2ICON , 0 , 0 659766Speter ,ADDTYPE( P2FTN | P2INT, P2PTR ) 660766Speter ,"_MAX" ); 661766Speter } 662766Speter ap = stkrval( al[2] , NIL , RREQ ); 663766Speter } 664766Speter if (ap == NIL) 665766Speter continue; 666766Speter if (isnta(ap,"i")) { 667766Speter error("First write width must be integer, not %s", nameof(ap)); 668766Speter continue; 669766Speter } 670766Speter switch ( typ ) { 671766Speter case TDOUBLE: 6729229Smckusick putleaf( P2ICON , REALSPC , 0 , P2INT , 0 ); 673766Speter putop( P2LISTOP , P2INT ); 674766Speter putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 675766Speter putop( P2LISTOP , P2INT ); 676766Speter putop( P2CALL , P2INT ); 677766Speter if ( al[3] == NIL ) { 678766Speter /* 679766Speter * finish up the comma op 680766Speter */ 681766Speter putop( P2COMOP , P2INT ); 682766Speter fmtspec &= ~VARPREC; 683766Speter putop( P2LISTOP , P2INT ); 684766Speter putleaf( P2ICON , 0 , 0 685766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 686766Speter , "_MAX" ); 6873833Speter putRV( 0 , cbn , 6883833Speter tempnlp -> value[ NL_OFFS ] , 6893833Speter tempnlp -> extra_flags , 6903833Speter P2INT ); 6913225Smckusic tmpfree(&soffset); 692*11883Smckusick putleaf( P2ICON , 693*11883Smckusick 5 + EXPOSIZE + REALSPC , 694*11883Smckusick 0 , P2INT , 0 ); 695766Speter putop( P2LISTOP , P2INT ); 696766Speter putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 697766Speter putop( P2LISTOP , P2INT ); 698766Speter putop( P2CALL , P2INT ); 699766Speter } 700766Speter putop( P2LISTOP , P2INT ); 701766Speter break; 702766Speter case TSTR: 703766Speter putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 704766Speter putop( P2LISTOP , P2INT ); 705766Speter putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 706766Speter putop( P2LISTOP , P2INT ); 707766Speter putop( P2CALL , P2INT ); 708766Speter putop( P2COMOP , P2INT ); 709766Speter putop( P2LISTOP , P2INT ); 710766Speter break; 711766Speter default: 712766Speter if (opt('t')) { 713766Speter putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 714766Speter putop( P2LISTOP , P2INT ); 715766Speter putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 716766Speter putop( P2LISTOP , P2INT ); 717766Speter putop( P2CALL , P2INT ); 718766Speter } 719766Speter putop( P2LISTOP , P2INT ); 720766Speter break; 721766Speter } 722766Speter } 723766Speter /* 724766Speter * If there is a variable precision, 725766Speter * evaluate it 726766Speter */ 727766Speter if (fmtspec & VARPREC) { 728766Speter if (opt('t')) { 729766Speter putleaf( P2ICON , 0 , 0 730766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 731766Speter , "_MAX" ); 732766Speter } 733766Speter ap = stkrval( al[3] , NIL , RREQ ); 734766Speter if (ap == NIL) 735766Speter continue; 736766Speter if (isnta(ap,"i")) { 737766Speter error("Second write width must be integer, not %s", nameof(ap)); 738766Speter continue; 739766Speter } 740766Speter if (opt('t')) { 741766Speter putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 742766Speter putop( P2LISTOP , P2INT ); 743766Speter putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 744766Speter putop( P2LISTOP , P2INT ); 745766Speter putop( P2CALL , P2INT ); 746766Speter } 747766Speter putop( P2LISTOP , P2INT ); 748766Speter } 749766Speter /* 750766Speter * evaluate the thing we want printed. 751766Speter */ 752766Speter switch ( typ ) { 7536540Smckusick case TPTR: 754766Speter case TCHAR: 755766Speter case TINT: 756766Speter stkrval( alv , NIL , RREQ ); 757766Speter putop( P2LISTOP , P2INT ); 758766Speter break; 759766Speter case TDOUBLE: 760766Speter ap = stkrval( alv , NIL , RREQ ); 76110373Speter if (isnta(ap, "d")) { 76210373Speter sconv(p2type(ap), P2DOUBLE); 763766Speter } 764766Speter putop( P2LISTOP , P2INT ); 765766Speter break; 766766Speter case TSCAL: 767766Speter case TBOOL: 768766Speter putleaf( P2ICON , 0 , 0 769766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 770766Speter , "_NAM" ); 771766Speter ap = stkrval( alv , NIL , RREQ ); 772766Speter sprintf( format , PREFIXFORMAT , LABELPREFIX 773766Speter , listnames( ap ) ); 774766Speter putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 775766Speter , format ); 776766Speter putop( P2LISTOP , P2INT ); 777766Speter putop( P2CALL , P2INT ); 778766Speter putop( P2LISTOP , P2INT ); 779766Speter break; 780766Speter case TSTR: 781766Speter putCONG( "" , 0 , LREQ ); 782766Speter putop( P2LISTOP , P2INT ); 783766Speter break; 7846540Smckusick default: 7856540Smckusick panic("fmt3"); 7866540Smckusick break; 787766Speter } 788766Speter putop( P2CALL , P2INT ); 789766Speter putdot( filename , line ); 790766Speter } 791766Speter /* 792766Speter * Write the string after its blank padding 793766Speter */ 794766Speter if (typ == TSTR ) { 795766Speter if ( opt( 't' ) ) { 796766Speter putleaf( P2ICON , 0 , 0 797766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 798766Speter , "_WRITES" ); 7993833Speter putRV( 0 , cbn , CURFILEOFFSET , 8003833Speter NLOCAL , P2PTR|P2STRTY ); 801766Speter ap = stkrval(alv, NIL , RREQ ); 802766Speter putop( P2LISTOP , P2INT ); 803766Speter } else { 804766Speter putleaf( P2ICON , 0 , 0 805766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 806766Speter , "_fwrite" ); 807766Speter ap = stkrval(alv, NIL , RREQ ); 808766Speter } 809766Speter if (strfmt & VARWIDTH) { 810766Speter /* 811766Speter * min, inline expanded as 812766Speter * temp < len ? temp : len 813766Speter */ 8143833Speter putRV( 0 , cbn , 8153833Speter tempnlp -> value[ NL_OFFS ] , 8163833Speter tempnlp -> extra_flags , P2INT ); 817766Speter putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 818766Speter putop( P2LT , P2INT ); 8193833Speter putRV( 0 , cbn , 8203833Speter tempnlp -> value[ NL_OFFS ] , 8213833Speter tempnlp -> extra_flags , P2INT ); 822766Speter putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 823766Speter putop( P2COLON , P2INT ); 824766Speter putop( P2QUEST , P2INT ); 8253225Smckusic tmpfree(&soffset); 826766Speter } else { 827766Speter if ( ( fmtspec & SKIP ) 828766Speter && ( strfmt & CONWIDTH ) ) { 829766Speter strnglen = field; 830766Speter } 831766Speter putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 832766Speter } 833766Speter putop( P2LISTOP , P2INT ); 834766Speter putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 835766Speter putop( P2LISTOP , P2INT ); 836766Speter putleaf( P2ICON , 0 , 0 837766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 838766Speter , "_ACTFILE" ); 8393833Speter putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 8403833Speter P2PTR|P2STRTY ); 841766Speter putop( P2CALL , P2INT ); 842766Speter putop( P2LISTOP , P2INT ); 843766Speter putop( P2CALL , P2INT ); 844766Speter putdot( filename , line ); 845766Speter } 846766Speter } 847766Speter /* 848766Speter * Done with arguments. 849766Speter * Handle writeln and 850766Speter * insufficent number of args. 851766Speter */ 852766Speter switch (p->value[0] &~ NSTAND) { 853766Speter case O_WRITEF: 854766Speter if (argc == 0) 855766Speter error("Write requires an argument"); 856766Speter break; 857766Speter case O_MESSAGE: 858766Speter if (argc == 0) 859766Speter error("Message requires an argument"); 860766Speter case O_WRITLN: 861766Speter if (filetype != nl+T1CHAR) 862766Speter error("Can't 'writeln' a non text file"); 863766Speter if ( opt( 't' ) ) { 864766Speter putleaf( P2ICON , 0 , 0 865766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 866766Speter , "_WRITLN" ); 8673833Speter putRV( 0 , cbn , CURFILEOFFSET , 8683833Speter NLOCAL , P2PTR|P2STRTY ); 869766Speter } else { 870766Speter putleaf( P2ICON , 0 , 0 871766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 872766Speter , "_fputc" ); 873766Speter putleaf( P2ICON , '\n' , 0 , P2CHAR , 0 ); 874766Speter putleaf( P2ICON , 0 , 0 875766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 876766Speter , "_ACTFILE" ); 8773833Speter putRV( 0 , cbn , CURFILEOFFSET , 8783833Speter NLOCAL , P2PTR|P2STRTY ); 879766Speter putop( P2CALL , P2INT ); 880766Speter putop( P2LISTOP , P2INT ); 881766Speter } 882766Speter putop( P2CALL , P2INT ); 883766Speter putdot( filename , line ); 884766Speter break; 885766Speter } 886766Speter return; 887766Speter 888766Speter case O_READ4: 889766Speter case O_READLN: 890766Speter /* 891766Speter * Set up default 892766Speter * file "input". 893766Speter */ 894766Speter file = NIL; 895766Speter filetype = nl+T1CHAR; 896766Speter /* 897766Speter * Determine the file implied 898766Speter * for the read and generate 899766Speter * code to make it the active file. 900766Speter */ 901766Speter if (argv != NIL) { 902766Speter codeoff(); 903766Speter ap = stkrval(argv[1], NIL , RREQ ); 904766Speter codeon(); 905766Speter if (ap == NIL) 906766Speter argv = argv[2]; 907766Speter if (ap != NIL && ap->class == FILET) { 908766Speter /* 909766Speter * Got "read(f, ...", make 910766Speter * f the active file, and save 911766Speter * it and its type for use in 912766Speter * processing the rest of the 913766Speter * arguments to read. 914766Speter */ 915766Speter file = argv[1]; 916766Speter filetype = ap->type; 9173833Speter putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 9183833Speter P2PTR|P2STRTY ); 919766Speter putleaf( P2ICON , 0 , 0 920766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 921766Speter , "_UNIT" ); 922766Speter stklval(argv[1], NOFLAGS); 923766Speter putop( P2CALL , P2INT ); 924766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 925766Speter putdot( filename , line ); 926766Speter argv = argv[2]; 927766Speter argc--; 928766Speter } else { 929766Speter /* 930766Speter * Default is read from 931766Speter * standard input. 932766Speter */ 9333833Speter putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 9343833Speter P2PTR|P2STRTY ); 9353833Speter putLV( "_input" , 0 , 0 , NGLOBAL , 9363833Speter P2PTR|P2STRTY ); 937766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 938766Speter putdot( filename , line ); 939766Speter input->nl_flags |= NUSED; 940766Speter } 941766Speter } else { 9423833Speter putRV( 0, cbn , CURFILEOFFSET , NLOCAL , 9433833Speter P2PTR|P2STRTY ); 9443833Speter putLV( "_input" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY ); 945766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 946766Speter putdot( filename , line ); 947766Speter input->nl_flags |= NUSED; 948766Speter } 949766Speter /* 950766Speter * Loop and process each 951766Speter * of the arguments. 952766Speter */ 953766Speter for (; argv != NIL; argv = argv[2]) { 954766Speter /* 955766Speter * Get the address of the target 956766Speter * on the stack. 957766Speter */ 958766Speter al = argv[1]; 959766Speter if (al == NIL) 960766Speter continue; 961766Speter if (al[0] != T_VAR) { 962766Speter error("Arguments to %s must be variables, not expressions", p->symbol); 963766Speter continue; 964766Speter } 965766Speter codeoff(); 966766Speter ap = stklval(al, MOD|ASGN|NOUSE); 967766Speter codeon(); 968766Speter if (ap == NIL) 969766Speter continue; 970766Speter if (filetype != nl+T1CHAR) { 971766Speter /* 972766Speter * Generalized read, i.e. 973766Speter * from a non-textfile. 974766Speter */ 975766Speter if (incompat(filetype, ap, argv[1] )) { 976766Speter error("Type mismatch in read from non-text file"); 977766Speter continue; 978766Speter } 979766Speter /* 980766Speter * var := file ^; 981766Speter */ 982766Speter ap = lvalue( al , MOD | ASGN | NOUSE , RREQ ); 983766Speter if ( isa( ap , "bsci" ) ) { 984766Speter precheck( ap , "_RANG4" , "_RSNG4" ); 985766Speter } 986766Speter putleaf( P2ICON , 0 , 0 987766Speter , ADDTYPE( 988766Speter ADDTYPE( 989766Speter ADDTYPE( 990766Speter p2type( filetype ) , P2PTR ) 991766Speter , P2FTN ) 992766Speter , P2PTR ) 993766Speter , "_FNIL" ); 994766Speter if (file != NIL) 995766Speter stklval(file, NOFLAGS); 996766Speter else /* Magic */ 9973833Speter putRV( "_input" , 0 , 0 , NGLOBAL , 9983833Speter P2PTR | P2STRTY ); 99910668Speter putop(P2CALL, ADDTYPE(p2type(filetype), P2PTR)); 1000766Speter switch ( classify( filetype ) ) { 1001766Speter case TBOOL: 1002766Speter case TCHAR: 1003766Speter case TINT: 1004766Speter case TSCAL: 1005766Speter case TDOUBLE: 1006766Speter case TPTR: 1007766Speter putop( P2UNARY P2MUL 1008766Speter , p2type( filetype ) ); 1009766Speter } 1010766Speter switch ( classify( filetype ) ) { 1011766Speter case TBOOL: 1012766Speter case TCHAR: 1013766Speter case TINT: 1014766Speter case TSCAL: 101510373Speter postcheck(ap, filetype); 101610373Speter sconv(p2type(filetype), p2type(ap)); 1017766Speter /* and fall through */ 1018766Speter case TDOUBLE: 1019766Speter case TPTR: 1020766Speter putop( P2ASSIGN , p2type( ap ) ); 1021766Speter putdot( filename , line ); 1022766Speter break; 1023766Speter default: 102411856Speter putstrop(P2STASG, 102511856Speter ADDTYPE(p2type(ap), P2PTR), 102611856Speter lwidth(ap), 102711856Speter align(ap)); 1028766Speter putdot( filename , line ); 1029766Speter break; 1030766Speter } 1031766Speter /* 1032766Speter * get(file); 1033766Speter */ 1034766Speter putleaf( P2ICON , 0 , 0 1035766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 1036766Speter , "_GET" ); 10373833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 10383833Speter P2PTR|P2STRTY ); 1039766Speter putop( P2CALL , P2INT ); 1040766Speter putdot( filename , line ); 1041766Speter continue; 1042766Speter } 1043766Speter /* 1044766Speter * if you get to here, you are reading from 1045766Speter * a text file. only possiblities are: 1046766Speter * character, integer, real, or scalar. 1047766Speter * read( f , foo , ... ) is done as 1048766Speter * foo := read( f ) with rangechecking 1049766Speter * if appropriate. 1050766Speter */ 1051766Speter typ = classify(ap); 1052766Speter op = rdops(typ); 1053766Speter if (op == NIL) { 1054766Speter error("Can't read %ss from a text file", clnames[typ]); 1055766Speter continue; 1056766Speter } 1057766Speter /* 1058766Speter * left hand side of foo := read( f ) 1059766Speter */ 1060766Speter ap = lvalue( al , MOD|ASGN|NOUSE , RREQ ); 1061766Speter if ( isa( ap , "bsci" ) ) { 1062766Speter precheck( ap , "_RANG4" , "_RSNG4" ); 1063766Speter } 1064766Speter switch ( op ) { 1065766Speter case O_READC: 1066766Speter readname = "_READC"; 1067766Speter readtype = P2INT; 1068766Speter break; 1069766Speter case O_READ4: 1070766Speter readname = "_READ4"; 1071766Speter readtype = P2INT; 1072766Speter break; 1073766Speter case O_READ8: 1074766Speter readname = "_READ8"; 1075766Speter readtype = P2DOUBLE; 1076766Speter break; 1077766Speter case O_READE: 1078766Speter readname = "_READE"; 1079766Speter readtype = P2INT; 1080766Speter break; 1081766Speter } 1082766Speter putleaf( P2ICON , 0 , 0 1083766Speter , ADDTYPE( P2FTN | readtype , P2PTR ) 1084766Speter , readname ); 10853833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 10863833Speter P2PTR|P2STRTY ); 1087766Speter if ( op == O_READE ) { 1088766Speter sprintf( format , PREFIXFORMAT , LABELPREFIX 1089766Speter , listnames( ap ) ); 1090766Speter putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR 1091766Speter , format ); 1092766Speter putop( P2LISTOP , P2INT ); 10931629Speter warning(); 1094766Speter if (opt('s')) { 1095766Speter standard(); 1096766Speter } 10971629Speter error("Reading scalars from text files is non-standard"); 1098766Speter } 1099766Speter putop( P2CALL , readtype ); 1100766Speter if ( isa( ap , "bcsi" ) ) { 110110373Speter postcheck(ap, readtype==P2INT?nl+T4INT:nl+TDOUBLE); 1102766Speter } 110310373Speter sconv(readtype, p2type(ap)); 1104766Speter putop( P2ASSIGN , p2type( ap ) ); 1105766Speter putdot( filename , line ); 1106766Speter } 1107766Speter /* 1108766Speter * Done with arguments. 1109766Speter * Handle readln and 1110766Speter * insufficient number of args. 1111766Speter */ 1112766Speter if (p->value[0] == O_READLN) { 1113766Speter if (filetype != nl+T1CHAR) 1114766Speter error("Can't 'readln' a non text file"); 1115766Speter putleaf( P2ICON , 0 , 0 1116766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 1117766Speter , "_READLN" ); 11183833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , 11193833Speter P2PTR|P2STRTY ); 1120766Speter putop( P2CALL , P2INT ); 1121766Speter putdot( filename , line ); 1122766Speter } else if (argc == 0) 1123766Speter error("read requires an argument"); 1124766Speter return; 1125766Speter 1126766Speter case O_GET: 1127766Speter case O_PUT: 1128766Speter if (argc != 1) { 1129766Speter error("%s expects one argument", p->symbol); 1130766Speter return; 1131766Speter } 11323833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1133766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1134766Speter , "_UNIT" ); 1135766Speter ap = stklval(argv[1], NOFLAGS); 1136766Speter if (ap == NIL) 1137766Speter return; 1138766Speter if (ap->class != FILET) { 1139766Speter error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1140766Speter return; 1141766Speter } 1142766Speter putop( P2CALL , P2INT ); 1143766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 1144766Speter putdot( filename , line ); 1145766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1146766Speter , op == O_GET ? "_GET" : "_PUT" ); 11473833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1148766Speter putop( P2CALL , P2INT ); 1149766Speter putdot( filename , line ); 1150766Speter return; 1151766Speter 1152766Speter case O_RESET: 1153766Speter case O_REWRITE: 1154766Speter if (argc == 0 || argc > 2) { 1155766Speter error("%s expects one or two arguments", p->symbol); 1156766Speter return; 1157766Speter } 1158766Speter if (opt('s') && argc == 2) { 1159766Speter standard(); 1160766Speter error("Two argument forms of reset and rewrite are non-standard"); 1161766Speter } 1162766Speter putleaf( P2ICON , 0 , 0 , P2INT 1163766Speter , op == O_RESET ? "_RESET" : "_REWRITE" ); 1164766Speter ap = stklval(argv[1], MOD|NOUSE); 1165766Speter if (ap == NIL) 1166766Speter return; 1167766Speter if (ap->class != FILET) { 1168766Speter error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); 1169766Speter return; 1170766Speter } 1171766Speter if (argc == 2) { 1172766Speter /* 1173766Speter * Optional second argument 1174766Speter * is a string name of a 1175766Speter * UNIX (R) file to be associated. 1176766Speter */ 1177766Speter al = argv[2]; 1178766Speter al = stkrval(al[1], NOFLAGS , RREQ ); 1179766Speter if (al == NIL) 1180766Speter return; 1181766Speter if (classify(al) != TSTR) { 1182766Speter error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); 1183766Speter return; 1184766Speter } 1185766Speter strnglen = width(al); 1186766Speter } else { 1187766Speter putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 1188766Speter strnglen = 0; 1189766Speter } 1190766Speter putop( P2LISTOP , P2INT ); 1191766Speter putleaf( P2ICON , strnglen , 0 , P2INT , 0 ); 1192766Speter putop( P2LISTOP , P2INT ); 1193766Speter putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 ); 1194766Speter putop( P2LISTOP , P2INT ); 1195766Speter putop( P2CALL , P2INT ); 1196766Speter putdot( filename , line ); 1197766Speter return; 1198766Speter 1199766Speter case O_NEW: 1200766Speter case O_DISPOSE: 1201766Speter if (argc == 0) { 1202766Speter error("%s expects at least one argument", p->symbol); 1203766Speter return; 1204766Speter } 12059139Smckusick alv = argv[1]; 12067967Smckusick codeoff(); 12079139Smckusick ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 12087967Smckusick codeon(); 1209766Speter if (ap == NIL) 1210766Speter return; 1211766Speter if (ap->class != PTR) { 1212766Speter error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); 1213766Speter return; 1214766Speter } 1215766Speter ap = ap->type; 1216766Speter if (ap == NIL) 1217766Speter return; 12189139Smckusick if (op == O_NEW) 12199139Smckusick cmd = "_NEW"; 12209139Smckusick else /* op == O_DISPOSE */ 12217967Smckusick if ((ap->nl_flags & NFILES) != 0) 12227967Smckusick cmd = "_DFDISPOSE"; 12237967Smckusick else 12247967Smckusick cmd = "_DISPOSE"; 12257967Smckusick putleaf( P2ICON, 0, 0, ADDTYPE( P2FTN | P2INT , P2PTR ), cmd); 12269139Smckusick stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD ); 1227766Speter argv = argv[2]; 1228766Speter if (argv != NIL) { 1229766Speter if (ap->class != RECORD) { 1230766Speter error("Record required when specifying variant tags"); 1231766Speter return; 1232766Speter } 1233766Speter for (; argv != NIL; argv = argv[2]) { 1234766Speter if (ap->ptr[NL_VARNT] == NIL) { 1235766Speter error("Too many tag fields"); 1236766Speter return; 1237766Speter } 1238766Speter if (!isconst(argv[1])) { 1239766Speter error("Second and successive arguments to %s must be constants", p->symbol); 1240766Speter return; 1241766Speter } 1242766Speter gconst(argv[1]); 1243766Speter if (con.ctype == NIL) 1244766Speter return; 1245766Speter if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) { 1246766Speter cerror("Specified tag constant type clashed with variant case selector type"); 1247766Speter return; 1248766Speter } 1249766Speter for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain) 1250766Speter if (ap->range[0] == con.crval) 1251766Speter break; 1252766Speter if (ap == NIL) { 1253766Speter error("No variant case label value equals specified constant value"); 1254766Speter return; 1255766Speter } 1256766Speter ap = ap->ptr[NL_VTOREC]; 1257766Speter } 1258766Speter } 1259766Speter putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1260766Speter putop( P2LISTOP , P2INT ); 1261766Speter putop( P2CALL , P2INT ); 1262766Speter putdot( filename , line ); 12639139Smckusick if (opt('t') && op == O_NEW) { 12649139Smckusick putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 12659139Smckusick , "_blkclr" ); 12669264Smckusick stkrval(alv, NIL , RREQ ); 12679139Smckusick putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 12689139Smckusick putop( P2LISTOP , P2INT ); 12699139Smckusick putop( P2CALL , P2INT ); 12709139Smckusick putdot( filename , line ); 12719139Smckusick } 1272766Speter return; 1273766Speter 1274766Speter case O_DATE: 1275766Speter case O_TIME: 1276766Speter if (argc != 1) { 1277766Speter error("%s expects one argument", p->symbol); 1278766Speter return; 1279766Speter } 1280766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1281766Speter , op == O_DATE ? "_DATE" : "_TIME" ); 1282766Speter ap = stklval(argv[1], MOD|NOUSE); 1283766Speter if (ap == NIL) 1284766Speter return; 1285766Speter if (classify(ap) != TSTR || width(ap) != 10) { 1286766Speter error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); 1287766Speter return; 1288766Speter } 1289766Speter putop( P2CALL , P2INT ); 1290766Speter putdot( filename , line ); 1291766Speter return; 1292766Speter 1293766Speter case O_HALT: 1294766Speter if (argc != 0) { 1295766Speter error("halt takes no arguments"); 1296766Speter return; 1297766Speter } 1298766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1299766Speter , "_HALT" ); 1300766Speter 1301766Speter putop( P2UNARY P2CALL , P2INT ); 1302766Speter putdot( filename , line ); 1303766Speter noreach = 1; 1304766Speter return; 1305766Speter 1306766Speter case O_ARGV: 1307766Speter if (argc != 2) { 1308766Speter error("argv takes two arguments"); 1309766Speter return; 1310766Speter } 1311766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1312766Speter , "_ARGV" ); 1313766Speter ap = stkrval(argv[1], NIL , RREQ ); 1314766Speter if (ap == NIL) 1315766Speter return; 1316766Speter if (isnta(ap, "i")) { 1317766Speter error("argv's first argument must be an integer, not %s", nameof(ap)); 1318766Speter return; 1319766Speter } 1320766Speter al = argv[2]; 1321766Speter ap = stklval(al[1], MOD|NOUSE); 1322766Speter if (ap == NIL) 1323766Speter return; 1324766Speter if (classify(ap) != TSTR) { 1325766Speter error("argv's second argument must be a string, not %s", nameof(ap)); 1326766Speter return; 1327766Speter } 1328766Speter putop( P2LISTOP , P2INT ); 1329766Speter putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1330766Speter putop( P2LISTOP , P2INT ); 1331766Speter putop( P2CALL , P2INT ); 1332766Speter putdot( filename , line ); 1333766Speter return; 1334766Speter 1335766Speter case O_STLIM: 1336766Speter if (argc != 1) { 1337766Speter error("stlimit requires one argument"); 1338766Speter return; 1339766Speter } 1340766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1341766Speter , "_STLIM" ); 1342766Speter ap = stkrval(argv[1], NIL , RREQ ); 1343766Speter if (ap == NIL) 1344766Speter return; 1345766Speter if (isnta(ap, "i")) { 1346766Speter error("stlimit's argument must be an integer, not %s", nameof(ap)); 1347766Speter return; 1348766Speter } 1349766Speter putop( P2CALL , P2INT ); 1350766Speter putdot( filename , line ); 1351766Speter return; 1352766Speter 1353766Speter case O_REMOVE: 1354766Speter if (argc != 1) { 1355766Speter error("remove expects one argument"); 1356766Speter return; 1357766Speter } 1358766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1359766Speter , "_REMOVE" ); 1360766Speter ap = stkrval(argv[1], NOFLAGS , RREQ ); 1361766Speter if (ap == NIL) 1362766Speter return; 1363766Speter if (classify(ap) != TSTR) { 1364766Speter error("remove's argument must be a string, not %s", nameof(ap)); 1365766Speter return; 1366766Speter } 1367766Speter putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 ); 1368766Speter putop( P2LISTOP , P2INT ); 1369766Speter putop( P2CALL , P2INT ); 1370766Speter putdot( filename , line ); 1371766Speter return; 1372766Speter 1373766Speter case O_LLIMIT: 1374766Speter if (argc != 2) { 1375766Speter error("linelimit expects two arguments"); 1376766Speter return; 1377766Speter } 1378766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1379766Speter , "_LLIMIT" ); 1380766Speter ap = stklval(argv[1], NOFLAGS|NOUSE); 1381766Speter if (ap == NIL) 1382766Speter return; 1383766Speter if (!text(ap)) { 1384766Speter error("linelimit's first argument must be a text file, not %s", nameof(ap)); 1385766Speter return; 1386766Speter } 1387766Speter al = argv[2]; 1388766Speter ap = stkrval(al[1], NIL , RREQ ); 1389766Speter if (ap == NIL) 1390766Speter return; 1391766Speter if (isnta(ap, "i")) { 1392766Speter error("linelimit's second argument must be an integer, not %s", nameof(ap)); 1393766Speter return; 1394766Speter } 1395766Speter putop( P2LISTOP , P2INT ); 1396766Speter putop( P2CALL , P2INT ); 1397766Speter putdot( filename , line ); 1398766Speter return; 1399766Speter case O_PAGE: 1400766Speter if (argc != 1) { 1401766Speter error("page expects one argument"); 1402766Speter return; 1403766Speter } 14043833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1405766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1406766Speter , "_UNIT" ); 1407766Speter ap = stklval(argv[1], NOFLAGS); 1408766Speter if (ap == NIL) 1409766Speter return; 1410766Speter if (!text(ap)) { 1411766Speter error("Argument to page must be a text file, not %s", nameof(ap)); 1412766Speter return; 1413766Speter } 1414766Speter putop( P2CALL , P2INT ); 1415766Speter putop( P2ASSIGN , P2PTR|P2STRTY ); 1416766Speter putdot( filename , line ); 1417766Speter if ( opt( 't' ) ) { 1418766Speter putleaf( P2ICON , 0 , 0 1419766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 1420766Speter , "_PAGE" ); 14213833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1422766Speter } else { 1423766Speter putleaf( P2ICON , 0 , 0 1424766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 1425766Speter , "_fputc" ); 1426766Speter putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 ); 1427766Speter putleaf( P2ICON , 0 , 0 1428766Speter , ADDTYPE( P2FTN | P2INT , P2PTR ) 1429766Speter , "_ACTFILE" ); 14303833Speter putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY ); 1431766Speter putop( P2CALL , P2INT ); 1432766Speter putop( P2LISTOP , P2INT ); 1433766Speter } 1434766Speter putop( P2CALL , P2INT ); 1435766Speter putdot( filename , line ); 1436766Speter return; 1437766Speter 14387928Smckusick case O_ASRT: 14397928Smckusick if (!opt('t')) 14407928Smckusick return; 14417928Smckusick if (argc == 0 || argc > 2) { 14427928Smckusick error("Assert expects one or two arguments"); 14437928Smckusick return; 14447928Smckusick } 14459139Smckusick if (argc == 2) 14469139Smckusick cmd = "_ASRTS"; 14479139Smckusick else 14489139Smckusick cmd = "_ASRT"; 14497928Smckusick putleaf( P2ICON , 0 , 0 14509139Smckusick , ADDTYPE( P2FTN | P2INT , P2PTR ) , cmd ); 14517928Smckusick ap = stkrval(argv[1], NIL , RREQ ); 14527928Smckusick if (ap == NIL) 14537928Smckusick return; 14547928Smckusick if (isnta(ap, "b")) 14557928Smckusick error("Assert expression must be Boolean, not %ss", nameof(ap)); 14567928Smckusick if (argc == 2) { 14577928Smckusick /* 14587928Smckusick * Optional second argument is a string specifying 14597928Smckusick * why the assertion failed. 14607928Smckusick */ 14617928Smckusick al = argv[2]; 14627928Smckusick al = stkrval(al[1], NIL , RREQ ); 14637928Smckusick if (al == NIL) 14647928Smckusick return; 14657928Smckusick if (classify(al) != TSTR) { 14667928Smckusick error("Second argument to assert must be a string, not %s", nameof(al)); 14677928Smckusick return; 14687928Smckusick } 14699139Smckusick putop( P2LISTOP , P2INT ); 14707928Smckusick } 14717928Smckusick putop( P2CALL , P2INT ); 14727928Smckusick putdot( filename , line ); 14737928Smckusick return; 14747928Smckusick 1475766Speter case O_PACK: 1476766Speter if (argc != 3) { 1477766Speter error("pack expects three arguments"); 1478766Speter return; 1479766Speter } 1480766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1481766Speter , "_PACK" ); 1482766Speter pu = "pack(a,i,z)"; 1483766Speter pua = (al = argv)[1]; 1484766Speter pui = (al = al[2])[1]; 1485766Speter puz = (al = al[2])[1]; 1486766Speter goto packunp; 1487766Speter case O_UNPACK: 1488766Speter if (argc != 3) { 1489766Speter error("unpack expects three arguments"); 1490766Speter return; 1491766Speter } 1492766Speter putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 1493766Speter , "_UNPACK" ); 1494766Speter pu = "unpack(z,a,i)"; 1495766Speter puz = (al = argv)[1]; 1496766Speter pua = (al = al[2])[1]; 1497766Speter pui = (al = al[2])[1]; 1498766Speter packunp: 1499766Speter ap = stkrval((int *) pui, NLNIL , RREQ ); 1500766Speter if (ap == NIL) 1501766Speter return; 1502766Speter ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE); 1503766Speter if (ap == NIL) 1504766Speter return; 1505766Speter if (ap->class != ARRAY) { 1506766Speter error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); 1507766Speter return; 1508766Speter } 1509766Speter putop( P2LISTOP , P2INT ); 1510766Speter al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE); 1511766Speter if (al->class != ARRAY) { 1512766Speter error("%s requires z to be a packed array, not %s", pu, nameof(ap)); 1513766Speter return; 1514766Speter } 1515766Speter if (al->type == NIL || ap->type == NIL) 1516766Speter return; 1517766Speter if (al->type != ap->type) { 1518766Speter error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); 1519766Speter return; 1520766Speter } 1521766Speter putop( P2LISTOP , P2INT ); 1522766Speter k = width(al); 1523766Speter itemwidth = width(ap->type); 1524766Speter ap = ap->chain; 1525766Speter al = al->chain; 1526766Speter if (ap->chain != NIL || al->chain != NIL) { 1527766Speter error("%s requires a and z to be single dimension arrays", pu); 1528766Speter return; 1529766Speter } 1530766Speter if (ap == NIL || al == NIL) 1531766Speter return; 1532766Speter /* 1533766Speter * al is the range for z i.e. u..v 1534766Speter * ap is the range for a i.e. m..n 1535766Speter * i will be n-m+1 1536766Speter * j will be v-u+1 1537766Speter */ 1538766Speter i = ap->range[1] - ap->range[0] + 1; 1539766Speter j = al->range[1] - al->range[0] + 1; 1540766Speter if (i < j) { 1541766Speter error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); 1542766Speter return; 1543766Speter } 1544766Speter /* 1545766Speter * get n-m-(v-u) and m for the interpreter 1546766Speter */ 1547766Speter i -= j; 1548766Speter j = ap->range[0]; 1549766Speter putleaf( P2ICON , itemwidth , 0 , P2INT , 0 ); 1550766Speter putop( P2LISTOP , P2INT ); 1551766Speter putleaf( P2ICON , j , 0 , P2INT , 0 ); 1552766Speter putop( P2LISTOP , P2INT ); 1553766Speter putleaf( P2ICON , i , 0 , P2INT , 0 ); 1554766Speter putop( P2LISTOP , P2INT ); 1555766Speter putleaf( P2ICON , k , 0 , P2INT , 0 ); 1556766Speter putop( P2LISTOP , P2INT ); 1557766Speter putop( P2CALL , P2INT ); 1558766Speter putdot( filename , line ); 1559766Speter return; 1560766Speter case 0: 15617928Smckusick error("%s is an unimplemented extension", p->symbol); 1562766Speter return; 1563766Speter 1564766Speter default: 1565766Speter panic("proc case"); 1566766Speter } 1567766Speter } 1568766Speter #endif PC 1569