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   GFC_INTEGER_4 m4;
 108   GFC_INTEGER_8 m8;
 109   int length, length_read;
 110   char *p;
 111
 112   if (compile_options.record_marker == 0)
 113     length = sizeof (gfc_offset);
 114   else
 115     length = compile_options.record_marker;
 116
 117   length_read = length;
 118
 119   p = salloc_r_at (u->s, &length_read,
 120                    file_position (u->s) - length);
 121   if (p == NULL || length_read != length)
 122     goto io_error;
 123
 124   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
 125   if (u->flags.convert == CONVERT_NATIVE)
 126     {
 127       switch (compile_options.record_marker)
 128         {
 129         case 0:
 130           memcpy (&m, p, sizeof(gfc_offset));
 131           break;
 132
 133         case sizeof(GFC_INTEGER_4):
 134           memcpy (&m4, p, sizeof (m4));
 135           m = m4;
 136           break;
 137
 138         case sizeof(GFC_INTEGER_8):
 139           memcpy (&m8, p, sizeof (m8));
 140           m = m8;
 141           break;
 142
 143         default:
 144           runtime_error ("Illegal value for record marker");
 145           break;
 146         }
 147     }
 148   else
 149     {
 150       switch (compile_options.record_marker)
 151         {
 152         case 0:
 153           reverse_memcpy (&m, p, sizeof(gfc_offset));
 154           break;
 155
 156         case sizeof(GFC_INTEGER_4):
 157           reverse_memcpy (&m4, p, sizeof (m4));
 158           m = m4;
 159           break;
 160
 161         case sizeof(GFC_INTEGER_8):
 162           reverse_memcpy (&m8, p, sizeof (m8));
 163           m = m8;
 164           break;
 165
 166         default:
 167           runtime_error ("Illegal value for record marker");
 168           break;
 169         }
 170
 171     }
 172
 173   if ((new = file_position (u->s) - m - 2*length) < 0)
 174     new = 0;
 175
 176   if (sseek (u->s, new) == FAILURE)
 177     goto io_error;
 178
 179   u->last_record--;
 180   return;
 181
 182  io_error:
 183   generate_error (&fpp->common, ERROR_OS, NULL);
 184 }
 185
 186
 187 extern void st_backspace (st_parameter_filepos *);
 188 export_proto(st_backspace);
 189
 190 void
 191 st_backspace (st_parameter_filepos *fpp)
 192 {
 193   gfc_unit *u;
 194
 195   library_start (&fpp->common);
 196
 197   u = find_unit (fpp->common.unit);
 198   if (u == NULL)
 199     {
 200       generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
 201       goto done;
 202     }
 203
 204   /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
 205      sequential I/O and the next direct access transfer repositions the file
 206      anyway.  */
 207
 208   if (u->flags.access == ACCESS_DIRECT)
 209     goto done;
 210
 211   /* Check for special cases involving the ENDFILE record first.  */
 212
 213   if (u->endfile == AFTER_ENDFILE)
 214     {
 215       u->endfile = AT_ENDFILE;
 216       flush (u->s);
 217       struncate (u->s);
 218     }
 219   else
 220     {
 221       if (file_position (u->s) == 0)
 222         goto done;              /* Common special case */
 223
 224       if (u->mode == WRITING)
 225         {
 226           flush (u->s);
 227           struncate (u->s);
 228           u->mode = READING;
 229         }
 230
 231       if (u->flags.form == FORM_FORMATTED)
 232         formatted_backspace (fpp, u);
 233       else
 234         unformatted_backspace (fpp, u);
 235
 236       u->endfile = NO_ENDFILE;
 237       u->current_record = 0;
 238       u->bytes_left = 0;
 239     }
 240
 241  done:
 242   if (u != NULL)
 243     unlock_unit (u);
 244
 245   library_end ();
 246 }
 247
 248
 249 extern void st_endfile (st_parameter_filepos *);
 250 export_proto(st_endfile);
 251
 252 void
 253 st_endfile (st_parameter_filepos *fpp)
 254 {
 255   gfc_unit *u;
 256
 257   library_start (&fpp->common);
 258
 259   u = find_unit (fpp->common.unit);
 260   if (u != NULL)
 261     {
 262       if (u->current_record)
 263         {
 264           st_parameter_dt dtp;
 265           dtp.common = fpp->common;
 266           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 267           dtp.u.p.current_unit = u;
 268           next_record (&dtp, 1);
 269         }
 270
 271       flush (u->s);
 272       struncate (u->s);
 273       u->endfile = AFTER_ENDFILE;
 274       unlock_unit (u);
 275     }
 276
 277   library_end ();
 278 }
 279
 280
 281 extern void st_rewind (st_parameter_filepos *);
 282 export_proto(st_rewind);
 283
 284 void
 285 st_rewind (st_parameter_filepos *fpp)
 286 {
 287   gfc_unit *u;
 288
 289   library_start (&fpp->common);
 290
 291   u = find_unit (fpp->common.unit);
 292   if (u != NULL)
 293     {
 294       if (u->flags.access != ACCESS_SEQUENTIAL)
 295         generate_error (&fpp->common, ERROR_BAD_OPTION,
 296                         "Cannot REWIND a file opened for DIRECT access");
 297       else
 298         {
 299           /* Flush the buffers.  If we have been writing to the file, the last
 300                written record is the last record in the file, so truncate the
 301                file now.  Reset to read mode so two consecutive rewind
 302                statements do not delete the file contents.  */
 303           flush (u->s);
 304           if (u->mode == WRITING)
 305             struncate (u->s);
 306
 307           u->mode = READING;
 308           u->last_record = 0;
 309           if (sseek (u->s, 0) == FAILURE)
 310             generate_error (&fpp->common, ERROR_OS, NULL);
 311
 312           u->endfile = NO_ENDFILE;
 313           u->current_record = 0;
 314           u->bytes_left = 0;
 315           u->read_bad = 0;
 316           test_endfile (u);
 317         }
 318       /* Update position for INQUIRE.  */
 319       u->flags.position = POSITION_REWIND;
 320       unlock_unit (u);
 321     }
 322
 323   library_end ();
 324 }
 325
 326
 327 extern void st_flush (st_parameter_filepos *);
 328 export_proto(st_flush);
 329
 330 void
 331 st_flush (st_parameter_filepos *fpp)
 332 {
 333   gfc_unit *u;
 334
 335   library_start (&fpp->common);
 336
 337   u = find_unit (fpp->common.unit);
 338   if (u != NULL)
 339     {
 340       flush (u->s);
 341       unlock_unit (u);
 342     }
 343   else
 344     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 345     generate_error (&fpp->common, ERROR_BAD_OPTION,
 346                         "Specified UNIT in FLUSH is not connected");
 347
 348   library_end ();
 349 }