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.  Loop over subrecords.  */
 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   int continued;
 111   char *p;
 112
 113   if (compile_options.record_marker == 0)
 114     length = sizeof (GFC_INTEGER_4);
 115   else
 116     length = compile_options.record_marker;
 117
 118   do
 119     {
 120       length_read = length;
 121
 122       p = salloc_r_at (u->s, &length_read,
 123                        file_position (u->s) - length);
 124       if (p == NULL || length_read != length)
 125         goto io_error;
 126
 127       /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
 128       if (u->flags.convert == CONVERT_NATIVE)
 129         {
 130           switch (length)
 131             {
 132             case sizeof(GFC_INTEGER_4):
 133               memcpy (&m4, p, sizeof (m4));
 134               m = m4;
 135               break;
 136
 137             case sizeof(GFC_INTEGER_8):
 138               memcpy (&m8, p, sizeof (m8));
 139               m = m8;
 140               break;
 141
 142             default:
 143               runtime_error ("Illegal value for record marker");
 144               break;
 145             }
 146         }
 147       else
 148         {
 149           switch (length)
 150             {
 151             case sizeof(GFC_INTEGER_4):
 152               reverse_memcpy (&m4, p, sizeof (m4));
 153               m = m4;
 154               break;
 155
 156             case sizeof(GFC_INTEGER_8):
 157               reverse_memcpy (&m8, p, sizeof (m8));
 158               m = m8;
 159               break;
 160
 161             default:
 162               runtime_error ("Illegal value for record marker");
 163               break;
 164             }
 165
 166         }
 167
 168       continued = m < 0;
 169       if (continued)
 170         m = -m;
 171
 172       if ((new = file_position (u->s) - m - 2*length) < 0)
 173         new = 0;
 174
 175       if (sseek (u->s, new) == FAILURE)
 176         goto io_error;
 177     } while (continued);
 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 || u->flags.access == ACCESS_STREAM)
 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_DIRECT)
 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 && u->flags.access != ACCESS_STREAM)
 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->strm_pos = 1;
 316           u->read_bad = 0;
 317           test_endfile (u);
 318         }
 319       /* Update position for INQUIRE.  */
 320       u->flags.position = POSITION_REWIND;
 321       unlock_unit (u);
 322     }
 323
 324   library_end ();
 325 }
 326
 327
 328 extern void st_flush (st_parameter_filepos *);
 329 export_proto(st_flush);
 330
 331 void
 332 st_flush (st_parameter_filepos *fpp)
 333 {
 334   gfc_unit *u;
 335
 336   library_start (&fpp->common);
 337
 338   u = find_unit (fpp->common.unit);
 339   if (u != NULL)
 340     {
 341       flush (u->s);
 342       unlock_unit (u);
 343     }
 344   else
 345     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 346     generate_error (&fpp->common, ERROR_BAD_OPTION,
 347                         "Specified UNIT in FLUSH is not connected");
 348
 349   library_end ();
 350 }