libgfortran/io/file_pos.c

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