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
1649       /* Skip over tail */
1650       dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset);
1651
1652       /* Fall through...  */
1653
1654     case FORMATTED_DIRECT:
1655     case UNFORMATTED_DIRECT:
1656       if (dtp->u.p.current_unit->bytes_left == 0)
1657         break;
1658
1659       if (is_seekable (dtp->u.p.current_unit->s))
1660         {
1661           new = file_position (dtp->u.p.current_unit->s)
1662                 + dtp->u.p.current_unit->bytes_left;
1663
1664           /* Direct access files do not generate END conditions,
1665              only I/O errors.  */
1666           if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1667             generate_error (&dtp->common, ERROR_OS, NULL);
1668
1669         }
1670       else
1671         {                       /* Seek by reading data.  */
1672           while (dtp->u.p.current_unit->bytes_left > 0)
1673             {
1674               rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1675                 MAX_READ : dtp->u.p.current_unit->bytes_left;
1676
1677               p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1678               if (p == NULL)
1679                 {
1680                   generate_error (&dtp->common, ERROR_OS, NULL);
1681                   break;
1682                 }
1683
1684               dtp->u.p.current_unit->bytes_left -= length;
1685             }
1686         }
1687       break;
1688
1689     case FORMATTED_SEQUENTIAL:
1690       length = 1;
1691       /* sf_read has already terminated input because of an '\n'  */
1692       if (dtp->u.p.sf_seen_eor)
1693         {
1694           dtp->u.p.sf_seen_eor = 0;
1695           break;
1696         }
1697
1698       if (is_internal_unit (dtp))
1699         {
1700           if (is_array_io (dtp))
1701             {
1702               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1703
1704               /* Now seek to this record.  */
1705               record = record * dtp->u.p.current_unit->recl;
1706               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1707                 {
1708                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
1709                   break;
1710                 }
1711               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1712             }
1713           else
1714             {
1715               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
1716               p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
1717               if (p != NULL)
1718                 dtp->u.p.current_unit->bytes_left
1719                   = dtp->u.p.current_unit->recl;
1720             }
1721           break;
1722         }
1723       else do
1724         {
1725           p = salloc_r (dtp->u.p.current_unit->s, &length);
1726
1727           if (p == NULL)
1728             {
1729               generate_error (&dtp->common, ERROR_OS, NULL);
1730               break;
1731             }
1732
1733           if (length == 0)
1734             {
1735               dtp->u.p.current_unit->endfile = AT_ENDFILE;
1736               break;
1737             }
1738         }
1739       while (*p != '\n');
1740
1741       break;
1742     }
1743
1744   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
1745     test_endfile (dtp->u.p.current_unit);
1746 }
1747
1748
1749 /* Position to the next record in write mode.  */
1750
1751 static void
1752 next_record_w (st_parameter_dt *dtp, int done)
1753 {
1754   gfc_offset c, m, record, max_pos;
1755   int length;
1756   char *p;
1757
1758   /* Zero counters for X- and T-editing.  */
1759   max_pos = dtp->u.p.max_pos;
1760   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1761
1762   switch (current_mode (dtp))
1763     {
1764     case FORMATTED_DIRECT:
1765       if (dtp->u.p.current_unit->bytes_left == 0)
1766         break;
1767
1768       length = dtp->u.p.current_unit->bytes_left;
1769       p = salloc_w (dtp->u.p.current_unit->s, &length);
1770
1771       if (p == NULL)
1772         goto io_error;
1773
1774       memset (p, ' ', dtp->u.p.current_unit->bytes_left);
1775       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
1776         goto io_error;
1777       break;
1778
1779     case UNFORMATTED_DIRECT:
1780       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
1781         goto io_error;
1782       break;
1783
1784     case UNFORMATTED_SEQUENTIAL:
1785       /* Bytes written.  */
1786       m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
1787       c = file_position (dtp->u.p.current_unit->s);
1788
1789       length = sizeof (gfc_offset);
1790
1791       /* Write the length tail.  */
1792
1793       p = salloc_w (dtp->u.p.current_unit->s, &length);
1794       if (p == NULL)
1795         goto io_error;
1796
1797       /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
1798       if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1799         memcpy (p, &m, sizeof (gfc_offset));
1800       else
1801         reverse_memcpy (p, &m, sizeof (gfc_offset));
1802
1803       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
1804         goto io_error;
1805
1806       /* Seek to the head and overwrite the bogus length with the real
1807          length.  */
1808
1809       p = salloc_w_at (dtp->u.p.current_unit->s, &length, c - m - length);
1810       if (p == NULL)
1811         generate_error (&dtp->common, ERROR_OS, NULL);
1812
1813       /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
1814       if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1815         memcpy (p, &m, sizeof (gfc_offset));
1816       else
1817         reverse_memcpy (p, &m, sizeof (gfc_offset));
1818
1819       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
1820         goto io_error;
1821
1822       /* Seek past the end of the current record.  */
1823
1824       if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1825         goto io_error;
1826
1827       break;
1828
1829     case FORMATTED_SEQUENTIAL:
1830
1831       if (dtp->u.p.current_unit->bytes_left == 0)
1832         break;
1833
1834       if (is_internal_unit (dtp))
1835         {
1836           if (is_array_io (dtp))
1837             {
1838               length = (int) dtp->u.p.current_unit->bytes_left;
1839
1840               /* If the farthest position reached is greater than current
1841               position, adjust the position and set length to pad out
1842               whats left.  Otherwise just pad whats left.
1843               (for character array unit) */
1844               m = dtp->u.p.current_unit->recl
1845                         - dtp->u.p.current_unit->bytes_left;
1846               if (max_pos > m)
1847                 {
1848                   length = (int) (max_pos - m);
1849                   p = salloc_w (dtp->u.p.current_unit->s, &length);
1850                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
1851                 }
1852
1853               p = salloc_w (dtp->u.p.current_unit->s, &length);
1854               if (p == NULL)
1855                 {
1856                   generate_error (&dtp->common, ERROR_END, NULL);
1857                   return;
1858                 }
1859               memset(p, ' ', length);
1860
1861               /* Now that the current record has been padded out,
1862                  determine where the next record in the array is. */
1863               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1864
1865               /* Now seek to this record */
1866               record = record * dtp->u.p.current_unit->recl;
1867
1868               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1869                 {
1870                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
1871                   return;
1872                 }
1873
1874               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1875             }
1876           else
1877             {
1878               length = 1;
1879
1880               /* If this is the last call to next_record move to the farthest
1881                  position reached and set length to pad out the remainder
1882                  of the record. (for character scaler unit) */
1883               if (done)
1884                 {
1885                   m = dtp->u.p.current_unit->recl
1886                         - dtp->u.p.current_unit->bytes_left;
1887                   if (max_pos > m)
1888                     {
1889                       length = (int) (max_pos - m);
1890                       p = salloc_w (dtp->u.p.current_unit->s, &length);
1891                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
1892                     }
1893                   else
1894                     length = (int) dtp->u.p.current_unit->bytes_left;
1895                 }
1896               p = salloc_w (dtp->u.p.current_unit->s, &length);
1897               if (p == NULL)
1898                 {
1899                   generate_error (&dtp->common, ERROR_END, NULL);
1900                   return;
1901                 }
1902               memset (p, ' ', length);
1903             }
1904         }
1905       else
1906         {
1907           /* If this is the last call to next_record move to the farthest
1908           position reached in preparation for completing the record.
1909           (for file unit) */
1910           if (done)
1911             {
1912               m = dtp->u.p.current_unit->recl -
1913                         dtp->u.p.current_unit->bytes_left;
1914               if (max_pos > m)
1915                 {
1916                   length = (int) (max_pos - m);
1917                   p = salloc_w (dtp->u.p.current_unit->s, &length);
1918                 }
1919             }
1920 #ifdef HAVE_CRLF
1921           length = 2;
1922 #else
1923           length = 1;
1924 #endif
1925           p = salloc_w (dtp->u.p.current_unit->s, &length);
1926           if (p)
1927             {  /* No new line for internal writes.  */
1928 #ifdef HAVE_CRLF
1929               p[0] = '\r';
1930               p[1] = '\n';
1931 #else
1932               *p = '\n';
1933 #endif
1934             }
1935           else
1936             goto io_error;
1937         }
1938
1939       break;
1940
1941     io_error:
1942       generate_error (&dtp->common, ERROR_OS, NULL);
1943       break;
1944     }
1945 }
1946
1947 /* Position to the next record, which means moving to the end of the
1948    current record.  This can happen under several different
1949    conditions.  If the done flag is not set, we get ready to process
1950    the next record.  */
1951
1952 void
1953 next_record (st_parameter_dt *dtp, int done)
1954 {
1955   gfc_offset fp; /* File position.  */
1956
1957   dtp->u.p.current_unit->read_bad = 0;
1958
1959   if (dtp->u.p.mode == READING)
1960     next_record_r (dtp);
1961   else
1962     next_record_w (dtp, done);
1963
1964   /* keep position up to date for INQUIRE */
1965   dtp->u.p.current_unit->flags.position = POSITION_ASIS;
1966
1967   dtp->u.p.current_unit->current_record = 0;
1968   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1969    {
1970     fp = file_position (dtp->u.p.current_unit->s);
1971     /* Calculate next record, rounding up partial records.  */
1972     dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
1973                                 / dtp->u.p.current_unit->recl;
1974    }
1975   else
1976     dtp->u.p.current_unit->last_record++;
1977
1978   if (!done)
1979     pre_position (dtp);
1980 }
1981
1982
1983 /* Finalize the current data transfer.  For a nonadvancing transfer,
1984    this means advancing to the next record.  For internal units close the
1985    stream associated with the unit.  */
1986
1987 static void
1988 finalize_transfer (st_parameter_dt *dtp)
1989 {
1990   jmp_buf eof_jump;
1991   GFC_INTEGER_4 cf = dtp->common.flags;
1992
1993   if (dtp->u.p.eor_condition)
1994     {
1995       generate_error (&dtp->common, ERROR_EOR, NULL);
1996       return;
1997     }
1998
1999   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2000     return;
2001
2002   if ((dtp->u.p.ionml != NULL)
2003       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2004     {
2005        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2006          namelist_read (dtp);
2007        else
2008          namelist_write (dtp);
2009     }
2010
2011   dtp->u.p.transfer = NULL;
2012   if (dtp->u.p.current_unit == NULL)
2013     return;
2014
2015   dtp->u.p.eof_jump = &eof_jump;
2016   if (setjmp (eof_jump))
2017     {
2018       generate_error (&dtp->common, ERROR_END, NULL);
2019       return;
2020     }
2021
2022   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2023     finish_list_read (dtp);
2024   else
2025     {
2026       dtp->u.p.current_unit->current_record = 0;
2027       if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
2028         {
2029           /* Most systems buffer lines, so force the partial record
2030              to be written out.  */
2031           flush (dtp->u.p.current_unit->s);
2032           dtp->u.p.seen_dollar = 0;
2033           return;
2034         }
2035
2036       next_record (dtp, 1);
2037     }
2038
2039   sfree (dtp->u.p.current_unit->s);
2040
2041   if (is_internal_unit (dtp))
2042     {
2043       if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
2044         free_mem (dtp->u.p.current_unit->ls);
2045       sclose (dtp->u.p.current_unit->s);
2046     }
2047 }
2048
2049
2050 /* Transfer function for IOLENGTH. It doesn't actually do any
2051    data transfer, it just updates the length counter.  */
2052
2053 static void
2054 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2055                    void *dest __attribute__ ((unused)),
2056                    int kind __attribute__((unused)),
2057                    size_t size, size_t nelems)
2058 {
2059   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2060     *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2061 }
2062
2063
2064 /* Initialize the IOLENGTH data transfer. This function is in essence
2065    a very much simplified version of data_transfer_init(), because it
2066    doesn't have to deal with units at all.  */
2067
2068 static void
2069 iolength_transfer_init (st_parameter_dt *dtp)
2070 {
2071   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2072     *dtp->iolength = 0;
2073
2074   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2075
2076   /* Set up the subroutine that will handle the transfers.  */
2077
2078   dtp->u.p.transfer = iolength_transfer;
2079 }
2080
2081
2082 /* Library entry point for the IOLENGTH form of the INQUIRE
2083    statement. The IOLENGTH form requires no I/O to be performed, but
2084    it must still be a runtime library call so that we can determine
2085    the iolength for dynamic arrays and such.  */
2086
2087 extern void st_iolength (st_parameter_dt *);
2088 export_proto(st_iolength);
2089
2090 void
2091 st_iolength (st_parameter_dt *dtp)
2092 {
2093   library_start (&dtp->common);
2094   iolength_transfer_init (dtp);
2095 }
2096
2097 extern void st_iolength_done (st_parameter_dt *);
2098 export_proto(st_iolength_done);
2099
2100 void
2101 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2102 {
2103   free_ionml (dtp);
2104   if (dtp->u.p.scratch != NULL)
2105     free_mem (dtp->u.p.scratch);
2106   library_end ();
2107 }
2108
2109
2110 /* The READ statement.  */
2111
2112 extern void st_read (st_parameter_dt *);
2113 export_proto(st_read);
2114
2115 void
2116 st_read (st_parameter_dt *dtp)
2117 {
2118
2119   library_start (&dtp->common);
2120
2121   data_transfer_init (dtp, 1);
2122
2123   /* Handle complications dealing with the endfile record.  It is
2124      significant that this is the only place where ERROR_END is
2125      generated.  Reading an end of file elsewhere is either end of
2126      record or an I/O error. */
2127
2128   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2129     switch (dtp->u.p.current_unit->endfile)
2130       {
2131       case NO_ENDFILE:
2132         break;
2133
2134       case AT_ENDFILE:
2135         if (!is_internal_unit (dtp))
2136           {
2137             generate_error (&dtp->common, ERROR_END, NULL);
2138             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2139             dtp->u.p.current_unit->current_record = 0;
2140           }
2141         break;
2142
2143       case AFTER_ENDFILE:
2144         generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2145         dtp->u.p.current_unit->current_record = 0;
2146         break;
2147       }
2148 }
2149
2150 extern void st_read_done (st_parameter_dt *);
2151 export_proto(st_read_done);
2152
2153 void
2154 st_read_done (st_parameter_dt *dtp)
2155 {
2156   finalize_transfer (dtp);
2157   free_format_data (dtp);
2158   free_ionml (dtp);
2159   if (dtp->u.p.scratch != NULL)
2160     free_mem (dtp->u.p.scratch);
2161   if (dtp->u.p.current_unit != NULL)
2162     unlock_unit (dtp->u.p.current_unit);
2163   library_end ();
2164 }
2165
2166 extern void st_write (st_parameter_dt *);
2167 export_proto(st_write);
2168
2169 void
2170 st_write (st_parameter_dt *dtp)
2171 {
2172   library_start (&dtp->common);
2173   data_transfer_init (dtp, 0);
2174 }
2175
2176 extern void st_write_done (st_parameter_dt *);
2177 export_proto(st_write_done);
2178
2179 void
2180 st_write_done (st_parameter_dt *dtp)
2181 {
2182   finalize_transfer (dtp);
2183
2184   /* Deal with endfile conditions associated with sequential files.  */
2185
2186   if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2187     switch (dtp->u.p.current_unit->endfile)
2188       {
2189       case AT_ENDFILE:          /* Remain at the endfile record.  */
2190         break;
2191
2192       case AFTER_ENDFILE:
2193         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
2194         break;
2195
2196       case NO_ENDFILE:
2197         if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record)
2198           {
2199             /* Get rid of whatever is after this record.  */
2200             if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2201               generate_error (&dtp->common, ERROR_OS, NULL);
2202           }
2203
2204         dtp->u.p.current_unit->endfile = AT_ENDFILE;
2205         break;
2206       }
2207
2208   free_format_data (dtp);
2209   free_ionml (dtp);
2210   if (dtp->u.p.scratch != NULL)
2211     free_mem (dtp->u.p.scratch);
2212   if (dtp->u.p.current_unit != NULL)
2213     unlock_unit (dtp->u.p.current_unit);
2214   library_end ();
2215 }
2216
2217 /* Receives the scalar information for namelist objects and stores it
2218    in a linked list of namelist_info types.  */
2219
2220 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2221                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2222 export_proto(st_set_nml_var);
2223
2224
2225 void
2226 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2227                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2228                 GFC_INTEGER_4 dtype)
2229 {
2230   namelist_info *t1 = NULL;
2231   namelist_info *nml;
2232
2233   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2234
2235   nml->mem_pos = var_addr;
2236
2237   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2238   strcpy (nml->var_name, var_name);
2239
2240   nml->len = (int) len;
2241   nml->string_length = (index_type) string_length;
2242
2243   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2244   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2245   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2246
2247   if (nml->var_rank > 0)
2248     {
2249       nml->dim = (descriptor_dimension*)
2250                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2251       nml->ls = (array_loop_spec*)
2252                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2253     }
2254   else
2255     {
2256       nml->dim = NULL;
2257       nml->ls = NULL;
2258     }
2259
2260   nml->next = NULL;
2261
2262   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2263     {
2264       dtp->common.flags |= IOPARM_DT_IONML_SET;
2265       dtp->u.p.ionml = nml;
2266     }
2267   else
2268     {
2269       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2270       t1->next = nml;
2271     }
2272 }
2273
2274 /* Store the dimensional information for the namelist object.  */
2275 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2276                                 GFC_INTEGER_4, GFC_INTEGER_4,
2277                                 GFC_INTEGER_4);
2278 export_proto(st_set_nml_var_dim);
2279
2280 void
2281 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2282                     GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2283                     GFC_INTEGER_4 ubound)
2284 {
2285   namelist_info * nml;
2286   int n;
2287
2288   n = (int)n_dim;
2289
2290   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2291
2292   nml->dim[n].stride = (ssize_t)stride;
2293   nml->dim[n].lbound = (ssize_t)lbound;
2294   nml->dim[n].ubound = (ssize_t)ubound;
2295 }
2296
2297 /* Reverse memcpy - used for byte swapping.  */
2298
2299 void reverse_memcpy (void *dest, const void *src, size_t n)
2300 {
2301   char *d, *s;
2302   size_t i;
2303
2304   d = (char *) dest;
2305   s = (char *) src + n - 1;
2306
2307   /* Write with ascending order - this is likely faster
2308      on modern architectures because of write combining.  */
2309   for (i=0; i<n; i++)
2310       *(d++) = *(s--);
2311 }