libgfortran/io/transfer.c

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