libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005, 2006 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   if ((new = file_position (u->s) - m - 2*length) < 0)
 124     new = 0;
 125
 126   if (sseek (u->s, new) == FAILURE)
 127     goto io_error;
 128
 129   u->last_record--;
 130   return;
 131
 132  io_error:
 133   generate_error (&fpp->common, ERROR_OS, NULL);
 134 }
 135
 136
 137 extern void st_backspace (st_parameter_filepos *);
 138 export_proto(st_backspace);
 139
 140 void
 141 st_backspace (st_parameter_filepos *fpp)
 142 {
 143   gfc_unit *u;
 144
 145   library_start (&fpp->common);
 146
 147   u = find_unit (fpp->common.unit);
 148   if (u == NULL)
 149     {
 150       generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
 151       goto done;
 152     }
 153
 154   /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
 155      sequential I/O and the next direct access transfer repositions the file
 156      anyway.  */
 157
 158   if (u->flags.access == ACCESS_DIRECT)
 159     goto done;
 160
 161   /* Check for special cases involving the ENDFILE record first.  */
 162
 163   if (u->endfile == AFTER_ENDFILE)
 164     {
 165       u->endfile = AT_ENDFILE;
 166       flush (u->s);
 167       struncate (u->s);
 168     }
 169   else
 170     {
 171       if (file_position (u->s) == 0)
 172         goto done;              /* Common special case */
 173
 174       if (u->mode == WRITING)
 175         {
 176           flush (u->s);
 177           struncate (u->s);
 178           u->mode = READING;
 179         }
 180
 181       if (u->flags.form == FORM_FORMATTED)
 182         formatted_backspace (fpp, u);
 183       else
 184         unformatted_backspace (fpp, u);
 185
 186       u->endfile = NO_ENDFILE;
 187       u->current_record = 0;
 188       u->bytes_left = 0;
 189     }
 190
 191  done:
 192   if (u != NULL)
 193     unlock_unit (u);
 194
 195   library_end ();
 196 }
 197
 198
 199 extern void st_endfile (st_parameter_filepos *);
 200 export_proto(st_endfile);
 201
 202 void
 203 st_endfile (st_parameter_filepos *fpp)
 204 {
 205   gfc_unit *u;
 206
 207   library_start (&fpp->common);
 208
 209   u = find_unit (fpp->common.unit);
 210   if (u != NULL)
 211     {
 212       if (u->current_record)
 213         {
 214           st_parameter_dt dtp;
 215           dtp.common = fpp->common;
 216           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 217           dtp.u.p.current_unit = u;
 218           next_record (&dtp, 1);
 219         }
 220
 221       flush (u->s);
 222       struncate (u->s);
 223       u->endfile = AFTER_ENDFILE;
 224       unlock_unit (u);
 225     }
 226
 227   library_end ();
 228 }
 229
 230
 231 extern void st_rewind (st_parameter_filepos *);
 232 export_proto(st_rewind);
 233
 234 void
 235 st_rewind (st_parameter_filepos *fpp)
 236 {
 237   gfc_unit *u;
 238
 239   library_start (&fpp->common);
 240
 241   u = find_unit (fpp->common.unit);
 242   if (u != NULL)
 243     {
 244       if (u->flags.access != ACCESS_SEQUENTIAL)
 245         generate_error (&fpp->common, ERROR_BAD_OPTION,
 246                         "Cannot REWIND a file opened for DIRECT access");
 247       else
 248         {
 249           /* Flush the buffers.  If we have been writing to the file, the last
 250                written record is the last record in the file, so truncate the
 251                file now.  Reset to read mode so two consecutive rewind
 252                statements do not delete the file contents.  */
 253           flush (u->s);
 254           if (u->mode == WRITING)
 255             struncate (u->s);
 256
 257           u->mode = READING;
 258           u->last_record = 0;
 259           if (sseek (u->s, 0) == FAILURE)
 260             generate_error (&fpp->common, ERROR_OS, NULL);
 261
 262           u->endfile = NO_ENDFILE;
 263           u->current_record = 0;
 264           u->bytes_left = 0;
 265           test_endfile (u);
 266         }
 267       /* Update position for INQUIRE.  */
 268       u->flags.position = POSITION_REWIND;
 269       unlock_unit (u);
 270     }
 271
 272   library_end ();
 273 }
 274
 275
 276 extern void st_flush (st_parameter_filepos *);
 277 export_proto(st_flush);
 278
 279 void
 280 st_flush (st_parameter_filepos *fpp)
 281 {
 282   gfc_unit *u;
 283
 284   library_start (&fpp->common);
 285
 286   u = find_unit (fpp->common.unit);
 287   if (u != NULL)
 288     {
 289       flush (u->s);
 290       unlock_unit (u);
 291     }
 292
 293   library_end ();
 294 }