libgfortran/io/transfer.c

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