# 2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/pcproc.c

##### Functions

    pcproc            X

##### Variables

    rdxxxx            X

##### Macros

    CONPREC           X
    CONWIDTH          X
    EXPOSIZE          X
    REALSPC           X
    SKIP              X
    VARPREC           X
    VARWIDTH          X
    rdops             X

       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

- in /usr/src/ucb/PORT/pascal/src/stat.c line 78

#### 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

- in line 309, 341, 347, 505, 514

CONWIDTH defined in line 89; used 11 times

- in line 335, 342, 348, 481, 505, 521-522(2), 551, 606-609(2), 845

EXPOSIZE defined in line 36; used 4 times

- in line 502-503(2), 511, 710

REALSPC defined in line 37; used 5 times

- in line 508, 523-528(2), 690, 710

SKIP defined in line 91; used 3 times

- in line 548-553(2), 844

VARPREC defined in line 88; used 4 times

- in line 312, 518, 700, 744

VARWIDTH defined in line 90; used 5 times

- in line 338, 612-615(2), 646, 827

rdops defined in line 43; used 1 times

- in line 1073

Last modified: 1985-06-22 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 4797 |