libgfortran/io/transfer.c

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