libgfortran/io/transfer.c

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