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 (3301, 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 (3302, prelex);
   410          break;
   411        }
   412        if (TOKEN (",")) {
   413          SYNTAX (3303, ",,");
   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_POS (1);
   427  // Quick lookahead.
   428        int_4 loop = impl_do ();
   429  // Restore.
   430        RESTORE_POS (1);
   431        UNSCAN;
   432        rc = scan ("(");
   433  // Decide.
   434        if (loop) {
   435          (*nest)++;
   436          int_4 where = code (nprocs, BODY, NO_TEXT);
   437          io_list (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, where, nest, items);
   438        } else {
   439          io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   440          rc = scan (EXPECT_NONE);
   441        }
   442      } else if (TOKEN (")")) {
   443  // Expression closed by ')'
   444        (*nest)--;
   445        return;
   446      } else if (rc == WORD) {
   447        if (*nest == 0) {
   448          io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   449          rc = scan (EXPECT_NONE);
   450        } else {
   451          SAVE_POS (2);
   452          rc = scan (EXPECT_NONE);
   453          if (!TOKEN ("=")) {
   454            RESTORE_POS (2);
   455            UNSCAN;
   456            rc = scan (EXPECT_NONE);
   457            io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   458            rc = scan (EXPECT_NONE);
   459          } else {
   460            NEW_RECORD (lid); NEW_RECORD (loop);
   461            EXPR from, to, by;
   462            MODE mode;
   463            IDENT *idf = impl_decl (prelex, &mode);
   464            if (idf->arg || idf->alias != NULL) {
   465              _srecordf (lid, "*%s", C_NAME (idf));
   466            } else {
   467             (void) idf_full_c_name (lid, idf);
   468            }
   469            rc = scan (EXPECT_NONE);
   470            express (&from, idf->mode.type, idf->mode.len);
   471            rc = scan (",");
   472            rc = scan (EXPECT_NONE);
   473            express (&to, idf->mode.type, idf->mode.len);
   474            rc = scan (EXPECT_NONE);
   475            if (TOKEN (",")) {
   476              rc = scan (EXPECT_NONE);
   477              express (&by, idf->mode.type, idf->mode.len);
   478              _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", 
   479                        lid, from.str, lid, to.str, lid, by.str);
   480              rc = scan (EXPECT_NONE);
   481            } else {
   482              _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", 
   483                        lid, from.str, lid, to.str, lid);
   484            }
   485            patch (lpatch, loop);
   486            if (TOKEN (")")) {
   487  // Implied DO loop closed by ')'.
   488              (*nest)--;
   489              code (nprocs, BODY, "}; // implied DO \n");
   490            } else {
   491              EXPECT (3304, ")");
   492            }
   493            return;
   494          }
   495        }
   496      } else {
   497        io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
   498        rc = scan (EXPECT_NONE);
   499      }
   500    }
   501  }
   502  
   503  void io_unit (EXPR *unit, int_4 defunit)
   504  {
   505  // Reasonable default.
   506    unit->mode.type = INTEGER;
   507    unit->mode.len = 4;
   508  //
   509    if (TOKEN ("*")) {
   510      _srecordf (unit->str, "%d", defunit);
   511    } else if (TOKEN ("stdin")) {
   512      _srecordf (unit->str, "STDF_IN");
   513    } else if (TOKEN ("stdout")) {
   514      _srecordf (unit->str, "STDF_OUT");
   515    } else if (TOKEN ("stderr")) {
   516      _srecordf (unit->str, "STDF_ERR");
   517    } else {
   518      EXPR reg;
   519      express (&reg, NOTYPE, NOLEN);
   520      if (reg.mode.type == INTEGER) {
   521        if (reg.variant == EXPR_CONST) {
   522          _srecordf (unit->str, "%s", reg.str);
   523          int_4 val;
   524          (void) is_int4 (unit->str, &val);
   525          if (val < 1 || val > MAX_FILES - 1) {
   526            ERROR (3305, "unit number out of range", unit->str);
   527          }
   528        } else {
   529          NEW_RECORD (str);
   530          _srecordf (unit->str, "%s", edit_unit (nloctmps++));
   531          add_local (unit->str, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
   532          _srecordf (str, "%s = %s;\n", unit, reg.str);
   533          code (nprocs, BODY, str);
   534        }   
   535      } else if (reg.mode.type == CHARACTER) {
   536        (*unit) = reg;
   537      } else {
   538        ERROR (3306, "unit must be INTEGER or CHARACTER", NO_TEXT);
   539      }
   540    }
   541  }
   542  
   543  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)
   544  {
   545    int_4 rc, parm = 1;
   546    RECCLR (unit->str);
   547    RECCLR (rec->str);
   548    RECCLR (fmt->str);
   549    *action = action_default;
   550    *disp = disp_old;
   551    *end = NO_LABEL;
   552    *err = NO_LABEL;
   553    *fn = NO_TEXT;
   554    *form = form_unformatted;
   555    *iostat = NO_TEXT;
   556    rec->str[0] = '\0';
   557  // We accept that only a unit specification follows.
   558    if (curret == INT_NUMBER || curret == WORD) {
   559      io_unit (unit, defunit);
   560      return;
   561    }
   562    if (TOKEN ("(")) {
   563      rc = scan (EXPECT_NONE); 
   564    } else {
   565      EXPECT (3307, "(");
   566      return;
   567    }
   568  //
   569    while (!TOKEN (")") && rc != END_OF_MODULE) {
   570  // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str |  DISP=str |  END=n | ERR=n])
   571      if (TOKEN ("unit") && lookahead ("=")) {
   572        rc = scan ("=");
   573        rc = scan (EXPECT_NONE);
   574        io_unit (unit, defunit);
   575      } else if (TOKEN ("rec") && lookahead ("=")) {
   576        rc = scan ("=");
   577        rc = scan (EXPECT_NONE);
   578        express (rec, INTEGER, 4);
   579      } else if (TOKEN ("file") && lookahead ("=")) {
   580        EXPR reg;
   581        rc = scan ("=");
   582        rc = scan (EXPECT_NONE);
   583        if (express (&reg, CHARACTER, NOLEN)) {
   584          *fn = f_stralloc (reg.str);
   585        }
   586      } else if (TOKEN ("form") && lookahead ("=")) {
   587        rc = scan ("=");
   588        rc = scan (EXPECT_NONE);
   589        if (MATCH ("formatted")) {
   590          *form = form_formatted;
   591        } else if (MATCH ("unformatted")) {
   592          *form = form_unformatted;
   593        } else {
   594          SYNTAX (3308, "invalid FORM specification");
   595        }
   596      } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
   597        rc = scan ("=");
   598        rc = scan (EXPECT_NONE);
   599        if (MATCH ("read")) {
   600          *action = action_read;
   601        } else if (MATCH ("write")) {
   602          *action = action_write;
   603        } else if (MATCH ("readwrite")) {
   604          *action = action_readwrite;
   605        } else if (MATCH ("direct")) {
   606          *action = action_readwrite;
   607        } else {
   608          SYNTAX (3309, "invalid ACCESS specification");
   609        }
   610      } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
   611  // Straight from JCL :-)
   612        rc = scan ("=");
   613        rc = scan (EXPECT_NONE);
   614        if (MATCH ("old")) {
   615          *disp = disp_old;
   616        } else if (MATCH ("new")) {
   617          *disp = disp_new;
   618        } else if (MATCH ("keep")) {
   619          *disp = disp_keep;
   620        } else if (MATCH ("delete")) {
   621          *disp = disp_delete;
   622        } else if (MATCH ("unknown")) {
   623          *disp = disp_new;
   624        } else {
   625          SYNTAX (3310, "invalid DISP specification");
   626        }
   627      } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
   628        rc = scan ("=");
   629        rc = scan (EXPECT_NONE);
   630        express (rec, INTEGER, 4);
   631      } else if (TOKEN ("fmt") && lookahead ("=")) {
   632        rc = scan ("=");
   633        rc = scan (EXPECT_NONE);
   634        if (TOKEN ("*")) {
   635          *form = form_formatted;
   636        } else if (rc == INT_NUMBER) {
   637          bufcpy (fmt->str, curlex, RECLN);
   638          fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   639          *form = form_formatted;
   640        } else if (rc == WORD) {
   641          express (fmt, NOTYPE, NOLEN);
   642          *form = form_formatted;
   643        } else if (rc == TEXT) {
   644          int_4 k = format_str (curlex);
   645          _srecordf (fmt->str, "%d", k);
   646          fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   647          *form = form_formatted;
   648        } else {
   649          EXPECT (3311, "label or format string");
   650        }
   651      } else if (TOKEN ("end") && lookahead ("=")) {
   652        rc = scan ("=");
   653        if ((rc = scan (EXPECT_LABEL)) == LABEL) {
   654          if (((*end) = find_label (curlex)) == NO_LABEL) {
   655            ERROR (3312, "no such label", curlex);
   656          }
   657          (*end)->jumped++;
   658        } else {
   659          EXPECT (3313, "label");
   660        }
   661      } else if (TOKEN ("err") && lookahead ("=")) {
   662        rc = scan ("=");
   663        if ((rc = scan (EXPECT_LABEL)) == LABEL) {
   664          if (((*err) = find_label (curlex)) == NO_LABEL) {
   665            ERROR (3314, "no such label", curlex);
   666          }
   667          (*err)->jumped++;
   668        } else {
   669          EXPECT (3315, "label");
   670        }
   671      } else if (TOKEN ("iostat") && lookahead ("=")) {
   672        rc = scan ("=");
   673        rc = scan (EXPECT_NONE);
   674        if (rc != WORD) {
   675          EXPECT (3316, "variable")
   676        } else {
   677          (void) impl_decl (curlex, NO_MODE);
   678          *iostat = f_stralloc (curlex);
   679        }
   680      } else {
   681        if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
   682          if (parm == 1 && rc == INT_NUMBER) {
   683            (void) is_int4 (curlex, lrecl);
   684          } else if (parm == 2 && TOKEN ("*")) {
   685            ;
   686          } else if (parm == 2 && rc == WORD) {
   687            express (fmt, NOTYPE, NOLEN);
   688            *form = form_formatted;
   689          } else if (parm == 2 && rc == TEXT) {
   690            int_4 k = format_str (curlex);
   691            _srecordf (fmt->str, "%d", k);
   692            fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   693          } else if (parm == 2 && rc == INT_NUMBER) {
   694            bufcpy (fmt->str, curlex, RECLN);
   695            fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   696          } else if (parm == 3) {
   697            io_unit (unit, defunit);
   698          } else {
   699            SYNTAX (3317, curlex);
   700          }
   701        } else {
   702          if (parm == 1) {
   703            io_unit (unit, defunit);
   704          } else if (parm == 2 && TOKEN ("*")) {
   705            *form = form_formatted;
   706          } else if (parm == 2 && rc == WORD) {
   707            express (fmt, NOTYPE, NOLEN);
   708            *form = form_formatted;
   709          } else if (parm == 2 && rc == TEXT) {
   710            int_4 k = format_str (curlex);
   711            _srecordf (fmt->str, "%d", k);
   712            fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   713            *form = form_formatted;
   714          } else if (parm == 2 && rc == INT_NUMBER) {
   715            bufcpy (fmt->str, curlex, RECLN);
   716            fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   717            *form = form_formatted;
   718          } else {
   719            SYNTAX (3318, curlex);
   720          }
   721        }
   722      }
   723  // Next item.
   724      parm++;
   725      rc = scan (EXPECT_NONE); 
   726      if (TOKEN (",")) {
   727        rc = scan (EXPECT_NONE); 
   728      } else if (TOKEN (")")) {
   729        ;
   730      } else {
   731        SYNTAX (3319, curlex);
   732      }
   733    }
   734  }
   735  
   736  void vif_close (void)
   737  {
   738    int_4 rc, lrecl = 0;
   739    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   740    EXPR unit, rec, fmt;
   741    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   742    NEW_RECORD (str);
   743    rc = scan (EXPECT_NONE);
   744    io_specs ("close", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   745    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   746    code (nprocs, BODY, str);
   747    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   748    code (nprocs, BODY, str);
   749    _srecordf (str, "_funregister (\"%s\", %s);\n", stat_start, unum (&unit));
   750    code (nprocs, BODY, str);
   751    if (iostat != NO_TEXT) {
   752      NEW_RECORD (ios);
   753      _srecordf (ios, "%s_ = errno;\n", iostat);
   754      code (nprocs, BODY, ios);
   755    }
   756    code (nprocs, BODY, "if (errno != 0) {\n");
   757    if (errlbl == NO_LABEL) {
   758      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   759    } else {
   760      _srecordf (str, "goto _l%d;\n", errlbl->num);
   761    }
   762    code (nprocs, BODY, str);
   763    code (nprocs, BODY, "}\n");
   764    code (nprocs, BODY, "}\n");
   765    (void) rc;
   766  }
   767  
   768  void vif_endfile (void)
   769  {
   770    int_4 rc, lrecl = 0;
   771    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   772    EXPR unit, rec, fmt;
   773    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   774    NEW_RECORD (str);
   775    rc = scan (EXPECT_NONE);
   776    io_specs ("endfile", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   777    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   778    code (nprocs, BODY, str);
   779    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   780    code (nprocs, BODY, str);
   781    _srecordf (str, "fprintf (_ffile[%s].unit, \"%%c\", EOF);\n", unum (&unit));
   782    code (nprocs, BODY, str);
   783    if (iostat != NO_TEXT) {
   784      NEW_RECORD (ios);
   785      _srecordf (ios, "%s_ = errno;\n", iostat);
   786      code (nprocs, BODY, ios);
   787    }
   788    code (nprocs, BODY, "if (errno != 0) {\n");
   789    if (errlbl == NO_LABEL) {
   790      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   791    } else {
   792      _srecordf (str, "goto _l%d;\n", errlbl->num);
   793    }
   794    code (nprocs, BODY, str);
   795    code (nprocs, BODY, "}\n");
   796    code (nprocs, BODY, "}\n");
   797    (void) rc;
   798  }
   799  
   800  void vif_backspace (void)
   801  {
   802    int_4 rc, lrecl = 0;
   803    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   804    EXPR unit, rec, fmt;
   805    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   806    NEW_RECORD (str);
   807    rc = scan (EXPECT_NONE);
   808    io_specs ("backspace", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   809    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   810    code (nprocs, BODY, str);
   811    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   812    code (nprocs, BODY, str);
   813    _srecordf (str, "_backspace (\"%s\", %s);\n", stat_start, unum (&unit));
   814    code (nprocs, BODY, str);
   815    if (iostat != NO_TEXT) {
   816      NEW_RECORD (ios);
   817      _srecordf (ios, "%s_ = errno;\n", iostat);
   818      code (nprocs, BODY, ios);
   819    }
   820    code (nprocs, BODY, "if (errno != 0) {\n");
   821    if (errlbl == NO_LABEL) {
   822      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   823    } else {
   824      _srecordf (str, "goto _l%d;\n", errlbl->num);
   825    }
   826    code (nprocs, BODY, str);
   827    code (nprocs, BODY, "}\n");
   828    code (nprocs, BODY, "}\n");
   829    (void) rc;
   830  }
   831  
   832  void vif_rewind (void)
   833  {
   834    int_4 rc, lrecl = 0;
   835    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   836    EXPR unit, rec, fmt;
   837    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   838    NEW_RECORD (str);
   839    rc = scan (EXPECT_NONE);
   840    io_specs ("rewind", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   841    _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
   842    code (nprocs, BODY, str);
   843    _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
   844    code (nprocs, BODY, str);
   845    _srecordf (str, "_rewind (\"%s\", %s);\n", stat_start, unum (&unit));
   846    code (nprocs, BODY, str);
   847    if (iostat != NO_TEXT) {
   848      NEW_RECORD (ios);
   849      _srecordf (ios, "%s_ = errno;\n", iostat);
   850      code (nprocs, BODY, ios);
   851    }
   852    code (nprocs, BODY, "if (errno != 0) {\n");
   853    if (errlbl == NO_LABEL) {
   854      _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
   855    } else {
   856      _srecordf (str, "goto _l%d;\n", errlbl->num);
   857    }
   858    code (nprocs, BODY, str);
   859    code (nprocs, BODY, "}\n");
   860    code (nprocs, BODY, "}\n");
   861    (void) rc;
   862  }
   863  
   864  void vif_open (void)
   865  {
   866    int_4 rc, lrecl = 0;
   867    char *daction = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *ddisp = NO_TEXT, *iostat = NO_TEXT;
   868    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   869    EXPR unit, rec, fmt;
   870    NEW_RECORD (str);
   871    rc = scan (EXPECT_NONE);
   872    io_specs ("open", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   873    if (dfn != NO_TEXT) {
   874      _srecordf (str, "_fregister (\"%s\", %s, %d, %s, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dfn, dform, daction, ddisp);
   875    } else {
   876      _srecordf (str, "_fregister (\"%s\", %s, %d, NULL, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dform, daction, ddisp);
   877    }
   878    code (nprocs, BODY, str);
   879    if (iostat != NO_TEXT) {
   880      NEW_RECORD (ios);
   881      _srecordf (ios, "%s_ = errno;\n", iostat);
   882      code (nprocs, BODY, ios);
   883    }
   884    (void) rc;
   885  }
   886  
   887  void io_open_internal (EXPR *unit, char *acc)
   888  {
   889    if (unit->mode.type != CHARACTER) {
   890      ERROR (3320, "unit type must be CHARACTER", unit->str);
   891    } else if (unit->variant == EXPR_CONST) {
   892      ERROR (3321, "unit must be CHARACTER variable", unit->str);
   893    } else {
   894      int N = unit->mode.len, M = 1;
   895      if (unit->idf->mode.dim == 0) {
   896        ;
   897      } else {
   898        NEW_RECORD (len);
   899        compute_row_size (len, unit->idf);
   900        if (! is_int4 (len, &M)) {
   901          ERROR (3322, "size must be integer constant", len);
   902        }
   903        if (M > 1) {
   904          N *= M;
   905        }
   906      }
   907      NEW_RECORD (str);
   908      _srecordf (str, "_ffile[0].buff = _ffile[0].rewind = (char *) (%s);\n", unit->str);
   909      code (nprocs, BODY, str);
   910      _srecordf (str, "_ffile[0].lrecl = %d;\n", unit->mode.len);
   911      code (nprocs, BODY, str);
   912      _srecordf (str, "_ffile[0].record = 0;\n");
   913      code (nprocs, BODY, str);
   914      _srecordf (str, "_ffile[0].records = %d;\n", M);
   915      code (nprocs, BODY, str);
   916      _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"%s\");\n", unit->str, N, acc);
   917      code (nprocs, BODY, str);
   918      _srecordf (str, "_ffile[0].buff_init = FALSE;\n");
   919      code (nprocs, BODY, str);
   920    }
   921  }
   922  
   923  void do_io (char *proc, int_4 *nest)
   924  {
   925    int_4 form = UNFORMATTED, lrecl = 0;
   926    LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
   927    NEW_RECORD (fstr);
   928    NEW_RECORD (fid);
   929    NEW_RECORD (iorc);
   930    NEW_RECORD (str);
   931    char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
   932    EXPR unit, rec, fmt;
   933    RECCLR (fmt.str);
   934    unit.mode.type = INTEGER;
   935    unit.mode.len = 4;
   936    fstr[0] = '\0';
   937    fid[0] = '\0';
   938    iorc[0] = '\0';
   939    rec.str[0] = '\0';
   940    int_4 rc = scan (EXPECT_NONE);
   941    if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
   942      if (TOKEN ("*")) {
   943        _srecordf (unit.str, "STDF_IN");
   944        dform = form_formatted;
   945        rc = scan (EXPECT_NONE);
   946      } else if (rc == INT_NUMBER) { // FORTRAN II
   947        _srecordf (unit.str, "STDF_IN");
   948        bufcpy (fmt.str, curlex, RECLN);
   949        fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   950        dform = form_formatted;
   951        rc = scan (EXPECT_NONE);
   952      } else if (rc == TEXT) {
   953        _srecordf (unit.str, "STDF_IN");
   954        int_4 k = format_str (curlex);
   955        _srecordf (fmt.str, "%d", k);
   956        fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   957        dform = form_formatted;
   958        rc = scan (EXPECT_NONE);
   959      } else {
   960        io_specs (proc, &unit, STDF_IN, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   961      }
   962    } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
   963      if (TOKEN ("*")) {
   964        _srecordf (unit.str, "STDF_OUT");
   965        dform = form_formatted;
   966        rc = scan (EXPECT_NONE);
   967      } else if (rc == INT_NUMBER) { // FORTRAN II
   968        _srecordf (unit.str, "STDF_OUT");
   969        bufcpy (fmt.str, curlex, RECLN);
   970        fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   971        dform = form_formatted;
   972        rc = scan (EXPECT_NONE);
   973      } else if (rc == TEXT) {
   974        _srecordf (unit.str, "STDF_OUT");
   975        int_4 k = format_str (curlex);
   976        _srecordf (fmt.str, "%d", k);
   977        fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
   978        dform = form_formatted;
   979        rc = scan (EXPECT_NONE);
   980      } else {
   981        io_specs (proc, &unit, STDF_OUT, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   982      }
   983    } else if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
   984      io_specs (proc, &unit, STDF_OUT, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
   985      ddisp = disp_old;
   986      dfn = NO_TEXT;
   987      iostat = NO_TEXT;
   988      dform = form_formatted;
   989      if (EQUAL (proc, "encode")) {
   990        proc = "write";
   991        daction = action_write;
   992      } else if (EQUAL (proc, "decode")) {
   993        proc = "read";
   994        daction = action_read;
   995      }
   996    }
   997    if (strlen (fmt.str) == 0 && dform != form_unformatted) {
   998      form = STDFORMAT;
   999    } else if (strlen (fmt.str) == 0 && dform == form_unformatted) {
  1000      form = UNFORMATTED;
  1001    } else {
  1002      form = FORMATTED;
  1003    }
  1004  // IO to a string implies UNIT=0.
  1005    if (unit.mode.type == CHARACTER) {
  1006      if (EQUAL (proc, "read")) {
  1007        io_open_internal (&unit, "r");
  1008      } else if (EQUAL (proc, "accept")) {
  1009        io_open_internal (&unit, "r");
  1010      } else if (EQUAL (proc, "write")) {
  1011        io_open_internal (&unit, "w");
  1012      } else if (EQUAL (proc, "print")) {
  1013        io_open_internal (&unit, "w");
  1014      } else if (EQUAL (proc, "punch")) {
  1015        io_open_internal (&unit, "w");
  1016      }
  1017    }
  1018  // Runtime checks - can the file do this?
  1019    if (EQUAL (proc, "read")) {
  1020      _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
  1021    } else if (EQUAL (proc, "accept")) {
  1022      _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
  1023    } else if (EQUAL (proc, "write")) {
  1024      _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  1025    } else if (EQUAL (proc, "print")) {
  1026      _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  1027    } else if (EQUAL (proc, "punch")) {
  1028      _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
  1029    }
  1030    code (nprocs, BODY, str);
  1031  // Set record.
  1032    if (strlen (rec.str) > 0) {
  1033      _srecordf (str, "_set_record (\"%s\", %s, %s);\n", stat_start, unum (&unit), rec.str);
  1034      code (nprocs, BODY, str);
  1035    }
  1036  // Formats.
  1037    if (form == FORMATTED) {
  1038      NEW_RECORD (fcnt);
  1039      int_4 val;
  1040      _srecordf (fid, "__fcnt");
  1041      add_local (fid, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  1042      _srecordf (iorc, "__rc");
  1043      add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  1044      _srecordf (fcnt, "%s = 0;\n", fid);
  1045      code (nprocs, BODY, fcnt);
  1046      if (is_int4 (fmt.str, &val)) {
  1047        _srecordf (fstr, "%s", edit_fmt (val));
  1048      } else {
  1049        if (fmt.mode.type == INTEGER) {
  1050  // Assigned FORMAT.
  1051          _srecordf (str, "switch (%s) {\n", fmt.str);
  1052          code (nprocs, BODY, str);
  1053          code (nprocs, BODY, "default:\n");
  1054          for (int_4 k = 0; k < nlabels; k++) {
  1055            LBL *L = &labels[k];
  1056            if (L->format) {
  1057              L->jumped++;
  1058              _srecordf (str, "case %d: __fmt_a = %s; break;\n", L->index, edit_fmt(L->num));
  1059              code (nprocs, BODY, str);
  1060            }
  1061          }
  1062          code (nprocs, BODY, "}\n");
  1063          RECCPY (fstr, "__fmt_a");
  1064        } else if (fmt.mode.type == CHARACTER) {
  1065          _srecordf (str, "__fmt_a = _vif_jit (\"%s\", %s);\n", stat_start, fmt.str);
  1066          code (nprocs, BODY, str);
  1067          RECCPY (fstr, "__fmt_a");
  1068        } else {
  1069          ERROR (3323, "format identifier mode error", qtype (&fmt.mode));
  1070        }
  1071      }
  1072    } else {
  1073      _srecordf (iorc, "__rc_%d", nloctmps++);
  1074      add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
  1075    }
  1076  // Start-of-record.
  1077    if (form == FORMATTED) {
  1078      if (EQUAL (proc, "read")) {
  1079        io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1080      } else if (EQUAL (proc, "accept")) {
  1081        io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1082      } else if (EQUAL (proc, "write")) {
  1083        io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1084      } else if (EQUAL (proc, "print")) {
  1085        io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1086      } else if (EQUAL (proc, "punch")) {
  1087        io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
  1088      }
  1089    }
  1090    int_4 items = 0;
  1091    if (EQUAL (proc, "read")) {
  1092      io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1093    } else if (EQUAL (proc, "accept")) {
  1094      io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1095    } else if (EQUAL (proc, "write")) {
  1096      io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1097    } else if (EQUAL (proc, "print")) {
  1098      io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1099    } else if (EQUAL (proc, "punch")) {
  1100      io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
  1101    }
  1102    if (unit.mode.type == CHARACTER) {
  1103  // IO to a string implies UNIT=0.
  1104  //  code (nprocs, BODY, "_fclose (0);\n");
  1105    } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
  1106  // End-of-record.
  1107      if (form != UNFORMATTED) {
  1108        _srecordf (str, "_write_eol (%s);\n", unum (&unit));
  1109        code (nprocs, BODY, str);
  1110      }
  1111    } else if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
  1112  // End-of-record.
  1113      if (form != UNFORMATTED) {
  1114        _srecordf (str, "_read_eol (%s);\n", unum (&unit));
  1115        code (nprocs, BODY, str);
  1116      }
  1117    }
  1118  //
  1119    save_iostat (iostat);
  1120  //
  1121    (void) rc;
  1122  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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