libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005 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 "config.h"
  31 #include <string.h>
  32 #include "libgfortran.h"
  33 #include "io.h"
  34
  35 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
  36    ENDFILE, and REWIND as well as the FLUSH statement.  */
  37
  38
  39 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
  40    current position is after the newline that terminates the previous
  41    record, and we have to sift backwards to find the newline before
  42    that or the start of the file, whichever comes first.  */
  43
  44 #define READ_CHUNK 4096
  45
  46 static void
  47 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  48 {
  49   gfc_offset base;
  50   char *p;
  51   int n;
  52
  53   base = file_position (u->s) - 1;
  54
  55   do
  56     {
  57       n = (base < READ_CHUNK) ? base : READ_CHUNK;
  58       base -= n;
  59
  60       p = salloc_r_at (u->s, &n, base);
  61       if (p == NULL)
  62         goto io_error;
  63
  64       /* We have moved backwards from the current position, it should
  65          not be possible to get a short read.  Because it is not
  66          clear what to do about such thing, we ignore the possibility.  */
  67
  68       /* There is no memrchr() in the C library, so we have to do it
  69          ourselves.  */
  70
  71       n--;
  72       while (n >= 0)
  73         {
  74           if (p[n] == '\n')
  75             {
  76               base += n + 1;
  77               goto done;
  78             }
  79           n--;
  80         }
  81
  82     }
  83   while (base != 0);
  84
  85   /* base is the new pointer.  Seek to it exactly.  */
  86  done:
  87   if (sseek (u->s, base) == FAILURE)
  88     goto io_error;
  89   u->last_record--;
  90   u->endfile = NO_ENDFILE;
  91
  92   return;
  93
  94  io_error:
  95   generate_error (&fpp->common, ERROR_OS, NULL);
  96 }
  97
  98
  99 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
 100    sequential file.  We are guaranteed to be between records on entry and
 101    we have to shift to the previous record.  */
 102
 103 static void
 104 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 105 {
 106   gfc_offset m, new;
 107   int length;
 108   char *p;
 109
 110   length = sizeof (gfc_offset);
 111
 112   p = salloc_r_at (u->s, &length,
 113                    file_position (u->s) - length);
 114   if (p == NULL)
 115     goto io_error;
 116
 117   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
 118   if (u->flags.convert == CONVERT_NATIVE)
 119     memcpy (&m, p, sizeof (gfc_offset));
 120   else
 121     reverse_memcpy (&m, p, sizeof (gfc_offset));
 122
 123   new = file_position (u->s) - m - 2*length;
 124   if (sseek (u->s, new) == FAILURE)
 125     goto io_error;
 126
 127   u->last_record--;
 128   return;
 129
 130  io_error:
 131   generate_error (&fpp->common, ERROR_OS, NULL);
 132 }
 133
 134
 135 extern void st_backspace (st_parameter_filepos *);
 136 export_proto(st_backspace);
 137
 138 void
 139 st_backspace (st_parameter_filepos *fpp)
 140 {
 141   gfc_unit *u;
 142
 143   library_start (&fpp->common);
 144
 145   u = find_unit (fpp->common.unit);
 146   if (u == NULL)
 147     {
 148       generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
 149       goto done;
 150     }
 151
 152   /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
 153      sequential I/O and the next direct access transfer repositions the file
 154      anyway.  */
 155
 156   if (u->flags.access == ACCESS_DIRECT)
 157     goto done;
 158
 159   /* Check for special cases involving the ENDFILE record first.  */
 160
 161   if (u->endfile == AFTER_ENDFILE)
 162     u->endfile = AT_ENDFILE;
 163   else
 164     {
 165       if (file_position (u->s) == 0)
 166         goto done;              /* Common special case */
 167
 168       if (u->mode == WRITING)
 169         {
 170           flush (u->s);
 171           struncate (u->s);
 172           u->mode = READING;
 173         }
 174
 175       if (u->flags.form == FORM_FORMATTED)
 176         formatted_backspace (fpp, u);
 177       else
 178         unformatted_backspace (fpp, u);
 179
 180       u->endfile = NO_ENDFILE;
 181       u->current_record = 0;
 182     }
 183
 184  done:
 185   if (u != NULL)
 186     unlock_unit (u);
 187
 188   library_end ();
 189 }
 190
 191
 192 extern void st_endfile (st_parameter_filepos *);
 193 export_proto(st_endfile);
 194
 195 void
 196 st_endfile (st_parameter_filepos *fpp)
 197 {
 198   gfc_unit *u;
 199
 200   library_start (&fpp->common);
 201
 202   u = find_unit (fpp->common.unit);
 203   if (u != NULL)
 204     {
 205       if (u->current_record)
 206         {
 207           st_parameter_dt dtp;
 208           dtp.common = fpp->common;
 209           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 210           dtp.u.p.current_unit = u;
 211           next_record (&dtp, 1);
 212         }
 213
 214       flush (u->s);
 215       struncate (u->s);
 216       u->endfile = AFTER_ENDFILE;
 217       unlock_unit (u);
 218     }
 219
 220   library_end ();
 221 }
 222
 223
 224 extern void st_rewind (st_parameter_filepos *);
 225 export_proto(st_rewind);
 226
 227 void
 228 st_rewind (st_parameter_filepos *fpp)
 229 {
 230   gfc_unit *u;
 231
 232   library_start (&fpp->common);
 233
 234   u = find_unit (fpp->common.unit);
 235   if (u != NULL)
 236     {
 237       if (u->flags.access != ACCESS_SEQUENTIAL)
 238         generate_error (&fpp->common, ERROR_BAD_OPTION,
 239                         "Cannot REWIND a file opened for DIRECT access");
 240       else
 241         {
 242           /* If we have been writing to the file, the last written record
 243              is the last record in the file, so truncate the file now.
 244              Reset to read mode so two consecutive rewind statements do not
 245              delete the file contents.  Flush buffer when switching mode.  */
 246           if (u->mode == WRITING)
 247             {
 248               flush (u->s);
 249               struncate (u->s);
 250             }
 251           u->mode = READING;
 252           u->last_record = 0;
 253           if (sseek (u->s, 0) == FAILURE)
 254             generate_error (&fpp->common, ERROR_OS, NULL);
 255
 256           u->endfile = NO_ENDFILE;
 257           u->current_record = 0;
 258           test_endfile (u);
 259         }
 260       /* Update position for INQUIRE.  */
 261       u->flags.position = POSITION_REWIND;
 262       unlock_unit (u);
 263     }
 264
 265   library_end ();
 266 }
 267
 268
 269 extern void st_flush (st_parameter_filepos *);
 270 export_proto(st_flush);
 271
 272 void
 273 st_flush (st_parameter_filepos *fpp)
 274 {
 275   gfc_unit *u;
 276
 277   library_start (&fpp->common);
 278
 279   u = find_unit (fpp->common.unit);
 280   if (u != NULL)
 281     {
 282       flush (u->s);
 283       unlock_unit (u);
 284     }
 285
 286   library_end ();
 287 }