Algol 68 Genie

transput.c

     1  //! @file transput.c
     2  //! @author J. Marcel van der Veer
     3  //
     4  //! @section Copyright
     5  //
     6  // This file is part of VIF - vintage FORTRAN compiler.
     7  // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
     8  //
     9  //! @section License
    10  //
    11  // This program is free software; you can redistribute it and/or modify it 
    12  // under the terms of the GNU General Public License as published by the 
    13  // Free Software Foundation; either version 3 of the License, or 
    14  // (at your option) any later version.
    15  //
    16  // This program is distributed in the hope that it will be useful, but 
    17  // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
    18  // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
    19  // more details. You should have received a copy of the GNU General Public 
    20  // License along with this program. If not, see <http://www.gnu.org/licenses/>.
    21  
    22  //! @section Synopsis
    23  //!
    24  //! Compile Fortran IO.
    25  
    26  #include <vif.h>
    27  
    28  static char *unum (EXPR *unit)
    29  {
    30    if (unit->mode.type == INTEGER) {
    31      return unit->str;
    32    } else {
    33      return "0";
    34    }
    35  }
    36  
    37  void save_iostat (char *iostat)
    38  {
    39    if (iostat != NO_TEXT) {
    40      EXPR loc; 
    41      NEW_RECORD (ios);
    42      NEW_RECORD (str);
    43      MODE mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
    44      _srecordf (ios, "%s", iostat);
    45      RECCLR (loc.str);
    46      factor_variable (&loc, NULL, &mode, ios);
    47      if (loc.mode.type == mode.type && loc.mode.len == mode.len) {
    48        _srecordf (str, "%s_ = errno;\n", loc.str);
    49        code (nprocs, BODY, str);
    50      } else {
    51        MODE_ERROR (3201, qtype (&(loc.mode)), qtype (&mode));
    52      }
    53    }
    54  }
    55  
    56  void io_event (char *proc, EXPR *unit, char *iorc, LBL *endlbl, LBL *errlbl)
    57  {
    58    if (EQUAL (proc, "write")) {
    59      NEW_RECORD (str);
    60      if (errlbl == NO_LABEL) {
    61        _srecordf (str, "_write_err (%s, %s, _ioerr_%s (\"%s\", %s));\n", iorc, unum (unit), proc, stat_start, unum (unit));
    62      } else {
    63        _srecordf (str, "_write_err (%s, %s, goto _l%d);\n", iorc, unum (unit), errlbl->num);
    64      }
    65      code (nprocs, BODY, str);
    66    } else if (EQUAL (proc, "read")) {
    67      NEW_RECORD (str1);
    68      NEW_RECORD (str2);
    69      NEW_RECORD (str);
    70      if (endlbl == NO_LABEL) {
    71        _srecordf (str1, "_ioend_%s (\"%s\", %s)", proc, stat_start, unum (unit));
    72      } else {
    73        _srecordf (str1, "goto _l%d", endlbl->num);
    74      }
    75      if (errlbl == NO_LABEL) {
    76        _srecordf (str2, "_ioerr_%s (\"%s\", %s)", proc, stat_start, unum (unit));
    77      } else {
    78        _srecordf (str2, "goto _l%d", errlbl->num);
    79      }
    80      _srecordf (str, "_read_err (%s, %s, %s, %s);\n", iorc, unum (unit), str1, str2);
    81      code (nprocs, BODY, str);
    82    } else {
    83      BUG ("io_event");
    84    }
    85  }
    86  
    87  void io_parm (EXPR *reg, char *elem)
    88  {
    89    if (reg->variant == EXPR_VAR) {
    90      if (IS_ROW (reg->mode)) {
    91        _srecordf (elem, "%s", reg->str);
    92      } else if (reg->str[0] == '*') {
    93        _srecordf (elem, "%s", &reg->str[1]);
    94      } else if (reg->mode.type == CHARACTER) {
    95        _srecordf (elem, "%s", reg->str);
    96      } else {
    97        (void) impl_decl (reg->str, NO_MODE);
    98        _srecordf (elem, "&%s", reg->str);
    99      }
   100    } else if (reg->variant == EXPR_SLICE) {
   101      _srecordf (elem, "&%s", reg->str);
   102    } else {
   103      NEW_RECORD (tmp);
   104      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
   105      if (reg->mode.type == CHARACTER) {
   106        norm_mode (&reg->mode);
   107        if (reg->mode.len == 0) {
   108          add_local (tmp, reg->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   109          _srecordf (elem, "strcpy (%s, %s);\n", tmp, reg->str);
   110        } else {
   111          add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   112          _srecordf (elem, "bufcpy (%s, %s, %d);\n", tmp, reg->str, reg->mode.len);
   113        }
   114        code (nprocs, BODY, elem);
   115        _srecordf (elem, "%s", tmp);
   116      } else {
   117        add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   118        _srecordf (elem, "%s = %s;\n", tmp, reg->str);
   119        code (nprocs, BODY, elem);
   120        _srecordf (elem, "&%s", tmp);
   121      }
   122    }
   123  }
   124  
   125  void io_text_items (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, logical_4 term)
   126  {
   127    NEW_RECORD (str);
   128    if (EQUAL (proc, "write")) {
   129      _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
   130      code (nprocs, BODY, str);
   131      if (term) {
   132        _srecordf (str, "if (%s[%s + 2] == FMT_TERM) {\n", fstr, fid);
   133        code (nprocs, BODY, str);
   134        code (nprocs, BODY, "break;\n");
   135        code (nprocs, BODY, "}\n");
   136      }
   137      _srecordf (str, "%s = _vif_printf (%s, %s[%s + 2], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
   138      code (nprocs, BODY, str);
   139      io_event (proc, unit, iorc, endlbl, errlbl);
   140      _srecordf (str, "%s += 3;\n", fid);
   141      code (nprocs, BODY, str);
   142      code (nprocs, BODY, "}\n");
   143    } else if (EQUAL (proc, "read")) {
   144      _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
   145      code (nprocs, BODY, str);
   146      _srecordf (str, "%s = _vif_scanf (%s, %s[%s + 1], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
   147      code (nprocs, BODY, str);
   148      io_event (proc, unit, iorc, endlbl, errlbl);
   149      _srecordf (str, "%s += 3;\n", fid);
   150      code (nprocs, BODY, str);
   151      code (nprocs, BODY, "}\n");
   152    }
   153  }
   154  
   155  void io_format (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, char *elem, char *type, int_4 len)
   156  {
   157    NEW_RECORD (str);
   158    if (EQUAL (proc, "write")) {
   159      _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
   160      code (nprocs, BODY, str);
   161      _srecordf (str, "%s = 0;\n", fid);
   162      code (nprocs, BODY, str);
   163      _srecordf (str, "%s = fprintf (_ffile[%s].unit, \"\\n\");\n", iorc, unum (unit));
   164      code (nprocs, BODY, str);
   165      io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
   166      code (nprocs, BODY, "};\n");
   167      _srecordf (str, "%s = _vif_printf (%s, %s[%s + 2], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
   168      code (nprocs, BODY, str);
   169      io_event (proc, unit, iorc, endlbl, errlbl);
   170      _srecordf (str, "%s += 3;\n", fid);
   171      code (nprocs, BODY, str);
   172      io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, TRUE);
   173    } else if (EQUAL (proc, "read")) {
   174      _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
   175      code (nprocs, BODY, str);
   176      _srecordf (str, "%s = 0;\n", fid);
   177      code (nprocs, BODY, str);
   178      _srecordf (str, "_vif_scanf (%s, NULL, NULL, NOTYPE, 0);\n", unum (unit));
   179      code (nprocs, BODY, str);
   180      io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
   181      code (nprocs, BODY, "};\n");
   182      _srecordf (str, "%s = _vif_scanf (%s, %s[%s + 1], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
   183      code (nprocs, BODY, str);
   184      io_event (proc, unit, iorc, endlbl, errlbl);
   185      _srecordf (str, "%s += 3;\n", fid);
   186      code (nprocs, BODY, str);
   187      io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
   188    }
   189  }
   190  
   191  void io_elemuf (char *proc, EXPR *unit, EXPR *reg, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
   192  {
   193    NEW_RECORD (str);
   194    NEW_RECORD (elem);
   195    io_parm (reg, elem);
   196    if (EQUAL (proc, "write")) {
   197      _srecordf (str, "%s = fwrite (%s", iorc, elem);
   198      code (nprocs, BODY, str);
   199    } else if (EQUAL (proc, "read")) {
   200      _srecordf (str, "%s = fread (%s", iorc, elem);
   201      code (nprocs, BODY, str);
   202    } else {
   203      BUG ("io_elemuf");
   204    }
   205    _srecordf (str, ", sizeof (%s), ", wtype (&reg->mode, NOARG, NOFUN));
   206    code (nprocs, BODY, str);
   207    if (reg->variant == EXPR_VAR && IS_ROW (reg->mode)) {
   208      code_row_len (reg->idf);
   209    } else {
   210      code (nprocs, BODY, "1");
   211    }
   212    _srecordf (str, ", _ffile[%s].unit);\n", unum (unit));
   213    code (nprocs, BODY, str);
   214    io_event (proc, unit, iorc, endlbl, errlbl);
   215  }
   216  
   217  void io_elemstd (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
   218  {
   219    NEW_RECORD (str);
   220    NEW_RECORD (elem);
   221    io_parm (reg, elem);
   222    if (reg->mode.type == INTEGER) {
   223      if (EQUAL (proc, "write")) {
   224        _srecordf (str, "%s = _vif_printf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   225      } else if (EQUAL (proc, "read")) {
   226        _srecordf (str, "%s = _vif_scanf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   227      }
   228    } else if (reg->mode.type == LOGICAL) {
   229      if (EQUAL (proc, "write")) {
   230        _srecordf (str, "%s = _vif_printf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   231      } else if (EQUAL (proc, "read")) {
   232        _srecordf (str, "%s = _vif_scanf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   233      }
   234    } else if (reg->mode.type == REAL) {
   235      if (EQUAL (proc, "write")) {
   236        NEW_RECORD (fmt);
   237        if (reg->mode.len == 32) {
   238          _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
   239          _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
   240        } else if (reg->mode.len == 16) {
   241          _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
   242          _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
   243        } else if (reg->mode.len == 8) {
   244          _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
   245          _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
   246        } else if (reg->mode.len == 4) {
   247          _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
   248          _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
   249        }
   250      } else if (EQUAL (proc, "read")) {
   251        _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, REAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   252      }
   253    } else if (reg->mode.type == COMPLEX) {
   254      if (EQUAL (proc, "write")) {
   255        NEW_RECORD (fmt);
   256        if (reg->mode.len == 8) {
   257          _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
   258        } else if (reg->mode.len == 16) {
   259          _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
   260        } else if (reg->mode.len == 32) {
   261          _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
   262        } else if (reg->mode.len == 64) {
   263          _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
   264        }
   265        _srecordf (str, "%s = _vif_printf (%s, %s, %s, COMPLEX, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
   266        code (nprocs, BODY, str);
   267        io_event (proc, unit, iorc, endlbl, errlbl);
   268        _srecordf (str, "%s = _vif_printf (%s, \" \", NULL, NOTYPE, 0);\n", iorc, unum (unit));
   269        code (nprocs, BODY, str);
   270        io_event (proc, unit, iorc, endlbl, errlbl);
   271        _srecordf (str, "%s = _vif_printf (%s, %s, %s, COMPLEX, -%d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
   272      } else if (EQUAL (proc, "read")) {
   273        _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, COMPLEX, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   274        code (nprocs, BODY, str);
   275        io_event (proc, unit, iorc, endlbl, errlbl);
   276        _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, COMPLEX, -%d);\n", iorc, unum (unit), elem, reg->mode.len);
   277      }
   278    } else if (reg->mode.type == CHARACTER) {
   279      if (EQUAL (proc, "write")) {
   280  //    _srecordf (str, "%s = _vif_printf (%s, \"%%-%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
   281        _srecordf (str, "%s = _vif_printf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   282      } else if (EQUAL (proc, "read")) {
   283  //    _srecordf (str, "%s = _vif_scanf (%s, \"%%%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
   284        _srecordf (str, "%s = _vif_scanf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
   285      }
   286    }
   287    code (nprocs, BODY, str);
   288    io_event (proc, unit, iorc, endlbl, errlbl);
   289    (*items) ++;
   290  }
   291  
   292  void io_elemf (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
   293  {
   294    NEW_RECORD (elem);
   295    io_parm (reg, elem);
   296    if (reg->mode.type == INTEGER) {
   297      io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "INTEGER", reg->mode.len);
   298      (*items) ++;
   299    } else if (reg->mode.type == LOGICAL) {
   300      io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "LOGICAL", reg->mode.len);
   301      (*items) ++;
   302    } else if (reg->mode.type == REAL) {
   303      io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "REAL", reg->mode.len);
   304      (*items) ++;
   305    } else if (reg->mode.type == COMPLEX) {
   306      io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", reg->mode.len);
   307      io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", -reg->mode.len);
   308      (*items) ++;
   309    } else if (reg->mode.type == CHARACTER) {
   310      io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "CHARACTER", reg->mode.len);
   311      (*items) ++;
   312    }
   313  }
   314  
   315  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)
   316  {
   317    NEW_RECORD (str); NEW_RECORD (tmpa); NEW_RECORD (tmpk);
   318    EXPR elem;
   319    IDENT *ptr;
   320    _srecordf (tmpa, "_arr_%d", nloctmps++);
   321    ptr = add_local (tmpa, reg->mode.type, reg->mode.len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   322    ptr->alias = reg->idf;
   323    _srecordf (tmpk, "_k_%d", nloctmps++);
   324    add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   325    _srecordf (str, "for (%s = %s %s, %s = 0; %s < ", tmpa, ptr_to_array (ptr, NOCONST, CAST, ACTUAL), reg->str, tmpk, tmpk);
   326    code (nprocs, BODY, str);
   327    code_row_len (reg->idf);
   328    _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
   329    code (nprocs, BODY, str);
   330    memcpy (&elem, reg, sizeof (EXPR));
   331    elem.mode.dim = 0;
   332    if (EQUAL (proc, "read")) {
   333      _srecordf (elem.str, "%s", tmpa);
   334    } else if (EQUAL (proc, "write")) {
   335      _srecordf (elem.str, "*%s", tmpa);
   336    } else {
   337      BUG ("io_array");
   338    }
   339    if (form == STDFORMAT) {
   340      io_elemstd (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
   341    } else if (form == FORMATTED) {
   342      io_elemf (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
   343    }
   344    code (nprocs, BODY, "}\n");
   345  }
   346  
   347  void io_elem (char *proc, EXPR *unit, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
   348  {
   349    EXPR reg;
   350    express (&reg, NOTYPE, 0);
   351    if (form == UNFORMATTED) {
   352      io_elemuf (proc, unit, &reg, iorc, endlbl, errlbl, items);
   353    } else if (form == STDFORMAT) {
   354      if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
   355        io_array (proc, unit, &reg, form, fstr, fid, iorc, endlbl, errlbl, items);
   356      } else {
   357        io_elemstd (proc, unit, &reg, fstr, fid, iorc, endlbl, errlbl, items);
   358      }
   359    } else if (form == FORMATTED) {
   360      if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
   361        io_array (proc, unit, &reg, form, fstr, fid, iorc, endlbl, errlbl, items);
   362      } else {
   363        io_elemf (proc, unit, &reg, fstr, fid, iorc, endlbl, errlbl, items);
   364      }
   365    } else {
   366      BUG ("IO formatting unspecified");
   367    }
   368  }
   369  
   370  int_4 impl_do (void)
   371  {
   372  // Quick check whether (...) in a list is an implied DO loop.
   373    int_4 rc, nest = 1;
   374    while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
   375      if (TOKEN ("(")) {
   376        nest++;
   377      } else if (TOKEN (")")) {
   378        nest--;
   379        if (nest == 0) {
   380          return FALSE;
   381        }
   382      } else if (nest == 1 && TOKEN (",")) {
   383  // Trigger is the sequence ", I =" in outer nest.
   384        rc = scan (EXPECT_NONE);
   385        if (rc == WORD) {
   386          NEW_RECORD (name);
   387          RECCPY (name, curlex);
   388          rc = scan (EXPECT_NONE);
   389          if (TOKEN ("=")) {
   390            (void) impl_decl (name, NO_MODE);
   391            return TRUE;
   392          } else {
   393            UNSCAN;
   394          }
   395        }
   396      }
   397    }
   398    (void) rc;
   399    return FALSE;
   400  }
   401  
   402  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)
   403  {
   404    while (WITHIN) {
   405      int_4 rc;
   406      if (TOKEN (",")) {
   407        rc = scan (EXPECT_NONE);
   408        if (! WITHIN) {
   409          SYNTAX (3202, prelex);
   410          break;
   411        }
   412        if (TOKEN (",")) {
   413          SYNTAX (3203, ",,");
   414          continue;
   415        }
   416      } else {
   417        rc = scan (EXPECT_NONE);
   418        if (TOKEN (",")) {
   419          continue;
   420        }
   421      }
   422      if (! WITHIN) {
   423        break;
   424      }
   425      if (TOKEN ("(")) {
   426        SAVE_PRE;
   427  // Quick lookahead.
   428        int_4 loop = impl_do ();
   429  // Restore.
   430        RESTORE_POS;
   431        rc = scan ("(");
   432  // Decide.
   433        if (loop) {
   434          (*nest)++;
   435          int_4 where = code (nprocs, BODY, NO_TEXT);
   436          io_list (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, where, nest, items);
   437        } else {
   438          io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   439          rc = scan (EXPECT_NONE);
   440        }
   441      } else if (TOKEN (")")) {
   442  // Expression closed by ')'
   443        (*nest)--;
   444        return;
   445      } else if (rc == WORD) {
   446        if (*nest == 0) {
   447          io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   448          rc = scan (EXPECT_NONE);
   449        } else {
   450          SAVE_PRE;
   451          rc = scan (EXPECT_NONE);
   452          if (!TOKEN ("=")) {
   453            RESTORE_POS;
   454            rc = scan (EXPECT_NONE);
   455            io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   456            rc = scan (EXPECT_NONE);
   457          } else {
   458            NEW_RECORD (lid); NEW_RECORD (loop);
   459            EXPR from, to, by;
   460            MODE mode;
   461            IDENT *idf = impl_decl (prelex, &mode);
   462            if (idf->arg || idf->alias != NULL) {
   463              _srecordf (lid, "*%s", C_NAME (idf));
   464            } else {
   465             (void) idf_full_c_name (lid, idf);
   466            }
   467            rc = scan (EXPECT_NONE);
   468            express (&from, idf->mode.type, idf->mode.len);
   469            rc = scan (",");
   470            rc = scan (EXPECT_NONE);
   471            express (&to, idf->mode.type, idf->mode.len);
   472            rc = scan (EXPECT_NONE);
   473            if (TOKEN (",")) {
   474              rc = scan (EXPECT_NONE);
   475              express (&by, idf->mode.type, idf->mode.len);
   476              _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", 
   477                        lid, from.str, lid, to.str, lid, by.str);
   478              rc = scan (EXPECT_NONE);
   479            } else {
   480              _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", 
   481                        lid, from.str, lid, to.str, lid);
   482            }
   483            patch (lpatch, loop);
   484            if (TOKEN (")")) {
   485  // Implied DO loop closed by ')'.
   486              (*nest)--;
   487              code (nprocs, BODY, "}; // implied DO \n");
   488            } else {
   489              EXPECT (3204, ")");
   490            }
   491            return;
   492          }
   493        }
   494      } else {
   495        io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   496        rc = scan (EXPECT_NONE);
   497      }
   498    }
   499  }
   500  
   501  void io_unit (EXPR *unit, int_4 defunit)
   502  {
   503  // Reasonable default.
   504    unit->mode.type = INTEGER;
   505    unit->mode.len = 4;
   506  //
   507    if (TOKEN ("*")) {
   508      _srecordf (unit->str, "%d", defunit);
   509    } else if (TOKEN ("stdin")) {
   510      _srecordf (unit->str, "STDF_IN");
   511    } else if (TOKEN ("stdout")) {
   512      _srecordf (unit->str, "STDF_OUT");
   513    } else if (TOKEN ("stderr")) {
   514      _srecordf (unit->str, "STDF_ERR");
   515    } else {
   516      EXPR reg;
   517      express (&reg, NOTYPE, NOLEN);
   518      if (reg.mode.type == INTEGER) {
   519        if (reg.variant == EXPR_CONST) {
   520          _srecordf (unit->str, "%s", reg.str);
   521          int_4 val;
   522          (void) is_int4 (unit->str, &val);
   523          if (val < 1 || val > MAX_FILES - 1) {
   524            ERROR (3205, "unit number out of range", unit->str);
   525          }
   526        } else {
   527          NEW_RECORD (str);
   528          _srecordf (unit->str, "%s", edit_unit (nloctmps++));
   529          add_local (unit->str, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   530          _srecordf (str, "%s = %s;\n", unit, reg.str);
   531          code (nprocs, BODY, str);
   532        }   
   533      } else if (reg.mode.type == CHARACTER) {
   534        (*unit) = reg;
   535      } else {
   536        ERROR (3206, "unit must be INTEGER or CHARACTER", NO_TEXT);
   537      }
   538    }
   539  }
   540  
   541  static void io_specs (char *proc, EXPR *unit, int_4 defunit, EXPR *rec, char *fmt, char **fn, char **form, char **action, int_4 *lrecl, char **disp, LBL **end, LBL **err, char **iostat)
   542  {
   543    int_4 rc, parm = 1;
   544    unit->str[0] = '\0';
   545    fmt[0] = '\0';
   546    *action = action_default;
   547    *disp = disp_old;
   548    *end = NO_LABEL;
   549    *err = NO_LABEL;
   550    *fn = NO_TEXT;
   551    *form = form_unformatted;
   552    *iostat = NO_TEXT;
   553    rec->str[0] = '\0';
   554  // We accept that only a unit specification follows.
   555    if (curret == INT_NUMBER || curret == WORD) {
   556      io_unit (unit, defunit);
   557      return;
   558    }
   559    if (TOKEN ("(")) {
   560      rc = scan (EXPECT_NONE); 
   561    } else {
   562      EXPECT (3207, "(");
   563      return;
   564    }
   565  //
   566    while (!TOKEN (")") && rc != END_OF_MODULE) {
   567  // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str |  DISP=str |  END=n | ERR=n])
   568      if (TOKEN ("unit")) {
   569        rc = scan ("=");
   570        rc = scan (EXPECT_NONE);
   571        io_unit (unit, defunit);
   572      } else if (TOKEN ("rec")) {
   573        rc = scan ("=");
   574        rc = scan (EXPECT_NONE);
   575        express (rec, INTEGER, 4);
   576      } else if (TOKEN ("file")) {
   577        EXPR reg;
   578        rc = scan ("=");
   579        rc = scan (EXPECT_NONE);
   580        if (express (&reg, CHARACTER, NOLEN)) {
   581          *fn = f_stralloc (reg.str);
   582        }
   583      } else if (TOKEN ("form")) {
   584        rc = scan ("=");
   585        rc = scan (EXPECT_NONE);
   586        if (MATCH ("formatted")) {
   587          *form = form_formatted;
   588        } else if (MATCH ("unformatted")) {
   589          *form = form_unformatted;
   590        } else {
   591          SYNTAX (3208, "invalid FORM specification");
   592        }
   593      } else if (TOKEN ("action") || TOKEN ("access")) {
   594        rc = scan ("=");
   595        rc = scan (EXPECT_NONE);
   596        if (MATCH ("read")) {
   597          *action = action_read;
   598        } else if (MATCH ("write")) {
   599          *action = action_write;
   600        } else if (MATCH ("readwrite")) {
   601          *action = action_readwrite;
   602        } else if (MATCH ("direct")) {
   603          *action = action_readwrite;
   604        } else {
   605          SYNTAX (3209, "invalid ACCESS specification");
   606        }
   607      } else if (TOKEN ("disp") || TOKEN ("status")) {
   608  // Straight from JCL :-)
   609        rc = scan ("=");
   610        rc = scan (EXPECT_NONE);
   611        if (MATCH ("old")) {
   612          *disp = disp_old;
   613        } else if (MATCH ("new")) {
   614          *disp = disp_new;
   615        } else if (MATCH ("keep")) {
   616          *disp = disp_keep;
   617        } else if (MATCH ("delete")) {
   618          *disp = disp_delete;
   619        } else if (MATCH ("unknown")) {
   620          *disp = disp_new;
   621        } else {
   622          SYNTAX (3210, "invalid DISP specification");
   623        }
   624      } else if (TOKEN ("lrecl") || TOKEN ("recl")) {
   625        rc = scan ("=");
   626        rc = scan (EXPECT_NONE);
   627        express (rec, INTEGER, 4);
   628      } else if (TOKEN ("fmt")) {
   629        rc = scan ("=");
   630        rc = scan (EXPECT_LABEL);
   631        if (TOKEN ("*")) {
   632          fmt[0] = '\0';
   633          *form = form_formatted;
   634        } else if (rc == WORD || rc == LABEL) {
   635          bufcpy (fmt, curlex, RECLN);
   636          *form = form_formatted;
   637        } else if (rc == TEXT) {
   638          int_4 k = format_str (curlex);
   639          _srecordf (fmt, "%d", k);
   640          *form = form_formatted;
   641        } else {
   642          EXPECT (3211, "label or format string");
   643        }
   644      } else if (TOKEN ("end")) {
   645        rc = scan ("=");
   646        if ((rc = scan (EXPECT_LABEL)) == LABEL) {
   647          if (((*end) = find_label (curlex)) == NO_LABEL) {
   648            ERROR (3212, "no such label", curlex);
   649          }
   650          (*end)->jumped++;
   651        } else {
   652          EXPECT (3213, "label");
   653        }
   654      } else if (TOKEN ("err")) {
   655        rc = scan ("=");
   656        if ((rc = scan (EXPECT_LABEL)) == LABEL) {
   657          if (((*err) = find_label (curlex)) == NO_LABEL) {
   658            ERROR (3214, "no such label", curlex);
   659          }
   660          (*err)->jumped++;
   661        } else {
   662          EXPECT (3215, "label");
   663        }
   664      } else if (TOKEN ("iostat")) {
   665        rc = scan ("=");
   666        rc = scan (EXPECT_NONE);
   667        if (rc != WORD) {
   668          EXPECT (3216, "variable")
   669        } else {
   670          (void) impl_decl (curlex, NO_MODE);
   671          *iostat = f_stralloc (curlex);
   672        }
   673      } else {
   674        if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
   675          if (parm == 1 && rc == INT_NUMBER) {
   676            (void) is_int4 (curlex, lrecl);
   677          } else if (parm == 2 && TOKEN ("*")) {
   678            ;
   679          } else if (parm == 2 && rc == TEXT) {
   680            int_4 k = format_str (curlex);
   681            _srecordf (fmt, "%d", k);
   682          } else if (parm == 2 && (rc == WORD || rc == INT_NUMBER)) {
   683            bufcpy (fmt, curlex, RECLN);
   684          } else if (parm == 3) {
   685            io_unit (unit, defunit);
   686          } else {
   687            SYNTAX (3217, curlex);
   688          }
   689        } else {
   690          if (parm == 1) {
   691            io_unit (unit, defunit);
   692          } else if (parm == 2 && TOKEN ("*")) {
   693            *form = form_formatted;
   694          } else if (parm == 2 && rc == TEXT) {
   695            int_4 k = format_str (curlex);
   696            _srecordf (fmt, "%d", k);
   697            *form = form_formatted;
   698          } else if (parm == 2 && (rc == WORD || rc == INT_NUMBER)) {
   699            bufcpy (fmt, curlex, RECLN);
   700            *form = form_formatted;
   701          } else {
   702            SYNTAX (3218, curlex);
   703          }
   704        }
   705      }
   706  // Next item.
   707      parm++;
   708      rc = scan (EXPECT_NONE); 
   709      if (TOKEN (",")) {
   710        rc = scan (EXPECT_NONE); 
   711      } else if (TOKEN (")")) {
   712        ;
   713      } else {
   714        SYNTAX (3219, curlex);
   715      }
   716    }
   717  }
   718  
   719  void vif_close (void)
   720  {
   721    int_4 rc, lrecl = 0;
   722    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   723    EXPR unit, rec;
   724    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   725    NEW_RECORD (str);
   726    NEW_RECORD (fmt);
   727    rc = scan (EXPECT_NONE);
   728    io_specs ("close", &unit, ERR, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   729    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   730    code (nprocs, BODY, str);
   731    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   732    code (nprocs, BODY, str);
   733    _srecordf (str, "_funregister (\"%s\", %s);\n", stat_start, unum (&unit));
   734    code (nprocs, BODY, str);
   735    if (iostat != NO_TEXT) {
   736      NEW_RECORD (ios);
   737      _srecordf (ios, "%s_ = errno;\n", iostat);
   738      code (nprocs, BODY, ios);
   739    }
   740    code (nprocs, BODY, "if (errno != 0) {\n");
   741    if (errlbl == NO_LABEL) {
   742      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   743    } else {
   744      _srecordf (str, "goto _l%d;\n", errlbl->num);
   745    }
   746    code (nprocs, BODY, str);
   747    code (nprocs, BODY, "}\n");
   748    code (nprocs, BODY, "}\n");
   749    (void) rc;
   750  }
   751  
   752  void vif_endfile (void)
   753  {
   754    int_4 rc, lrecl = 0;
   755    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   756    EXPR unit, rec;
   757    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   758    NEW_RECORD (str);
   759    NEW_RECORD (fmt);
   760    rc = scan (EXPECT_NONE);
   761    io_specs ("endfile", &unit, ERR, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   762    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   763    code (nprocs, BODY, str);
   764    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   765    code (nprocs, BODY, str);
   766    _srecordf (str, "fprintf (_ffile[%s].unit, \"%%c\", EOF);\n", unum (&unit));
   767    code (nprocs, BODY, str);
   768    if (iostat != NO_TEXT) {
   769      NEW_RECORD (ios);
   770      _srecordf (ios, "%s_ = errno;\n", iostat);
   771      code (nprocs, BODY, ios);
   772    }
   773    code (nprocs, BODY, "if (errno != 0) {\n");
   774    if (errlbl == NO_LABEL) {
   775      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   776    } else {
   777      _srecordf (str, "goto _l%d;\n", errlbl->num);
   778    }
   779    code (nprocs, BODY, str);
   780    code (nprocs, BODY, "}\n");
   781    code (nprocs, BODY, "}\n");
   782    (void) rc;
   783  }
   784  
   785  void vif_backspace (void)
   786  {
   787    int_4 rc, lrecl = 0;
   788    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   789    EXPR unit, rec;
   790    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   791    NEW_RECORD (str);
   792    NEW_RECORD (fmt);
   793    rc = scan (EXPECT_NONE);
   794    io_specs ("backspace", &unit, ERR, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   795    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   796    code (nprocs, BODY, str);
   797    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   798    code (nprocs, BODY, str);
   799    _srecordf (str, "_backspace (\"%s\", %s);\n", stat_start, unum (&unit));
   800    code (nprocs, BODY, str);
   801    if (iostat != NO_TEXT) {
   802      NEW_RECORD (ios);
   803      _srecordf (ios, "%s_ = errno;\n", iostat);
   804      code (nprocs, BODY, ios);
   805    }
   806    code (nprocs, BODY, "if (errno != 0) {\n");
   807    if (errlbl == NO_LABEL) {
   808      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   809    } else {
   810      _srecordf (str, "goto _l%d;\n", errlbl->num);
   811    }
   812    code (nprocs, BODY, str);
   813    code (nprocs, BODY, "}\n");
   814    code (nprocs, BODY, "}\n");
   815    (void) rc;
   816  }
   817  
   818  void vif_rewind (void)
   819  {
   820    int_4 rc, lrecl = 0;
   821    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   822    EXPR unit, rec;
   823    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   824    NEW_RECORD (str);
   825    NEW_RECORD (fmt);
   826    rc = scan (EXPECT_NONE);
   827    io_specs ("rewind", &unit, ERR, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   828    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   829    code (nprocs, BODY, str);
   830    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   831    code (nprocs, BODY, str);
   832    _srecordf (str, "_rewind (\"%s\", %s);\n", stat_start, unum (&unit));
   833    code (nprocs, BODY, str);
   834    if (iostat != NO_TEXT) {
   835      NEW_RECORD (ios);
   836      _srecordf (ios, "%s_ = errno;\n", iostat);
   837      code (nprocs, BODY, ios);
   838    }
   839    code (nprocs, BODY, "if (errno != 0) {\n");
   840    if (errlbl == NO_LABEL) {
   841      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   842    } else {
   843      _srecordf (str, "goto _l%d;\n", errlbl->num);
   844    }
   845    code (nprocs, BODY, str);
   846    code (nprocs, BODY, "}\n");
   847    code (nprocs, BODY, "}\n");
   848    (void) rc;
   849  }
   850  
   851  void vif_open (void)
   852  {
   853    int_4 rc, lrecl = 0;
   854    char *daction = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *ddisp = NO_TEXT, *iostat = NO_TEXT;
   855    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   856    EXPR unit, rec;
   857    NEW_RECORD (str);
   858    NEW_RECORD (fmt);
   859    rc = scan (EXPECT_NONE);
   860    io_specs ("open", &unit, ERR, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   861    if (dfn != NO_TEXT) {
   862      _srecordf (str, "_fregister (\"%s\", %s, %d, %s, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dfn, dform, daction, ddisp);
   863    } else {
   864      _srecordf (str, "_fregister (\"%s\", %s, %d, NULL, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dform, daction, ddisp);
   865    }
   866    code (nprocs, BODY, str);
   867    if (iostat != NO_TEXT) {
   868      NEW_RECORD (ios);
   869      _srecordf (ios, "%s_ = errno;\n", iostat);
   870      code (nprocs, BODY, ios);
   871    }
   872    (void) rc;
   873  }
   874  
   875  void io_open_internal (EXPR *unit, char *acc)
   876  {
   877    if (unit->mode.type != CHARACTER) {
   878      ERROR (3220, "unit type must be CHARACTER", unit->str);
   879    } else if (unit->variant == EXPR_CONST) {
   880      ERROR (3221, "unit must be CHARACTER variable", unit->str);
   881    } else {
   882      int N = unit->mode.len, M = 1;
   883      if (unit->idf->mode.dim == 0) {
   884        ;
   885      } else {
   886        NEW_RECORD (len);
   887        compute_row_size (len, unit->idf);
   888        if (! is_int4 (len, &M)) {
   889          ERROR (3222, "size must be integer constant", len);
   890        }
   891        if (M > 1) {
   892          N *= M;
   893        }
   894      }
   895      NEW_RECORD (str);
   896      _srecordf (str, "_ffile[0].buff = _ffile[0].rewind = (char *) (%s);\n", unit->str);
   897      code (nprocs, BODY, str);
   898      _srecordf (str, "_ffile[0].lrecl = %d;\n", unit->mode.len);
   899      code (nprocs, BODY, str);
   900      _srecordf (str, "_ffile[0].record = 0;\n");
   901      code (nprocs, BODY, str);
   902      _srecordf (str, "_ffile[0].records = %d;\n", M);
   903      code (nprocs, BODY, str);
   904      _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"%s\");\n", unit->str, N, acc);
   905      code (nprocs, BODY, str);
   906      _srecordf (str, "_ffile[0].buff_init = FALSE;\n");
   907      code (nprocs, BODY, str);
   908    }
   909  }
   910  
   911  void do_io (char *proc, int_4 *nest)
   912  {
   913    int_4 form = UNFORMATTED, lrecl = 0;
   914    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   915    NEW_RECORD (fstr);
   916    NEW_RECORD (fid);
   917    NEW_RECORD (iorc);
   918    NEW_RECORD (str);
   919    NEW_RECORD (fmt);
   920    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   921    EXPR unit, rec;
   922    unit.mode.type = INTEGER;
   923    unit.mode.len = 4;
   924    fmt[0] = '\0';
   925    fstr[0] = '\0';
   926    fid[0] = '\0';
   927    iorc[0] = '\0';
   928    rec.str[0] = '\0';
   929    int_4 rc = scan (EXPECT_NONE);
   930    if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
   931      if (TOKEN ("*")) {
   932        _srecordf (unit.str, "STDF_IN");
   933        dform = form_formatted;
   934        rc = scan (EXPECT_NONE);
   935      } else if (rc == INT_NUMBER) { // FORTRAN II
   936        _srecordf (unit.str, "STDF_IN");
   937        bufcpy (fmt, curlex, RECLN);
   938        dform = form_formatted;
   939        rc = scan (EXPECT_NONE);
   940      } else if (rc == TEXT) {
   941        _srecordf (unit.str, "STDF_IN");
   942        int_4 k = format_str (curlex);
   943        _srecordf (fmt, "%d", k);
   944        dform = form_formatted;
   945        rc = scan (EXPECT_NONE);
   946      } else {
   947        io_specs (proc, &unit, STDF_IN, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   948      }
   949    } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
   950      if (TOKEN ("*")) {
   951        _srecordf (unit.str, "STDF_OUT");
   952        dform = form_formatted;
   953        rc = scan (EXPECT_NONE);
   954      } else if (rc == INT_NUMBER) { // FORTRAN II
   955        _srecordf (unit.str, "STDF_OUT");
   956        bufcpy (fmt, curlex, RECLN);
   957        dform = form_formatted;
   958        rc = scan (EXPECT_NONE);
   959      } else if (rc == TEXT) {
   960        _srecordf (unit.str, "STDF_OUT");
   961        int_4 k = format_str (curlex);
   962        _srecordf (fmt, "%d", k);
   963        dform = form_formatted;
   964        rc = scan (EXPECT_NONE);
   965      } else {
   966        io_specs (proc, &unit, STDF_OUT, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   967      }
   968    } else if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
   969      io_specs (proc, &unit, STDF_OUT, &rec, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   970      ddisp = disp_old;
   971      dfn = NO_TEXT;
   972      iostat = NO_TEXT;
   973      dform = form_formatted;
   974      if (EQUAL (proc, "encode")) {
   975        proc = "write";
   976        daction = action_write;
   977      } else if (EQUAL (proc, "decode")) {
   978        proc = "read";
   979        daction = action_read;
   980      }
   981    }
   982    if (strlen (fmt) == 0 && dform != form_unformatted) {
   983      form = STDFORMAT;
   984    } else if (strlen (fmt) == 0 && dform == form_unformatted) {
   985      form = UNFORMATTED;
   986    } else {
   987      form = FORMATTED;
   988    }
   989  // IO to a string implies UNIT=0.
   990    if (unit.mode.type == CHARACTER) {
   991      if (EQUAL (proc, "read")) {
   992        io_open_internal (&unit, "r");
   993      } else if (EQUAL (proc, "accept")) {
   994        io_open_internal (&unit, "r");
   995      } else if (EQUAL (proc, "write")) {
   996        io_open_internal (&unit, "w");
   997      } else if (EQUAL (proc, "print")) {
   998        io_open_internal (&unit, "w");
   999      } else if (EQUAL (proc, "punch")) {
  1000        io_open_internal (&unit, "w");
  1001      }
  1002    }
  1003  // Runtime checks - can the file do this?
  1004    if (EQUAL (proc, "read")) {
  1005      _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
  1006    } else if (EQUAL (proc, "accept")) {
  1007      _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
  1008    } else if (EQUAL (proc, "write")) {
  1009      _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  1010    } else if (EQUAL (proc, "print")) {
  1011      _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  1012    } else if (EQUAL (proc, "punch")) {
  1013      _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  1014    }
  1015    code (nprocs, BODY, str);
  1016  // Set record.
  1017    if (strlen (rec.str) > 0) {
  1018      _srecordf (str, "_set_record (\"%s\", %s, %s);\n", stat_start, unum (&unit), rec.str);
  1019      code (nprocs, BODY, str);
  1020    }
  1021  // Formats.
  1022    if (form == FORMATTED) {
  1023      NEW_RECORD (fcnt);
  1024      int_4 val;
  1025      _srecordf (fid, "__fcnt");
  1026      add_local (fid, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  1027      _srecordf (iorc, "__rc");
  1028      add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  1029      _srecordf (fcnt, "%s = 0;\n", fid);
  1030      code (nprocs, BODY, fcnt);
  1031      if (is_int4 (fmt, &val)) {
  1032        _srecordf (fstr, "%s", edit_fmt (val));
  1033      } else {
  1034        MODE mode;
  1035        IDENT *idf = find_local (fmt, &mode);
  1036        if (idf == NO_IDENT) {
  1037          ERROR (3223, "undeclared format identifier", fmt);
  1038        } else if (mode.type == INTEGER) {
  1039  // Assigned FORMAT.
  1040          _srecordf (str, "switch (%s) {\n", C_NAME (idf));
  1041          code (nprocs, BODY, str);
  1042          code (nprocs, BODY, "default:\n");
  1043          for (int_4 k = 0; k < nlabels; k++) {
  1044            LBL *L = &labels[k];
  1045            if (L->format) {
  1046              L->jumped++;
  1047              _srecordf (str, "case %d: __fmt_a = %s; break;\n", L->index, edit_fmt(L->num));
  1048              code (nprocs, BODY, str);
  1049            }
  1050          }
  1051          code (nprocs, BODY, "}\n");
  1052          RECCPY (fstr, "__fmt_a");
  1053        } else if (mode.type == CHARACTER) {
  1054          _srecordf (str, "__fmt_a = _vif_jit (\"%s\", %s);\n", stat_start, C_NAME (idf));
  1055          code (nprocs, BODY, str);
  1056          RECCPY (fstr, "__fmt_a");
  1057        } else {
  1058          ERROR (3224, "format identifier mode error", qtype (&mode));
  1059        }
  1060      }
  1061    } else {
  1062      _srecordf (iorc, "__rc_%d", nloctmps++);
  1063      add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  1064    }
  1065  // Start-of-record.
  1066    if (form == FORMATTED) {
  1067      if (EQUAL (proc, "read")) {
  1068        io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1069      } else if (EQUAL (proc, "accept")) {
  1070        io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1071      } else if (EQUAL (proc, "write")) {
  1072        io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1073      } else if (EQUAL (proc, "print")) {
  1074        io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1075      } else if (EQUAL (proc, "punch")) {
  1076        io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1077      }
  1078    }
  1079    int_4 items = 0;
  1080    if (EQUAL (proc, "read")) {
  1081      io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1082    } else if (EQUAL (proc, "accept")) {
  1083      io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1084    } else if (EQUAL (proc, "write")) {
  1085      io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1086    } else if (EQUAL (proc, "print")) {
  1087      io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1088    } else if (EQUAL (proc, "punch")) {
  1089      io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1090    }
  1091    if (unit.mode.type == CHARACTER) {
  1092  // IO to a string implies UNIT=0.
  1093  //  code (nprocs, BODY, "_fclose (0);\n");
  1094    } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
  1095  // End-of-record.
  1096      if (form != UNFORMATTED) {
  1097        _srecordf (str, "_write_eol (%s);\n", unum (&unit));
  1098        code (nprocs, BODY, str);
  1099      }
  1100    } else if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
  1101  // End-of-record.
  1102      if (form != UNFORMATTED) {
  1103        _srecordf (str, "_read_eol (%s);\n", unum (&unit));
  1104        code (nprocs, BODY, str);
  1105      }
  1106    }
  1107  //
  1108    save_iostat (iostat);
  1109  //
  1110    (void) rc;
  1111  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

This website is archived by the National Library of the Netherlands.