l4/pkg/libgfortran/lib/contrib/io/transfer.c

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