//! @file transput.c
//! @author J. Marcel van der Veer
//
//! @section Copyright
//
// This file is part of VIF - vintage FORTRAN compiler.
// Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
//
//! @section License
//
// This program is free software; you can redistribute it and/or modify it 
// under the terms of the GNU General Public License as published by the 
// Free Software Foundation; either version 3 of the License, or 
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful, but 
// WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
// or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
// more details. You should have received a copy of the GNU General Public 
// License along with this program. If not, see <http://www.gnu.org/licenses/>.

//! @section Synopsis
//!
//! Compile Fortran IO.

#include <vif.h>

static char *unum (EXPR *unit)
{
  if (unit->mode.type == INTEGER) {
    return unit->str;
  } else {
    return "0";
  }
}

void save_iostat (char *iostat)
{
  if (iostat != NO_TEXT) {
    EXPR loc; 
    NEW_RECORD (ios);
    NEW_RECORD (str);
    MODE mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
    _srecordf (ios, "%s", iostat);
    RECCLR (loc.str);
    factor_variable (&loc, NULL, &mode, ios);
    if (loc.mode.type == mode.type && loc.mode.len == mode.len) {
      _srecordf (str, "%s_ = errno;\n", loc.str);
      code (nprocs, BODY, str);
    } else {
      MODE_ERROR (3301, qtype (&(loc.mode)), qtype (&mode));
    }
  }
}

void io_event (char *proc, EXPR *unit, char *iorc, LBL *endlbl, LBL *errlbl)
{
  if (EQUAL (proc, "write")) {
    NEW_RECORD (str);
    if (errlbl == NO_LABEL) {
      _srecordf (str, "_write_err (%s, %s, _ioerr_%s (\"%s\", %s));\n", iorc, unum (unit), proc, stat_start, unum (unit));
    } else {
      _srecordf (str, "_write_err (%s, %s, goto _l%d);\n", iorc, unum (unit), errlbl->num);
    }
    code (nprocs, BODY, str);
  } else if (EQUAL (proc, "read")) {
    NEW_RECORD (str1);
    NEW_RECORD (str2);
    NEW_RECORD (str);
    if (endlbl == NO_LABEL) {
      _srecordf (str1, "_ioend_%s (\"%s\", %s)", proc, stat_start, unum (unit));
    } else {
      _srecordf (str1, "goto _l%d", endlbl->num);
    }
    if (errlbl == NO_LABEL) {
      _srecordf (str2, "_ioerr_%s (\"%s\", %s)", proc, stat_start, unum (unit));
    } else {
      _srecordf (str2, "goto _l%d", errlbl->num);
    }
    _srecordf (str, "_read_err (%s, %s, %s, %s);\n", iorc, unum (unit), str1, str2);
    code (nprocs, BODY, str);
  } else {
    BUG ("io_event");
  }
}

