libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005, 2006, 2007 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       u->flags.position = POSITION_APPEND;
 217       flush (u->s);
 218       struncate (u->s);
 219     }
 220   else
 221     {
 222       if (file_position (u->s) == 0)
 223         {
 224           u->flags.position = POSITION_REWIND;
 225           goto done;            /* Common special case */
 226         }
 227
 228       if (u->mode == WRITING)
 229         {
 230           flush (u->s);
 231           struncate (u->s);
 232           u->mode = READING;
 233         }
 234
 235       if (u->flags.form == FORM_FORMATTED)
 236         formatted_backspace (fpp, u);
 237       else
 238         unformatted_backspace (fpp, u);
 239
 240       update_position (u);
 241       u->endfile = NO_ENDFILE;
 242       u->current_record = 0;
 243       u->bytes_left = 0;
 244     }
 245
 246  done:
 247   if (u != NULL)
 248     unlock_unit (u);
 249
 250   library_end ();
 251 }
 252
 253
 254 extern void st_endfile (st_parameter_filepos *);
 255 export_proto(st_endfile);
 256
 257 void
 258 st_endfile (st_parameter_filepos *fpp)
 259 {
 260   gfc_unit *u;
 261
 262   library_start (&fpp->common);
 263
 264   u = find_unit (fpp->common.unit);
 265   if (u != NULL)
 266     {
 267       if (u->current_record)
 268         {
 269           st_parameter_dt dtp;
 270           dtp.common = fpp->common;
 271           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 272           dtp.u.p.current_unit = u;
 273           next_record (&dtp, 1);
 274         }
 275
 276       flush (u->s);
 277       struncate (u->s);
 278       u->endfile = AFTER_ENDFILE;
 279       update_position (u);
 280       unlock_unit (u);
 281     }
 282
 283   library_end ();
 284 }
 285
 286
 287 extern void st_rewind (st_parameter_filepos *);
 288 export_proto(st_rewind);
 289
 290 void
 291 st_rewind (st_parameter_filepos *fpp)
 292 {
 293   gfc_unit *u;
 294
 295   library_start (&fpp->common);
 296
 297   u = find_unit (fpp->common.unit);
 298   if (u != NULL)
 299     {
 300       if (u->flags.access == ACCESS_DIRECT)
 301         generate_error (&fpp->common, ERROR_BAD_OPTION,
 302                         "Cannot REWIND a file opened for DIRECT access");
 303       else
 304         {
 305           /* Flush the buffers.  If we have been writing to the file, the last
 306                written record is the last record in the file, so truncate the
 307                file now.  Reset to read mode so two consecutive rewind
 308                statements do not delete the file contents.  */
 309           flush (u->s);
 310           if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
 311             struncate (u->s);
 312
 313           u->mode = READING;
 314           u->last_record = 0;
 315
 316           if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE)
 317             generate_error (&fpp->common, ERROR_OS, NULL);
 318
 319           /* Handle special files like /dev/null differently.  */
 320           if (!is_special (u->s))
 321             {
 322               /* We are rewinding so we are not at the end.  */
 323               u->endfile = NO_ENDFILE;
 324             }
 325           else
 326             {
 327               /* Set this for compatibilty with g77 for /dev/null.  */
 328               if (file_length (u->s) == 0  && file_position (u->s) == 0)
 329                 u->endfile = AT_ENDFILE;
 330               /* Future refinements on special files can go here.  */
 331             }
 332
 333           u->current_record = 0;
 334           u->strm_pos = 1;
 335           u->read_bad = 0;
 336         }
 337       /* Update position for INQUIRE.  */
 338       u->flags.position = POSITION_REWIND;
 339       unlock_unit (u);
 340     }
 341
 342   library_end ();
 343 }
 344
 345
 346 extern void st_flush (st_parameter_filepos *);
 347 export_proto(st_flush);
 348
 349 void
 350 st_flush (st_parameter_filepos *fpp)
 351 {
 352   gfc_unit *u;
 353
 354   library_start (&fpp->common);
 355
 356   u = find_unit (fpp->common.unit);
 357   if (u != NULL)
 358     {
 359       flush (u->s);
 360       unlock_unit (u);
 361     }
 362   else
 363     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 364     generate_error (&fpp->common, ERROR_BAD_OPTION,
 365                         "Specified UNIT in FLUSH is not connected");
 366
 367   library_end ();
 368 }