libgfortran/io/transfer.c

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