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   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     u->endfile = AT_ENDFILE;
 165   else
 166     {
 167       if (file_position (u->s) == 0)
 168         goto done;              /* Common special case */
 169
 170       if (u->mode == WRITING)
 171         {
 172           flush (u->s);
 173           struncate (u->s);
 174           u->mode = READING;
 175         }
 176
 177       if (u->flags.form == FORM_FORMATTED)
 178         formatted_backspace (fpp, u);
 179       else
 180         unformatted_backspace (fpp, u);
 181
 182       u->endfile = NO_ENDFILE;
 183       u->current_record = 0;
 184       u->bytes_left = 0;
 185     }
 186
 187  done:
 188   if (u != NULL)
 189     unlock_unit (u);
 190
 191   library_end ();
 192 }
 193
 194
 195 extern void st_endfile (st_parameter_filepos *);
 196 export_proto(st_endfile);
 197
 198 void
 199 st_endfile (st_parameter_filepos *fpp)
 200 {
 201   gfc_unit *u;
 202
 203   library_start (&fpp->common);
 204
 205   u = find_unit (fpp->common.unit);
 206   if (u != NULL)
 207     {
 208       if (u->current_record)
 209         {
 210           st_parameter_dt dtp;
 211           dtp.common = fpp->common;
 212           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 213           dtp.u.p.current_unit = u;
 214           next_record (&dtp, 1);
 215         }
 216
 217       flush (u->s);
 218       struncate (u->s);
 219       u->endfile = AFTER_ENDFILE;
 220       unlock_unit (u);
 221     }
 222
 223   library_end ();
 224 }
 225
 226
 227 extern void st_rewind (st_parameter_filepos *);
 228 export_proto(st_rewind);
 229
 230 void
 231 st_rewind (st_parameter_filepos *fpp)
 232 {
 233   gfc_unit *u;
 234
 235   library_start (&fpp->common);
 236
 237   u = find_unit (fpp->common.unit);
 238   if (u != NULL)
 239     {
 240       if (u->flags.access != ACCESS_SEQUENTIAL)
 241         generate_error (&fpp->common, ERROR_BAD_OPTION,
 242                         "Cannot REWIND a file opened for DIRECT access");
 243       else
 244         {
 245           /* If we have been writing to the file, the last written record
 246              is the last record in the file, so truncate the file now.
 247              Reset to read mode so two consecutive rewind statements do not
 248              delete the file contents.  Flush buffer when switching mode.  */
 249           if (u->mode == WRITING)
 250             {
 251               flush (u->s);
 252               struncate (u->s);
 253             }
 254           u->mode = READING;
 255           u->last_record = 0;
 256           if (sseek (u->s, 0) == FAILURE)
 257             generate_error (&fpp->common, ERROR_OS, NULL);
 258
 259           u->endfile = NO_ENDFILE;
 260           u->current_record = 0;
 261           u->bytes_left = 0;
 262           test_endfile (u);
 263         }
 264       /* Update position for INQUIRE.  */
 265       u->flags.position = POSITION_REWIND;
 266       unlock_unit (u);
 267     }
 268
 269   library_end ();
 270 }
 271
 272
 273 extern void st_flush (st_parameter_filepos *);
 274 export_proto(st_flush);
 275
 276 void
 277 st_flush (st_parameter_filepos *fpp)
 278 {
 279   gfc_unit *u;
 280
 281   library_start (&fpp->common);
 282
 283   u = find_unit (fpp->common.unit);
 284   if (u != NULL)
 285     {
 286       flush (u->s);
 287       unlock_unit (u);
 288     }
 289
 290   library_end ();
 291 }