libgfortran/io/transfer.c

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