libgfortran/io/transfer.c

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