libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005, 2006, 2007 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 2, or (at your option)
   9 any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with Libgfortran; see the file COPYING.  If not, write to
  27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  28 Boston, MA 02110-1301, USA.  */
  29
  30 #include "io.h"
  31 #include <string.h>
  32
  33 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
  34    ENDFILE, and REWIND as well as the FLUSH statement.  */
  35
  36
  37 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
  38    current position is after the newline that terminates the previous
  39    record, and we have to sift backwards to find the newline before
  40    that or the start of the file, whichever comes first.  */
  41
  42 static const int READ_CHUNK = 4096;
  43
  44 static void
  45 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  46 {
  47   gfc_offset base;
  48   char p[READ_CHUNK];
  49   size_t n;
  50
  51   base = file_position (u->s) - 1;
  52
  53   do
  54     {
  55       n = (base < READ_CHUNK) ? base : READ_CHUNK;
  56       base -= n;
  57       if (sseek (u->s, base) == FAILURE)
  58         goto io_error;
  59       if (sread (u->s, p, &n) != 0)
  60         goto io_error;
  61
  62       /* We have moved backwards from the current position, it should
  63          not be possible to get a short read.  Because it is not
  64          clear what to do about such thing, we ignore the possibility.  */
  65
  66       /* There is no memrchr() in the C library, so we have to do it
  67          ourselves.  */
  68
  69       while (n > 0)
  70         {
  71           n--;
  72           if (p[n] == '\n')
  73             {
  74               base += n + 1;
  75               goto done;
  76             }
  77         }
  78
  79     }
  80   while (base != 0);
  81
  82   /* base is the new pointer.  Seek to it exactly.  */
  83  done:
  84   if (sseek (u->s, base) == FAILURE)
  85     goto io_error;
  86   u->last_record--;
  87   u->endfile = NO_ENDFILE;
  88
  89   return;
  90
  91  io_error:
  92   generate_error (&fpp->common, LIBERROR_OS, NULL);
  93 }
  94
  95
  96 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
  97    sequential file.  We are guaranteed to be between records on entry and
  98    we have to shift to the previous record.  Loop over subrecords.  */
  99
 100 static void
 101 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 102 {
 103   gfc_offset m, new;
 104   GFC_INTEGER_4 m4;
 105   GFC_INTEGER_8 m8;
 106   size_t length;
 107   int continued;
 108   char p[sizeof (GFC_INTEGER_8)];
 109
 110   if (compile_options.record_marker == 0)
 111     length = sizeof (GFC_INTEGER_4);
 112   else
 113     length = compile_options.record_marker;
 114
 115   do
 116     {
 117       if (sseek (u->s, file_position (u->s) - length) == FAILURE)
 118         goto io_error;
 119       if (sread (u->s, p, &length) != 0)
 120         goto io_error;
 121
 122       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
 123       if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
 124         {
 125           switch (length)
 126             {
 127             case sizeof(GFC_INTEGER_4):
 128               memcpy (&m4, p, sizeof (m4));
 129               m = m4;
 130               break;
 131
 132             case sizeof(GFC_INTEGER_8):
 133               memcpy (&m8, p, sizeof (m8));
 134               m = m8;
 135               break;
 136
 137             default:
 138               runtime_error ("Illegal value for record marker");
 139               break;
 140             }
 141         }
 142       else
 143         {
 144           switch (length)
 145             {
 146             case sizeof(GFC_INTEGER_4):
 147               reverse_memcpy (&m4, p, sizeof (m4));
 148               m = m4;
 149               break;
 150
 151             case sizeof(GFC_INTEGER_8):
 152               reverse_memcpy (&m8, p, sizeof (m8));
 153               m = m8;
 154               break;
 155
 156             default:
 157               runtime_error ("Illegal value for record marker");
 158               break;
 159             }
 160
 161         }
 162
 163       continued = m < 0;
 164       if (continued)
 165         m = -m;
 166
 167       if ((new = file_position (u->s) - m - 2*length) < 0)
 168         new = 0;
 169
 170       if (sseek (u->s, new) == FAILURE)
 171         goto io_error;
 172     } while (continued);
 173
 174   u->last_record--;
 175   return;
 176
 177  io_error:
 178   generate_error (&fpp->common, LIBERROR_OS, NULL);
 179 }
 180
 181
 182 extern void st_backspace (st_parameter_filepos *);
 183 export_proto(st_backspace);
 184
 185 void
 186 st_backspace (st_parameter_filepos *fpp)
 187 {
 188   gfc_unit *u;
 189
 190   library_start (&fpp->common);
 191
 192   u = find_unit (fpp->common.unit);
 193   if (u == NULL)
 194     {
 195       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
 196       goto done;
 197     }
 198
 199   /* Direct access is prohibited, and so is unformatted stream access.  */
 200
 201
 202   if (u->flags.access == ACCESS_DIRECT)
 203     {
 204       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 205                       "Cannot BACKSPACE a file opened for DIRECT access");
 206       goto done;
 207     }
 208
 209     if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
 210       {
 211         generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 212                         "Cannot BACKSPACE an unformatted stream file");
 213         goto done;
 214       }
 215
 216   /* Make sure format buffer is flushed.  */
 217   fbuf_flush (u, 1);
 218
 219   /* Check for special cases involving the ENDFILE record first.  */
 220
 221   if (u->endfile == AFTER_ENDFILE)
 222     {
 223       u->endfile = AT_ENDFILE;
 224       u->flags.position = POSITION_APPEND;
 225       flush (u->s);
 226     }
 227   else
 228     {
 229       if (file_position (u->s) == 0)
 230         {
 231           u->flags.position = POSITION_REWIND;
 232           goto done;            /* Common special case */
 233         }
 234
 235       if (u->mode == WRITING)
 236         {
 237           /* If there are previously written bytes from a write with
 238              ADVANCE="no", add a record marker before performing the
 239              BACKSPACE.  */
 240
 241           if (u->previous_nonadvancing_write)
 242             finish_last_advance_record (u);
 243
 244           u->previous_nonadvancing_write = 0;
 245
 246           flush (u->s);
 247           struncate (u->s);
 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       update_position (u);
 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       flush (u->s);
 309       struncate (u->s);
 310       u->endfile = AFTER_ENDFILE;
 311       update_position (u);
 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           /* Flush the buffers.  If we have been writing to the file, the last
 347                written record is the last record in the file, so truncate the
 348                file now.  Reset to read mode so two consecutive rewind
 349                statements do not delete the file contents.  */
 350           flush (u->s);
 351           if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
 352             struncate (u->s);
 353
 354           u->mode = READING;
 355           u->last_record = 0;
 356
 357           if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE)
 358             generate_error (&fpp->common, LIBERROR_OS, NULL);
 359
 360           /* Handle special files like /dev/null differently.  */
 361           if (!is_special (u->s))
 362             {
 363               /* We are rewinding so we are not at the end.  */
 364               u->endfile = NO_ENDFILE;
 365             }
 366           else
 367             {
 368               /* Set this for compatibilty with g77 for /dev/null.  */
 369               if (file_length (u->s) == 0  && file_position (u->s) == 0)
 370                 u->endfile = AT_ENDFILE;
 371               /* Future refinements on special files can go here.  */
 372             }
 373
 374           u->current_record = 0;
 375           u->strm_pos = 1;
 376           u->read_bad = 0;
 377         }
 378       /* Update position for INQUIRE.  */
 379       u->flags.position = POSITION_REWIND;
 380       unlock_unit (u);
 381     }
 382
 383   library_end ();
 384 }
 385
 386
 387 extern void st_flush (st_parameter_filepos *);
 388 export_proto(st_flush);
 389
 390 void
 391 st_flush (st_parameter_filepos *fpp)
 392 {
 393   gfc_unit *u;
 394
 395   library_start (&fpp->common);
 396
 397   u = find_unit (fpp->common.unit);
 398   if (u != NULL)
 399     {
 400       flush (u->s);
 401       unlock_unit (u);
 402     }
 403   else
 404     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 405     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 406                         "Specified UNIT in FLUSH is not connected");
 407
 408   library_end ();
 409 }