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, 59 Temple Place - Suite 330,
  29 Boston, MA 02111-1307, 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 (void *, int);
  67 export_proto(transfer_integer);
  68
  69 extern void transfer_real (void *, int);
  70 export_proto(transfer_real);
  71
  72 extern void transfer_logical (void *, int);
  73 export_proto(transfer_logical);
  74
  75 extern void transfer_character (void *, int);
  76 export_proto(transfer_character);
  77
  78 extern void transfer_complex (void *, int);
  79 export_proto(transfer_complex);
  80
  81 gfc_unit *current_unit = NULL;
  82 static int sf_seen_eor = 0;
  83 static int eor_condition = 0;
  84
  85 char scratch[SCRATCH_SIZE];
  86 static char *line_buffer = NULL;
  87
  88 static unit_advance advance_status;
  89
  90 static st_option advance_opt[] = {
  91   {"yes", ADVANCE_YES},
  92   {"no", ADVANCE_NO},
  93   {NULL, 0}
  94 };
  95
  96
  97 static void (*transfer) (bt, void *, int);
  98
  99
 100 typedef enum
 101 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
 102   FORMATTED_DIRECT, UNFORMATTED_DIRECT
 103 }
 104 file_mode;
 105
 106
 107 static file_mode
 108 current_mode (void)
 109 {
 110   file_mode m;
 111
 112   if (current_unit->flags.access == ACCESS_DIRECT)
 113     {
 114       m = current_unit->flags.form == FORM_FORMATTED ?
 115         FORMATTED_DIRECT : UNFORMATTED_DIRECT;
 116     }
 117   else
 118     {
 119       m = current_unit->flags.form == FORM_FORMATTED ?
 120         FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
 121     }
 122
 123   return m;
 124 }
 125
 126
 127 /* Mid level data transfer statements.  These subroutines do reading
 128    and writing in the style of salloc_r()/salloc_w() within the
 129    current record.  */
 130
 131 /* When reading sequential formatted records we have a problem.  We
 132    don't know how long the line is until we read the trailing newline,
 133    and we don't want to read too much.  If we read too much, we might
 134    have to do a physical seek backwards depending on how much data is
 135    present, and devices like terminals aren't seekable and would cause
 136    an I/O error.
 137
 138    Given this, the solution is to read a byte at a time, stopping if
 139    we hit the newline.  For small locations, we use a static buffer.
 140    For larger allocations, we are forced to allocate memory on the
 141    heap.  Hopefully this won't happen very often.  */
 142
 143 static char *
 144 read_sf (int *length)
 145 {
 146   static char data[SCRATCH_SIZE];
 147   char *base, *p, *q;
 148   int n, readlen;
 149
 150   if (*length > SCRATCH_SIZE)
 151     p = base = line_buffer = get_mem (*length);
 152   else
 153     p = base = data;
 154
 155   /* If we have seen an eor previously, return a length of 0.  The
 156      caller is responsible for correctly padding the input field.  */
 157   if (sf_seen_eor)
 158     {
 159       *length = 0;
 160       return base;
 161     }
 162
 163   readlen = 1;
 164   n = 0;
 165
 166   do
 167     {
 168       if (is_internal_unit())
 169         {
 170           /* readlen may be modified inside salloc_r if
 171              is_internal_unit() is true.  */
 172           readlen = 1;
 173         }
 174
 175       q = salloc_r (current_unit->s, &readlen);
 176       if (q == NULL)
 177         break;
 178
 179       /* If we have a line without a terminating \n, drop through to
 180          EOR below.  */
 181       if (readlen < 1 && n == 0)
 182         {
 183           generate_error (ERROR_END, NULL);
 184           return NULL;
 185         }
 186
 187       if (readlen < 1 || *q == '\n' || *q == '\r')
 188         {
 189           /* Unexpected end of line.  */
 190
 191           /* If we see an EOR during non-advancing I/O, we need to skip
 192              the rest of the I/O statement.  Set the corresponding flag.  */
 193           if (advance_status == ADVANCE_NO || g.seen_dollar)
 194             eor_condition = 1;
 195
 196           /* Without padding, terminate the I/O statement without assigning
 197              the value.  With padding, the value still needs to be assigned,
 198              so we can just continue with a short read.  */
 199           if (current_unit->flags.pad == PAD_NO)
 200             {
 201               generate_error (ERROR_EOR, NULL);
 202               return NULL;
 203             }
 204
 205           current_unit->bytes_left = 0;
 206           *length = n;
 207           sf_seen_eor = 1;
 208           break;
 209         }
 210
 211       n++;
 212       *p++ = *q;
 213       sf_seen_eor = 0;
 214     }
 215   while (n < *length);
 216   current_unit->bytes_left -= *length;
 217
 218   if (ioparm.size != NULL)
 219     *ioparm.size += *length;
 220
 221   return base;
 222 }
 223
 224
 225 /* Function for reading the next couple of bytes from the current
 226    file, advancing the current position.  We return a pointer to a
 227    buffer containing the bytes.  We return NULL on end of record or
 228    end of file.
 229
 230    If the read is short, then it is because the current record does not
 231    have enough data to satisfy the read request and the file was
 232    opened with PAD=YES.  The caller must assume tailing spaces for
 233    short reads.  */
 234
 235 void *
 236 read_block (int *length)
 237 {
 238   char *source;
 239   int nread;
 240
 241   if (current_unit->flags.form == FORM_FORMATTED &&
 242       current_unit->flags.access == ACCESS_SEQUENTIAL)
 243     return read_sf (length);    /* Special case.  */
 244
 245   if (current_unit->bytes_left < *length)
 246     {
 247       if (current_unit->flags.pad == PAD_NO)
 248         {
 249           generate_error (ERROR_EOR, NULL); /* Not enough data left.  */
 250           return NULL;
 251         }
 252
 253       *length = current_unit->bytes_left;
 254     }
 255
 256   current_unit->bytes_left -= *length;
 257
 258   nread = *length;
 259   source = salloc_r (current_unit->s, &nread);
 260
 261   if (ioparm.size != NULL)
 262     *ioparm.size += nread;
 263
 264   if (nread != *length)
 265     {                           /* Short read, this shouldn't happen.  */
 266       if (current_unit->flags.pad == PAD_YES)
 267         *length = nread;
 268       else
 269         {
 270           generate_error (ERROR_EOR, NULL);
 271           source = NULL;
 272         }
 273     }
 274
 275   return source;
 276 }
 277
 278
 279 /* Function for writing a block of bytes to the current file at the
 280    current position, advancing the file pointer. We are given a length
 281    and return a pointer to a buffer that the caller must (completely)
 282    fill in.  Returns NULL on error.  */
 283
 284 void *
 285 write_block (int length)
 286 {
 287   char *dest;
 288
 289   if (!is_internal_unit() && current_unit->bytes_left < length)
 290     {
 291       generate_error (ERROR_EOR, NULL);
 292       return NULL;
 293     }
 294
 295   current_unit->bytes_left -= length;
 296   dest = salloc_w (current_unit->s, &length);
 297
 298   if (ioparm.size != NULL)
 299     *ioparm.size += length;
 300
 301   return dest;
 302 }
 303
 304
 305 /* Master function for unformatted reads.  */
 306
 307 static void
 308 unformatted_read (bt type, void *dest, int length)
 309 {
 310   void *source;
 311   int w;
 312
 313   /* Transfer functions get passed the kind of the entity, so we have
 314      to fix this for COMPLEX data which are twice the size of their
 315      kind.  */
 316   if (type == BT_COMPLEX)
 317     length *= 2;
 318
 319   w = length;
 320   source = read_block (&w);
 321
 322   if (source != NULL)
 323     {
 324       memcpy (dest, source, w);
 325       if (length != w)
 326         memset (((char *) dest) + w, ' ', length - w);
 327     }
 328 }
 329
 330 /* Master function for unformatted writes.  */
 331
 332 static void
 333 unformatted_write (bt type, void *source, int length)
 334 {
 335   void *dest;
 336
 337   /* Correction for kind vs. length as in unformatted_read.  */
 338   if (type == BT_COMPLEX)
 339     length *= 2;
 340
 341   dest = write_block (length);
 342   if (dest != NULL)
 343     memcpy (dest, source, length);
 344 }
 345
 346
 347 /* Return a pointer to the name of a type.  */
 348
 349 const char *
 350 type_name (bt type)
 351 {
 352   const char *p;
 353
 354   switch (type)
 355     {
 356     case BT_INTEGER:
 357       p = "INTEGER";
 358       break;
 359     case BT_LOGICAL:
 360       p = "LOGICAL";
 361       break;
 362     case BT_CHARACTER:
 363       p = "CHARACTER";
 364       break;
 365     case BT_REAL:
 366       p = "REAL";
 367       break;
 368     case BT_COMPLEX:
 369       p = "COMPLEX";
 370       break;
 371     default:
 372       internal_error ("type_name(): Bad type");
 373     }
 374
 375   return p;
 376 }
 377
 378
 379 /* Write a constant string to the output.
 380    This is complicated because the string can have doubled delimiters
 381    in it.  The length in the format node is the true length.  */
 382
 383 static void
 384 write_constant_string (fnode * f)
 385 {
 386   char c, delimiter, *p, *q;
 387   int length;
 388
 389   length = f->u.string.length;
 390   if (length == 0)
 391     return;
 392
 393   p = write_block (length);
 394   if (p == NULL)
 395     return;
 396
 397   q = f->u.string.p;
 398   delimiter = q[-1];
 399
 400   for (; length > 0; length--)
 401     {
 402       c = *p++ = *q++;
 403       if (c == delimiter && c != 'H' && c != 'h')
 404         q++;                    /* Skip the doubled delimiter.  */
 405     }
 406 }
 407
 408
 409 /* Given actual and expected types in a formatted data transfer, make
 410    sure they agree.  If not, an error message is generated.  Returns
 411    nonzero if something went wrong.  */
 412
 413 static int
 414 require_type (bt expected, bt actual, fnode * f)
 415 {
 416   char buffer[100];
 417
 418   if (actual == expected)
 419     return 0;
 420
 421   st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
 422               type_name (expected), g.item_count, type_name (actual));
 423
 424   format_error (f, buffer);
 425   return 1;
 426 }
 427
 428
 429 /* This subroutine is the main loop for a formatted data transfer
 430    statement.  It would be natural to implement this as a coroutine
 431    with the user program, but C makes that awkward.  We loop,
 432    processesing format elements.  When we actually have to transfer
 433    data instead of just setting flags, we return control to the user
 434    program which calls a subroutine that supplies the address and type
 435    of the next element, then comes back here to process it.  */
 436
 437 static void
 438 formatted_transfer (bt type, void *p, int len)
 439 {
 440   int pos ,m ;
 441   fnode *f;
 442   int i, n;
 443   int consume_data_flag;
 444
 445   /* Change a complex data item into a pair of reals.  */
 446
 447   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
 448   if (type == BT_COMPLEX)
 449     type = BT_REAL;
 450
 451   /* If there's an EOR condition, we simulate finalizing the transfer
 452      by doing nothing.  */
 453   if (eor_condition)
 454     return;
 455
 456   for (;;)
 457     {
 458       /* If reversion has occurred and there is another real data item,
 459          then we have to move to the next record.  */
 460       if (g.reversion_flag && n > 0)
 461         {
 462           g.reversion_flag = 0;
 463           next_record (0);
 464         }
 465
 466       consume_data_flag = 1 ;
 467       if (ioparm.library_return != LIBRARY_OK)
 468         break;
 469
 470       f = next_format ();
 471       if (f == NULL)
 472         return;         /* No data descriptors left (already raised).  */
 473
 474       switch (f->format)
 475         {
 476         case FMT_I:
 477           if (n == 0)
 478             goto need_data;
 479           if (require_type (BT_INTEGER, type, f))
 480             return;
 481
 482           if (g.mode == READING)
 483             read_decimal (f, p, len);
 484           else
 485             write_i (f, p, len);
 486
 487           break;
 488
 489         case FMT_B:
 490           if (n == 0)
 491             goto need_data;
 492           if (require_type (BT_INTEGER, type, f))
 493             return;
 494
 495           if (g.mode == READING)
 496             read_radix (f, p, len, 2);
 497           else
 498             write_b (f, p, len);
 499
 500           break;
 501
 502         case FMT_O:
 503           if (n == 0)
 504             goto need_data;
 505
 506           if (g.mode == READING)
 507             read_radix (f, p, len, 8);
 508           else
 509             write_o (f, p, len);
 510
 511           break;
 512
 513         case FMT_Z:
 514           if (n == 0)
 515             goto need_data;
 516
 517           if (g.mode == READING)
 518             read_radix (f, p, len, 16);
 519           else
 520             write_z (f, p, len);
 521
 522           break;
 523
 524         case FMT_A:
 525           if (n == 0)
 526             goto need_data;
 527           if (require_type (BT_CHARACTER, type, f))
 528             return;
 529
 530           if (g.mode == READING)
 531             read_a (f, p, len);
 532           else
 533             write_a (f, p, len);
 534
 535           break;
 536
 537         case FMT_L:
 538           if (n == 0)
 539             goto need_data;
 540
 541           if (g.mode == READING)
 542             read_l (f, p, len);
 543           else
 544             write_l (f, p, len);
 545
 546           break;
 547
 548         case FMT_D:
 549           if (n == 0)
 550             goto need_data;
 551           if (require_type (BT_REAL, type, f))
 552             return;
 553
 554           if (g.mode == READING)
 555             read_f (f, p, len);
 556           else
 557             write_d (f, p, len);
 558
 559           break;
 560
 561         case FMT_E:
 562           if (n == 0)
 563             goto need_data;
 564           if (require_type (BT_REAL, type, f))
 565             return;
 566
 567           if (g.mode == READING)
 568             read_f (f, p, len);
 569           else
 570             write_e (f, p, len);
 571           break;
 572
 573         case FMT_EN:
 574           if (n == 0)
 575             goto need_data;
 576           if (require_type (BT_REAL, type, f))
 577             return;
 578
 579           if (g.mode == READING)
 580             read_f (f, p, len);
 581           else
 582             write_en (f, p, len);
 583
 584           break;
 585
 586         case FMT_ES:
 587           if (n == 0)
 588             goto need_data;
 589           if (require_type (BT_REAL, type, f))
 590             return;
 591
 592           if (g.mode == READING)
 593             read_f (f, p, len);
 594           else
 595             write_es (f, p, len);
 596
 597           break;
 598
 599         case FMT_F:
 600           if (n == 0)
 601             goto need_data;
 602           if (require_type (BT_REAL, type, f))
 603             return;
 604
 605           if (g.mode == READING)
 606             read_f (f, p, len);
 607           else
 608             write_f (f, p, len);
 609
 610           break;
 611
 612         case FMT_G:
 613           if (n == 0)
 614             goto need_data;
 615           if (g.mode == READING)
 616             switch (type)
 617               {
 618               case BT_INTEGER:
 619                 read_decimal (f, p, len);
 620                 break;
 621               case BT_LOGICAL:
 622                 read_l (f, p, len);
 623                 break;
 624               case BT_CHARACTER:
 625                 read_a (f, p, len);
 626                 break;
 627               case BT_REAL:
 628                 read_f (f, p, len);
 629                 break;
 630               default:
 631                 goto bad_type;
 632               }
 633           else
 634             switch (type)
 635               {
 636               case BT_INTEGER:
 637                 write_i (f, p, len);
 638                 break;
 639               case BT_LOGICAL:
 640                 write_l (f, p, len);
 641                 break;
 642               case BT_CHARACTER:
 643                 write_a (f, p, len);
 644                 break;
 645               case BT_REAL:
 646                 write_d (f, p, len);
 647                 break;
 648               default:
 649               bad_type:
 650                 internal_error ("formatted_transfer(): Bad type");
 651               }
 652
 653           break;
 654
 655         case FMT_STRING:
 656           consume_data_flag = 0 ;
 657           if (g.mode == READING)
 658             {
 659               format_error (f, "Constant string in input format");
 660               return;
 661             }
 662           write_constant_string (f);
 663           break;
 664
 665           /* Format codes that don't transfer data.  */
 666         case FMT_X:
 667         case FMT_TR:
 668           consume_data_flag = 0 ;
 669           if (g.mode == READING)
 670             read_x (f);
 671           else
 672             write_x (f);
 673
 674           break;
 675
 676         case FMT_TL:
 677         case FMT_T:
 678            if (f->format == FMT_TL)
 679              pos = current_unit->recl - current_unit->bytes_left - f->u.n;
 680            else /* FMT_T */
 681              {
 682                consume_data_flag = 0;
 683                pos = f->u.n - 1;
 684              }
 685
 686            if (pos < 0 || pos >= current_unit->recl )
 687              {
 688                generate_error (ERROR_EOR, "T Or TL edit position error");
 689                break ;
 690              }
 691             m = pos - (current_unit->recl - current_unit->bytes_left);
 692
 693             if (m == 0)
 694                break;
 695
 696             if (m > 0)
 697              {
 698                f->u.n = m;
 699                if (g.mode == READING)
 700                  read_x (f);
 701                else
 702                  write_x (f);
 703              }
 704             if (m < 0)
 705              {
 706                move_pos_offset (current_unit->s,m);
 707                current_unit->bytes_left -= m;
 708              }
 709
 710           break;
 711
 712         case FMT_S:
 713           consume_data_flag = 0 ;
 714           g.sign_status = SIGN_S;
 715           break;
 716
 717         case FMT_SS:
 718           consume_data_flag = 0 ;
 719           g.sign_status = SIGN_SS;
 720           break;
 721
 722         case FMT_SP:
 723           consume_data_flag = 0 ;
 724           g.sign_status = SIGN_SP;
 725           break;
 726
 727         case FMT_BN:
 728           consume_data_flag = 0 ;
 729           g.blank_status = BLANK_NULL;
 730           break;
 731
 732         case FMT_BZ:
 733           consume_data_flag = 0 ;
 734           g.blank_status = BLANK_ZERO;
 735           break;
 736
 737         case FMT_P:
 738           consume_data_flag = 0 ;
 739           g.scale_factor = f->u.k;
 740           break;
 741
 742         case FMT_DOLLAR:
 743           consume_data_flag = 0 ;
 744           g.seen_dollar = 1;
 745           break;
 746
 747         case FMT_SLASH:
 748           consume_data_flag = 0 ;
 749           for (i = 0; i < f->repeat; i++)
 750             next_record (0);
 751
 752           break;
 753
 754         case FMT_COLON:
 755           /* A colon descriptor causes us to exit this loop (in
 756              particular preventing another / descriptor from being
 757              processed) unless there is another data item to be
 758              transferred.  */
 759           consume_data_flag = 0 ;
 760           if (n == 0)
 761             return;
 762           break;
 763
 764         default:
 765           internal_error ("Bad format node");
 766         }
 767
 768       /* Free a buffer that we had to allocate during a sequential
 769          formatted read of a block that was larger than the static
 770          buffer.  */
 771
 772       if (line_buffer != NULL)
 773         {
 774           free_mem (line_buffer);
 775           line_buffer = NULL;
 776         }
 777
 778       /* Adjust the item count and data pointer.  */
 779
 780       if ((consume_data_flag > 0) && (n > 0))
 781       {
 782         n--;
 783         p = ((char *) p) + len;
 784       }
 785     }
 786
 787   return;
 788
 789   /* Come here when we need a data descriptor but don't have one.  We
 790      push the current format node back onto the input, then return and
 791      let the user program call us back with the data.  */
 792  need_data:
 793   unget_format (f);
 794 }
 795
 796
 797 /* Data transfer entry points.  The type of the data entity is
 798    implicit in the subroutine call.  This prevents us from having to
 799    share a common enum with the compiler.  */
 800
 801 void
 802 transfer_integer (void *p, int kind)
 803 {
 804   g.item_count++;
 805   if (ioparm.library_return != LIBRARY_OK)
 806     return;
 807   transfer (BT_INTEGER, p, kind);
 808 }
 809
 810
 811 void
 812 transfer_real (void *p, int kind)
 813 {
 814   g.item_count++;
 815   if (ioparm.library_return != LIBRARY_OK)
 816     return;
 817   transfer (BT_REAL, p, kind);
 818 }
 819
 820
 821 void
 822 transfer_logical (void *p, int kind)
 823 {
 824   g.item_count++;
 825   if (ioparm.library_return != LIBRARY_OK)
 826     return;
 827   transfer (BT_LOGICAL, p, kind);
 828 }
 829
 830
 831 void
 832 transfer_character (void *p, int len)
 833 {
 834   g.item_count++;
 835   if (ioparm.library_return != LIBRARY_OK)
 836     return;
 837   transfer (BT_CHARACTER, p, len);
 838 }
 839
 840
 841 void
 842 transfer_complex (void *p, int kind)
 843 {
 844   g.item_count++;
 845   if (ioparm.library_return != LIBRARY_OK)
 846     return;
 847   transfer (BT_COMPLEX, p, kind);
 848 }
 849
 850
 851 /* Preposition a sequential unformatted file while reading.  */
 852
 853 static void
 854 us_read (void)
 855 {
 856   char *p;
 857   int n;
 858   gfc_offset i;
 859
 860   n = sizeof (gfc_offset);
 861   p = salloc_r (current_unit->s, &n);
 862
 863   if (n == 0)
 864     return;  /* end of file */
 865
 866   if (p == NULL || n != sizeof (gfc_offset))
 867     {
 868       generate_error (ERROR_BAD_US, NULL);
 869       return;
 870     }
 871
 872   memcpy (&i, p, sizeof (gfc_offset));
 873   current_unit->bytes_left = i;
 874 }
 875
 876
 877 /* Preposition a sequential unformatted file while writing.  This
 878    amount to writing a bogus length that will be filled in later.  */
 879
 880 static void
 881 us_write (void)
 882 {
 883   char *p;
 884   int length;
 885
 886   length = sizeof (gfc_offset);
 887   p = salloc_w (current_unit->s, &length);
 888
 889   if (p == NULL)
 890     {
 891       generate_error (ERROR_OS, NULL);
 892       return;
 893     }
 894
 895   memset (p, '\0', sizeof (gfc_offset));        /* Bogus value for now.  */
 896   if (sfree (current_unit->s) == FAILURE)
 897     generate_error (ERROR_OS, NULL);
 898
 899   /* For sequential unformatted, we write until we have more bytes than
 900      can fit in the record markers. If disk space runs out first, it will
 901      error on the write.  */
 902   current_unit->recl = g.max_offset;
 903
 904   current_unit->bytes_left = current_unit->recl;
 905 }
 906
 907
 908 /* Position to the next record prior to transfer.  We are assumed to
 909    be before the next record.  We also calculate the bytes in the next
 910    record.  */
 911
 912 static void
 913 pre_position (void)
 914 {
 915   if (current_unit->current_record)
 916     return;                     /* Already positioned.  */
 917
 918   switch (current_mode ())
 919     {
 920     case UNFORMATTED_SEQUENTIAL:
 921       if (g.mode == READING)
 922         us_read ();
 923       else
 924         us_write ();
 925
 926       break;
 927
 928     case FORMATTED_SEQUENTIAL:
 929     case FORMATTED_DIRECT:
 930     case UNFORMATTED_DIRECT:
 931       current_unit->bytes_left = current_unit->recl;
 932       break;
 933     }
 934
 935   current_unit->current_record = 1;
 936 }
 937
 938
 939 /* Initialize things for a data transfer.  This code is common for
 940    both reading and writing.  */
 941
 942 static void
 943 data_transfer_init (int read_flag)
 944 {
 945   unit_flags u_flags;  /* Used for creating a unit if needed.  */
 946
 947   g.mode = read_flag ? READING : WRITING;
 948
 949   if (ioparm.size != NULL)
 950     *ioparm.size = 0;           /* Initialize the count.  */
 951
 952   current_unit = get_unit (read_flag);
 953   if (current_unit == NULL)
 954   {  /* Open the unit with some default flags.  */
 955      if (ioparm.unit < 0)
 956      {
 957        generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
 958        library_end ();
 959        return;
 960      }
 961      memset (&u_flags, '\0', sizeof (u_flags));
 962      u_flags.access = ACCESS_SEQUENTIAL;
 963      u_flags.action = ACTION_READWRITE;
 964      /* Is it unformatted?  */
 965      if (ioparm.format == NULL && !ioparm.list_format)
 966        u_flags.form = FORM_UNFORMATTED;
 967      else
 968        u_flags.form = FORM_UNSPECIFIED;
 969      u_flags.delim = DELIM_UNSPECIFIED;
 970      u_flags.blank = BLANK_UNSPECIFIED;
 971      u_flags.pad = PAD_UNSPECIFIED;
 972      u_flags.status = STATUS_UNKNOWN;
 973      new_unit(&u_flags);
 974      current_unit = get_unit (read_flag);
 975   }
 976
 977   if (current_unit == NULL)
 978     return;
 979
 980   if (is_internal_unit())
 981     {
 982       current_unit->recl = file_length(current_unit->s);
 983       if (g.mode==WRITING)
 984         empty_internal_buffer (current_unit->s);
 985     }
 986
 987   /* Check the action.  */
 988
 989   if (read_flag && current_unit->flags.action == ACTION_WRITE)
 990     generate_error (ERROR_BAD_ACTION,
 991                     "Cannot read from file opened for WRITE");
 992
 993   if (!read_flag && current_unit->flags.action == ACTION_READ)
 994     generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
 995
 996   if (ioparm.library_return != LIBRARY_OK)
 997     return;
 998
 999   /* Check the format.  */
1000
1001   if (ioparm.format)
1002     parse_format ();
1003
1004   if (ioparm.library_return != LIBRARY_OK)
1005     return;
1006
1007   if (current_unit->flags.form == FORM_UNFORMATTED
1008       && (ioparm.format != NULL || ioparm.list_format))
1009     generate_error (ERROR_OPTION_CONFLICT,
1010                     "Format present for UNFORMATTED data transfer");
1011
1012   if (ioparm.namelist_name != NULL && ionml != NULL)
1013      {
1014         if(ioparm.format != NULL)
1015            generate_error (ERROR_OPTION_CONFLICT,
1016                     "A format cannot be specified with a namelist");
1017      }
1018   else if (current_unit->flags.form == FORM_FORMATTED &&
1019            ioparm.format == NULL && !ioparm.list_format)
1020     generate_error (ERROR_OPTION_CONFLICT,
1021                     "Missing format for FORMATTED data transfer");
1022
1023
1024   if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1025     generate_error (ERROR_OPTION_CONFLICT,
1026                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1027
1028   /* Check the record number.  */
1029
1030   if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1031     {
1032       generate_error (ERROR_MISSING_OPTION,
1033                       "Direct access data transfer requires record number");
1034       return;
1035     }
1036
1037   if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1038     {
1039       generate_error (ERROR_OPTION_CONFLICT,
1040                       "Record number not allowed for sequential access data transfer");
1041       return;
1042     }
1043
1044   /* Process the ADVANCE option.  */
1045
1046   advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1047     find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1048                  "Bad ADVANCE parameter in data transfer statement");
1049
1050   if (advance_status != ADVANCE_UNSPECIFIED)
1051     {
1052       if (current_unit->flags.access == ACCESS_DIRECT)
1053         generate_error (ERROR_OPTION_CONFLICT,
1054                         "ADVANCE specification conflicts with sequential access");
1055
1056       if (is_internal_unit ())
1057         generate_error (ERROR_OPTION_CONFLICT,
1058                         "ADVANCE specification conflicts with internal file");
1059
1060       if (ioparm.format == NULL || ioparm.list_format)
1061         generate_error (ERROR_OPTION_CONFLICT,
1062                         "ADVANCE specification requires an explicit format");
1063     }
1064
1065   if (read_flag)
1066     {
1067       if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
1068         generate_error (ERROR_MISSING_OPTION,
1069                         "EOR specification requires an ADVANCE specification of NO");
1070
1071       if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1072         generate_error (ERROR_MISSING_OPTION,
1073                         "SIZE specification requires an ADVANCE specification of NO");
1074
1075     }
1076   else
1077     {                           /* Write constraints.  */
1078       if (ioparm.end != 0)
1079         generate_error (ERROR_OPTION_CONFLICT,
1080                         "END specification cannot appear in a write statement");
1081
1082       if (ioparm.eor != 0)
1083         generate_error (ERROR_OPTION_CONFLICT,
1084                         "EOR specification cannot appear in a write statement");
1085
1086       if (ioparm.size != 0)
1087         generate_error (ERROR_OPTION_CONFLICT,
1088                         "SIZE specification cannot appear in a write statement");
1089     }
1090
1091   if (advance_status == ADVANCE_UNSPECIFIED)
1092     advance_status = ADVANCE_YES;
1093   if (ioparm.library_return != LIBRARY_OK)
1094     return;
1095
1096   /* Sanity checks on the record number.  */
1097
1098   if (ioparm.rec)
1099     {
1100       if (ioparm.rec <= 0)
1101         {
1102           generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1103           return;
1104         }
1105
1106       if (ioparm.rec >= current_unit->maxrec)
1107         {
1108           generate_error (ERROR_BAD_OPTION, "Record number too large");
1109           return;
1110         }
1111
1112       /* Check to see if we might be reading what we wrote before  */
1113
1114       if (g.mode == READING && current_unit->mode  == WRITING)
1115          flush(current_unit->s);
1116
1117       /* Position the file.  */
1118       if (sseek (current_unit->s,
1119                (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1120         generate_error (ERROR_OS, NULL);
1121     }
1122
1123   /* Overwriting an existing sequential file ?
1124      it is always safe to truncate the file on the first write */
1125   if (g.mode == WRITING
1126       && current_unit->flags.access == ACCESS_SEQUENTIAL
1127       && current_unit->current_record == 0)
1128         struncate(current_unit->s);
1129
1130   current_unit->mode = g.mode;
1131
1132   /* Set the initial value of flags.  */
1133
1134   g.blank_status = current_unit->flags.blank;
1135   g.sign_status = SIGN_S;
1136   g.scale_factor = 0;
1137   g.seen_dollar = 0;
1138   g.first_item = 1;
1139   g.item_count = 0;
1140   sf_seen_eor = 0;
1141   eor_condition = 0;
1142
1143   pre_position ();
1144
1145   /* Set up the subroutine that will handle the transfers.  */
1146
1147   if (read_flag)
1148     {
1149       if (current_unit->flags.form == FORM_UNFORMATTED)
1150         transfer = unformatted_read;
1151       else
1152         {
1153           if (ioparm.list_format)
1154             {
1155                transfer = list_formatted_read;
1156                init_at_eol();
1157             }
1158           else
1159             transfer = formatted_transfer;
1160         }
1161     }
1162   else
1163     {
1164       if (current_unit->flags.form == FORM_UNFORMATTED)
1165         transfer = unformatted_write;
1166       else
1167         {
1168           if (ioparm.list_format)
1169             transfer = list_formatted_write;
1170           else
1171             transfer = formatted_transfer;
1172         }
1173     }
1174
1175   /* Make sure that we don't do a read after a nonadvancing write.  */
1176
1177   if (read_flag)
1178     {
1179       if (current_unit->read_bad)
1180         {
1181           generate_error (ERROR_BAD_OPTION,
1182                           "Cannot READ after a nonadvancing WRITE");
1183           return;
1184         }
1185     }
1186   else
1187     {
1188       if (advance_status == ADVANCE_YES && !g.seen_dollar)
1189         current_unit->read_bad = 1;
1190     }
1191
1192   /* Start the data transfer if we are doing a formatted transfer.  */
1193   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1194       && ioparm.namelist_name == NULL && ionml == NULL)
1195     formatted_transfer (0, NULL, 0);
1196 }
1197
1198
1199 /* Space to the next record for read mode.  If the file is not
1200    seekable, we read MAX_READ chunks until we get to the right
1201    position.  */
1202
1203 #define MAX_READ 4096
1204
1205 static void
1206 next_record_r (void)
1207 {
1208   int rlength, length;
1209   gfc_offset new;
1210   char *p;
1211
1212   switch (current_mode ())
1213     {
1214     case UNFORMATTED_SEQUENTIAL:
1215       current_unit->bytes_left += sizeof (gfc_offset);  /* Skip over tail */
1216
1217       /* Fall through...  */
1218
1219     case FORMATTED_DIRECT:
1220     case UNFORMATTED_DIRECT:
1221       if (current_unit->bytes_left == 0)
1222         break;
1223
1224       if (is_seekable (current_unit->s))
1225         {
1226           new = file_position (current_unit->s) + current_unit->bytes_left;
1227
1228           /* Direct access files do not generate END conditions,
1229              only I/O errors.  */
1230           if (sseek (current_unit->s, new) == FAILURE)
1231             generate_error (ERROR_OS, NULL);
1232
1233         }
1234       else
1235         {                       /* Seek by reading data.  */
1236           while (current_unit->bytes_left > 0)
1237             {
1238               rlength = length = (MAX_READ > current_unit->bytes_left) ?
1239                 MAX_READ : current_unit->bytes_left;
1240
1241               p = salloc_r (current_unit->s, &rlength);
1242               if (p == NULL)
1243                 {
1244                   generate_error (ERROR_OS, NULL);
1245                   break;
1246                 }
1247
1248               current_unit->bytes_left -= length;
1249             }
1250         }
1251       break;
1252
1253     case FORMATTED_SEQUENTIAL:
1254       length = 1;
1255       /* sf_read has already terminated input because of an '\n'  */
1256       if (sf_seen_eor)
1257         {
1258           sf_seen_eor=0;
1259           break;
1260         }
1261
1262       do
1263         {
1264           p = salloc_r (current_unit->s, &length);
1265
1266           /* In case of internal file, there may not be any '\n'.  */
1267           if (is_internal_unit() && p == NULL)
1268             {
1269                break;
1270             }
1271
1272           if (p == NULL)
1273             {
1274               generate_error (ERROR_OS, NULL);
1275               break;
1276             }
1277
1278           if (length == 0)
1279             {
1280               current_unit->endfile = AT_ENDFILE;
1281               break;
1282             }
1283         }
1284       while (*p != '\n');
1285
1286       break;
1287     }
1288
1289   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1290     test_endfile (current_unit);
1291 }
1292
1293
1294 /* Position to the next record in write mode.  */
1295
1296 static void
1297 next_record_w (void)
1298 {
1299   gfc_offset c, m;
1300   int length;
1301   char *p;
1302
1303   switch (current_mode ())
1304     {
1305     case FORMATTED_DIRECT:
1306       if (current_unit->bytes_left == 0)
1307         break;
1308
1309       length = current_unit->bytes_left;
1310       p = salloc_w (current_unit->s, &length);
1311
1312       if (p == NULL)
1313         goto io_error;
1314
1315       memset (p, ' ', current_unit->bytes_left);
1316       if (sfree (current_unit->s) == FAILURE)
1317         goto io_error;
1318       break;
1319
1320     case UNFORMATTED_DIRECT:
1321       if (sfree (current_unit->s) == FAILURE)
1322         goto io_error;
1323       break;
1324
1325     case UNFORMATTED_SEQUENTIAL:
1326       m = current_unit->recl - current_unit->bytes_left; /* Bytes written.  */
1327       c = file_position (current_unit->s);
1328
1329       length = sizeof (gfc_offset);
1330
1331       /* Write the length tail.  */
1332
1333       p = salloc_w (current_unit->s, &length);
1334       if (p == NULL)
1335         goto io_error;
1336
1337       memcpy (p, &m, sizeof (gfc_offset));
1338       if (sfree (current_unit->s) == FAILURE)
1339         goto io_error;
1340
1341       /* Seek to the head and overwrite the bogus length with the real
1342          length.  */
1343
1344       p = salloc_w_at (current_unit->s, &length, c - m - length);
1345       if (p == NULL)
1346         generate_error (ERROR_OS, NULL);
1347
1348       memcpy (p, &m, sizeof (gfc_offset));
1349       if (sfree (current_unit->s) == FAILURE)
1350         goto io_error;
1351
1352       /* Seek past the end of the current record.  */
1353
1354       if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1355         goto io_error;
1356
1357       break;
1358
1359     case FORMATTED_SEQUENTIAL:
1360       length = 1;
1361       p = salloc_w (current_unit->s, &length);
1362
1363       if (!is_internal_unit())
1364         {
1365           if (p)
1366             *p = '\n'; /* No CR for internal writes.  */
1367           else
1368             goto io_error;
1369         }
1370
1371       if (sfree (current_unit->s) == FAILURE)
1372         goto io_error;
1373
1374       break;
1375
1376     io_error:
1377       generate_error (ERROR_OS, NULL);
1378       break;
1379     }
1380 }
1381
1382
1383 /* Position to the next record, which means moving to the end of the
1384    current record.  This can happen under several different
1385    conditions.  If the done flag is not set, we get ready to process
1386    the next record.  */
1387
1388 void
1389 next_record (int done)
1390 {
1391   gfc_offset fp; /* File position.  */
1392
1393   current_unit->read_bad = 0;
1394
1395   if (g.mode == READING)
1396     next_record_r ();
1397   else
1398     next_record_w ();
1399
1400   /* keep position up to date for INQUIRE */
1401   current_unit->flags.position = POSITION_ASIS;
1402
1403   current_unit->current_record = 0;
1404   if (current_unit->flags.access == ACCESS_DIRECT)
1405    {
1406     fp = file_position (current_unit->s);
1407     /* Calculate next record, rounding up partial records.  */
1408     current_unit->last_record = (fp + current_unit->recl - 1)
1409                                 / current_unit->recl;
1410    }
1411   else
1412     current_unit->last_record++;
1413
1414   if (!done)
1415     pre_position ();
1416 }
1417
1418
1419 /* Finalize the current data transfer.  For a nonadvancing transfer,
1420    this means advancing to the next record.  For internal units close the
1421    steam associated with the unit.  */
1422
1423 static void
1424 finalize_transfer (void)
1425 {
1426
1427   if (eor_condition)
1428     {
1429       generate_error (ERROR_EOR, NULL);
1430       return;
1431     }
1432
1433   if (ioparm.library_return != LIBRARY_OK)
1434     return;
1435
1436   if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1437     {
1438        if (ioparm.namelist_read_mode)
1439          namelist_read();
1440        else
1441          namelist_write();
1442     }
1443
1444   transfer = NULL;
1445   if (current_unit == NULL)
1446     return;
1447
1448   if (setjmp (g.eof_jump))
1449     {
1450       generate_error (ERROR_END, NULL);
1451       return;
1452     }
1453
1454   if (ioparm.list_format && g.mode == READING)
1455     finish_list_read ();
1456   else
1457     {
1458       free_fnodes ();
1459
1460       if (advance_status == ADVANCE_NO || g.seen_dollar)
1461         {
1462           /* Most systems buffer lines, so force the partial record
1463              to be written out.  */
1464           flush (current_unit->s);
1465           g.seen_dollar = 0;
1466           return;
1467         }
1468
1469       next_record (1);
1470       current_unit->current_record = 0;
1471     }
1472
1473   sfree (current_unit->s);
1474
1475   if (is_internal_unit ())
1476     sclose (current_unit->s);
1477 }
1478
1479
1480 /* Transfer function for IOLENGTH. It doesn't actually do any
1481    data transfer, it just updates the length counter.  */
1482
1483 static void
1484 iolength_transfer (bt type   __attribute__ ((unused)),
1485                    void *dest __attribute__ ((unused)),
1486                    int len)
1487 {
1488   if (ioparm.iolength != NULL)
1489     *ioparm.iolength += len;
1490 }
1491
1492
1493 /* Initialize the IOLENGTH data transfer. This function is in essence
1494    a very much simplified version of data_transfer_init(), because it
1495    doesn't have to deal with units at all.  */
1496
1497 static void
1498 iolength_transfer_init (void)
1499 {
1500   if (ioparm.iolength != NULL)
1501     *ioparm.iolength = 0;
1502
1503   g.item_count = 0;
1504
1505   /* Set up the subroutine that will handle the transfers.  */
1506
1507   transfer = iolength_transfer;
1508 }
1509
1510
1511 /* Library entry point for the IOLENGTH form of the INQUIRE
1512    statement. The IOLENGTH form requires no I/O to be performed, but
1513    it must still be a runtime library call so that we can determine
1514    the iolength for dynamic arrays and such.  */
1515
1516 extern void st_iolength (void);
1517 export_proto(st_iolength);
1518
1519 void
1520 st_iolength (void)
1521 {
1522   library_start ();
1523   iolength_transfer_init ();
1524 }
1525
1526 extern void st_iolength_done (void);
1527 export_proto(st_iolength_done);
1528
1529 void
1530 st_iolength_done (void)
1531 {
1532   library_end ();
1533 }
1534
1535
1536 /* The READ statement.  */
1537
1538 extern void st_read (void);
1539 export_proto(st_read);
1540
1541 void
1542 st_read (void)
1543 {
1544   library_start ();
1545
1546   data_transfer_init (1);
1547
1548   /* Handle complications dealing with the endfile record.  It is
1549      significant that this is the only place where ERROR_END is
1550      generated.  Reading an end of file elsewhere is either end of
1551      record or an I/O error. */
1552
1553   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1554     switch (current_unit->endfile)
1555       {
1556       case NO_ENDFILE:
1557         break;
1558
1559       case AT_ENDFILE:
1560         if (!is_internal_unit())
1561           {
1562             generate_error (ERROR_END, NULL);
1563             current_unit->endfile = AFTER_ENDFILE;
1564           }
1565         break;
1566
1567       case AFTER_ENDFILE:
1568         generate_error (ERROR_ENDFILE, NULL);
1569         break;
1570       }
1571 }
1572
1573 extern void st_read_done (void);
1574 export_proto(st_read_done);
1575
1576 void
1577 st_read_done (void)
1578 {
1579   finalize_transfer ();
1580   library_end ();
1581 }
1582
1583 extern void st_write (void);
1584 export_proto(st_write);
1585
1586 void
1587 st_write (void)
1588 {
1589   library_start ();
1590   data_transfer_init (0);
1591 }
1592
1593 extern void st_write_done (void);
1594 export_proto(st_write_done);
1595
1596 void
1597 st_write_done (void)
1598 {
1599   finalize_transfer ();
1600
1601   /* Deal with endfile conditions associated with sequential files.  */
1602
1603   if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1604     switch (current_unit->endfile)
1605       {
1606       case AT_ENDFILE:          /* Remain at the endfile record.  */
1607         break;
1608
1609       case AFTER_ENDFILE:
1610         current_unit->endfile = AT_ENDFILE;     /* Just at it now.  */
1611         break;
1612
1613       case NO_ENDFILE:
1614         if (current_unit->current_record > current_unit->last_record)
1615           {
1616             /* Get rid of whatever is after this record.  */
1617             if (struncate (current_unit->s) == FAILURE)
1618               generate_error (ERROR_OS, NULL);
1619           }
1620
1621         current_unit->endfile = AT_ENDFILE;
1622         break;
1623       }
1624
1625   library_end ();
1626 }
1627
1628 /* Receives the scalar information for namelist objects and stores it
1629    in a linked list of namelist_info types.  */
1630
1631 extern void st_set_nml_var (void * ,char * ,
1632                             GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
1633 export_proto(st_set_nml_var);
1634
1635
1636 void
1637 st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
1638                 gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
1639 {
1640   namelist_info *t1 = NULL;
1641   namelist_info *nml;
1642
1643   nml = (namelist_info*) get_mem (sizeof (namelist_info));
1644
1645   nml->mem_pos = var_addr;
1646
1647   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
1648   strcpy (nml->var_name, var_name);
1649
1650   nml->len = (int) len;
1651   nml->string_length = (index_type) string_length;
1652
1653   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
1654   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
1655   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
1656
1657   if (nml->var_rank > 0)
1658     {
1659       nml->dim = (descriptor_dimension*)
1660                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
1661       nml->ls = (nml_loop_spec*)
1662                   get_mem (nml->var_rank * sizeof (nml_loop_spec));
1663     }
1664   else
1665     {
1666       nml->dim = NULL;
1667       nml->ls = NULL;
1668     }
1669
1670   nml->next = NULL;
1671
1672   if (ionml == NULL)
1673     ionml = nml;
1674   else
1675     {
1676       for (t1 = ionml; t1->next; t1 = t1->next);
1677       t1->next = nml;
1678     }
1679   return;
1680 }
1681
1682 /* Store the dimensional information for the namelist object.  */
1683 extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
1684                                 GFC_INTEGER_4 ,GFC_INTEGER_4);
1685 export_proto(st_set_nml_var_dim);
1686
1687 void
1688 st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
1689                     GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
1690 {
1691   namelist_info * nml;
1692   int n;
1693
1694   n = (int)n_dim;
1695
1696   for (nml = ionml; nml->next; nml = nml->next);
1697
1698   nml->dim[n].stride = (ssize_t)stride;
1699   nml->dim[n].lbound = (ssize_t)lbound;
1700   nml->dim[n].ubound = (ssize_t)ubound;
1701 }