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 *, 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);
 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->flags.form == FORM_FORMATTED &&
 252       current_unit->flags.access == ACCESS_SEQUENTIAL)
 253     return read_sf (length);    /* Special case.  */
 254
 255   if (current_unit->bytes_left < *length)
 256     {
 257       if (current_unit->flags.pad == PAD_NO)
 258         {
 259           generate_error (ERROR_EOR, NULL); /* Not enough data left.  */
 260           return NULL;
 261         }
 262
 263       *length = current_unit->bytes_left;
 264     }
 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->flags.form == FORM_FORMATTED &&
 299       current_unit->flags.access == ACCESS_SEQUENTIAL)
 300     {
 301       length = (int*) nbytes;
 302       data = read_sf (length);  /* Special case.  */
 303       memcpy (buf, data, (size_t) *length);
 304       return;
 305     }
 306
 307   if (current_unit->bytes_left < *nbytes)
 308     {
 309       if (current_unit->flags.pad == PAD_NO)
 310         {
 311           generate_error (ERROR_EOR, NULL); /* Not enough data left.  */
 312           return;
 313         }
 314
 315       *nbytes = current_unit->bytes_left;
 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, void *dest, int length, size_t nelems)
 398 {
 399   size_t len;
 400
 401   len = length * nelems;
 402
 403   /* Transfer functions get passed the kind of the entity, so we have
 404      to fix this for COMPLEX data which are twice the size of their
 405      kind.  */
 406   if (type == BT_COMPLEX)
 407     len *= 2;
 408
 409   read_block_direct (dest, &len);
 410 }
 411
 412
 413 /* Master function for unformatted writes.  */
 414
 415 static void
 416 unformatted_write (bt type, void *source, int length, size_t nelems)
 417 {
 418   size_t len;
 419
 420   len = length * nelems;
 421
 422   /* Correction for kind vs. length as in unformatted_read.  */
 423   if (type == BT_COMPLEX)
 424     len *= 2;
 425
 426   write_block_direct (source, &len);
 427 }
 428
 429
 430 /* Return a pointer to the name of a type.  */
 431
 432 const char *
 433 type_name (bt type)
 434 {
 435   const char *p;
 436
 437   switch (type)
 438     {
 439     case BT_INTEGER:
 440       p = "INTEGER";
 441       break;
 442     case BT_LOGICAL:
 443       p = "LOGICAL";
 444       break;
 445     case BT_CHARACTER:
 446       p = "CHARACTER";
 447       break;
 448     case BT_REAL:
 449       p = "REAL";
 450       break;
 451     case BT_COMPLEX:
 452       p = "COMPLEX";
 453       break;
 454     default:
 455       internal_error ("type_name(): Bad type");
 456     }
 457
 458   return p;
 459 }
 460
 461
 462 /* Write a constant string to the output.
 463    This is complicated because the string can have doubled delimiters
 464    in it.  The length in the format node is the true length.  */
 465
 466 static void
 467 write_constant_string (fnode * f)
 468 {
 469   char c, delimiter, *p, *q;
 470   int length;
 471
 472   length = f->u.string.length;
 473   if (length == 0)
 474     return;
 475
 476   p = write_block (length);
 477   if (p == NULL)
 478     return;
 479
 480   q = f->u.string.p;
 481   delimiter = q[-1];
 482
 483   for (; length > 0; length--)
 484     {
 485       c = *p++ = *q++;
 486       if (c == delimiter && c != 'H' && c != 'h')
 487         q++;                    /* Skip the doubled delimiter.  */
 488     }
 489 }
 490
 491
 492 /* Given actual and expected types in a formatted data transfer, make
 493    sure they agree.  If not, an error message is generated.  Returns
 494    nonzero if something went wrong.  */
 495
 496 static int
 497 require_type (bt expected, bt actual, fnode * f)
 498 {
 499   char buffer[100];
 500
 501   if (actual == expected)
 502     return 0;
 503
 504   st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
 505               type_name (expected), g.item_count, type_name (actual));
 506
 507   format_error (f, buffer);
 508   return 1;
 509 }
 510
 511
 512 /* This subroutine is the main loop for a formatted data transfer
 513    statement.  It would be natural to implement this as a coroutine
 514    with the user program, but C makes that awkward.  We loop,
 515    processesing format elements.  When we actually have to transfer
 516    data instead of just setting flags, we return control to the user
 517    program which calls a subroutine that supplies the address and type
 518    of the next element, then comes back here to process it.  */
 519
 520 static void
 521 formatted_transfer_scalar (bt type, void *p, int len)
 522 {
 523   int pos, bytes_used;
 524   fnode *f;
 525   format_token t;
 526   int n;
 527   int consume_data_flag;
 528
 529   /* Change a complex data item into a pair of reals.  */
 530
 531   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
 532   if (type == BT_COMPLEX)
 533     type = BT_REAL;
 534
 535   /* If there's an EOR condition, we simulate finalizing the transfer
 536      by doing nothing.  */
 537   if (eor_condition)
 538     return;
 539
 540   for (;;)
 541     {
 542       /* If reversion has occurred and there is another real data item,
 543          then we have to move to the next record.  */
 544       if (g.reversion_flag && n > 0)
 545         {
 546           g.reversion_flag = 0;
 547           next_record (0);
 548         }
 549
 550       consume_data_flag = 1 ;
 551       if (ioparm.library_return != LIBRARY_OK)
 552         break;
 553
 554       f = next_format ();
 555       if (f == NULL)
 556         return;       /* No data descriptors left (already raised).  */
 557
 558       /* Now discharge T, TR and X movements to the right.  This is delayed
 559          until a data producing format to suppress trailing spaces.  */
 560       t = f->format;
 561       if (g.mode == WRITING && skips != 0
 562         && ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
 563                     || t == FMT_Z  || t == FMT_F  || t == FMT_E
 564                     || t == FMT_EN || t == FMT_ES || t == FMT_G
 565                     || t == FMT_L  || t == FMT_A  || t == FMT_D))
 566             || t == FMT_STRING))
 567         {
 568           if (skips > 0)
 569             {
 570               write_x (skips, pending_spaces);
 571               max_pos = (int)(current_unit->recl - current_unit->bytes_left);
 572             }
 573           if (skips < 0)
 574             {
 575               move_pos_offset (current_unit->s, skips);
 576               current_unit->bytes_left -= (gfc_offset)skips;
 577             }
 578           skips = pending_spaces = 0;
 579         }
 580
 581       bytes_used = (int)(current_unit->recl - current_unit->bytes_left);
 582
 583       switch (t)
 584         {
 585         case FMT_I:
 586           if (n == 0)
 587             goto need_data;
 588           if (require_type (BT_INTEGER, type, f))
 589             return;
 590
 591           if (g.mode == READING)
 592             read_decimal (f, p, len);
 593           else
 594             write_i (f, p, len);
 595
 596           break;
 597
 598         case FMT_B:
 599           if (n == 0)
 600             goto need_data;
 601           if (require_type (BT_INTEGER, type, f))
 602             return;
 603
 604           if (g.mode == READING)
 605             read_radix (f, p, len, 2);
 606           else
 607             write_b (f, p, len);
 608
 609           break;
 610
 611         case FMT_O:
 612           if (n == 0)
 613             goto need_data;
 614
 615           if (g.mode == READING)
 616             read_radix (f, p, len, 8);
 617           else
 618             write_o (f, p, len);
 619
 620           break;
 621
 622         case FMT_Z:
 623           if (n == 0)
 624             goto need_data;
 625
 626           if (g.mode == READING)
 627             read_radix (f, p, len, 16);
 628           else
 629             write_z (f, p, len);
 630
 631           break;
 632
 633         case FMT_A:
 634           if (n == 0)
 635             goto need_data;
 636
 637           if (g.mode == READING)
 638             read_a (f, p, len);
 639           else
 640             write_a (f, p, len);
 641
 642           break;
 643
 644         case FMT_L:
 645           if (n == 0)
 646             goto need_data;
 647
 648           if (g.mode == READING)
 649             read_l (f, p, len);
 650           else
 651             write_l (f, p, len);
 652
 653           break;
 654
 655         case FMT_D:
 656           if (n == 0)
 657             goto need_data;
 658           if (require_type (BT_REAL, type, f))
 659             return;
 660
 661           if (g.mode == READING)
 662             read_f (f, p, len);
 663           else
 664             write_d (f, p, len);
 665
 666           break;
 667
 668         case FMT_E:
 669           if (n == 0)
 670             goto need_data;
 671           if (require_type (BT_REAL, type, f))
 672             return;
 673
 674           if (g.mode == READING)
 675             read_f (f, p, len);
 676           else
 677             write_e (f, p, len);
 678           break;
 679
 680         case FMT_EN:
 681           if (n == 0)
 682             goto need_data;
 683           if (require_type (BT_REAL, type, f))
 684             return;
 685
 686           if (g.mode == READING)
 687             read_f (f, p, len);
 688           else
 689             write_en (f, p, len);
 690
 691           break;
 692
 693         case FMT_ES:
 694           if (n == 0)
 695             goto need_data;
 696           if (require_type (BT_REAL, type, f))
 697             return;
 698
 699           if (g.mode == READING)
 700             read_f (f, p, len);
 701           else
 702             write_es (f, p, len);
 703
 704           break;
 705
 706         case FMT_F:
 707           if (n == 0)
 708             goto need_data;
 709           if (require_type (BT_REAL, type, f))
 710             return;
 711
 712           if (g.mode == READING)
 713             read_f (f, p, len);
 714           else
 715             write_f (f, p, len);
 716
 717           break;
 718
 719         case FMT_G:
 720           if (n == 0)
 721             goto need_data;
 722           if (g.mode == READING)
 723             switch (type)
 724               {
 725               case BT_INTEGER:
 726                 read_decimal (f, p, len);
 727                 break;
 728               case BT_LOGICAL:
 729                 read_l (f, p, len);
 730                 break;
 731               case BT_CHARACTER:
 732                 read_a (f, p, len);
 733                 break;
 734               case BT_REAL:
 735                 read_f (f, p, len);
 736                 break;
 737               default:
 738                 goto bad_type;
 739               }
 740           else
 741             switch (type)
 742               {
 743               case BT_INTEGER:
 744                 write_i (f, p, len);
 745                 break;
 746               case BT_LOGICAL:
 747                 write_l (f, p, len);
 748                 break;
 749               case BT_CHARACTER:
 750                 write_a (f, p, len);
 751                 break;
 752               case BT_REAL:
 753                 write_d (f, p, len);
 754                 break;
 755               default:
 756               bad_type:
 757                 internal_error ("formatted_transfer(): Bad type");
 758               }
 759
 760           break;
 761
 762         case FMT_STRING:
 763           consume_data_flag = 0 ;
 764           if (g.mode == READING)
 765             {
 766               format_error (f, "Constant string in input format");
 767               return;
 768             }
 769           write_constant_string (f);
 770           break;
 771
 772         /* Format codes that don't transfer data.  */
 773         case FMT_X:
 774         case FMT_TR:
 775           consume_data_flag = 0 ;
 776
 777           pos = bytes_used + f->u.n + skips;
 778           skips = f->u.n + skips;
 779           pending_spaces = pos - max_pos;
 780
 781           /* Writes occur just before the switch on f->format, above, so that
 782              trailing blanks are suppressed.  */
 783           if (g.mode == READING)
 784             read_x (f->u.n);
 785
 786           break;
 787
 788         case FMT_TL:
 789         case FMT_T:
 790           if (f->format == FMT_TL)
 791             pos = bytes_used - f->u.n;
 792           else /* FMT_T */
 793             {
 794               consume_data_flag = 0;
 795               pos = f->u.n - 1;
 796             }
 797
 798           /* Standard 10.6.1.1: excessive left tabbing is reset to the
 799              left tab limit.  We do not check if the position has gone
 800              beyond the end of record because a subsequent tab could
 801              bring us back again.  */
 802           pos = pos < 0 ? 0 : pos;
 803
 804           skips = skips + pos - bytes_used;
 805           pending_spaces =  pending_spaces + pos - max_pos;
 806
 807           if (skips == 0)
 808             break;
 809
 810           /* Writes occur just before the switch on f->format, above, so that
 811              trailing blanks are suppressed.  */
 812           if (g.mode == READING)
 813             {
 814               if (skips > 0)
 815                 read_x (skips);
 816               if (skips < 0)
 817                 {
 818                   move_pos_offset (current_unit->s, skips);
 819                   current_unit->bytes_left -= (gfc_offset)skips;
 820                   skips = pending_spaces = 0;
 821                 }
 822             }
 823
 824           break;
 825
 826         case FMT_S:
 827           consume_data_flag = 0 ;
 828           g.sign_status = SIGN_S;
 829           break;
 830
 831         case FMT_SS:
 832           consume_data_flag = 0 ;
 833           g.sign_status = SIGN_SS;
 834           break;
 835
 836         case FMT_SP:
 837           consume_data_flag = 0 ;
 838           g.sign_status = SIGN_SP;
 839           break;
 840
 841         case FMT_BN:
 842           consume_data_flag = 0 ;
 843           g.blank_status = BLANK_NULL;
 844           break;
 845
 846         case FMT_BZ:
 847           consume_data_flag = 0 ;
 848           g.blank_status = BLANK_ZERO;
 849           break;
 850
 851         case FMT_P:
 852           consume_data_flag = 0 ;
 853           g.scale_factor = f->u.k;
 854           break;
 855
 856         case FMT_DOLLAR:
 857           consume_data_flag = 0 ;
 858           g.seen_dollar = 1;
 859           break;
 860
 861         case FMT_SLASH:
 862           consume_data_flag = 0 ;
 863           skips = pending_spaces = 0;
 864           next_record (0);
 865           break;
 866
 867         case FMT_COLON:
 868           /* A colon descriptor causes us to exit this loop (in
 869              particular preventing another / descriptor from being
 870              processed) unless there is another data item to be
 871              transferred.  */
 872           consume_data_flag = 0 ;
 873           if (n == 0)
 874             return;
 875           break;
 876
 877         default:
 878           internal_error ("Bad format node");
 879         }
 880
 881       /* Free a buffer that we had to allocate during a sequential
 882          formatted read of a block that was larger than the static
 883          buffer.  */
 884
 885       if (line_buffer != NULL)
 886         {
 887           free_mem (line_buffer);
 888           line_buffer = NULL;
 889         }
 890
 891       /* Adjust the item count and data pointer.  */
 892
 893       if ((consume_data_flag > 0) && (n > 0))
 894       {
 895         n--;
 896         p = ((char *) p) + len;
 897       }
 898
 899       if (g.mode == READING)
 900         skips = 0;
 901
 902       pos = (int)(current_unit->recl - current_unit->bytes_left);
 903       max_pos = (max_pos > pos) ? max_pos : pos;
 904
 905     }
 906
 907   return;
 908
 909   /* Come here when we need a data descriptor but don't have one.  We
 910      push the current format node back onto the input, then return and
 911      let the user program call us back with the data.  */
 912  need_data:
 913   unget_format (f);
 914 }
 915
 916 static void
 917 formatted_transfer (bt type, void *p, int len, size_t nelems)
 918 {
 919   size_t elem;
 920   int  size;
 921   char *tmp;
 922
 923   tmp = (char *) p;
 924
 925   if (type == BT_COMPLEX)
 926     size = 2 * len;
 927   else
 928     size = len;
 929
 930   /* Big loop over all the elements.  */
 931   for (elem = 0; elem < nelems; elem++)
 932     {
 933       g.item_count++;
 934       formatted_transfer_scalar (type, tmp + size*elem, len);
 935     }
 936 }
 937
 938
 939
 940 /* Data transfer entry points.  The type of the data entity is
 941    implicit in the subroutine call.  This prevents us from having to
 942    share a common enum with the compiler.  */
 943
 944 void
 945 transfer_integer (void *p, int kind)
 946 {
 947   if (ioparm.library_return != LIBRARY_OK)
 948     return;
 949   transfer (BT_INTEGER, p, kind, 1);
 950 }
 951
 952
 953 void
 954 transfer_real (void *p, int kind)
 955 {
 956   if (ioparm.library_return != LIBRARY_OK)
 957     return;
 958   transfer (BT_REAL, p, kind, 1);
 959 }
 960
 961
 962 void
 963 transfer_logical (void *p, int kind)
 964 {
 965   if (ioparm.library_return != LIBRARY_OK)
 966     return;
 967   transfer (BT_LOGICAL, p, kind, 1);
 968 }
 969
 970
 971 void
 972 transfer_character (void *p, int len)
 973 {
 974   if (ioparm.library_return != LIBRARY_OK)
 975     return;
 976   transfer (BT_CHARACTER, p, len, 1);
 977 }
 978
 979
 980 void
 981 transfer_complex (void *p, int kind)
 982 {
 983   if (ioparm.library_return != LIBRARY_OK)
 984     return;
 985   transfer (BT_COMPLEX, p, kind, 1);
 986 }
 987
 988
 989 void
 990 transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
 991 {
 992   index_type count[GFC_MAX_DIMENSIONS];
 993   index_type extent[GFC_MAX_DIMENSIONS];
 994   index_type stride[GFC_MAX_DIMENSIONS];
 995   index_type stride0, rank, size, type, n, kind;
 996   size_t tsize;
 997   char *data;
 998   bt iotype;
 999
1000   if (ioparm.library_return != LIBRARY_OK)
1001     return;
1002
1003   type = GFC_DESCRIPTOR_TYPE (desc);
1004   size = GFC_DESCRIPTOR_SIZE (desc);
1005   kind = size;
1006
1007   /* FIXME: What a kludge: Array descriptors and the IO library use
1008      different enums for types.  */
1009   switch (type)
1010     {
1011     case GFC_DTYPE_UNKNOWN:
1012       iotype = BT_NULL;  /* Is this correct?  */
1013       break;
1014     case GFC_DTYPE_INTEGER:
1015       iotype = BT_INTEGER;
1016       break;
1017     case GFC_DTYPE_LOGICAL:
1018       iotype = BT_LOGICAL;
1019       break;
1020     case GFC_DTYPE_REAL:
1021       iotype = BT_REAL;
1022       break;
1023     case GFC_DTYPE_COMPLEX:
1024       iotype = BT_COMPLEX;
1025       kind /= 2;
1026       break;
1027     case GFC_DTYPE_CHARACTER:
1028       iotype = BT_CHARACTER;
1029       /* FIXME: Currently dtype contains the charlen, which is
1030          clobbered if charlen > 2**24. That's why we use a separate
1031          argument for the charlen. However, if we want to support
1032          non-8-bit charsets we need to fix dtype to contain
1033          sizeof(chartype) and fix the code below.  */
1034       size = charlen;
1035       kind = charlen;
1036       break;
1037     case GFC_DTYPE_DERIVED:
1038       internal_error ("Derived type I/O should have been handled via the frontend.");
1039       break;
1040     default:
1041       internal_error ("transfer_array(): Bad type");
1042     }
1043
1044   if (desc->dim[0].stride == 0)
1045     desc->dim[0].stride = 1;
1046
1047   rank = GFC_DESCRIPTOR_RANK (desc);
1048   for (n = 0; n < rank; n++)
1049     {
1050       count[n] = 0;
1051       stride[n] = desc->dim[n].stride;
1052       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1053
1054       /* If the extent of even one dimension is zero, then the entire
1055          array section contains zero elements, so we return.  */
1056       if (extent[n] == 0)
1057         return;
1058     }
1059
1060   stride0 = stride[0];
1061
1062   /* If the innermost dimension has stride 1, we can do the transfer
1063      in contiguous chunks.  */
1064   if (stride0 == 1)
1065     tsize = extent[0];
1066   else
1067     tsize = 1;
1068
1069   data = GFC_DESCRIPTOR_DATA (desc);
1070
1071   while (data)
1072     {
1073       transfer (iotype, data, kind, tsize);
1074       data += stride0 * size * tsize;
1075       count[0] += tsize;
1076       n = 0;
1077       while (count[n] == extent[n])
1078         {
1079           count[n] = 0;
1080           data -= stride[n] * extent[n] * size;
1081           n++;
1082           if (n == rank)
1083             {
1084               data = NULL;
1085               break;
1086             }
1087           else
1088             {
1089               count[n]++;
1090               data += stride[n] * size;
1091             }
1092         }
1093     }
1094 }
1095
1096
1097 /* Preposition a sequential unformatted file while reading.  */
1098
1099 static void
1100 us_read (void)
1101 {
1102   char *p;
1103   int n;
1104   gfc_offset i;
1105
1106   n = sizeof (gfc_offset);
1107   p = salloc_r (current_unit->s, &n);
1108
1109   if (n == 0)
1110     return;  /* end of file */
1111
1112   if (p == NULL || n != sizeof (gfc_offset))
1113     {
1114       generate_error (ERROR_BAD_US, NULL);
1115       return;
1116     }
1117
1118   memcpy (&i, p, sizeof (gfc_offset));
1119   current_unit->bytes_left = i;
1120 }
1121
1122
1123 /* Preposition a sequential unformatted file while writing.  This
1124    amount to writing a bogus length that will be filled in later.  */
1125
1126 static void
1127 us_write (void)
1128 {
1129   char *p;
1130   int length;
1131
1132   length = sizeof (gfc_offset);
1133   p = salloc_w (current_unit->s, &length);
1134
1135   if (p == NULL)
1136     {
1137       generate_error (ERROR_OS, NULL);
1138       return;
1139     }
1140
1141   memset (p, '\0', sizeof (gfc_offset));        /* Bogus value for now.  */
1142   if (sfree (current_unit->s) == FAILURE)
1143     generate_error (ERROR_OS, NULL);
1144
1145   /* For sequential unformatted, we write until we have more bytes than
1146      can fit in the record markers. If disk space runs out first, it will
1147      error on the write.  */
1148   current_unit->recl = g.max_offset;
1149
1150   current_unit->bytes_left = current_unit->recl;
1151 }
1152
1153
1154 /* Position to the next record prior to transfer.  We are assumed to
1155    be before the next record.  We also calculate the bytes in the next
1156    record.  */
1157
1158 static void
1159 pre_position (void)
1160 {
1161   if (current_unit->current_record)
1162     return;                     /* Already positioned.  */
1163
1164   switch (current_mode ())
1165     {
1166     case UNFORMATTED_SEQUENTIAL:
1167       if (g.mode == READING)
1168         us_read ();
1169       else
1170         us_write ();
1171
1172       break;
1173
1174     case FORMATTED_SEQUENTIAL:
1175     case FORMATTED_DIRECT:
1176     case UNFORMATTED_DIRECT:
1177       current_unit->bytes_left = current_unit->recl;
1178       break;
1179     }
1180
1181   current_unit->current_record = 1;
1182 }
1183
1184
1185 /* Initialize things for a data transfer.  This code is common for
1186    both reading and writing.  */
1187
1188 static void
1189 data_transfer_init (int read_flag)
1190 {
1191   unit_flags u_flags;  /* Used for creating a unit if needed.  */
1192
1193   g.mode = read_flag ? READING : WRITING;
1194
1195   if (ioparm.size != NULL)
1196     *ioparm.size = 0;           /* Initialize the count.  */
1197
1198   current_unit = get_unit (read_flag);
1199   if (current_unit == NULL)
1200   {  /* Open the unit with some default flags.  */
1201      if (ioparm.unit < 0)
1202      {
1203        generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
1204        library_end ();
1205        return;
1206      }
1207      memset (&u_flags, '\0', sizeof (u_flags));
1208      u_flags.access = ACCESS_SEQUENTIAL;
1209      u_flags.action = ACTION_READWRITE;
1210      /* Is it unformatted?  */
1211      if (ioparm.format == NULL && !ioparm.list_format)
1212        u_flags.form = FORM_UNFORMATTED;
1213      else
1214        u_flags.form = FORM_UNSPECIFIED;
1215      u_flags.delim = DELIM_UNSPECIFIED;
1216      u_flags.blank = BLANK_UNSPECIFIED;
1217      u_flags.pad = PAD_UNSPECIFIED;
1218      u_flags.status = STATUS_UNKNOWN;
1219      new_unit(&u_flags);
1220      current_unit = get_unit (read_flag);
1221   }
1222
1223   if (current_unit == NULL)
1224     return;
1225
1226   /* Check the action.  */
1227
1228   if (read_flag && current_unit->flags.action == ACTION_WRITE)
1229     generate_error (ERROR_BAD_ACTION,
1230                     "Cannot read from file opened for WRITE");
1231
1232   if (!read_flag && current_unit->flags.action == ACTION_READ)
1233     generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
1234
1235   if (ioparm.library_return != LIBRARY_OK)
1236     return;
1237
1238   /* Check the format.  */
1239
1240   if (ioparm.format)
1241     parse_format ();
1242
1243   if (ioparm.library_return != LIBRARY_OK)
1244     return;
1245
1246   if (current_unit->flags.form == FORM_UNFORMATTED
1247       && (ioparm.format != NULL || ioparm.list_format))
1248     generate_error (ERROR_OPTION_CONFLICT,
1249                     "Format present for UNFORMATTED data transfer");
1250
1251   if (ioparm.namelist_name != NULL && ionml != NULL)
1252      {
1253         if(ioparm.format != NULL)
1254            generate_error (ERROR_OPTION_CONFLICT,
1255                     "A format cannot be specified with a namelist");
1256      }
1257   else if (current_unit->flags.form == FORM_FORMATTED &&
1258            ioparm.format == NULL && !ioparm.list_format)
1259     generate_error (ERROR_OPTION_CONFLICT,
1260                     "Missing format for FORMATTED data transfer");
1261
1262
1263   if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1264     generate_error (ERROR_OPTION_CONFLICT,
1265                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1266
1267   /* Check the record number.  */
1268
1269   if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1270     {
1271       generate_error (ERROR_MISSING_OPTION,
1272                       "Direct access data transfer requires record number");
1273       return;
1274     }
1275
1276   if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1277     {
1278       generate_error (ERROR_OPTION_CONFLICT,
1279                       "Record number not allowed for sequential access data transfer");
1280       return;
1281     }
1282
1283   /* Process the ADVANCE option.  */
1284
1285   advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1286     find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1287                  "Bad ADVANCE parameter in data transfer statement");
1288
1289   if (advance_status != ADVANCE_UNSPECIFIED)
1290     {
1291       if (current_unit->flags.access == ACCESS_DIRECT)
1292         generate_error (ERROR_OPTION_CONFLICT,
1293                         "ADVANCE specification conflicts with sequential access");
1294
1295       if (is_internal_unit ())
1296         generate_error (ERROR_OPTION_CONFLICT,
1297                         "ADVANCE specification conflicts with internal file");
1298
1299       if (ioparm.format == NULL || ioparm.list_format)
1300         generate_error (ERROR_OPTION_CONFLICT,
1301                         "ADVANCE specification requires an explicit format");
1302     }
1303
1304   if (read_flag)
1305     {
1306       if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
1307         generate_error (ERROR_MISSING_OPTION,
1308                         "EOR specification requires an ADVANCE specification of NO");
1309
1310       if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1311         generate_error (ERROR_MISSING_OPTION,
1312                         "SIZE specification requires an ADVANCE specification of NO");
1313
1314     }
1315   else
1316     {                           /* Write constraints.  */
1317       if (ioparm.end != 0)
1318         generate_error (ERROR_OPTION_CONFLICT,
1319                         "END specification cannot appear in a write statement");
1320
1321       if (ioparm.eor != 0)
1322         generate_error (ERROR_OPTION_CONFLICT,
1323                         "EOR specification cannot appear in a write statement");
1324
1325       if (ioparm.size != 0)
1326         generate_error (ERROR_OPTION_CONFLICT,
1327                         "SIZE specification cannot appear in a write statement");
1328     }
1329
1330   if (advance_status == ADVANCE_UNSPECIFIED)
1331     advance_status = ADVANCE_YES;
1332   if (ioparm.library_return != LIBRARY_OK)
1333     return;
1334
1335   /* Sanity checks on the record number.  */
1336
1337   if (ioparm.rec)
1338     {
1339       if (ioparm.rec <= 0)
1340         {
1341           generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1342           return;
1343         }
1344
1345       if (ioparm.rec >= current_unit->maxrec)
1346         {
1347           generate_error (ERROR_BAD_OPTION, "Record number too large");
1348           return;
1349         }
1350
1351       /* Check to see if we might be reading what we wrote before  */
1352
1353       if (g.mode == READING && current_unit->mode  == WRITING)
1354          flush(current_unit->s);
1355
1356       /* Check whether the record exists to be read.  Only
1357          a partial record needs to exist.  */
1358
1359       if (g.mode == READING && (ioparm.rec -1)
1360           * current_unit->recl >= file_length (current_unit->s))
1361         {
1362           generate_error (ERROR_BAD_OPTION, "Non-existing record number");
1363           return;
1364         }
1365
1366       /* Position the file.  */
1367       if (sseek (current_unit->s,
1368                (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1369         {
1370           generate_error (ERROR_OS, NULL);
1371           return;
1372         }
1373     }
1374
1375   /* Overwriting an existing sequential file ?
1376      it is always safe to truncate the file on the first write */
1377   if (g.mode == WRITING
1378       && current_unit->flags.access == ACCESS_SEQUENTIAL
1379       && current_unit->last_record == 0 && !is_preconnected(current_unit->s))
1380         struncate(current_unit->s);
1381
1382   current_unit->mode = g.mode;
1383
1384   /* Set the initial value of flags.  */
1385
1386   g.blank_status = current_unit->flags.blank;
1387   g.sign_status = SIGN_S;
1388   g.scale_factor = 0;
1389   g.seen_dollar = 0;
1390   g.first_item = 1;
1391   g.item_count = 0;
1392   sf_seen_eor = 0;
1393   eor_condition = 0;
1394
1395   pre_position ();
1396
1397   /* Set up the subroutine that will handle the transfers.  */
1398
1399   if (read_flag)
1400     {
1401       if (current_unit->flags.form == FORM_UNFORMATTED)
1402         transfer = unformatted_read;
1403       else
1404         {
1405           if (ioparm.list_format)
1406             {
1407                transfer = list_formatted_read;
1408                init_at_eol();
1409             }
1410           else
1411             transfer = formatted_transfer;
1412         }
1413     }
1414   else
1415     {
1416       if (current_unit->flags.form == FORM_UNFORMATTED)
1417         transfer = unformatted_write;
1418       else
1419         {
1420           if (ioparm.list_format)
1421             transfer = list_formatted_write;
1422           else
1423             transfer = formatted_transfer;
1424         }
1425     }
1426
1427   /* Make sure that we don't do a read after a nonadvancing write.  */
1428
1429   if (read_flag)
1430     {
1431       if (current_unit->read_bad)
1432         {
1433           generate_error (ERROR_BAD_OPTION,
1434                           "Cannot READ after a nonadvancing WRITE");
1435           return;
1436         }
1437     }
1438   else
1439     {
1440       if (advance_status == ADVANCE_YES && !g.seen_dollar)
1441         current_unit->read_bad = 1;
1442     }
1443
1444   /* Reset counters for T and X-editing.  */
1445   max_pos = skips = pending_spaces = 0;
1446
1447   /* Start the data transfer if we are doing a formatted transfer.  */
1448   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1449       && ioparm.namelist_name == NULL && ionml == NULL)
1450     formatted_transfer (0, NULL, 0, 1);
1451 }
1452
1453
1454 /* Space to the next record for read mode.  If the file is not
1455    seekable, we read MAX_READ chunks until we get to the right
1456    position.  */
1457
1458 #define MAX_READ 4096
1459
1460 static void
1461 next_record_r (void)
1462 {
1463   int rlength, length, bytes_left;
1464   gfc_offset new;
1465   char *p;
1466
1467   switch (current_mode ())
1468     {
1469     case UNFORMATTED_SEQUENTIAL:
1470       current_unit->bytes_left += sizeof (gfc_offset);  /* Skip over tail */
1471
1472       /* Fall through...  */
1473
1474     case FORMATTED_DIRECT:
1475     case UNFORMATTED_DIRECT:
1476       if (current_unit->bytes_left == 0)
1477         break;
1478
1479       if (is_seekable (current_unit->s))
1480         {
1481           new = file_position (current_unit->s) + current_unit->bytes_left;
1482
1483           /* Direct access files do not generate END conditions,
1484              only I/O errors.  */
1485           if (sseek (current_unit->s, new) == FAILURE)
1486             generate_error (ERROR_OS, NULL);
1487
1488         }
1489       else
1490         {                       /* Seek by reading data.  */
1491           while (current_unit->bytes_left > 0)
1492             {
1493               rlength = length = (MAX_READ > current_unit->bytes_left) ?
1494                 MAX_READ : current_unit->bytes_left;
1495
1496               p = salloc_r (current_unit->s, &rlength);
1497               if (p == NULL)
1498                 {
1499                   generate_error (ERROR_OS, NULL);
1500                   break;
1501                 }
1502
1503               current_unit->bytes_left -= length;
1504             }
1505         }
1506       break;
1507
1508     case FORMATTED_SEQUENTIAL:
1509       length = 1;
1510       /* sf_read has already terminated input because of an '\n'  */
1511       if (sf_seen_eor)
1512         {
1513           sf_seen_eor=0;
1514           break;
1515         }
1516
1517       if (is_internal_unit())
1518         {
1519           bytes_left = (int) current_unit->bytes_left;
1520           p = salloc_r (current_unit->s, &bytes_left);
1521           if (p != NULL)
1522             current_unit->bytes_left = current_unit->recl;
1523           break;
1524         }
1525       else do
1526         {
1527           p = salloc_r (current_unit->s, &length);
1528
1529           if (p == NULL)
1530             {
1531               generate_error (ERROR_OS, NULL);
1532               break;
1533             }
1534
1535           if (length == 0)
1536             {
1537               current_unit->endfile = AT_ENDFILE;
1538               break;
1539             }
1540         }
1541       while (*p != '\n');
1542
1543       break;
1544     }
1545
1546   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1547     test_endfile (current_unit);
1548 }
1549
1550
1551 /* Position to the next record in write mode.  */
1552
1553 static void
1554 next_record_w (void)
1555 {
1556   gfc_offset c, m;
1557   int length, bytes_left;
1558   char *p;
1559
1560   /* Zero counters for X- and T-editing.  */
1561   max_pos = skips = pending_spaces = 0;
1562
1563   switch (current_mode ())
1564     {
1565     case FORMATTED_DIRECT:
1566       if (current_unit->bytes_left == 0)
1567         break;
1568
1569       length = current_unit->bytes_left;
1570       p = salloc_w (current_unit->s, &length);
1571
1572       if (p == NULL)
1573         goto io_error;
1574
1575       memset (p, ' ', current_unit->bytes_left);
1576       if (sfree (current_unit->s) == FAILURE)
1577         goto io_error;
1578       break;
1579
1580     case UNFORMATTED_DIRECT:
1581       if (sfree (current_unit->s) == FAILURE)
1582         goto io_error;
1583       break;
1584
1585     case UNFORMATTED_SEQUENTIAL:
1586       m = current_unit->recl - current_unit->bytes_left; /* Bytes written.  */
1587       c = file_position (current_unit->s);
1588
1589       length = sizeof (gfc_offset);
1590
1591       /* Write the length tail.  */
1592
1593       p = salloc_w (current_unit->s, &length);
1594       if (p == NULL)
1595         goto io_error;
1596
1597       memcpy (p, &m, sizeof (gfc_offset));
1598       if (sfree (current_unit->s) == FAILURE)
1599         goto io_error;
1600
1601       /* Seek to the head and overwrite the bogus length with the real
1602          length.  */
1603
1604       p = salloc_w_at (current_unit->s, &length, c - m - length);
1605       if (p == NULL)
1606         generate_error (ERROR_OS, NULL);
1607
1608       memcpy (p, &m, sizeof (gfc_offset));
1609       if (sfree (current_unit->s) == FAILURE)
1610         goto io_error;
1611
1612       /* Seek past the end of the current record.  */
1613
1614       if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1615         goto io_error;
1616
1617       break;
1618
1619     case FORMATTED_SEQUENTIAL:
1620
1621       if (current_unit->bytes_left == 0)
1622         break;
1623
1624       if (is_internal_unit())
1625         {
1626           if (is_array_io())
1627             {
1628               bytes_left = (int) current_unit->bytes_left;
1629               p = salloc_w (current_unit->s, &bytes_left);
1630               if (p == NULL)
1631                 {
1632                   generate_error (ERROR_END, NULL);
1633                   return;
1634                 }
1635               memset(p, ' ', bytes_left);
1636               current_unit->bytes_left = current_unit->recl;
1637             }
1638           else
1639             {
1640               length = 1;
1641               p = salloc_w (current_unit->s, &length);
1642               if (p==NULL)
1643                 goto io_error;
1644             }
1645         }
1646       else
1647         {
1648 #ifdef HAVE_CRLF
1649           length = 2;
1650 #else
1651           length = 1;
1652 #endif
1653           p = salloc_w (current_unit->s, &length);
1654           if (p)
1655             {  /* No new line for internal writes.  */
1656 #ifdef HAVE_CRLF
1657               p[0] = '\r';
1658               p[1] = '\n';
1659 #else
1660               *p = '\n';
1661 #endif
1662             }
1663           else
1664             goto io_error;
1665         }
1666
1667       break;
1668
1669     io_error:
1670       generate_error (ERROR_OS, NULL);
1671       break;
1672     }
1673 }
1674
1675
1676 /* Position to the next record, which means moving to the end of the
1677    current record.  This can happen under several different
1678    conditions.  If the done flag is not set, we get ready to process
1679    the next record.  */
1680
1681 void
1682 next_record (int done)
1683 {
1684   gfc_offset fp; /* File position.  */
1685
1686   current_unit->read_bad = 0;
1687
1688   if (g.mode == READING)
1689     next_record_r ();
1690   else
1691     next_record_w ();
1692
1693   /* keep position up to date for INQUIRE */
1694   current_unit->flags.position = POSITION_ASIS;
1695
1696   current_unit->current_record = 0;
1697   if (current_unit->flags.access == ACCESS_DIRECT)
1698    {
1699     fp = file_position (current_unit->s);
1700     /* Calculate next record, rounding up partial records.  */
1701     current_unit->last_record = (fp + current_unit->recl - 1)
1702                                 / current_unit->recl;
1703    }
1704   else
1705     current_unit->last_record++;
1706
1707   if (!done)
1708     pre_position ();
1709 }
1710
1711
1712 /* Finalize the current data transfer.  For a nonadvancing transfer,
1713    this means advancing to the next record.  For internal units close the
1714    steam associated with the unit.  */
1715
1716 static void
1717 finalize_transfer (void)
1718 {
1719
1720   if (eor_condition)
1721     {
1722       generate_error (ERROR_EOR, NULL);
1723       return;
1724     }
1725
1726   if (ioparm.library_return != LIBRARY_OK)
1727     return;
1728
1729   if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1730     {
1731        if (ioparm.namelist_read_mode)
1732          namelist_read();
1733        else
1734          namelist_write();
1735     }
1736
1737   transfer = NULL;
1738   if (current_unit == NULL)
1739     return;
1740
1741   if (setjmp (g.eof_jump))
1742     {
1743       generate_error (ERROR_END, NULL);
1744       return;
1745     }
1746
1747   if (ioparm.list_format && g.mode == READING)
1748     finish_list_read ();
1749   else
1750     {
1751       free_fnodes ();
1752
1753       if (advance_status == ADVANCE_NO || g.seen_dollar)
1754         {
1755           /* Most systems buffer lines, so force the partial record
1756              to be written out.  */
1757           flush (current_unit->s);
1758           g.seen_dollar = 0;
1759           return;
1760         }
1761
1762       next_record (1);
1763       current_unit->current_record = 0;
1764     }
1765
1766   sfree (current_unit->s);
1767
1768   if (is_internal_unit ())
1769     sclose (current_unit->s);
1770 }
1771
1772
1773 /* Transfer function for IOLENGTH. It doesn't actually do any
1774    data transfer, it just updates the length counter.  */
1775
1776 static void
1777 iolength_transfer (bt type, void *dest __attribute__ ((unused)),
1778                    int len, size_t nelems)
1779 {
1780   if (ioparm.iolength != NULL)
1781     {
1782       if (type == BT_COMPLEX)
1783         *ioparm.iolength += 2 * len * nelems;
1784       else
1785         *ioparm.iolength += len * nelems;
1786     }
1787 }
1788
1789
1790 /* Initialize the IOLENGTH data transfer. This function is in essence
1791    a very much simplified version of data_transfer_init(), because it
1792    doesn't have to deal with units at all.  */
1793
1794 static void
1795 iolength_transfer_init (void)
1796 {
1797   if (ioparm.iolength != NULL)
1798     *ioparm.iolength = 0;
1799
1800   g.item_count = 0;
1801
1802   /* Set up the subroutine that will handle the transfers.  */
1803
1804   transfer = iolength_transfer;
1805 }
1806
1807
1808 /* Library entry point for the IOLENGTH form of the INQUIRE
1809    statement. The IOLENGTH form requires no I/O to be performed, but
1810    it must still be a runtime library call so that we can determine
1811    the iolength for dynamic arrays and such.  */
1812
1813 extern void st_iolength (void);
1814 export_proto(st_iolength);
1815
1816 void
1817 st_iolength (void)
1818 {
1819   library_start ();
1820   iolength_transfer_init ();
1821 }
1822
1823 extern void st_iolength_done (void);
1824 export_proto(st_iolength_done);
1825
1826 void
1827 st_iolength_done (void)
1828 {
1829   library_end ();
1830 }
1831
1832
1833 /* The READ statement.  */
1834
1835 extern void st_read (void);
1836 export_proto(st_read);
1837
1838 void
1839 st_read (void)
1840 {
1841
1842   library_start ();
1843
1844   data_transfer_init (1);
1845
1846   /* Handle complications dealing with the endfile record.  It is
1847      significant that this is the only place where ERROR_END is
1848      generated.  Reading an end of file elsewhere is either end of
1849      record or an I/O error. */
1850
1851   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1852     switch (current_unit->endfile)
1853       {
1854       case NO_ENDFILE:
1855         break;
1856
1857       case AT_ENDFILE:
1858         if (!is_internal_unit())
1859           {
1860             generate_error (ERROR_END, NULL);
1861             current_unit->endfile = AFTER_ENDFILE;
1862           }
1863         break;
1864
1865       case AFTER_ENDFILE:
1866         generate_error (ERROR_ENDFILE, NULL);
1867         break;
1868       }
1869 }
1870
1871 extern void st_read_done (void);
1872 export_proto(st_read_done);
1873
1874 void
1875 st_read_done (void)
1876 {
1877   finalize_transfer ();
1878   library_end ();
1879 }
1880
1881 extern void st_write (void);
1882 export_proto(st_write);
1883
1884 void
1885 st_write (void)
1886 {
1887
1888   library_start ();
1889   data_transfer_init (0);
1890 }
1891
1892 extern void st_write_done (void);
1893 export_proto(st_write_done);
1894
1895 void
1896 st_write_done (void)
1897 {
1898   finalize_transfer ();
1899
1900   /* Deal with endfile conditions associated with sequential files.  */
1901
1902   if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1903     switch (current_unit->endfile)
1904       {
1905       case AT_ENDFILE:          /* Remain at the endfile record.  */
1906         break;
1907
1908       case AFTER_ENDFILE:
1909         current_unit->endfile = AT_ENDFILE;     /* Just at it now.  */
1910         break;
1911
1912       case NO_ENDFILE:
1913         if (current_unit->current_record > current_unit->last_record)
1914           {
1915             /* Get rid of whatever is after this record.  */
1916             if (struncate (current_unit->s) == FAILURE)
1917               generate_error (ERROR_OS, NULL);
1918           }
1919
1920         current_unit->endfile = AT_ENDFILE;
1921         break;
1922       }
1923
1924   library_end ();
1925 }
1926
1927 /* Receives the scalar information for namelist objects and stores it
1928    in a linked list of namelist_info types.  */
1929
1930 extern void st_set_nml_var (void * ,char * ,
1931                             GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
1932 export_proto(st_set_nml_var);
1933
1934
1935 void
1936 st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
1937                 gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
1938 {
1939   namelist_info *t1 = NULL;
1940   namelist_info *nml;
1941
1942   nml = (namelist_info*) get_mem (sizeof (namelist_info));
1943
1944   nml->mem_pos = var_addr;
1945
1946   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
1947   strcpy (nml->var_name, var_name);
1948
1949   nml->len = (int) len;
1950   nml->string_length = (index_type) string_length;
1951
1952   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
1953   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
1954   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
1955
1956   if (nml->var_rank > 0)
1957     {
1958       nml->dim = (descriptor_dimension*)
1959                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
1960       nml->ls = (nml_loop_spec*)
1961                   get_mem (nml->var_rank * sizeof (nml_loop_spec));
1962     }
1963   else
1964     {
1965       nml->dim = NULL;
1966       nml->ls = NULL;
1967     }
1968
1969   nml->next = NULL;
1970
1971   if (ionml == NULL)
1972     ionml = nml;
1973   else
1974     {
1975       for (t1 = ionml; t1->next; t1 = t1->next);
1976       t1->next = nml;
1977     }
1978   return;
1979 }
1980
1981 /* Store the dimensional information for the namelist object.  */
1982 extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
1983                                 GFC_INTEGER_4 ,GFC_INTEGER_4);
1984 export_proto(st_set_nml_var_dim);
1985
1986 void
1987 st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
1988                     GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
1989 {
1990   namelist_info * nml;
1991   int n;
1992
1993   n = (int)n_dim;
1994
1995   for (nml = ionml; nml->next; nml = nml->next);
1996
1997   nml->dim[n].stride = (ssize_t)stride;
1998   nml->dim[n].lbound = (ssize_t)lbound;
1999   nml->dim[n].ubound = (ssize_t)ubound;
2000 }