libgfortran/io/transfer.c

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