libgfortran/io/transfer.c

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