libgfortran/io/transfer.c

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