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   current_unit->bytes_left = options.default_recl;
 164   readlen = 1;
 165   n = 0;
 166
 167   do
 168     {
 169       if (is_internal_unit())
 170         {
 171           /* readlen may be modified inside salloc_r if
 172              is_internal_unit() is true.  */
 173           readlen = 1;
 174         }
 175
 176       q = salloc_r (current_unit->s, &readlen);
 177       if (q == NULL)
 178         break;
 179
 180       /* If we have a line without a terminating \n, drop through to
 181          EOR below.  */
 182       if (readlen < 1 && n == 0)
 183         {
 184           generate_error (ERROR_END, NULL);
 185           return NULL;
 186         }
 187
 188       if (readlen < 1 || *q == '\n' || *q == '\r')
 189         {
 190           /* Unexpected end of line.  */
 191
 192           /* If we see an EOR during non-advancing I/O, we need to skip
 193              the rest of the I/O statement.  Set the corresponding flag.  */
 194           if (advance_status == ADVANCE_NO || g.seen_dollar)
 195             eor_condition = 1;
 196
 197           /* Without padding, terminate the I/O statement without assigning
 198              the value.  With padding, the value still needs to be assigned,
 199              so we can just continue with a short read.  */
 200           if (current_unit->flags.pad == PAD_NO)
 201             {
 202               generate_error (ERROR_EOR, NULL);
 203               return NULL;
 204             }
 205
 206           current_unit->bytes_left = 0;
 207           *length = n;
 208           sf_seen_eor = 1;
 209           break;
 210         }
 211
 212       n++;
 213       *p++ = *q;
 214       sf_seen_eor = 0;
 215     }
 216   while (n < *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              {
 680                 pos = f->u.n ;
 681                 pos= current_unit->recl - current_unit->bytes_left - pos;
 682              }
 683            else // FMT==T
 684              {
 685                 consume_data_flag = 0 ;
 686                 pos = f->u.n - 1;
 687              }
 688
 689            if (pos < 0 || pos >= current_unit->recl )
 690            {
 691              generate_error (ERROR_EOR, "T Or TL edit position error");
 692              break ;
 693             }
 694             m = pos - (current_unit->recl - current_unit->bytes_left);
 695
 696             if (m == 0)
 697                break;
 698
 699             if (m > 0)
 700              {
 701                f->u.n = m;
 702                if (g.mode == READING)
 703                  read_x (f);
 704                else
 705                  write_x (f);
 706              }
 707             if (m < 0)
 708              {
 709                move_pos_offset (current_unit->s,m);
 710              }
 711
 712           break;
 713
 714         case FMT_S:
 715           consume_data_flag = 0 ;
 716           g.sign_status = SIGN_S;
 717           break;
 718
 719         case FMT_SS:
 720           consume_data_flag = 0 ;
 721           g.sign_status = SIGN_SS;
 722           break;
 723
 724         case FMT_SP:
 725           consume_data_flag = 0 ;
 726           g.sign_status = SIGN_SP;
 727           break;
 728
 729         case FMT_BN:
 730           consume_data_flag = 0 ;
 731           g.blank_status = BLANK_NULL;
 732           break;
 733
 734         case FMT_BZ:
 735           consume_data_flag = 0 ;
 736           g.blank_status = BLANK_ZERO;
 737           break;
 738
 739         case FMT_P:
 740           consume_data_flag = 0 ;
 741           g.scale_factor = f->u.k;
 742           break;
 743
 744         case FMT_DOLLAR:
 745           consume_data_flag = 0 ;
 746           g.seen_dollar = 1;
 747           break;
 748
 749         case FMT_SLASH:
 750           consume_data_flag = 0 ;
 751           for (i = 0; i < f->repeat; i++)
 752             next_record (0);
 753
 754           break;
 755
 756         case FMT_COLON:
 757           /* A colon descriptor causes us to exit this loop (in
 758              particular preventing another / descriptor from being
 759              processed) unless there is another data item to be
 760              transferred.  */
 761           consume_data_flag = 0 ;
 762           if (n == 0)
 763             return;
 764           break;
 765
 766         default:
 767           internal_error ("Bad format node");
 768         }
 769
 770       /* Free a buffer that we had to allocate during a sequential
 771          formatted read of a block that was larger than the static
 772          buffer.  */
 773
 774       if (line_buffer != NULL)
 775         {
 776           free_mem (line_buffer);
 777           line_buffer = NULL;
 778         }
 779
 780       /* Adjust the item count and data pointer.  */
 781
 782       if ((consume_data_flag > 0) && (n > 0))
 783       {
 784         n--;
 785         p = ((char *) p) + len;
 786       }
 787     }
 788
 789   return;
 790
 791   /* Come here when we need a data descriptor but don't have one.  We
 792      push the current format node back onto the input, then return and
 793      let the user program call us back with the data.  */
 794  need_data:
 795   unget_format (f);
 796 }
 797
 798
 799 /* Data transfer entry points.  The type of the data entity is
 800    implicit in the subroutine call.  This prevents us from having to
 801    share a common enum with the compiler.  */
 802
 803 void
 804 transfer_integer (void *p, int kind)
 805 {
 806   g.item_count++;
 807   if (ioparm.library_return != LIBRARY_OK)
 808     return;
 809   transfer (BT_INTEGER, p, kind);
 810 }
 811
 812
 813 void
 814 transfer_real (void *p, int kind)
 815 {
 816   g.item_count++;
 817   if (ioparm.library_return != LIBRARY_OK)
 818     return;
 819   transfer (BT_REAL, p, kind);
 820 }
 821
 822
 823 void
 824 transfer_logical (void *p, int kind)
 825 {
 826   g.item_count++;
 827   if (ioparm.library_return != LIBRARY_OK)
 828     return;
 829   transfer (BT_LOGICAL, p, kind);
 830 }
 831
 832
 833 void
 834 transfer_character (void *p, int len)
 835 {
 836   g.item_count++;
 837   if (ioparm.library_return != LIBRARY_OK)
 838     return;
 839   transfer (BT_CHARACTER, p, len);
 840 }
 841
 842
 843 void
 844 transfer_complex (void *p, int kind)
 845 {
 846   g.item_count++;
 847   if (ioparm.library_return != LIBRARY_OK)
 848     return;
 849   transfer (BT_COMPLEX, p, kind);
 850 }
 851
 852
 853 /* Preposition a sequential unformatted file while reading.  */
 854
 855 static void
 856 us_read (void)
 857 {
 858   char *p;
 859   int n;
 860   gfc_offset i;
 861
 862   n = sizeof (gfc_offset);
 863   p = salloc_r (current_unit->s, &n);
 864
 865   if (n == 0)
 866     return;  /* end of file */
 867
 868   if (p == NULL || n != sizeof (gfc_offset))
 869     {
 870       generate_error (ERROR_BAD_US, NULL);
 871       return;
 872     }
 873
 874   memcpy (&i, p, sizeof (gfc_offset));
 875   current_unit->bytes_left = i;
 876 }
 877
 878
 879 /* Preposition a sequential unformatted file while writing.  This
 880    amount to writing a bogus length that will be filled in later.  */
 881
 882 static void
 883 us_write (void)
 884 {
 885   char *p;
 886   int length;
 887
 888   length = sizeof (gfc_offset);
 889   p = salloc_w (current_unit->s, &length);
 890
 891   if (p == NULL)
 892     {
 893       generate_error (ERROR_OS, NULL);
 894       return;
 895     }
 896
 897   memset (p, '\0', sizeof (gfc_offset));        /* Bogus value for now.  */
 898   if (sfree (current_unit->s) == FAILURE)
 899     generate_error (ERROR_OS, NULL);
 900
 901   /* For sequential unformatted, we write until we have more bytes than
 902      can fit in the record markers. If disk space runs out first, it will
 903      error on the write.  */
 904   current_unit->recl = g.max_offset;
 905
 906   current_unit->bytes_left = current_unit->recl;
 907 }
 908
 909
 910 /* Position to the next record prior to transfer.  We are assumed to
 911    be before the next record.  We also calculate the bytes in the next
 912    record.  */
 913
 914 static void
 915 pre_position (void)
 916 {
 917   if (current_unit->current_record)
 918     return;                     /* Already positioned.  */
 919
 920   switch (current_mode ())
 921     {
 922     case UNFORMATTED_SEQUENTIAL:
 923       if (g.mode == READING)
 924         us_read ();
 925       else
 926         us_write ();
 927
 928       break;
 929
 930     case FORMATTED_SEQUENTIAL:
 931     case FORMATTED_DIRECT:
 932     case UNFORMATTED_DIRECT:
 933       current_unit->bytes_left = current_unit->recl;
 934       break;
 935     }
 936
 937   current_unit->current_record = 1;
 938 }
 939
 940
 941 /* Initialize things for a data transfer.  This code is common for
 942    both reading and writing.  */
 943
 944 static void
 945 data_transfer_init (int read_flag)
 946 {
 947   unit_flags u_flags;  /* Used for creating a unit if needed.  */
 948
 949   g.mode = read_flag ? READING : WRITING;
 950
 951   if (ioparm.size != NULL)
 952     *ioparm.size = 0;           /* Initialize the count.  */
 953
 954   current_unit = get_unit (read_flag);
 955   if (current_unit == NULL)
 956   {  /* Open the unit with some default flags.  */
 957      if (ioparm.unit < 0)
 958      {
 959        generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
 960        library_end ();
 961        return;
 962      }
 963      memset (&u_flags, '\0', sizeof (u_flags));
 964      u_flags.access = ACCESS_SEQUENTIAL;
 965      u_flags.action = ACTION_READWRITE;
 966      /* Is it unformatted?  */
 967      if (ioparm.format == NULL && !ioparm.list_format)
 968        u_flags.form = FORM_UNFORMATTED;
 969      else
 970        u_flags.form = FORM_UNSPECIFIED;
 971      u_flags.delim = DELIM_UNSPECIFIED;
 972      u_flags.blank = BLANK_UNSPECIFIED;
 973      u_flags.pad = PAD_UNSPECIFIED;
 974      u_flags.status = STATUS_UNKNOWN;
 975      new_unit(&u_flags);
 976      current_unit = get_unit (read_flag);
 977   }
 978
 979   if (current_unit == NULL)
 980     return;
 981
 982   if (is_internal_unit())
 983     {
 984       current_unit->recl = file_length(current_unit->s);
 985       if (g.mode==WRITING)
 986         empty_internal_buffer (current_unit->s);
 987     }
 988
 989   /* Check the action.  */
 990
 991   if (read_flag && current_unit->flags.action == ACTION_WRITE)
 992     generate_error (ERROR_BAD_ACTION,
 993                     "Cannot read from file opened for WRITE");
 994
 995   if (!read_flag && current_unit->flags.action == ACTION_READ)
 996     generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
 997
 998   if (ioparm.library_return != LIBRARY_OK)
 999     return;
1000
1001   /* Check the format.  */
1002
1003   if (ioparm.format)
1004     parse_format ();
1005
1006   if (ioparm.library_return != LIBRARY_OK)
1007     return;
1008
1009   if (current_unit->flags.form == FORM_UNFORMATTED
1010       && (ioparm.format != NULL || ioparm.list_format))
1011     generate_error (ERROR_OPTION_CONFLICT,
1012                     "Format present for UNFORMATTED data transfer");
1013
1014   if (ioparm.namelist_name != NULL && ionml != NULL)
1015      {
1016         if(ioparm.format != NULL)
1017            generate_error (ERROR_OPTION_CONFLICT,
1018                     "A format cannot be specified with a namelist");
1019      }
1020   else if (current_unit->flags.form == FORM_FORMATTED &&
1021            ioparm.format == NULL && !ioparm.list_format)
1022     generate_error (ERROR_OPTION_CONFLICT,
1023                     "Missing format for FORMATTED data transfer");
1024
1025
1026   if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1027     generate_error (ERROR_OPTION_CONFLICT,
1028                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1029
1030   /* Check the record number.  */
1031
1032   if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1033     {
1034       generate_error (ERROR_MISSING_OPTION,
1035                       "Direct access data transfer requires record number");
1036       return;
1037     }
1038
1039   if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1040     {
1041       generate_error (ERROR_OPTION_CONFLICT,
1042                       "Record number not allowed for sequential access data transfer");
1043       return;
1044     }
1045
1046   /* Process the ADVANCE option.  */
1047
1048   advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1049     find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1050                  "Bad ADVANCE parameter in data transfer statement");
1051
1052   if (advance_status != ADVANCE_UNSPECIFIED)
1053     {
1054       if (current_unit->flags.access == ACCESS_DIRECT)
1055         generate_error (ERROR_OPTION_CONFLICT,
1056                         "ADVANCE specification conflicts with sequential access");
1057
1058       if (is_internal_unit ())
1059         generate_error (ERROR_OPTION_CONFLICT,
1060                         "ADVANCE specification conflicts with internal file");
1061
1062       if (ioparm.format == NULL || ioparm.list_format)
1063         generate_error (ERROR_OPTION_CONFLICT,
1064                         "ADVANCE specification requires an explicit format");
1065     }
1066
1067   if (read_flag)
1068     {
1069       if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
1070         generate_error (ERROR_MISSING_OPTION,
1071                         "EOR specification requires an ADVANCE specification of NO");
1072
1073       if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1074         generate_error (ERROR_MISSING_OPTION,
1075                         "SIZE specification requires an ADVANCE specification of NO");
1076
1077     }
1078   else
1079     {                           /* Write constraints.  */
1080       if (ioparm.end != 0)
1081         generate_error (ERROR_OPTION_CONFLICT,
1082                         "END specification cannot appear in a write statement");
1083
1084       if (ioparm.eor != 0)
1085         generate_error (ERROR_OPTION_CONFLICT,
1086                         "EOR specification cannot appear in a write statement");
1087
1088       if (ioparm.size != 0)
1089         generate_error (ERROR_OPTION_CONFLICT,
1090                         "SIZE specification cannot appear in a write statement");
1091     }
1092
1093   if (advance_status == ADVANCE_UNSPECIFIED)
1094     advance_status = ADVANCE_YES;
1095   if (ioparm.library_return != LIBRARY_OK)
1096     return;
1097
1098   /* Sanity checks on the record number.  */
1099
1100   if (ioparm.rec)
1101     {
1102       if (ioparm.rec <= 0)
1103         {
1104           generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1105           return;
1106         }
1107
1108       if (ioparm.rec >= current_unit->maxrec)
1109         {
1110           generate_error (ERROR_BAD_OPTION, "Record number too large");
1111           return;
1112         }
1113
1114       /* Check to see if we might be reading what we wrote before  */
1115
1116       if (g.mode == READING && current_unit->mode  == WRITING)
1117          flush(current_unit->s);
1118
1119       /* Position the file.  */
1120       if (sseek (current_unit->s,
1121                (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1122         generate_error (ERROR_OS, NULL);
1123     }
1124
1125   /* Overwriting an existing sequential file ?
1126      it is always safe to truncate the file on the first write */
1127   if (g.mode == WRITING
1128       && current_unit->flags.access == ACCESS_SEQUENTIAL
1129       && current_unit->current_record == 0)
1130         struncate(current_unit->s);
1131
1132   current_unit->mode = g.mode;
1133
1134   /* Set the initial value of flags.  */
1135
1136   g.blank_status = current_unit->flags.blank;
1137   g.sign_status = SIGN_S;
1138   g.scale_factor = 0;
1139   g.seen_dollar = 0;
1140   g.first_item = 1;
1141   g.item_count = 0;
1142   sf_seen_eor = 0;
1143   eor_condition = 0;
1144
1145   pre_position ();
1146
1147   /* Set up the subroutine that will handle the transfers.  */
1148
1149   if (read_flag)
1150     {
1151       if (current_unit->flags.form == FORM_UNFORMATTED)
1152         transfer = unformatted_read;
1153       else
1154         {
1155           if (ioparm.list_format)
1156             {
1157                transfer = list_formatted_read;
1158                init_at_eol();
1159             }
1160           else
1161             transfer = formatted_transfer;
1162         }
1163     }
1164   else
1165     {
1166       if (current_unit->flags.form == FORM_UNFORMATTED)
1167         transfer = unformatted_write;
1168       else
1169         {
1170           if (ioparm.list_format)
1171             transfer = list_formatted_write;
1172           else
1173             transfer = formatted_transfer;
1174         }
1175     }
1176
1177   /* Make sure that we don't do a read after a nonadvancing write.  */
1178
1179   if (read_flag)
1180     {
1181       if (current_unit->read_bad)
1182         {
1183           generate_error (ERROR_BAD_OPTION,
1184                           "Cannot READ after a nonadvancing WRITE");
1185           return;
1186         }
1187     }
1188   else
1189     {
1190       if (advance_status == ADVANCE_YES && !g.seen_dollar)
1191         current_unit->read_bad = 1;
1192     }
1193
1194   /* Start the data transfer if we are doing a formatted transfer.  */
1195   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1196       && ioparm.namelist_name == NULL && ionml == NULL)
1197     formatted_transfer (0, NULL, 0);
1198 }
1199
1200
1201 /* Space to the next record for read mode.  If the file is not
1202    seekable, we read MAX_READ chunks until we get to the right
1203    position.  */
1204
1205 #define MAX_READ 4096
1206
1207 static void
1208 next_record_r (void)
1209 {
1210   int rlength, length;
1211   gfc_offset new;
1212   char *p;
1213
1214   switch (current_mode ())
1215     {
1216     case UNFORMATTED_SEQUENTIAL:
1217       current_unit->bytes_left += sizeof (gfc_offset);  /* Skip over tail */
1218
1219       /* Fall through...  */
1220
1221     case FORMATTED_DIRECT:
1222     case UNFORMATTED_DIRECT:
1223       if (current_unit->bytes_left == 0)
1224         break;
1225
1226       if (is_seekable (current_unit->s))
1227         {
1228           new = file_position (current_unit->s) + current_unit->bytes_left;
1229
1230           /* Direct access files do not generate END conditions,
1231              only I/O errors.  */
1232           if (sseek (current_unit->s, new) == FAILURE)
1233             generate_error (ERROR_OS, NULL);
1234
1235         }
1236       else
1237         {                       /* Seek by reading data.  */
1238           while (current_unit->bytes_left > 0)
1239             {
1240               rlength = length = (MAX_READ > current_unit->bytes_left) ?
1241                 MAX_READ : current_unit->bytes_left;
1242
1243               p = salloc_r (current_unit->s, &rlength);
1244               if (p == NULL)
1245                 {
1246                   generate_error (ERROR_OS, NULL);
1247                   break;
1248                 }
1249
1250               current_unit->bytes_left -= length;
1251             }
1252         }
1253       break;
1254
1255     case FORMATTED_SEQUENTIAL:
1256       length = 1;
1257       /* sf_read has already terminated input because of an '\n'  */
1258       if (sf_seen_eor)
1259         {
1260           sf_seen_eor=0;
1261           break;
1262         }
1263
1264       do
1265         {
1266           p = salloc_r (current_unit->s, &length);
1267
1268           /* In case of internal file, there may not be any '\n'.  */
1269           if (is_internal_unit() && p == NULL)
1270             {
1271                break;
1272             }
1273
1274           if (p == NULL)
1275             {
1276               generate_error (ERROR_OS, NULL);
1277               break;
1278             }
1279
1280           if (length == 0)
1281             {
1282               current_unit->endfile = AT_ENDFILE;
1283               break;
1284             }
1285         }
1286       while (*p != '\n');
1287
1288       break;
1289     }
1290
1291   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1292     test_endfile (current_unit);
1293 }
1294
1295
1296 /* Position to the next record in write mode.  */
1297
1298 static void
1299 next_record_w (void)
1300 {
1301   gfc_offset c, m;
1302   int length;
1303   char *p;
1304
1305   switch (current_mode ())
1306     {
1307     case FORMATTED_DIRECT:
1308       if (current_unit->bytes_left == 0)
1309         break;
1310
1311       length = current_unit->bytes_left;
1312       p = salloc_w (current_unit->s, &length);
1313
1314       if (p == NULL)
1315         goto io_error;
1316
1317       memset (p, ' ', current_unit->bytes_left);
1318       if (sfree (current_unit->s) == FAILURE)
1319         goto io_error;
1320       break;
1321
1322     case UNFORMATTED_DIRECT:
1323       if (sfree (current_unit->s) == FAILURE)
1324         goto io_error;
1325       break;
1326
1327     case UNFORMATTED_SEQUENTIAL:
1328       m = current_unit->recl - current_unit->bytes_left; /* Bytes written.  */
1329       c = file_position (current_unit->s);
1330
1331       length = sizeof (gfc_offset);
1332
1333       /* Write the length tail.  */
1334
1335       p = salloc_w (current_unit->s, &length);
1336       if (p == NULL)
1337         goto io_error;
1338
1339       memcpy (p, &m, sizeof (gfc_offset));
1340       if (sfree (current_unit->s) == FAILURE)
1341         goto io_error;
1342
1343       /* Seek to the head and overwrite the bogus length with the real
1344          length.  */
1345
1346       p = salloc_w_at (current_unit->s, &length, c - m - length);
1347       if (p == NULL)
1348         generate_error (ERROR_OS, NULL);
1349
1350       memcpy (p, &m, sizeof (gfc_offset));
1351       if (sfree (current_unit->s) == FAILURE)
1352         goto io_error;
1353
1354       /* Seek past the end of the current record.  */
1355
1356       if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1357         goto io_error;
1358
1359       break;
1360
1361     case FORMATTED_SEQUENTIAL:
1362       length = 1;
1363       p = salloc_w (current_unit->s, &length);
1364
1365       if (!is_internal_unit())
1366         {
1367           if (p)
1368             *p = '\n'; /* No CR for internal writes.  */
1369           else
1370             goto io_error;
1371         }
1372
1373       if (sfree (current_unit->s) == FAILURE)
1374         goto io_error;
1375
1376       break;
1377
1378     io_error:
1379       generate_error (ERROR_OS, NULL);
1380       break;
1381     }
1382 }
1383
1384
1385 /* Position to the next record, which means moving to the end of the
1386    current record.  This can happen under several different
1387    conditions.  If the done flag is not set, we get ready to process
1388    the next record.  */
1389
1390 void
1391 next_record (int done)
1392 {
1393   gfc_offset fp; /* File position.  */
1394
1395   current_unit->read_bad = 0;
1396
1397   if (g.mode == READING)
1398     next_record_r ();
1399   else
1400     next_record_w ();
1401
1402   /* keep position up to date for INQUIRE */
1403   current_unit->flags.position = POSITION_ASIS;
1404
1405   current_unit->current_record = 0;
1406   if (current_unit->flags.access == ACCESS_DIRECT)
1407    {
1408     fp = file_position (current_unit->s);
1409     /* Calculate next record, rounding up partial records.  */
1410     current_unit->last_record = (fp + current_unit->recl - 1)
1411                                 / current_unit->recl;
1412    }
1413   else
1414     current_unit->last_record++;
1415
1416   if (!done)
1417     pre_position ();
1418 }
1419
1420
1421 /* Finalize the current data transfer.  For a nonadvancing transfer,
1422    this means advancing to the next record.  For internal units close the
1423    steam associated with the unit.  */
1424
1425 static void
1426 finalize_transfer (void)
1427 {
1428
1429   if (eor_condition)
1430     {
1431       generate_error (ERROR_EOR, NULL);
1432       return;
1433     }
1434
1435   if (ioparm.library_return != LIBRARY_OK)
1436     return;
1437
1438   if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1439     {
1440        if (ioparm.namelist_read_mode)
1441          namelist_read();
1442        else
1443          namelist_write();
1444     }
1445
1446   transfer = NULL;
1447   if (current_unit == NULL)
1448     return;
1449
1450   if (setjmp (g.eof_jump))
1451     {
1452       generate_error (ERROR_END, NULL);
1453       return;
1454     }
1455
1456   if (ioparm.list_format && g.mode == READING)
1457     finish_list_read ();
1458   else
1459     {
1460       free_fnodes ();
1461
1462       if (advance_status == ADVANCE_NO || g.seen_dollar)
1463         {
1464           /* Most systems buffer lines, so force the partial record
1465              to be written out.  */
1466           flush (current_unit->s);
1467           g.seen_dollar = 0;
1468           return;
1469         }
1470
1471       next_record (1);
1472       current_unit->current_record = 0;
1473     }
1474
1475   sfree (current_unit->s);
1476
1477   if (is_internal_unit ())
1478     sclose (current_unit->s);
1479 }
1480
1481
1482 /* Transfer function for IOLENGTH. It doesn't actually do any
1483    data transfer, it just updates the length counter.  */
1484
1485 static void
1486 iolength_transfer (bt type   __attribute__ ((unused)),
1487                    void *dest __attribute__ ((unused)),
1488                    int len)
1489 {
1490   if (ioparm.iolength != NULL)
1491     *ioparm.iolength += len;
1492 }
1493
1494
1495 /* Initialize the IOLENGTH data transfer. This function is in essence
1496    a very much simplified version of data_transfer_init(), because it
1497    doesn't have to deal with units at all.  */
1498
1499 static void
1500 iolength_transfer_init (void)
1501 {
1502   if (ioparm.iolength != NULL)
1503     *ioparm.iolength = 0;
1504
1505   g.item_count = 0;
1506
1507   /* Set up the subroutine that will handle the transfers.  */
1508
1509   transfer = iolength_transfer;
1510 }
1511
1512
1513 /* Library entry point for the IOLENGTH form of the INQUIRE
1514    statement. The IOLENGTH form requires no I/O to be performed, but
1515    it must still be a runtime library call so that we can determine
1516    the iolength for dynamic arrays and such.  */
1517
1518 extern void st_iolength (void);
1519 export_proto(st_iolength);
1520
1521 void
1522 st_iolength (void)
1523 {
1524   library_start ();
1525   iolength_transfer_init ();
1526 }
1527
1528 extern void st_iolength_done (void);
1529 export_proto(st_iolength_done);
1530
1531 void
1532 st_iolength_done (void)
1533 {
1534   library_end ();
1535 }
1536
1537
1538 /* The READ statement.  */
1539
1540 extern void st_read (void);
1541 export_proto(st_read);
1542
1543 void
1544 st_read (void)
1545 {
1546   library_start ();
1547
1548   data_transfer_init (1);
1549
1550   /* Handle complications dealing with the endfile record.  It is
1551      significant that this is the only place where ERROR_END is
1552      generated.  Reading an end of file elsewhere is either end of
1553      record or an I/O error. */
1554
1555   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1556     switch (current_unit->endfile)
1557       {
1558       case NO_ENDFILE:
1559         break;
1560
1561       case AT_ENDFILE:
1562         if (!is_internal_unit())
1563           {
1564             generate_error (ERROR_END, NULL);
1565             current_unit->endfile = AFTER_ENDFILE;
1566           }
1567         break;
1568
1569       case AFTER_ENDFILE:
1570         generate_error (ERROR_ENDFILE, NULL);
1571         break;
1572       }
1573 }
1574
1575 extern void st_read_done (void);
1576 export_proto(st_read_done);
1577
1578 void
1579 st_read_done (void)
1580 {
1581   finalize_transfer ();
1582   library_end ();
1583 }
1584
1585 extern void st_write (void);
1586 export_proto(st_write);
1587
1588 void
1589 st_write (void)
1590 {
1591   library_start ();
1592   data_transfer_init (0);
1593 }
1594
1595 extern void st_write_done (void);
1596 export_proto(st_write_done);
1597
1598 void
1599 st_write_done (void)
1600 {
1601   finalize_transfer ();
1602
1603   /* Deal with endfile conditions associated with sequential files.  */
1604
1605   if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1606     switch (current_unit->endfile)
1607       {
1608       case AT_ENDFILE:          /* Remain at the endfile record.  */
1609         break;
1610
1611       case AFTER_ENDFILE:
1612         current_unit->endfile = AT_ENDFILE;     /* Just at it now.  */
1613         break;
1614
1615       case NO_ENDFILE:
1616         if (current_unit->current_record > current_unit->last_record)
1617           {
1618             /* Get rid of whatever is after this record.  */
1619             if (struncate (current_unit->s) == FAILURE)
1620               generate_error (ERROR_OS, NULL);
1621           }
1622
1623         current_unit->endfile = AT_ENDFILE;
1624         break;
1625       }
1626
1627   library_end ();
1628 }
1629
1630 /* Receives the scalar information for namelist objects and stores it
1631    in a linked list of namelist_info types.  */
1632
1633 extern void st_set_nml_var (void * ,char * ,
1634                             GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
1635 export_proto(st_set_nml_var);
1636
1637
1638 void
1639 st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
1640                 gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
1641 {
1642   namelist_info *t1 = NULL;
1643   namelist_info *nml;
1644
1645   nml = (namelist_info*) get_mem (sizeof (namelist_info));
1646
1647   nml->mem_pos = var_addr;
1648
1649   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
1650   strcpy (nml->var_name, var_name);
1651
1652   nml->len = (int) len;
1653   nml->string_length = (index_type) string_length;
1654
1655   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
1656   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
1657   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
1658
1659   if (nml->var_rank > 0)
1660     {
1661       nml->dim = (descriptor_dimension*)
1662                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
1663       nml->ls = (nml_loop_spec*)
1664                   get_mem (nml->var_rank * sizeof (nml_loop_spec));
1665     }
1666   else
1667     {
1668       nml->dim = NULL;
1669       nml->ls = NULL;
1670     }
1671
1672   nml->next = NULL;
1673
1674   if (ionml == NULL)
1675     ionml = nml;
1676   else
1677     {
1678       for (t1 = ionml; t1->next; t1 = t1->next);
1679       t1->next = nml;
1680     }
1681   return;
1682 }
1683
1684 /* Store the dimensional information for the namelist object.  */
1685 extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
1686                                 GFC_INTEGER_4 ,GFC_INTEGER_4);
1687 export_proto(st_set_nml_var_dim);
1688
1689 void
1690 st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
1691                     GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
1692 {
1693   namelist_info * nml;
1694   int n;
1695
1696   n = (int)n_dim;
1697
1698   for (nml = ionml; nml->next; nml = nml->next);
1699
1700   nml->dim[n].stride = (ssize_t)stride;
1701   nml->dim[n].lbound = (ssize_t)lbound;
1702   nml->dim[n].ubound = (ssize_t)ubound;
1703 }