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