libgfortran/io/transfer.c

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