libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009 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 3, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 Under Section 7 of GPL version 3, you are granted additional
  17 permissions described in the GCC Runtime Library Exception, version
  18 3.1, as published by the Free Software Foundation.
  19
  20 You should have received a copy of the GNU General Public License and
  21 a copy of the GCC Runtime Library Exception along with this program;
  22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  23 <http://www.gnu.org/licenses/>.  */
  24
  25 #include "io.h"
  26 #include "fbuf.h"
  27 #include "unix.h"
  28 #include <string.h>
  29
  30 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
  31    ENDFILE, and REWIND as well as the FLUSH statement.  */
  32
  33
  34 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
  35    current position is after the newline that terminates the previous
  36    record, and we have to sift backwards to find the newline before
  37    that or the start of the file, whichever comes first.  */
  38
  39 static const int READ_CHUNK = 4096;
  40
  41 static void
  42 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  43 {
  44   gfc_offset base;
  45   char p[READ_CHUNK];
  46   ssize_t n;
  47
  48   base = stell (u->s) - 1;
  49
  50   do
  51     {
  52       n = (base < READ_CHUNK) ? base : READ_CHUNK;
  53       base -= n;
  54       if (sseek (u->s, base, SEEK_SET) < 0)
  55         goto io_error;
  56       if (sread (u->s, p, n) != n)
  57         goto io_error;
  58
  59       /* We have moved backwards from the current position, it should
  60          not be possible to get a short read.  Because it is not
  61          clear what to do about such thing, we ignore the possibility.  */
  62
  63       /* There is no memrchr() in the C library, so we have to do it
  64          ourselves.  */
  65
  66       while (n > 0)
  67         {
  68           n--;
  69           if (p[n] == '\n')
  70             {
  71               base += n + 1;
  72               goto done;
  73             }
  74         }
  75
  76     }
  77   while (base != 0);
  78
  79   /* base is the new pointer.  Seek to it exactly.  */
  80  done:
  81   if (sseek (u->s, base, SEEK_SET) < 0)
  82     goto io_error;
  83   u->last_record--;
  84   u->endfile = NO_ENDFILE;
  85
  86   return;
  87
  88  io_error:
  89   generate_error (&fpp->common, LIBERROR_OS, NULL);
  90 }
  91
  92
  93 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
  94    sequential file.  We are guaranteed to be between records on entry and
  95    we have to shift to the previous record.  Loop over subrecords.  */
  96
  97 static void
  98 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  99 {
 100   gfc_offset m, slen;
 101   GFC_INTEGER_4 m4;
 102   GFC_INTEGER_8 m8;
 103   ssize_t length;
 104   int continued;
 105   char p[sizeof (GFC_INTEGER_8)];
 106
 107   if (compile_options.record_marker == 0)
 108     length = sizeof (GFC_INTEGER_4);
 109   else
 110     length = compile_options.record_marker;
 111
 112   do
 113     {
 114       slen = - (gfc_offset) length;
 115       if (sseek (u->s, slen, SEEK_CUR) < 0)
 116         goto io_error;
 117       if (sread (u->s, p, length) != length)
 118         goto io_error;
 119
 120       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
 121       if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
 122         {
 123           switch (length)
 124             {
 125             case sizeof(GFC_INTEGER_4):
 126               memcpy (&m4, p, sizeof (m4));
 127               m = m4;
 128               break;
 129
 130             case sizeof(GFC_INTEGER_8):
 131               memcpy (&m8, p, sizeof (m8));
 132               m = m8;
 133               break;
 134
 135             default:
 136               runtime_error ("Illegal value for record marker");
 137               break;
 138             }
 139         }
 140       else
 141         {
 142           switch (length)
 143             {
 144             case sizeof(GFC_INTEGER_4):
 145               reverse_memcpy (&m4, p, sizeof (m4));
 146               m = m4;
 147               break;
 148
 149             case sizeof(GFC_INTEGER_8):
 150               reverse_memcpy (&m8, p, sizeof (m8));
 151               m = m8;
 152               break;
 153
 154             default:
 155               runtime_error ("Illegal value for record marker");
 156               break;
 157             }
 158
 159         }
 160
 161       continued = m < 0;
 162       if (continued)
 163         m = -m;
 164
 165       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
 166         goto io_error;
 167     } while (continued);
 168
 169   u->last_record--;
 170   return;
 171
 172  io_error:
 173   generate_error (&fpp->common, LIBERROR_OS, NULL);
 174 }
 175
 176
 177 extern void st_backspace (st_parameter_filepos *);
 178 export_proto(st_backspace);
 179
 180 void
 181 st_backspace (st_parameter_filepos *fpp)
 182 {
 183   gfc_unit *u;
 184
 185   library_start (&fpp->common);
 186
 187   u = find_unit (fpp->common.unit);
 188   if (u == NULL)
 189     {
 190       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
 191       goto done;
 192     }
 193
 194   /* Direct access is prohibited, and so is unformatted stream access.  */
 195
 196
 197   if (u->flags.access == ACCESS_DIRECT)
 198     {
 199       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 200                       "Cannot BACKSPACE a file opened for DIRECT access");
 201       goto done;
 202     }
 203
 204   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
 205     {
 206       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 207                       "Cannot BACKSPACE an unformatted stream file");
 208       goto done;
 209     }
 210
 211   /* Make sure format buffer is flushed and reset.  */
 212   if (u->flags.form == FORM_FORMATTED)
 213     {
 214       int pos = fbuf_reset (u);
 215       if (pos != 0)
 216         sseek (u->s, pos, SEEK_CUR);
 217     }
 218
 219
 220   /* Check for special cases involving the ENDFILE record first.  */
 221
 222   if (u->endfile == AFTER_ENDFILE)
 223     {
 224       u->endfile = AT_ENDFILE;
 225       u->flags.position = POSITION_APPEND;
 226       sflush (u->s);
 227     }
 228   else
 229     {
 230       if (stell (u->s) == 0)
 231         {
 232           u->flags.position = POSITION_REWIND;
 233           goto done;            /* Common special case */
 234         }
 235
 236       if (u->mode == WRITING)
 237         {
 238           /* If there are previously written bytes from a write with
 239              ADVANCE="no", add a record marker before performing the
 240              BACKSPACE.  */
 241
 242           if (u->previous_nonadvancing_write)
 243             finish_last_advance_record (u);
 244
 245           u->previous_nonadvancing_write = 0;
 246
 247           unit_truncate (u, stell (u->s), &fpp->common);
 248           u->mode = READING;
 249         }
 250
 251       if (u->flags.form == FORM_FORMATTED)
 252         formatted_backspace (fpp, u);
 253       else
 254         unformatted_backspace (fpp, u);
 255
 256       u->flags.position = POSITION_UNSPECIFIED;
 257       u->endfile = NO_ENDFILE;
 258       u->current_record = 0;
 259       u->bytes_left = 0;
 260     }
 261
 262  done:
 263   if (u != NULL)
 264     unlock_unit (u);
 265
 266   library_end ();
 267 }
 268
 269
 270 extern void st_endfile (st_parameter_filepos *);
 271 export_proto(st_endfile);
 272
 273 void
 274 st_endfile (st_parameter_filepos *fpp)
 275 {
 276   gfc_unit *u;
 277
 278   library_start (&fpp->common);
 279
 280   u = find_unit (fpp->common.unit);
 281   if (u != NULL)
 282     {
 283       if (u->flags.access == ACCESS_DIRECT)
 284         {
 285           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 286                           "Cannot perform ENDFILE on a file opened "
 287                           "for DIRECT access");
 288           goto done;
 289         }
 290
 291       if (u->flags.access == ACCESS_SEQUENTIAL
 292           && u->endfile == AFTER_ENDFILE)
 293         {
 294           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 295                           "Cannot perform ENDFILE on a file already "
 296                           "positioned after the EOF marker");
 297           goto done;
 298         }
 299
 300       /* If there are previously written bytes from a write with ADVANCE="no",
 301          add a record marker before performing the ENDFILE.  */
 302
 303       if (u->previous_nonadvancing_write)
 304         finish_last_advance_record (u);
 305
 306       u->previous_nonadvancing_write = 0;
 307
 308       if (u->current_record)
 309         {
 310           st_parameter_dt dtp;
 311           dtp.common = fpp->common;
 312           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 313           dtp.u.p.current_unit = u;
 314           next_record (&dtp, 1);
 315         }
 316
 317       unit_truncate (u, stell (u->s), &fpp->common);
 318       u->endfile = AFTER_ENDFILE;
 319       if (0 == stell (u->s))
 320         u->flags.position = POSITION_REWIND;
 321     }
 322   else
 323     {
 324       if (fpp->common.unit < 0)
 325         {
 326           generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 327                           "Bad unit number in statement");
 328           return;
 329         }
 330
 331       u = find_or_create_unit (fpp->common.unit);
 332       if (u->s == NULL)
 333         {
 334           /* Open the unit with some default flags.  */
 335           st_parameter_open opp;
 336           unit_flags u_flags;
 337
 338           memset (&u_flags, '\0', sizeof (u_flags));
 339           u_flags.access = ACCESS_SEQUENTIAL;
 340           u_flags.action = ACTION_READWRITE;
 341
 342           /* Is it unformatted?  */
 343           if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
 344                                      | IOPARM_DT_IONML_SET)))
 345             u_flags.form = FORM_UNFORMATTED;
 346           else
 347             u_flags.form = FORM_UNSPECIFIED;
 348
 349           u_flags.delim = DELIM_UNSPECIFIED;
 350           u_flags.blank = BLANK_UNSPECIFIED;
 351           u_flags.pad = PAD_UNSPECIFIED;
 352           u_flags.decimal = DECIMAL_UNSPECIFIED;
 353           u_flags.encoding = ENCODING_UNSPECIFIED;
 354           u_flags.async = ASYNC_UNSPECIFIED;
 355           u_flags.round = ROUND_UNSPECIFIED;
 356           u_flags.sign = SIGN_UNSPECIFIED;
 357           u_flags.status = STATUS_UNKNOWN;
 358           u_flags.convert = GFC_CONVERT_NATIVE;
 359
 360           opp.common = fpp->common;
 361           opp.common.flags &= IOPARM_COMMON_MASK;
 362           u = new_unit (&opp, u, &u_flags);
 363           if (u == NULL)
 364             return;
 365           u->endfile = AFTER_ENDFILE;
 366         }
 367     }
 368
 369   done:
 370     unlock_unit (u);
 371
 372   library_end ();
 373 }
 374
 375
 376 extern void st_rewind (st_parameter_filepos *);
 377 export_proto(st_rewind);
 378
 379 void
 380 st_rewind (st_parameter_filepos *fpp)
 381 {
 382   gfc_unit *u;
 383
 384   library_start (&fpp->common);
 385
 386   u = find_unit (fpp->common.unit);
 387   if (u != NULL)
 388     {
 389       if (u->flags.access == ACCESS_DIRECT)
 390         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 391                         "Cannot REWIND a file opened for DIRECT access");
 392       else
 393         {
 394           /* If there are previously written bytes from a write with ADVANCE="no",
 395              add a record marker before performing the ENDFILE.  */
 396
 397           if (u->previous_nonadvancing_write)
 398             finish_last_advance_record (u);
 399
 400           u->previous_nonadvancing_write = 0;
 401
 402           fbuf_reset (u);
 403
 404           u->last_record = 0;
 405
 406           if (sseek (u->s, 0, SEEK_SET) < 0)
 407             generate_error (&fpp->common, LIBERROR_OS, NULL);
 408
 409           /* Handle special files like /dev/null differently.  */
 410           if (!is_special (u->s))
 411             {
 412               /* We are rewinding so we are not at the end.  */
 413               u->endfile = NO_ENDFILE;
 414             }
 415           else
 416             {
 417               /* Set this for compatibilty with g77 for /dev/null.  */
 418               if (file_length (u->s) == 0  && stell (u->s) == 0)
 419                 u->endfile = AT_ENDFILE;
 420               /* Future refinements on special files can go here.  */
 421             }
 422
 423           u->current_record = 0;
 424           u->strm_pos = 1;
 425           u->read_bad = 0;
 426         }
 427       /* Update position for INQUIRE.  */
 428       u->flags.position = POSITION_REWIND;
 429       unlock_unit (u);
 430     }
 431
 432   library_end ();
 433 }
 434
 435
 436 extern void st_flush (st_parameter_filepos *);
 437 export_proto(st_flush);
 438
 439 void
 440 st_flush (st_parameter_filepos *fpp)
 441 {
 442   gfc_unit *u;
 443
 444   library_start (&fpp->common);
 445
 446   u = find_unit (fpp->common.unit);
 447   if (u != NULL)
 448     {
 449       /* Make sure format buffer is flushed.  */
 450       if (u->flags.form == FORM_FORMATTED)
 451         fbuf_flush (u, u->mode);
 452
 453       sflush (u->s);
 454       unlock_unit (u);
 455     }
 456   else
 457     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 458     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 459                         "Specified UNIT in FLUSH is not connected");
 460
 461   library_end ();
 462 }