libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2024 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         }
 356
 357       unit_truncate (u, stell (u->s), &fpp->common);
 358       u->endfile = AFTER_ENDFILE;
 359       u->last_char = EOF - 1;
 360       if (0 == stell (u->s))
 361         u->flags.position = POSITION_REWIND;
 362     }
 363   else
 364     {
 365       if (fpp->common.unit < 0)
 366         {
 367           generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 368                           "Bad unit number in statement");
 369           return;
 370         }
 371
 372       u = find_or_create_unit (fpp->common.unit);
 373       if (u->s == NULL)
 374         {
 375           /* Open the unit with some default flags.  */
 376           st_parameter_open opp;
 377           unit_flags u_flags;
 378
 379           memset (&u_flags, '\0', sizeof (u_flags));
 380           u_flags.access = ACCESS_SEQUENTIAL;
 381           u_flags.action = ACTION_READWRITE;
 382
 383           /* Is it unformatted?  */
 384           if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
 385                                      | IOPARM_DT_IONML_SET)))
 386             u_flags.form = FORM_UNFORMATTED;
 387           else
 388             u_flags.form = FORM_UNSPECIFIED;
 389
 390           u_flags.delim = DELIM_UNSPECIFIED;
 391           u_flags.blank = BLANK_UNSPECIFIED;
 392           u_flags.pad = PAD_UNSPECIFIED;
 393           u_flags.decimal = DECIMAL_UNSPECIFIED;
 394           u_flags.encoding = ENCODING_UNSPECIFIED;
 395           u_flags.async = ASYNC_UNSPECIFIED;
 396           u_flags.round = ROUND_UNSPECIFIED;
 397           u_flags.sign = SIGN_UNSPECIFIED;
 398           u_flags.status = STATUS_UNKNOWN;
 399           u_flags.convert = GFC_CONVERT_NATIVE;
 400           u_flags.share = SHARE_UNSPECIFIED;
 401           u_flags.cc = CC_UNSPECIFIED;
 402
 403           opp.common = fpp->common;
 404           opp.common.flags &= IOPARM_COMMON_MASK;
 405           u = new_unit (&opp, u, &u_flags);
 406           if (u == NULL)
 407             return;
 408           u->endfile = AFTER_ENDFILE;
 409           u->last_char = EOF - 1;
 410         }
 411     }
 412
 413  done:
 414   if (ASYNC_IO && u->au && needs_unlock)
 415     UNLOCK (&u->au->io_lock);
 416
 417   unlock_unit (u);
 418
 419   library_end ();
 420 }
 421
 422
 423 extern void st_rewind (st_parameter_filepos *);
 424 export_proto(st_rewind);
 425
 426 void
 427 st_rewind (st_parameter_filepos *fpp)
 428 {
 429   gfc_unit *u;
 430   bool needs_unlock = true;
 431
 432   library_start (&fpp->common);
 433
 434   u = find_unit (fpp->common.unit);
 435   if (u != NULL)
 436     {
 437       if (u->flags.access == ACCESS_DIRECT)
 438         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 439                         "Cannot REWIND a file opened for DIRECT access");
 440       else
 441         {
 442           if (ASYNC_IO && u->au)
 443             {
 444               if (async_wait (&(fpp->common), u->au))
 445                 return;
 446               else
 447                 {
 448                   needs_unlock = true;
 449                   LOCK (&u->au->io_lock);
 450                 }
 451             }
 452
 453           /* If there are previously written bytes from a write with ADVANCE="no",
 454              add a record marker before performing the ENDFILE.  */
 455
 456           if (u->previous_nonadvancing_write)
 457             finish_last_advance_record (u);
 458
 459           u->previous_nonadvancing_write = 0;
 460
 461           fbuf_reset (u);
 462
 463           u->last_record = 0;
 464
 465           if (sseek (u->s, 0, SEEK_SET) < 0)
 466             {
 467               generate_error (&fpp->common, LIBERROR_OS, NULL);
 468               library_end ();
 469               return;
 470             }
 471
 472           /* Set this for compatibilty with g77 for /dev/null.  */
 473           if (ssize (u->s) == 0)
 474             u->endfile = AT_ENDFILE;
 475           else
 476             {
 477               /* We are rewinding so we are not at the end.  */
 478               u->endfile = NO_ENDFILE;
 479             }
 480
 481           u->current_record = 0;
 482           u->strm_pos = 1;
 483           u->read_bad = 0;
 484           u->last_char = EOF - 1;
 485         }
 486       /* Update position for INQUIRE.  */
 487       u->flags.position = POSITION_REWIND;
 488
 489       if (ASYNC_IO && u->au && needs_unlock)
 490         UNLOCK (&u->au->io_lock);
 491
 492       unlock_unit (u);
 493     }
 494
 495   library_end ();
 496 }
 497
 498
 499 extern void st_flush (st_parameter_filepos *);
 500 export_proto(st_flush);
 501
 502 void
 503 st_flush (st_parameter_filepos *fpp)
 504 {
 505   gfc_unit *u;
 506   bool needs_unlock = false;
 507
 508   library_start (&fpp->common);
 509
 510   u = find_unit (fpp->common.unit);
 511   if (u != NULL)
 512     {
 513       if (ASYNC_IO && u->au)
 514         {
 515           if (async_wait (&(fpp->common), u->au))
 516             return;
 517           else
 518             {
 519               needs_unlock = true;
 520               LOCK (&u->au->io_lock);
 521             }
 522         }
 523
 524       /* Make sure format buffer is flushed.  */
 525       if (u->flags.form == FORM_FORMATTED)
 526         fbuf_flush (u, u->mode);
 527
 528       sflush (u->s);
 529       u->last_char = EOF - 1;
 530       unlock_unit (u);
 531     }
 532   else
 533     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 534     generate_error (&fpp->common, -LIBERROR_BAD_UNIT,
 535                         "Specified UNIT in FLUSH is not connected");
 536
 537   if (needs_unlock)
 538     UNLOCK (&u->au->io_lock);
 539
 540   library_end ();
 541 }