libgfortran/io/transfer.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    Namelist transfer functions contributed by Paul Thomas
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31
  32 /* transfer.c -- Top level handling of data transfer statements.  */
  33
  34 #include "config.h"
  35 #include <string.h>
  36 #include <assert.h>
  37 #include "libgfortran.h"
  38 #include "io.h"
  39
  40
  41 /* Calling conventions:  Data transfer statements are unlike other
  42    library calls in that they extend over several calls.
  43
  44    The first call is always a call to st_read() or st_write().  These
  45    subroutines return no status unless a namelist read or write is
  46    being done, in which case there is the usual status.  No further
  47    calls are necessary in this case.
  48
  49    For other sorts of data transfer, there are zero or more data
  50    transfer statement that depend on the format of the data transfer
  51    statement.
  52
  53       transfer_integer
  54       transfer_logical
  55       transfer_character
  56       transfer_real
  57       transfer_complex
  58
  59     These subroutines do not return status.
  60
  61     The last call is a call to st_[read|write]_done().  While
  62     something can easily go wrong with the initial st_read() or
  63     st_write(), an error inhibits any data from actually being
  64     transferred.  */
  65
  66 extern void transfer_integer (void *, int);
  67 export_proto(transfer_integer);
  68
  69 extern void transfer_real (void *, int);
  70 export_proto(transfer_real);
  71
  72 extern void transfer_logical (void *, int);
  73 export_proto(transfer_logical);
  74
  75 extern void transfer_character (void *, int);
  76 export_proto(transfer_character);
  77
  78 extern void transfer_complex (void *, int);
  79 export_proto(transfer_complex);
  80
  81 extern void transfer_array (gfc_array_char *, int, gfc_charlen_type);
  82 export_proto(transfer_array);
  83
  84 gfc_unit *current_unit = NULL;
  85 static int sf_seen_eor = 0;
  86 static int eor_condition = 0;
  87
  88 /* Maximum righthand column written to.  */
  89 static int max_pos;
  90 /* Number of skips + spaces to be done for T and X-editing.  */
  91 static int skips;
  92 /* Number of spaces to be done for T and X-editing.  */
  93 static int pending_spaces;
  94
  95 char scratch[SCRATCH_SIZE];
  96 static char *line_buffer = NULL;
  97
  98 static unit_advance advance_status;
  99
 100 static const st_option advance_opt[] = {
 101   {"yes", ADVANCE_YES},
 102   {"no", ADVANCE_NO},
 103   {NULL, 0}
 104 };
 105
 106
 107 static void (*transfer) (bt, void *, int, size_t, size_t);
 108
 109
 110 typedef enum
 111 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
 112   FORMATTED_DIRECT, UNFORMATTED_DIRECT
 113 }
 114 file_mode;
 115
 116
 117 static file_mode
 118 current_mode (void)
 119 {
 120   file_mode m;
 121
 122   if (current_unit->flags.access == ACCESS_DIRECT)
 123     {
 124       m = current_unit->flags.form == FORM_FORMATTED ?
 125         FORMATTED_DIRECT : UNFORMATTED_DIRECT;
 126     }
 127   else
 128     {
 129       m = current_unit->flags.form == FORM_FORMATTED ?
 130         FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
 131     }
 132
 133   return m;
 134 }
 135
 136
 137 /* Mid level data transfer statements.  These subroutines do reading
 138    and writing in the style of salloc_r()/salloc_w() within the
 139    current record.  */
 140
 141 /* When reading sequential formatted records we have a problem.  We
 142    don't know how long the line is until we read the trailing newline,
 143    and we don't want to read too much.  If we read too much, we might
 144    have to do a physical seek backwards depending on how much data is
 145    present, and devices like terminals aren't seekable and would cause
 146    an I/O error.
 147
 148    Given this, the solution is to read a byte at a time, stopping if
 149    we hit the newline.  For small locations, we use a static buffer.
 150    For larger allocations, we are forced to allocate memory on the
 151    heap.  Hopefully this won't happen very often.  */
 152
 153 static char *
 154 read_sf (int *length)
 155 {
 156   static char data[SCRATCH_SIZE];
 157   char *base, *p, *q;
 158   int n, readlen;
 159
 160   if (*length > SCRATCH_SIZE)
 161     p = base = line_buffer = get_mem (*length);
 162   else
 163     p = base = data;
 164
 165   /* If we have seen an eor previously, return a length of 0.  The
 166      caller is responsible for correctly padding the input field.  */
 167   if (sf_seen_eor)
 168     {
 169       *length = 0;
 170       return base;
 171     }
 172
 173   readlen = 1;
 174   n = 0;
 175
 176   do
 177     {
 178       if (is_internal_unit())
 179         {
 180           /* readlen may be modified inside salloc_r if
 181              is_internal_unit() is true.  */
 182           readlen = 1;
 183         }
 184
 185       q = salloc_r (current_unit->s, &readlen);
 186       if (q == NULL)
 187         break;
 188
 189       /* If we have a line without a terminating \n, drop through to
 190          EOR below.  */
 191       if (readlen < 1 && n == 0)
 192         {
 193           generate_error (ERROR_END, NULL);
 194           return NULL;
 195         }
 196
 197       if (readlen < 1 || *q == '\n' || *q == '\r')
 198         {
 199           /* Unexpected end of line.  */
 200
 201           /* If we see an EOR during non-advancing I/O, we need to skip
 202              the rest of the I/O statement.  Set the corresponding flag.  */
 203           if (advance_status == ADVANCE_NO || g.seen_dollar)
 204             eor_condition = 1;
 205
 206           /* Without padding, terminate the I/O statement without assigning
 207              the value.  With padding, the value still needs to be assigned,
 208              so we can just continue with a short read.  */
 209           if (current_unit->flags.pad == PAD_NO)
 210             {
 211               generate_error (ERROR_EOR, NULL);
 212               return NULL;
 213             }
 214
 215           current_unit->bytes_left = 0;
 216           *length = n;
 217           sf_seen_eor = 1;
 218           break;
 219         }
 220
 221       n++;
 222       *p++ = *q;
 223       sf_seen_eor = 0;
 224     }
 225   while (n < *length);
 226   current_unit->bytes_left -= *length;
 227
 228   if (ioparm.size != NULL)
 229     *ioparm.size += *length;
 230
 231   return base;
 232 }
 233
 234
 235 /* Function for reading the next couple of bytes from the current
 236    file, advancing the current position.  We return a pointer to a
 237    buffer containing the bytes.  We return NULL on end of record or
 238    end of file.
 239
 240    If the read is short, then it is because the current record does not
 241    have enough data to satisfy the read request and the file was
 242    opened with PAD=YES.  The caller must assume tailing spaces for
 243    short reads.  */
 244
 245 void *
 246 read_block (int *length)
 247 {
 248   char *source;
 249   int nread;
 250
 251   if (current_unit->bytes_left < *length)
 252     {
 253       if (current_unit->flags.pad == PAD_NO)
 254         {
 255           generate_error (ERROR_EOR, NULL); /* Not enough data left.  */
 256           return NULL;
 257         }
 258
 259       *length = current_unit->bytes_left;
 260     }
 261
 262   if (current_unit->flags.form == FORM_FORMATTED &&
 263       current_unit->flags.access == ACCESS_SEQUENTIAL)
 264     return read_sf (length);    /* Special case.  */
 265
 266   current_unit->bytes_left -= *length;
 267
 268   nread = *length;
 269   source = salloc_r (current_unit->s, &nread);
 270
 271   if (ioparm.size != NULL)
 272     *ioparm.size += nread;
 273
 274   if (nread != *length)
 275     {                           /* Short read, this shouldn't happen.  */
 276       if (current_unit->flags.pad == PAD_YES)
 277         *length = nread;
 278       else
 279         {
 280           generate_error (ERROR_EOR, NULL);
 281           source = NULL;
 282         }
 283     }
 284
 285   return source;
 286 }
 287
 288
 289 /* Reads a block directly into application data space.  */
 290
 291 static void
 292 read_block_direct (void * buf, size_t * nbytes)
 293 {
 294   int *length;
 295   void *data;
 296   size_t nread;
 297
 298   if (current_unit->bytes_left < *nbytes)
 299     {
 300       if (current_unit->flags.pad == PAD_NO)
 301         {
 302           generate_error (ERROR_EOR, NULL); /* Not enough data left.  */
 303           return;
 304         }
 305
 306       *nbytes = current_unit->bytes_left;
 307     }
 308
 309   if (current_unit->flags.form == FORM_FORMATTED &&
 310       current_unit->flags.access == ACCESS_SEQUENTIAL)
 311     {
 312       length = (int*) nbytes;
 313       data = read_sf (length);  /* Special case.  */
 314       memcpy (buf, data, (size_t) *length);
 315       return;
 316     }
 317
 318   current_unit->bytes_left -= *nbytes;
 319
 320   nread = *nbytes;
 321   if (sread (current_unit->s, buf, &nread) != 0)
 322     {
 323       generate_error (ERROR_OS, NULL);
 324       return;
 325     }
 326
 327   if (ioparm.size != NULL)
 328     *ioparm.size += (GFC_INTEGER_4) nread;
 329
 330   if (nread != *nbytes)
 331     {                           /* Short read, e.g. if we hit EOF.  */
 332       if (current_unit->flags.pad == PAD_YES)
 333         {
 334           memset (((char *) buf) + nread, ' ', *nbytes - nread);
 335           *nbytes = nread;
 336         }
 337       else
 338         generate_error (ERROR_EOR, NULL);
 339     }
 340 }
 341
 342
 343 /* Function for writing a block of bytes to the current file at the
 344    current position, advancing the file pointer. We are given a length
 345    and return a pointer to a buffer that the caller must (completely)
 346    fill in.  Returns NULL on error.  */
 347
 348 void *
 349 write_block (int length)
 350 {
 351   char *dest;
 352
 353   if (current_unit->bytes_left < length)
 354     {
 355       generate_error (ERROR_EOR, NULL);
 356       return NULL;
 357     }
 358
 359   current_unit->bytes_left -= (gfc_offset)length;
 360   dest = salloc_w (current_unit->s, &length);
 361
 362   if (dest == NULL)
 363     {
 364       generate_error (ERROR_END, NULL);
 365       return NULL;
 366     }
 367
 368   if (ioparm.size != NULL)
 369     *ioparm.size += length;
 370
 371   return dest;
 372 }
 373
 374
 375 /* Writes a block directly without necessarily allocating space in a
 376    buffer.  */
 377
 378 static void
 379 write_block_direct (void * buf, size_t * nbytes)
 380 {
 381   if (current_unit->bytes_left < *nbytes)
 382     generate_error (ERROR_EOR, NULL);
 383
 384   current_unit->bytes_left -= (gfc_offset) *nbytes;
 385
 386   if (swrite (current_unit->s, buf, nbytes) != 0)
 387     generate_error (ERROR_OS, NULL);
 388
 389   if (ioparm.size != NULL)
 390     *ioparm.size += (GFC_INTEGER_4) *nbytes;
 391 }
 392
 393
 394 /* Master function for unformatted reads.  */
 395
 396 static void
 397 unformatted_read (bt type __attribute__((unused)), void *dest,
 398                  int kind __attribute__((unused)),
 399                  size_t size, size_t nelems)
 400 {
 401   size *= nelems;
 402
 403   read_block_direct (dest, &size);
 404 }
 405
 406
 407 /* Master function for unformatted writes.  */
 408
 409 static void
 410 unformatted_write (bt type __attribute__((unused)), void *source,
 411                   int kind __attribute__((unused)),
 412                   size_t size, size_t nelems)
 413 {
 414   size *= nelems;
 415
 416   write_block_direct (source, &size);
 417 }
 418
 419
 420 /* Return a pointer to the name of a type.  */
 421
 422 const char *
 423 type_name (bt type)
 424 {
 425   const char *p;
 426
 427   switch (type)
 428     {
 429     case BT_INTEGER:
 430       p = "INTEGER";
 431       break;
 432     case BT_LOGICAL:
 433       p = "LOGICAL";
 434       break;
 435     case BT_CHARACTER:
 436       p = "CHARACTER";
 437       break;
 438     case BT_REAL:
 439       p = "REAL";
 440       break;
 441     case BT_COMPLEX:
 442       p = "COMPLEX";
 443       break;
 444     default:
 445       internal_error ("type_name(): Bad type");
 446     }
 447
 448   return p;
 449 }
 450
 451
 452 /* Write a constant string to the output.
 453    This is complicated because the string can have doubled delimiters
 454    in it.  The length in the format node is the true length.  */
 455
 456 static void
 457 write_constant_string (fnode * f)
 458 {
 459   char c, delimiter, *p, *q;
 460   int length;
 461
 462   length = f->u.string.length;
 463   if (length == 0)
 464     return;
 465
 466   p = write_block (length);
 467   if (p == NULL)
 468     return;
 469
 470   q = f->u.string.p;
 471   delimiter = q[-1];
 472
 473   for (; length > 0; length--)
 474     {
 475       c = *p++ = *q++;
 476       if (c == delimiter && c != 'H' && c != 'h')
 477         q++;                    /* Skip the doubled delimiter.  */
 478     }
 479 }
 480
 481
 482 /* Given actual and expected types in a formatted data transfer, make
 483    sure they agree.  If not, an error message is generated.  Returns
 484    nonzero if something went wrong.  */
 485
 486 static int
 487 require_type (bt expected, bt actual, fnode * f)
 488 {
 489   char buffer[100];
 490
 491   if (actual == expected)
 492     return 0;
 493
 494   st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
 495               type_name (expected), g.item_count, type_name (actual));
 496
 497   format_error (f, buffer);
 498   return 1;
 499 }
 500
 501
 502 /* This subroutine is the main loop for a formatted data transfer
 503    statement.  It would be natural to implement this as a coroutine
 504    with the user program, but C makes that awkward.  We loop,
 505    processesing format elements.  When we actually have to transfer
 506    data instead of just setting flags, we return control to the user
 507    program which calls a subroutine that supplies the address and type
 508    of the next element, then comes back here to process it.  */
 509
 510 static void
 511 formatted_transfer_scalar (bt type, void *p, int len, size_t size)
 512 {
 513   int pos, bytes_used;
 514   fnode *f;
 515   format_token t;
 516   int n;
 517   int consume_data_flag;
 518
 519   /* Change a complex data item into a pair of reals.  */
 520
 521   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
 522   if (type == BT_COMPLEX)
 523     {
 524       type = BT_REAL;
 525       size /= 2;
 526     }
 527
 528   /* If there's an EOR condition, we simulate finalizing the transfer
 529      by doing nothing.  */
 530   if (eor_condition)
 531     return;
 532
 533   for (;;)
 534     {
 535       /* If reversion has occurred and there is another real data item,
 536          then we have to move to the next record.  */
 537       if (g.reversion_flag && n > 0)
 538         {
 539           g.reversion_flag = 0;
 540           next_record (0);
 541         }
 542
 543       consume_data_flag = 1 ;
 544       if (ioparm.library_return != LIBRARY_OK)
 545         break;
 546
 547       f = next_format ();
 548       if (f == NULL)
 549         return;       /* No data descriptors left (already raised).  */
 550
 551       /* Now discharge T, TR and X movements to the right.  This is delayed
 552          until a data producing format to suppress trailing spaces.  */
 553       t = f->format;
 554       if (g.mode == WRITING && skips != 0
 555         && ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
 556                     || t == FMT_Z  || t == FMT_F  || t == FMT_E
 557                     || t == FMT_EN || t == FMT_ES || t == FMT_G
 558                     || t == FMT_L  || t == FMT_A  || t == FMT_D))
 559             || t == FMT_STRING))
 560         {
 561           if (skips > 0)
 562             {
 563               write_x (skips, pending_spaces);
 564               max_pos = (int)(current_unit->recl - current_unit->bytes_left);
 565             }
 566           if (skips < 0)
 567             {
 568               move_pos_offset (current_unit->s, skips);
 569               current_unit->bytes_left -= (gfc_offset)skips;
 570             }
 571           skips = pending_spaces = 0;
 572         }
 573
 574       bytes_used = (int)(current_unit->recl - current_unit->bytes_left);
 575
 576       switch (t)
 577         {
 578         case FMT_I:
 579           if (n == 0)
 580             goto need_data;
 581           if (require_type (BT_INTEGER, type, f))
 582             return;
 583
 584           if (g.mode == READING)
 585             read_decimal (f, p, len);
 586           else
 587             write_i (f, p, len);
 588
 589           break;
 590
 591         case FMT_B:
 592           if (n == 0)
 593             goto need_data;
 594           if (require_type (BT_INTEGER, type, f))
 595             return;
 596
 597           if (g.mode == READING)
 598             read_radix (f, p, len, 2);
 599           else
 600             write_b (f, p, len);
 601
 602           break;
 603
 604         case FMT_O:
 605           if (n == 0)
 606             goto need_data;
 607
 608           if (g.mode == READING)
 609             read_radix (f, p, len, 8);
 610           else
 611             write_o (f, p, len);
 612
 613           break;
 614
 615         case FMT_Z:
 616           if (n == 0)
 617             goto need_data;
 618
 619           if (g.mode == READING)
 620             read_radix (f, p, len, 16);
 621           else
 622             write_z (f, p, len);
 623
 624           break;
 625
 626         case FMT_A:
 627           if (n == 0)
 628             goto need_data;
 629
 630           if (g.mode == READING)
 631             read_a (f, p, len);
 632           else
 633             write_a (f, p, len);
 634
 635           break;
 636
 637         case FMT_L:
 638           if (n == 0)
 639             goto need_data;
 640
 641           if (g.mode == READING)
 642             read_l (f, p, len);
 643           else
 644             write_l (f, p, len);
 645
 646           break;
 647
 648         case FMT_D:
 649           if (n == 0)
 650             goto need_data;
 651           if (require_type (BT_REAL, type, f))
 652             return;
 653
 654           if (g.mode == READING)
 655             read_f (f, p, len);
 656           else
 657             write_d (f, p, len);
 658
 659           break;
 660
 661         case FMT_E:
 662           if (n == 0)
 663             goto need_data;
 664           if (require_type (BT_REAL, type, f))
 665             return;
 666
 667           if (g.mode == READING)
 668             read_f (f, p, len);
 669           else
 670             write_e (f, p, len);
 671           break;
 672
 673         case FMT_EN:
 674           if (n == 0)
 675             goto need_data;
 676           if (require_type (BT_REAL, type, f))
 677             return;
 678
 679           if (g.mode == READING)
 680             read_f (f, p, len);
 681           else
 682             write_en (f, p, len);
 683
 684           break;
 685
 686         case FMT_ES:
 687           if (n == 0)
 688             goto need_data;
 689           if (require_type (BT_REAL, type, f))
 690             return;
 691
 692           if (g.mode == READING)
 693             read_f (f, p, len);
 694           else
 695             write_es (f, p, len);
 696
 697           break;
 698
 699         case FMT_F:
 700           if (n == 0)
 701             goto need_data;
 702           if (require_type (BT_REAL, type, f))
 703             return;
 704
 705           if (g.mode == READING)
 706             read_f (f, p, len);
 707           else
 708             write_f (f, p, len);
 709
 710           break;
 711
 712         case FMT_G:
 713           if (n == 0)
 714             goto need_data;
 715           if (g.mode == READING)
 716             switch (type)
 717               {
 718               case BT_INTEGER:
 719                 read_decimal (f, p, len);
 720                 break;
 721               case BT_LOGICAL:
 722                 read_l (f, p, len);
 723                 break;
 724               case BT_CHARACTER:
 725                 read_a (f, p, len);
 726                 break;
 727               case BT_REAL:
 728                 read_f (f, p, len);
 729                 break;
 730               default:
 731                 goto bad_type;
 732               }
 733           else
 734             switch (type)
 735               {
 736               case BT_INTEGER:
 737                 write_i (f, p, len);
 738                 break;
 739               case BT_LOGICAL:
 740                 write_l (f, p, len);
 741                 break;
 742               case BT_CHARACTER:
 743                 write_a (f, p, len);
 744                 break;
 745               case BT_REAL:
 746                 write_d (f, p, len);
 747                 break;
 748               default:
 749               bad_type:
 750                 internal_error ("formatted_transfer(): Bad type");
 751               }
 752
 753           break;
 754
 755         case FMT_STRING:
 756           consume_data_flag = 0 ;
 757           if (g.mode == READING)
 758             {
 759               format_error (f, "Constant string in input format");
 760               return;
 761             }
 762           write_constant_string (f);
 763           break;
 764
 765         /* Format codes that don't transfer data.  */
 766         case FMT_X:
 767         case FMT_TR:
 768           consume_data_flag = 0 ;
 769
 770           pos = bytes_used + f->u.n + skips;
 771           skips = f->u.n + skips;
 772           pending_spaces = pos - max_pos;
 773
 774           /* Writes occur just before the switch on f->format, above, so that
 775              trailing blanks are suppressed.  */
 776           if (g.mode == READING)
 777             read_x (f->u.n);
 778
 779           break;
 780
 781         case FMT_TL:
 782         case FMT_T:
 783           if (f->format == FMT_TL)
 784             pos = bytes_used - f->u.n;
 785           else /* FMT_T */
 786             {
 787               consume_data_flag = 0;
 788               pos = f->u.n - 1;
 789             }
 790
 791           /* Standard 10.6.1.1: excessive left tabbing is reset to the
 792              left tab limit.  We do not check if the position has gone
 793              beyond the end of record because a subsequent tab could
 794              bring us back again.  */
 795           pos = pos < 0 ? 0 : pos;
 796
 797           skips = skips + pos - bytes_used;
 798           pending_spaces =  pending_spaces + pos - max_pos;
 799
 800           if (skips == 0)
 801             break;
 802
 803           /* Writes occur just before the switch on f->format, above, so that
 804              trailing blanks are suppressed.  */
 805           if (g.mode == READING)
 806             {
 807               if (skips > 0)
 808                 read_x (skips);
 809               if (skips < 0)
 810                 {
 811                   move_pos_offset (current_unit->s, skips);
 812                   current_unit->bytes_left -= (gfc_offset)skips;
 813                   skips = pending_spaces = 0;
 814                 }
 815             }
 816
 817           break;
 818
 819         case FMT_S:
 820           consume_data_flag = 0 ;
 821           g.sign_status = SIGN_S;
 822           break;
 823
 824         case FMT_SS:
 825           consume_data_flag = 0 ;
 826           g.sign_status = SIGN_SS;
 827           break;
 828
 829         case FMT_SP:
 830           consume_data_flag = 0 ;
 831           g.sign_status = SIGN_SP;
 832           break;
 833
 834         case FMT_BN:
 835           consume_data_flag = 0 ;
 836           g.blank_status = BLANK_NULL;
 837           break;
 838
 839         case FMT_BZ:
 840           consume_data_flag = 0 ;
 841           g.blank_status = BLANK_ZERO;
 842           break;
 843
 844         case FMT_P:
 845           consume_data_flag = 0 ;
 846           g.scale_factor = f->u.k;
 847           break;
 848
 849         case FMT_DOLLAR:
 850           consume_data_flag = 0 ;
 851           g.seen_dollar = 1;
 852           break;
 853
 854         case FMT_SLASH:
 855           consume_data_flag = 0 ;
 856           skips = pending_spaces = 0;
 857           next_record (0);
 858           break;
 859
 860         case FMT_COLON:
 861           /* A colon descriptor causes us to exit this loop (in
 862              particular preventing another / descriptor from being
 863              processed) unless there is another data item to be
 864              transferred.  */
 865           consume_data_flag = 0 ;
 866           if (n == 0)
 867             return;
 868           break;
 869
 870         default:
 871           internal_error ("Bad format node");
 872         }
 873
 874       /* Free a buffer that we had to allocate during a sequential
 875          formatted read of a block that was larger than the static
 876          buffer.  */
 877
 878       if (line_buffer != NULL)
 879         {
 880           free_mem (line_buffer);
 881           line_buffer = NULL;
 882         }
 883
 884       /* Adjust the item count and data pointer.  */
 885
 886       if ((consume_data_flag > 0) && (n > 0))
 887       {
 888         n--;
 889         p = ((char *) p) + size;
 890       }
 891
 892       if (g.mode == READING)
 893         skips = 0;
 894
 895       pos = (int)(current_unit->recl - current_unit->bytes_left);
 896       max_pos = (max_pos > pos) ? max_pos : pos;
 897
 898     }
 899
 900   return;
 901
 902   /* Come here when we need a data descriptor but don't have one.  We
 903      push the current format node back onto the input, then return and
 904      let the user program call us back with the data.  */
 905  need_data:
 906   unget_format (f);
 907 }
 908
 909 static void
 910 formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems)
 911 {
 912   size_t elem;
 913   char *tmp;
 914
 915   tmp = (char *) p;
 916
 917   /* Big loop over all the elements.  */
 918   for (elem = 0; elem < nelems; elem++)
 919     {
 920       g.item_count++;
 921       formatted_transfer_scalar (type, tmp + size*elem, kind, size);
 922     }
 923 }
 924
 925
 926
 927 /* Data transfer entry points.  The type of the data entity is
 928    implicit in the subroutine call.  This prevents us from having to
 929    share a common enum with the compiler.  */
 930
 931 void
 932 transfer_integer (void *p, int kind)
 933 {
 934   if (ioparm.library_return != LIBRARY_OK)
 935     return;
 936   transfer (BT_INTEGER, p, kind, kind, 1);
 937 }
 938
 939
 940 void
 941 transfer_real (void *p, int kind)
 942 {
 943   size_t size;
 944   if (ioparm.library_return != LIBRARY_OK)
 945     return;
 946   size = size_from_real_kind (kind);
 947   transfer (BT_REAL, p, kind, size, 1);
 948 }
 949
 950
 951 void
 952 transfer_logical (void *p, int kind)
 953 {
 954   if (ioparm.library_return != LIBRARY_OK)
 955     return;
 956   transfer (BT_LOGICAL, p, kind, kind, 1);
 957 }
 958
 959
 960 void
 961 transfer_character (void *p, int len)
 962 {
 963   if (ioparm.library_return != LIBRARY_OK)
 964     return;
 965   /* Currently we support only 1 byte chars, and the library is a bit
 966      confused of character kind vs. length, so we kludge it by setting
 967      kind = length.  */
 968   transfer (BT_CHARACTER, p, len, len, 1);
 969 }
 970
 971
 972 void
 973 transfer_complex (void *p, int kind)
 974 {
 975   size_t size;
 976   if (ioparm.library_return != LIBRARY_OK)
 977     return;
 978   size = size_from_complex_kind (kind);
 979   transfer (BT_COMPLEX, p, kind, size, 1);
 980 }
 981
 982
 983 void
 984 transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
 985 {
 986   index_type count[GFC_MAX_DIMENSIONS];
 987   index_type extent[GFC_MAX_DIMENSIONS];
 988   index_type stride[GFC_MAX_DIMENSIONS];
 989   index_type stride0, rank, size, type, n;
 990   size_t tsize;
 991   char *data;
 992   bt iotype;
 993
 994   if (ioparm.library_return != LIBRARY_OK)
 995     return;
 996
 997   type = GFC_DESCRIPTOR_TYPE (desc);
 998   size = GFC_DESCRIPTOR_SIZE (desc);
 999
1000   /* FIXME: What a kludge: Array descriptors and the IO library use
1001      different enums for types.  */
1002   switch (type)
1003     {
1004     case GFC_DTYPE_UNKNOWN:
1005       iotype = BT_NULL;  /* Is this correct?  */
1006       break;
1007     case GFC_DTYPE_INTEGER:
1008       iotype = BT_INTEGER;
1009       break;
1010     case GFC_DTYPE_LOGICAL:
1011       iotype = BT_LOGICAL;
1012       break;
1013     case GFC_DTYPE_REAL:
1014       iotype = BT_REAL;
1015       break;
1016     case GFC_DTYPE_COMPLEX:
1017       iotype = BT_COMPLEX;
1018       break;
1019     case GFC_DTYPE_CHARACTER:
1020       iotype = BT_CHARACTER;
1021       /* FIXME: Currently dtype contains the charlen, which is
1022          clobbered if charlen > 2**24. That's why we use a separate
1023          argument for the charlen. However, if we want to support
1024          non-8-bit charsets we need to fix dtype to contain
1025          sizeof(chartype) and fix the code below.  */
1026       size = charlen;
1027       kind = charlen;
1028       break;
1029     case GFC_DTYPE_DERIVED:
1030       internal_error ("Derived type I/O should have been handled via the frontend.");
1031       break;
1032     default:
1033       internal_error ("transfer_array(): Bad type");
1034     }
1035
1036   if (desc->dim[0].stride == 0)
1037     desc->dim[0].stride = 1;
1038
1039   rank = GFC_DESCRIPTOR_RANK (desc);
1040   for (n = 0; n < rank; n++)
1041     {
1042       count[n] = 0;
1043       stride[n] = desc->dim[n].stride;
1044       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1045
1046       /* If the extent of even one dimension is zero, then the entire
1047          array section contains zero elements, so we return.  */
1048       if (extent[n] == 0)
1049         return;
1050     }
1051
1052   stride0 = stride[0];
1053
1054   /* If the innermost dimension has stride 1, we can do the transfer
1055      in contiguous chunks.  */
1056   if (stride0 == 1)
1057     tsize = extent[0];
1058   else
1059     tsize = 1;
1060
1061   data = GFC_DESCRIPTOR_DATA (desc);
1062
1063   while (data)
1064     {
1065       transfer (iotype, data, kind, size, tsize);
1066       data += stride0 * size * tsize;
1067       count[0] += tsize;
1068       n = 0;
1069       while (count[n] == extent[n])
1070         {
1071           count[n] = 0;
1072           data -= stride[n] * extent[n] * size;
1073           n++;
1074           if (n == rank)
1075             {
1076               data = NULL;
1077               break;
1078             }
1079           else
1080             {
1081               count[n]++;
1082               data += stride[n] * size;
1083             }
1084         }
1085     }
1086 }
1087
1088
1089 /* Preposition a sequential unformatted file while reading.  */
1090
1091 static void
1092 us_read (void)
1093 {
1094   char *p;
1095   int n;
1096   gfc_offset i;
1097
1098   n = sizeof (gfc_offset);
1099   p = salloc_r (current_unit->s, &n);
1100
1101   if (n == 0)
1102     return;  /* end of file */
1103
1104   if (p == NULL || n != sizeof (gfc_offset))
1105     {
1106       generate_error (ERROR_BAD_US, NULL);
1107       return;
1108     }
1109
1110   memcpy (&i, p, sizeof (gfc_offset));
1111   current_unit->bytes_left = i;
1112 }
1113
1114
1115 /* Preposition a sequential unformatted file while writing.  This
1116    amount to writing a bogus length that will be filled in later.  */
1117
1118 static void
1119 us_write (void)
1120 {
1121   char *p;
1122   int length;
1123
1124   length = sizeof (gfc_offset);
1125   p = salloc_w (current_unit->s, &length);
1126
1127   if (p == NULL)
1128     {
1129       generate_error (ERROR_OS, NULL);
1130       return;
1131     }
1132
1133   memset (p, '\0', sizeof (gfc_offset));        /* Bogus value for now.  */
1134   if (sfree (current_unit->s) == FAILURE)
1135     generate_error (ERROR_OS, NULL);
1136
1137   /* For sequential unformatted, we write until we have more bytes than
1138      can fit in the record markers. If disk space runs out first, it will
1139      error on the write.  */
1140   current_unit->recl = g.max_offset;
1141
1142   current_unit->bytes_left = current_unit->recl;
1143 }
1144
1145
1146 /* Position to the next record prior to transfer.  We are assumed to
1147    be before the next record.  We also calculate the bytes in the next
1148    record.  */
1149
1150 static void
1151 pre_position (void)
1152 {
1153   if (current_unit->current_record)
1154     return;                     /* Already positioned.  */
1155
1156   switch (current_mode ())
1157     {
1158     case UNFORMATTED_SEQUENTIAL:
1159       if (g.mode == READING)
1160         us_read ();
1161       else
1162         us_write ();
1163
1164       break;
1165
1166     case FORMATTED_SEQUENTIAL:
1167     case FORMATTED_DIRECT:
1168     case UNFORMATTED_DIRECT:
1169       current_unit->bytes_left = current_unit->recl;
1170       break;
1171     }
1172
1173   current_unit->current_record = 1;
1174 }
1175
1176
1177 /* Initialize things for a data transfer.  This code is common for
1178    both reading and writing.  */
1179
1180 static void
1181 data_transfer_init (int read_flag)
1182 {
1183   unit_flags u_flags;  /* Used for creating a unit if needed.  */
1184
1185   g.mode = read_flag ? READING : WRITING;
1186
1187   if (ioparm.size != NULL)
1188     *ioparm.size = 0;           /* Initialize the count.  */
1189
1190   current_unit = get_unit (read_flag);
1191   if (current_unit == NULL)
1192   {  /* Open the unit with some default flags.  */
1193      if (ioparm.unit < 0)
1194      {
1195        generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
1196        library_end ();
1197        return;
1198      }
1199      memset (&u_flags, '\0', sizeof (u_flags));
1200      u_flags.access = ACCESS_SEQUENTIAL;
1201      u_flags.action = ACTION_READWRITE;
1202      /* Is it unformatted?  */
1203      if (ioparm.format == NULL && !ioparm.list_format)
1204        u_flags.form = FORM_UNFORMATTED;
1205      else
1206        u_flags.form = FORM_UNSPECIFIED;
1207      u_flags.delim = DELIM_UNSPECIFIED;
1208      u_flags.blank = BLANK_UNSPECIFIED;
1209      u_flags.pad = PAD_UNSPECIFIED;
1210      u_flags.status = STATUS_UNKNOWN;
1211      new_unit(&u_flags);
1212      current_unit = get_unit (read_flag);
1213   }
1214
1215   if (current_unit == NULL)
1216     return;
1217
1218   /* Check the action.  */
1219
1220   if (read_flag && current_unit->flags.action == ACTION_WRITE)
1221     generate_error (ERROR_BAD_ACTION,
1222                     "Cannot read from file opened for WRITE");
1223
1224   if (!read_flag && current_unit->flags.action == ACTION_READ)
1225     generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
1226
1227   if (ioparm.library_return != LIBRARY_OK)
1228     return;
1229
1230   /* Check the format.  */
1231
1232   if (ioparm.format)
1233     parse_format ();
1234
1235   if (ioparm.library_return != LIBRARY_OK)
1236     return;
1237
1238   if (current_unit->flags.form == FORM_UNFORMATTED
1239       && (ioparm.format != NULL || ioparm.list_format))
1240     generate_error (ERROR_OPTION_CONFLICT,
1241                     "Format present for UNFORMATTED data transfer");
1242
1243   if (ioparm.namelist_name != NULL && ionml != NULL)
1244      {
1245         if(ioparm.format != NULL)
1246            generate_error (ERROR_OPTION_CONFLICT,
1247                     "A format cannot be specified with a namelist");
1248      }
1249   else if (current_unit->flags.form == FORM_FORMATTED &&
1250            ioparm.format == NULL && !ioparm.list_format)
1251     generate_error (ERROR_OPTION_CONFLICT,
1252                     "Missing format for FORMATTED data transfer");
1253
1254
1255   if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1256     generate_error (ERROR_OPTION_CONFLICT,
1257                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1258
1259   /* Check the record number.  */
1260
1261   if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1262     {
1263       generate_error (ERROR_MISSING_OPTION,
1264                       "Direct access data transfer requires record number");
1265       return;
1266     }
1267
1268   if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1269     {
1270       generate_error (ERROR_OPTION_CONFLICT,
1271                       "Record number not allowed for sequential access data transfer");
1272       return;
1273     }
1274
1275   /* Process the ADVANCE option.  */
1276
1277   advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1278     find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1279                  "Bad ADVANCE parameter in data transfer statement");
1280
1281   if (advance_status != ADVANCE_UNSPECIFIED)
1282     {
1283       if (current_unit->flags.access == ACCESS_DIRECT)
1284         generate_error (ERROR_OPTION_CONFLICT,
1285                         "ADVANCE specification conflicts with sequential access");
1286
1287       if (is_internal_unit ())
1288         generate_error (ERROR_OPTION_CONFLICT,
1289                         "ADVANCE specification conflicts with internal file");
1290
1291       if (ioparm.format == NULL || ioparm.list_format)
1292         generate_error (ERROR_OPTION_CONFLICT,
1293                         "ADVANCE specification requires an explicit format");
1294     }
1295
1296   if (read_flag)
1297     {
1298       if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
1299         generate_error (ERROR_MISSING_OPTION,
1300                         "EOR specification requires an ADVANCE specification of NO");
1301
1302       if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1303         generate_error (ERROR_MISSING_OPTION,
1304                         "SIZE specification requires an ADVANCE specification of NO");
1305
1306     }
1307   else
1308     {                           /* Write constraints.  */
1309       if (ioparm.end != 0)
1310         generate_error (ERROR_OPTION_CONFLICT,
1311                         "END specification cannot appear in a write statement");
1312
1313       if (ioparm.eor != 0)
1314         generate_error (ERROR_OPTION_CONFLICT,
1315                         "EOR specification cannot appear in a write statement");
1316
1317       if (ioparm.size != 0)
1318         generate_error (ERROR_OPTION_CONFLICT,
1319                         "SIZE specification cannot appear in a write statement");
1320     }
1321
1322   if (advance_status == ADVANCE_UNSPECIFIED)
1323     advance_status = ADVANCE_YES;
1324   if (ioparm.library_return != LIBRARY_OK)
1325     return;
1326
1327   /* Sanity checks on the record number.  */
1328
1329   if (ioparm.rec)
1330     {
1331       if (ioparm.rec <= 0)
1332         {
1333           generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1334           return;
1335         }
1336
1337       if (ioparm.rec >= current_unit->maxrec)
1338         {
1339           generate_error (ERROR_BAD_OPTION, "Record number too large");
1340           return;
1341         }
1342
1343       /* Check to see if we might be reading what we wrote before  */
1344
1345       if (g.mode == READING && current_unit->mode  == WRITING)
1346          flush(current_unit->s);
1347
1348       /* Check whether the record exists to be read.  Only
1349          a partial record needs to exist.  */
1350
1351       if (g.mode == READING && (ioparm.rec -1)
1352           * current_unit->recl >= file_length (current_unit->s))
1353         {
1354           generate_error (ERROR_BAD_OPTION, "Non-existing record number");
1355           return;
1356         }
1357
1358       /* Position the file.  */
1359       if (sseek (current_unit->s,
1360                (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1361         {
1362           generate_error (ERROR_OS, NULL);
1363           return;
1364         }
1365     }
1366
1367   /* Overwriting an existing sequential file ?
1368      it is always safe to truncate the file on the first write */
1369   if (g.mode == WRITING
1370       && current_unit->flags.access == ACCESS_SEQUENTIAL
1371       && current_unit->last_record == 0 && !is_preconnected(current_unit->s))
1372         struncate(current_unit->s);
1373
1374   /* Bugware for badly written mixed C-Fortran I/O.  */
1375   flush_if_preconnected(current_unit->s);
1376
1377   current_unit->mode = g.mode;
1378
1379   /* Set the initial value of flags.  */
1380
1381   g.blank_status = current_unit->flags.blank;
1382   g.sign_status = SIGN_S;
1383   g.scale_factor = 0;
1384   g.seen_dollar = 0;
1385   g.first_item = 1;
1386   g.item_count = 0;
1387   sf_seen_eor = 0;
1388   eor_condition = 0;
1389
1390   pre_position ();
1391
1392   /* Set up the subroutine that will handle the transfers.  */
1393
1394   if (read_flag)
1395     {
1396       if (current_unit->flags.form == FORM_UNFORMATTED)
1397         transfer = unformatted_read;
1398       else
1399         {
1400           if (ioparm.list_format)
1401             {
1402                transfer = list_formatted_read;
1403                init_at_eol();
1404             }
1405           else
1406             transfer = formatted_transfer;
1407         }
1408     }
1409   else
1410     {
1411       if (current_unit->flags.form == FORM_UNFORMATTED)
1412         transfer = unformatted_write;
1413       else
1414         {
1415           if (ioparm.list_format)
1416             transfer = list_formatted_write;
1417           else
1418             transfer = formatted_transfer;
1419         }
1420     }
1421
1422   /* Make sure that we don't do a read after a nonadvancing write.  */
1423
1424   if (read_flag)
1425     {
1426       if (current_unit->read_bad)
1427         {
1428           generate_error (ERROR_BAD_OPTION,
1429                           "Cannot READ after a nonadvancing WRITE");
1430           return;
1431         }
1432     }
1433   else
1434     {
1435       if (advance_status == ADVANCE_YES && !g.seen_dollar)
1436         current_unit->read_bad = 1;
1437     }
1438
1439   /* Reset counters for T and X-editing.  */
1440   max_pos = skips = pending_spaces = 0;
1441
1442   /* Start the data transfer if we are doing a formatted transfer.  */
1443   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1444       && ioparm.namelist_name == NULL && ionml == NULL)
1445     formatted_transfer (0, NULL, 0, 0, 1);
1446 }
1447
1448 /* Initialize an array_loop_spec given the array descriptor.  The function
1449    returns the index of the last element of the array.  */
1450
1451 gfc_offset
1452 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1453 {
1454   int rank = GFC_DESCRIPTOR_RANK(desc);
1455   int i;
1456   gfc_offset index;
1457
1458   index = 1;
1459   for (i=0; i<rank; i++)
1460     {
1461       ls[i].idx = 1;
1462       ls[i].start = desc->dim[i].lbound;
1463       ls[i].end = desc->dim[i].ubound;
1464       ls[i].step = desc->dim[i].stride;
1465
1466       index += (desc->dim[i].ubound - desc->dim[i].lbound)
1467                       * desc->dim[i].stride;
1468     }
1469   return index;
1470 }
1471
1472 /* Determine the index to the next record in an internal unit array by
1473    by incrementing through the array_loop_spec.  TODO:  Implement handling
1474    negative strides. */
1475
1476 gfc_offset
1477 next_array_record ( array_loop_spec * ls )
1478 {
1479   int i, carry;
1480   gfc_offset index;
1481
1482   carry = 1;
1483   index = 0;
1484
1485   for (i = 0; i < current_unit->rank; i++)
1486     {
1487       if (carry)
1488         {
1489           ls[i].idx++;
1490           if (ls[i].idx > ls[i].end)
1491             {
1492               ls[i].idx = ls[i].start;
1493               carry = 1;
1494             }
1495           else
1496             carry = 0;
1497         }
1498       index = index + (ls[i].idx - 1) * ls[i].step;
1499     }
1500   return index;
1501 }
1502
1503 /* Space to the next record for read mode.  If the file is not
1504    seekable, we read MAX_READ chunks until we get to the right
1505    position.  */
1506
1507 #define MAX_READ 4096
1508
1509 static void
1510 next_record_r (void)
1511 {
1512   gfc_offset new, record;
1513   int bytes_left, rlength, length;
1514   char *p;
1515
1516   switch (current_mode ())
1517     {
1518     case UNFORMATTED_SEQUENTIAL:
1519       current_unit->bytes_left += sizeof (gfc_offset);  /* Skip over tail */
1520
1521       /* Fall through...  */
1522
1523     case FORMATTED_DIRECT:
1524     case UNFORMATTED_DIRECT:
1525       if (current_unit->bytes_left == 0)
1526         break;
1527
1528       if (is_seekable (current_unit->s))
1529         {
1530           new = file_position (current_unit->s) + current_unit->bytes_left;
1531
1532           /* Direct access files do not generate END conditions,
1533              only I/O errors.  */
1534           if (sseek (current_unit->s, new) == FAILURE)
1535             generate_error (ERROR_OS, NULL);
1536
1537         }
1538       else
1539         {                       /* Seek by reading data.  */
1540           while (current_unit->bytes_left > 0)
1541             {
1542               rlength = length = (MAX_READ > current_unit->bytes_left) ?
1543                 MAX_READ : current_unit->bytes_left;
1544
1545               p = salloc_r (current_unit->s, &rlength);
1546               if (p == NULL)
1547                 {
1548                   generate_error (ERROR_OS, NULL);
1549                   break;
1550                 }
1551
1552               current_unit->bytes_left -= length;
1553             }
1554         }
1555       break;
1556
1557     case FORMATTED_SEQUENTIAL:
1558       length = 1;
1559       /* sf_read has already terminated input because of an '\n'  */
1560       if (sf_seen_eor)
1561         {
1562           sf_seen_eor=0;
1563           break;
1564         }
1565
1566       if (is_internal_unit())
1567         {
1568           if (is_array_io())
1569           {
1570             record =  next_array_record (current_unit->ls);
1571
1572             /* Now seek to this record.  */
1573             record = record * current_unit->recl;
1574             if (sseek (current_unit->s, record) == FAILURE)
1575               {
1576                 generate_error (ERROR_OS, NULL);
1577                 break;
1578               }
1579             current_unit->bytes_left = current_unit->recl;
1580           }
1581         else
1582           {
1583             bytes_left = (int) current_unit->bytes_left;
1584             p = salloc_r (current_unit->s, &bytes_left);
1585             if (p != NULL)
1586               current_unit->bytes_left = current_unit->recl;
1587           }
1588         break;
1589         }
1590       else do
1591         {
1592           p = salloc_r (current_unit->s, &length);
1593
1594           if (p == NULL)
1595             {
1596               generate_error (ERROR_OS, NULL);
1597               break;
1598             }
1599
1600           if (length == 0)
1601             {
1602               current_unit->endfile = AT_ENDFILE;
1603               break;
1604             }
1605         }
1606       while (*p != '\n');
1607
1608       break;
1609     }
1610
1611   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1612     test_endfile (current_unit);
1613 }
1614
1615
1616 /* Position to the next record in write mode.  */
1617
1618 static void
1619 next_record_w (void)
1620 {
1621   gfc_offset c, m, record;
1622   int bytes_left, length;
1623   char *p;
1624
1625   /* Zero counters for X- and T-editing.  */
1626   max_pos = skips = pending_spaces = 0;
1627
1628   switch (current_mode ())
1629     {
1630     case FORMATTED_DIRECT:
1631       if (current_unit->bytes_left == 0)
1632         break;
1633
1634       length = current_unit->bytes_left;
1635       p = salloc_w (current_unit->s, &length);
1636
1637       if (p == NULL)
1638         goto io_error;
1639
1640       memset (p, ' ', current_unit->bytes_left);
1641       if (sfree (current_unit->s) == FAILURE)
1642         goto io_error;
1643       break;
1644
1645     case UNFORMATTED_DIRECT:
1646       if (sfree (current_unit->s) == FAILURE)
1647         goto io_error;
1648       break;
1649
1650     case UNFORMATTED_SEQUENTIAL:
1651       m = current_unit->recl - current_unit->bytes_left; /* Bytes written.  */
1652       c = file_position (current_unit->s);
1653
1654       length = sizeof (gfc_offset);
1655
1656       /* Write the length tail.  */
1657
1658       p = salloc_w (current_unit->s, &length);
1659       if (p == NULL)
1660         goto io_error;
1661
1662       memcpy (p, &m, sizeof (gfc_offset));
1663       if (sfree (current_unit->s) == FAILURE)
1664         goto io_error;
1665
1666       /* Seek to the head and overwrite the bogus length with the real
1667          length.  */
1668
1669       p = salloc_w_at (current_unit->s, &length, c - m - length);
1670       if (p == NULL)
1671         generate_error (ERROR_OS, NULL);
1672
1673       memcpy (p, &m, sizeof (gfc_offset));
1674       if (sfree (current_unit->s) == FAILURE)
1675         goto io_error;
1676
1677       /* Seek past the end of the current record.  */
1678
1679       if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1680         goto io_error;
1681
1682       break;
1683
1684     case FORMATTED_SEQUENTIAL:
1685
1686       if (current_unit->bytes_left == 0)
1687         break;
1688
1689       if (is_internal_unit())
1690         {
1691           if (is_array_io())
1692             {
1693               bytes_left = (int) current_unit->bytes_left;
1694               p = salloc_w (current_unit->s, &bytes_left);
1695               if (p == NULL)
1696                 {
1697                   generate_error (ERROR_END, NULL);
1698                   return;
1699                 }
1700               memset(p, ' ', bytes_left);
1701
1702               /* Now that the current record has been padded out,
1703                  determine where the next record in the array is. */
1704
1705               record =  next_array_record (current_unit->ls);
1706
1707               /* Now seek to this record */
1708               record = record * current_unit->recl;
1709
1710               if (sseek (current_unit->s, record) == FAILURE)
1711                 goto io_error;
1712
1713               current_unit->bytes_left = current_unit->recl;
1714             }
1715           else
1716             {
1717               length = 1;
1718               p = salloc_w (current_unit->s, &length);
1719               if (p==NULL)
1720                 goto io_error;
1721             }
1722         }
1723       else
1724         {
1725 #ifdef HAVE_CRLF
1726           length = 2;
1727 #else
1728           length = 1;
1729 #endif
1730           p = salloc_w (current_unit->s, &length);
1731           if (p)
1732             {  /* No new line for internal writes.  */
1733 #ifdef HAVE_CRLF
1734               p[0] = '\r';
1735               p[1] = '\n';
1736 #else
1737               *p = '\n';
1738 #endif
1739             }
1740           else
1741             goto io_error;
1742         }
1743
1744       break;
1745
1746     io_error:
1747       generate_error (ERROR_OS, NULL);
1748       break;
1749     }
1750 }
1751
1752 /* Position to the next record, which means moving to the end of the
1753    current record.  This can happen under several different
1754    conditions.  If the done flag is not set, we get ready to process
1755    the next record.  */
1756
1757 void
1758 next_record (int done)
1759 {
1760   gfc_offset fp; /* File position.  */
1761
1762   current_unit->read_bad = 0;
1763
1764   if (g.mode == READING)
1765     next_record_r ();
1766   else
1767     next_record_w ();
1768
1769   /* keep position up to date for INQUIRE */
1770   current_unit->flags.position = POSITION_ASIS;
1771
1772   current_unit->current_record = 0;
1773   if (current_unit->flags.access == ACCESS_DIRECT)
1774    {
1775     fp = file_position (current_unit->s);
1776     /* Calculate next record, rounding up partial records.  */
1777     current_unit->last_record = (fp + current_unit->recl - 1)
1778                                 / current_unit->recl;
1779    }
1780   else
1781     current_unit->last_record++;
1782
1783   if (!done)
1784     pre_position ();
1785 }
1786
1787
1788 /* Finalize the current data transfer.  For a nonadvancing transfer,
1789    this means advancing to the next record.  For internal units close the
1790    stream associated with the unit.  */
1791
1792 static void
1793 finalize_transfer (void)
1794 {
1795
1796   if (eor_condition)
1797     {
1798       generate_error (ERROR_EOR, NULL);
1799       return;
1800     }
1801
1802   if (ioparm.library_return != LIBRARY_OK)
1803     return;
1804
1805   if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1806     {
1807        if (ioparm.namelist_read_mode)
1808          namelist_read();
1809        else
1810          namelist_write();
1811     }
1812
1813   transfer = NULL;
1814   if (current_unit == NULL)
1815     return;
1816
1817   if (setjmp (g.eof_jump))
1818     {
1819       generate_error (ERROR_END, NULL);
1820       return;
1821     }
1822
1823   if (ioparm.list_format && g.mode == READING)
1824     finish_list_read ();
1825   else
1826     {
1827       free_fnodes ();
1828
1829       if (advance_status == ADVANCE_NO || g.seen_dollar)
1830         {
1831           /* Most systems buffer lines, so force the partial record
1832              to be written out.  */
1833           flush (current_unit->s);
1834           g.seen_dollar = 0;
1835           return;
1836         }
1837
1838       next_record (1);
1839       current_unit->current_record = 0;
1840     }
1841
1842   sfree (current_unit->s);
1843
1844   if (is_internal_unit ())
1845     {
1846       if (is_array_io() && current_unit->ls != NULL)
1847         free_mem (current_unit->ls);
1848       sclose (current_unit->s);
1849     }
1850 }
1851
1852
1853 /* Transfer function for IOLENGTH. It doesn't actually do any
1854    data transfer, it just updates the length counter.  */
1855
1856 static void
1857 iolength_transfer (bt type __attribute__((unused)),
1858                    void *dest __attribute__ ((unused)),
1859                    int kind __attribute__((unused)),
1860                    size_t size, size_t nelems)
1861 {
1862   if (ioparm.iolength != NULL)
1863     *ioparm.iolength += (GFC_INTEGER_4) size * nelems;
1864 }
1865
1866
1867 /* Initialize the IOLENGTH data transfer. This function is in essence
1868    a very much simplified version of data_transfer_init(), because it
1869    doesn't have to deal with units at all.  */
1870
1871 static void
1872 iolength_transfer_init (void)
1873 {
1874   if (ioparm.iolength != NULL)
1875     *ioparm.iolength = 0;
1876
1877   g.item_count = 0;
1878
1879   /* Set up the subroutine that will handle the transfers.  */
1880
1881   transfer = iolength_transfer;
1882 }
1883
1884
1885 /* Library entry point for the IOLENGTH form of the INQUIRE
1886    statement. The IOLENGTH form requires no I/O to be performed, but
1887    it must still be a runtime library call so that we can determine
1888    the iolength for dynamic arrays and such.  */
1889
1890 extern void st_iolength (void);
1891 export_proto(st_iolength);
1892
1893 void
1894 st_iolength (void)
1895 {
1896   library_start ();
1897   iolength_transfer_init ();
1898 }
1899
1900 extern void st_iolength_done (void);
1901 export_proto(st_iolength_done);
1902
1903 void
1904 st_iolength_done (void)
1905 {
1906   library_end ();
1907 }
1908
1909
1910 /* The READ statement.  */
1911
1912 extern void st_read (void);
1913 export_proto(st_read);
1914
1915 void
1916 st_read (void)
1917 {
1918
1919   library_start ();
1920
1921   data_transfer_init (1);
1922
1923   /* Handle complications dealing with the endfile record.  It is
1924      significant that this is the only place where ERROR_END is
1925      generated.  Reading an end of file elsewhere is either end of
1926      record or an I/O error. */
1927
1928   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1929     switch (current_unit->endfile)
1930       {
1931       case NO_ENDFILE:
1932         break;
1933
1934       case AT_ENDFILE:
1935         if (!is_internal_unit())
1936           {
1937             generate_error (ERROR_END, NULL);
1938             current_unit->endfile = AFTER_ENDFILE;
1939           }
1940         break;
1941
1942       case AFTER_ENDFILE:
1943         generate_error (ERROR_ENDFILE, NULL);
1944         break;
1945       }
1946 }
1947
1948 extern void st_read_done (void);
1949 export_proto(st_read_done);
1950
1951 void
1952 st_read_done (void)
1953 {
1954   finalize_transfer ();
1955   library_end ();
1956 }
1957
1958 extern void st_write (void);
1959 export_proto(st_write);
1960
1961 void
1962 st_write (void)
1963 {
1964
1965   library_start ();
1966   data_transfer_init (0);
1967 }
1968
1969 extern void st_write_done (void);
1970 export_proto(st_write_done);
1971
1972 void
1973 st_write_done (void)
1974 {
1975   finalize_transfer ();
1976
1977   /* Deal with endfile conditions associated with sequential files.  */
1978
1979   if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1980     switch (current_unit->endfile)
1981       {
1982       case AT_ENDFILE:          /* Remain at the endfile record.  */
1983         break;
1984
1985       case AFTER_ENDFILE:
1986         current_unit->endfile = AT_ENDFILE;     /* Just at it now.  */
1987         break;
1988
1989       case NO_ENDFILE:
1990         if (current_unit->current_record > current_unit->last_record)
1991           {
1992             /* Get rid of whatever is after this record.  */
1993             if (struncate (current_unit->s) == FAILURE)
1994               generate_error (ERROR_OS, NULL);
1995           }
1996
1997         current_unit->endfile = AT_ENDFILE;
1998         break;
1999       }
2000
2001   library_end ();
2002 }
2003
2004 /* Receives the scalar information for namelist objects and stores it
2005    in a linked list of namelist_info types.  */
2006
2007 extern void st_set_nml_var (void * ,char * ,
2008                             GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
2009 export_proto(st_set_nml_var);
2010
2011
2012 void
2013 st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
2014                 gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
2015 {
2016   namelist_info *t1 = NULL;
2017   namelist_info *nml;
2018
2019   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2020
2021   nml->mem_pos = var_addr;
2022
2023   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2024   strcpy (nml->var_name, var_name);
2025
2026   nml->len = (int) len;
2027   nml->string_length = (index_type) string_length;
2028
2029   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2030   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2031   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2032
2033   if (nml->var_rank > 0)
2034     {
2035       nml->dim = (descriptor_dimension*)
2036                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2037       nml->ls = (array_loop_spec*)
2038                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2039     }
2040   else
2041     {
2042       nml->dim = NULL;
2043       nml->ls = NULL;
2044     }
2045
2046   nml->next = NULL;
2047
2048   if (ionml == NULL)
2049     ionml = nml;
2050   else
2051     {
2052       for (t1 = ionml; t1->next; t1 = t1->next);
2053       t1->next = nml;
2054     }
2055   return;
2056 }
2057
2058 /* Store the dimensional information for the namelist object.  */
2059 extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
2060                                 GFC_INTEGER_4 ,GFC_INTEGER_4);
2061 export_proto(st_set_nml_var_dim);
2062
2063 void
2064 st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
2065                     GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
2066 {
2067   namelist_info * nml;
2068   int n;
2069
2070   n = (int)n_dim;
2071
2072   for (nml = ionml; nml->next; nml = nml->next);
2073
2074   nml->dim[n].stride = (ssize_t)stride;
2075   nml->dim[n].lbound = (ssize_t)lbound;
2076   nml->dim[n].ubound = (ssize_t)ubound;
2077 }