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