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 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')
 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')
 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      memset (&u_flags, '\0', sizeof (u_flags));
 939      u_flags.access = ACCESS_SEQUENTIAL;
 940      u_flags.action = ACTION_READWRITE;
 941      /* Is it unformatted?  */
 942      if (ioparm.format == NULL && !ioparm.list_format)
 943        u_flags.form = FORM_UNFORMATTED;
 944      else
 945        u_flags.form = FORM_UNSPECIFIED;
 946      u_flags.delim = DELIM_UNSPECIFIED;
 947      u_flags.blank = BLANK_UNSPECIFIED;
 948      u_flags.pad = PAD_UNSPECIFIED;
 949      u_flags.status = STATUS_UNKNOWN;
 950      new_unit(&u_flags);
 951      current_unit = get_unit (read_flag);
 952   }
 953
 954   if (current_unit == NULL)
 955     return;
 956
 957   if (is_internal_unit())
 958     {
 959       current_unit->recl = file_length(current_unit->s);
 960       if (g.mode==WRITING)
 961         empty_internal_buffer (current_unit->s);
 962     }
 963
 964   /* Check the action.  */
 965
 966   if (read_flag && current_unit->flags.action == ACTION_WRITE)
 967     generate_error (ERROR_BAD_ACTION,
 968                     "Cannot read from file opened for WRITE");
 969
 970   if (!read_flag && current_unit->flags.action == ACTION_READ)
 971     generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
 972
 973   if (ioparm.library_return != LIBRARY_OK)
 974     return;
 975
 976   /* Check the format.  */
 977
 978   if (ioparm.format)
 979     parse_format ();
 980
 981   if (ioparm.library_return != LIBRARY_OK)
 982     return;
 983
 984   if (current_unit->flags.form == FORM_UNFORMATTED
 985       && (ioparm.format != NULL || ioparm.list_format))
 986     generate_error (ERROR_OPTION_CONFLICT,
 987                     "Format present for UNFORMATTED data transfer");
 988
 989   if (ioparm.namelist_name != NULL && ionml != NULL)
 990      {
 991         if(ioparm.format != NULL)
 992            generate_error (ERROR_OPTION_CONFLICT,
 993                     "A format cannot be specified with a namelist");
 994      }
 995   else if (current_unit->flags.form == FORM_FORMATTED &&
 996            ioparm.format == NULL && !ioparm.list_format)
 997     generate_error (ERROR_OPTION_CONFLICT,
 998                     "Missing format for FORMATTED data transfer");
 999
