libgfortran/io/transfer.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    Namelist transfer functions contributed by Paul Thomas
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31
  32 /* transfer.c -- Top level handling of data transfer statements.  */
  33
  34 #include "config.h"
  35 #include <string.h>
  36 #include <assert.h>
  37 #include "libgfortran.h"
  38 #include "io.h"
  39
  40
  41 /* Calling conventions:  Data transfer statements are unlike other
  42    library calls in that they extend over several calls.
  43
  44    The first call is always a call to st_read() or st_write().  These
  45    subroutines return no status unless a namelist read or write is
  46    being done, in which case there is the usual status.  No further
  47    calls are necessary in this case.
  48
  49    For other sorts of data transfer, there are zero or more data
  50    transfer statement that depend on the format of the data transfer
  51    statement.
  52
  53       transfer_integer
  54       transfer_logical
  55       transfer_character
  56       transfer_real
  57       transfer_complex
  58
  59     These subroutines do not return status.
  60
  61     The last call is a call to st_[read|write]_done().  While
  62     something can easily go wrong with the initial st_read() or
  63     st_write(), an error inhibits any data from actually being
  64     transferred.  */
  65
  66 extern void transfer_integer (st_parameter_dt *, void *, int);
  67 export_proto(transfer_integer);
  68
  69 extern void transfer_real (st_parameter_dt *, void *, int);
  70 export_proto(transfer_real);
  71
  72 extern void transfer_logical (st_parameter_dt *, void *, int);
  73 export_proto(transfer_logical);
  74
  75 extern void transfer_character (st_parameter_dt *, void *, int);
  76 export_proto(transfer_character);
  77
  78 extern void transfer_complex (st_parameter_dt *, void *, int);
  79 export_proto(transfer_complex);
  80
  81 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
  82                             gfc_charlen_type);
  83 export_proto(transfer_array);
  84
  85 static const st_option advance_opt[] = {
  86   {"yes", ADVANCE_YES},
  87   {"no", ADVANCE_NO},
  88   {NULL, 0}
  89 };
  90
  91
  92 typedef enum
  93 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
  94   FORMATTED_DIRECT, UNFORMATTED_DIRECT
  95 }
  96 file_mode;
  97
  98
  99 static file_mode
 100 current_mode (st_parameter_dt *dtp)
 101 {
 102   file_mode m;
 103
 104   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 105     {
 106       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
 107         FORMATTED_DIRECT : UNFORMATTED_DIRECT;
 108     }
 109   else
 110     {
 111       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
 112         FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
 113     }
 114
 115   return m;
 116 }
 117
 118
 119 /* Mid level data transfer statements.  These subroutines do reading
 120    and writing in the style of salloc_r()/salloc_w() within the
 121    current record.  */
 122
 123 /* When reading sequential formatted records we have a problem.  We
 124    don't know how long the line is until we read the trailing newline,
 125    and we don't want to read too much.  If we read too much, we might
 126    have to do a physical seek backwards depending on how much data is
 127    present, and devices like terminals aren't seekable and would cause
 128    an I/O error.
 129
 130    Given this, the solution is to read a byte at a time, stopping if
 131    we hit the newline.  For small locations, we use a static buffer.
 132    For larger allocations, we are forced to allocate memory on the
 133    heap.  Hopefully this won't happen very often.  */
 134
 135 char *
 136 read_sf (st_parameter_dt *dtp, int *length, int no_error)
 137 {
 138   char *base, *p, *q;
 139   int n, readlen, crlf;
 140   gfc_offset pos;
 141
 142   if (*length > SCRATCH_SIZE)
 143     dtp->u.p.line_buffer = get_mem (*length);
 144   p = base = dtp->u.p.line_buffer;
 145
 146   /* If we have seen an eor previously, return a length of 0.  The
 147      caller is responsible for correctly padding the input field.  */
 148   if (dtp->u.p.sf_seen_eor)
 149     {
 150       *length = 0;
 151       return base;
 152     }
 153
 154   readlen = 1;
 155   n = 0;
 156
 157   do
 158     {
 159       if (is_internal_unit (dtp))
 160         {
 161           /* readlen may be modified inside salloc_r if
 162              is_internal_unit (dtp) is true.  */
 163           readlen = 1;
 164         }
 165
 166       q = salloc_r (dtp->u.p.current_unit->s, &readlen);
 167       if (q == NULL)
 168         break;
 169
 170       /* If we have a line without a terminating \n, drop through to
 171          EOR below.  */
 172       if (readlen < 1 && n == 0)
 173         {
 174           if (no_error)
 175             break;
 176           generate_error (&dtp->common, ERROR_END, NULL);
 177           return NULL;
 178         }
 179
 180       if (readlen < 1 || *q == '\n' || *q == '\r')
 181         {
 182           /* Unexpected end of line.  */
 183
 184           /* If we see an EOR during non-advancing I/O, we need to skip
 185              the rest of the I/O statement.  Set the corresponding flag.  */
 186           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
 187             dtp->u.p.eor_condition = 1;
 188
 189           crlf = 0;
 190           /* If we encounter a CR, it might be a CRLF.  */
 191           if (*q == '\r') /* Probably a CRLF */
 192             {
 193               readlen = 1;
 194               pos = stream_offset (dtp->u.p.current_unit->s);
 195               q = salloc_r (dtp->u.p.current_unit->s, &readlen);
 196               if (*q != '\n' && readlen == 1) /* Not a CRLF after all.  */
 197                 sseek (dtp->u.p.current_unit->s, pos);
 198               else
 199                 crlf = 1;
 200             }
 201
 202           /* Without padding, terminate the I/O statement without assigning
 203              the value.  With padding, the value still needs to be assigned,
 204              so we can just continue with a short read.  */
 205           if (dtp->u.p.current_unit->flags.pad == PAD_NO)
 206             {
 207               if (no_error)
 208                 break;
 209               generate_error (&dtp->common, ERROR_EOR, NULL);
 210               return NULL;
 211             }
 212
 213           *length = n;
 214           dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
 215           break;
 216         }
 217       /*  Short circuit the read if a comma is found during numeric input.
 218           The flag is set to zero during character reads so that commas in
 219           strings are not ignored  */
 220       if (*q == ',')
 221         if (dtp->u.p.sf_read_comma == 1)
 222           {
 223             notify_std (GFC_STD_GNU, "Comma in formatted numeric read.");
 224             *length = n;
 225             break;
 226           }
 227
 228       n++;
 229       *p++ = *q;
 230       dtp->u.p.sf_seen_eor = 0;
 231     }
 232   while (n < *length);
 233   dtp->u.p.current_unit->bytes_left -= *length;
 234
 235   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 236     dtp->u.p.size_used += (gfc_offset) *length;
 237
 238   return base;
 239 }
 240
 241
 242 /* Function for reading the next couple of bytes from the current
 243    file, advancing the current position.  We return a pointer to a
 244    buffer containing the bytes.  We return NULL on end of record or
 245    end of file.
 246
 247    If the read is short, then it is because the current record does not
 248    have enough data to satisfy the read request and the file was
 249    opened with PAD=YES.  The caller must assume tailing spaces for
 250    short reads.  */
 251
 252 void *
 253 read_block (st_parameter_dt *dtp, int *length)
 254 {
 255   char *source;
 256   int nread;
 257
 258   if (dtp->u.p.current_unit->bytes_left < *length)
 259     {
 260       if (dtp->u.p.current_unit->flags.pad == PAD_NO)
 261         {
 262           generate_error (&dtp->common, ERROR_EOR, NULL);
 263           /* Not enough data left.  */
 264           return NULL;
 265         }
 266
 267       *length = dtp->u.p.current_unit->bytes_left;
 268     }
 269
 270   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
 271       dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
 272     return read_sf (dtp, length, 0);    /* Special case.  */
 273
 274   dtp->u.p.current_unit->bytes_left -= *length;
 275
 276   nread = *length;
 277   source = salloc_r (dtp->u.p.current_unit->s, &nread);
 278
 279   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 280     dtp->u.p.size_used += (gfc_offset) nread;
 281
 282   if (nread != *length)
 283     {                           /* Short read, this shouldn't happen.  */
 284       if (dtp->u.p.current_unit->flags.pad == PAD_YES)
 285         *length = nread;
 286       else
 287         {
 288           generate_error (&dtp->common, ERROR_EOR, NULL);
 289           source = NULL;
 290         }
 291     }
 292
 293   return source;
 294 }
 295
 296
 297 /* Reads a block directly into application data space.  */
 298
 299 static void
 300 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 301 {
 302   int *length;
 303   void *data;
 304   size_t nread;
 305
 306   if (dtp->u.p.current_unit->bytes_left < *nbytes)
 307     {
 308       if (dtp->u.p.current_unit->flags.pad == PAD_NO)
 309         {
 310           /* Not enough data left.  */
 311           generate_error (&dtp->common, ERROR_EOR, NULL);
 312           return;
 313         }
 314
 315       *nbytes = dtp->u.p.current_unit->bytes_left;
 316     }
 317
 318   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
 319       dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
 320     {
 321       length = (int *) nbytes;
 322       data = read_sf (dtp, length, 0);  /* Special case.  */
 323       memcpy (buf, data, (size_t) *length);
 324       return;
 325     }
 326
 327   dtp->u.p.current_unit->bytes_left -= *nbytes;
 328
 329   nread = *nbytes;
 330   if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
 331     {
 332       generate_error (&dtp->common, ERROR_OS, NULL);
 333       return;
 334     }
 335
 336   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 337     dtp->u.p.size_used += (gfc_offset) nread;
 338
 339   if (nread != *nbytes)
 340     {                           /* Short read, e.g. if we hit EOF.  */
 341       if (dtp->u.p.current_unit->flags.pad == PAD_YES)
 342         {
 343           memset (((char *) buf) + nread, ' ', *nbytes - nread);
 344           *nbytes = nread;
 345         }
 346       else
 347         generate_error (&dtp->common, ERROR_EOR, NULL);
 348     }
 349 }
 350
 351
 352 /* Function for writing a block of bytes to the current file at the
 353    current position, advancing the file pointer. We are given a length
 354    and return a pointer to a buffer that the caller must (completely)
 355    fill in.  Returns NULL on error.  */
 356
 357 void *
 358 write_block (st_parameter_dt *dtp, int length)
 359 {
 360   char *dest;
 361
 362   if (dtp->u.p.current_unit->bytes_left < length)
 363     {
 364       generate_error (&dtp->common, ERROR_EOR, NULL);
 365       return NULL;
 366     }
 367
 368   dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
 369   dest = salloc_w (dtp->u.p.current_unit->s, &length);
 370
 371   if (dest == NULL)
 372     {
 373       generate_error (&dtp->common, ERROR_END, NULL);
 374       return NULL;
 375     }
 376
 377   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 378     dtp->u.p.size_used += (gfc_offset) length;
 379
 380   return dest;
 381 }
 382
 383
 384 /* High level interface to swrite(), taking care of errors.  */
 385
 386 static try
 387 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 388 {
 389   if (dtp->u.p.current_unit->bytes_left < nbytes)
 390     {
 391       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 392         generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
 393       else
 394         generate_error (&dtp->common, ERROR_EOR, NULL);
 395       return FAILURE;
 396     }
 397
 398   dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
 399
 400   if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
 401     {
 402       generate_error (&dtp->common, ERROR_OS, NULL);
 403       return FAILURE;
 404     }
 405
 406   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
 407     dtp->u.p.size_used += (gfc_offset) nbytes;
 408
 409   return SUCCESS;
 410 }
 411
 412
 413 /* Master function for unformatted reads.  */
 414
 415 static void
 416 unformatted_read (st_parameter_dt *dtp, bt type,
 417                   void *dest, int kind,
 418                   size_t size, size_t nelems)
 419 {
 420   /* Currently, character implies size=1.  */
 421   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
 422       || size == 1 || type == BT_CHARACTER)
 423     {
 424       size *= nelems;
 425       read_block_direct (dtp, dest, &size);
 426     }
 427   else
 428     {
 429       char buffer[16];
 430       char *p;
 431       size_t i, sz;
 432
 433       /* Break up complex into its constituent reals.  */
 434       if (type == BT_COMPLEX)
 435         {
 436           nelems *= 2;
 437           size /= 2;
 438         }
 439       p = dest;
 440
 441       /* By now, all complex variables have been split into their
 442          constituent reals.  For types with padding, we only need to
 443          read kind bytes.  We don't care about the contents
 444          of the padding.  */
 445
 446       sz = kind;
 447       for (i=0; i<nelems; i++)
 448         {
 449           read_block_direct (dtp, buffer, &sz);
 450           reverse_memcpy (p, buffer, sz);
 451           p += size;
 452         }
 453     }
 454 }
 455
 456
 457 /* Master function for unformatted writes.  */
 458
 459 static void
 460 unformatted_write (st_parameter_dt *dtp, bt type,
 461                    void *source, int kind,
 462                    size_t size, size_t nelems)
 463 {
 464   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
 465       size == 1 || type == BT_CHARACTER)
 466     {
 467       size *= nelems;
 468
 469       write_buf (dtp, source, size);
 470     }
 471   else
 472     {
 473       char buffer[16];
 474       char *p;
 475       size_t i, sz;
 476
 477       /* Break up complex into its constituent reals.  */
 478       if (type == BT_COMPLEX)
 479         {
 480           nelems *= 2;
 481           size /= 2;
 482         }
 483
 484       p = source;
 485
 486       /* By now, all complex variables have been split into their
 487          constituent reals.  For types with padding, we only need to
 488          read kind bytes.  We don't care about the contents
 489          of the padding.  */
 490
 491       sz = kind;
 492       for (i=0; i<nelems; i++)
 493         {
 494           reverse_memcpy(buffer, p, size);
 495           p+= size;
 496           write_buf (dtp, buffer, sz);
 497         }
 498     }
 499 }
 500
 501
 502 /* Return a pointer to the name of a type.  */
 503
 504 const char *
 505 type_name (bt type)
 506 {
 507   const char *p;
 508
 509   switch (type)
 510     {
 511     case BT_INTEGER:
 512       p = "INTEGER";
 513       break;
 514     case BT_LOGICAL:
 515       p = "LOGICAL";
 516       break;
 517     case BT_CHARACTER:
 518       p = "CHARACTER";
 519       break;
 520     case BT_REAL:
 521       p = "REAL";
 522       break;
 523     case BT_COMPLEX:
 524       p = "COMPLEX";
 525       break;
 526     default:
 527       internal_error (NULL, "type_name(): Bad type");
 528     }
 529
 530   return p;
 531 }
 532
 533
 534 /* Write a constant string to the output.
 535    This is complicated because the string can have doubled delimiters
 536    in it.  The length in the format node is the true length.  */
 537
 538 static void
 539 write_constant_string (st_parameter_dt *dtp, const fnode *f)
 540 {
 541   char c, delimiter, *p, *q;
 542   int length;
 543
 544   length = f->u.string.length;
 545   if (length == 0)
 546     return;
 547
 548   p = write_block (dtp, length);
 549   if (p == NULL)
 550     return;
 551
 552   q = f->u.string.p;
 553   delimiter = q[-1];
 554
 555   for (; length > 0; length--)
 556     {
 557       c = *p++ = *q++;
 558       if (c == delimiter && c != 'H' && c != 'h')
 559         q++;                    /* Skip the doubled delimiter.  */
 560     }
 561 }
 562
 563
 564 /* Given actual and expected types in a formatted data transfer, make
 565    sure they agree.  If not, an error message is generated.  Returns
 566    nonzero if something went wrong.  */
 567
 568 static int
 569 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
 570 {
 571   char buffer[100];
 572
 573   if (actual == expected)
 574     return 0;
 575
 576   st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
 577               type_name (expected), dtp->u.p.item_count, type_name (actual));
 578
 579   format_error (dtp, f, buffer);
 580   return 1;
 581 }
 582
 583
 584 /* This subroutine is the main loop for a formatted data transfer
 585    statement.  It would be natural to implement this as a coroutine
 586    with the user program, but C makes that awkward.  We loop,
 587    processesing format elements.  When we actually have to transfer
 588    data instead of just setting flags, we return control to the user
 589    program which calls a subroutine that supplies the address and type
 590    of the next element, then comes back here to process it.  */
 591
 592 static void
 593 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 594                            size_t size)
 595 {
 596   char scratch[SCRATCH_SIZE];
 597   int pos, bytes_used;
 598   const fnode *f;
 599   format_token t;
 600   int n;
 601   int consume_data_flag;
 602
 603   /* Change a complex data item into a pair of reals.  */
 604
 605   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
 606   if (type == BT_COMPLEX)
 607     {
 608       type = BT_REAL;
 609       size /= 2;
 610     }
 611
 612   /* If there's an EOR condition, we simulate finalizing the transfer
 613      by doing nothing.  */
 614   if (dtp->u.p.eor_condition)
 615     return;
 616
 617   /* Set this flag so that commas in reads cause the read to complete before
 618      the entire field has been read.  The next read field will start right after
 619      the comma in the stream.  (Set to 0 for character reads).  */
 620   dtp->u.p.sf_read_comma = 1;
 621
 622   dtp->u.p.line_buffer = scratch;
 623   for (;;)
 624     {
 625       /* If reversion has occurred and there is another real data item,
 626          then we have to move to the next record.  */
 627       if (dtp->u.p.reversion_flag && n > 0)
 628         {
 629           dtp->u.p.reversion_flag = 0;
 630           next_record (dtp, 0);
 631         }
 632
 633       consume_data_flag = 1 ;
 634       if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
 635         break;
 636
 637       f = next_format (dtp);
 638       if (f == NULL)
 639         return;       /* No data descriptors left (already raised).  */
 640
 641       /* Now discharge T, TR and X movements to the right.  This is delayed
 642          until a data producing format to suppress trailing spaces.  */
 643
 644       t = f->format;
 645       if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
 646         && ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
 647                     || t == FMT_Z  || t == FMT_F  || t == FMT_E
 648                     || t == FMT_EN || t == FMT_ES || t == FMT_G
 649                     || t == FMT_L  || t == FMT_A  || t == FMT_D))
 650             || t == FMT_STRING))
 651         {
 652           if (dtp->u.p.skips > 0)
 653             {
 654               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
 655               dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
 656                                        - dtp->u.p.current_unit->bytes_left);
 657             }
 658           if (dtp->u.p.skips < 0)
 659             {
 660               move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
 661               dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
 662             }
 663           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
 664         }
 665
 666       bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
 667
 668       switch (t)
 669         {
 670         case FMT_I:
 671           if (n == 0)
 672             goto need_data;
 673           if (require_type (dtp, BT_INTEGER, type, f))
 674             return;
 675
 676           if (dtp->u.p.mode == READING)
 677             read_decimal (dtp, f, p, len);
 678           else
 679             write_i (dtp, f, p, len);
 680
 681           break;
 682
 683         case FMT_B:
 684           if (n == 0)
 685             goto need_data;
 686           if (require_type (dtp, BT_INTEGER, type, f))
 687             return;
 688
 689           if (dtp->u.p.mode == READING)
 690             read_radix (dtp, f, p, len, 2);
 691           else
 692             write_b (dtp, f, p, len);
 693
 694           break;
 695
 696         case FMT_O:
 697           if (n == 0)
 698             goto need_data;
 699
 700           if (dtp->u.p.mode == READING)
 701             read_radix (dtp, f, p, len, 8);
 702           else
 703             write_o (dtp, f, p, len);
 704
 705           break;
 706
 707         case FMT_Z:
 708           if (n == 0)
 709             goto need_data;
 710
 711           if (dtp->u.p.mode == READING)
 712             read_radix (dtp, f, p, len, 16);
 713           else
 714             write_z (dtp, f, p, len);
 715
 716           break;
 717
 718         case FMT_A:
 719           if (n == 0)
 720             goto need_data;
 721
 722           if (dtp->u.p.mode == READING)
 723             read_a (dtp, f, p, len);
 724           else
 725             write_a (dtp, f, p, len);
 726
 727           break;
 728
 729         case FMT_L:
 730           if (n == 0)
 731             goto need_data;
 732
 733           if (dtp->u.p.mode == READING)
 734             read_l (dtp, f, p, len);
 735           else
 736             write_l (dtp, f, p, len);
 737
 738           break;
 739
 740         case FMT_D:
 741           if (n == 0)
 742             goto need_data;
 743           if (require_type (dtp, BT_REAL, type, f))
 744             return;
 745
 746           if (dtp->u.p.mode == READING)
 747             read_f (dtp, f, p, len);
 748           else
 749             write_d (dtp, f, p, len);
 750
 751           break;
 752
 753         case FMT_E:
 754           if (n == 0)
 755             goto need_data;
 756           if (require_type (dtp, BT_REAL, type, f))
 757             return;
 758
 759           if (dtp->u.p.mode == READING)
 760             read_f (dtp, f, p, len);
 761           else
 762             write_e (dtp, f, p, len);
 763           break;
 764
 765         case FMT_EN:
 766           if (n == 0)
 767             goto need_data;
 768           if (require_type (dtp, BT_REAL, type, f))
 769             return;
 770
 771           if (dtp->u.p.mode == READING)
 772             read_f (dtp, f, p, len);
 773           else
 774             write_en (dtp, f, p, len);
 775
 776           break;
 777
 778         case FMT_ES:
 779           if (n == 0)
 780             goto need_data;
 781           if (require_type (dtp, BT_REAL, type, f))
 782             return;
 783
 784           if (dtp->u.p.mode == READING)
 785             read_f (dtp, f, p, len);
 786           else
 787             write_es (dtp, f, p, len);
 788
 789           break;
 790
 791         case FMT_F:
 792           if (n == 0)
 793             goto need_data;
 794           if (require_type (dtp, BT_REAL, type, f))
 795             return;
 796
 797           if (dtp->u.p.mode == READING)
 798             read_f (dtp, f, p, len);
 799           else
 800             write_f (dtp, f, p, len);
 801
 802           break;
 803
 804         case FMT_G:
 805           if (n == 0)
 806             goto need_data;
 807           if (dtp->u.p.mode == READING)
 808             switch (type)
 809               {
 810               case BT_INTEGER:
 811                 read_decimal (dtp, f, p, len);
 812                 break;
 813               case BT_LOGICAL:
 814                 read_l (dtp, f, p, len);
 815                 break;
 816               case BT_CHARACTER:
 817                 read_a (dtp, f, p, len);
 818                 break;
 819               case BT_REAL:
 820                 read_f (dtp, f, p, len);
 821                 break;
 822               default:
 823                 goto bad_type;
 824               }
 825           else
 826             switch (type)
 827               {
 828               case BT_INTEGER:
 829                 write_i (dtp, f, p, len);
 830                 break;
 831               case BT_LOGICAL:
 832                 write_l (dtp, f, p, len);
 833                 break;
 834               case BT_CHARACTER:
 835                 write_a (dtp, f, p, len);
 836                 break;
 837               case BT_REAL:
 838                 write_d (dtp, f, p, len);
 839                 break;
 840               default:
 841               bad_type:
 842                 internal_error (&dtp->common,
 843                                 "formatted_transfer(): Bad type");
 844               }
 845
 846           break;
 847
 848         case FMT_STRING:
 849           consume_data_flag = 0 ;
 850           if (dtp->u.p.mode == READING)
 851             {
 852               format_error (dtp, f, "Constant string in input format");
 853               return;
 854             }
 855           write_constant_string (dtp, f);
 856           break;
 857
 858         /* Format codes that don't transfer data.  */
 859         case FMT_X:
 860         case FMT_TR:
 861           consume_data_flag = 0 ;
 862
 863           pos = bytes_used + f->u.n + dtp->u.p.skips;
 864           dtp->u.p.skips = f->u.n + dtp->u.p.skips;
 865           dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
 866
 867           /* Writes occur just before the switch on f->format, above, so
 868              that trailing blanks are suppressed, unless we are doing a
 869              non-advancing write in which case we want to output the blanks
 870              now.  */
 871           if (dtp->u.p.mode == WRITING
 872               && dtp->u.p.advance_status == ADVANCE_NO)
 873             {
 874               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
 875               dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
 876             }
 877           if (dtp->u.p.mode == READING)
 878             read_x (dtp, f->u.n);
 879
 880           break;
 881
 882         case FMT_TL:
 883         case FMT_T:
 884           if (f->format == FMT_TL)
 885             {
 886
 887               /* Handle the special case when no bytes have been used yet.
 888                  Cannot go below zero. */
 889               if (bytes_used == 0)
 890                 {
 891                   dtp->u.p.pending_spaces -= f->u.n;
 892                   dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
 893                                             : dtp->u.p.pending_spaces;
 894                   dtp->u.p.skips -= f->u.n;
 895                   dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
 896                 }
 897
 898               pos = bytes_used - f->u.n;
 899             }
 900           else /* FMT_T */
 901             {
 902               consume_data_flag = 0;
 903               pos = f->u.n - 1;
 904             }
 905
 906           /* Standard 10.6.1.1: excessive left tabbing is reset to the
 907              left tab limit.  We do not check if the position has gone
 908              beyond the end of record because a subsequent tab could
 909              bring us back again.  */
 910           pos = pos < 0 ? 0 : pos;
 911
 912           dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
 913           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
 914                                     + pos - dtp->u.p.max_pos;
 915
 916           if (dtp->u.p.skips == 0)
 917             break;
 918
 919           /* Writes occur just before the switch on f->format, above, so that
 920              trailing blanks are suppressed.  */
 921           if (dtp->u.p.mode == READING)
 922             {
 923               /* Adjust everything for end-of-record condition */
 924               if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
 925                 {
 926                   if (dtp->u.p.sf_seen_eor == 2)
 927                     {
 928                       /* The EOR was a CRLF (two bytes wide).  */
 929                       dtp->u.p.current_unit->bytes_left -= 2;
 930                       dtp->u.p.skips -= 2;
 931                     }
 932                   else
 933                     {
 934                       /* The EOR marker was only one byte wide.  */
 935                       dtp->u.p.current_unit->bytes_left--;
 936                       dtp->u.p.skips--;
 937                     }
 938                   bytes_used = pos;
 939                   dtp->u.p.sf_seen_eor = 0;
 940                 }
 941               if (dtp->u.p.skips < 0)
 942                 {
 943                   move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
 944                   dtp->u.p.current_unit->bytes_left
 945                     -= (gfc_offset) dtp->u.p.skips;
 946                   dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
 947                 }
 948               else
 949                 read_x (dtp, dtp->u.p.skips);
 950             }
 951
 952           break;
 953
 954         case FMT_S:
 955           consume_data_flag = 0 ;
 956           dtp->u.p.sign_status = SIGN_S;
 957           break;
 958
 959         case FMT_SS:
 960           consume_data_flag = 0 ;
 961           dtp->u.p.sign_status = SIGN_SS;
 962           break;
 963
 964         case FMT_SP:
 965           consume_data_flag = 0 ;
 966           dtp->u.p.sign_status = SIGN_SP;
 967           break;
 968
 969         case FMT_BN:
 970           consume_data_flag = 0 ;
 971           dtp->u.p.blank_status = BLANK_NULL;
 972           break;
 973
 974         case FMT_BZ:
 975           consume_data_flag = 0 ;
 976           dtp->u.p.blank_status = BLANK_ZERO;
 977           break;
 978
 979         case FMT_P:
 980           consume_data_flag = 0 ;
 981           dtp->u.p.scale_factor = f->u.k;
 982           break;
 983
 984         case FMT_DOLLAR:
 985           consume_data_flag = 0 ;
 986           dtp->u.p.seen_dollar = 1;
 987           break;
 988
 989         case FMT_SLASH:
 990           consume_data_flag = 0 ;
 991           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
 992           next_record (dtp, 0);
 993           break;
 994
 995         case FMT_COLON:
 996           /* A colon descriptor causes us to exit this loop (in
 997              particular preventing another / descriptor from being
 998              processed) unless there is another data item to be
 999              transferred.  */
1000           consume_data_flag = 0 ;
1001           if (n == 0)
1002             return;
1003           break;
1004
1005         default:
1006           internal_error (&dtp->common, "Bad format node");
1007         }
1008
1009       /* Free a buffer that we had to allocate during a sequential
1010          formatted read of a block that was larger than the static
1011          buffer.  */
1012
1013       if (dtp->u.p.line_buffer != scratch)
1014         {
1015           free_mem (dtp->u.p.line_buffer);
1016           dtp->u.p.line_buffer = scratch;
1017         }
1018
1019       /* Adjust the item count and data pointer.  */
1020
1021       if ((consume_data_flag > 0) && (n > 0))
1022       {
1023         n--;
1024         p = ((char *) p) + size;
1025       }
1026
1027       if (dtp->u.p.mode == READING)
1028         dtp->u.p.skips = 0;
1029
1030       pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1031       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1032
1033     }
1034
1035   return;
1036
1037   /* Come here when we need a data descriptor but don't have one.  We
1038      push the current format node back onto the input, then return and
1039      let the user program call us back with the data.  */
1040  need_data:
1041   unget_format (dtp, f);
1042 }
1043
1044 static void
1045 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1046                     size_t size, size_t nelems)
1047 {
1048   size_t elem;
1049   char *tmp;
1050
1051   tmp = (char *) p;
1052
1053   /* Big loop over all the elements.  */
1054   for (elem = 0; elem < nelems; elem++)
1055     {
1056       dtp->u.p.item_count++;
1057       formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1058     }
1059 }
1060
1061
1062
1063 /* Data transfer entry points.  The type of the data entity is
1064    implicit in the subroutine call.  This prevents us from having to
1065    share a common enum with the compiler.  */
1066
1067 void
1068 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1069 {
1070   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1071     return;
1072   dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1073 }
1074
1075
1076 void
1077 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1078 {
1079   size_t size;
1080   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1081     return;
1082   size = size_from_real_kind (kind);
1083   dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1084 }
1085
1086
1087 void
1088 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1089 {
1090   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1091     return;
1092   dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1093 }
1094
1095
1096 void
1097 transfer_character (st_parameter_dt *dtp, void *p, int len)
1098 {
1099   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1100     return;
1101   /* Currently we support only 1 byte chars, and the library is a bit
1102      confused of character kind vs. length, so we kludge it by setting
1103      kind = length.  */
1104   dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1105 }
1106
1107
1108 void
1109 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1110 {
1111   size_t size;
1112   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1113     return;
1114   size = size_from_complex_kind (kind);
1115   dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1116 }
1117
1118
1119 void
1120 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1121                 gfc_charlen_type charlen)
1122 {
1123   index_type count[GFC_MAX_DIMENSIONS];
1124   index_type extent[GFC_MAX_DIMENSIONS];
1125   index_type stride[GFC_MAX_DIMENSIONS];
1126   index_type stride0, rank, size, type, n;
1127   size_t tsize;
1128   char *data;
1129   bt iotype;
1130
1131   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1132     return;
1133
1134   type = GFC_DESCRIPTOR_TYPE (desc);
1135   size = GFC_DESCRIPTOR_SIZE (desc);
1136
1137   /* FIXME: What a kludge: Array descriptors and the IO library use
1138      different enums for types.  */
1139   switch (type)
1140     {
1141     case GFC_DTYPE_UNKNOWN:
1142       iotype = BT_NULL;  /* Is this correct?  */
1143       break;
1144     case GFC_DTYPE_INTEGER:
1145       iotype = BT_INTEGER;
1146       break;
1147     case GFC_DTYPE_LOGICAL:
1148       iotype = BT_LOGICAL;
1149       break;
1150     case GFC_DTYPE_REAL:
1151       iotype = BT_REAL;
1152       break;
1153     case GFC_DTYPE_COMPLEX:
1154       iotype = BT_COMPLEX;
1155       break;
1156     case GFC_DTYPE_CHARACTER:
1157       iotype = BT_CHARACTER;
1158       /* FIXME: Currently dtype contains the charlen, which is
1159          clobbered if charlen > 2**24. That's why we use a separate
1160          argument for the charlen. However, if we want to support
1161          non-8-bit charsets we need to fix dtype to contain
1162          sizeof(chartype) and fix the code below.  */
1163       size = charlen;
1164       kind = charlen;
1165       break;
1166     case GFC_DTYPE_DERIVED:
1167       internal_error (&dtp->common,
1168                 "Derived type I/O should have been handled via the frontend.");
1169       break;
1170     default:
1171       internal_error (&dtp->common, "transfer_array(): Bad type");
1172     }
1173
1174   if (desc->dim[0].stride == 0)
1175     desc->dim[0].stride = 1;
1176
1177   rank = GFC_DESCRIPTOR_RANK (desc);
1178   for (n = 0; n < rank; n++)
1179     {
1180       count[n] = 0;
1181       stride[n] = desc->dim[n].stride;
1182       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1183
1184       /* If the extent of even one dimension is zero, then the entire
1185          array section contains zero elements, so we return.  */
1186       if (extent[n] == 0)
1187         return;
1188     }
1189
1190   stride0 = stride[0];
1191
1192   /* If the innermost dimension has stride 1, we can do the transfer
1193      in contiguous chunks.  */
1194   if (stride0 == 1)
1195     tsize = extent[0];
1196   else
1197     tsize = 1;
1198
1199   data = GFC_DESCRIPTOR_DATA (desc);
1200
1201   while (data)
1202     {
1203       dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1204       data += stride0 * size * tsize;
1205       count[0] += tsize;
1206       n = 0;
1207       while (count[n] == extent[n])
1208         {
1209           count[n] = 0;
1210           data -= stride[n] * extent[n] * size;
1211           n++;
1212           if (n == rank)
1213             {
1214               data = NULL;
1215               break;
1216             }
1217           else
1218             {
1219               count[n]++;
1220               data += stride[n] * size;
1221             }
1222         }
1223     }
1224 }
1225
1226
1227 /* Preposition a sequential unformatted file while reading.  */
1228
1229 static void
1230 us_read (st_parameter_dt *dtp)
1231 {
1232   char *p;
1233   int n;
1234   int nr;
1235   GFC_INTEGER_4 i4;
1236   GFC_INTEGER_8 i8;
1237   gfc_offset i;
1238
1239   if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1240     return;
1241
1242   if (compile_options.record_marker == 0)
1243     n = sizeof (gfc_offset);
1244   else
1245     n = compile_options.record_marker;
1246
1247   nr = n;
1248
1249   p = salloc_r (dtp->u.p.current_unit->s, &n);
1250
1251   if (n == 0)
1252     {
1253       dtp->u.p.current_unit->endfile = AT_ENDFILE;
1254       return;  /* end of file */
1255     }
1256
1257   if (p == NULL || n != nr)
1258     {
1259       generate_error (&dtp->common, ERROR_BAD_US, NULL);
1260       return;
1261     }
1262
1263   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
1264   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1265     {
1266       switch (compile_options.record_marker)
1267         {
1268         case 0:
1269           memcpy (&i, p, sizeof(gfc_offset));
1270           break;
1271
1272         case sizeof(GFC_INTEGER_4):
1273           memcpy (&i4, p, sizeof (i4));
1274           i = i4;
1275           break;
1276
1277         case sizeof(GFC_INTEGER_8):
1278           memcpy (&i8, p, sizeof (i8));
1279           i = i8;
1280           break;
1281
1282         default:
1283           runtime_error ("Illegal value for record marker");
1284           break;
1285         }
1286     }
1287   else
1288       switch (compile_options.record_marker)
1289         {
1290         case 0:
1291           reverse_memcpy (&i, p, sizeof(gfc_offset));
1292           break;
1293
1294         case sizeof(GFC_INTEGER_4):
1295           reverse_memcpy (&i4, p, sizeof (i4));
1296           i = i4;
1297           break;
1298
1299         case sizeof(GFC_INTEGER_8):
1300           reverse_memcpy (&i8, p, sizeof (i8));
1301           i = i8;
1302           break;
1303
1304         default:
1305           runtime_error ("Illegal value for record marker");
1306           break;
1307         }
1308
1309   dtp->u.p.current_unit->bytes_left = i;
1310 }
1311
1312
1313 /* Preposition a sequential unformatted file while writing.  This
1314    amount to writing a bogus length that will be filled in later.  */
1315
1316 static void
1317 us_write (st_parameter_dt *dtp)
1318 {
1319   size_t nbytes;
1320   gfc_offset dummy;
1321
1322   dummy = 0;
1323
1324   if (compile_options.record_marker == 0)
1325     nbytes = sizeof (gfc_offset);
1326   else
1327     nbytes = compile_options.record_marker ;
1328
1329   if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1330     generate_error (&dtp->common, ERROR_OS, NULL);
1331
1332   /* For sequential unformatted, we write until we have more bytes
1333      than can fit in the record markers. If disk space runs out first,
1334      it will error on the write.  */
1335   dtp->u.p.current_unit->recl = max_offset;
1336
1337   dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1338 }
1339
1340
1341 /* Position to the next record prior to transfer.  We are assumed to
1342    be before the next record.  We also calculate the bytes in the next
1343    record.  */
1344
1345 static void
1346 pre_position (st_parameter_dt *dtp)
1347 {
1348   if (dtp->u.p.current_unit->current_record)
1349     return;                     /* Already positioned.  */
1350
1351   switch (current_mode (dtp))
1352     {
1353     case UNFORMATTED_SEQUENTIAL:
1354       if (dtp->u.p.mode == READING)
1355         us_read (dtp);
1356       else
1357         us_write (dtp);
1358
1359       break;
1360
1361     case FORMATTED_SEQUENTIAL:
1362     case FORMATTED_DIRECT:
1363     case UNFORMATTED_DIRECT:
1364       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1365       break;
1366     }
1367
1368   dtp->u.p.current_unit->current_record = 1;
1369 }
1370
1371
1372 /* Initialize things for a data transfer.  This code is common for
1373    both reading and writing.  */
1374
1375 static void
1376 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1377 {
1378   unit_flags u_flags;  /* Used for creating a unit if needed.  */
1379   GFC_INTEGER_4 cf = dtp->common.flags;
1380   namelist_info *ionml;
1381
1382   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1383   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1384   dtp->u.p.ionml = ionml;
1385   dtp->u.p.mode = read_flag ? READING : WRITING;
1386
1387   if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1388     dtp->u.p.size_used = 0;  /* Initialize the count.  */
1389
1390   dtp->u.p.current_unit = get_unit (dtp, 1);
1391   if (dtp->u.p.current_unit->s == NULL)
1392   {  /* Open the unit with some default flags.  */
1393      st_parameter_open opp;
1394      unit_convert conv;
1395
1396      if (dtp->common.unit < 0)
1397      {
1398        close_unit (dtp->u.p.current_unit);
1399        dtp->u.p.current_unit = NULL;
1400        generate_error (&dtp->common, ERROR_BAD_OPTION,
1401                        "Bad unit number in OPEN statement");
1402        return;
1403      }
1404      memset (&u_flags, '\0', sizeof (u_flags));
1405      u_flags.access = ACCESS_SEQUENTIAL;
1406      u_flags.action = ACTION_READWRITE;
1407
1408      /* Is it unformatted?  */
1409      if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1410                  | IOPARM_DT_IONML_SET)))
1411        u_flags.form = FORM_UNFORMATTED;
1412      else
1413        u_flags.form = FORM_UNSPECIFIED;
1414
1415      u_flags.delim = DELIM_UNSPECIFIED;
1416      u_flags.blank = BLANK_UNSPECIFIED;
1417      u_flags.pad = PAD_UNSPECIFIED;
1418      u_flags.status = STATUS_UNKNOWN;
1419
1420      conv = get_unformatted_convert (dtp->common.unit);
1421
1422      if (conv == CONVERT_NONE)
1423        conv = compile_options.convert;
1424
1425      /* We use l8_to_l4_offset, which is 0 on little-endian machines
1426         and 1 on big-endian machines.  */
1427      switch (conv)
1428        {
1429        case CONVERT_NATIVE:
1430        case CONVERT_SWAP:
1431          break;
1432
1433        case CONVERT_BIG:
1434          conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1435          break;
1436
1437        case CONVERT_LITTLE:
1438          conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1439          break;
1440
1441        default:
1442          internal_error (&opp.common, "Illegal value for CONVERT");
1443          break;
1444        }
1445
1446      u_flags.convert = conv;
1447
1448      opp.common = dtp->common;
1449      opp.common.flags &= IOPARM_COMMON_MASK;
1450      dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1451      dtp->common.flags &= ~IOPARM_COMMON_MASK;
1452      dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1453      if (dtp->u.p.current_unit == NULL)
1454        return;
1455   }
1456
1457   /* Check the action.  */
1458
1459   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1460     generate_error (&dtp->common, ERROR_BAD_ACTION,
1461                     "Cannot read from file opened for WRITE");
1462
1463   if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1464     generate_error (&dtp->common, ERROR_BAD_ACTION,
1465                     "Cannot write to file opened for READ");
1466
1467   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1468     return;
1469
1470   dtp->u.p.first_item = 1;
1471
1472   /* Check the format.  */
1473
1474   if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1475     parse_format (dtp);
1476
1477   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1478     return;
1479
1480   if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1481       && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1482          != 0)
1483     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1484                     "Format present for UNFORMATTED data transfer");
1485
1486   if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1487      {
1488         if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1489            generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1490                     "A format cannot be specified with a namelist");
1491      }
1492   else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1493            !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1494     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1495                     "Missing format for FORMATTED data transfer");
1496
1497
1498   if (is_internal_unit (dtp)
1499       && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1500     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1501                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1502
1503   /* Check the record number.  */
1504
1505   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1506       && (cf & IOPARM_DT_HAS_REC) == 0)
1507     {
1508       generate_error (&dtp->common, ERROR_MISSING_OPTION,
1509                       "Direct access data transfer requires record number");
1510       return;
1511     }
1512
1513   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1514       && (cf & IOPARM_DT_HAS_REC) != 0)
1515     {
1516       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1517                       "Record number not allowed for sequential access data transfer");
1518       return;
1519     }
1520
1521   /* Process the ADVANCE option.  */
1522
1523   dtp->u.p.advance_status
1524     = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1525       find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1526                    "Bad ADVANCE parameter in data transfer statement");
1527
1528   if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1529     {
1530       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1531         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1532                         "ADVANCE specification conflicts with sequential access");
1533
1534       if (is_internal_unit (dtp))
1535         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1536                         "ADVANCE specification conflicts with internal file");
1537
1538       if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1539           != IOPARM_DT_HAS_FORMAT)
1540         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1541                         "ADVANCE specification requires an explicit format");
1542     }
1543
1544   if (read_flag)
1545     {
1546       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1547         generate_error (&dtp->common, ERROR_MISSING_OPTION,
1548                         "EOR specification requires an ADVANCE specification of NO");
1549
1550       if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1551         generate_error (&dtp->common, ERROR_MISSING_OPTION,
1552                         "SIZE specification requires an ADVANCE specification of NO");
1553
1554     }
1555   else
1556     {                           /* Write constraints.  */
1557       if ((cf & IOPARM_END) != 0)
1558         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1559                         "END specification cannot appear in a write statement");
1560
1561       if ((cf & IOPARM_EOR) != 0)
1562         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1563                         "EOR specification cannot appear in a write statement");
1564
1565       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1566         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1567                         "SIZE specification cannot appear in a write statement");
1568     }
1569
1570   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1571     dtp->u.p.advance_status = ADVANCE_YES;
1572   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1573     return;
1574
1575   /* Sanity checks on the record number.  */
1576
1577   if ((cf & IOPARM_DT_HAS_REC) != 0)
1578     {
1579       if (dtp->rec <= 0)
1580         {
1581           generate_error (&dtp->common, ERROR_BAD_OPTION,
1582                           "Record number must be positive");
1583           return;
1584         }
1585
1586       if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1587         {
1588           generate_error (&dtp->common, ERROR_BAD_OPTION,
1589                           "Record number too large");
1590           return;
1591         }
1592
1593       /* Check to see if we might be reading what we wrote before  */
1594
1595       if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode  == WRITING)
1596          flush(dtp->u.p.current_unit->s);
1597
1598       /* Check whether the record exists to be read.  Only
1599          a partial record needs to exist.  */
1600
1601       if (dtp->u.p.mode == READING && (dtp->rec -1)
1602           * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1603         {
1604           generate_error (&dtp->common, ERROR_BAD_OPTION,
1605                           "Non-existing record number");
1606           return;
1607         }
1608
1609       /* Position the file.  */
1610       if (sseek (dtp->u.p.current_unit->s,
1611                (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE)
1612         {
1613           generate_error (&dtp->common, ERROR_OS, NULL);
1614           return;
1615         }
1616     }
1617
1618   /* Overwriting an existing sequential file ?
1619      it is always safe to truncate the file on the first write */
1620   if (dtp->u.p.mode == WRITING
1621       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1622       && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
1623         struncate(dtp->u.p.current_unit->s);
1624
1625   /* Bugware for badly written mixed C-Fortran I/O.  */
1626   flush_if_preconnected(dtp->u.p.current_unit->s);
1627
1628   dtp->u.p.current_unit->mode = dtp->u.p.mode;
1629
1630   /* Set the initial value of flags.  */
1631
1632   dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1633   dtp->u.p.sign_status = SIGN_S;
1634
1635   pre_position (dtp);
1636
1637   /* Set up the subroutine that will handle the transfers.  */
1638
1639   if (read_flag)
1640     {
1641       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1642         dtp->u.p.transfer = unformatted_read;
1643       else
1644         {
1645           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1646             dtp->u.p.transfer = list_formatted_read;
1647           else
1648             dtp->u.p.transfer = formatted_transfer;
1649         }
1650     }
1651   else
1652     {
1653       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1654         dtp->u.p.transfer = unformatted_write;
1655       else
1656         {
1657           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1658             dtp->u.p.transfer = list_formatted_write;
1659           else
1660             dtp->u.p.transfer = formatted_transfer;
1661         }
1662     }
1663
1664   /* Make sure that we don't do a read after a nonadvancing write.  */
1665
1666   if (read_flag)
1667     {
1668       if (dtp->u.p.current_unit->read_bad)
1669         {
1670           generate_error (&dtp->common, ERROR_BAD_OPTION,
1671                           "Cannot READ after a nonadvancing WRITE");
1672           return;
1673         }
1674     }
1675   else
1676     {
1677       if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1678         dtp->u.p.current_unit->read_bad = 1;
1679     }
1680
1681   /* Start the data transfer if we are doing a formatted transfer.  */
1682   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1683       && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1684       && dtp->u.p.ionml == NULL)
1685     formatted_transfer (dtp, 0, NULL, 0, 0, 1);
1686 }
1687
1688 /* Initialize an array_loop_spec given the array descriptor.  The function
1689    returns the index of the last element of the array.  */
1690
1691 gfc_offset
1692 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1693 {
1694   int rank = GFC_DESCRIPTOR_RANK(desc);
1695   int i;
1696   gfc_offset index;
1697
1698   index = 1;
1699   for (i=0; i<rank; i++)
1700     {
1701       ls[i].idx = 1;
1702       ls[i].start = desc->dim[i].lbound;
1703       ls[i].end = desc->dim[i].ubound;
1704       ls[i].step = desc->dim[i].stride;
1705
1706       index += (desc->dim[i].ubound - desc->dim[i].lbound)
1707                       * desc->dim[i].stride;
1708     }
1709   return index;
1710 }
1711
1712 /* Determine the index to the next record in an internal unit array by
1713    by incrementing through the array_loop_spec.  TODO:  Implement handling
1714    negative strides. */
1715
1716 gfc_offset
1717 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
1718 {
1719   int i, carry;
1720   gfc_offset index;
1721
1722   carry = 1;
1723   index = 0;
1724
1725   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
1726     {
1727       if (carry)
1728         {
1729           ls[i].idx++;
1730           if (ls[i].idx > ls[i].end)
1731             {
1732               ls[i].idx = ls[i].start;
1733               carry = 1;
1734             }
1735           else
1736             carry = 0;
1737         }
1738       index = index + (ls[i].idx - 1) * ls[i].step;
1739     }
1740   return index;
1741 }
1742
1743 /* Space to the next record for read mode.  If the file is not
1744    seekable, we read MAX_READ chunks until we get to the right
1745    position.  */
1746
1747 #define MAX_READ 4096
1748
1749 static void
1750 next_record_r (st_parameter_dt *dtp)
1751 {
1752   gfc_offset new, record;
1753   int bytes_left, rlength, length;
1754   char *p;
1755
1756   switch (current_mode (dtp))
1757     {
1758     case UNFORMATTED_SEQUENTIAL:
1759
1760       /* Skip over tail */
1761       dtp->u.p.current_unit->bytes_left +=
1762         compile_options.record_marker == 0 ?
1763         sizeof (gfc_offset) : compile_options.record_marker;
1764
1765       /* Fall through...  */
1766
1767     case FORMATTED_DIRECT:
1768     case UNFORMATTED_DIRECT:
1769       if (dtp->u.p.current_unit->bytes_left == 0)
1770         break;
1771
1772       if (is_seekable (dtp->u.p.current_unit->s))
1773         {
1774           new = file_position (dtp->u.p.current_unit->s)
1775                 + dtp->u.p.current_unit->bytes_left;
1776
1777           /* Direct access files do not generate END conditions,
1778              only I/O errors.  */
1779           if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1780             generate_error (&dtp->common, ERROR_OS, NULL);
1781
1782         }
1783       else
1784         {                       /* Seek by reading data.  */
1785           while (dtp->u.p.current_unit->bytes_left > 0)
1786             {
1787               rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1788                 MAX_READ : dtp->u.p.current_unit->bytes_left;
1789
1790               p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1791               if (p == NULL)
1792                 {
1793                   generate_error (&dtp->common, ERROR_OS, NULL);
1794                   break;
1795                 }
1796
1797               dtp->u.p.current_unit->bytes_left -= length;
1798             }
1799         }
1800       break;
1801
1802     case FORMATTED_SEQUENTIAL:
1803       length = 1;
1804       /* sf_read has already terminated input because of an '\n'  */
1805       if (dtp->u.p.sf_seen_eor)
1806         {
1807           dtp->u.p.sf_seen_eor = 0;
1808           break;
1809         }
1810
1811       if (is_internal_unit (dtp))
1812         {
1813           if (is_array_io (dtp))
1814             {
1815               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1816
1817               /* Now seek to this record.  */
1818               record = record * dtp->u.p.current_unit->recl;
1819               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1820                 {
1821                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
1822                   break;
1823                 }
1824               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1825             }
1826           else
1827             {
1828               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
1829               p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
1830               if (p != NULL)
1831                 dtp->u.p.current_unit->bytes_left
1832                   = dtp->u.p.current_unit->recl;
1833             }
1834           break;
1835         }
1836       else do
1837         {
1838           p = salloc_r (dtp->u.p.current_unit->s, &length);
1839
1840           if (p == NULL)
1841             {
1842               generate_error (&dtp->common, ERROR_OS, NULL);
1843               break;
1844             }
1845
1846           if (length == 0)
1847             {
1848               dtp->u.p.current_unit->endfile = AT_ENDFILE;
1849               break;
1850             }
1851         }
1852       while (*p != '\n');
1853
1854       break;
1855     }
1856
1857   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
1858     test_endfile (dtp->u.p.current_unit);
1859 }
1860
1861
1862 /* Small utility function to write a record marker, taking care of
1863    byte swapping and of choosing the correct size.  */
1864
1865 inline static int
1866 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
1867 {
1868   size_t len;
1869   GFC_INTEGER_4 buf4;
1870   GFC_INTEGER_8 buf8;
1871   char p[sizeof (GFC_INTEGER_8)];
1872
1873   if (compile_options.record_marker == 0)
1874     len = sizeof (gfc_offset);
1875   else
1876     len = compile_options.record_marker;
1877
1878   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
1879   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1880     {
1881       switch (compile_options.record_marker)
1882         {
1883         case 0:
1884           return swrite (dtp->u.p.current_unit->s, &buf, &len);
1885           break;
1886
1887         case sizeof (GFC_INTEGER_4):
1888           buf4 = buf;
1889           return swrite (dtp->u.p.current_unit->s, &buf4, &len);
1890           break;
1891
1892         case sizeof (GFC_INTEGER_8):
1893           buf8 = buf;
1894           return swrite (dtp->u.p.current_unit->s, &buf8, &len);
1895           break;
1896
1897         default:
1898           runtime_error ("Illegal value for record marker");
1899           break;
1900         }
1901     }
1902   else
1903     {
1904       switch (compile_options.record_marker)
1905         {
1906         case 0:
1907           reverse_memcpy (p, &buf, sizeof (gfc_offset));
1908           return swrite (dtp->u.p.current_unit->s, p, &len);
1909           break;
1910
1911         case sizeof (GFC_INTEGER_4):
1912           buf4 = buf;
1913           reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
1914           return swrite (dtp->u.p.current_unit->s, p, &len);
1915           break;
1916
1917         case sizeof (GFC_INTEGER_8):
1918           buf8 = buf;
1919           reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
1920           return swrite (dtp->u.p.current_unit->s, p, &len);
1921           break;
1922
1923         default:
1924           runtime_error ("Illegal value for record marker");
1925           break;
1926         }
1927     }
1928
1929 }
1930
1931
1932 /* Position to the next record in write mode.  */
1933
1934 static void
1935 next_record_w (st_parameter_dt *dtp, int done)
1936 {
1937   gfc_offset c, m, record, max_pos;
1938   int length;
1939   char *p;
1940   size_t record_marker;
1941
1942   /* Zero counters for X- and T-editing.  */
1943   max_pos = dtp->u.p.max_pos;
1944   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1945
1946   switch (current_mode (dtp))
1947     {
1948     case FORMATTED_DIRECT:
1949       if (dtp->u.p.current_unit->bytes_left == 0)
1950         break;
1951
1952       if (sset (dtp->u.p.current_unit->s, ' ',
1953                 dtp->u.p.current_unit->bytes_left) == FAILURE)
1954         goto io_error;
1955
1956       break;
1957
1958     case UNFORMATTED_DIRECT:
1959       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
1960         goto io_error;
1961       break;
1962
1963     case UNFORMATTED_SEQUENTIAL:
1964       /* Bytes written.  */
1965       m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
1966       c = file_position (dtp->u.p.current_unit->s);
1967
1968       /* Write the length tail.  */
1969
1970       if (write_us_marker (dtp, m) != 0)
1971         goto io_error;
1972
1973       if (compile_options.record_marker == 4)
1974         record_marker = sizeof(GFC_INTEGER_4);
1975       else
1976         record_marker = sizeof (gfc_offset);
1977
1978       /* Seek to the head and overwrite the bogus length with the real
1979          length.  */
1980
1981       if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
1982           == FAILURE)
1983         goto io_error;
1984
1985       if (write_us_marker (dtp, m) != 0)
1986         goto io_error;
1987
1988       /* Seek past the end of the current record.  */
1989
1990       if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
1991         goto io_error;
1992
1993       break;
1994
1995     case FORMATTED_SEQUENTIAL:
1996
1997       if (dtp->u.p.current_unit->bytes_left == 0)
1998         break;
1999
2000       if (is_internal_unit (dtp))
2001         {
2002           if (is_array_io (dtp))
2003             {
2004               length = (int) dtp->u.p.current_unit->bytes_left;
2005
2006               /* If the farthest position reached is greater than current
2007               position, adjust the position and set length to pad out
2008               whats left.  Otherwise just pad whats left.
2009               (for character array unit) */
2010               m = dtp->u.p.current_unit->recl
2011                         - dtp->u.p.current_unit->bytes_left;
2012               if (max_pos > m)
2013                 {
2014                   length = (int) (max_pos - m);
2015                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2016                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
2017                 }
2018
2019               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2020                 {
2021                   generate_error (&dtp->common, ERROR_END, NULL);
2022                   return;
2023                 }
2024
2025               /* Now that the current record has been padded out,
2026                  determine where the next record in the array is. */
2027               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2028
2029               /* Now seek to this record */
2030               record = record * dtp->u.p.current_unit->recl;
2031
2032               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2033                 {
2034                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2035                   return;
2036                 }
2037
2038               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2039             }
2040           else
2041             {
2042               length = 1;
2043
2044               /* If this is the last call to next_record move to the farthest
2045                  position reached and set length to pad out the remainder
2046                  of the record. (for character scaler unit) */
2047               if (done)
2048                 {
2049                   m = dtp->u.p.current_unit->recl
2050                         - dtp->u.p.current_unit->bytes_left;
2051                   if (max_pos > m)
2052                     {
2053                       length = (int) (max_pos - m);
2054                       p = salloc_w (dtp->u.p.current_unit->s, &length);
2055                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
2056                     }
2057                   else
2058                     length = (int) dtp->u.p.current_unit->bytes_left;
2059                 }
2060               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2061                 {
2062                   generate_error (&dtp->common, ERROR_END, NULL);
2063                   return;
2064                 }
2065             }
2066         }
2067       else
2068         {
2069           /* If this is the last call to next_record move to the farthest
2070           position reached in preparation for completing the record.
2071           (for file unit) */
2072           if (done)
2073             {
2074               m = dtp->u.p.current_unit->recl -
2075                         dtp->u.p.current_unit->bytes_left;
2076               if (max_pos > m)
2077                 {
2078                   length = (int) (max_pos - m);
2079                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2080                 }
2081             }
2082           size_t len;
2083           const char crlf[] = "\r\n";
2084 #ifdef HAVE_CRLF
2085           len = 2;
2086 #else
2087           len = 1;
2088 #endif
2089           if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2090             goto io_error;
2091         }
2092
2093       break;
2094
2095     io_error:
2096       generate_error (&dtp->common, ERROR_OS, NULL);
2097       break;
2098     }
2099 }
2100
2101 /* Position to the next record, which means moving to the end of the
2102    current record.  This can happen under several different
2103    conditions.  If the done flag is not set, we get ready to process
2104    the next record.  */
2105
2106 void
2107 next_record (st_parameter_dt *dtp, int done)
2108 {
2109   gfc_offset fp; /* File position.  */
2110
2111   dtp->u.p.current_unit->read_bad = 0;
2112
2113   if (dtp->u.p.mode == READING)
2114     next_record_r (dtp);
2115   else
2116     next_record_w (dtp, done);
2117
2118   /* keep position up to date for INQUIRE */
2119   dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2120
2121   dtp->u.p.current_unit->current_record = 0;
2122   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2123    {
2124     fp = file_position (dtp->u.p.current_unit->s);
2125     /* Calculate next record, rounding up partial records.  */
2126     dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
2127                                 / dtp->u.p.current_unit->recl;
2128    }
2129   else
2130     dtp->u.p.current_unit->last_record++;
2131
2132   if (!done)
2133     pre_position (dtp);
2134 }
2135
2136
2137 /* Finalize the current data transfer.  For a nonadvancing transfer,
2138    this means advancing to the next record.  For internal units close the
2139    stream associated with the unit.  */
2140
2141 static void
2142 finalize_transfer (st_parameter_dt *dtp)
2143 {
2144   jmp_buf eof_jump;
2145   GFC_INTEGER_4 cf = dtp->common.flags;
2146
2147   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2148     *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2149
2150   if (dtp->u.p.eor_condition)
2151     {
2152       generate_error (&dtp->common, ERROR_EOR, NULL);
2153       return;
2154     }
2155
2156   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2157     return;
2158
2159   if ((dtp->u.p.ionml != NULL)
2160       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2161     {
2162        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2163          namelist_read (dtp);
2164        else
2165          namelist_write (dtp);
2166     }
2167
2168   dtp->u.p.transfer = NULL;
2169   if (dtp->u.p.current_unit == NULL)
2170     return;
2171
2172   dtp->u.p.eof_jump = &eof_jump;
2173   if (setjmp (eof_jump))
2174     {
2175       generate_error (&dtp->common, ERROR_END, NULL);
2176       return;
2177     }
2178
2179   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2180     finish_list_read (dtp);
2181   else
2182     {
2183       dtp->u.p.current_unit->current_record = 0;
2184       if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
2185         {
2186           /* Most systems buffer lines, so force the partial record
2187              to be written out.  */
2188           flush (dtp->u.p.current_unit->s);
2189           dtp->u.p.seen_dollar = 0;
2190           return;
2191         }
2192
2193       next_record (dtp, 1);
2194     }
2195
2196   sfree (dtp->u.p.current_unit->s);
2197
2198   if (is_internal_unit (dtp))
2199     {
2200       if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
2201         free_mem (dtp->u.p.current_unit->ls);
2202       sclose (dtp->u.p.current_unit->s);
2203     }
2204 }
2205
2206
2207 /* Transfer function for IOLENGTH. It doesn't actually do any
2208    data transfer, it just updates the length counter.  */
2209
2210 static void
2211 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2212                    void *dest __attribute__ ((unused)),
2213                    int kind __attribute__((unused)),
2214                    size_t size, size_t nelems)
2215 {
2216   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2217     *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2218 }
2219
2220
2221 /* Initialize the IOLENGTH data transfer. This function is in essence
2222    a very much simplified version of data_transfer_init(), because it
2223    doesn't have to deal with units at all.  */
2224
2225 static void
2226 iolength_transfer_init (st_parameter_dt *dtp)
2227 {
2228   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2229     *dtp->iolength = 0;
2230
2231   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2232
2233   /* Set up the subroutine that will handle the transfers.  */
2234
2235   dtp->u.p.transfer = iolength_transfer;
2236 }
2237
2238
2239 /* Library entry point for the IOLENGTH form of the INQUIRE
2240    statement. The IOLENGTH form requires no I/O to be performed, but
2241    it must still be a runtime library call so that we can determine
2242    the iolength for dynamic arrays and such.  */
2243
2244 extern void st_iolength (st_parameter_dt *);
2245 export_proto(st_iolength);
2246
2247 void
2248 st_iolength (st_parameter_dt *dtp)
2249 {
2250   library_start (&dtp->common);
2251   iolength_transfer_init (dtp);
2252 }
2253
2254 extern void st_iolength_done (st_parameter_dt *);
2255 export_proto(st_iolength_done);
2256
2257 void
2258 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2259 {
2260   free_ionml (dtp);
2261   if (dtp->u.p.scratch != NULL)
2262     free_mem (dtp->u.p.scratch);
2263   library_end ();
2264 }
2265
2266
2267 /* The READ statement.  */
2268
2269 extern void st_read (st_parameter_dt *);
2270 export_proto(st_read);
2271
2272 void
2273 st_read (st_parameter_dt *dtp)
2274 {
2275
2276   library_start (&dtp->common);
2277
2278   data_transfer_init (dtp, 1);
2279
2280   /* Handle complications dealing with the endfile record.  It is
2281      significant that this is the only place where ERROR_END is
2282      generated.  Reading an end of file elsewhere is either end of
2283      record or an I/O error. */
2284
2285   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2286     switch (dtp->u.p.current_unit->endfile)
2287       {
2288       case NO_ENDFILE:
2289         break;
2290
2291       case AT_ENDFILE:
2292         if (!is_internal_unit (dtp))
2293           {
2294             generate_error (&dtp->common, ERROR_END, NULL);
2295             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2296             dtp->u.p.current_unit->current_record = 0;
2297           }
2298         break;
2299
2300       case AFTER_ENDFILE:
2301         generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2302         dtp->u.p.current_unit->current_record = 0;
2303         break;
2304       }
2305 }
2306
2307 extern void st_read_done (st_parameter_dt *);
2308 export_proto(st_read_done);
2309
2310 void
2311 st_read_done (st_parameter_dt *dtp)
2312 {
2313   finalize_transfer (dtp);
2314   free_format_data (dtp);
2315   free_ionml (dtp);
2316   if (dtp->u.p.scratch != NULL)
2317     free_mem (dtp->u.p.scratch);
2318   if (dtp->u.p.current_unit != NULL)
2319     unlock_unit (dtp->u.p.current_unit);
2320   library_end ();
2321 }
2322
2323 extern void st_write (st_parameter_dt *);
2324 export_proto(st_write);
2325
2326 void
2327 st_write (st_parameter_dt *dtp)
2328 {
2329   library_start (&dtp->common);
2330   data_transfer_init (dtp, 0);
2331 }
2332
2333 extern void st_write_done (st_parameter_dt *);
2334 export_proto(st_write_done);
2335
2336 void
2337 st_write_done (st_parameter_dt *dtp)
2338 {
2339   finalize_transfer (dtp);
2340
2341   /* Deal with endfile conditions associated with sequential files.  */
2342
2343   if (dtp->u.p.current_unit != NULL
2344       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2345     switch (dtp->u.p.current_unit->endfile)
2346       {
2347       case AT_ENDFILE:          /* Remain at the endfile record.  */
2348         break;
2349
2350       case AFTER_ENDFILE:
2351         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
2352         break;
2353
2354       case NO_ENDFILE:
2355         /* Get rid of whatever is after this record.  */
2356         flush (dtp->u.p.current_unit->s);
2357         if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2358           generate_error (&dtp->common, ERROR_OS, NULL);
2359
2360         dtp->u.p.current_unit->endfile = AT_ENDFILE;
2361         break;
2362       }
2363
2364   free_format_data (dtp);
2365   free_ionml (dtp);
2366   if (dtp->u.p.scratch != NULL)
2367     free_mem (dtp->u.p.scratch);
2368   if (dtp->u.p.current_unit != NULL)
2369     unlock_unit (dtp->u.p.current_unit);
2370   library_end ();
2371 }
2372
2373 /* Receives the scalar information for namelist objects and stores it
2374    in a linked list of namelist_info types.  */
2375
2376 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2377                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2378 export_proto(st_set_nml_var);
2379
2380
2381 void
2382 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2383                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2384                 GFC_INTEGER_4 dtype)
2385 {
2386   namelist_info *t1 = NULL;
2387   namelist_info *nml;
2388
2389   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2390
2391   nml->mem_pos = var_addr;
2392
2393   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2394   strcpy (nml->var_name, var_name);
2395
2396   nml->len = (int) len;
2397   nml->string_length = (index_type) string_length;
2398
2399   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2400   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2401   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2402
2403   if (nml->var_rank > 0)
2404     {
2405       nml->dim = (descriptor_dimension*)
2406                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2407       nml->ls = (array_loop_spec*)
2408                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2409     }
2410   else
2411     {
2412       nml->dim = NULL;
2413       nml->ls = NULL;
2414     }
2415
2416   nml->next = NULL;
2417
2418   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2419     {
2420       dtp->common.flags |= IOPARM_DT_IONML_SET;
2421       dtp->u.p.ionml = nml;
2422     }
2423   else
2424     {
2425       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2426       t1->next = nml;
2427     }
2428 }
2429
2430 /* Store the dimensional information for the namelist object.  */
2431 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2432                                 GFC_INTEGER_4, GFC_INTEGER_4,
2433                                 GFC_INTEGER_4);
2434 export_proto(st_set_nml_var_dim);
2435
2436 void
2437 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2438                     GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2439                     GFC_INTEGER_4 ubound)
2440 {
2441   namelist_info * nml;
2442   int n;
2443
2444   n = (int)n_dim;
2445
2446   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2447
2448   nml->dim[n].stride = (ssize_t)stride;
2449   nml->dim[n].lbound = (ssize_t)lbound;
2450   nml->dim[n].ubound = (ssize_t)ubound;
2451 }
2452
2453 /* Reverse memcpy - used for byte swapping.  */
2454
2455 void reverse_memcpy (void *dest, const void *src, size_t n)
2456 {
2457   char *d, *s;
2458   size_t i;
2459
2460   d = (char *) dest;
2461   s = (char *) src + n - 1;
2462
2463   /* Write with ascending order - this is likely faster
2464      on modern architectures because of write combining.  */
2465   for (i=0; i<n; i++)
2466       *(d++) = *(s--);
2467 }