1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  */
   6: 
   7: #ifndef lint
   8: static char sccsid[] = "@(#)pcproc.c	5.1 (Berkeley) 6/5/85";
   9: #endif not lint
  10: 
  11: #include "whoami.h"
  12: #ifdef PC
  13:     /*
  14:      * and to the end of the file
  15:      */
  16: #include "0.h"
  17: #include "tree.h"
  18: #include "objfmt.h"
  19: #include "opcode.h"
  20: #include "pc.h"
  21: #include <pcc.h>
  22: #include "tmps.h"
  23: #include "tree_ty.h"
  24: 
  25: /*
  26:  * The constant EXPOSIZE specifies the number of digits in the exponent
  27:  * of real numbers.
  28:  *
  29:  * The constant REALSPC defines the amount of forced padding preceeding
  30:  * real numbers when they are printed. If REALSPC == 0, then no padding
  31:  * is added, REALSPC == 1 adds one extra blank irregardless of the width
  32:  * specified by the user.
  33:  *
  34:  * N.B. - Values greater than one require program mods.
  35:  */
  36: #define EXPOSIZE    2
  37: #define REALSPC     0
  38: 
  39: /*
  40:  * The following array is used to determine which classes may be read
  41:  * from textfiles. It is indexed by the return value from classify.
  42:  */
  43: #define rdops(x) rdxxxx[(x)-(TFIRST)]
  44: 
  45: int rdxxxx[] = {
  46:     0,      /* -7 file types */
  47:     0,      /* -6 record types */
  48:     0,      /* -5 array types */
  49:     O_READE,    /* -4 scalar types */
  50:     0,      /* -3 pointer types */
  51:     0,      /* -2 set types */
  52:     0,      /* -1 string types */
  53:     0,      /*  0 nil, no type */
  54:     O_READE,    /*  1 boolean */
  55:     O_READC,    /*  2 character */
  56:     O_READ4,    /*  3 integer */
  57:     O_READ8     /*  4 real */
  58: };
  59: 
  60: /*
  61:  * Proc handles procedure calls.
  62:  * Non-builtin procedures are "buck-passed" to func (with a flag
  63:  * indicating that they are actually procedures.
  64:  * builtin procedures are handled here.
  65:  */
  66: pcproc(r)
  67:     struct tnode *r;    /* T_PCALL */
  68: {
  69:     register struct nl *p;
  70:     register struct tnode *alv, *al;
  71:     register op;
  72:     struct nl *filetype, *ap;
  73:     int argc, typ, fmtspec, strfmt;
  74:     struct tnode *argv, *file;
  75:     char fmt, format[20], *strptr, *cmd;
  76:     int prec, field, strnglen, fmtstart;
  77:     char *pu;
  78:     struct tnode *pua, *pui, *puz;
  79:     int i, j, k;
  80:     int itemwidth;
  81:     char        *readname;
  82:     struct nl   *tempnlp;
  83:     long        readtype;
  84:     struct tmps soffset;
  85:     bool        soffset_flag;
  86: 
  87: #define CONPREC 4
  88: #define VARPREC 8
  89: #define CONWIDTH 1
  90: #define VARWIDTH 2
  91: #define SKIP 16
  92: 
  93:     /*
  94: 	 * Verify that the name is
  95: 	 * defined and is that of a
  96: 	 * procedure.
  97: 	 */
  98:     p = lookup(r->pcall_node.proc_id);
  99:     if (p == NLNIL) {
 100:         rvlist(r->pcall_node.arg);
 101:         return;
 102:     }
 103:     if (p->class != PROC && p->class != FPROC) {
 104:         error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
 105:         rvlist(r->pcall_node.arg);
 106:         return;
 107:     }
 108:     argv = r->pcall_node.arg;
 109: 
 110:     /*
 111: 	 * Call handles user defined
 112: 	 * procedures and functions.
 113: 	 */
 114:     if (bn != 0) {
 115:         (void) call(p, argv, PROC, bn);
 116:         return;
 117:     }
 118: 
 119:     /*
 120: 	 * Call to built-in procedure.
 121: 	 * Count the arguments.
 122: 	 */
 123:     argc = 0;
 124:     for (al = argv; al != TR_NIL; al = al->list_node.next)
 125:         argc++;
 126: 
 127:     /*
 128: 	 * Switch on the operator
 129: 	 * associated with the built-in
 130: 	 * procedure in the namelist
 131: 	 */
 132:     op = p->value[0] &~ NSTAND;
 133:     if (opt('s') && (p->value[0] & NSTAND)) {
 134:         standard();
 135:         error("%s is a nonstandard procedure", p->symbol);
 136:     }
 137:     switch (op) {
 138: 
 139:     case O_ABORT:
 140:         if (argc != 0)
 141:             error("null takes no arguments");
 142:         return;
 143: 
 144:     case O_FLUSH:
 145:         if (argc == 0) {
 146:             putleaf( PCC_ICON , 0 , 0 , PCCT_INT , "_PFLUSH" );
 147:             putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
 148:             putdot( filename , line );
 149:             return;
 150:         }
 151:         if (argc != 1) {
 152:             error("flush takes at most one argument");
 153:             return;
 154:         }
 155:         putleaf( PCC_ICON , 0 , 0
 156:             , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 157:             , "_FLUSH" );
 158:         ap = stklval(argv->list_node.list, NOFLAGS);
 159:         if (ap == NLNIL)
 160:             return;
 161:         if (ap->class != FILET) {
 162:             error("flush's argument must be a file, not %s", nameof(ap));
 163:             return;
 164:         }
 165:         putop( PCC_CALL , PCCT_INT );
 166:         putdot( filename , line );
 167:         return;
 168: 
 169:     case O_MESSAGE:
 170:     case O_WRITEF:
 171:     case O_WRITLN:
 172:         /*
 173: 		 * Set up default file "output"'s type
 174: 		 */
 175:         file = NIL;
 176:         filetype = nl+T1CHAR;
 177:         /*
 178: 		 * Determine the file implied
 179: 		 * for the write and generate
 180: 		 * code to make it the active file.
 181: 		 */
 182:         if (op == O_MESSAGE) {
 183:             /*
 184: 			 * For message, all that matters
 185: 			 * is that the filetype is
 186: 			 * a character file.
 187: 			 * Thus "output" will suit us fine.
 188: 			 */
 189:             putleaf( PCC_ICON , 0 , 0 , PCCT_INT , "_PFLUSH" );
 190:             putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
 191:             putdot( filename , line );
 192:             putRV( (char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
 193:                 PCCTM_PTR|PCCT_STRTY );
 194:             putLV( "__err" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY );
 195:             putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 196:             putdot( filename , line );
 197:         } else if (argv != TR_NIL && (al = argv->list_node.list)->tag !=
 198:                     T_WEXP) {
 199:             /*
 200: 			 * If there is a first argument which has
 201: 			 * no write widths, then it is potentially
 202: 			 * a file name.
 203: 			 */
 204:             codeoff();
 205:             ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
 206:             codeon();
 207:             if (ap == NLNIL)
 208:                 argv = argv->list_node.next;
 209:             if (ap != NIL && ap->class == FILET) {
 210:                 /*
 211: 				 * Got "write(f, ...", make
 212: 				 * f the active file, and save
 213: 				 * it and its type for use in
 214: 				 * processing the rest of the
 215: 				 * arguments to write.
 216: 				 */
 217:                 putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
 218:                     PCCTM_PTR|PCCT_STRTY );
 219:                 putleaf( PCC_ICON , 0 , 0
 220:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 221:                     , "_UNIT" );
 222:                 file = argv->list_node.list;
 223:                 filetype = ap->type;
 224:                 (void) stklval(argv->list_node.list, NOFLAGS);
 225:                 putop( PCC_CALL , PCCT_INT );
 226:                 putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 227:                 putdot( filename , line );
 228:                 /*
 229: 				 * Skip over the first argument
 230: 				 */
 231:                 argv = argv->list_node.next;
 232:                 argc--;
 233:             } else {
 234:                 /*
 235: 				 * Set up for writing on
 236: 				 * standard output.
 237: 				 */
 238:                 putRV((char *) 0, cbn , CURFILEOFFSET ,
 239:                     NLOCAL , PCCTM_PTR|PCCT_STRTY );
 240:                 putLV( "_output" , 0 , 0 , NGLOBAL ,
 241:                     PCCTM_PTR|PCCT_STRTY );
 242:                 putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 243:                 putdot( filename , line );
 244:                 output->nl_flags |= NUSED;
 245:             }
 246:         } else {
 247:             putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL ,
 248:                 PCCTM_PTR|PCCT_STRTY );
 249:             putLV( "_output" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY );
 250:             putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 251:             putdot( filename , line );
 252:             output->nl_flags |= NUSED;
 253:         }
 254:         /*
 255: 		 * Loop and process each
 256: 		 * of the arguments.
 257: 		 */
 258:         for (; argv != TR_NIL; argv = argv->list_node.next) {
 259:                 soffset_flag = FALSE;
 260:             /*
 261: 			 * fmtspec indicates the type (CONstant or VARiable)
 262: 			 *	and number (none, WIDTH, and/or PRECision)
 263: 			 *	of the fields in the printf format for this
 264: 			 *	output variable.
 265: 			 * fmt is the format output indicator (D, E, F, O, X, S)
 266: 			 * fmtstart = 0 for leading blank; = 1 for no blank
 267: 			 */
 268:             fmtspec = NIL;
 269:             fmt = 'D';
 270:             fmtstart = 1;
 271:             al = argv->list_node.list;
 272:             if (al == NIL)
 273:                 continue;
 274:             if (al->tag == T_WEXP)
 275:                 alv = al->wexpr_node.expr1;
 276:             else
 277:                 alv = al;
 278:             if (alv == TR_NIL)
 279:                 continue;
 280:             codeoff();
 281:             ap = stkrval(alv, NLNIL , (long) RREQ );
 282:             codeon();
 283:             if (ap == NLNIL)
 284:                 continue;
 285:             typ = classify(ap);
 286:             if (al->tag == T_WEXP) {
 287:                 /*
 288: 				 * Handle width expressions.
 289: 				 * The basic game here is that width
 290: 				 * expressions get evaluated. If they
 291: 				 * are constant, the value is placed
 292: 				 * directly in the format string.
 293: 				 * Otherwise the value is pushed onto
 294: 				 * the stack and an indirection is
 295: 				 * put into the format string.
 296: 				 */
 297:                 if (al->wexpr_node.expr3 ==
 298:                         (struct tnode *) OCT)
 299:                     fmt = 'O';
 300:                 else if (al->wexpr_node.expr3 ==
 301:                         (struct tnode *) HEX)
 302:                     fmt = 'X';
 303:                 else if (al->wexpr_node.expr3 != TR_NIL) {
 304:                     /*
 305: 					 * Evaluate second format spec
 306: 					 */
 307:                     if ( constval(al->wexpr_node.expr3)
 308:                         && isa( con.ctype , "i" ) ) {
 309:                         fmtspec += CONPREC;
 310:                         prec = con.crval;
 311:                     } else {
 312:                         fmtspec += VARPREC;
 313:                     }
 314:                     fmt = 'f';
 315:                     switch ( typ ) {
 316:                     case TINT:
 317:                         if ( opt( 's' ) ) {
 318:                             standard();
 319:                             error("Writing %ss with two write widths is non-standard", clnames[typ]);
 320:                         }
 321:                         /* and fall through */
 322:                     case TDOUBLE:
 323:                         break;
 324:                     default:
 325:                         error("Cannot write %ss with two write widths", clnames[typ]);
 326:                         continue;
 327:                     }
 328:                 }
 329:                 /*
 330: 				 * Evaluate first format spec
 331: 				 */
 332:                 if (al->wexpr_node.expr2 != TR_NIL) {
 333:                     if ( constval(al->wexpr_node.expr2)
 334:                         && isa( con.ctype , "i" ) ) {
 335:                         fmtspec += CONWIDTH;
 336:                         field = con.crval;
 337:                     } else {
 338:                         fmtspec += VARWIDTH;
 339:                     }
 340:                 }
 341:                 if ((fmtspec & CONPREC) && prec < 0 ||
 342:                     (fmtspec & CONWIDTH) && field < 0) {
 343:                     error("Negative widths are not allowed");
 344:                     continue;
 345:                 }
 346:                 if ( opt('s') &&
 347:                     ((fmtspec & CONPREC) && prec == 0 ||
 348:                     (fmtspec & CONWIDTH) && field == 0)) {
 349:                     standard();
 350:                     error("Zero widths are non-standard");
 351:                 }
 352:             }
 353:             if (filetype != nl+T1CHAR) {
 354:                 if (fmt == 'O' || fmt == 'X') {
 355:                     error("Oct/hex allowed only on text files");
 356:                     continue;
 357:                 }
 358:                 if (fmtspec) {
 359:                     error("Write widths allowed only on text files");
 360:                     continue;
 361:                 }
 362:                 /*
 363: 				 * Generalized write, i.e.
 364: 				 * to a non-textfile.
 365: 				 */
 366:                 putleaf( PCC_ICON , 0 , 0
 367:                     , (int) (PCCM_ADDTYPE(
 368:                     PCCM_ADDTYPE(
 369:                         PCCM_ADDTYPE( p2type( filetype )
 370:                             , PCCTM_PTR )
 371:                         , PCCTM_FTN )
 372:                     , PCCTM_PTR ))
 373:                     , "_FNIL" );
 374:                 (void) stklval(file, NOFLAGS);
 375:                 putop( PCC_CALL
 376:                     , PCCM_ADDTYPE( p2type( filetype ) , PCCTM_PTR ) );
 377:                 putop( PCCOM_UNARY PCC_MUL , p2type( filetype ) );
 378:                 /*
 379: 				 * file^ := ...
 380: 				 */
 381:                 switch ( classify( filetype ) ) {
 382:                     case TBOOL:
 383:                     case TCHAR:
 384:                     case TINT:
 385:                     case TSCAL:
 386:                     precheck( filetype , "_RANG4"  , "_RSNG4" );
 387:                         /* and fall through */
 388:                     case TDOUBLE:
 389:                     case TPTR:
 390:                     ap = rvalue( argv->list_node.list , filetype , RREQ );
 391:                     break;
 392:                     default:
 393:                     ap = rvalue( argv->list_node.list , filetype , LREQ );
 394:                     break;
 395:                 }
 396:                 if (ap == NIL)
 397:                     continue;
 398:                 if (incompat(ap, filetype, argv->list_node.list)) {
 399:                     cerror("Type mismatch in write to non-text file");
 400:                     continue;
 401:                 }
 402:                 switch ( classify( filetype ) ) {
 403:                     case TBOOL:
 404:                     case TCHAR:
 405:                     case TINT:
 406:                     case TSCAL:
 407:                         postcheck(filetype, ap);
 408:                         sconv(p2type(ap), p2type(filetype));
 409:                         /* and fall through */
 410:                     case TDOUBLE:
 411:                     case TPTR:
 412:                         putop( PCC_ASSIGN , p2type( filetype ) );
 413:                         putdot( filename , line );
 414:                         break;
 415:                     default:
 416:                         putstrop(PCC_STASG,
 417:                             PCCM_ADDTYPE(p2type(filetype),
 418:                                 PCCTM_PTR),
 419:                             (int) lwidth(filetype),
 420:                             align(filetype));
 421:                         putdot( filename , line );
 422:                         break;
 423:                 }
 424:                 /*
 425: 				 * put(file)
 426: 				 */
 427:                 putleaf( PCC_ICON , 0 , 0
 428:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 429:                     , "_PUT" );
 430:                 putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
 431:                     PCCTM_PTR|PCCT_STRTY );
 432:                 putop( PCC_CALL , PCCT_INT );
 433:                 putdot( filename , line );
 434:                 continue;
 435:             }
 436:             /*
 437: 			 * Write to a textfile
 438: 			 *
 439: 			 * Evaluate the expression
 440: 			 * to be written.
 441: 			 */
 442:             if (fmt == 'O' || fmt == 'X') {
 443:                 if (opt('s')) {
 444:                     standard();
 445:                     error("Oct and hex are non-standard");
 446:                 }
 447:                 if (typ == TSTR || typ == TDOUBLE) {
 448:                     error("Can't write %ss with oct/hex", clnames[typ]);
 449:                     continue;
 450:                 }
 451:                 if (typ == TCHAR || typ == TBOOL)
 452:                     typ = TINT;
 453:             }
 454:             /*
 455: 			 * If there is no format specified by the programmer,
 456: 			 * implement the default.
 457: 			 */
 458:             switch (typ) {
 459:             case TPTR:
 460:                 warning();
 461:                 if (opt('s')) {
 462:                     standard();
 463:                 }
 464:                 error("Writing %ss to text files is non-standard",
 465:                     clnames[typ]);
 466:                 /* and fall through */
 467:             case TINT:
 468:                 if (fmt == 'f') {
 469:                     typ = TDOUBLE;
 470:                     goto tdouble;
 471:                 }
 472:                 if (fmtspec == NIL) {
 473:                     if (fmt == 'D')
 474:                         field = 10;
 475:                     else if (fmt == 'X')
 476:                         field = 8;
 477:                     else if (fmt == 'O')
 478:                         field = 11;
 479:                     else
 480:                         panic("fmt1");
 481:                     fmtspec = CONWIDTH;
 482:                 }
 483:                 break;
 484:             case TCHAR:
 485:                  tchar:
 486:                 fmt = 'c';
 487:                 break;
 488:             case TSCAL:
 489:                 warning();
 490:                 if (opt('s')) {
 491:                     standard();
 492:                 }
 493:                 error("Writing %ss to text files is non-standard",
 494:                     clnames[typ]);
 495:             case TBOOL:
 496:                 fmt = 's';
 497:                 break;
 498:             case TDOUBLE:
 499:                  tdouble:
 500:                 switch (fmtspec) {
 501:                 case NIL:
 502:                     field = 14 + (5 + EXPOSIZE);
 503:                         prec = field - (5 + EXPOSIZE);
 504:                     fmt = 'e';
 505:                     fmtspec = CONWIDTH + CONPREC;
 506:                     break;
 507:                 case CONWIDTH:
 508:                     field -= REALSPC;
 509:                     if (field < 1)
 510:                         field = 1;
 511:                         prec = field - (5 + EXPOSIZE);
 512:                     if (prec < 1)
 513:                         prec = 1;
 514:                     fmtspec += CONPREC;
 515:                     fmt = 'e';
 516:                     break;
 517:                 case VARWIDTH:
 518:                     fmtspec += VARPREC;
 519:                     fmt = 'e';
 520:                     break;
 521:                 case CONWIDTH + CONPREC:
 522:                 case CONWIDTH + VARPREC:
 523:                     field -= REALSPC;
 524:                     if (field < 1)
 525:                         field = 1;
 526:                 }
 527:                 format[0] = ' ';
 528:                 fmtstart = 1 - REALSPC;
 529:                 break;
 530:             case TSTR:
 531:                 (void) constval( alv );
 532:                 switch ( classify( con.ctype ) ) {
 533:                     case TCHAR:
 534:                     typ = TCHAR;
 535:                     goto tchar;
 536:                     case TSTR:
 537:                     strptr = con.cpval;
 538:                     for (strnglen = 0;  *strptr++;  strnglen++) /* void */;
 539:                     strptr = con.cpval;
 540:                     break;
 541:                     default:
 542:                     strnglen = width(ap);
 543:                     break;
 544:                 }
 545:                 fmt = 's';
 546:                 strfmt = fmtspec;
 547:                 if (fmtspec == NIL) {
 548:                     fmtspec = SKIP;
 549:                     break;
 550:                 }
 551:                 if (fmtspec & CONWIDTH) {
 552:                     if (field <= strnglen)
 553:                         fmtspec = SKIP;
 554:                     else
 555:                         field -= strnglen;
 556:                 }
 557:                 break;
 558:             default:
 559:                 error("Can't write %ss to a text file", clnames[typ]);
 560:                 continue;
 561:             }
 562:             /*
 563: 			 * Generate the format string
 564: 			 */
 565:             switch (fmtspec) {
 566:             default:
 567:                 panic("fmt2");
 568:             case NIL:
 569:                 if (fmt == 'c') {
 570:                     if ( opt( 't' ) ) {
 571:                         putleaf( PCC_ICON , 0 , 0
 572:                         , PCCM_ADDTYPE( PCCTM_FTN|PCCT_INT , PCCTM_PTR )
 573:                         , "_WRITEC" );
 574:                         putRV((char *) 0 , cbn , CURFILEOFFSET ,
 575:                             NLOCAL , PCCTM_PTR|PCCT_STRTY );
 576:                         (void) stkrval( alv , NLNIL , (long) RREQ );
 577:                         putop( PCC_CM , PCCT_INT );
 578:                     } else {
 579:                         putleaf( PCC_ICON , 0 , 0
 580:                         , PCCM_ADDTYPE( PCCTM_FTN|PCCT_INT , PCCTM_PTR )
 581:                         , "_fputc" );
 582:                         (void) stkrval( alv , NLNIL ,
 583:                             (long) RREQ );
 584:                     }
 585:                     putleaf( PCC_ICON , 0 , 0
 586:                         , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 587:                         , "_ACTFILE" );
 588:                     putRV((char *) 0, cbn , CURFILEOFFSET ,
 589:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 590:                     putop( PCC_CALL , PCCT_INT );
 591:                     putop( PCC_CM , PCCT_INT );
 592:                     putop( PCC_CALL , PCCT_INT );
 593:                     putdot( filename , line );
 594:                 } else  {
 595:                     sprintf(&format[1], "%%%c", fmt);
 596:                     goto fmtgen;
 597:                 }
 598:             case SKIP:
 599:                 break;
 600:             case CONWIDTH:
 601:                 sprintf(&format[1], "%%%1D%c", field, fmt);
 602:                 goto fmtgen;
 603:             case VARWIDTH:
 604:                 sprintf(&format[1], "%%*%c", fmt);
 605:                 goto fmtgen;
 606:             case CONWIDTH + CONPREC:
 607:                 sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt);
 608:                 goto fmtgen;
 609:             case CONWIDTH + VARPREC:
 610:                 sprintf(&format[1], "%%%1D.*%c", field, fmt);
 611:                 goto fmtgen;
 612:             case VARWIDTH + CONPREC:
 613:                 sprintf(&format[1], "%%*.%1D%c", prec, fmt);
 614:                 goto fmtgen;
 615:             case VARWIDTH + VARPREC:
 616:                 sprintf(&format[1], "%%*.*%c", fmt);
 617:             fmtgen:
 618:                 if ( opt( 't' ) ) {
 619:                     putleaf( PCC_ICON , 0 , 0
 620:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 621:                     , "_WRITEF" );
 622:                     putRV((char *) 0 , cbn , CURFILEOFFSET ,
 623:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 624:                     putleaf( PCC_ICON , 0 , 0
 625:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 626:                     , "_ACTFILE" );
 627:                     putRV((char *) 0 , cbn , CURFILEOFFSET ,
 628:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 629:                     putop( PCC_CALL , PCCT_INT );
 630:                     putop( PCC_CM , PCCT_INT );
 631:                 } else {
 632:                     putleaf( PCC_ICON , 0 , 0
 633:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 634:                     , "_fprintf" );
 635:                     putleaf( PCC_ICON , 0 , 0
 636:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 637:                     , "_ACTFILE" );
 638:                     putRV((char *) 0 , cbn , CURFILEOFFSET ,
 639:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 640:                     putop( PCC_CALL , PCCT_INT );
 641:                 }
 642:                 putCONG( &format[ fmtstart ]
 643:                     , strlen( &format[ fmtstart ] )
 644:                     , LREQ );
 645:                 putop( PCC_CM , PCCT_INT );
 646:                 if ( fmtspec & VARWIDTH ) {
 647:                     /*
 648: 					 * either
 649: 					 *	,(temp=width,MAX(temp,...)),
 650: 					 * or
 651: 					 *	, MAX( width , ... ) ,
 652: 					 */
 653:                     if ( ( typ == TDOUBLE &&
 654:                         al->wexpr_node.expr3 == TR_NIL )
 655:                     || typ == TSTR ) {
 656:                     soffset_flag = TRUE;
 657:                     soffset = sizes[cbn].curtmps;
 658:                     tempnlp = tmpalloc((long) (sizeof(long)),
 659:                         nl+T4INT, REGOK);
 660:                     putRV((char *) 0 , cbn ,
 661:                         tempnlp -> value[ NL_OFFS ] ,
 662:                         tempnlp -> extra_flags , PCCT_INT );
 663:                     ap = stkrval( al->wexpr_node.expr2 ,
 664:                         NLNIL , (long) RREQ );
 665:                     putop( PCC_ASSIGN , PCCT_INT );
 666:                     putleaf( PCC_ICON , 0 , 0
 667:                         , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 668:                         , "_MAX" );
 669:                     putRV((char *) 0 , cbn ,
 670:                         tempnlp -> value[ NL_OFFS ] ,
 671:                         tempnlp -> extra_flags , PCCT_INT );
 672:                     } else {
 673:                     if (opt('t')
 674:                         || typ == TSTR || typ == TDOUBLE) {
 675:                         putleaf( PCC_ICON , 0 , 0
 676:                         ,PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT, PCCTM_PTR )
 677:                         ,"_MAX" );
 678:                     }
 679:                     ap = stkrval( al->wexpr_node.expr2,
 680:                         NLNIL , (long) RREQ );
 681:                     }
 682:                     if (ap == NLNIL)
 683:                         continue;
 684:                     if (isnta(ap,"i")) {
 685:                         error("First write width must be integer, not %s", nameof(ap));
 686:                         continue;
 687:                     }
 688:                     switch ( typ ) {
 689:                     case TDOUBLE:
 690:                     putleaf( PCC_ICON , REALSPC , 0 , PCCT_INT , (char *) 0 );
 691:                     putop( PCC_CM , PCCT_INT );
 692:                     putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
 693:                     putop( PCC_CM , PCCT_INT );
 694:                     putop( PCC_CALL , PCCT_INT );
 695:                     if ( al->wexpr_node.expr3 == TR_NIL ) {
 696:                         /*
 697: 						 * finish up the comma op
 698: 						 */
 699:                         putop( PCC_COMOP , PCCT_INT );
 700:                         fmtspec &= ~VARPREC;
 701:                         putop( PCC_CM , PCCT_INT );
 702:                         putleaf( PCC_ICON , 0 , 0
 703:                         , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 704:                         , "_MAX" );
 705:                         putRV((char *) 0 , cbn ,
 706:                         tempnlp -> value[ NL_OFFS ] ,
 707:                         tempnlp -> extra_flags ,
 708:                         PCCT_INT );
 709:                         putleaf( PCC_ICON ,
 710:                         5 + EXPOSIZE + REALSPC ,
 711:                         0 , PCCT_INT , (char *) 0 );
 712:                         putop( PCC_CM , PCCT_INT );
 713:                         putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
 714:                         putop( PCC_CM , PCCT_INT );
 715:                         putop( PCC_CALL , PCCT_INT );
 716:                     }
 717:                     putop( PCC_CM , PCCT_INT );
 718:                     break;
 719:                     case TSTR:
 720:                     putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 );
 721:                     putop( PCC_CM , PCCT_INT );
 722:                     putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
 723:                     putop( PCC_CM , PCCT_INT );
 724:                     putop( PCC_CALL , PCCT_INT );
 725:                     putop( PCC_COMOP , PCCT_INT );
 726:                     putop( PCC_CM , PCCT_INT );
 727:                     break;
 728:                     default:
 729:                     if (opt('t')) {
 730:                         putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
 731:                         putop( PCC_CM , PCCT_INT );
 732:                         putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
 733:                         putop( PCC_CM , PCCT_INT );
 734:                         putop( PCC_CALL , PCCT_INT );
 735:                     }
 736:                     putop( PCC_CM , PCCT_INT );
 737:                     break;
 738:                     }
 739:                 }
 740:                 /*
 741: 				 * If there is a variable precision,
 742: 				 * evaluate it
 743: 				 */
 744:                 if (fmtspec & VARPREC) {
 745:                     if (opt('t')) {
 746:                     putleaf( PCC_ICON , 0 , 0
 747:                         , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 748:                         , "_MAX" );
 749:                     }
 750:                     ap = stkrval( al->wexpr_node.expr3 ,
 751:                         NLNIL , (long) RREQ );
 752:                     if (ap == NIL)
 753:                         continue;
 754:                     if (isnta(ap,"i")) {
 755:                         error("Second write width must be integer, not %s", nameof(ap));
 756:                         continue;
 757:                     }
 758:                     if (opt('t')) {
 759:                         putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
 760:                         putop( PCC_CM , PCCT_INT );
 761:                         putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
 762:                         putop( PCC_CM , PCCT_INT );
 763:                         putop( PCC_CALL , PCCT_INT );
 764:                     }
 765:                     putop( PCC_CM , PCCT_INT );
 766:                 }
 767:                 /*
 768: 				 * evaluate the thing we want printed.
 769: 				 */
 770:                 switch ( typ ) {
 771:                 case TPTR:
 772:                 case TCHAR:
 773:                 case TINT:
 774:                     (void) stkrval( alv , NLNIL , (long) RREQ );
 775:                     putop( PCC_CM , PCCT_INT );
 776:                     break;
 777:                 case TDOUBLE:
 778:                     ap = stkrval( alv , NLNIL , (long) RREQ );
 779:                     if (isnta(ap, "d")) {
 780:                     sconv(p2type(ap), PCCT_DOUBLE);
 781:                     }
 782:                     putop( PCC_CM , PCCT_INT );
 783:                     break;
 784:                 case TSCAL:
 785:                 case TBOOL:
 786:                     putleaf( PCC_ICON , 0 , 0
 787:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 788:                     , "_NAM" );
 789:                     ap = stkrval( alv , NLNIL , (long) RREQ );
 790:                     sprintf( format , PREFIXFORMAT , LABELPREFIX
 791:                         , listnames( ap ) );
 792:                     putleaf( PCC_ICON , 0 , 0 ,
 793:                     (int) (PCCTM_PTR | PCCT_CHAR), format );
 794:                     putop( PCC_CM , PCCT_INT );
 795:                     putop( PCC_CALL , PCCT_INT );
 796:                     putop( PCC_CM , PCCT_INT );
 797:                     break;
 798:                 case TSTR:
 799:                     putCONG( "" , 0 , LREQ );
 800:                     putop( PCC_CM , PCCT_INT );
 801:                     break;
 802:                 default:
 803:                     panic("fmt3");
 804:                     break;
 805:                 }
 806:                 putop( PCC_CALL , PCCT_INT );
 807:                 putdot( filename , line );
 808:             }
 809:             /*
 810: 			 * Write the string after its blank padding
 811: 			 */
 812:             if (typ == TSTR ) {
 813:                 if ( opt( 't' ) ) {
 814:                     putleaf( PCC_ICON , 0 , 0
 815:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 816:                     , "_WRITES" );
 817:                     putRV((char *) 0 , cbn , CURFILEOFFSET ,
 818:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 819:                     ap = stkrval(alv, NLNIL , (long) RREQ );
 820:                     putop( PCC_CM , PCCT_INT );
 821:                 } else {
 822:                     putleaf( PCC_ICON , 0 , 0
 823:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 824:                     , "_fwrite" );
 825:                     ap = stkrval(alv, NLNIL , (long) RREQ );
 826:                 }
 827:                 if (strfmt & VARWIDTH) {
 828:                         /*
 829: 					     *	min, inline expanded as
 830: 					     *	temp < len ? temp : len
 831: 					     */
 832:                     putRV((char *) 0 , cbn ,
 833:                         tempnlp -> value[ NL_OFFS ] ,
 834:                         tempnlp -> extra_flags , PCCT_INT );
 835:                     putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 );
 836:                     putop( PCC_LT , PCCT_INT );
 837:                     putRV((char *) 0 , cbn ,
 838:                         tempnlp -> value[ NL_OFFS ] ,
 839:                         tempnlp -> extra_flags , PCCT_INT );
 840:                     putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 );
 841:                     putop( PCC_COLON , PCCT_INT );
 842:                     putop( PCC_QUEST , PCCT_INT );
 843:                 } else {
 844:                     if (   ( fmtspec & SKIP )
 845:                         && ( strfmt & CONWIDTH ) ) {
 846:                         strnglen = field;
 847:                     }
 848:                     putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 );
 849:                 }
 850:                 putop( PCC_CM , PCCT_INT );
 851:                 putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
 852:                 putop( PCC_CM , PCCT_INT );
 853:                 putleaf( PCC_ICON , 0 , 0
 854:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 855:                     , "_ACTFILE" );
 856:                 putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL ,
 857:                     PCCTM_PTR|PCCT_STRTY );
 858:                 putop( PCC_CALL , PCCT_INT );
 859:                 putop( PCC_CM , PCCT_INT );
 860:                 putop( PCC_CALL , PCCT_INT );
 861:                 putdot( filename , line );
 862:             }
 863:             if (soffset_flag) {
 864:                 tmpfree(&soffset);
 865:                 soffset_flag = FALSE;
 866:             }
 867:         }
 868:         /*
 869: 		 * Done with arguments.
 870: 		 * Handle writeln and
 871: 		 * insufficent number of args.
 872: 		 */
 873:         switch (p->value[0] &~ NSTAND) {
 874:             case O_WRITEF:
 875:                 if (argc == 0)
 876:                     error("Write requires an argument");
 877:                 break;
 878:             case O_MESSAGE:
 879:                 if (argc == 0)
 880:                     error("Message requires an argument");
 881:             case O_WRITLN:
 882:                 if (filetype != nl+T1CHAR)
 883:                     error("Can't 'writeln' a non text file");
 884:                 if ( opt( 't' ) ) {
 885:                     putleaf( PCC_ICON , 0 , 0
 886:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 887:                     , "_WRITLN" );
 888:                     putRV((char *) 0 , cbn , CURFILEOFFSET ,
 889:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 890:                 } else {
 891:                     putleaf( PCC_ICON , 0 , 0
 892:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 893:                     , "_fputc" );
 894:                     putleaf( PCC_ICON , '\n' , 0 , (int) PCCT_CHAR , (char *) 0 );
 895:                     putleaf( PCC_ICON , 0 , 0
 896:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 897:                     , "_ACTFILE" );
 898:                     putRV((char *) 0 , cbn , CURFILEOFFSET ,
 899:                         NLOCAL , PCCTM_PTR|PCCT_STRTY );
 900:                     putop( PCC_CALL , PCCT_INT );
 901:                     putop( PCC_CM , PCCT_INT );
 902:                 }
 903:                 putop( PCC_CALL , PCCT_INT );
 904:                 putdot( filename , line );
 905:                 break;
 906:         }
 907:         return;
 908: 
 909:     case O_READ4:
 910:     case O_READLN:
 911:         /*
 912: 		 * Set up default
 913: 		 * file "input".
 914: 		 */
 915:         file = NIL;
 916:         filetype = nl+T1CHAR;
 917:         /*
 918: 		 * Determine the file implied
 919: 		 * for the read and generate
 920: 		 * code to make it the active file.
 921: 		 */
 922:         if (argv != TR_NIL) {
 923:             codeoff();
 924:             ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
 925:             codeon();
 926:             if (ap == NLNIL)
 927:                 argv = argv->list_node.next;
 928:             if (ap != NLNIL && ap->class == FILET) {
 929:                 /*
 930: 				 * Got "read(f, ...", make
 931: 				 * f the active file, and save
 932: 				 * it and its type for use in
 933: 				 * processing the rest of the
 934: 				 * arguments to read.
 935: 				 */
 936:                 file = argv->list_node.list;
 937:                 filetype = ap->type;
 938:                 putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL ,
 939:                     PCCTM_PTR|PCCT_STRTY );
 940:                 putleaf( PCC_ICON , 0 , 0
 941:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
 942:                     , "_UNIT" );
 943:                 (void) stklval(argv->list_node.list, NOFLAGS);
 944:                 putop( PCC_CALL , PCCT_INT );
 945:                 putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 946:                 putdot( filename , line );
 947:                 argv = argv->list_node.next;
 948:                 argc--;
 949:             } else {
 950:                 /*
 951: 				 * Default is read from
 952: 				 * standard input.
 953: 				 */
 954:                 putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL ,
 955:                     PCCTM_PTR|PCCT_STRTY );
 956:                 putLV( "_input" , 0 , 0 , NGLOBAL ,
 957:                     PCCTM_PTR|PCCT_STRTY );
 958:                 putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 959:                 putdot( filename , line );
 960:                 input->nl_flags |= NUSED;
 961:             }
 962:         } else {
 963:             putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL ,
 964:                 PCCTM_PTR|PCCT_STRTY );
 965:             putLV( "_input" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY );
 966:             putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
 967:             putdot( filename , line );
 968:             input->nl_flags |= NUSED;
 969:         }
 970:         /*
 971: 		 * Loop and process each
 972: 		 * of the arguments.
 973: 		 */
 974:         for (; argv != TR_NIL; argv = argv->list_node.next) {
 975:             /*
 976: 			 * Get the address of the target
 977: 			 * on the stack.
 978: 			 */
 979:             al = argv->list_node.list;
 980:             if (al == TR_NIL)
 981:                 continue;
 982:             if (al->tag != T_VAR) {
 983:                 error("Arguments to %s must be variables, not expressions", p->symbol);
 984:                 continue;
 985:             }
 986:             codeoff();
 987:             ap = stklval(al, MOD|ASGN|NOUSE);
 988:             codeon();
 989:             if (ap == NLNIL)
 990:                 continue;
 991:             if (filetype != nl+T1CHAR) {
 992:                 /*
 993: 				 * Generalized read, i.e.
 994: 				 * from a non-textfile.
 995: 				 */
 996:                 if (incompat(filetype, ap, argv->list_node.list )) {
 997:                     error("Type mismatch in read from non-text file");
 998:                     continue;
 999:                 }
1000:                 /*
1001: 				 * var := file ^;
1002: 				 */
1003:                 ap = lvalue( al , MOD | ASGN | NOUSE , RREQ );
1004:                 if ( isa( ap , "bsci" ) ) {
1005:                     precheck( ap , "_RANG4" , "_RSNG4" );
1006:                 }
1007:                 putleaf( PCC_ICON , 0 , 0
1008:                     , (int) (PCCM_ADDTYPE(
1009:                     PCCM_ADDTYPE(
1010:                         PCCM_ADDTYPE(
1011:                         p2type( filetype ) , PCCTM_PTR )
1012:                         , PCCTM_FTN )
1013:                     , PCCTM_PTR ))
1014:                     , "_FNIL" );
1015:                 if (file != NIL)
1016:                     (void) stklval(file, NOFLAGS);
1017:                 else /* Magic */
1018:                     putRV( "_input" , 0 , 0 , NGLOBAL ,
1019:                         PCCTM_PTR | PCCT_STRTY );
1020:                 putop(PCC_CALL, PCCM_ADDTYPE(p2type(filetype), PCCTM_PTR));
1021:                 switch ( classify( filetype ) ) {
1022:                     case TBOOL:
1023:                     case TCHAR:
1024:                     case TINT:
1025:                     case TSCAL:
1026:                     case TDOUBLE:
1027:                     case TPTR:
1028:                     putop( PCCOM_UNARY PCC_MUL
1029:                         , p2type( filetype ) );
1030:                 }
1031:                 switch ( classify( filetype ) ) {
1032:                     case TBOOL:
1033:                     case TCHAR:
1034:                     case TINT:
1035:                     case TSCAL:
1036:                         postcheck(ap, filetype);
1037:                         sconv(p2type(filetype), p2type(ap));
1038:                         /* and fall through */
1039:                     case TDOUBLE:
1040:                     case TPTR:
1041:                         putop( PCC_ASSIGN , p2type( ap ) );
1042:                         putdot( filename , line );
1043:                         break;
1044:                     default:
1045:                         putstrop(PCC_STASG,
1046:                             PCCM_ADDTYPE(p2type(ap), PCCTM_PTR),
1047:                             (int) lwidth(ap),
1048:                             align(ap));
1049:                         putdot( filename , line );
1050:                         break;
1051:                 }
1052:                 /*
1053: 				 * get(file);
1054: 				 */
1055:                 putleaf( PCC_ICON , 0 , 0
1056:                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1057:                     , "_GET" );
1058:                 putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
1059:                     PCCTM_PTR|PCCT_STRTY );
1060:                 putop( PCC_CALL , PCCT_INT );
1061:                 putdot( filename , line );
1062:                 continue;
1063:             }
1064:                 /*
1065: 			     *	if you get to here, you are reading from
1066: 			     *	a text file.  only possiblities are:
1067: 			     *	character, integer, real, or scalar.
1068: 			     *	read( f , foo , ... ) is done as
1069: 			     *	foo := read( f ) with rangechecking
1070: 			     *	if appropriate.
1071: 			     */
1072:             typ = classify(ap);
1073:             op = rdops(typ);
1074:             if (op == NIL) {
1075:                 error("Can't read %ss from a text file", clnames[typ]);
1076:                 continue;
1077:             }
1078:                 /*
1079: 			     *	left hand side of foo := read( f )
1080: 			     */
1081:             ap = lvalue( al , MOD|ASGN|NOUSE , RREQ );
1082:             if ( isa( ap , "bsci" ) ) {
1083:                 precheck( ap , "_RANG4" , "_RSNG4" );
1084:             }
1085:             switch ( op ) {
1086:                 case O_READC:
1087:                 readname = "_READC";
1088:                 readtype = PCCT_INT;
1089:                 break;
1090:                 case O_READ4:
1091:                 readname = "_READ4";
1092:                 readtype = PCCT_INT;
1093:                 break;
1094:                 case O_READ8:
1095:                 readname = "_READ8";
1096:                 readtype = PCCT_DOUBLE;
1097:                 break;
1098:                 case O_READE:
1099:                 readname = "_READE";
1100:                 readtype = PCCT_INT;
1101:                 break;
1102:             }
1103:             putleaf( PCC_ICON , 0 , 0
1104:                 , (int) PCCM_ADDTYPE( PCCTM_FTN | readtype , PCCTM_PTR )
1105:                 , readname );
1106:             putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
1107:                 PCCTM_PTR|PCCT_STRTY );
1108:             if ( op == O_READE ) {
1109:                 sprintf( format , PREFIXFORMAT , LABELPREFIX
1110:                     , listnames( ap ) );
1111:                 putleaf( PCC_ICON , 0, 0, (int) (PCCTM_PTR | PCCT_CHAR),
1112:                     format );
1113:                 putop( PCC_CM , PCCT_INT );
1114:                 warning();
1115:                 if (opt('s')) {
1116:                     standard();
1117:                 }
1118:                 error("Reading scalars from text files is non-standard");
1119:             }
1120:             putop( PCC_CALL , (int) readtype );
1121:             if ( isa( ap , "bcsi" ) ) {
1122:                 postcheck(ap, readtype==PCCT_INT?nl+T4INT:nl+TDOUBLE);
1123:             }
1124:             sconv((int) readtype, p2type(ap));
1125:             putop( PCC_ASSIGN , p2type( ap ) );
1126:             putdot( filename , line );
1127:         }
1128:         /*
1129: 		 * Done with arguments.
1130: 		 * Handle readln and
1131: 		 * insufficient number of args.
1132: 		 */
1133:         if (p->value[0] == O_READLN) {
1134:             if (filetype != nl+T1CHAR)
1135:                 error("Can't 'readln' a non text file");
1136:             putleaf( PCC_ICON , 0 , 0
1137:                 , (int) PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1138:                 , "_READLN" );
1139:             putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
1140:                 PCCTM_PTR|PCCT_STRTY );
1141:             putop( PCC_CALL , PCCT_INT );
1142:             putdot( filename , line );
1143:         } else if (argc == 0)
1144:             error("read requires an argument");
1145:         return;
1146: 
1147:     case O_GET:
1148:     case O_PUT:
1149:         if (argc != 1) {
1150:             error("%s expects one argument", p->symbol);
1151:             return;
1152:         }
1153:         putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
1154:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1155:             , "_UNIT" );
1156:         ap = stklval(argv->list_node.list, NOFLAGS);
1157:         if (ap == NLNIL)
1158:             return;
1159:         if (ap->class != FILET) {
1160:             error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
1161:             return;
1162:         }
1163:         putop( PCC_CALL , PCCT_INT );
1164:         putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
1165:         putdot( filename , line );
1166:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1167:             , op == O_GET ? "_GET" : "_PUT" );
1168:         putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
1169:         putop( PCC_CALL , PCCT_INT );
1170:         putdot( filename , line );
1171:         return;
1172: 
1173:     case O_RESET:
1174:     case O_REWRITE:
1175:         if (argc == 0 || argc > 2) {
1176:             error("%s expects one or two arguments", p->symbol);
1177:             return;
1178:         }
1179:         if (opt('s') && argc == 2) {
1180:             standard();
1181:             error("Two argument forms of reset and rewrite are non-standard");
1182:         }
1183:         putleaf( PCC_ICON , 0 , 0 , PCCT_INT
1184:             , op == O_RESET ? "_RESET" : "_REWRITE" );
1185:         ap = stklval(argv->list_node.list, MOD|NOUSE);
1186:         if (ap == NLNIL)
1187:             return;
1188:         if (ap->class != FILET) {
1189:             error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
1190:             return;
1191:         }
1192:         if (argc == 2) {
1193:             /*
1194: 			 * Optional second argument
1195: 			 * is a string name of a
1196: 			 * UNIX (R) file to be associated.
1197: 			 */
1198:             al = argv->list_node.next;
1199:             al = (struct tnode *) stkrval(al->list_node.list,
1200:                     NLNIL , (long) RREQ );
1201:             if (al == TR_NIL)
1202:                 return;
1203:             if (classify((struct nl *) al) != TSTR) {
1204:                 error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al));
1205:                 return;
1206:             }
1207:             strnglen = width((struct nl *) al);
1208:         } else {
1209:             putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
1210:             strnglen = 0;
1211:         }
1212:         putop( PCC_CM , PCCT_INT );
1213:         putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 );
1214:         putop( PCC_CM , PCCT_INT );
1215:         putleaf( PCC_ICON , text(ap) ? 0: width(ap->type) , 0 , PCCT_INT , (char *) 0 );
1216:         putop( PCC_CM , PCCT_INT );
1217:         putop( PCC_CALL , PCCT_INT );
1218:         putdot( filename , line );
1219:         return;
1220: 
1221:     case O_NEW:
1222:     case O_DISPOSE:
1223:         if (argc == 0) {
1224:             error("%s expects at least one argument", p->symbol);
1225:             return;
1226:         }
1227:         alv = argv->list_node.list;
1228:         codeoff();
1229:         ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
1230:         codeon();
1231:         if (ap == NLNIL)
1232:             return;
1233:         if (ap->class != PTR) {
1234:             error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
1235:             return;
1236:         }
1237:         ap = ap->type;
1238:         if (ap == NLNIL)
1239:             return;
1240:         if (op == O_NEW)
1241:             cmd = "_NEW";
1242:         else /* op == O_DISPOSE */
1243:             if ((ap->nl_flags & NFILES) != 0)
1244:                 cmd = "_DFDISPOSE";
1245:             else
1246:                 cmd = "_DISPOSE";
1247:         putleaf( PCC_ICON, 0, 0, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ), cmd);
1248:         (void) stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
1249:         argv = argv->list_node.next;
1250:         if (argv != TR_NIL) {
1251:             if (ap->class != RECORD) {
1252:                 error("Record required when specifying variant tags");
1253:                 return;
1254:             }
1255:             for (; argv != TR_NIL; argv = argv->list_node.next) {
1256:                 if (ap->ptr[NL_VARNT] == NIL) {
1257:                     error("Too many tag fields");
1258:                     return;
1259:                 }
1260:                 if (!isconst(argv->list_node.list)) {
1261:                     error("Second and successive arguments to %s must be constants", p->symbol);
1262:                     return;
1263:                 }
1264:                 gconst(argv->list_node.list);
1265:                 if (con.ctype == NIL)
1266:                     return;
1267:                 if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , TR_NIL )) {
1268:                     cerror("Specified tag constant type clashed with variant case selector type");
1269:                     return;
1270:                 }
1271:                 for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
1272:                     if (ap->range[0] == con.crval)
1273:                         break;
1274:                 if (ap == NIL) {
1275:                     error("No variant case label value equals specified constant value");
1276:                     return;
1277:                 }
1278:                 ap = ap->ptr[NL_VTOREC];
1279:             }
1280:         }
1281:         putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
1282:         putop( PCC_CM , PCCT_INT );
1283:         putop( PCC_CALL , PCCT_INT );
1284:         putdot( filename , line );
1285:         if (opt('t') && op == O_NEW) {
1286:             putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1287:                 , "_blkclr" );
1288:             (void) stkrval(alv, NLNIL , (long) RREQ );
1289:             putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
1290:             putop( PCC_CM , PCCT_INT );
1291:             putop( PCC_CALL , PCCT_INT );
1292:             putdot( filename , line );
1293:         }
1294:         return;
1295: 
1296:     case O_DATE:
1297:     case O_TIME:
1298:         if (argc != 1) {
1299:             error("%s expects one argument", p->symbol);
1300:             return;
1301:         }
1302:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1303:             , op == O_DATE ? "_DATE" : "_TIME" );
1304:         ap = stklval(argv->list_node.list, MOD|NOUSE);
1305:         if (ap == NIL)
1306:             return;
1307:         if (classify(ap) != TSTR || width(ap) != 10) {
1308:             error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
1309:             return;
1310:         }
1311:         putop( PCC_CALL , PCCT_INT );
1312:         putdot( filename , line );
1313:         return;
1314: 
1315:     case O_HALT:
1316:         if (argc != 0) {
1317:             error("halt takes no arguments");
1318:             return;
1319:         }
1320:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1321:             , "_HALT" );
1322: 
1323:         putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
1324:         putdot( filename , line );
1325:         noreach = TRUE;
1326:         return;
1327: 
1328:     case O_ARGV:
1329:         if (argc != 2) {
1330:             error("argv takes two arguments");
1331:             return;
1332:         }
1333:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1334:             , "_ARGV" );
1335:         ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
1336:         if (ap == NLNIL)
1337:             return;
1338:         if (isnta(ap, "i")) {
1339:             error("argv's first argument must be an integer, not %s", nameof(ap));
1340:             return;
1341:         }
1342:         al = argv->list_node.next;
1343:         ap = stklval(al->list_node.list, MOD|NOUSE);
1344:         if (ap == NLNIL)
1345:             return;
1346:         if (classify(ap) != TSTR) {
1347:             error("argv's second argument must be a string, not %s", nameof(ap));
1348:             return;
1349:         }
1350:         putop( PCC_CM , PCCT_INT );
1351:         putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
1352:         putop( PCC_CM , PCCT_INT );
1353:         putop( PCC_CALL , PCCT_INT );
1354:         putdot( filename , line );
1355:         return;
1356: 
1357:     case O_STLIM:
1358:         if (argc != 1) {
1359:             error("stlimit requires one argument");
1360:             return;
1361:         }
1362:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1363:             , "_STLIM" );
1364:         ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
1365:         if (ap == NLNIL)
1366:             return;
1367:         if (isnta(ap, "i")) {
1368:             error("stlimit's argument must be an integer, not %s", nameof(ap));
1369:             return;
1370:         }
1371:         putop( PCC_CALL , PCCT_INT );
1372:         putdot( filename , line );
1373:         return;
1374: 
1375:     case O_REMOVE:
1376:         if (argc != 1) {
1377:             error("remove expects one argument");
1378:             return;
1379:         }
1380:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1381:             , "_REMOVE" );
1382:         ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
1383:         if (ap == NLNIL)
1384:             return;
1385:         if (classify(ap) != TSTR) {
1386:             error("remove's argument must be a string, not %s", nameof(ap));
1387:             return;
1388:         }
1389:         putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
1390:         putop( PCC_CM , PCCT_INT );
1391:         putop( PCC_CALL , PCCT_INT );
1392:         putdot( filename , line );
1393:         return;
1394: 
1395:     case O_LLIMIT:
1396:         if (argc != 2) {
1397:             error("linelimit expects two arguments");
1398:             return;
1399:         }
1400:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1401:             , "_LLIMIT" );
1402:         ap = stklval(argv->list_node.list, NOFLAGS|NOUSE);
1403:         if (ap == NLNIL)
1404:             return;
1405:         if (!text(ap)) {
1406:             error("linelimit's first argument must be a text file, not %s", nameof(ap));
1407:             return;
1408:         }
1409:         al = argv->list_node.next;
1410:         ap = stkrval(al->list_node.list, NLNIL , (long) RREQ );
1411:         if (ap == NLNIL)
1412:             return;
1413:         if (isnta(ap, "i")) {
1414:             error("linelimit's second argument must be an integer, not %s", nameof(ap));
1415:             return;
1416:         }
1417:         putop( PCC_CM , PCCT_INT );
1418:         putop( PCC_CALL , PCCT_INT );
1419:         putdot( filename , line );
1420:         return;
1421:     case O_PAGE:
1422:         if (argc != 1) {
1423:             error("page expects one argument");
1424:             return;
1425:         }
1426:         putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
1427:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1428:             , "_UNIT" );
1429:         ap = stklval(argv->list_node.list, NOFLAGS);
1430:         if (ap == NLNIL)
1431:             return;
1432:         if (!text(ap)) {
1433:             error("Argument to page must be a text file, not %s", nameof(ap));
1434:             return;
1435:         }
1436:         putop( PCC_CALL , PCCT_INT );
1437:         putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
1438:         putdot( filename , line );
1439:         if ( opt( 't' ) ) {
1440:             putleaf( PCC_ICON , 0 , 0
1441:             , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1442:             , "_PAGE" );
1443:             putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
1444:         } else {
1445:             putleaf( PCC_ICON , 0 , 0
1446:             , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1447:             , "_fputc" );
1448:             putleaf( PCC_ICON , '\f' , 0 , (int) PCCT_CHAR , (char *) 0 );
1449:             putleaf( PCC_ICON , 0 , 0
1450:             , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1451:             , "_ACTFILE" );
1452:             putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
1453:             putop( PCC_CALL , PCCT_INT );
1454:             putop( PCC_CM , PCCT_INT );
1455:         }
1456:         putop( PCC_CALL , PCCT_INT );
1457:         putdot( filename , line );
1458:         return;
1459: 
1460:     case O_ASRT:
1461:         if (!opt('t'))
1462:             return;
1463:         if (argc == 0 || argc > 2) {
1464:             error("Assert expects one or two arguments");
1465:             return;
1466:         }
1467:         if (argc == 2)
1468:             cmd = "_ASRTS";
1469:         else
1470:             cmd = "_ASRT";
1471:         putleaf( PCC_ICON , 0 , 0
1472:             , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , cmd );
1473:         ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
1474:         if (ap == NLNIL)
1475:             return;
1476:         if (isnta(ap, "b"))
1477:             error("Assert expression must be Boolean, not %ss", nameof(ap));
1478:         if (argc == 2) {
1479:             /*
1480: 			 * Optional second argument is a string specifying
1481: 			 * why the assertion failed.
1482: 			 */
1483:             al = argv->list_node.next;
1484:             al = (struct tnode *) stkrval(al->list_node.list, NLNIL , (long) RREQ );
1485:             if (al == TR_NIL)
1486:                 return;
1487:             if (classify((struct nl *) al) != TSTR) {
1488:                 error("Second argument to assert must be a string, not %s", nameof((struct nl *) al));
1489:                 return;
1490:             }
1491:             putop( PCC_CM , PCCT_INT );
1492:         }
1493:         putop( PCC_CALL , PCCT_INT );
1494:         putdot( filename , line );
1495:         return;
1496: 
1497:     case O_PACK:
1498:         if (argc != 3) {
1499:             error("pack expects three arguments");
1500:             return;
1501:         }
1502:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1503:             , "_PACK" );
1504:         pu = "pack(a,i,z)";
1505:         pua = (al = argv)->list_node.list;
1506:         pui = (al = al->list_node.next)->list_node.list;
1507:         puz = (al = al->list_node.next)->list_node.list;
1508:         goto packunp;
1509:     case O_UNPACK:
1510:         if (argc != 3) {
1511:             error("unpack expects three arguments");
1512:             return;
1513:         }
1514:         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
1515:             , "_UNPACK" );
1516:         pu = "unpack(z,a,i)";
1517:         puz = (al = argv)->list_node.list;
1518:         pua = (al = al->list_node.next)->list_node.list;
1519:         pui = (al = al->list_node.next)->list_node.list;
1520: packunp:
1521:         ap = stkrval(pui, NLNIL , (long) RREQ );
1522:         if (ap == NIL)
1523:             return;
1524:         ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
1525:         if (ap == NIL)
1526:             return;
1527:         if (ap->class != ARRAY) {
1528:             error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
1529:             return;
1530:         }
1531:         putop( PCC_CM , PCCT_INT );
1532:         al = (struct tnode *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
1533:         if (((struct nl *) al)->class != ARRAY) {
1534:             error("%s requires z to be a packed array, not %s", pu, nameof(ap));
1535:             return;
1536:         }
1537:         if (((struct nl *) al)->type == NIL ||
1538:             ((struct nl *) ap)->type == NIL)
1539:             return;
1540:         if (((struct nl *) al)->type != ((struct nl *) ap)->type) {
1541:             error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
1542:             return;
1543:         }
1544:         putop( PCC_CM , PCCT_INT );
1545:         k = width((struct nl *) al);
1546:         itemwidth = width(ap->type);
1547:         ap = ap->chain;
1548:         al = ((struct tnode *) ((struct nl *) al)->chain);
1549:         if (ap->chain != NIL || ((struct nl *) al)->chain != NIL) {
1550:             error("%s requires a and z to be single dimension arrays", pu);
1551:             return;
1552:         }
1553:         if (ap == NIL || al == NIL)
1554:             return;
1555:         /*
1556: 		 * al is the range for z i.e. u..v
1557: 		 * ap is the range for a i.e. m..n
1558: 		 * i will be n-m+1
1559: 		 * j will be v-u+1
1560: 		 */
1561:         i = ap->range[1] - ap->range[0] + 1;
1562:         j = ((struct nl *) al)->range[1] -
1563:             ((struct nl *) al)->range[0] + 1;
1564:         if (i < j) {
1565:             error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i);
1566:             return;
1567:         }
1568:         /*
1569: 		 * get n-m-(v-u) and m for the interpreter
1570: 		 */
1571:         i -= j;
1572:         j = ap->range[0];
1573:         putleaf( PCC_ICON , itemwidth , 0 , PCCT_INT , (char *) 0 );
1574:         putop( PCC_CM , PCCT_INT );
1575:         putleaf( PCC_ICON , j , 0 , PCCT_INT , (char *) 0 );
1576:         putop( PCC_CM , PCCT_INT );
1577:         putleaf( PCC_ICON , i , 0 , PCCT_INT , (char *) 0 );
1578:         putop( PCC_CM , PCCT_INT );
1579:         putleaf( PCC_ICON , k , 0 , PCCT_INT , (char *) 0 );
1580:         putop( PCC_CM , PCCT_INT );
1581:         putop( PCC_CALL , PCCT_INT );
1582:         putdot( filename , line );
1583:         return;
1584:     case 0:
1585:         error("%s is an unimplemented extension", p->symbol);
1586:         return;
1587: 
1588:     default:
1589:         panic("proc case");
1590:     }
1591: }
1592: #endif PC

Defined functions

pcproc defined in line 66; used 1 times

Defined variables

rdxxxx defined in line 45; used 1 times
  • in line 43
sccsid defined in line 8; never used

Defined macros

CONPREC defined in line 87; used 5 times
CONWIDTH defined in line 89; used 11 times
EXPOSIZE defined in line 36; used 4 times
REALSPC defined in line 37; used 5 times
SKIP defined in line 91; used 3 times
VARPREC defined in line 88; used 4 times
VARWIDTH defined in line 90; used 5 times
rdops defined in line 43; used 1 times
Last modified: 1985-06-22
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 4714
Valid CSS Valid XHTML 1.0 Strict