libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009 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 static const int 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           switch (length)
 143             {
 144             case sizeof(GFC_INTEGER_4):
 145               reverse_memcpy (&m4, p, sizeof (m4));
 146               m = m4;
 147               break;
 148
 149             case sizeof(GFC_INTEGER_8):
 150               reverse_memcpy (&m8, p, sizeof (m8));
 151               m = m8;
 152               break;
 153
 154             default:
 155               runtime_error ("Illegal value for record marker");
 156               break;
 157             }
 158
 159         }
 160
 161       continued = m < 0;
 162       if (continued)
 163         m = -m;
 164
 165       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
 166         goto io_error;
 167     } while (continued);
 168
 169   u->last_record--;
 170   return;
 171
 172  io_error:
 173   generate_error (&fpp->common, LIBERROR_OS, NULL);
 174 }
 175
 176
 177 extern void st_backspace (st_parameter_filepos *);
 178 export_proto(st_backspace);
 179
 180 void
 181 st_backspace (st_parameter_filepos *fpp)
 182 {
 183   gfc_unit *u;
 184
 185   library_start (&fpp->common);
 186
 187   u = find_unit (fpp->common.unit);
 188   if (u == NULL)
 189     {
 190       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
 191       goto done;
 192     }
 193
 194   /* Direct access is prohibited, and so is unformatted stream access.  */
 195
 196
 197   if (u->flags.access == ACCESS_DIRECT)
 198     {
 199       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 200                       "Cannot BACKSPACE a file opened for DIRECT access");
 201       goto done;
 202     }
 203
 204   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
 205     {
 206       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 207                       "Cannot BACKSPACE an unformatted stream file");
 208       goto done;
 209     }
 210
 211   /* Make sure format buffer is flushed and reset.  */
 212   if (u->flags.form == FORM_FORMATTED)
 213     {
 214       int pos = fbuf_reset (u);
 215       if (pos != 0)
 216         sseek (u->s, pos, SEEK_CUR);
 217     }
 218
 219
 220   /* Check for special cases involving the ENDFILE record first.  */
 221
 222   if (u->endfile == AFTER_ENDFILE)
 223     {
 224       u->endfile = AT_ENDFILE;
 225       u->flags.position = POSITION_APPEND;
 226       sflush (u->s);
 227     }
 228   else
 229     {
 230       if (stell (u->s) == 0)
 231         {
 232           u->flags.position = POSITION_REWIND;
 233           goto done;            /* Common special case */
 234         }
 235
 236       if (u->mode == WRITING)
 237         {
 238           /* If there are previously written bytes from a write with
 239              ADVANCE="no", add a record marker before performing the
 240              BACKSPACE.  */
 241
 242           if (u->previous_nonadvancing_write)
 243             finish_last_advance_record (u);
 244
 245           u->previous_nonadvancing_write = 0;
 246
 247           unit_truncate (u, stell (u->s), &fpp->common);
 248           u->mode = READING;
 249         }
 250
 251       if (u->flags.form == FORM_FORMATTED)
 252         formatted_backspace (fpp, u);
 253       else
 254         unformatted_backspace (fpp, u);
 255
 256       u->flags.position = POSITION_UNSPECIFIED;
 257       u->endfile = NO_ENDFILE;
 258       u->current_record = 0;
 259       u->bytes_left = 0;
 260     }
 261
 262  done:
 263   if (u != NULL)
 264     unlock_unit (u);
 265
 266   library_end ();
 267 }
 268
 269
 270 extern void st_endfile (st_parameter_filepos *);
 271 export_proto(st_endfile);
 272
 273 void
 274 st_endfile (st_parameter_filepos *fpp)
 275 {
 276   gfc_unit *u;
 277
 278   library_start (&fpp->common);
 279
 280   u = find_unit (fpp->common.unit);
 281   if (u != NULL)
 282     {
 283       if (u->flags.access == ACCESS_DIRECT)
 284         {
 285           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 286                           "Cannot perform ENDFILE on a file opened"
 287                           " for DIRECT access");
 288           goto done;
 289         }
 290
 291       /* If there are previously written bytes from a write with ADVANCE="no",
 292          add a record marker before performing the ENDFILE.  */
 293
 294       if (u->previous_nonadvancing_write)
 295         finish_last_advance_record (u);
 296
 297       u->previous_nonadvancing_write = 0;
 298
 299       if (u->current_record)
 300         {
 301           st_parameter_dt dtp;
 302           dtp.common = fpp->common;
 303           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 304           dtp.u.p.current_unit = u;
 305           next_record (&dtp, 1);
 306         }
 307
 308       unit_truncate (u, stell (u->s), &fpp->common);
 309       u->endfile = AFTER_ENDFILE;
 310       if (0 == stell (u->s))
 311         u->flags.position = POSITION_REWIND;
 312     done:
 313       unlock_unit (u);
 314     }
 315
 316   library_end ();
 317 }
 318
 319
 320 extern void st_rewind (st_parameter_filepos *);
 321 export_proto(st_rewind);
 322
 323 void
 324 st_rewind (st_parameter_filepos *fpp)
 325 {
 326   gfc_unit *u;
 327
 328   library_start (&fpp->common);
 329
 330   u = find_unit (fpp->common.unit);
 331   if (u != NULL)
 332     {
 333       if (u->flags.access == ACCESS_DIRECT)
 334         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 335                         "Cannot REWIND a file opened for DIRECT access");
 336       else
 337         {
 338           /* If there are previously written bytes from a write with ADVANCE="no",
 339              add a record marker before performing the ENDFILE.  */
 340
 341           if (u->previous_nonadvancing_write)
 342             finish_last_advance_record (u);
 343
 344           u->previous_nonadvancing_write = 0;
 345
 346           fbuf_reset (u);
 347
 348           u->last_record = 0;
 349
 350           if (sseek (u->s, 0, SEEK_SET) < 0)
 351             generate_error (&fpp->common, LIBERROR_OS, NULL);
 352
 353           /* Handle special files like /dev/null differently.  */
 354           if (!is_special (u->s))
 355             {
 356               /* We are rewinding so we are not at the end.  */
 357               u->endfile = NO_ENDFILE;
 358             }
 359           else
 360             {
 361               /* Set this for compatibilty with g77 for /dev/null.  */
 362               if (file_length (u->s) == 0  && stell (u->s) == 0)
 363                 u->endfile = AT_ENDFILE;
 364               /* Future refinements on special files can go here.  */
 365             }
 366
 367           u->current_record = 0;
 368           u->strm_pos = 1;
 369           u->read_bad = 0;
 370         }
 371       /* Update position for INQUIRE.  */
 372       u->flags.position = POSITION_REWIND;
 373       unlock_unit (u);
 374     }
 375
 376   library_end ();
 377 }
 378
 379
 380 extern void st_flush (st_parameter_filepos *);
 381 export_proto(st_flush);
 382
 383 void
 384 st_flush (st_parameter_filepos *fpp)
 385 {
 386   gfc_unit *u;
 387
 388   library_start (&fpp->common);
 389
 390   u = find_unit (fpp->common.unit);
 391   if (u != NULL)
 392     {
 393       /* Make sure format buffer is flushed.  */
 394       if (u->flags.form == FORM_FORMATTED)
 395         fbuf_flush (u, u->mode);
 396
 397       sflush (u->s);
 398       unlock_unit (u);
 399     }
 400   else
 401     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 402     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 403                         "Specified UNIT in FLUSH is not connected");
 404
 405   library_end ();
 406 }