libgfortran/io/transfer.c

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