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