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