libgfortran/io/transfer.c

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