libgfortran/io/transfer.c

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