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