libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2017 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
  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       if (0 == stell (u->s))
 326         u->flags.position = POSITION_REWIND;
 327     }
 328   else
 329     {
 330       if (fpp->common.unit < 0)
 331         {
 332           generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 333                           "Bad unit number in statement");
 334           return;
 335         }
 336
 337       u = find_or_create_unit (fpp->common.unit);
 338       if (u->s == NULL)
 339         {
 340           /* Open the unit with some default flags.  */
 341           st_parameter_open opp;
 342           unit_flags u_flags;
 343
 344           memset (&u_flags, '\0', sizeof (u_flags));
 345           u_flags.access = ACCESS_SEQUENTIAL;
 346           u_flags.action = ACTION_READWRITE;
 347
 348           /* Is it unformatted?  */
 349           if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
 350                                      | IOPARM_DT_IONML_SET)))
 351             u_flags.form = FORM_UNFORMATTED;
 352           else
 353             u_flags.form = FORM_UNSPECIFIED;
 354
 355           u_flags.delim = DELIM_UNSPECIFIED;
 356           u_flags.blank = BLANK_UNSPECIFIED;
 357           u_flags.pad = PAD_UNSPECIFIED;
 358           u_flags.decimal = DECIMAL_UNSPECIFIED;
 359           u_flags.encoding = ENCODING_UNSPECIFIED;
 360           u_flags.async = ASYNC_UNSPECIFIED;
 361           u_flags.round = ROUND_UNSPECIFIED;
 362           u_flags.sign = SIGN_UNSPECIFIED;
 363           u_flags.status = STATUS_UNKNOWN;
 364           u_flags.convert = GFC_CONVERT_NATIVE;
 365           u_flags.share = SHARE_UNSPECIFIED;
 366           u_flags.cc = CC_UNSPECIFIED;
 367
 368           opp.common = fpp->common;
 369           opp.common.flags &= IOPARM_COMMON_MASK;
 370           u = new_unit (&opp, u, &u_flags);
 371           if (u == NULL)
 372             return;
 373           u->endfile = AFTER_ENDFILE;
 374         }
 375     }
 376
 377   done:
 378     unlock_unit (u);
 379
 380   library_end ();
 381 }
 382
 383
 384 extern void st_rewind (st_parameter_filepos *);
 385 export_proto(st_rewind);
 386
 387 void
 388 st_rewind (st_parameter_filepos *fpp)
 389 {
 390   gfc_unit *u;
 391
 392   library_start (&fpp->common);
 393
 394   u = find_unit (fpp->common.unit);
 395   if (u != NULL)
 396     {
 397       if (u->flags.access == ACCESS_DIRECT)
 398         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 399                         "Cannot REWIND a file opened for DIRECT access");
 400       else
 401         {
 402           /* If there are previously written bytes from a write with ADVANCE="no",
 403              add a record marker before performing the ENDFILE.  */
 404
 405           if (u->previous_nonadvancing_write)
 406             finish_last_advance_record (u);
 407
 408           u->previous_nonadvancing_write = 0;
 409
 410           fbuf_reset (u);
 411
 412           u->last_record = 0;
 413
 414           if (sseek (u->s, 0, SEEK_SET) < 0)
 415             {
 416               generate_error (&fpp->common, LIBERROR_OS, NULL);
 417               library_end ();
 418               return;
 419             }
 420
 421           /* Set this for compatibilty with g77 for /dev/null.  */
 422           if (ssize (u->s) == 0)
 423             u->endfile = AT_ENDFILE;
 424           else
 425             {
 426               /* We are rewinding so we are not at the end.  */
 427               u->endfile = NO_ENDFILE;
 428             }
 429
 430           u->current_record = 0;
 431           u->strm_pos = 1;
 432           u->read_bad = 0;
 433         }
 434       /* Update position for INQUIRE.  */
 435       u->flags.position = POSITION_REWIND;
 436       unlock_unit (u);
 437     }
 438
 439   library_end ();
 440 }
 441
 442
 443 extern void st_flush (st_parameter_filepos *);
 444 export_proto(st_flush);
 445
 446 void
 447 st_flush (st_parameter_filepos *fpp)
 448 {
 449   gfc_unit *u;
 450
 451   library_start (&fpp->common);
 452
 453   u = find_unit (fpp->common.unit);
 454   if (u != NULL)
 455     {
 456       /* Make sure format buffer is flushed.  */
 457       if (u->flags.form == FORM_FORMATTED)
 458         fbuf_flush (u, u->mode);
 459
 460       sflush (u->s);
 461       unlock_unit (u);
 462     }
 463   else
 464     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 465     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 466                         "Specified UNIT in FLUSH is not connected");
 467
 468   library_end ();
 469 }