libgfortran/io/transfer.c

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