libgfortran/io/transfer.c

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