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

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