1000
1001   if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1002     generate_error (ERROR_OPTION_CONFLICT,
1003                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1004
1005   /* Check the record number.  */
1006
1007   if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1008     {
1009       generate_error (ERROR_MISSING_OPTION,
1010                       "Direct access data transfer requires record number");
1011       return;
1012     }
1013
1014   if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1015     {
1016       generate_error (ERROR_OPTION_CONFLICT,
1017                       "Record number not allowed for sequential access data transfer");
1018       return;
1019     }
1020
1021   /* Process the ADVANCE option.  */
1022
1023   advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1024     find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1025                  "Bad ADVANCE parameter in data transfer statement");
1026
1027   if (advance_status != ADVANCE_UNSPECIFIED)
1028     {
1029       if (current_unit->flags.access == ACCESS_DIRECT)
1030         generate_error (ERROR_OPTION_CONFLICT,
1031                         "ADVANCE specification conflicts with sequential access");
1032
1033       if (is_internal_unit ())
1034         generate_error (ERROR_OPTION_CONFLICT,
1035                         "ADVANCE specification conflicts with internal file");
1036
1037       if (ioparm.format == NULL || ioparm.list_format)
1038         generate_error (ERROR_OPTION_CONFLICT,
1039                         "ADVANCE specification requires an explicit format");
1040     }
1041
1042   if (read_flag)
1043     {
1044       if (ioparm.eor != 0 && advance_status == ADVANCE_NO)
1045         generate_error (ERROR_MISSING_OPTION,
1046                         "EOR specification requires an ADVANCE specification of NO");
1047
1048       if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1049         generate_error (ERROR_MISSING_OPTION,
1050                         "SIZE specification requires an ADVANCE specification of NO");
1051
1052     }
1053   else
1054     {                           /* Write constraints.  */
1055       if (ioparm.end != 0)
1056         generate_error (ERROR_OPTION_CONFLICT,
1057                         "END specification cannot appear in a write statement");
1058
1059       if (ioparm.eor != 0)
1060         generate_error (ERROR_OPTION_CONFLICT,
1061                         "EOR specification cannot appear in a write statement");
1062
1063       if (ioparm.size != 0)
1064         generate_error (ERROR_OPTION_CONFLICT,
1065                         "SIZE specification cannot appear in a write statement");
1066     }
1067
1068   if (advance_status == ADVANCE_UNSPECIFIED)
1069     advance_status = ADVANCE_YES;
1070   if (ioparm.library_return != LIBRARY_OK)
1071     return;
1072
1073   /* Sanity checks on the record number.  */
1074
1075   if (ioparm.rec)
1076     {
1077       if (ioparm.rec <= 0)
1078         {
1079           generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1080           return;
1081         }
1082
1083       if (ioparm.rec >= current_unit->maxrec)
1084         {
1085           generate_error (ERROR_BAD_OPTION, "Record number too large");
1086           return;
1087         }
1088
1089       /* Check to see if we might be reading what we wrote before  */
1090
1091       if (g.mode == READING && current_unit->mode  == WRITING)
1092          flush(current_unit->s);
1093
1094       /* Position the file.  */
1095       if (sseek (current_unit->s,
1096                (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1097         generate_error (ERROR_OS, NULL);
1098     }
1099
1100   current_unit->mode = g.mode;
1101
1102   /* Set the initial value of flags.  */
1103
1104   g.blank_status = current_unit->flags.blank;
1105   g.sign_status = SIGN_S;
1106   g.scale_factor = 0;
1107   g.seen_dollar = 0;
1108   g.first_item = 1;
1109   g.item_count = 0;
1110   sf_seen_eor = 0;
1111
1112   pre_position ();
1113
1114   /* Set up the subroutine that will handle the transfers.  */
1115
1116   if (read_flag)
1117     {
1118       if (current_unit->flags.form == FORM_UNFORMATTED)
1119         transfer = unformatted_read;
1120       else
1121         {
1122           if (ioparm.list_format)
1123             {
1124                transfer = list_formatted_read;
1125                init_at_eol();
1126             }
1127           else
1128             transfer = formatted_transfer;
1129         }
1130     }
1131   else
1132     {
1133       if (current_unit->flags.form == FORM_UNFORMATTED)
1134         transfer = unformatted_write;
1135       else
1136         {
1137           if (ioparm.list_format)
1138             transfer = list_formatted_write;
1139           else
1140             transfer = formatted_transfer;
1141         }
1142     }
1143
1144   /* Make sure that we don't do a read after a nonadvancing write.  */
1145
1146   if (read_flag)
1147     {
1148       if (current_unit->read_bad)
1149         {
1150           generate_error (ERROR_BAD_OPTION,
1151                           "Cannot READ after a nonadvancing WRITE");
1152           return;
1153         }
1154     }
1155   else
1156     {
1157       if (advance_status == ADVANCE_YES)
1158         current_unit->read_bad = 1;
1159     }
1160
1161   /* Start the data transfer if we are doing a formatted transfer.  */
1162   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1163       && ioparm.namelist_name == NULL && ionml == NULL)
1164     formatted_transfer (0, NULL, 0);
1165 }
1166
1167
1168 /* Space to the next record for read mode.  If the file is not
1169    seekable, we read MAX_READ chunks until we get to the right
1170    position.  */
1171
1172 #define MAX_READ 4096
1173
1174 static void
1175 next_record_r (int done)
1176 {
1177   int rlength, length;
1178   gfc_offset new;
1179   char *p;
1180
1181   switch (current_mode ())
1182     {
1183     case UNFORMATTED_SEQUENTIAL:
1184       current_unit->bytes_left += sizeof (gfc_offset);  /* Skip over tail */
1185
1186       /* Fall through...  */
1187
1188     case FORMATTED_DIRECT:
1189     case UNFORMATTED_DIRECT:
1190       if (current_unit->bytes_left == 0)
1191         break;
1192
1193       if (is_seekable (current_unit->s))
1194         {
1195           new = file_position (current_unit->s) + current_unit->bytes_left;
1196
1197           /* Direct access files do not generate END conditions,
1198              only I/O errors.  */
1199           if (sseek (current_unit->s, new) == FAILURE)
1200             generate_error (ERROR_OS, NULL);
1201
1202         }
1203       else
1204         {                       /* Seek by reading data.  */
1205           while (current_unit->bytes_left > 0)
1206             {
1207               rlength = length = (MAX_READ > current_unit->bytes_left) ?
1208                 MAX_READ : current_unit->bytes_left;
1209
1210               p = salloc_r (current_unit->s, &rlength);
1211               if (p == NULL)
1212                 {
1213                   generate_error (ERROR_OS, NULL);
1214                   break;
1215                 }
1216
1217               current_unit->bytes_left -= length;
1218             }
1219         }
1220       break;
1221
1222     case FORMATTED_SEQUENTIAL:
1223       length = 1;
1224       /* sf_read has already terminated input because of an '\n'  */
1225       if (sf_seen_eor)
1226          break;
1227
1228       do
1229         {
1230           p = salloc_r (current_unit->s, &length);
1231
1232           /* In case of internal file, there may not be any '\n'.  */
1233           if (is_internal_unit() && p == NULL)
1234             {
1235                break;
1236             }
1237
1238           if (p == NULL)
1239             {
1240               generate_error (ERROR_OS, NULL);
1241               break;
1242             }
1243
1244           if (length == 0)
1245             {
1246               current_unit->endfile = AT_ENDFILE;
1247               break;
1248             }
1249         }
1250       while (*p != '\n');
1251
1252       break;
1253     }
1254
1255   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1256     test_endfile (current_unit);
1257 }
1258
1259
1260 /* Position to the next record in write mode.  */
1261
1262 static void
1263 next_record_w (int done)
1264 {
1265   gfc_offset c, m;
1266   int length;
1267   char *p;
1268
1269   switch (current_mode ())
1270     {
1271     case FORMATTED_DIRECT:
1272       if (current_unit->bytes_left == 0)
1273         break;
1274
1275       length = current_unit->bytes_left;
1276       p = salloc_w (current_unit->s, &length);
1277
1278       if (p == NULL)
1279         goto io_error;
1280
1281       memset (p, ' ', current_unit->bytes_left);
1282       if (sfree (current_unit->s) == FAILURE)
1283         goto io_error;
1284       break;
1285
1286     case UNFORMATTED_DIRECT:
1287       if (sfree (current_unit->s) == FAILURE)
1288         goto io_error;
1289       break;
1290
1291     case UNFORMATTED_SEQUENTIAL:
1292       m = current_unit->recl - current_unit->bytes_left; /* Bytes written.  */
1293       c = file_position (current_unit->s);
1294
1295       length = sizeof (gfc_offset);
1296
1297       /* Write the length tail.  */
1298
1299       p = salloc_w (current_unit->s, &length);
1300       if (p == NULL)
1301         goto io_error;
1302
1303       memcpy (p, &m, sizeof (gfc_offset));
1304       if (sfree (current_unit->s) == FAILURE)
1305         goto io_error;
1306
1307       /* Seek to the head and overwrite the bogus length with the real
1308          length.  */
1309
1310       p = salloc_w_at (current_unit->s, &length, c - m - length);
1311       if (p == NULL)
1312         generate_error (ERROR_OS, NULL);
1313
1314       memcpy (p, &m, sizeof (gfc_offset));
1315       if (sfree (current_unit->s) == FAILURE)
1316         goto io_error;
1317
1318       /* Seek past the end of the current record.  */
1319
1320       if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1321         goto io_error;
1322
1323       break;
1324
1325     case FORMATTED_SEQUENTIAL:
1326       length = 1;
1327       p = salloc_w (current_unit->s, &length);
1328
1329       if (!is_internal_unit())
1330         {
1331           if (p)
1332             *p = '\n'; /* No CR for internal writes.  */
1333           else
1334             goto io_error;
1335         }
1336
1337       if (sfree (current_unit->s) == FAILURE)
1338         goto io_error;
1339
1340       break;
1341
1342     io_error:
1343       generate_error (ERROR_OS, NULL);
1344       break;
1345     }
1346 }
1347
1348
1349 /* Position to the next record, which means moving to the end of the
1350    current record.  This can happen under several different
1351    conditions.  If the done flag is not set, we get ready to process
1352    the next record.  */
1353
1354 void
1355 next_record (int done)
1356 {
1357   gfc_offset fp; /* File position.  */
1358
1359   current_unit->read_bad = 0;
1360
1361   if (g.mode == READING)
1362     next_record_r (done);
1363   else
1364     next_record_w (done);
1365
1366   /* keep position up to date for INQUIRE */
1367   current_unit->flags.position = POSITION_ASIS;
1368
1369   current_unit->current_record = 0;
1370   if (current_unit->flags.access == ACCESS_DIRECT)
1371    {
1372     fp = file_position (current_unit->s);
1373     /* Calculate next record, rounding up partial records.  */
1374     current_unit->last_record = (fp + current_unit->recl - 1)
1375                                 / current_unit->recl;
1376    }
1377   else
1378     current_unit->last_record++;
1379
1380   if (!done)
1381     pre_position ();
1382 }
1383
1384
1385 /* Finalize the current data transfer.  For a nonadvancing transfer,
1386    this means advancing to the next record.  For internal units close the
1387    steam associated with the unit.  */
1388
1389 static void
1390 finalize_transfer (void)
1391 {
1392   if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1393     {
1394        if (ioparm.namelist_read_mode)
1395          namelist_read();
1396        else
1397          namelist_write();
1398     }
1399
1400   transfer = NULL;
1401   if (current_unit == NULL)
1402     return;
1403
1404   if (setjmp (g.eof_jump))
1405     {
1406       generate_error (ERROR_END, NULL);
1407       return;
1408     }
1409
1410   if (ioparm.list_format && g.mode == READING)
1411     finish_list_read ();
1412   else
1413     {
1414       free_fnodes ();
1415
1416       if (advance_status == ADVANCE_NO)
1417         {
1418           /* Most systems buffer lines, so force the partial record
1419              to be written out.  */
1420           flush (current_unit->s);
1421           return;
1422         }
1423
1424       next_record (1);
1425       current_unit->current_record = 0;
1426     }
1427
1428   sfree (current_unit->s);
1429
1430   if (is_internal_unit ())
1431     sclose (current_unit->s);
1432 }
1433
1434
1435 /* Transfer function for IOLENGTH. It doesn't actually do any
1436    data transfer, it just updates the length counter.  */
1437
1438 static void
1439 iolength_transfer (bt type, void *dest, int len)
1440 {
1441   if (ioparm.iolength != NULL)
1442     *ioparm.iolength += len;
1443 }
1444
1445
1446 /* Initialize the IOLENGTH data transfer. This function is in essence
1447    a very much simplified version of data_transfer_init(), because it
1448    doesn't have to deal with units at all.  */
1449
1450 static void
1451 iolength_transfer_init (void)
1452 {
1453   if (ioparm.iolength != NULL)
1454     *ioparm.iolength = 0;
1455
1456   g.item_count = 0;
1457
1458   /* Set up the subroutine that will handle the transfers.  */
1459
1460   transfer = iolength_transfer;
1461 }
1462
1463
1464 /* Library entry point for the IOLENGTH form of the INQUIRE
1465    statement. The IOLENGTH form requires no I/O to be performed, but
1466    it must still be a runtime library call so that we can determine
1467    the iolength for dynamic arrays and such.  */
1468
1469 extern void st_iolength (void);
1470 export_proto(st_iolength);
1471
1472 void
1473 st_iolength (void)
1474 {
1475   library_start ();
1476   iolength_transfer_init ();
1477 }
1478
1479 extern void st_iolength_done (void);
1480 export_proto(st_iolength_done);
1481
1482 void
1483 st_iolength_done (void)
1484 {
1485   library_end ();
1486 }
1487
1488
1489 /* The READ statement.  */
1490
1491 extern void st_read (void);
1492 export_proto(st_read);
1493
1494 void
1495 st_read (void)
1496 {
1497   library_start ();
1498
1499   data_transfer_init (1);
1500
1501   /* Handle complications dealing with the endfile record.  It is
1502      significant that this is the only place where ERROR_END is
1503      generated.  Reading an end of file elsewhere is either end of
1504      record or an I/O error. */
1505
1506   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1507     switch (current_unit->endfile)
1508       {
1509       case NO_ENDFILE:
1510         break;
1511
1512       case AT_ENDFILE:
1513         if (!is_internal_unit())
1514           {
1515             generate_error (ERROR_END, NULL);
1516             current_unit->endfile = AFTER_ENDFILE;
1517           }
1518         break;
1519
1520       case AFTER_ENDFILE:
1521         generate_error (ERROR_ENDFILE, NULL);
1522         break;
1523       }
1524 }
1525
1526 extern void st_read_done (void);
1527 export_proto(st_read_done);
1528
1529 void
1530 st_read_done (void)
1531 {
1532   finalize_transfer ();
1533   library_end ();
1534 }
1535
1536 extern void st_write (void);
1537 export_proto(st_write);
1538
1539 void
1540 st_write (void)
1541 {
1542   library_start ();
1543   data_transfer_init (0);
1544 }
1545
1546 extern void st_write_done (void);
1547 export_proto(st_write_done);
1548
1549 void
1550 st_write_done (void)
1551 {
1552   finalize_transfer ();
1553
1554   /* Deal with endfile conditions associated with sequential files.  */
1555
1556   if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1557     switch (current_unit->endfile)
1558       {
1559       case AT_ENDFILE:          /* Remain at the endfile record.  */
1560         break;
1561
1562       case AFTER_ENDFILE:
1563         current_unit->endfile = AT_ENDFILE;     /* Just at it now.  */
1564         break;
1565
1566       case NO_ENDFILE:
1567         if (current_unit->current_record > current_unit->last_record)
1568           {
1569             /* Get rid of whatever is after this record.  */
1570             if (struncate (current_unit->s) == FAILURE)
1571               generate_error (ERROR_OS, NULL);
1572           }
1573
1574         current_unit->endfile = AT_ENDFILE;
1575         break;
1576       }
1577
1578   library_end ();
1579 }
1580
1581
1582 static void
1583 st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
1584                 int kind, bt type, int string_length)
1585 {
1586   namelist_info *t1 = NULL, *t2 = NULL;
1587   namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
1588   nml->mem_pos = var_addr;
1589   if (var_name)
1590     {
1591       assert (var_name_len > 0);
1592       nml->var_name = (char*) get_mem (var_name_len+1);
1593       strncpy (nml->var_name, var_name, var_name_len);
1594       nml->var_name[var_name_len] = 0;
1595     }
1596   else
1597     {
1598       assert (var_name_len == 0);
1599       nml->var_name = NULL;
1600     }
1601
1602   nml->len = kind;
1603   nml->type = type;
1604   nml->string_length = string_length;
1605
1606   nml->next = NULL;
1607
1608   if (ionml == NULL)
1609      ionml = nml;
1610   else
1611     {
1612       t1 = ionml;
1613       while (t1 != NULL)
1614        {
1615          t2 = t1;
1616          t1 = t1->next;
1617        }
1618        t2->next = nml;
1619     }
1620 }
1621
1622 extern void st_set_nml_var_int (void *, char *, int, int);
1623 export_proto(st_set_nml_var_int);
1624
1625 extern void st_set_nml_var_float (void *, char *, int, int);
1626 export_proto(st_set_nml_var_float);
1627
1628 extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
1629 export_proto(st_set_nml_var_char);
1630
1631 extern void st_set_nml_var_complex (void *, char *, int, int);
1632 export_proto(st_set_nml_var_complex);
1633
1634 extern void st_set_nml_var_log (void *, char *, int, int);
1635 export_proto(st_set_nml_var_log);
1636
1637 void
1638 st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
1639                     int kind)
1640 {
1641   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
1642 }
1643
1644 void
1645 st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
1646                       int kind)
1647 {
1648   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
1649 }
1650
1651 void
1652 st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
1653                      int kind, gfc_charlen_type string_length)
1654 {
1655   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
1656                   string_length);
1657 }
1658
1659 void
1660 st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
1661                         int kind)
1662 {
1663   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
1664 }
1665
1666 void
1667 st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
1668                     int kind)
1669 {
1670    st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0);
1671 }