void io_parm (EXPR *reg, char *elem)
{
  if (reg->variant == EXPR_VAR) {
    if (IS_ROW (reg->mode)) {
      _srecordf (elem, "%s", reg->str);
    } else if (reg->str[0] == '*') {
      _srecordf (elem, "%s", &reg->str[1]);
    } else if (reg->mode.type == CHARACTER) {
      _srecordf (elem, "%s", reg->str);
    } else {
      (void) impl_decl (reg->str, NO_MODE);
      _srecordf (elem, "&%s", reg->str);
    }
  } else if (reg->variant == EXPR_SLICE) {
    _srecordf (elem, "&%s", reg->str);
  } else {
    NEW_RECORD (tmp);
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    if (reg->mode.type == CHARACTER) {
      norm_mode (&reg->mode);
      if (reg->mode.len == 0) {
        add_local (tmp, reg->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
        _srecordf (elem, "strcpy (%s, %s);\n", tmp, reg->str);
      } else {
        add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
        _srecordf (elem, "bufcpy (%s, %s, %d);\n", tmp, reg->str, reg->mode.len);
      }
      code (nprocs, BODY, elem);
      _srecordf (elem, "%s", tmp);
    } else {
      add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (elem, "%s = %s;\n", tmp, reg->str);
      code (nprocs, BODY, elem);
      _srecordf (elem, "&%s", tmp);
    }
  }
}

void io_text_items (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, logical_4 term)
{
  NEW_RECORD (str);
  if (EQUAL (proc, "write")) {
    _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
    code (nprocs, BODY, str);
    if (term) {
      _srecordf (str, "if (%s[%s + 2] == FMT_TERM) {\n", fstr, fid);
      code (nprocs, BODY, str);
      code (nprocs, BODY, "break;\n");
      code (nprocs, BODY, "}\n");
    }
    _srecordf (str, "%s = _vif_printf (%s, %s[%s + 2], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
    code (nprocs, BODY, str);
    io_event (proc, unit, iorc, endlbl, errlbl);
    _srecordf (str, "%s += 3;\n", fid);
    code (nprocs, BODY, str);
    code (nprocs, BODY, "}\n");
  } else if (EQUAL (proc, "read")) {
    _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
    code (nprocs, BODY, str);
    _srecordf (str, "%s = _vif_scanf (%s, %s[%s + 1], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
    code (nprocs, BODY, str);
    io_event (proc, unit, iorc, endlbl, errlbl);
    _srecordf (str, "%s += 3;\n", fid);
    code (nprocs, BODY, str);
    code (nprocs, BODY, "}\n");
  }
}

void io_format (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, char *elem, char *type, int_4 len)
{
  NEW_RECORD (str);
  if (EQUAL (proc, "write")) {
    _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
    code (nprocs, BODY, str);
    _srecordf (str, "%s = 0;\n", fid);
    code (nprocs, BODY, str);
    _srecordf (str, "%s = fprintf (_ffile[%s].unit, \"\\n\");\n", iorc, unum (unit));
    code (nprocs, BODY, str);
    io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    code (nprocs, BODY, "};\n");
    _srecordf (str, "%s = _vif_printf (%s, %s[%s + 2], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
    code (nprocs, BODY, str);
    io_event (proc, unit, iorc, endlbl, errlbl);
    _srecordf (str, "%s += 3;\n", fid);
    code (nprocs, BODY, str);
    io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, TRUE);
  } else if (EQUAL (proc, "read")) {
    _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
    code (nprocs, BODY, str);
    _srecordf (str, "%s = 0;\n", fid);
    code (nprocs, BODY, str);
    _srecordf (str, "_vif_scanf (%s, NULL, NULL, NOTYPE, 0);\n", unum (unit));
    code (nprocs, BODY, str);
    io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    code (nprocs, BODY, "};\n");
    _srecordf (str, "%s = _vif_scanf (%s, %s[%s + 1], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
    code (nprocs, BODY, str);
    io_event (proc, unit, iorc, endlbl, errlbl);
    _srecordf (str, "%s += 3;\n", fid);
    code (nprocs, BODY, str);
    io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  }
}

void io_elemuf (char *proc, EXPR *unit, EXPR *reg, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
{
  NEW_RECORD (str);
  NEW_RECORD (elem);
  io_parm (reg, elem);
  if (EQUAL (proc, "write")) {
    _srecordf (str, "%s = fwrite (%s", iorc, elem);
    code (nprocs, BODY, str);
  } else if (EQUAL (proc, "read")) {
    _srecordf (str, "%s = fread (%s", iorc, elem);
    code (nprocs, BODY, str);
  } else {
    BUG ("io_elemuf");
  }
  _srecordf (str, ", sizeof (%s), ", wtype (&reg->mode, NOARG, NOFUN));
  code (nprocs, BODY, str);
  if (reg->variant == EXPR_VAR && IS_ROW (reg->mode)) {
    code_row_len (reg->idf);
  } else {
    code (nprocs, BODY, "1");
  }
  _srecordf (str, ", _ffile[%s].unit);\n", unum (unit));
  code (nprocs, BODY, str);
  io_event (proc, unit, iorc, endlbl, errlbl);
}

void io_elemstd (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
{
  NEW_RECORD (str);
  NEW_RECORD (elem);
  io_parm (reg, elem);
  if (reg->mode.type == INTEGER) {
    if (EQUAL (proc, "write")) {
      _srecordf (str, "%s = _vif_printf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    } else if (EQUAL (proc, "read")) {
      _srecordf (str, "%s = _vif_scanf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    }
  } else if (reg->mode.type == LOGICAL) {
    if (EQUAL (proc, "write")) {
      _srecordf (str, "%s = _vif_printf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    } else if (EQUAL (proc, "read")) {
      _srecordf (str, "%s = _vif_scanf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    }
  } else if (reg->mode.type == REAL) {
    if (EQUAL (proc, "write")) {
      NEW_RECORD (fmt);
      if (reg->mode.len == 32) {
        _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
        _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
      } else if (reg->mode.len == 16) {
        _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
        _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
      } else if (reg->mode.len == 8) {
        _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
        _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
      } else if (reg->mode.len == 4) {
        _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
        _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
      }
    } else if (EQUAL (proc, "read")) {
      _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, REAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    }
  } else if (reg->mode.type == COMPLEX) {
    if (EQUAL (proc, "write")) {
      NEW_RECORD (fmt);
      if (reg->mode.len == 8) {
        _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
      } else if (reg->mode.len == 16) {
        _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
      } else if (reg->mode.len == 32) {
        _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
      } else if (reg->mode.len == 64) {
        _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
      }
      _srecordf (str, "%s = _vif_printf (%s, %s, %s, COMPLEX, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
      code (nprocs, BODY, str);
      io_event (proc, unit, iorc, endlbl, errlbl);
      _srecordf (str, "%s = _vif_printf (%s, \" \", NULL, NOTYPE, 0);\n", iorc, unum (unit));
      code (nprocs, BODY, str);
      io_event (proc, unit, iorc, endlbl, errlbl);
      _srecordf (str, "%s = _vif_printf (%s, %s, %s, COMPLEX, -%d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
    } else if (EQUAL (proc, "read")) {
      _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, COMPLEX, %d);\n", iorc, unum (unit), elem, reg->mode.len);
      code (nprocs, BODY, str);
      io_event (proc, unit, iorc, endlbl, errlbl);
      _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, COMPLEX, -%d);\n", iorc, unum (unit), elem, reg->mode.len);
    }
  } else if (reg->mode.type == CHARACTER) {
    if (EQUAL (proc, "write")) {
//    _srecordf (str, "%s = _vif_printf (%s, \"%%-%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
      _srecordf (str, "%s = _vif_printf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    } else if (EQUAL (proc, "read")) {
//    _srecordf (str, "%s = _vif_scanf (%s, \"%%%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
      _srecordf (str, "%s = _vif_scanf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
    }
  }
  code (nprocs, BODY, str);
  io_event (proc, unit, iorc, endlbl, errlbl);
  (*items) ++;
}

void io_elemf (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
{
  NEW_RECORD (elem);
  io_parm (reg, elem);
  if (reg->mode.type == INTEGER) {
    io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "INTEGER", reg->mode.len);
    (*items) ++;
  } else if (reg->mode.type == LOGICAL) {
    io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "LOGICAL", reg->mode.len);
    (*items) ++;
  } else if (reg->mode.type == REAL) {
    io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "REAL", reg->mode.len);
    (*items) ++;
  } else if (reg->mode.type == COMPLEX) {
    io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", reg->mode.len);
    io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", -reg->mode.len);
    (*items) ++;
  } else if (reg->mode.type == CHARACTER) {
    io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "CHARACTER", reg->mode.len);
    (*items) ++;
  }
}

void io_array (char *proc, EXPR *unit, EXPR *reg, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
{
  NEW_RECORD (str); NEW_RECORD (tmpa); NEW_RECORD (tmpk);
  EXPR elem;
  IDENT *ptr;
  _srecordf (tmpa, "_arr_%d", nloctmps++);
  ptr = add_local (tmpa, reg->mode.type, reg->mode.len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  ptr->alias = reg->idf;
  _srecordf (tmpk, "_k_%d", nloctmps++);
  add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  _srecordf (str, "for (%s = %s %s, %s = 0; %s < ", tmpa, ptr_to_array (ptr, NOCONST, CAST, ACTUAL), reg->str, tmpk, tmpk);
  code (nprocs, BODY, str);
  code_row_len (reg->idf);
  _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
  code (nprocs, BODY, str);
  memcpy (&elem, reg, sizeof (EXPR));
  elem.mode.dim = 0;
  if (EQUAL (proc, "read")) {
    _srecordf (elem.str, "%s", tmpa);
  } else if (EQUAL (proc, "write")) {
    _srecordf (elem.str, "*%s", tmpa);
  } else {
    BUG ("io_array");
  }
  if (form == STDFORMAT) {
    io_elemstd (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
  } else if (form == FORMATTED) {
    io_elemf (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
  }
  code (nprocs, BODY, "}\n");
}

void io_elem (char *proc, EXPR *unit, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
{
  EXPR reg;
  macro_depth = 0;
  express (&reg, NOTYPE, 0);
  if (form == UNFORMATTED) {
    io_elemuf (proc, unit, &reg, iorc, endlbl, errlbl, items);
  } else if (form == STDFORMAT) {
    if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
      io_array (proc, unit, &reg, form, fstr, fid, iorc, endlbl, errlbl, items);
    } else {
      io_elemstd (proc, unit, &reg, fstr, fid, iorc, endlbl, errlbl, items);
    }
  } else if (form == FORMATTED) {
    if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
      io_array (proc, unit, &reg, form, fstr, fid, iorc, endlbl, errlbl, items);
    } else {
      io_elemf (proc, unit, &reg, fstr, fid, iorc, endlbl, errlbl, items);
    }
  } else {
    BUG ("IO formatting unspecified");
  }
}

int_4 impl_do (void)
{
// Quick check whether (...) in a list is an implied DO loop.
  int_4 rc, nest = 1;
  while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
    if (TOKEN ("(")) {
      nest++;
    } else if (TOKEN (")")) {
      nest--;
      if (nest == 0) {
        return FALSE;
      }
    } else if (nest == 1 && TOKEN (",")) {
// Trigger is the sequence ", I =" in outer nest.
      rc = scan (EXPECT_NONE);
      if (rc == WORD) {
        NEW_RECORD (name);
        RECCPY (name, curlex);
        rc = scan (EXPECT_NONE);
        if (TOKEN ("=")) {
          (void) impl_decl (name, NO_MODE);
          return TRUE;
        } else {
          UNSCAN;
        }
      }
    }
  }
  (void) rc;
  return FALSE;
}

void io_list (char *proc, EXPR *unit, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 lpatch, int_4 *nest, int_4 *items)
{
  while (WITHIN) {
    int_4 rc;
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE);
      if (! WITHIN) {
        SYNTAX (3302, prelex);
        break;
      }
      if (TOKEN (",")) {
        SYNTAX (3303, ",,");
        continue;
      }
    } else {
      rc = scan (EXPECT_NONE);
      if (TOKEN (",")) {
        continue;
      }
    }
    if (! WITHIN) {
      break;
    }
    if (TOKEN ("(")) {
      SAVE_POS (1);
// Quick lookahead.
      int_4 loop = impl_do ();
// Restore.
      RESTORE_POS (1);
      UNSCAN;
      rc = scan ("(");
// Decide.
      if (loop) {
        (*nest)++;
        int_4 where = code (nprocs, BODY, NO_TEXT);
        io_list (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, where, nest, items);
      } else {
        io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
        rc = scan (EXPECT_NONE);
      }
    } else if (TOKEN (")")) {
// Expression closed by ')'
      (*nest)--;
      return;
    } else if (rc == WORD) {
      if (*nest == 0) {
        io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
        rc = scan (EXPECT_NONE);
      } else {
        SAVE_POS (2);
        rc = scan (EXPECT_NONE);
        if (!TOKEN ("=")) {
          RESTORE_POS (2);
          UNSCAN;
          rc = scan (EXPECT_NONE);
          io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
          rc = scan (EXPECT_NONE);
        } else {
          NEW_RECORD (lid); NEW_RECORD (loop);
          EXPR from, to, by;
          MODE mode;
          IDENT *idf = impl_decl (prelex, &mode);
          if (idf->arg || idf->alias != NULL) {
            _srecordf (lid, "*%s", C_NAME (idf));
          } else {
           (void) idf_full_c_name (lid, idf);
          }
          rc = scan (EXPECT_NONE);
          express (&from, idf->mode.type, idf->mode.len);
          rc = scan (",");
          rc = scan (EXPECT_NONE);
          express (&to, idf->mode.type, idf->mode.len);
          rc = scan (EXPECT_NONE);
          if (TOKEN (",")) {
            rc = scan (EXPECT_NONE);
            express (&by, idf->mode.type, idf->mode.len);
            _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", 
                      lid, from.str, lid, to.str, lid, by.str);
            rc = scan (EXPECT_NONE);
          } else {
            _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", 
                      lid, from.str, lid, to.str, lid);
          }
          patch (lpatch, loop);
          if (TOKEN (")")) {
// Implied DO loop closed by ')'.
            (*nest)--;
            code (nprocs, BODY, "}; // implied DO \n");
          } else {
            EXPECT (3304, ")");
          }
          return;
        }
      }
    } else {
      io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
      rc = scan (EXPECT_NONE);
    }
  }
}

void io_unit (EXPR *unit, int_4 defunit)
{
// Reasonable default.
  unit->mode.type = INTEGER;
  unit->mode.len = 4;
//
  if (TOKEN ("*")) {
    _srecordf (unit->str, "%d", defunit);
  } else if (TOKEN ("stdin")) {
    _srecordf (unit->str, "STDF_IN");
  } else if (TOKEN ("stdout")) {
    _srecordf (unit->str, "STDF_OUT");
  } else if (TOKEN ("stderr")) {
    _srecordf (unit->str, "STDF_ERR");
  } else {
    EXPR reg;
    macro_depth = 0;
    express (&reg, NOTYPE, NOLEN);
    if (reg.mode.type == INTEGER) {
      if (reg.variant == EXPR_CONST) {
        _srecordf (unit->str, "%s", reg.str);
        int_4 val;
        (void) is_int4 (unit->str, &val);
        if (val < 1 || val > MAX_FILES - 1) {
          ERROR (3305, "unit number out of range", unit->str);
        }
      } else {
        NEW_RECORD (str);
        _srecordf (unit->str, "%s", edit_unit (nloctmps++));
        add_local (unit->str, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
        _srecordf (str, "%s = %s;\n", unit, reg.str);
        code (nprocs, BODY, str);
      }   
    } else if (reg.mode.type == CHARACTER) {
      (*unit) = reg;
    } else {
      ERROR (3306, "unit must be INTEGER or CHARACTER", NO_TEXT);
    }
  }
}

static void io_specs (char *proc, EXPR *unit, int_4 defunit, EXPR *rec, EXPR *fmt, char **fn, char **form, char **action, int_4 *lrecl, char **disp, LBL **end, LBL **err, char **iostat)
{
  int_4 rc, parm = 1;
  RECCLR (unit->str);
  RECCLR (rec->str);
  RECCLR (fmt->str);
  *action = action_default;
  *disp = disp_old;
  *end = NO_LABEL;
  *err = NO_LABEL;
  *fn = NO_TEXT;
  *form = form_unformatted;
  *iostat = NO_TEXT;
  rec->str[0] = '\0';
// We accept that only a unit specification follows.
  if (curret == INT_NUMBER || curret == WORD) {
    io_unit (unit, defunit);
    return;
  }
  if (TOKEN ("(")) {
    rc = scan (EXPECT_NONE); 
  } else {
    EXPECT (3307, "(");
    return;
  }
//
  while (!TOKEN (")") && rc != END_OF_MODULE) {
// ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str |  DISP=str |  END=n | ERR=n])
    if (TOKEN ("unit") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      io_unit (unit, defunit);
    } else if (TOKEN ("rec") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      express (rec, INTEGER, 4);
    } else if (TOKEN ("file") && lookahead ("=")) {
      EXPR reg;
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      if (express (&reg, CHARACTER, NOLEN)) {
        *fn = f_stralloc (reg.str);
      }
    } else if (TOKEN ("form") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (MATCH ("formatted")) {
        *form = form_formatted;
      } else if (MATCH ("unformatted")) {
        *form = form_unformatted;
      } else {
        SYNTAX (3308, "invalid FORM specification");
      }
    } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (MATCH ("read")) {
        *action = action_read;
      } else if (MATCH ("write")) {
        *action = action_write;
      } else if (MATCH ("readwrite")) {
        *action = action_readwrite;
      } else if (MATCH ("direct")) {
        *action = action_readwrite;
      } else {
        SYNTAX (3309, "invalid ACCESS specification");
      }
    } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
// Straight from JCL :-)
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (MATCH ("old")) {
        *disp = disp_old;
      } else if (MATCH ("new")) {
        *disp = disp_new;
      } else if (MATCH ("keep")) {
        *disp = disp_keep;
      } else if (MATCH ("delete")) {
        *disp = disp_delete;
      } else if (MATCH ("unknown")) {
        *disp = disp_new;
      } else {
        SYNTAX (3310, "invalid DISP specification");
      }
    } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      express (rec, INTEGER, 4);
    } else if (TOKEN ("fmt") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (TOKEN ("*")) {
        *form = form_formatted;
      } else if (rc == INT_NUMBER) {
        bufcpy (fmt->str, curlex, RECLN);
        fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
        *form = form_formatted;
      } else if (rc == WORD) {
        macro_depth = 0;
        express (fmt, NOTYPE, NOLEN);
        *form = form_formatted;
      } else if (rc == TEXT) {
        int_4 k = format_str (curlex);
        _srecordf (fmt->str, "%d", k);
        fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
        *form = form_formatted;
      } else {
        EXPECT (3311, "label or format string");
      }
    } else if (TOKEN ("end") && lookahead ("=")) {
      rc = scan ("=");
      if ((rc = scan (EXPECT_LABEL)) == LABEL) {
        if (((*end) = find_label (curlex)) == NO_LABEL) {
          ERROR (3312, "no such label", curlex);
        }
        (*end)->jumped++;
      } else {
        EXPECT (3313, "label");
      }
    } else if (TOKEN ("err") && lookahead ("=")) {
      rc = scan ("=");
      if ((rc = scan (EXPECT_LABEL)) == LABEL) {
        if (((*err) = find_label (curlex)) == NO_LABEL) {
          ERROR (3314, "no such label", curlex);
        }
        (*err)->jumped++;
      } else {
        EXPECT (3315, "label");
      }
    } else if (TOKEN ("iostat") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (rc != WORD) {
        EXPECT (3316, "variable")
      } else {
        (void) impl_decl (curlex, NO_MODE);
        *iostat = f_stralloc (curlex);
      }
    } else {
      if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
        if (parm == 1 && rc == INT_NUMBER) {
          (void) is_int4 (curlex, lrecl);
        } else if (parm == 2 && TOKEN ("*")) {
          ;
        } else if (parm == 2 && rc == WORD) {
          macro_depth = 0;
          express (fmt, NOTYPE, NOLEN);
          *form = form_formatted;
        } else if (parm == 2 && rc == TEXT) {
          int_4 k = format_str (curlex);
          _srecordf (fmt->str, "%d", k);
          fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
        } else if (parm == 2 && rc == INT_NUMBER) {
          bufcpy (fmt->str, curlex, RECLN);
          fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
        } else if (parm == 3) {
          io_unit (unit, defunit);
        } else {
          SYNTAX (3317, curlex);
        }
      } else {
        if (parm == 1) {
          io_unit (unit, defunit);
        } else if (parm == 2 && TOKEN ("*")) {
          *form = form_formatted;
        } else if (parm == 2 && rc == WORD) {
          macro_depth = 0;
          express (fmt, NOTYPE, NOLEN);
          *form = form_formatted;
        } else if (parm == 2 && rc == TEXT) {
          int_4 k = format_str (curlex);
          _srecordf (fmt->str, "%d", k);
          fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
          *form = form_formatted;
        } else if (parm == 2 && rc == INT_NUMBER) {
          bufcpy (fmt->str, curlex, RECLN);
          fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
          *form = form_formatted;
        } else {
          SYNTAX (3318, curlex);
        }
      }
    }
// Next item.
    parm++;
    rc = scan (EXPECT_NONE); 
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE); 
    } else if (TOKEN (")")) {
      ;
    } else {
      SYNTAX (3319, curlex);
    }
  }
}

void vif_close (void)
{
  int_4 rc, lrecl = 0;
  char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
  EXPR unit, rec, fmt;
  LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
  NEW_RECORD (str);
  rc = scan (EXPECT_NONE);
  io_specs ("close", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
  _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "_funregister (\"%s\", %s);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  if (iostat != NO_TEXT) {
    NEW_RECORD (ios);
    _srecordf (ios, "%s_ = errno;\n", iostat);
    code (nprocs, BODY, ios);
  }
  code (nprocs, BODY, "if (errno != 0) {\n");
  if (errlbl == NO_LABEL) {
    _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
  } else {
    _srecordf (str, "goto _l%d;\n", errlbl->num);
  }
  code (nprocs, BODY, str);
  code (nprocs, BODY, "}\n");
  code (nprocs, BODY, "}\n");
  (void) rc;
}

void vif_endfile (void)
{
  int_4 rc, lrecl = 0;
  char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
  EXPR unit, rec, fmt;
  LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
  NEW_RECORD (str);
  rc = scan (EXPECT_NONE);
  io_specs ("endfile", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
  _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "fprintf (_ffile[%s].unit, \"%%c\", EOF);\n", unum (&unit));
  code (nprocs, BODY, str);
  if (iostat != NO_TEXT) {
    NEW_RECORD (ios);
    _srecordf (ios, "%s_ = errno;\n", iostat);
    code (nprocs, BODY, ios);
  }
  code (nprocs, BODY, "if (errno != 0) {\n");
  if (errlbl == NO_LABEL) {
    _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
  } else {
    _srecordf (str, "goto _l%d;\n", errlbl->num);
  }
  code (nprocs, BODY, str);
  code (nprocs, BODY, "}\n");
  code (nprocs, BODY, "}\n");
  (void) rc;
}

void vif_backspace (void)
{
  int_4 rc, lrecl = 0;
  char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
  EXPR unit, rec, fmt;
  LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
  NEW_RECORD (str);
  rc = scan (EXPECT_NONE);
  io_specs ("backspace", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
  _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "_backspace (\"%s\", %s);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  if (iostat != NO_TEXT) {
    NEW_RECORD (ios);
    _srecordf (ios, "%s_ = errno;\n", iostat);
    code (nprocs, BODY, ios);
  }
  code (nprocs, BODY, "if (errno != 0) {\n");
  if (errlbl == NO_LABEL) {
    _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
  } else {
    _srecordf (str, "goto _l%d;\n", errlbl->num);
  }
  code (nprocs, BODY, str);
  code (nprocs, BODY, "}\n");
  code (nprocs, BODY, "}\n");
  (void) rc;
}

void vif_rewind (void)
{
  int_4 rc, lrecl = 0;
  char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
  EXPR unit, rec, fmt;
  LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
  NEW_RECORD (str);
  rc = scan (EXPECT_NONE);
  io_specs ("rewind", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
  _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
  code (nprocs, BODY, str);
  _srecordf (str, "_rewind (\"%s\", %s);\n", stat_start, unum (&unit));
  code (nprocs, BODY, str);
  if (iostat != NO_TEXT) {
    NEW_RECORD (ios);
    _srecordf (ios, "%s_ = errno;\n", iostat);
    code (nprocs, BODY, ios);
  }
  code (nprocs, BODY, "if (errno != 0) {\n");
  if (errlbl == NO_LABEL) {
    _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
  } else {
    _srecordf (str, "goto _l%d;\n", errlbl->num);
  }
  code (nprocs, BODY, str);
  code (nprocs, BODY, "}\n");
  code (nprocs, BODY, "}\n");
  (void) rc;
}

void vif_open (void)
{
  int_4 rc, lrecl = 0;
  char *daction = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *ddisp = NO_TEXT, *iostat = NO_TEXT;
  LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
  EXPR unit, rec, fmt;
  NEW_RECORD (str);
  rc = scan (EXPECT_NONE);
  io_specs ("open", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
  if (dfn != NO_TEXT) {
    _srecordf (str, "_fregister (\"%s\", %s, %d, %s, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dfn, dform, daction, ddisp);
  } else {
    _srecordf (str, "_fregister (\"%s\", %s, %d, NULL, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dform, daction, ddisp);
  }
  code (nprocs, BODY, str);
  if (iostat != NO_TEXT) {
    NEW_RECORD (ios);
    _srecordf (ios, "%s_ = errno;\n", iostat);
    code (nprocs, BODY, ios);
  }
  (void) rc;
}

void io_open_internal (EXPR *unit, char *acc)
{
  if (unit->mode.type != CHARACTER) {
    ERROR (3320, "unit type must be CHARACTER", unit->str);
  } else if (unit->variant == EXPR_CONST) {
    ERROR (3321, "unit must be CHARACTER variable", unit->str);
  } else {
    int N = unit->mode.len, M = 1;
    if (unit->idf->mode.dim == 0) {
      ;
    } else {
      NEW_RECORD (len);
      compute_row_size (len, unit->idf);
      if (! is_int4 (len, &M)) {
        ERROR (3322, "size must be integer constant", len);
      }
      if (M > 1) {
        N *= M;
      }
    }
    NEW_RECORD (str);
    _srecordf (str, "_ffile[0].buff = _ffile[0].rewind = (char *) (%s);\n", unit->str);
    code (nprocs, BODY, str);
    _srecordf (str, "_ffile[0].lrecl = %d;\n", unit->mode.len);
    code (nprocs, BODY, str);
    _srecordf (str, "_ffile[0].record = 0;\n");
    code (nprocs, BODY, str);
    _srecordf (str, "_ffile[0].records = %d;\n", M);
    code (nprocs, BODY, str);
    _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"%s\");\n", unit->str, N, acc);
    code (nprocs, BODY, str);
    _srecordf (str, "_ffile[0].buff_init = FALSE;\n");
    code (nprocs, BODY, str);
  }
}

void do_io (char *proc, int_4 *nest)
{
  int_4 form = UNFORMATTED, lrecl = 0;
  LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
  NEW_RECORD (fstr);
  NEW_RECORD (fid);
  NEW_RECORD (iorc);
  NEW_RECORD (str);
  char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
  EXPR unit, rec, fmt;
  RECCLR (fmt.str);
  unit.mode.type = INTEGER;
  unit.mode.len = 4;
  fstr[0] = '\0';
  fid[0] = '\0';
  iorc[0] = '\0';
  rec.str[0] = '\0';
  int_4 rc = scan (EXPECT_NONE);
  if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
    if (TOKEN ("*")) {
      _srecordf (unit.str, "STDF_IN");
      dform = form_formatted;
      rc = scan (EXPECT_NONE);
    } else if (rc == INT_NUMBER) { // FORTRAN II
      _srecordf (unit.str, "STDF_IN");
      bufcpy (fmt.str, curlex, RECLN);
      fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
      dform = form_formatted;
      rc = scan (EXPECT_NONE);
    } else if (rc == TEXT) {
      _srecordf (unit.str, "STDF_IN");
      int_4 k = format_str (curlex);
      _srecordf (fmt.str, "%d", k);
      fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
      dform = form_formatted;
      rc = scan (EXPECT_NONE);
    } else {
      io_specs (proc, &unit, STDF_IN, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
    }
  } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
    if (TOKEN ("*")) {
      _srecordf (unit.str, "STDF_OUT");
      dform = form_formatted;
      rc = scan (EXPECT_NONE);
    } else if (rc == INT_NUMBER) { // FORTRAN II
      _srecordf (unit.str, "STDF_OUT");
      bufcpy (fmt.str, curlex, RECLN);
      fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
      dform = form_formatted;
      rc = scan (EXPECT_NONE);
    } else if (rc == TEXT) {
      _srecordf (unit.str, "STDF_OUT");
      int_4 k = format_str (curlex);
      _srecordf (fmt.str, "%d", k);
      fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
      dform = form_formatted;
      rc = scan (EXPECT_NONE);
    } else {
      io_specs (proc, &unit, STDF_OUT, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
    }
  } else if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
    io_specs (proc, &unit, STDF_OUT, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
    ddisp = disp_old;
    dfn = NO_TEXT;
    iostat = NO_TEXT;
    dform = form_formatted;
    if (EQUAL (proc, "encode")) {
      proc = "write";
      daction = action_write;
    } else if (EQUAL (proc, "decode")) {
      proc = "read";
      daction = action_read;
    }
  }
  if (strlen (fmt.str) == 0 && dform != form_unformatted) {
    form = STDFORMAT;
  } else if (strlen (fmt.str) == 0 && dform == form_unformatted) {
    form = UNFORMATTED;
  } else {
    form = FORMATTED;
  }
// IO to a string implies UNIT=0.
  if (unit.mode.type == CHARACTER) {
    if (EQUAL (proc, "read")) {
      io_open_internal (&unit, "r");
    } else if (EQUAL (proc, "accept")) {
      io_open_internal (&unit, "r");
    } else if (EQUAL (proc, "write")) {
      io_open_internal (&unit, "w");
    } else if (EQUAL (proc, "print")) {
      io_open_internal (&unit, "w");
    } else if (EQUAL (proc, "punch")) {
      io_open_internal (&unit, "w");
    }
  }
// Runtime checks - can the file do this?
  if (EQUAL (proc, "read")) {
    _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
  } else if (EQUAL (proc, "accept")) {
    _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
  } else if (EQUAL (proc, "write")) {
    _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  } else if (EQUAL (proc, "print")) {
    _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  } else if (EQUAL (proc, "punch")) {
    _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  }
  code (nprocs, BODY, str);
// Set record.
  if (strlen (rec.str) > 0) {
    _srecordf (str, "_set_record (\"%s\", %s, %s);\n", stat_start, unum (&unit), rec.str);
    code (nprocs, BODY, str);
  }
// Formats.
  if (form == FORMATTED) {
    NEW_RECORD (fcnt);
    int_4 val;
    _srecordf (fid, "__fcnt");
    add_local (fid, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (iorc, "__rc");
    add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (fcnt, "%s = 0;\n", fid);
    code (nprocs, BODY, fcnt);
    if (is_int4 (fmt.str, &val)) {
      _srecordf (fstr, "%s", edit_fmt (val));
    } else {
      if (fmt.mode.type == INTEGER) {
// Assigned FORMAT.
        _srecordf (str, "switch (%s) {\n", fmt.str);
        code (nprocs, BODY, str);
        code (nprocs, BODY, "default:\n");
        for (int_4 k = 0; k < nlabels; k++) {
          LBL *L = &labels[k];
          if (L->format) {
            L->jumped++;
            _srecordf (str, "case %d: __fmt_a = %s; break;\n", L->index, edit_fmt(L->num));
            code (nprocs, BODY, str);
          }
        }
        code (nprocs, BODY, "}\n");
        RECCPY (fstr, "__fmt_a");
      } else if (fmt.mode.type == CHARACTER) {
        _srecordf (str, "__fmt_a = _vif_jit (\"%s\", %s);\n", stat_start, fmt.str);
        code (nprocs, BODY, str);
        RECCPY (fstr, "__fmt_a");
      } else {
        ERROR (3323, "format identifier mode error", qtype (&fmt.mode));
      }
    }
  } else {
    _srecordf (iorc, "__rc_%d", nloctmps++);
    add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  }
// Start-of-record.
  if (form == FORMATTED) {
    if (EQUAL (proc, "read")) {
      io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    } else if (EQUAL (proc, "accept")) {
      io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    } else if (EQUAL (proc, "write")) {
      io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    } else if (EQUAL (proc, "print")) {
      io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    } else if (EQUAL (proc, "punch")) {
      io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
    }
  }
  int_4 items = 0;
  if (EQUAL (proc, "read")) {
    io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  } else if (EQUAL (proc, "accept")) {
    io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  } else if (EQUAL (proc, "write")) {
    io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  } else if (EQUAL (proc, "print")) {
    io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  } else if (EQUAL (proc, "punch")) {
    io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  }
  if (unit.mode.type == CHARACTER) {
// IO to a string implies UNIT=0.
//  code (nprocs, BODY, "_fclose (0);\n");
  } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
// End-of-record.
    if (form != UNFORMATTED) {
      _srecordf (str, "_write_eol (%s);\n", unum (&unit));
      code (nprocs, BODY, str);
    }
  } else if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
// End-of-record.
    if (form != UNFORMATTED) {
      _srecordf (str, "_read_eol (%s);\n", unum (&unit));
      code (nprocs, BODY, str);
    }
  }
//
  save_iostat (iostat);
//
  (void) rc;
}
