libgfortran/io/transfer.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
   2    Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4    Namelist transfer functions contributed by Paul Thomas
   5    F2003 I/O support contributed by Jerry DeLisle
   6
   7 This file is part of the GNU Fortran runtime library (libgfortran).
   8
   9 Libgfortran is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 3, or (at your option)
  12 any later version.
  13
  14 Libgfortran is distributed in the hope that it will be useful,
  15 but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 GNU General Public License for more details.
  18
  19 Under Section 7 of GPL version 3, you are granted additional
  20 permissions described in the GCC Runtime Library Exception, version
  21 3.1, as published by the Free Software Foundation.
  22
  23 You should have received a copy of the GNU General Public License and
  24 a copy of the GCC Runtime Library Exception along with this program;
  25 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  26 <http://www.gnu.org/licenses/>.  */
  27
  28
  29 /* transfer.c -- Top level handling of data transfer statements.  */
  30
  31 #include "io.h"
  32 #include "fbuf.h"
  33 #include "format.h"
  34 #include "unix.h"
  35 #include <string.h>
  36 #include <assert.h>
  37 #include <stdlib.h>
  38 #include <errno.h>
  39
  40
  41 /* Calling conventions:  Data transfer statements are unlike other
  42    library calls in that they extend over several calls.
  43
  44    The first call is always a call to st_read() or st_write().  These
  45    subroutines return no status unless a namelist read or write is
  46    being done, in which case there is the usual status.  No further
  47    calls are necessary in this case.
  48
  49    For other sorts of data transfer, there are zero or more data
  50    transfer statement that depend on the format of the data transfer
  51    statement. For READ (and for backwards compatibily: for WRITE), one has
  52
  53       transfer_integer
  54       transfer_logical
  55       transfer_character
  56       transfer_character_wide
  57       transfer_real
  58       transfer_complex
  59       transfer_real128
  60       transfer_complex128
  61
  62     and for WRITE
  63
  64       transfer_integer_write
  65       transfer_logical_write
  66       transfer_character_write
  67       transfer_character_wide_write
  68       transfer_real_write
  69       transfer_complex_write
  70       transfer_real128_write
  71       transfer_complex128_write
  72
  73     These subroutines do not return status. The *128 functions
  74     are in the file transfer128.c.
  75
  76     The last call is a call to st_[read|write]_done().  While
  77     something can easily go wrong with the initial st_read() or
  78     st_write(), an error inhibits any data from actually being
  79     transferred.  */
  80
  81 extern void transfer_integer (st_parameter_dt *, void *, int);
  82 export_proto(transfer_integer);
  83
  84 extern void transfer_integer_write (st_parameter_dt *, void *, int);
  85 export_proto(transfer_integer_write);
  86
  87 extern void transfer_real (st_parameter_dt *, void *, int);
  88 export_proto(transfer_real);
  89
  90 extern void transfer_real_write (st_parameter_dt *, void *, int);
  91 export_proto(transfer_real_write);
  92
  93 extern void transfer_logical (st_parameter_dt *, void *, int);
  94 export_proto(transfer_logical);
  95
  96 extern void transfer_logical_write (st_parameter_dt *, void *, int);
  97 export_proto(transfer_logical_write);
  98
  99 extern void transfer_character (st_parameter_dt *, void *, int);
 100 export_proto(transfer_character);
 101
 102 extern void transfer_character_write (st_parameter_dt *, void *, int);
 103 export_proto(transfer_character_write);
 104
 105 extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
 106 export_proto(transfer_character_wide);
 107
 108 extern void transfer_character_wide_write (st_parameter_dt *,
 109                                            void *, int, int);
 110 export_proto(transfer_character_wide_write);
 111
 112 extern void transfer_complex (st_parameter_dt *, void *, int);
 113 export_proto(transfer_complex);
 114
 115 extern void transfer_complex_write (st_parameter_dt *, void *, int);
 116 export_proto(transfer_complex_write);
 117
 118 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
 119                             gfc_charlen_type);
 120 export_proto(transfer_array);
 121
 122 extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
 123                             gfc_charlen_type);
 124 export_proto(transfer_array_write);
 125
 126 static void us_read (st_parameter_dt *, int);
 127 static void us_write (st_parameter_dt *, int);
 128 static void next_record_r_unf (st_parameter_dt *, int);
 129 static void next_record_w_unf (st_parameter_dt *, int);
 130
 131 static const st_option advance_opt[] = {
 132   {"yes", ADVANCE_YES},
 133   {"no", ADVANCE_NO},
 134   {NULL, 0}
 135 };
 136
 137
 138 static const st_option decimal_opt[] = {
 139   {"point", DECIMAL_POINT},
 140   {"comma", DECIMAL_COMMA},
 141   {NULL, 0}
 142 };
 143
 144 static const st_option round_opt[] = {
 145   {"up", ROUND_UP},
 146   {"down", ROUND_DOWN},
 147   {"zero", ROUND_ZERO},
 148   {"nearest", ROUND_NEAREST},
 149   {"compatible", ROUND_COMPATIBLE},
 150   {"processor_defined", ROUND_PROCDEFINED},
 151   {NULL, 0}
 152 };
 153
 154
 155 static const st_option sign_opt[] = {
 156   {"plus", SIGN_SP},
 157   {"suppress", SIGN_SS},
 158   {"processor_defined", SIGN_S},
 159   {NULL, 0}
 160 };
 161
 162 static const st_option blank_opt[] = {
 163   {"null", BLANK_NULL},
 164   {"zero", BLANK_ZERO},
 165   {NULL, 0}
 166 };
 167
 168 static const st_option delim_opt[] = {
 169   {"apostrophe", DELIM_APOSTROPHE},
 170   {"quote", DELIM_QUOTE},
 171   {"none", DELIM_NONE},
 172   {NULL, 0}
 173 };
 174
 175 static const st_option pad_opt[] = {
 176   {"yes", PAD_YES},
 177   {"no", PAD_NO},
 178   {NULL, 0}
 179 };
 180
 181 typedef enum
 182 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
 183   FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
 184 }
 185 file_mode;
 186
 187
 188 static file_mode
 189 current_mode (st_parameter_dt *dtp)
 190 {
 191   file_mode m;
 192
 193   m = FORM_UNSPECIFIED;
 194
 195   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 196     {
 197       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
 198         FORMATTED_DIRECT : UNFORMATTED_DIRECT;
 199     }
 200   else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
 201     {
 202       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
 203         FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
 204     }
 205   else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
 206     {
 207       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
 208         FORMATTED_STREAM : UNFORMATTED_STREAM;
 209     }
 210
 211   return m;
 212 }
 213
 214
 215 /* Mid level data transfer statements.  */
 216
 217 /* Read sequential file - internal unit  */
 218
 219 static char *
 220 read_sf_internal (st_parameter_dt *dtp, int * length)
 221 {
 222   static char *empty_string[0];
 223   char *base;
 224   int lorig;
 225
 226   /* Zero size array gives internal unit len of 0.  Nothing to read. */
 227   if (dtp->internal_unit_len == 0
 228       && dtp->u.p.current_unit->pad_status == PAD_NO)
 229     hit_eof (dtp);
 230
 231   /* If we have seen an eor previously, return a length of 0.  The
 232      caller is responsible for correctly padding the input field.  */
 233   if (dtp->u.p.sf_seen_eor)
 234     {
 235       *length = 0;
 236       /* Just return something that isn't a NULL pointer, otherwise the
 237          caller thinks an error occured.  */
 238       return (char*) empty_string;
 239     }
 240
 241   lorig = *length;
 242   if (is_char4_unit(dtp))
 243     {
 244       int i;
 245       gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
 246                         length);
 247       base = fbuf_alloc (dtp->u.p.current_unit, lorig);
 248       for (i = 0; i < *length; i++, p++)
 249         base[i] = *p > 255 ? '?' : (unsigned char) *p;
 250     }
 251   else
 252     base = mem_alloc_r (dtp->u.p.current_unit->s, length);
 253
 254   if (unlikely (lorig > *length))
 255     {
 256       hit_eof (dtp);
 257       return NULL;
 258     }
 259
 260   dtp->u.p.current_unit->bytes_left -= *length;
 261
 262   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 263     dtp->u.p.size_used += (GFC_IO_INT) *length;
 264
 265   return base;
 266
 267 }
 268
 269 /* When reading sequential formatted records we have a problem.  We
 270    don't know how long the line is until we read the trailing newline,
 271    and we don't want to read too much.  If we read too much, we might
 272    have to do a physical seek backwards depending on how much data is
 273    present, and devices like terminals aren't seekable and would cause
 274    an I/O error.
 275
 276    Given this, the solution is to read a byte at a time, stopping if
 277    we hit the newline.  For small allocations, we use a static buffer.
 278    For larger allocations, we are forced to allocate memory on the
 279    heap.  Hopefully this won't happen very often.  */
 280
 281 /* Read sequential file - external unit */
 282
 283 static char *
 284 read_sf (st_parameter_dt *dtp, int * length)
 285 {
 286   static char *empty_string[0];
 287   int q, q2;
 288   int n, lorig, seen_comma;
 289
 290   /* If we have seen an eor previously, return a length of 0.  The
 291      caller is responsible for correctly padding the input field.  */
 292   if (dtp->u.p.sf_seen_eor)
 293     {
 294       *length = 0;
 295       /* Just return something that isn't a NULL pointer, otherwise the
 296          caller thinks an error occured.  */
 297       return (char*) empty_string;
 298     }
 299
 300   n = seen_comma = 0;
 301
 302   /* Read data into format buffer and scan through it.  */
 303   lorig = *length;
 304
 305   while (n < *length)
 306     {
 307       q = fbuf_getc (dtp->u.p.current_unit);
 308       if (q == EOF)
 309         break;
 310       else if (q == '\n' || q == '\r')
 311         {
 312           /* Unexpected end of line. Set the position.  */
 313           dtp->u.p.sf_seen_eor = 1;
 314
 315           /* If we see an EOR during non-advancing I/O, we need to skip
 316              the rest of the I/O statement.  Set the corresponding flag.  */
 317           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
 318             dtp->u.p.eor_condition = 1;
 319
 320           /* If we encounter a CR, it might be a CRLF.  */
 321           if (q == '\r') /* Probably a CRLF */
 322             {
 323               /* See if there is an LF.  */
 324               q2 = fbuf_getc (dtp->u.p.current_unit);
 325               if (q2 == '\n')
 326                 dtp->u.p.sf_seen_eor = 2;
 327               else if (q2 != EOF) /* Oops, seek back.  */
 328                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
 329             }
 330
 331           /* Without padding, terminate the I/O statement without assigning
 332              the value.  With padding, the value still needs to be assigned,
 333              so we can just continue with a short read.  */
 334           if (dtp->u.p.current_unit->pad_status == PAD_NO)
 335             {
 336               generate_error (&dtp->common, LIBERROR_EOR, NULL);
 337               return NULL;
 338             }
 339
 340           *length = n;
 341           goto done;
 342         }
 343       /*  Short circuit the read if a comma is found during numeric input.
 344           The flag is set to zero during character reads so that commas in
 345           strings are not ignored  */
 346       else if (q == ',')
 347         if (dtp->u.p.sf_read_comma == 1)
 348           {
 349             seen_comma = 1;
 350             notify_std (&dtp->common, GFC_STD_GNU,
 351                         "Comma in formatted numeric read.");
 352             break;
 353           }
 354       n++;
 355     }
 356
 357   *length = n;
 358
 359   /* A short read implies we hit EOF, unless we hit EOR, a comma, or
 360      some other stuff. Set the relevant flags.  */
 361   if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
 362     {
 363       if (n > 0)
 364         {
 365           if (dtp->u.p.advance_status == ADVANCE_NO)
 366             {
 367               if (dtp->u.p.current_unit->pad_status == PAD_NO)
 368                 {
 369                   hit_eof (dtp);
 370                   return NULL;
 371                 }
 372               else
 373                 dtp->u.p.eor_condition = 1;
 374             }
 375           else
 376             dtp->u.p.at_eof = 1;
 377         }
 378       else if (dtp->u.p.advance_status == ADVANCE_NO
 379                || dtp->u.p.current_unit->pad_status == PAD_NO
 380                || dtp->u.p.current_unit->bytes_left
 381                     == dtp->u.p.current_unit->recl)
 382         {
 383           hit_eof (dtp);
 384           return NULL;
 385         }
 386     }
 387
 388  done:
 389
 390   dtp->u.p.current_unit->bytes_left -= n;
 391
 392   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 393     dtp->u.p.size_used += (GFC_IO_INT) n;
 394
 395   /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
 396      fbuf_getc might reallocate the buffer.  So return current pointer
 397      minus all the advances, which is n plus up to two characters
 398      of newline or comma.  */
 399   return fbuf_getptr (dtp->u.p.current_unit)
 400          - n - dtp->u.p.sf_seen_eor - seen_comma;
 401 }
 402
 403
 404 /* Function for reading the next couple of bytes from the current
 405    file, advancing the current position. We return FAILURE on end of record or
 406    end of file. This function is only for formatted I/O, unformatted uses
 407    read_block_direct.
 408
 409    If the read is short, then it is because the current record does not
 410    have enough data to satisfy the read request and the file was
 411    opened with PAD=YES.  The caller must assume tailing spaces for
 412    short reads.  */
 413
 414 void *
 415 read_block_form (st_parameter_dt *dtp, int * nbytes)
 416 {
 417   char *source;
 418   int norig;
 419
 420   if (!is_stream_io (dtp))
 421     {
 422       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
 423         {
 424           /* For preconnected units with default record length, set bytes left
 425            to unit record length and proceed, otherwise error.  */
 426           if (dtp->u.p.current_unit->unit_number == options.stdin_unit
 427               && dtp->u.p.current_unit->recl == DEFAULT_RECL)
 428             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
 429           else
 430             {
 431               if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
 432                   && !is_internal_unit (dtp))
 433                 {
 434                   /* Not enough data left.  */
 435                   generate_error (&dtp->common, LIBERROR_EOR, NULL);
 436                   return NULL;
 437                 }
 438             }
 439
 440           if (unlikely (dtp->u.p.current_unit->bytes_left == 0
 441               && !is_internal_unit(dtp)))
 442             {
 443               hit_eof (dtp);
 444               return NULL;
 445             }
 446
 447           *nbytes = dtp->u.p.current_unit->bytes_left;
 448         }
 449     }
 450
 451   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
 452       (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
 453        dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
 454     {
 455       if (is_internal_unit (dtp))
 456         source = read_sf_internal (dtp, nbytes);
 457       else
 458         source = read_sf (dtp, nbytes);
 459
 460       dtp->u.p.current_unit->strm_pos +=
 461         (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
 462       return source;
 463     }
 464
 465   /* If we reach here, we can assume it's direct access.  */
 466
 467   dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
 468
 469   norig = *nbytes;
 470   source = fbuf_read (dtp->u.p.current_unit, nbytes);
 471   fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
 472
 473   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 474     dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
 475
 476   if (norig != *nbytes)
 477     {
 478       /* Short read, this shouldn't happen.  */
 479       if (!dtp->u.p.current_unit->pad_status == PAD_YES)
 480         {
 481           generate_error (&dtp->common, LIBERROR_EOR, NULL);
 482           source = NULL;
 483         }
 484     }
 485
 486   dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
 487
 488   return source;
 489 }
 490
 491
 492 /* Read a block from a character(kind=4) internal unit, to be transferred into
 493    a character(kind=4) variable.  Note: Portions of this code borrowed from
 494    read_sf_internal.  */
 495 void *
 496 read_block_form4 (st_parameter_dt *dtp, int * nbytes)
 497 {
 498   static gfc_char4_t *empty_string[0];
 499   gfc_char4_t *source;
 500   int lorig;
 501
 502   if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
 503     *nbytes = dtp->u.p.current_unit->bytes_left;
 504
 505   /* Zero size array gives internal unit len of 0.  Nothing to read. */
 506   if (dtp->internal_unit_len == 0
 507       && dtp->u.p.current_unit->pad_status == PAD_NO)
 508     hit_eof (dtp);
 509
 510   /* If we have seen an eor previously, return a length of 0.  The
 511      caller is responsible for correctly padding the input field.  */
 512   if (dtp->u.p.sf_seen_eor)
 513     {
 514       *nbytes = 0;
 515       /* Just return something that isn't a NULL pointer, otherwise the
 516          caller thinks an error occured.  */
 517       return empty_string;
 518     }
 519
 520   lorig = *nbytes;
 521   source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
 522
 523   if (unlikely (lorig > *nbytes))
 524     {
 525       hit_eof (dtp);
 526       return NULL;
 527     }
 528
 529   dtp->u.p.current_unit->bytes_left -= *nbytes;
 530
 531   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 532     dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
 533
 534   return source;
 535 }
 536
 537
 538 /* Reads a block directly into application data space.  This is for
 539    unformatted files.  */
 540
 541 static void
 542 read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
 543 {
 544   ssize_t to_read_record;
 545   ssize_t have_read_record;
 546   ssize_t to_read_subrecord;
 547   ssize_t have_read_subrecord;
 548   int short_record;
 549
 550   if (is_stream_io (dtp))
 551     {
 552       have_read_record = sread (dtp->u.p.current_unit->s, buf,
 553                                 nbytes);
 554       if (unlikely (have_read_record < 0))
 555         {
 556           generate_error (&dtp->common, LIBERROR_OS, NULL);
 557           return;
 558         }
 559
 560       dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
 561
 562       if (unlikely ((ssize_t) nbytes != have_read_record))
 563         {
 564           /* Short read,  e.g. if we hit EOF.  For stream files,
 565            we have to set the end-of-file condition.  */
 566           hit_eof (dtp);
 567         }
 568       return;
 569     }
 570
 571   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 572     {
 573       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
 574         {
 575           short_record = 1;
 576           to_read_record = dtp->u.p.current_unit->bytes_left;
 577           nbytes = to_read_record;
 578         }
 579       else
 580         {
 581           short_record = 0;
 582           to_read_record = nbytes;
 583         }
 584
 585       dtp->u.p.current_unit->bytes_left -= to_read_record;
 586
 587       to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
 588       if (unlikely (to_read_record < 0))
 589         {
 590           generate_error (&dtp->common, LIBERROR_OS, NULL);
 591           return;
 592         }
 593
 594       if (to_read_record != (ssize_t) nbytes)
 595         {
 596           /* Short read, e.g. if we hit EOF.  Apparently, we read
 597            more than was written to the last record.  */
 598           return;
 599         }
 600
 601       if (unlikely (short_record))
 602         {
 603           generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
 604         }
 605       return;
 606     }
 607
 608   /* Unformatted sequential.  We loop over the subrecords, reading
 609      until the request has been fulfilled or the record has run out
 610      of continuation subrecords.  */
 611
 612   /* Check whether we exceed the total record length.  */
 613
 614   if (dtp->u.p.current_unit->flags.has_recl
 615       && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
 616     {
 617       to_read_record = dtp->u.p.current_unit->bytes_left;
 618       short_record = 1;
 619     }
 620   else
 621     {
 622       to_read_record = nbytes;
 623       short_record = 0;
 624     }
 625   have_read_record = 0;
 626
 627   while(1)
 628     {
 629       if (dtp->u.p.current_unit->bytes_left_subrecord
 630           < (gfc_offset) to_read_record)
 631         {
 632           to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord;
 633           to_read_record -= to_read_subrecord;
 634         }
 635       else
 636         {
 637           to_read_subrecord = to_read_record;
 638           to_read_record = 0;
 639         }
 640
 641       dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
 642
 643       have_read_subrecord = sread (dtp->u.p.current_unit->s,
 644                                    buf + have_read_record, to_read_subrecord);
 645       if (unlikely (have_read_subrecord) < 0)
 646         {
 647           generate_error (&dtp->common, LIBERROR_OS, NULL);
 648           return;
 649         }
 650
 651       have_read_record += have_read_subrecord;
 652
 653       if (unlikely (to_read_subrecord != have_read_subrecord))
 654         {
 655           /* Short read, e.g. if we hit EOF.  This means the record
 656              structure has been corrupted, or the trailing record
 657              marker would still be present.  */
 658
 659           generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
 660           return;
 661         }
 662
 663       if (to_read_record > 0)
 664         {
 665           if (likely (dtp->u.p.current_unit->continued))
 666             {
 667               next_record_r_unf (dtp, 0);
 668               us_read (dtp, 1);
 669             }
 670           else
 671             {
 672               /* Let's make sure the file position is correctly pre-positioned
 673                  for the next read statement.  */
 674
 675               dtp->u.p.current_unit->current_record = 0;
 676               next_record_r_unf (dtp, 0);
 677               generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
 678               return;
 679             }
 680         }
 681       else
 682         {
 683           /* Normal exit, the read request has been fulfilled.  */
 684           break;
 685         }
 686     }
 687
 688   dtp->u.p.current_unit->bytes_left -= have_read_record;
 689   if (unlikely (short_record))
 690     {
 691       generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
 692       return;
 693     }
 694   return;
 695 }
 696
 697
 698 /* Function for writing a block of bytes to the current file at the
 699    current position, advancing the file pointer. We are given a length
 700    and return a pointer to a buffer that the caller must (completely)
 701    fill in.  Returns NULL on error.  */
 702
 703 void *
 704 write_block (st_parameter_dt *dtp, int length)
 705 {
 706   char *dest;
 707
 708   if (!is_stream_io (dtp))
 709     {
 710       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
 711         {
 712           /* For preconnected units with default record length, set bytes left
 713              to unit record length and proceed, otherwise error.  */
 714           if (likely ((dtp->u.p.current_unit->unit_number
 715                        == options.stdout_unit
 716                        || dtp->u.p.current_unit->unit_number
 717                        == options.stderr_unit)
 718                       && dtp->u.p.current_unit->recl == DEFAULT_RECL))
 719             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
 720           else
 721             {
 722               generate_error (&dtp->common, LIBERROR_EOR, NULL);
 723               return NULL;
 724             }
 725         }
 726
 727       dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
 728     }
 729
 730   if (is_internal_unit (dtp))
 731     {
 732       if (dtp->common.unit) /* char4 internel unit.  */
 733         {
 734           gfc_char4_t *dest4;
 735           dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
 736           if (dest4 == NULL)
 737           {
 738             generate_error (&dtp->common, LIBERROR_END, NULL);
 739             return NULL;
 740           }
 741           return dest4;
 742         }
 743       else
 744         dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
 745
 746       if (dest == NULL)
 747         {
 748           generate_error (&dtp->common, LIBERROR_END, NULL);
 749           return NULL;
 750         }
 751
 752       if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
 753         generate_error (&dtp->common, LIBERROR_END, NULL);
 754     }
 755   else
 756     {
 757       dest = fbuf_alloc (dtp->u.p.current_unit, length);
 758       if (dest == NULL)
 759         {
 760           generate_error (&dtp->common, LIBERROR_OS, NULL);
 761           return NULL;
 762         }
 763     }
 764
 765   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 766     dtp->u.p.size_used += (GFC_IO_INT) length;
 767
 768   dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
 769
 770   return dest;
 771 }
 772
 773
 774 /* High level interface to swrite(), taking care of errors.  This is only
 775    called for unformatted files.  There are three cases to consider:
 776    Stream I/O, unformatted direct, unformatted sequential.  */
 777
 778 static try
 779 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 780 {
 781
 782   ssize_t have_written;
 783   ssize_t to_write_subrecord;
 784   int short_record;
 785
 786   /* Stream I/O.  */
 787
 788   if (is_stream_io (dtp))
 789     {
 790       have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
 791       if (unlikely (have_written < 0))
 792         {
 793           generate_error (&dtp->common, LIBERROR_OS, NULL);
 794           return FAILURE;
 795         }
 796
 797       dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
 798
 799       return SUCCESS;
 800     }
 801
 802   /* Unformatted direct access.  */
 803
 804   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 805     {
 806       if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes))
 807         {
 808           generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
 809           return FAILURE;
 810         }
 811
 812       if (buf == NULL && nbytes == 0)
 813         return SUCCESS;
 814
 815       have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
 816       if (unlikely (have_written < 0))
 817         {
 818           generate_error (&dtp->common, LIBERROR_OS, NULL);
 819           return FAILURE;
 820         }
 821
 822       dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
 823       dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
 824
 825       return SUCCESS;
 826     }
 827
 828   /* Unformatted sequential.  */
 829
 830   have_written = 0;
 831
 832   if (dtp->u.p.current_unit->flags.has_recl
 833       && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
 834     {
 835       nbytes = dtp->u.p.current_unit->bytes_left;
 836       short_record = 1;
 837     }
 838   else
 839     {
 840       short_record = 0;
 841     }
 842
 843   while (1)
 844     {
 845
 846       to_write_subrecord =
 847         (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
 848         (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
 849
 850       dtp->u.p.current_unit->bytes_left_subrecord -=
 851         (gfc_offset) to_write_subrecord;
 852
 853       to_write_subrecord = swrite (dtp->u.p.current_unit->s,
 854                                    buf + have_written, to_write_subrecord);
 855       if (unlikely (to_write_subrecord < 0))
 856         {
 857           generate_error (&dtp->common, LIBERROR_OS, NULL);
 858           return FAILURE;
 859         }
 860
 861       dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
 862       nbytes -= to_write_subrecord;
 863       have_written += to_write_subrecord;
 864
 865       if (nbytes == 0)
 866         break;
 867
 868       next_record_w_unf (dtp, 1);
 869       us_write (dtp, 1);
 870     }
 871   dtp->u.p.current_unit->bytes_left -= have_written;
 872   if (unlikely (short_record))
 873     {
 874       generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
 875       return FAILURE;
 876     }
 877   return SUCCESS;
 878 }
 879
 880
 881 /* Master function for unformatted reads.  */
 882
 883 static void
 884 unformatted_read (st_parameter_dt *dtp, bt type,
 885                   void *dest, int kind, size_t size, size_t nelems)
 886 {
 887   if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
 888       || kind == 1)
 889     {
 890       if (type == BT_CHARACTER)
 891         size *= GFC_SIZE_OF_CHAR_KIND(kind);
 892       read_block_direct (dtp, dest, size * nelems);
 893     }
 894   else
 895     {
 896       char buffer[16];
 897       char *p;
 898       size_t i;
 899
 900       p = dest;
 901
 902       /* Handle wide chracters.  */
 903       if (type == BT_CHARACTER && kind != 1)
 904         {
 905           nelems *= size;
 906           size = kind;
 907         }
 908
 909       /* Break up complex into its constituent reals.  */
 910       if (type == BT_COMPLEX)
 911         {
 912           nelems *= 2;
 913           size /= 2;
 914         }
 915
 916       /* By now, all complex variables have been split into their
 917          constituent reals.  */
 918
 919       for (i = 0; i < nelems; i++)
 920         {
 921           read_block_direct (dtp, buffer, size);
 922           reverse_memcpy (p, buffer, size);
 923           p += size;
 924         }
 925     }
 926 }
 927
 928
 929 /* Master function for unformatted writes.  NOTE: For kind=10 the size is 16
 930    bytes on 64 bit machines.  The unused bytes are not initialized and never
 931    used, which can show an error with memory checking analyzers like
 932    valgrind.  */
 933
 934 static void
 935 unformatted_write (st_parameter_dt *dtp, bt type,
 936                    void *source, int kind, size_t size, size_t nelems)
 937 {
 938   if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
 939       || kind == 1)
 940     {
 941       size_t stride = type == BT_CHARACTER ?
 942                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
 943
 944       write_buf (dtp, source, stride * nelems);
 945     }
 946   else
 947     {
 948       char buffer[16];
 949       char *p;
 950       size_t i;
 951
 952       p = source;
 953
 954       /* Handle wide chracters.  */
 955       if (type == BT_CHARACTER && kind != 1)
 956         {
 957           nelems *= size;
 958           size = kind;
 959         }
 960
 961       /* Break up complex into its constituent reals.  */
 962       if (type == BT_COMPLEX)
 963         {
 964           nelems *= 2;
 965           size /= 2;
 966         }
 967
 968       /* By now, all complex variables have been split into their
 969          constituent reals.  */
 970
 971       for (i = 0; i < nelems; i++)
 972         {
 973           reverse_memcpy(buffer, p, size);
 974           p += size;
 975           write_buf (dtp, buffer, size);
 976         }
 977     }
 978 }
 979
 980
 981 /* Return a pointer to the name of a type.  */
 982
 983 const char *
 984 type_name (bt type)
 985 {
 986   const char *p;
 987
 988   switch (type)
 989     {
 990     case BT_INTEGER:
 991       p = "INTEGER";
 992       break;
 993     case BT_LOGICAL:
 994       p = "LOGICAL";
 995       break;
 996     case BT_CHARACTER:
 997       p = "CHARACTER";
 998       break;
 999     case BT_REAL:
1000       p = "REAL";
1001       break;
1002     case BT_COMPLEX:
1003       p = "COMPLEX";
1004       break;
1005     default:
1006       internal_error (NULL, "type_name(): Bad type");
1007     }
1008
1009   return p;
1010 }
1011
1012
1013 /* Write a constant string to the output.
1014    This is complicated because the string can have doubled delimiters
1015    in it.  The length in the format node is the true length.  */
1016
1017 static void
1018 write_constant_string (st_parameter_dt *dtp, const fnode *f)
1019 {
1020   char c, delimiter, *p, *q;
1021   int length;
1022
1023   length = f->u.string.length;
1024   if (length == 0)
1025     return;
1026
1027   p = write_block (dtp, length);
1028   if (p == NULL)
1029     return;
1030
1031   q = f->u.string.p;
1032   delimiter = q[-1];
1033
1034   for (; length > 0; length--)
1035     {
1036       c = *p++ = *q++;
1037       if (c == delimiter && c != 'H' && c != 'h')
1038         q++;                    /* Skip the doubled delimiter.  */
1039     }
1040 }
1041
1042
1043 /* Given actual and expected types in a formatted data transfer, make
1044    sure they agree.  If not, an error message is generated.  Returns
1045    nonzero if something went wrong.  */
1046
1047 static int
1048 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
1049 {
1050 #define BUFLEN 100
1051   char buffer[BUFLEN];
1052
1053   if (actual == expected)
1054     return 0;
1055
1056   /* Adjust item_count before emitting error message.  */
1057   snprintf (buffer, BUFLEN,
1058             "Expected %s for item %d in formatted transfer, got %s",
1059            type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
1060
1061   format_error (dtp, f, buffer);
1062   return 1;
1063 }
1064
1065
1066 static int
1067 require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
1068 {
1069 #define BUFLEN 100
1070   char buffer[BUFLEN];
1071
1072   if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
1073     return 0;
1074
1075   /* Adjust item_count before emitting error message.  */
1076   snprintf (buffer, BUFLEN,
1077             "Expected numeric type for item %d in formatted transfer, got %s",
1078             dtp->u.p.item_count - 1, type_name (actual));
1079
1080   format_error (dtp, f, buffer);
1081   return 1;
1082 }
1083
1084
1085 /* This function is in the main loop for a formatted data transfer
1086    statement.  It would be natural to implement this as a coroutine
1087    with the user program, but C makes that awkward.  We loop,
1088    processing format elements.  When we actually have to transfer
1089    data instead of just setting flags, we return control to the user
1090    program which calls a function that supplies the address and type
1091    of the next element, then comes back here to process it.  */
1092
1093 static void
1094 formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1095                                 size_t size)
1096 {
1097   int pos, bytes_used;
1098   const fnode *f;
1099   format_token t;
1100   int n;
1101   int consume_data_flag;
1102
1103   /* Change a complex data item into a pair of reals.  */
1104
1105   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1106   if (type == BT_COMPLEX)
1107     {
1108       type = BT_REAL;
1109       size /= 2;
1110     }
1111
1112   /* If there's an EOR condition, we simulate finalizing the transfer
1113      by doing nothing.  */
1114   if (dtp->u.p.eor_condition)
1115     return;
1116
1117   /* Set this flag so that commas in reads cause the read to complete before
1118      the entire field has been read.  The next read field will start right after
1119      the comma in the stream.  (Set to 0 for character reads).  */
1120   dtp->u.p.sf_read_comma =
1121     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1122
1123   for (;;)
1124     {
1125       /* If reversion has occurred and there is another real data item,
1126          then we have to move to the next record.  */
1127       if (dtp->u.p.reversion_flag && n > 0)
1128         {
1129           dtp->u.p.reversion_flag = 0;
1130           next_record (dtp, 0);
1131         }
1132
1133       consume_data_flag = 1;
1134       if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1135         break;
1136
1137       f = next_format (dtp);
1138       if (f == NULL)
1139         {
1140           /* No data descriptors left.  */
1141           if (unlikely (n > 0))
1142             generate_error (&dtp->common, LIBERROR_FORMAT,
1143                 "Insufficient data descriptors in format after reversion");
1144           return;
1145         }
1146
1147       t = f->format;
1148
1149       bytes_used = (int)(dtp->u.p.current_unit->recl
1150                    - dtp->u.p.current_unit->bytes_left);
1151
1152       if (is_stream_io(dtp))
1153         bytes_used = 0;
1154
1155       switch (t)
1156         {
1157         case FMT_I:
1158           if (n == 0)
1159             goto need_read_data;
1160           if (require_type (dtp, BT_INTEGER, type, f))
1161             return;
1162           read_decimal (dtp, f, p, kind);
1163           break;
1164
1165         case FMT_B:
1166           if (n == 0)
1167             goto need_read_data;
1168           if (!(compile_options.allow_std & GFC_STD_GNU)
1169               && require_numeric_type (dtp, type, f))
1170             return;
1171           if (!(compile_options.allow_std & GFC_STD_F2008)
1172               && require_type (dtp, BT_INTEGER, type, f))
1173             return;
1174           read_radix (dtp, f, p, kind, 2);
1175           break;
1176
1177         case FMT_O:
1178           if (n == 0)
1179             goto need_read_data;
1180           if (!(compile_options.allow_std & GFC_STD_GNU)
1181               && require_numeric_type (dtp, type, f))
1182             return;
1183           if (!(compile_options.allow_std & GFC_STD_F2008)
1184               && require_type (dtp, BT_INTEGER, type, f))
1185             return;
1186           read_radix (dtp, f, p, kind, 8);
1187           break;
1188
1189         case FMT_Z:
1190           if (n == 0)
1191             goto need_read_data;
1192           if (!(compile_options.allow_std & GFC_STD_GNU)
1193               && require_numeric_type (dtp, type, f))
1194             return;
1195           if (!(compile_options.allow_std & GFC_STD_F2008)
1196               && require_type (dtp, BT_INTEGER, type, f))
1197             return;
1198           read_radix (dtp, f, p, kind, 16);
1199           break;
1200
1201         case FMT_A:
1202           if (n == 0)
1203             goto need_read_data;
1204
1205           /* It is possible to have FMT_A with something not BT_CHARACTER such
1206              as when writing out hollerith strings, so check both type
1207              and kind before calling wide character routines.  */
1208           if (type == BT_CHARACTER && kind == 4)
1209             read_a_char4 (dtp, f, p, size);
1210           else
1211             read_a (dtp, f, p, size);
1212           break;
1213
1214         case FMT_L:
1215           if (n == 0)
1216             goto need_read_data;
1217           read_l (dtp, f, p, kind);
1218           break;
1219
1220         case FMT_D:
1221           if (n == 0)
1222             goto need_read_data;
1223           if (require_type (dtp, BT_REAL, type, f))
1224             return;
1225           read_f (dtp, f, p, kind);
1226           break;
1227
1228         case FMT_E:
1229           if (n == 0)
1230             goto need_read_data;
1231           if (require_type (dtp, BT_REAL, type, f))
1232             return;
1233           read_f (dtp, f, p, kind);
1234           break;
1235
1236         case FMT_EN:
1237           if (n == 0)
1238             goto need_read_data;
1239           if (require_type (dtp, BT_REAL, type, f))
1240             return;
1241           read_f (dtp, f, p, kind);
1242           break;
1243
1244         case FMT_ES:
1245           if (n == 0)
1246             goto need_read_data;
1247           if (require_type (dtp, BT_REAL, type, f))
1248             return;
1249           read_f (dtp, f, p, kind);
1250           break;
1251
1252         case FMT_F:
1253           if (n == 0)
1254             goto need_read_data;
1255           if (require_type (dtp, BT_REAL, type, f))
1256             return;
1257           read_f (dtp, f, p, kind);
1258           break;
1259
1260         case FMT_G:
1261           if (n == 0)
1262             goto need_read_data;
1263           switch (type)
1264             {
1265               case BT_INTEGER:
1266                 read_decimal (dtp, f, p, kind);
1267                 break;
1268               case BT_LOGICAL:
1269                 read_l (dtp, f, p, kind);
1270                 break;
1271               case BT_CHARACTER:
1272                 if (kind == 4)
1273                   read_a_char4 (dtp, f, p, size);
1274                 else
1275                   read_a (dtp, f, p, size);
1276                 break;
1277               case BT_REAL:
1278                 read_f (dtp, f, p, kind);
1279                 break;
1280               default:
1281                 internal_error (&dtp->common, "formatted_transfer(): Bad type");
1282             }
1283           break;
1284
1285         case FMT_STRING:
1286           consume_data_flag = 0;
1287           format_error (dtp, f, "Constant string in input format");
1288           return;
1289
1290         /* Format codes that don't transfer data.  */
1291         case FMT_X:
1292         case FMT_TR:
1293           consume_data_flag = 0;
1294           dtp->u.p.skips += f->u.n;
1295           pos = bytes_used + dtp->u.p.skips - 1;
1296           dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1297           read_x (dtp, f->u.n);
1298           break;
1299
1300         case FMT_TL:
1301         case FMT_T:
1302           consume_data_flag = 0;
1303
1304           if (f->format == FMT_TL)
1305             {
1306               /* Handle the special case when no bytes have been used yet.
1307                  Cannot go below zero. */
1308               if (bytes_used == 0)
1309                 {
1310                   dtp->u.p.pending_spaces -= f->u.n;
1311                   dtp->u.p.skips -= f->u.n;
1312                   dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1313                 }
1314
1315               pos = bytes_used - f->u.n;
1316             }
1317           else /* FMT_T */
1318             pos = f->u.n - 1;
1319
1320           /* Standard 10.6.1.1: excessive left tabbing is reset to the
1321              left tab limit.  We do not check if the position has gone
1322              beyond the end of record because a subsequent tab could
1323              bring us back again.  */
1324           pos = pos < 0 ? 0 : pos;
1325
1326           dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1327           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1328                                     + pos - dtp->u.p.max_pos;
1329           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1330                                     ? 0 : dtp->u.p.pending_spaces;
1331           if (dtp->u.p.skips == 0)
1332             break;
1333
1334           /* Adjust everything for end-of-record condition */
1335           if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1336             {
1337               dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
1338               dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
1339               bytes_used = pos;
1340               dtp->u.p.sf_seen_eor = 0;
1341             }
1342           if (dtp->u.p.skips < 0)
1343             {
1344               if (is_internal_unit (dtp))
1345                 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1346               else
1347                 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1348               dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1349               dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1350             }
1351           else
1352             read_x (dtp, dtp->u.p.skips);
1353           break;
1354
1355         case FMT_S:
1356           consume_data_flag = 0;
1357           dtp->u.p.sign_status = SIGN_S;
1358           break;
1359
1360         case FMT_SS:
1361           consume_data_flag = 0;
1362           dtp->u.p.sign_status = SIGN_SS;
1363           break;
1364
1365         case FMT_SP:
1366           consume_data_flag = 0;
1367           dtp->u.p.sign_status = SIGN_SP;
1368           break;
1369
1370         case FMT_BN:
1371           consume_data_flag = 0 ;
1372           dtp->u.p.blank_status = BLANK_NULL;
1373           break;
1374
1375         case FMT_BZ:
1376           consume_data_flag = 0;
1377           dtp->u.p.blank_status = BLANK_ZERO;
1378           break;
1379
1380         case FMT_DC:
1381           consume_data_flag = 0;
1382           dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1383           break;
1384
1385         case FMT_DP:
1386           consume_data_flag = 0;
1387           dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1388           break;
1389
1390         case FMT_RC:
1391           consume_data_flag = 0;
1392           dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1393           break;
1394
1395         case FMT_RD:
1396           consume_data_flag = 0;
1397           dtp->u.p.current_unit->round_status = ROUND_DOWN;
1398           break;
1399
1400         case FMT_RN:
1401           consume_data_flag = 0;
1402           dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1403           break;
1404
1405         case FMT_RP:
1406           consume_data_flag = 0;
1407           dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1408           break;
1409
1410         case FMT_RU:
1411           consume_data_flag = 0;
1412           dtp->u.p.current_unit->round_status = ROUND_UP;
1413           break;
1414
1415         case FMT_RZ:
1416           consume_data_flag = 0;
1417           dtp->u.p.current_unit->round_status = ROUND_ZERO;
1418           break;
1419
1420         case FMT_P:
1421           consume_data_flag = 0;
1422           dtp->u.p.scale_factor = f->u.k;
1423           break;
1424
1425         case FMT_DOLLAR:
1426           consume_data_flag = 0;
1427           dtp->u.p.seen_dollar = 1;
1428           break;
1429
1430         case FMT_SLASH:
1431           consume_data_flag = 0;
1432           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1433           next_record (dtp, 0);
1434           break;
1435
1436         case FMT_COLON:
1437           /* A colon descriptor causes us to exit this loop (in
1438              particular preventing another / descriptor from being
1439              processed) unless there is another data item to be
1440              transferred.  */
1441           consume_data_flag = 0;
1442           if (n == 0)
1443             return;
1444           break;
1445
1446         default:
1447           internal_error (&dtp->common, "Bad format node");
1448         }
1449
1450       /* Adjust the item count and data pointer.  */
1451
1452       if ((consume_data_flag > 0) && (n > 0))
1453         {
1454           n--;
1455           p = ((char *) p) + size;
1456         }
1457
1458       dtp->u.p.skips = 0;
1459
1460       pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1461       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1462     }
1463
1464   return;
1465
1466   /* Come here when we need a data descriptor but don't have one.  We
1467      push the current format node back onto the input, then return and
1468      let the user program call us back with the data.  */
1469  need_read_data:
1470   unget_format (dtp, f);
1471 }
1472
1473
1474 static void
1475 formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1476                                  size_t size)
1477 {
1478   int pos, bytes_used;
1479   const fnode *f;
1480   format_token t;
1481   int n;
1482   int consume_data_flag;
1483
1484   /* Change a complex data item into a pair of reals.  */
1485
1486   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1487   if (type == BT_COMPLEX)
1488     {
1489       type = BT_REAL;
1490       size /= 2;
1491     }
1492
1493   /* If there's an EOR condition, we simulate finalizing the transfer
1494      by doing nothing.  */
1495   if (dtp->u.p.eor_condition)
1496     return;
1497
1498   /* Set this flag so that commas in reads cause the read to complete before
1499      the entire field has been read.  The next read field will start right after
1500      the comma in the stream.  (Set to 0 for character reads).  */
1501   dtp->u.p.sf_read_comma =
1502     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1503
1504   for (;;)
1505     {
1506       /* If reversion has occurred and there is another real data item,
1507          then we have to move to the next record.  */
1508       if (dtp->u.p.reversion_flag && n > 0)
1509         {
1510           dtp->u.p.reversion_flag = 0;
1511           next_record (dtp, 0);
1512         }
1513
1514       consume_data_flag = 1;
1515       if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1516         break;
1517
1518       f = next_format (dtp);
1519       if (f == NULL)
1520         {
1521           /* No data descriptors left.  */
1522           if (unlikely (n > 0))
1523             generate_error (&dtp->common, LIBERROR_FORMAT,
1524                 "Insufficient data descriptors in format after reversion");
1525           return;
1526         }
1527
1528       /* Now discharge T, TR and X movements to the right.  This is delayed
1529          until a data producing format to suppress trailing spaces.  */
1530
1531       t = f->format;
1532       if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
1533         && ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
1534                     || t == FMT_Z  || t == FMT_F  || t == FMT_E
1535                     || t == FMT_EN || t == FMT_ES || t == FMT_G
1536                     || t == FMT_L  || t == FMT_A  || t == FMT_D))
1537             || t == FMT_STRING))
1538         {
1539           if (dtp->u.p.skips > 0)
1540             {
1541               int tmp;
1542               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1543               tmp = (int)(dtp->u.p.current_unit->recl
1544                           - dtp->u.p.current_unit->bytes_left);
1545               dtp->u.p.max_pos =
1546                 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
1547             }
1548           if (dtp->u.p.skips < 0)
1549             {
1550               if (is_internal_unit (dtp))
1551                 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1552               else
1553                 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1554               dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1555             }
1556           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1557         }
1558
1559       bytes_used = (int)(dtp->u.p.current_unit->recl
1560                    - dtp->u.p.current_unit->bytes_left);
1561
1562       if (is_stream_io(dtp))
1563         bytes_used = 0;
1564
1565       switch (t)
1566         {
1567         case FMT_I:
1568           if (n == 0)
1569             goto need_data;
1570           if (require_type (dtp, BT_INTEGER, type, f))
1571             return;
1572           write_i (dtp, f, p, kind);
1573           break;
1574
1575         case FMT_B:
1576           if (n == 0)
1577             goto need_data;
1578           if (!(compile_options.allow_std & GFC_STD_GNU)
1579               && require_numeric_type (dtp, type, f))
1580             return;
1581           if (!(compile_options.allow_std & GFC_STD_F2008)
1582               && require_type (dtp, BT_INTEGER, type, f))
1583             return;
1584           write_b (dtp, f, p, kind);
1585           break;
1586
1587         case FMT_O:
1588           if (n == 0)
1589             goto need_data;
1590           if (!(compile_options.allow_std & GFC_STD_GNU)
1591               && require_numeric_type (dtp, type, f))
1592             return;
1593           if (!(compile_options.allow_std & GFC_STD_F2008)
1594               && require_type (dtp, BT_INTEGER, type, f))
1595             return;
1596           write_o (dtp, f, p, kind);
1597           break;
1598
1599         case FMT_Z:
1600           if (n == 0)
1601             goto need_data;
1602           if (!(compile_options.allow_std & GFC_STD_GNU)
1603               && require_numeric_type (dtp, type, f))
1604             return;
1605           if (!(compile_options.allow_std & GFC_STD_F2008)
1606               && require_type (dtp, BT_INTEGER, type, f))
1607             return;
1608           write_z (dtp, f, p, kind);
1609           break;
1610
1611         case FMT_A:
1612           if (n == 0)
1613             goto need_data;
1614
1615           /* It is possible to have FMT_A with something not BT_CHARACTER such
1616              as when writing out hollerith strings, so check both type
1617              and kind before calling wide character routines.  */
1618           if (type == BT_CHARACTER && kind == 4)
1619             write_a_char4 (dtp, f, p, size);
1620           else
1621             write_a (dtp, f, p, size);
1622           break;
1623
1624         case FMT_L:
1625           if (n == 0)
1626             goto need_data;
1627           write_l (dtp, f, p, kind);
1628           break;
1629
1630         case FMT_D:
1631           if (n == 0)
1632             goto need_data;
1633           if (require_type (dtp, BT_REAL, type, f))
1634             return;
1635           write_d (dtp, f, p, kind);
1636           break;
1637
1638         case FMT_E:
1639           if (n == 0)
1640             goto need_data;
1641           if (require_type (dtp, BT_REAL, type, f))
1642             return;
1643           write_e (dtp, f, p, kind);
1644           break;
1645
1646         case FMT_EN:
1647           if (n == 0)
1648             goto need_data;
1649           if (require_type (dtp, BT_REAL, type, f))
1650             return;
1651           write_en (dtp, f, p, kind);
1652           break;
1653
1654         case FMT_ES:
1655           if (n == 0)
1656             goto need_data;
1657           if (require_type (dtp, BT_REAL, type, f))
1658             return;
1659           write_es (dtp, f, p, kind);
1660           break;
1661
1662         case FMT_F:
1663           if (n == 0)
1664             goto need_data;
1665           if (require_type (dtp, BT_REAL, type, f))
1666             return;
1667           write_f (dtp, f, p, kind);
1668           break;
1669
1670         case FMT_G:
1671           if (n == 0)
1672             goto need_data;
1673           switch (type)
1674             {
1675               case BT_INTEGER:
1676                 write_i (dtp, f, p, kind);
1677                 break;
1678               case BT_LOGICAL:
1679                 write_l (dtp, f, p, kind);
1680                 break;
1681               case BT_CHARACTER:
1682                 if (kind == 4)
1683                   write_a_char4 (dtp, f, p, size);
1684                 else
1685                   write_a (dtp, f, p, size);
1686                 break;
1687               case BT_REAL:
1688                 if (f->u.real.w == 0)
1689                   write_real_g0 (dtp, p, kind, f->u.real.d);
1690                 else
1691                   write_d (dtp, f, p, kind);
1692                 break;
1693               default:
1694                 internal_error (&dtp->common,
1695                                 "formatted_transfer(): Bad type");
1696             }
1697           break;
1698
1699         case FMT_STRING:
1700           consume_data_flag = 0;
1701           write_constant_string (dtp, f);
1702           break;
1703
1704         /* Format codes that don't transfer data.  */
1705         case FMT_X:
1706         case FMT_TR:
1707           consume_data_flag = 0;
1708
1709           dtp->u.p.skips += f->u.n;
1710           pos = bytes_used + dtp->u.p.skips - 1;
1711           dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1712           /* Writes occur just before the switch on f->format, above, so
1713              that trailing blanks are suppressed, unless we are doing a
1714              non-advancing write in which case we want to output the blanks
1715              now.  */
1716           if (dtp->u.p.advance_status == ADVANCE_NO)
1717             {
1718               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1719               dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1720             }
1721           break;
1722
1723         case FMT_TL:
1724         case FMT_T:
1725           consume_data_flag = 0;
1726
1727           if (f->format == FMT_TL)
1728             {
1729
1730               /* Handle the special case when no bytes have been used yet.
1731                  Cannot go below zero. */
1732               if (bytes_used == 0)
1733                 {
1734                   dtp->u.p.pending_spaces -= f->u.n;
1735                   dtp->u.p.skips -= f->u.n;
1736                   dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1737                 }
1738
1739               pos = bytes_used - f->u.n;
1740             }
1741           else /* FMT_T */
1742             pos = f->u.n - dtp->u.p.pending_spaces - 1;
1743
1744           /* Standard 10.6.1.1: excessive left tabbing is reset to the
1745              left tab limit.  We do not check if the position has gone
1746              beyond the end of record because a subsequent tab could
1747              bring us back again.  */
1748           pos = pos < 0 ? 0 : pos;
1749
1750           dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1751           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1752                                     + pos - dtp->u.p.max_pos;
1753           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1754                                     ? 0 : dtp->u.p.pending_spaces;
1755           break;
1756
1757         case FMT_S:
1758           consume_data_flag = 0;
1759           dtp->u.p.sign_status = SIGN_S;
1760           break;
1761
1762         case FMT_SS:
1763           consume_data_flag = 0;
1764           dtp->u.p.sign_status = SIGN_SS;
1765           break;
1766
1767         case FMT_SP:
1768           consume_data_flag = 0;
1769           dtp->u.p.sign_status = SIGN_SP;
1770           break;
1771
1772         case FMT_BN:
1773           consume_data_flag = 0 ;
1774           dtp->u.p.blank_status = BLANK_NULL;
1775           break;
1776
1777         case FMT_BZ:
1778           consume_data_flag = 0;
1779           dtp->u.p.blank_status = BLANK_ZERO;
1780           break;
1781
1782         case FMT_DC:
1783           consume_data_flag = 0;
1784           dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1785           break;
1786
1787         case FMT_DP:
1788           consume_data_flag = 0;
1789           dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1790           break;
1791
1792         case FMT_RC:
1793           consume_data_flag = 0;
1794           dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1795           break;
1796
1797         case FMT_RD:
1798           consume_data_flag = 0;
1799           dtp->u.p.current_unit->round_status = ROUND_DOWN;
1800           break;
1801
1802         case FMT_RN:
1803           consume_data_flag = 0;
1804           dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1805           break;
1806
1807         case FMT_RP:
1808           consume_data_flag = 0;
1809           dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1810           break;
1811
1812         case FMT_RU:
1813           consume_data_flag = 0;
1814           dtp->u.p.current_unit->round_status = ROUND_UP;
1815           break;
1816
1817         case FMT_RZ:
1818           consume_data_flag = 0;
1819           dtp->u.p.current_unit->round_status = ROUND_ZERO;
1820           break;
1821
1822         case FMT_P:
1823           consume_data_flag = 0;
1824           dtp->u.p.scale_factor = f->u.k;
1825           break;
1826
1827         case FMT_DOLLAR:
1828           consume_data_flag = 0;
1829           dtp->u.p.seen_dollar = 1;
1830           break;
1831
1832         case FMT_SLASH:
1833           consume_data_flag = 0;
1834           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1835           next_record (dtp, 0);
1836           break;
1837
1838         case FMT_COLON:
1839           /* A colon descriptor causes us to exit this loop (in
1840              particular preventing another / descriptor from being
1841              processed) unless there is another data item to be
1842              transferred.  */
1843           consume_data_flag = 0;
1844           if (n == 0)
1845             return;
1846           break;
1847
1848         default:
1849           internal_error (&dtp->common, "Bad format node");
1850         }
1851
1852       /* Adjust the item count and data pointer.  */
1853
1854       if ((consume_data_flag > 0) && (n > 0))
1855         {
1856           n--;
1857           p = ((char *) p) + size;
1858         }
1859
1860       pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1861       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1862     }
1863
1864   return;
1865
1866   /* Come here when we need a data descriptor but don't have one.  We
1867      push the current format node back onto the input, then return and
1868      let the user program call us back with the data.  */
1869  need_data:
1870   unget_format (dtp, f);
1871 }
1872
1873   /* This function is first called from data_init_transfer to initiate the loop
1874      over each item in the format, transferring data as required.  Subsequent
1875      calls to this function occur for each data item foound in the READ/WRITE
1876      statement.  The item_count is incremented for each call.  Since the first
1877      call is from data_transfer_init, the item_count is always one greater than
1878      the actual count number of the item being transferred.  */
1879
1880 static void
1881 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1882                     size_t size, size_t nelems)
1883 {
1884   size_t elem;
1885   char *tmp;
1886
1887   tmp = (char *) p;
1888   size_t stride = type == BT_CHARACTER ?
1889                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1890   if (dtp->u.p.mode == READING)
1891     {
1892       /* Big loop over all the elements.  */
1893       for (elem = 0; elem < nelems; elem++)
1894         {
1895           dtp->u.p.item_count++;
1896           formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
1897         }
1898     }
1899   else
1900     {
1901       /* Big loop over all the elements.  */
1902       for (elem = 0; elem < nelems; elem++)
1903         {
1904           dtp->u.p.item_count++;
1905           formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
1906         }
1907     }
1908 }
1909
1910
1911 /* Data transfer entry points.  The type of the data entity is
1912    implicit in the subroutine call.  This prevents us from having to
1913    share a common enum with the compiler.  */
1914
1915 void
1916 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1917 {
1918   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1919     return;
1920   dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1921 }
1922
1923 void
1924 transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
1925 {
1926   transfer_integer (dtp, p, kind);
1927 }
1928
1929 void
1930 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1931 {
1932   size_t size;
1933   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1934     return;
1935   size = size_from_real_kind (kind);
1936   dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1937 }
1938
1939 void
1940 transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
1941 {
1942   transfer_real (dtp, p, kind);
1943 }
1944
1945 void
1946 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1947 {
1948   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1949     return;
1950   dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1951 }
1952
1953 void
1954 transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
1955 {
1956   transfer_logical (dtp, p, kind);
1957 }
1958
1959 void
1960 transfer_character (st_parameter_dt *dtp, void *p, int len)
1961 {
1962   static char *empty_string[0];
1963
1964   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1965     return;
1966
1967   /* Strings of zero length can have p == NULL, which confuses the
1968      transfer routines into thinking we need more data elements.  To avoid
1969      this, we give them a nice pointer.  */
1970   if (len == 0 && p == NULL)
1971     p = empty_string;
1972
1973   /* Set kind here to 1.  */
1974   dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
1975 }
1976
1977 void
1978 transfer_character_write (st_parameter_dt *dtp, void *p, int len)
1979 {
1980   transfer_character (dtp, p, len);
1981 }
1982
1983 void
1984 transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
1985 {
1986   static char *empty_string[0];
1987
1988   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1989     return;
1990
1991   /* Strings of zero length can have p == NULL, which confuses the
1992      transfer routines into thinking we need more data elements.  To avoid
1993      this, we give them a nice pointer.  */
1994   if (len == 0 && p == NULL)
1995     p = empty_string;
1996
1997   /* Here we pass the actual kind value.  */
1998   dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
1999 }
2000
2001 void
2002 transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
2003 {
2004   transfer_character_wide (dtp, p, len, kind);
2005 }
2006
2007 void
2008 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
2009 {
2010   size_t size;
2011   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2012     return;
2013   size = size_from_complex_kind (kind);
2014   dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
2015 }
2016
2017 void
2018 transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
2019 {
2020   transfer_complex (dtp, p, kind);
2021 }
2022
2023 void
2024 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2025                 gfc_charlen_type charlen)
2026 {
2027   index_type count[GFC_MAX_DIMENSIONS];
2028   index_type extent[GFC_MAX_DIMENSIONS];
2029   index_type stride[GFC_MAX_DIMENSIONS];
2030   index_type stride0, rank, size, n;
2031   size_t tsize;
2032   char *data;
2033   bt iotype;
2034
2035   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2036     return;
2037
2038   iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
2039   size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
2040
2041   rank = GFC_DESCRIPTOR_RANK (desc);
2042   for (n = 0; n < rank; n++)
2043     {
2044       count[n] = 0;
2045       stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
2046       extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
2047
2048       /* If the extent of even one dimension is zero, then the entire
2049          array section contains zero elements, so we return after writing
2050          a zero array record.  */
2051       if (extent[n] <= 0)
2052         {
2053           data = NULL;
2054           tsize = 0;
2055           dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2056           return;
2057         }
2058     }
2059
2060   stride0 = stride[0];
2061
2062   /* If the innermost dimension has a stride of 1, we can do the transfer
2063      in contiguous chunks.  */
2064   if (stride0 == size)
2065     tsize = extent[0];
2066   else
2067     tsize = 1;
2068
2069   data = GFC_DESCRIPTOR_DATA (desc);
2070
2071   while (data)
2072     {
2073       dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2074       data += stride0 * tsize;
2075       count[0] += tsize;
2076       n = 0;
2077       while (count[n] == extent[n])
2078         {
2079           count[n] = 0;
2080           data -= stride[n] * extent[n];
2081           n++;
2082           if (n == rank)
2083             {
2084               data = NULL;
2085               break;
2086             }
2087           else
2088             {
2089               count[n]++;
2090               data += stride[n];
2091             }
2092         }
2093     }
2094 }
2095
2096 void
2097 transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2098                       gfc_charlen_type charlen)
2099 {
2100   transfer_array (dtp, desc, kind, charlen);
2101 }
2102
2103 /* Preposition a sequential unformatted file while reading.  */
2104
2105 static void
2106 us_read (st_parameter_dt *dtp, int continued)
2107 {
2108   ssize_t n, nr;
2109   GFC_INTEGER_4 i4;
2110   GFC_INTEGER_8 i8;
2111   gfc_offset i;
2112
2113   if (compile_options.record_marker == 0)
2114     n = sizeof (GFC_INTEGER_4);
2115   else
2116     n = compile_options.record_marker;
2117
2118   nr = sread (dtp->u.p.current_unit->s, &i, n);
2119   if (unlikely (nr < 0))
2120     {
2121       generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2122       return;
2123     }
2124   else if (nr == 0)
2125     {
2126       hit_eof (dtp);
2127       return;  /* end of file */
2128     }
2129   else if (unlikely (n != nr))
2130     {
2131       generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2132       return;
2133     }
2134
2135   /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
2136   if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
2137     {
2138       switch (nr)
2139         {
2140         case sizeof(GFC_INTEGER_4):
2141           memcpy (&i4, &i, sizeof (i4));
2142           i = i4;
2143           break;
2144
2145         case sizeof(GFC_INTEGER_8):
2146           memcpy (&i8, &i, sizeof (i8));
2147           i = i8;
2148           break;
2149
2150         default:
2151           runtime_error ("Illegal value for record marker");
2152           break;
2153         }
2154     }
2155   else
2156       switch (nr)
2157         {
2158         case sizeof(GFC_INTEGER_4):
2159           reverse_memcpy (&i4, &i, sizeof (i4));
2160           i = i4;
2161           break;
2162
2163         case sizeof(GFC_INTEGER_8):
2164           reverse_memcpy (&i8, &i, sizeof (i8));
2165           i = i8;
2166           break;
2167
2168         default:
2169           runtime_error ("Illegal value for record marker");
2170           break;
2171         }
2172
2173   if (i >= 0)
2174     {
2175       dtp->u.p.current_unit->bytes_left_subrecord = i;
2176       dtp->u.p.current_unit->continued = 0;
2177     }
2178   else
2179     {
2180       dtp->u.p.current_unit->bytes_left_subrecord = -i;
2181       dtp->u.p.current_unit->continued = 1;
2182     }
2183
2184   if (! continued)
2185     dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2186 }
2187
2188
2189 /* Preposition a sequential unformatted file while writing.  This
2190    amount to writing a bogus length that will be filled in later.  */
2191
2192 static void
2193 us_write (st_parameter_dt *dtp, int continued)
2194 {
2195   ssize_t nbytes;
2196   gfc_offset dummy;
2197
2198   dummy = 0;
2199
2200   if (compile_options.record_marker == 0)
2201     nbytes = sizeof (GFC_INTEGER_4);
2202   else
2203     nbytes = compile_options.record_marker ;
2204
2205   if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
2206     generate_error (&dtp->common, LIBERROR_OS, NULL);
2207
2208   /* For sequential unformatted, if RECL= was not specified in the OPEN
2209      we write until we have more bytes than can fit in the subrecord
2210      markers, then we write a new subrecord.  */
2211
2212   dtp->u.p.current_unit->bytes_left_subrecord =
2213     dtp->u.p.current_unit->recl_subrecord;
2214   dtp->u.p.current_unit->continued = continued;
2215 }
2216
2217
2218 /* Position to the next record prior to transfer.  We are assumed to
2219    be before the next record.  We also calculate the bytes in the next
2220    record.  */
2221
2222 static void
2223 pre_position (st_parameter_dt *dtp)
2224 {
2225   if (dtp->u.p.current_unit->current_record)
2226     return;                     /* Already positioned.  */
2227
2228   switch (current_mode (dtp))
2229     {
2230     case FORMATTED_STREAM:
2231     case UNFORMATTED_STREAM:
2232       /* There are no records with stream I/O.  If the position was specified
2233          data_transfer_init has already positioned the file. If no position
2234          was specified, we continue from where we last left off.  I.e.
2235          there is nothing to do here.  */
2236       break;
2237
2238     case UNFORMATTED_SEQUENTIAL:
2239       if (dtp->u.p.mode == READING)
2240         us_read (dtp, 0);
2241       else
2242         us_write (dtp, 0);
2243
2244       break;
2245
2246     case FORMATTED_SEQUENTIAL:
2247     case FORMATTED_DIRECT:
2248     case UNFORMATTED_DIRECT:
2249       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2250       break;
2251     }
2252
2253   dtp->u.p.current_unit->current_record = 1;
2254 }
2255
2256
2257 /* Initialize things for a data transfer.  This code is common for
2258    both reading and writing.  */
2259
2260 static void
2261 data_transfer_init (st_parameter_dt *dtp, int read_flag)
2262 {
2263   unit_flags u_flags;  /* Used for creating a unit if needed.  */
2264   GFC_INTEGER_4 cf = dtp->common.flags;
2265   namelist_info *ionml;
2266
2267   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
2268
2269   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2270
2271   dtp->u.p.ionml = ionml;
2272   dtp->u.p.mode = read_flag ? READING : WRITING;
2273
2274   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2275     return;
2276
2277   if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2278     dtp->u.p.size_used = 0;  /* Initialize the count.  */
2279
2280   dtp->u.p.current_unit = get_unit (dtp, 1);
2281   if (dtp->u.p.current_unit->s == NULL)
2282     {  /* Open the unit with some default flags.  */
2283        st_parameter_open opp;
2284        unit_convert conv;
2285
2286       if (dtp->common.unit < 0)
2287         {
2288           close_unit (dtp->u.p.current_unit);
2289           dtp->u.p.current_unit = NULL;
2290           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2291                           "Bad unit number in statement");
2292           return;
2293         }
2294       memset (&u_flags, '\0', sizeof (u_flags));
2295       u_flags.access = ACCESS_SEQUENTIAL;
2296       u_flags.action = ACTION_READWRITE;
2297
2298       /* Is it unformatted?  */
2299       if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
2300                   | IOPARM_DT_IONML_SET)))
2301         u_flags.form = FORM_UNFORMATTED;
2302       else
2303         u_flags.form = FORM_UNSPECIFIED;
2304
2305       u_flags.delim = DELIM_UNSPECIFIED;
2306       u_flags.blank = BLANK_UNSPECIFIED;
2307       u_flags.pad = PAD_UNSPECIFIED;
2308       u_flags.decimal = DECIMAL_UNSPECIFIED;
2309       u_flags.encoding = ENCODING_UNSPECIFIED;
2310       u_flags.async = ASYNC_UNSPECIFIED;
2311       u_flags.round = ROUND_UNSPECIFIED;
2312       u_flags.sign = SIGN_UNSPECIFIED;
2313
2314       u_flags.status = STATUS_UNKNOWN;
2315
2316       conv = get_unformatted_convert (dtp->common.unit);
2317
2318       if (conv == GFC_CONVERT_NONE)
2319         conv = compile_options.convert;
2320
2321       /* We use big_endian, which is 0 on little-endian machines
2322          and 1 on big-endian machines.  */
2323       switch (conv)
2324         {
2325         case GFC_CONVERT_NATIVE:
2326         case GFC_CONVERT_SWAP:
2327           break;
2328
2329         case GFC_CONVERT_BIG:
2330           conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
2331           break;
2332
2333         case GFC_CONVERT_LITTLE:
2334           conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
2335           break;
2336
2337         default:
2338           internal_error (&opp.common, "Illegal value for CONVERT");
2339           break;
2340         }
2341
2342       u_flags.convert = conv;
2343
2344       opp.common = dtp->common;
2345       opp.common.flags &= IOPARM_COMMON_MASK;
2346       dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
2347       dtp->common.flags &= ~IOPARM_COMMON_MASK;
2348       dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
2349       if (dtp->u.p.current_unit == NULL)
2350         return;
2351     }
2352
2353   /* Check the action.  */
2354
2355   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
2356     {
2357       generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2358                       "Cannot read from file opened for WRITE");
2359       return;
2360     }
2361
2362   if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
2363     {
2364       generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2365                       "Cannot write to file opened for READ");
2366       return;
2367     }
2368
2369   dtp->u.p.first_item = 1;
2370
2371   /* Check the format.  */
2372
2373   if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2374     parse_format (dtp);
2375
2376   if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2377       && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2378          != 0)
2379     {
2380       generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2381                       "Format present for UNFORMATTED data transfer");
2382       return;
2383     }
2384
2385   if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
2386      {
2387         if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2388            generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2389                     "A format cannot be specified with a namelist");
2390      }
2391   else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
2392            !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
2393     {
2394       generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2395                       "Missing format for FORMATTED data transfer");
2396     }
2397
2398   if (is_internal_unit (dtp)
2399       && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2400     {
2401       generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2402                       "Internal file cannot be accessed by UNFORMATTED "
2403                       "data transfer");
2404       return;
2405     }
2406
2407   /* Check the record or position number.  */
2408
2409   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
2410       && (cf & IOPARM_DT_HAS_REC) == 0)
2411     {
2412       generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2413                       "Direct access data transfer requires record number");
2414       return;
2415     }
2416
2417   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2418     {
2419       if ((cf & IOPARM_DT_HAS_REC) != 0)
2420         {
2421           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2422                         "Record number not allowed for sequential access "
2423                         "data transfer");
2424           return;
2425         }
2426
2427       if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
2428         {
2429           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2430                         "Sequential READ or WRITE not allowed after "
2431                         "EOF marker, possibly use REWIND or BACKSPACE");
2432           return;
2433         }
2434
2435     }
2436   /* Process the ADVANCE option.  */
2437
2438   dtp->u.p.advance_status
2439     = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
2440       find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
2441                    "Bad ADVANCE parameter in data transfer statement");
2442
2443   if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
2444     {
2445       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2446         {
2447           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2448                           "ADVANCE specification conflicts with sequential "
2449                           "access");
2450           return;
2451         }
2452
2453       if (is_internal_unit (dtp))
2454         {
2455           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2456                           "ADVANCE specification conflicts with internal file");
2457           return;
2458         }
2459
2460       if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2461           != IOPARM_DT_HAS_FORMAT)
2462         {
2463           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2464                           "ADVANCE specification requires an explicit format");
2465           return;
2466         }
2467     }
2468
2469   if (read_flag)
2470     {
2471       dtp->u.p.current_unit->previous_nonadvancing_write = 0;
2472
2473       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
2474         {
2475           generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2476                           "EOR specification requires an ADVANCE specification "
2477                           "of NO");
2478           return;
2479         }
2480
2481       if ((cf & IOPARM_DT_HAS_SIZE) != 0
2482           && dtp->u.p.advance_status != ADVANCE_NO)
2483         {
2484           generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2485                           "SIZE specification requires an ADVANCE "
2486                           "specification of NO");
2487           return;
2488         }
2489     }
2490   else
2491     {                           /* Write constraints.  */
2492       if ((cf & IOPARM_END) != 0)
2493         {
2494           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2495                           "END specification cannot appear in a write "
2496                           "statement");
2497           return;
2498         }
2499
2500       if ((cf & IOPARM_EOR) != 0)
2501         {
2502           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2503                           "EOR specification cannot appear in a write "
2504                           "statement");
2505           return;
2506         }
2507
2508       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2509         {
2510           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2511                           "SIZE specification cannot appear in a write "
2512                           "statement");
2513           return;
2514         }
2515     }
2516
2517   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
2518     dtp->u.p.advance_status = ADVANCE_YES;
2519
2520   /* Check the decimal mode.  */
2521   dtp->u.p.current_unit->decimal_status
2522         = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
2523           find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
2524                         decimal_opt, "Bad DECIMAL parameter in data transfer "
2525                         "statement");
2526
2527   if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
2528         dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
2529
2530   /* Check the round mode.  */
2531   dtp->u.p.current_unit->round_status
2532         = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
2533           find_option (&dtp->common, dtp->round, dtp->round_len,
2534                         round_opt, "Bad ROUND parameter in data transfer "
2535                         "statement");
2536
2537   if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
2538         dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
2539
2540   /* Check the sign mode. */
2541   dtp->u.p.sign_status
2542         = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
2543           find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
2544                         "Bad SIGN parameter in data transfer statement");
2545
2546   if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
2547         dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
2548
2549   /* Check the blank mode.  */
2550   dtp->u.p.blank_status
2551         = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
2552           find_option (&dtp->common, dtp->blank, dtp->blank_len,
2553                         blank_opt,
2554                         "Bad BLANK parameter in data transfer statement");
2555
2556   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
2557         dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2558
2559   /* Check the delim mode.  */
2560   dtp->u.p.current_unit->delim_status
2561         = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
2562           find_option (&dtp->common, dtp->delim, dtp->delim_len,
2563           delim_opt, "Bad DELIM parameter in data transfer statement");
2564
2565   if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
2566     dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
2567
2568   /* Check the pad mode.  */
2569   dtp->u.p.current_unit->pad_status
2570         = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
2571           find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
2572                         "Bad PAD parameter in data transfer statement");
2573
2574   if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
2575         dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
2576
2577   /* Check to see if we might be reading what we wrote before  */
2578
2579   if (dtp->u.p.mode != dtp->u.p.current_unit->mode
2580       && !is_internal_unit (dtp))
2581     {
2582       int pos = fbuf_reset (dtp->u.p.current_unit);
2583       if (pos != 0)
2584         sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
2585       sflush(dtp->u.p.current_unit->s);
2586     }
2587
2588   /* Check the POS= specifier: that it is in range and that it is used with a
2589      unit that has been connected for STREAM access. F2003 9.5.1.10.  */
2590
2591   if (((cf & IOPARM_DT_HAS_POS) != 0))
2592     {
2593       if (is_stream_io (dtp))
2594         {
2595
2596           if (dtp->pos <= 0)
2597             {
2598               generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2599                               "POS=specifier must be positive");
2600               return;
2601             }
2602
2603           if (dtp->pos >= dtp->u.p.current_unit->maxrec)
2604             {
2605               generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2606                               "POS=specifier too large");
2607               return;
2608             }
2609
2610           dtp->rec = dtp->pos;
2611
2612           if (dtp->u.p.mode == READING)
2613             {
2614               /* Reset the endfile flag; if we hit EOF during reading
2615                  we'll set the flag and generate an error at that point
2616                  rather than worrying about it here.  */
2617               dtp->u.p.current_unit->endfile = NO_ENDFILE;
2618             }
2619
2620           if (dtp->pos != dtp->u.p.current_unit->strm_pos)
2621             {
2622               fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2623               if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
2624                 {
2625                   generate_error (&dtp->common, LIBERROR_OS, NULL);
2626                   return;
2627                 }
2628               dtp->u.p.current_unit->strm_pos = dtp->pos;
2629             }
2630         }
2631       else
2632         {
2633           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2634                           "POS=specifier not allowed, "
2635                           "Try OPEN with ACCESS='stream'");
2636           return;
2637         }
2638     }
2639
2640
2641   /* Sanity checks on the record number.  */
2642   if ((cf & IOPARM_DT_HAS_REC) != 0)
2643     {
2644       if (dtp->rec <= 0)
2645         {
2646           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2647                           "Record number must be positive");
2648           return;
2649         }
2650
2651       if (dtp->rec >= dtp->u.p.current_unit->maxrec)
2652         {
2653           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2654                           "Record number too large");
2655           return;
2656         }
2657
2658       /* Make sure format buffer is reset.  */
2659       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2660         fbuf_reset (dtp->u.p.current_unit);
2661
2662
2663       /* Check whether the record exists to be read.  Only
2664          a partial record needs to exist.  */
2665
2666       if (dtp->u.p.mode == READING && (dtp->rec - 1)
2667           * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s))
2668         {
2669           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2670                           "Non-existing record number");
2671           return;
2672         }
2673
2674       /* Position the file.  */
2675       if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
2676                  * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
2677         {
2678           generate_error (&dtp->common, LIBERROR_OS, NULL);
2679           return;
2680         }
2681
2682       /* TODO: This is required to maintain compatibility between
2683          4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2684
2685       if (is_stream_io (dtp))
2686         dtp->u.p.current_unit->strm_pos = dtp->rec;
2687
2688       /* TODO: Un-comment this code when ABI changes from 4.3.
2689       if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2690        {
2691          generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2692                      "Record number not allowed for stream access "
2693                      "data transfer");
2694          return;
2695        }  */
2696     }
2697
2698   /* Bugware for badly written mixed C-Fortran I/O.  */
2699   if (!is_internal_unit (dtp))
2700     flush_if_preconnected(dtp->u.p.current_unit->s);
2701
2702   dtp->u.p.current_unit->mode = dtp->u.p.mode;
2703
2704   /* Set the maximum position reached from the previous I/O operation.  This
2705      could be greater than zero from a previous non-advancing write.  */
2706   dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2707
2708   pre_position (dtp);
2709
2710
2711   /* Set up the subroutine that will handle the transfers.  */
2712
2713   if (read_flag)
2714     {
2715       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2716         dtp->u.p.transfer = unformatted_read;
2717       else
2718         {
2719           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2720             {
2721                 dtp->u.p.last_char = EOF - 1;
2722                 dtp->u.p.transfer = list_formatted_read;
2723             }
2724           else
2725             dtp->u.p.transfer = formatted_transfer;
2726         }
2727     }
2728   else
2729     {
2730       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2731         dtp->u.p.transfer = unformatted_write;
2732       else
2733         {
2734           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2735             dtp->u.p.transfer = list_formatted_write;
2736           else
2737             dtp->u.p.transfer = formatted_transfer;
2738         }
2739     }
2740
2741   /* Make sure that we don't do a read after a nonadvancing write.  */
2742
2743   if (read_flag)
2744     {
2745       if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2746         {
2747           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2748                           "Cannot READ after a nonadvancing WRITE");
2749           return;
2750         }
2751     }
2752   else
2753     {
2754       if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2755         dtp->u.p.current_unit->read_bad = 1;
2756     }
2757
2758   /* Start the data transfer if we are doing a formatted transfer.  */
2759   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2760       && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
2761       && dtp->u.p.ionml == NULL)
2762     formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2763 }
2764
2765 /* Initialize an array_loop_spec given the array descriptor.  The function
2766    returns the index of the last element of the array, and also returns
2767    starting record, where the first I/O goes to (necessary in case of
2768    negative strides).  */
2769
2770 gfc_offset
2771 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
2772                 gfc_offset *start_record)
2773 {
2774   int rank = GFC_DESCRIPTOR_RANK(desc);
2775   int i;
2776   gfc_offset index;
2777   int empty;
2778
2779   empty = 0;
2780   index = 1;
2781   *start_record = 0;
2782
2783   for (i=0; i<rank; i++)
2784     {
2785       ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
2786       ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
2787       ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
2788       ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
2789       empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
2790                         < GFC_DESCRIPTOR_LBOUND(desc,i));
2791
2792       if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
2793         {
2794           index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2795             * GFC_DESCRIPTOR_STRIDE(desc,i);
2796         }
2797       else
2798         {
2799           index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2800             * GFC_DESCRIPTOR_STRIDE(desc,i);
2801           *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2802             * GFC_DESCRIPTOR_STRIDE(desc,i);
2803         }
2804     }
2805
2806   if (empty)
2807     return 0;
2808   else
2809     return index;
2810 }
2811
2812 /* Determine the index to the next record in an internal unit array by
2813    by incrementing through the array_loop_spec.  */
2814
2815 gfc_offset
2816 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
2817 {
2818   int i, carry;
2819   gfc_offset index;
2820
2821   carry = 1;
2822   index = 0;
2823
2824   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2825     {
2826       if (carry)
2827         {
2828           ls[i].idx++;
2829           if (ls[i].idx > ls[i].end)
2830             {
2831               ls[i].idx = ls[i].start;
2832               carry = 1;
2833             }
2834           else
2835             carry = 0;
2836         }
2837       index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2838     }
2839
2840   *finished = carry;
2841
2842   return index;
2843 }
2844
2845
2846
2847 /* Skip to the end of the current record, taking care of an optional
2848    record marker of size bytes.  If the file is not seekable, we
2849    read chunks of size MAX_READ until we get to the right
2850    position.  */
2851
2852 static void
2853 skip_record (st_parameter_dt *dtp, ssize_t bytes)
2854 {
2855   ssize_t rlength, readb;
2856   static const ssize_t MAX_READ = 4096;
2857   char p[MAX_READ];
2858
2859   dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2860   if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2861     return;
2862
2863   /* Direct access files do not generate END conditions,
2864      only I/O errors.  */
2865   if (sseek (dtp->u.p.current_unit->s,
2866              dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
2867     {
2868       /* Seeking failed, fall back to seeking by reading data.  */
2869       while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2870         {
2871           rlength =
2872             (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
2873             MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2874
2875           readb = sread (dtp->u.p.current_unit->s, p, rlength);
2876           if (readb < 0)
2877             {
2878               generate_error (&dtp->common, LIBERROR_OS, NULL);
2879               return;
2880             }
2881
2882           dtp->u.p.current_unit->bytes_left_subrecord -= readb;
2883         }
2884       return;
2885     }
2886   dtp->u.p.current_unit->bytes_left_subrecord = 0;
2887 }
2888
2889
2890 /* Advance to the next record reading unformatted files, taking
2891    care of subrecords.  If complete_record is nonzero, we loop
2892    until all subrecords are cleared.  */
2893
2894 static void
2895 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2896 {
2897   size_t bytes;
2898
2899   bytes =  compile_options.record_marker == 0 ?
2900     sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2901
2902   while(1)
2903     {
2904
2905       /* Skip over tail */
2906
2907       skip_record (dtp, bytes);
2908
2909       if ( ! (complete_record && dtp->u.p.current_unit->continued))
2910         return;
2911
2912       us_read (dtp, 1);
2913     }
2914 }
2915
2916
2917 static gfc_offset
2918 min_off (gfc_offset a, gfc_offset b)
2919 {
2920   return (a < b ? a : b);
2921 }
2922
2923
2924 /* Space to the next record for read mode.  */
2925
2926 static void
2927 next_record_r (st_parameter_dt *dtp, int done)
2928 {
2929   gfc_offset record;
2930   int bytes_left;
2931   char p;
2932   int cc;
2933
2934   switch (current_mode (dtp))
2935     {
2936     /* No records in unformatted STREAM I/O.  */
2937     case UNFORMATTED_STREAM:
2938       return;
2939
2940     case UNFORMATTED_SEQUENTIAL:
2941       next_record_r_unf (dtp, 1);
2942       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2943       break;
2944
2945     case FORMATTED_DIRECT:
2946     case UNFORMATTED_DIRECT:
2947       skip_record (dtp, dtp->u.p.current_unit->bytes_left);
2948       break;
2949
2950     case FORMATTED_STREAM:
2951     case FORMATTED_SEQUENTIAL:
2952       /* read_sf has already terminated input because of an '\n', or
2953          we have hit EOF.  */
2954       if (dtp->u.p.sf_seen_eor)
2955         {
2956           dtp->u.p.sf_seen_eor = 0;
2957           break;
2958         }
2959
2960       if (is_internal_unit (dtp))
2961         {
2962           if (is_array_io (dtp))
2963             {
2964               int finished;
2965
2966               record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2967                                           &finished);
2968               if (!done && finished)
2969                 hit_eof (dtp);
2970
2971               /* Now seek to this record.  */
2972               record = record * dtp->u.p.current_unit->recl;
2973               if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
2974                 {
2975                   generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2976                   break;
2977                 }
2978               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2979             }
2980           else
2981             {
2982               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2983               bytes_left = min_off (bytes_left,
2984                       ssize (dtp->u.p.current_unit->s)
2985                       - stell (dtp->u.p.current_unit->s));
2986               if (sseek (dtp->u.p.current_unit->s,
2987                          bytes_left, SEEK_CUR) < 0)
2988                 {
2989                   generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2990                   break;
2991                 }
2992               dtp->u.p.current_unit->bytes_left
2993                 = dtp->u.p.current_unit->recl;
2994             }
2995           break;
2996         }
2997       else
2998         {
2999           do
3000             {
3001               errno = 0;
3002               cc = fbuf_getc (dtp->u.p.current_unit);
3003               if (cc == EOF)
3004                 {
3005                   if (errno != 0)
3006                     generate_error (&dtp->common, LIBERROR_OS, NULL);
3007                   else
3008                     {
3009                       if (is_stream_io (dtp)
3010                           || dtp->u.p.current_unit->pad_status == PAD_NO
3011                           || dtp->u.p.current_unit->bytes_left
3012                              == dtp->u.p.current_unit->recl)
3013                         hit_eof (dtp);
3014                     }
3015                   break;
3016                 }
3017
3018               if (is_stream_io (dtp))
3019                 dtp->u.p.current_unit->strm_pos++;
3020
3021               p = (char) cc;
3022             }
3023           while (p != '\n');
3024         }
3025       break;
3026     }
3027 }
3028
3029
3030 /* Small utility function to write a record marker, taking care of
3031    byte swapping and of choosing the correct size.  */
3032
3033 static int
3034 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
3035 {
3036   size_t len;
3037   GFC_INTEGER_4 buf4;
3038   GFC_INTEGER_8 buf8;
3039   char p[sizeof (GFC_INTEGER_8)];
3040
3041   if (compile_options.record_marker == 0)
3042     len = sizeof (GFC_INTEGER_4);
3043   else
3044     len = compile_options.record_marker;
3045
3046   /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
3047   if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
3048     {
3049       switch (len)
3050         {
3051         case sizeof (GFC_INTEGER_4):
3052           buf4 = buf;
3053           return swrite (dtp->u.p.current_unit->s, &buf4, len);
3054           break;
3055
3056         case sizeof (GFC_INTEGER_8):
3057           buf8 = buf;
3058           return swrite (dtp->u.p.current_unit->s, &buf8, len);
3059           break;
3060
3061         default:
3062           runtime_error ("Illegal value for record marker");
3063           break;
3064         }
3065     }
3066   else
3067     {
3068       switch (len)
3069         {
3070         case sizeof (GFC_INTEGER_4):
3071           buf4 = buf;
3072           reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
3073           return swrite (dtp->u.p.current_unit->s, p, len);
3074           break;
3075
3076         case sizeof (GFC_INTEGER_8):
3077           buf8 = buf;
3078           reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
3079           return swrite (dtp->u.p.current_unit->s, p, len);
3080           break;
3081
3082         default:
3083           runtime_error ("Illegal value for record marker");
3084           break;
3085         }
3086     }
3087
3088 }
3089
3090 /* Position to the next (sub)record in write mode for
3091    unformatted sequential files.  */
3092
3093 static void
3094 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
3095 {
3096   gfc_offset m, m_write, record_marker;
3097
3098   /* Bytes written.  */
3099   m = dtp->u.p.current_unit->recl_subrecord
3100     - dtp->u.p.current_unit->bytes_left_subrecord;
3101
3102   /* Write the length tail.  If we finish a record containing
3103      subrecords, we write out the negative length.  */
3104
3105   if (dtp->u.p.current_unit->continued)
3106     m_write = -m;
3107   else
3108     m_write = m;
3109
3110   if (unlikely (write_us_marker (dtp, m_write) < 0))
3111     goto io_error;
3112
3113   if (compile_options.record_marker == 0)
3114     record_marker = sizeof (GFC_INTEGER_4);
3115   else
3116     record_marker = compile_options.record_marker;
3117
3118   /* Seek to the head and overwrite the bogus length with the real
3119      length.  */
3120
3121   if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker,
3122                        SEEK_CUR) < 0))
3123     goto io_error;
3124
3125   if (next_subrecord)
3126     m_write = -m;
3127   else
3128     m_write = m;
3129
3130   if (unlikely (write_us_marker (dtp, m_write) < 0))
3131     goto io_error;
3132
3133   /* Seek past the end of the current record.  */
3134
3135   if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker,
3136                        SEEK_CUR) < 0))
3137     goto io_error;
3138
3139   return;
3140
3141  io_error:
3142   generate_error (&dtp->common, LIBERROR_OS, NULL);
3143   return;
3144
3145 }
3146
3147
3148 /* Utility function like memset() but operating on streams. Return
3149    value is same as for POSIX write().  */
3150
3151 static ssize_t
3152 sset (stream * s, int c, ssize_t nbyte)
3153 {
3154   static const int WRITE_CHUNK = 256;
3155   char p[WRITE_CHUNK];
3156   ssize_t bytes_left, trans;
3157
3158   if (nbyte < WRITE_CHUNK)
3159     memset (p, c, nbyte);
3160   else
3161     memset (p, c, WRITE_CHUNK);
3162
3163   bytes_left = nbyte;
3164   while (bytes_left > 0)
3165     {
3166       trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
3167       trans = swrite (s, p, trans);
3168       if (trans <= 0)
3169         return trans;
3170       bytes_left -= trans;
3171     }
3172
3173   return nbyte - bytes_left;
3174 }
3175
3176
3177 /* Position to the next record in write mode.  */
3178
3179 static void
3180 next_record_w (st_parameter_dt *dtp, int done)
3181 {
3182   gfc_offset m, record, max_pos;
3183   int length;
3184
3185   /* Zero counters for X- and T-editing.  */
3186   max_pos = dtp->u.p.max_pos;
3187   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
3188
3189   switch (current_mode (dtp))
3190     {
3191     /* No records in unformatted STREAM I/O.  */
3192     case UNFORMATTED_STREAM:
3193       return;
3194
3195     case FORMATTED_DIRECT:
3196       if (dtp->u.p.current_unit->bytes_left == 0)
3197         break;
3198
3199       fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3200       fbuf_flush (dtp->u.p.current_unit, WRITING);
3201       if (sset (dtp->u.p.current_unit->s, ' ',
3202                 dtp->u.p.current_unit->bytes_left)
3203           != dtp->u.p.current_unit->bytes_left)
3204         goto io_error;
3205
3206       break;
3207
3208     case UNFORMATTED_DIRECT:
3209       if (dtp->u.p.current_unit->bytes_left > 0)
3210         {
3211           length = (int) dtp->u.p.current_unit->bytes_left;
3212           if (sset (dtp->u.p.current_unit->s, 0, length) != length)
3213             goto io_error;
3214         }
3215       break;
3216
3217     case UNFORMATTED_SEQUENTIAL:
3218       next_record_w_unf (dtp, 0);
3219       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3220       break;
3221
3222     case FORMATTED_STREAM:
3223     case FORMATTED_SEQUENTIAL:
3224
3225       if (is_internal_unit (dtp))
3226         {
3227           char *p;
3228           if (is_array_io (dtp))
3229             {
3230               int finished;
3231
3232               length = (int) dtp->u.p.current_unit->bytes_left;
3233
3234               /* If the farthest position reached is greater than current
3235               position, adjust the position and set length to pad out
3236               whats left.  Otherwise just pad whats left.
3237               (for character array unit) */
3238               m = dtp->u.p.current_unit->recl
3239                         - dtp->u.p.current_unit->bytes_left;
3240               if (max_pos > m)
3241                 {
3242                   length = (int) (max_pos - m);
3243                   if (sseek (dtp->u.p.current_unit->s,
3244                              length, SEEK_CUR) < 0)
3245                     {
3246                       generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3247                       return;
3248                     }
3249                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
3250                 }
3251
3252               p = write_block (dtp, length);
3253               if (p == NULL)
3254                 return;
3255
3256               if (unlikely (is_char4_unit (dtp)))
3257                 {
3258                   gfc_char4_t *p4 = (gfc_char4_t *) p;
3259                   memset4 (p4, ' ', length);
3260                 }
3261               else
3262                 memset (p, ' ', length);
3263
3264               /* Now that the current record has been padded out,
3265                  determine where the next record in the array is. */
3266               record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3267                                           &finished);
3268               if (finished)
3269                 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3270
3271               /* Now seek to this record */
3272               record = record * dtp->u.p.current_unit->recl;
3273
3274               if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
3275                 {
3276                   generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3277                   return;
3278                 }
3279
3280               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3281             }
3282           else
3283             {
3284               length = 1;
3285
3286               /* If this is the last call to next_record move to the farthest
3287                  position reached and set length to pad out the remainder
3288                  of the record. (for character scaler unit) */
3289               if (done)
3290                 {
3291                   m = dtp->u.p.current_unit->recl
3292                         - dtp->u.p.current_unit->bytes_left;
3293                   if (max_pos > m)
3294                     {
3295                       length = (int) (max_pos - m);
3296                       if (sseek (dtp->u.p.current_unit->s,
3297                                  length, SEEK_CUR) < 0)
3298                         {
3299                           generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3300                           return;
3301                         }
3302                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
3303                     }
3304                   else
3305                     length = (int) dtp->u.p.current_unit->bytes_left;
3306                 }
3307               if (length > 0)
3308                 {
3309                   p = write_block (dtp, length);
3310                   if (p == NULL)
3311                     return;
3312
3313                   if (unlikely (is_char4_unit (dtp)))
3314                     {
3315                       gfc_char4_t *p4 = (gfc_char4_t *) p;
3316                       memset4 (p4, (gfc_char4_t) ' ', length);
3317                     }
3318                   else
3319                     memset (p, ' ', length);
3320                 }
3321             }
3322         }
3323       else
3324         {
3325 #ifdef HAVE_CRLF
3326           const int len = 2;
3327 #else
3328           const int len = 1;
3329 #endif
3330           fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3331           char * p = fbuf_alloc (dtp->u.p.current_unit, len);
3332           if (!p)
3333             goto io_error;
3334 #ifdef HAVE_CRLF
3335           *(p++) = '\r';
3336 #endif
3337           *p = '\n';
3338           if (is_stream_io (dtp))
3339             {
3340               dtp->u.p.current_unit->strm_pos += len;
3341               if (dtp->u.p.current_unit->strm_pos
3342                   < ssize (dtp->u.p.current_unit->s))
3343                 unit_truncate (dtp->u.p.current_unit,
3344                                dtp->u.p.current_unit->strm_pos - 1,
3345                                &dtp->common);
3346             }
3347         }
3348
3349       break;
3350
3351     io_error:
3352       generate_error (&dtp->common, LIBERROR_OS, NULL);
3353       break;
3354     }
3355 }
3356
3357 /* Position to the next record, which means moving to the end of the
3358    current record.  This can happen under several different
3359    conditions.  If the done flag is not set, we get ready to process
3360    the next record.  */
3361
3362 void
3363 next_record (st_parameter_dt *dtp, int done)
3364 {
3365   gfc_offset fp; /* File position.  */
3366
3367   dtp->u.p.current_unit->read_bad = 0;
3368
3369   if (dtp->u.p.mode == READING)
3370     next_record_r (dtp, done);
3371   else
3372     next_record_w (dtp, done);
3373
3374   if (!is_stream_io (dtp))
3375     {
3376       /* Since we have changed the position, set it to unspecified so
3377          that INQUIRE(POSITION=) knows it needs to look into it.  */
3378       if (done)
3379         dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED;
3380
3381       dtp->u.p.current_unit->current_record = 0;
3382       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
3383         {
3384           fp = stell (dtp->u.p.current_unit->s);
3385           /* Calculate next record, rounding up partial records.  */
3386           dtp->u.p.current_unit->last_record =
3387             (fp + dtp->u.p.current_unit->recl - 1) /
3388               dtp->u.p.current_unit->recl;
3389         }
3390       else
3391         dtp->u.p.current_unit->last_record++;
3392     }
3393
3394   if (!done)
3395     pre_position (dtp);
3396
3397   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3398 }
3399
3400
3401 /* Finalize the current data transfer.  For a nonadvancing transfer,
3402    this means advancing to the next record.  For internal units close the
3403    stream associated with the unit.  */
3404
3405 static void
3406 finalize_transfer (st_parameter_dt *dtp)
3407 {
3408   GFC_INTEGER_4 cf = dtp->common.flags;
3409
3410   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
3411     *dtp->size = dtp->u.p.size_used;
3412
3413   if (dtp->u.p.eor_condition)
3414     {
3415       generate_error (&dtp->common, LIBERROR_EOR, NULL);
3416       return;
3417     }
3418
3419   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
3420     {
3421       if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
3422         dtp->u.p.current_unit->current_record = 0;
3423       return;
3424     }
3425
3426   if ((dtp->u.p.ionml != NULL)
3427       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
3428     {
3429        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
3430          namelist_read (dtp);
3431        else
3432          namelist_write (dtp);
3433     }
3434
3435   dtp->u.p.transfer = NULL;
3436   if (dtp->u.p.current_unit == NULL)
3437     return;
3438
3439   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
3440     {
3441       finish_list_read (dtp);
3442       return;
3443     }
3444
3445   if (dtp->u.p.mode == WRITING)
3446     dtp->u.p.current_unit->previous_nonadvancing_write
3447       = dtp->u.p.advance_status == ADVANCE_NO;
3448
3449   if (is_stream_io (dtp))
3450     {
3451       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3452           && dtp->u.p.advance_status != ADVANCE_NO)
3453         next_record (dtp, 1);
3454
3455       return;
3456     }
3457
3458   dtp->u.p.current_unit->current_record = 0;
3459
3460   if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
3461     {
3462       fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3463       dtp->u.p.seen_dollar = 0;
3464       return;
3465     }
3466
3467   /* For non-advancing I/O, save the current maximum position for use in the
3468      next I/O operation if needed.  */
3469   if (dtp->u.p.advance_status == ADVANCE_NO)
3470     {
3471       int bytes_written = (int) (dtp->u.p.current_unit->recl
3472         - dtp->u.p.current_unit->bytes_left);
3473       dtp->u.p.current_unit->saved_pos =
3474         dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
3475       fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3476       return;
3477     }
3478   else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3479            && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
3480       fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3481
3482   dtp->u.p.current_unit->saved_pos = 0;
3483
3484   next_record (dtp, 1);
3485 }
3486
3487 /* Transfer function for IOLENGTH. It doesn't actually do any
3488    data transfer, it just updates the length counter.  */
3489
3490 static void
3491 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
3492                    void *dest __attribute__ ((unused)),
3493                    int kind __attribute__((unused)),
3494                    size_t size, size_t nelems)
3495 {
3496   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3497     *dtp->iolength += (GFC_IO_INT) (size * nelems);
3498 }
3499
3500
3501 /* Initialize the IOLENGTH data transfer. This function is in essence
3502    a very much simplified version of data_transfer_init(), because it
3503    doesn't have to deal with units at all.  */
3504
3505 static void
3506 iolength_transfer_init (st_parameter_dt *dtp)
3507 {
3508   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3509     *dtp->iolength = 0;
3510
3511   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
3512
3513   /* Set up the subroutine that will handle the transfers.  */
3514
3515   dtp->u.p.transfer = iolength_transfer;
3516 }
3517
3518
3519 /* Library entry point for the IOLENGTH form of the INQUIRE
3520    statement. The IOLENGTH form requires no I/O to be performed, but
3521    it must still be a runtime library call so that we can determine
3522    the iolength for dynamic arrays and such.  */
3523
3524 extern void st_iolength (st_parameter_dt *);
3525 export_proto(st_iolength);
3526
3527 void
3528 st_iolength (st_parameter_dt *dtp)
3529 {
3530   library_start (&dtp->common);
3531   iolength_transfer_init (dtp);
3532 }
3533
3534 extern void st_iolength_done (st_parameter_dt *);
3535 export_proto(st_iolength_done);
3536
3537 void
3538 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
3539 {
3540   free_ionml (dtp);
3541   library_end ();
3542 }
3543
3544
3545 /* The READ statement.  */
3546
3547 extern void st_read (st_parameter_dt *);
3548 export_proto(st_read);
3549
3550 void
3551 st_read (st_parameter_dt *dtp)
3552 {
3553   library_start (&dtp->common);
3554
3555   data_transfer_init (dtp, 1);
3556 }
3557
3558 extern void st_read_done (st_parameter_dt *);
3559 export_proto(st_read_done);
3560
3561 void
3562 st_read_done (st_parameter_dt *dtp)
3563 {
3564   finalize_transfer (dtp);
3565   if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3566     free_format_data (dtp->u.p.fmt);
3567   free_ionml (dtp);
3568   if (dtp->u.p.current_unit != NULL)
3569     unlock_unit (dtp->u.p.current_unit);
3570
3571   free_internal_unit (dtp);
3572
3573   library_end ();
3574 }
3575
3576 extern void st_write (st_parameter_dt *);
3577 export_proto(st_write);
3578
3579 void
3580 st_write (st_parameter_dt *dtp)
3581 {
3582   library_start (&dtp->common);
3583   data_transfer_init (dtp, 0);
3584 }
3585
3586 extern void st_write_done (st_parameter_dt *);
3587 export_proto(st_write_done);
3588
3589 void
3590 st_write_done (st_parameter_dt *dtp)
3591 {
3592   finalize_transfer (dtp);
3593
3594   /* Deal with endfile conditions associated with sequential files.  */
3595
3596   if (dtp->u.p.current_unit != NULL
3597       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3598     switch (dtp->u.p.current_unit->endfile)
3599       {
3600       case AT_ENDFILE:          /* Remain at the endfile record.  */
3601         break;
3602
3603       case AFTER_ENDFILE:
3604         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
3605         break;
3606
3607       case NO_ENDFILE:
3608         /* Get rid of whatever is after this record.  */
3609         if (!is_internal_unit (dtp))
3610           unit_truncate (dtp->u.p.current_unit,
3611                          stell (dtp->u.p.current_unit->s),
3612                          &dtp->common);
3613         dtp->u.p.current_unit->endfile = AT_ENDFILE;
3614         break;
3615       }
3616
3617   if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3618     free_format_data (dtp->u.p.fmt);
3619   free_ionml (dtp);
3620   if (dtp->u.p.current_unit != NULL)
3621     unlock_unit (dtp->u.p.current_unit);
3622
3623   free_internal_unit (dtp);
3624
3625   library_end ();
3626 }
3627
3628
3629 /* F2003: This is a stub for the runtime portion of the WAIT statement.  */
3630 void
3631 st_wait (st_parameter_wait *wtp __attribute__((unused)))
3632 {
3633 }
3634
3635
3636 /* Receives the scalar information for namelist objects and stores it
3637    in a linked list of namelist_info types.  */
3638
3639 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
3640                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
3641 export_proto(st_set_nml_var);
3642
3643
3644 void
3645 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
3646                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
3647                 GFC_INTEGER_4 dtype)
3648 {
3649   namelist_info *t1 = NULL;
3650   namelist_info *nml;
3651   size_t var_name_len = strlen (var_name);
3652
3653   nml = (namelist_info*) get_mem (sizeof (namelist_info));
3654
3655   nml->mem_pos = var_addr;
3656
3657   nml->var_name = (char*) get_mem (var_name_len + 1);
3658   memcpy (nml->var_name, var_name, var_name_len);
3659   nml->var_name[var_name_len] = '\0';
3660
3661   nml->len = (int) len;
3662   nml->string_length = (index_type) string_length;
3663
3664   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
3665   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
3666   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
3667
3668   if (nml->var_rank > 0)
3669     {
3670       nml->dim = (descriptor_dimension*)
3671                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
3672       nml->ls = (array_loop_spec*)
3673                   get_mem (nml->var_rank * sizeof (array_loop_spec));
3674     }
3675   else
3676     {
3677       nml->dim = NULL;
3678       nml->ls = NULL;
3679     }
3680
3681   nml->next = NULL;
3682
3683   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
3684     {
3685       dtp->common.flags |= IOPARM_DT_IONML_SET;
3686       dtp->u.p.ionml = nml;
3687     }
3688   else
3689     {
3690       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
3691       t1->next = nml;
3692     }
3693 }
3694
3695 /* Store the dimensional information for the namelist object.  */
3696 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
3697                                 index_type, index_type,
3698                                 index_type);
3699 export_proto(st_set_nml_var_dim);
3700
3701 void
3702 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
3703                     index_type stride, index_type lbound,
3704                     index_type ubound)
3705 {
3706   namelist_info * nml;
3707   int n;
3708
3709   n = (int)n_dim;
3710
3711   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
3712
3713   GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
3714 }
3715
3716 /* Reverse memcpy - used for byte swapping.  */
3717
3718 void reverse_memcpy (void *dest, const void *src, size_t n)
3719 {
3720   char *d, *s;
3721   size_t i;
3722
3723   d = (char *) dest;
3724   s = (char *) src + n - 1;
3725
3726   /* Write with ascending order - this is likely faster
3727      on modern architectures because of write combining.  */
3728   for (i=0; i<n; i++)
3729       *(d++) = *(s--);
3730 }
3731
3732
3733 /* Once upon a time, a poor innocent Fortran program was reading a
3734    file, when suddenly it hit the end-of-file (EOF).  Unfortunately
3735    the OS doesn't tell whether we're at the EOF or whether we already
3736    went past it.  Luckily our hero, libgfortran, keeps track of this.
3737    Call this function when you detect an EOF condition.  See Section
3738    9.10.2 in F2003.  */
3739
3740 void
3741 hit_eof (st_parameter_dt * dtp)
3742 {
3743   dtp->u.p.current_unit->flags.position = POSITION_APPEND;
3744
3745   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3746     switch (dtp->u.p.current_unit->endfile)
3747       {
3748       case NO_ENDFILE:
3749       case AT_ENDFILE:
3750         generate_error (&dtp->common, LIBERROR_END, NULL);
3751         if (!is_internal_unit (dtp))
3752           {
3753             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
3754             dtp->u.p.current_unit->current_record = 0;
3755           }
3756         else
3757           dtp->u.p.current_unit->endfile = AT_ENDFILE;
3758         break;
3759
3760       case AFTER_ENDFILE:
3761         generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
3762         dtp->u.p.current_unit->current_record = 0;
3763         break;
3764       }
3765   else
3766     {
3767       /* Non-sequential files don't have an ENDFILE record, so we
3768          can't be at AFTER_ENDFILE.  */
3769       dtp->u.p.current_unit->endfile = AT_ENDFILE;
3770       generate_error (&dtp->common, LIBERROR_END, NULL);
3771       dtp->u.p.current_unit->current_record = 0;
3772     }
3773 }