libgfortran/io/transfer.c

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