libgfortran/io/file_pos.c

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