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