libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught and Janne Blomqvist
   3
   4 This file is part of the GNU Fortran runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 3, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 Under Section 7 of GPL version 3, you are granted additional
  17 permissions described in the GCC Runtime Library Exception, version
  18 3.1, as published by the Free Software Foundation.
  19
  20 You should have received a copy of the GNU General Public License and
  21 a copy of the GCC Runtime Library Exception along with this program;
  22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  23 <http://www.gnu.org/licenses/>.  */
  24
  25 #include "io.h"
  26 #include "fbuf.h"
  27 #include "unix.h"
  28 #include <string.h>
  29
  30 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
  31    ENDFILE, and REWIND as well as the FLUSH statement.  */
  32
  33
  34 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
  35    current position is after the newline that terminates the previous
  36    record, and we have to sift backwards to find the newline before
  37    that or the start of the file, whichever comes first.  */
  38
  39 #define READ_CHUNK 4096
  40
  41 static void
  42 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  43 {
  44   gfc_offset base;
  45   char p[READ_CHUNK];
  46   ssize_t n;
  47
  48   base = stell (u->s) - 1;
  49
  50   do
  51     {
  52       n = (base < READ_CHUNK) ? base : READ_CHUNK;
  53       base -= n;
  54       if (sseek (u->s, base, SEEK_SET) < 0)
  55         goto io_error;
  56       if (sread (u->s, p, n) != n)
  57         goto io_error;
  58
  59       /* We have moved backwards from the current position, it should
  60          not be possible to get a short read.  Because it is not
  61          clear what to do about such thing, we ignore the possibility.  */
  62
  63       /* There is no memrchr() in the C library, so we have to do it
  64          ourselves.  */
  65
  66       while (n > 0)
  67         {
  68           n--;
  69           if (p[n] == '\n')
  70             {
  71               base += n + 1;
  72               goto done;
  73             }
  74         }
  75
  76     }
  77   while (base != 0);
  78
  79   /* base is the new pointer.  Seek to it exactly.  */
  80  done:
  81   if (sseek (u->s, base, SEEK_SET) < 0)
  82     goto io_error;
  83   u->last_record--;
  84   u->endfile = NO_ENDFILE;
  85   u->last_char = EOF - 1;
  86   return;
  87
  88  io_error:
  89   generate_error (&fpp->common, LIBERROR_OS, NULL);
  90 }
  91
  92
  93 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
  94    sequential file.  We are guaranteed to be between records on entry and
  95    we have to shift to the previous record.  Loop over subrecords.  */
  96
  97 static void
  98 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  99 {
 100   gfc_offset m, slen;
 101   GFC_INTEGER_4 m4;
 102   GFC_INTEGER_8 m8;
 103   ssize_t length;
 104   int continued;
 105   char p[sizeof (GFC_INTEGER_8)];
 106
 107   if (compile_options.record_marker == 0)
 108     length = sizeof (GFC_INTEGER_4);
 109   else
 110     length = compile_options.record_marker;
 111
 112   do
 113     {
 114       slen = - (gfc_offset) length;
 115       if (sseek (u->s, slen, SEEK_CUR) < 0)
 116         goto io_error;
 117       if (sread (u->s, p, length) != length)
 118         goto io_error;
 119
 120       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
 121       if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
 122         {
 123           switch (length)
 124             {
 125             case sizeof(GFC_INTEGER_4):
 126               memcpy (&m4, p, sizeof (m4));
 127               m = m4;
 128               break;
 129
 130             case sizeof(GFC_INTEGER_8):
 131               memcpy (&m8, p, sizeof (m8));
 132               m = m8;
 133               break;
 134
 135             default:
 136               runtime_error ("Illegal value for record marker");
 137               break;
 138             }
 139         }
 140       else
 141         {
 142           uint32_t u32;
 143           uint64_t u64;
 144           switch (length)
 145             {
 146             case sizeof(GFC_INTEGER_4):
 147               memcpy (&u32, p, sizeof (u32));
 148               u32 = __builtin_bswap32 (u32);
 149               memcpy (&m4, &u32, sizeof (m4));
 150               m = m4;
 151               break;
 152
 153             case sizeof(GFC_INTEGER_8):
 154               memcpy (&u64, p, sizeof (u64));
 155               u64 = __builtin_bswap64 (u64);
 156               memcpy (&m8, &u64, sizeof (m8));
 157               m = m8;
 158               break;
 159
 160             default:
 161               runtime_error ("Illegal value for record marker");
 162               break;
 163             }
 164
 165         }
 166
 167       continued = m < 0;
 168       if (continued)
 169         m = -m;
 170
 171       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
 172         goto io_error;
 173     } while (continued);
 174
 175   u->last_record--;
 176   return;
 177
 178  io_error:
 179   generate_error (&fpp->common, LIBERROR_OS, NULL);
 180 }
 181
 182
 183 extern void st_backspace (st_parameter_filepos *);
 184 export_proto(st_backspace);
 185
 186 void
 187 st_backspace (st_parameter_filepos *fpp)
 188 {
 189   gfc_unit *u;
 190
 191   library_start (&fpp->common);
 192
 193   u = find_unit (fpp->common.unit);
 194   if (u == NULL)
 195     {
 196       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
 197       goto done;
 198     }
 199
 200   /* Direct access is prohibited, and so is unformatted stream access.  */
 201
 202
 203   if (u->flags.access == ACCESS_DIRECT)
 204     {
 205       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 206                       "Cannot BACKSPACE a file opened for DIRECT access");
 207       goto done;
 208     }
 209
 210   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
 211     {
 212       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 213                       "Cannot BACKSPACE an unformatted stream file");
 214       goto done;
 215     }
 216
 217   /* Make sure format buffer is flushed and reset.  */
 218   if (u->flags.form == FORM_FORMATTED)
 219     {
 220       int pos = fbuf_reset (u);
 221       if (pos != 0)
 222         sseek (u->s, pos, SEEK_CUR);
 223     }
 224
 225
 226   /* Check for special cases involving the ENDFILE record first.  */
 227
 228   if (u->endfile == AFTER_ENDFILE)
 229     {
 230       u->endfile = AT_ENDFILE;
 231       u->flags.position = POSITION_APPEND;
 232       sflush (u->s);
 233     }
 234   else
 235     {
 236       if (stell (u->s) == 0)
 237         {
 238           u->flags.position = POSITION_REWIND;
 239           goto done;            /* Common special case */
 240         }
 241
 242       if (u->mode == WRITING)
 243         {
 244           /* If there are previously written bytes from a write with
 245              ADVANCE="no", add a record marker before performing the
 246              BACKSPACE.  */
 247
 248           if (u->previous_nonadvancing_write)
 249             finish_last_advance_record (u);
 250
 251           u->previous_nonadvancing_write = 0;
 252
 253           unit_truncate (u, stell (u->s), &fpp->common);
 254           u->mode = READING;
 255         }
 256
 257       if (u->flags.form == FORM_FORMATTED)
 258         formatted_backspace (fpp, u);
 259       else
 260         unformatted_backspace (fpp, u);
 261
 262       u->flags.position = POSITION_UNSPECIFIED;
 263       u->endfile = NO_ENDFILE;
 264       u->current_record = 0;
 265       u->bytes_left = 0;
 266     }
 267
 268  done:
 269   if (u != NULL)
 270     unlock_unit (u);
 271
 272   library_end ();
 273 }
 274
 275
 276 extern void st_endfile (st_parameter_filepos *);
 277 export_proto(st_endfile);
 278
 279 void
 280 st_endfile (st_parameter_filepos *fpp)
 281 {
 282   gfc_unit *u;
 283
 284   library_start (&fpp->common);
 285
 286   u = find_unit (fpp->common.unit);
 287   if (u != NULL)
 288     {
 289       if (u->flags.access == ACCESS_DIRECT)
 290         {
 291           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 292                           "Cannot perform ENDFILE on a file opened "
 293                           "for DIRECT access");
 294           goto done;
 295         }
 296
 297       if (u->flags.access == ACCESS_SEQUENTIAL
 298           && u->endfile == AFTER_ENDFILE)
 299         {
 300           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 301                           "Cannot perform ENDFILE on a file already "
 302                           "positioned after the EOF marker");
 303           goto done;
 304         }
 305
 306       /* If there are previously written bytes from a write with ADVANCE="no",
 307          add a record marker before performing the ENDFILE.  */
 308
 309       if (u->previous_nonadvancing_write)
 310         finish_last_advance_record (u);
 311
 312       u->previous_nonadvancing_write = 0;
 313
 314       if (u->current_record)
 315         {
 316           st_parameter_dt dtp;
 317           dtp.common = fpp->common;
 318           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 319           dtp.u.p.current_unit = u;
 320           next_record (&dtp, 1);
 321         }
 322
 323       unit_truncate (u, stell (u->s), &fpp->common);
 324       u->endfile = AFTER_ENDFILE;
 325       u->last_char = EOF - 1;
 326       if (0 == stell (u->s))
 327         u->flags.position = POSITION_REWIND;
 328     }
 329   else
 330     {
 331       if (fpp->common.unit < 0)
 332         {
 333           generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 334                           "Bad unit number in statement");
 335           return;
 336         }
 337
 338       u = find_or_create_unit (fpp->common.unit);
 339       if (u->s == NULL)
 340         {
 341           /* Open the unit with some default flags.  */
 342           st_parameter_open opp;
 343           unit_flags u_flags;
 344
 345           memset (&u_flags, '\0', sizeof (u_flags));
 346           u_flags.access = ACCESS_SEQUENTIAL;
 347           u_flags.action = ACTION_READWRITE;
 348
 349           /* Is it unformatted?  */
 350           if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
 351                                      | IOPARM_DT_IONML_SET)))
 352             u_flags.form = FORM_UNFORMATTED;
 353           else
 354             u_flags.form = FORM_UNSPECIFIED;
 355
 356           u_flags.delim = DELIM_UNSPECIFIED;
 357           u_flags.blank = BLANK_UNSPECIFIED;
 358           u_flags.pad = PAD_UNSPECIFIED;
 359           u_flags.decimal = DECIMAL_UNSPECIFIED;
 360           u_flags.encoding = ENCODING_UNSPECIFIED;
 361           u_flags.async = ASYNC_UNSPECIFIED;
 362           u_flags.round = ROUND_UNSPECIFIED;
 363           u_flags.sign = SIGN_UNSPECIFIED;
 364           u_flags.status = STATUS_UNKNOWN;
 365           u_flags.convert = GFC_CONVERT_NATIVE;
 366           u_flags.share = SHARE_UNSPECIFIED;
 367           u_flags.cc = CC_UNSPECIFIED;
 368
 369           opp.common = fpp->common;
 370           opp.common.flags &= IOPARM_COMMON_MASK;
 371           u = new_unit (&opp, u, &u_flags);
 372           if (u == NULL)
 373             return;
 374           u->endfile = AFTER_ENDFILE;
 375           u->last_char = EOF - 1;
 376         }
 377     }
 378
 379   done:
 380     unlock_unit (u);
 381
 382   library_end ();
 383 }
 384
 385
 386 extern void st_rewind (st_parameter_filepos *);
 387 export_proto(st_rewind);
 388
 389 void
 390 st_rewind (st_parameter_filepos *fpp)
 391 {
 392   gfc_unit *u;
 393
 394   library_start (&fpp->common);
 395
 396   u = find_unit (fpp->common.unit);
 397   if (u != NULL)
 398     {
 399       if (u->flags.access == ACCESS_DIRECT)
 400         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 401                         "Cannot REWIND a file opened for DIRECT access");
 402       else
 403         {
 404           /* If there are previously written bytes from a write with ADVANCE="no",
 405              add a record marker before performing the ENDFILE.  */
 406
 407           if (u->previous_nonadvancing_write)
 408             finish_last_advance_record (u);
 409
 410           u->previous_nonadvancing_write = 0;
 411
 412           fbuf_reset (u);
 413
 414           u->last_record = 0;
 415
 416           if (sseek (u->s, 0, SEEK_SET) < 0)
 417             {
 418               generate_error (&fpp->common, LIBERROR_OS, NULL);
 419               library_end ();
 420               return;
 421             }
 422
 423           /* Set this for compatibilty with g77 for /dev/null.  */
 424           if (ssize (u->s) == 0)
 425             u->endfile = AT_ENDFILE;
 426           else
 427             {
 428               /* We are rewinding so we are not at the end.  */
 429               u->endfile = NO_ENDFILE;
 430             }
 431
 432           u->current_record = 0;
 433           u->strm_pos = 1;
 434           u->read_bad = 0;
 435           u->last_char = EOF - 1;
 436         }
 437       /* Update position for INQUIRE.  */
 438       u->flags.position = POSITION_REWIND;
 439       unlock_unit (u);
 440     }
 441
 442   library_end ();
 443 }
 444
 445
 446 extern void st_flush (st_parameter_filepos *);
 447 export_proto(st_flush);
 448
 449 void
 450 st_flush (st_parameter_filepos *fpp)
 451 {
 452   gfc_unit *u;
 453
 454   library_start (&fpp->common);
 455
 456   u = find_unit (fpp->common.unit);
 457   if (u != NULL)
 458     {
 459       /* Make sure format buffer is flushed.  */
 460       if (u->flags.form == FORM_FORMATTED)
 461         fbuf_flush (u, u->mode);
 462
 463       sflush (u->s);
 464       u->last_char = EOF - 1;
 465       unlock_unit (u);
 466     }
 467   else
 468     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 469     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 470                         "Specified UNIT in FLUSH is not connected");
 471
 472   library_end ();
 473 }