libgfortran/io/list_read.c

   1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with Libgfortran; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 #include "config.h"
  23 #include <string.h>
  24 #include <ctype.h>
  25 #include "libgfortran.h"
  26 #include "io.h"
  27
  28
  29 /* List directed input.  Several parsing subroutines are practically
  30    reimplemented from formatted input, the reason being that there are
  31    all kinds of small differences between formatted and list directed
  32    parsing.  */
  33
  34
  35 /* Subroutines for reading characters from the input.  Because a
  36    repeat count is ambiguous with an integer, we have to read the
  37    whole digit string before seeing if there is a '*' which signals
  38    the repeat count.  Since we can have a lot of potential leading
  39    zeros, we have to be able to back up by arbitrary amount.  Because
  40    the input might not be seekable, we have to buffer the data
  41    ourselves.  Data is buffered in scratch[] until it becomes too
  42    large, after which we start allocating memory on the heap.  */
  43
  44 static int repeat_count, saved_length, saved_used, input_complete, at_eol;
  45 static int comma_flag, namelist_mode;
  46
  47 static char last_char, *saved_string;
  48 static bt saved_type;
  49
  50
  51
  52 /* Storage area for values except for strings.  Must be large enough
  53    to hold a complex value (two reals) of the largest kind.  */
  54
  55 static char value[20];
  56
  57 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
  58                       case '5': case '6': case '7': case '8': case '9'
  59
  60 #define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t'
  61
  62 /* This macro assumes that we're operating on a variable.  */
  63
  64 #define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
  65                          || c == '\t')
  66
  67 /* Maximum repeat count.  Less than ten times the maximum signed int32.  */
  68
  69 #define MAX_REPEAT 200000000
  70
  71
  72 /* Save a character to a string buffer, enlarging it as necessary.  */
  73
  74 static void
  75 push_char (char c)
  76 {
  77   char *new;
  78
  79   if (saved_string == NULL)
  80     {
  81       saved_string = scratch;
  82       memset (saved_string,0,SCRATCH_SIZE);
  83       saved_length = SCRATCH_SIZE;
  84       saved_used = 0;
  85     }
  86
  87   if (saved_used >= saved_length)
  88     {
  89       saved_length = 2 * saved_length;
  90       new = get_mem (2 * saved_length);
  91
  92       memset (new,0,2 * saved_length);
  93
  94       memcpy (new, saved_string, saved_used);
  95       if (saved_string != scratch)
  96         free_mem (saved_string);
  97
  98       saved_string = new;
  99     }
 100
 101   saved_string[saved_used++] = c;
 102 }
 103
 104
 105 /* Free the input buffer if necessary.  */
 106
 107 static void
 108 free_saved (void)
 109 {
 110
 111   if (saved_string == NULL)
 112     return;
 113
 114   if (saved_string != scratch)
 115     free_mem (saved_string);
 116
 117   saved_string = NULL;
 118 }
 119
 120
 121 static char
 122 next_char (void)
 123 {
 124   int length;
 125   char c, *p;
 126
 127   if (last_char != '\0')
 128     {
 129       at_eol = 0;
 130       c = last_char;
 131       last_char = '\0';
 132       goto done;
 133     }
 134
 135   length = 1;
 136
 137   p = salloc_r (current_unit->s, &length);
 138   if (p == NULL)
 139     {
 140       generate_error (ERROR_OS, NULL);
 141       return '\0';
 142     }
 143
 144   if (length == 0)
 145     longjmp (g.eof_jump, 1);
 146   c = *p;
 147
 148 done:
 149   at_eol = (c == '\n');
 150   return c;
 151 }
 152
 153
 154 /* Push a character back onto the input.  */
 155
 156 static void
 157 unget_char (char c)
 158 {
 159
 160   last_char = c;
 161 }
 162
 163
 164 /* Skip over spaces in the input.  Returns the nonspace character that
 165    terminated the eating and also places it back on the input.  */
 166
 167 static char
 168 eat_spaces (void)
 169 {
 170   char c;
 171
 172   do
 173     {
 174       c = next_char ();
 175     }
 176   while (c == ' ' || c == '\t');
 177
 178   unget_char (c);
 179   return c;
 180 }
 181
 182
 183 /* Skip over a separator.  Technically, we don't always eat the whole
 184    separator.  This is because if we've processed the last input item,
 185    then a separator is unnecessary.  Plus the fact that operating
 186    systems usually deliver console input on a line basis.
 187
 188    The upshot is that if we see a newline as part of reading a
 189    separator, we stop reading.  If there are more input items, we
 190    continue reading the separator with finish_separator() which takes
 191    care of the fact that we may or may not have seen a comma as part
 192    of the separator.  */
 193
 194 static void
 195 eat_separator (void)
 196 {
 197   char c;
 198
 199   eat_spaces ();
 200   comma_flag = 0;
 201
 202   c = next_char ();
 203   switch (c)
 204     {
 205     case ',':
 206       comma_flag = 1;
 207       eat_spaces ();
 208       break;
 209
 210     case '/':
 211       input_complete = 1;
 212       next_record (0);
 213       at_eol = 1;
 214       break;
 215
 216     case '\n':
 217       break;
 218
 219     case '!':
 220       if (namelist_mode)
 221         {                       /* Eat a namelist comment.  */
 222           do
 223             c = next_char ();
 224           while (c != '\n');
 225
 226           break;
 227         }
 228
 229       /* Fall Through...  */
 230
 231     default:
 232       unget_char (c);
 233       break;
 234     }
 235 }
 236
 237
 238 /* Finish processing a separator that was interrupted by a newline.
 239    If we're here, then another data item is present, so we finish what
 240    we started on the previous line.  */
 241
 242 static void
 243 finish_separator (void)
 244 {
 245   char c;
 246
 247 restart:
 248   eat_spaces ();
 249
 250   c = next_char ();
 251   switch (c)
 252     {
 253     case ',':
 254       if (comma_flag)
 255         unget_char (c);
 256       else
 257         {
 258           c = eat_spaces ();
 259           if (c == '\n')
 260             goto restart;
 261         }
 262
 263       break;
 264
 265     case '/':
 266       input_complete = 1;
 267       next_record (0);
 268       break;
 269
 270     case '\n':
 271       goto restart;
 272
 273     case '!':
 274       if (namelist_mode)
 275         {
 276           do
 277             c = next_char ();
 278           while (c != '\n');
 279
 280           goto restart;
 281         }
 282
 283     default:
 284       unget_char (c);
 285       break;
 286     }
 287 }
 288
 289
 290 /* Convert an unsigned string to an integer.  The length value is -1
 291    if we are working on a repeat count.  Returns nonzero if we have a
 292    range problem.  As a side effect, frees the saved_string.  */
 293
 294 static int
 295 convert_integer (int length, int negative)
 296 {
 297   char c, *buffer, message[100];
 298   int m;
 299   int64_t v, max, max10;
 300
 301   buffer = saved_string;
 302   v = 0;
 303
 304   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
 305   max10 = max / 10;
 306
 307   for (;;)
 308     {
 309       c = *buffer++;
 310       if (c == '\0')
 311         break;
 312       c -= '0';
 313
 314       if (v > max10)
 315         goto overflow;
 316       v = 10 * v;
 317
 318       if (v > max - c)
 319         goto overflow;
 320       v += c;
 321     }
 322
 323   m = 0;
 324
 325   if (length != -1)
 326     {
 327       if (negative)
 328         v = -v;
 329       set_integer (value, v, length);
 330     }
 331   else
 332     {
 333       repeat_count = v;
 334
 335       if (repeat_count == 0)
 336         {
 337           st_sprintf (message, "Zero repeat count in item %d of list input",
 338                       g.item_count);
 339
 340           generate_error (ERROR_READ_VALUE, message);
 341           m = 1;
 342         }
 343     }
 344
 345   free_saved ();
 346   return m;
 347
 348 overflow:
 349   if (length == -1)
 350     st_sprintf (message, "Repeat count overflow in item %d of list input",
 351                 g.item_count);
 352   else
 353     st_sprintf (message, "Integer overflow while reading item %d",
 354                 g.item_count);
 355
 356   free_saved ();
 357   generate_error (ERROR_READ_VALUE, message);
 358
 359   return 1;
 360 }
 361
 362
 363 /* Parse a repeat count for logical and complex values which cannot
 364    begin with a digit.  Returns nonzero if we are done, zero if we
 365    should continue on.  */
 366
 367 static int
 368 parse_repeat (void)
 369 {
 370   char c, message[100];
 371   int repeat;
 372
 373   c = next_char ();
 374   switch (c)
 375     {
 376     CASE_DIGITS:
 377       repeat = c - '0';
 378       break;
 379
 380     CASE_SEPARATORS:
 381       unget_char (c);
 382       eat_separator ();
 383       return 1;
 384
 385     default:
 386       unget_char (c);
 387       return 0;
 388     }
 389
 390   for (;;)
 391     {
 392       c = next_char ();
 393       switch (c)
 394         {
 395         CASE_DIGITS:
 396           repeat = 10 * repeat + c - '0';
 397
 398           if (repeat > MAX_REPEAT)
 399             {
 400               st_sprintf (message,
 401                           "Repeat count overflow in item %d of list input",
 402                           g.item_count);
 403
 404               generate_error (ERROR_READ_VALUE, message);
 405               return 1;
 406             }
 407
 408           break;
 409
 410         case '*':
 411           if (repeat == 0)
 412             {
 413               st_sprintf (message,
 414                           "Zero repeat count in item %d of list input",
 415                           g.item_count);
 416
 417               generate_error (ERROR_READ_VALUE, message);
 418               return 1;
 419             }
 420
 421           goto done;
 422
 423         default:
 424           goto bad_repeat;
 425         }
 426     }
 427
 428 done:
 429   repeat_count = repeat;
 430   return 0;
 431
 432 bad_repeat:
 433   st_sprintf (message, "Bad repeat count in item %d of list input",
 434               g.item_count);
 435
 436   generate_error (ERROR_READ_VALUE, message);
 437   return 1;
 438 }
 439
 440
 441 /* Read a logical character on the input.  */
 442
 443 static void
 444 read_logical (int length)
 445 {
 446   char c, message[100];
 447   int v;
 448
 449   if (parse_repeat ())
 450     return;
 451
 452   c = next_char ();
 453   switch (c)
 454     {
 455     case 't':
 456     case 'T':
 457       v = 1;
 458       break;
 459     case 'f':
 460     case 'F':
 461       v = 0;
 462       break;
 463
 464     case '.':
 465       c = next_char ();
 466       switch (c)
 467         {
 468         case 't':
 469         case 'T':
 470           v = 1;
 471           break;
 472         case 'f':
 473         case 'F':
 474           v = 0;
 475           break;
 476         default:
 477           goto bad_logical;
 478         }
 479
 480       break;
 481
 482     CASE_SEPARATORS:
 483       unget_char (c);
 484       eat_separator ();
 485       return;                   /* Null value.  */
 486
 487     default:
 488       goto bad_logical;
 489     }
 490
 491   saved_type = BT_LOGICAL;
 492   saved_length = length;
 493
 494   /* Eat trailing garbage.  */
 495   do
 496     {
 497       c = next_char ();
 498     }
 499   while (!is_separator (c));
 500
 501   unget_char (c);
 502   eat_separator ();
 503   free_saved ();
 504   set_integer ((int *) value, v, length);
 505
 506   return;
 507
 508 bad_logical:
 509   st_sprintf (message, "Bad logical value while reading item %d",
 510               g.item_count);
 511
 512   generate_error (ERROR_READ_VALUE, message);
 513 }
 514
 515
 516 /* Reading integers is tricky because we can actually be reading a
 517    repeat count.  We have to store the characters in a buffer because
 518    we could be reading an integer that is larger than the default int
 519    used for repeat counts.  */
 520
 521 static void
 522 read_integer (int length)
 523 {
 524   char c, message[100];
 525   int negative;
 526
 527   negative = 0;
 528
 529   c = next_char ();
 530   switch (c)
 531     {
 532     case '-':
 533       negative = 1;
 534       /* Fall through...  */
 535
 536     case '+':
 537       c = next_char ();
 538       goto get_integer;
 539
 540     CASE_SEPARATORS:            /* Single null.  */
 541       unget_char (c);
 542       eat_separator ();
 543       return;
 544
 545     CASE_DIGITS:
 546       push_char (c);
 547       break;
 548
 549     default:
 550       goto bad_integer;
 551     }
 552
 553   /* Take care of what may be a repeat count.  */
 554
 555   for (;;)
 556     {
 557       c = next_char ();
 558       switch (c)
 559         {
 560         CASE_DIGITS:
 561           push_char (c);
 562           break;
 563
 564         case '*':
 565           push_char ('\0');
 566           goto repeat;
 567
 568         CASE_SEPARATORS:        /* Not a repeat count.  */
 569           goto done;
 570
 571         default:
 572           goto bad_integer;
 573         }
 574     }
 575
 576 repeat:
 577   if (convert_integer (-1, 0))
 578     return;
 579
 580   /* Get the real integer.  */
 581
 582   c = next_char ();
 583   switch (c)
 584     {
 585     CASE_DIGITS:
 586       break;
 587
 588     CASE_SEPARATORS:
 589       unget_char (c);
 590       eat_separator ();
 591       return;
 592
 593     case '-':
 594       negative = 1;
 595       /* Fall through...  */
 596
 597     case '+':
 598       c = next_char ();
 599       break;
 600     }
 601
 602 get_integer:
 603   if (!isdigit (c))
 604     goto bad_integer;
 605   push_char (c);
 606
 607   for (;;)
 608     {
 609       c = next_char ();
 610       switch (c)
 611         {
 612         CASE_DIGITS:
 613           push_char (c);
 614           break;
 615
 616         CASE_SEPARATORS:
 617           goto done;
 618
 619         default:
 620           goto bad_integer;
 621         }
 622     }
 623
 624 bad_integer:
 625   free_saved ();
 626
 627   st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
 628   generate_error (ERROR_READ_VALUE, message);
 629
 630   return;
 631
 632 done:
 633   unget_char (c);
 634   eat_separator ();
 635
 636   push_char ('\0');
 637   if (convert_integer (length, negative))
 638     {
 639        free_saved ();
 640        return;
 641     }
 642
 643   free_saved ();
 644   saved_type = BT_INTEGER;
 645 }
 646
 647
 648 /* Read a character variable.  */
 649
 650 static void
 651 read_character (int length)
 652 {
 653   char c, quote, message[100];
 654
 655   quote = ' ';                  /* Space means no quote character.  */
 656
 657   c = next_char ();
 658   switch (c)
 659     {
 660     CASE_DIGITS:
 661       push_char (c);
 662       break;
 663
 664     CASE_SEPARATORS:
 665       unget_char (c);           /* NULL value.  */
 666       eat_separator ();
 667       return;
 668
 669     case '"':
 670     case '\'':
 671       quote = c;
 672       goto get_string;
 673
 674     default:
 675       push_char (c);
 676       goto get_string;
 677     }
 678
 679   /* Deal with a possible repeat count.  */
 680
 681   for (;;)
 682     {
 683       c = next_char ();
 684       switch (c)
 685         {
 686         CASE_DIGITS:
 687           push_char (c);
 688           break;
 689
 690         CASE_SEPARATORS:
 691           unget_char (c);
 692           goto done;            /* String was only digits!  */
 693
 694         case '*':
 695           push_char ('\0');
 696           goto got_repeat;
 697
 698         default:
 699           push_char (c);
 700           goto get_string;      /* Not a repeat count after all.  */
 701         }
 702     }
 703
 704 got_repeat:
 705   if (convert_integer (-1, 0))
 706     return;
 707
 708   /* Now get the real string.  */
 709
 710   c = next_char ();
 711   switch (c)
 712     {
 713     CASE_SEPARATORS:
 714       unget_char (c);           /* Repeated NULL values.  */
 715       eat_separator ();
 716       return;
 717
 718     case '"':
 719     case '\'':
 720       quote = c;
 721       break;
 722
 723     default:
 724       push_char (c);
 725       break;
 726     }
 727
 728 get_string:
 729   for (;;)
 730     {
 731       c = next_char ();
 732       switch (c)
 733         {
 734         case '"':
 735         case '\'':
 736           if (c != quote)
 737             {
 738               push_char (c);
 739               break;
 740             }
 741
 742           /* See if we have a doubled quote character or the end of
 743              the string.  */
 744
 745           c = next_char ();
 746           if (c == quote)
 747             {
 748               push_char (quote);
 749               break;
 750             }
 751
 752           unget_char (c);
 753           goto done;
 754
 755         CASE_SEPARATORS:
 756           if (quote == ' ')
 757             {
 758               unget_char (c);
 759               goto done;
 760             }
 761
 762           if (c != '\n')
 763             push_char (c);
 764           break;
 765
 766         default:
 767           push_char (c);
 768           break;
 769         }
 770     }
 771
 772 /* At this point, we have to have a separator, or else the string is
 773    invalid.  */
 774
 775 done:
 776   c = next_char ();
 777   if (is_separator (c))
 778     {
 779       unget_char (c);
 780       eat_separator ();
 781       saved_type = BT_CHARACTER;
 782     }
 783   else
 784     {
 785       free_saved ();
 786       st_sprintf (message, "Invalid string input in item %d", g.item_count);
 787       generate_error (ERROR_READ_VALUE, message);
 788     }
 789 }
 790
 791
 792 /* Parse a component of a complex constant or a real number that we
 793    are sure is already there.  This is a straight real number parser.  */
 794
 795 static int
 796 parse_real (void *buffer, int length)
 797 {
 798   char c, message[100];
 799   int m, seen_dp;
 800
 801   c = next_char ();
 802   if (c == '-' || c == '+')
 803     {
 804       push_char (c);
 805       c = next_char ();
 806     }
 807
 808   if (!isdigit (c) && c != '.')
 809     goto bad;
 810
 811   push_char (c);
 812
 813   seen_dp = (c == '.') ? 1 : 0;
 814
 815   for (;;)
 816     {
 817       c = next_char ();
 818       switch (c)
 819         {
 820         CASE_DIGITS:
 821           push_char (c);
 822           break;
 823
 824         case '.':
 825           if (seen_dp)
 826             goto bad;
 827
 828           seen_dp = 1;
 829           push_char (c);
 830           break;
 831
 832         case 'e':
 833         case 'E':
 834         case 'd':
 835         case 'D':
 836           push_char ('e');
 837           goto exp1;
 838
 839         case '-':
 840         case '+':
 841           push_char ('e');
 842           push_char (c);
 843           c = next_char ();
 844           goto exp2;
 845
 846         CASE_SEPARATORS:
 847           unget_char (c);
 848           goto done;
 849
 850         default:
 851           goto done;
 852         }
 853     }
 854
 855 exp1:
 856   c = next_char ();
 857   if (c != '-' && c != '+')
 858     push_char ('+');
 859   else
 860     {
 861       push_char (c);
 862       c = next_char ();
 863     }
 864
 865 exp2:
 866   if (!isdigit (c))
 867     goto bad;
 868   push_char (c);
 869
 870   for (;;)
 871     {
 872       c = next_char ();
 873       switch (c)
 874         {
 875         CASE_DIGITS:
 876           push_char (c);
 877           break;
 878
 879         CASE_SEPARATORS:
 880           unget_char (c);
 881           goto done;
 882
 883         default:
 884           goto done;
 885         }
 886     }
 887
 888 done:
 889   unget_char (c);
 890   push_char ('\0');
 891
 892   m = convert_real (buffer, saved_string, length);
 893   free_saved ();
 894
 895   return m;
 896
 897 bad:
 898   free_saved ();
 899   st_sprintf (message, "Bad floating point number for item %d", g.item_count);
 900   generate_error (ERROR_READ_VALUE, message);
 901
 902   return 1;
 903 }
 904
 905
 906 /* Reading a complex number is straightforward because we can tell
 907    what it is right away.  */
 908
 909 static void
 910 read_complex (int length)
 911 {
 912   char message[100];
 913   char c;
 914
 915   if (parse_repeat ())
 916     return;
 917
 918   c = next_char ();
 919   switch (c)
 920     {
 921     case '(':
 922       break;
 923
 924     CASE_SEPARATORS:
 925       unget_char (c);
 926       eat_separator ();
 927       return;
 928
 929     default:
 930       goto bad_complex;
 931     }
 932
 933   eat_spaces ();
 934   if (parse_real (value, length))
 935     return;
 936
 937   eat_spaces ();
 938   if (next_char () != ',')
 939     goto bad_complex;
 940
 941   eat_spaces ();
 942   if (parse_real (value + length, length))
 943     return;
 944
 945   eat_spaces ();
 946   if (next_char () != ')')
 947     goto bad_complex;
 948
 949   c = next_char ();
 950   if (!is_separator (c))
 951     goto bad_complex;
 952
 953   unget_char (c);
 954   eat_separator ();
 955
 956   free_saved ();
 957   saved_type = BT_COMPLEX;
 958   return;
 959
 960 bad_complex:
 961   st_sprintf (message, "Bad complex value in item %d of list input",
 962               g.item_count);
 963
 964   generate_error (ERROR_READ_VALUE, message);
 965 }
 966
 967
 968 /* Parse a real number with a possible repeat count.  */
 969
 970 static void
 971 read_real (int length)
 972 {
 973   char c, message[100];
 974   int seen_dp;
 975
 976   seen_dp = 0;
 977
 978   c = next_char ();
 979   switch (c)
 980     {
 981     CASE_DIGITS:
 982       push_char (c);
 983       break;
 984
 985     case '.':
 986       push_char (c);
 987       seen_dp = 1;
 988       break;
 989
 990     case '+':
 991     case '-':
 992       goto got_sign;
 993
 994     CASE_SEPARATORS:
 995       unget_char (c);           /* Single null.  */
 996       eat_separator ();
 997       return;
 998
 999     default:
1000       goto bad_real;
1001     }
1002
1003   /* Get the digit string that might be a repeat count.  */
1004
1005   for (;;)
1006     {
1007       c = next_char ();
1008       switch (c)
1009         {
1010         CASE_DIGITS:
1011           push_char (c);
1012           break;
1013
1014         case '.':
1015           if (seen_dp)
1016             goto bad_real;
1017
1018           seen_dp = 1;
1019           push_char (c);
1020           goto real_loop;
1021
1022         case 'E':
1023         case 'e':
1024         case 'D':
1025         case 'd':
1026           goto exp1;
1027
1028         case '+':
1029         case '-':
1030           push_char ('e');
1031           push_char (c);
1032           c = next_char ();
1033           goto exp2;
1034
1035         case '*':
1036           push_char ('\0');
1037           goto got_repeat;
1038
1039         CASE_SEPARATORS:
1040           if (c != '\n')
1041             unget_char (c);    /* Real number that is just a digit-string.  */
1042           goto done;
1043
1044         default:
1045           goto bad_real;
1046         }
1047     }
1048
1049 got_repeat:
1050   if (convert_integer (-1, 0))
1051     return;
1052
1053   /* Now get the number itself.  */
1054
1055   c = next_char ();
1056   if (is_separator (c))
1057     {                           /* Repeated null value.  */
1058       unget_char (c);
1059       eat_separator ();
1060       return;
1061     }
1062
1063   if (c != '-' && c != '+')
1064     push_char ('+');
1065   else
1066     {
1067     got_sign:
1068       push_char (c);
1069       c = next_char ();
1070     }
1071
1072   if (!isdigit (c) && c != '.')
1073     goto bad_real;
1074
1075   if (c == '.')
1076     {
1077       if (seen_dp)
1078         goto bad_real;
1079       else
1080         seen_dp = 1;
1081     }
1082
1083   push_char (c);
1084
1085 real_loop:
1086   for (;;)
1087     {
1088       c = next_char ();
1089       switch (c)
1090         {
1091         CASE_DIGITS:
1092           push_char (c);
1093           break;
1094
1095         CASE_SEPARATORS:
1096           goto done;
1097
1098         case '.':
1099           if (seen_dp)
1100             goto bad_real;
1101
1102           seen_dp = 1;
1103           push_char (c);
1104           break;
1105
1106         case 'E':
1107         case 'e':
1108         case 'D':
1109         case 'd':
1110           goto exp1;
1111
1112         case '+':
1113         case '-':
1114           push_char ('e');
1115           push_char (c);
1116           c = next_char ();
1117           goto exp2;
1118
1119         default:
1120           goto bad_real;
1121         }
1122     }
1123
1124 exp1:
1125   push_char ('e');
1126
1127   c = next_char ();
1128   if (c != '+' && c != '-')
1129     push_char ('+');
1130   else
1131     {
1132       push_char (c);
1133       c = next_char ();
1134     }
1135
1136 exp2:
1137   if (!isdigit (c))
1138     goto bad_real;
1139   push_char (c);
1140
1141   for (;;)
1142     {
1143       c = next_char ();
1144
1145       switch (c)
1146         {
1147         CASE_DIGITS:
1148           push_char (c);
1149           break;
1150
1151         CASE_SEPARATORS:
1152           unget_char (c);
1153           eat_separator ();
1154           goto done;
1155
1156         default:
1157           goto bad_real;
1158         }
1159     }
1160
1161 done:
1162   push_char ('\0');
1163   if (convert_real (value, saved_string, length))
1164     return;
1165
1166   free_saved ();
1167   saved_type = BT_REAL;
1168   return;
1169
1170 bad_real:
1171   st_sprintf (message, "Bad real number in item %d of list input",
1172               g.item_count);
1173
1174   generate_error (ERROR_READ_VALUE, message);
1175 }
1176
1177
1178 /* Check the current type against the saved type to make sure they are
1179    compatible.  Returns nonzero if incompatible.  */
1180
1181 static int
1182 check_type (bt type, int len)
1183 {
1184   char message[100];
1185
1186   if (saved_type != BT_NULL && saved_type != type)
1187     {
1188       st_sprintf (message, "Read type %s where %s was expected for item %d",
1189                   type_name (saved_type), type_name (type), g.item_count);
1190
1191       generate_error (ERROR_READ_VALUE, message);
1192       return 1;
1193     }
1194
1195   if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
1196     return 0;
1197
1198   if (saved_length != len)
1199     {
1200       st_sprintf (message,
1201                   "Read kind %d %s where kind %d is required for item %d",
1202                   saved_length, type_name (saved_type), len, g.item_count);
1203       generate_error (ERROR_READ_VALUE, message);
1204       return 1;
1205     }
1206
1207   return 0;
1208 }
1209
1210
1211 /* Top level data transfer subroutine for list reads.  Because we have
1212    to deal with repeat counts, the data item is always saved after
1213    reading, usually in the value[] array.  If a repeat count is
1214    greater than one, we copy the data item multiple times.  */
1215
1216 void
1217 list_formatted_read (bt type, void *p, int len)
1218 {
1219   char c;
1220   int m;
1221
1222   namelist_mode = 0;
1223
1224   if (setjmp (g.eof_jump))
1225     {
1226       generate_error (ERROR_END, NULL);
1227       return;
1228     }
1229
1230   if (g.first_item)
1231     {
1232       g.first_item = 0;
1233       input_complete = 0;
1234       repeat_count = 1;
1235       at_eol = 0;
1236
1237       c = eat_spaces ();
1238       if (is_separator (c))
1239         {                       /* Found a null value.  */
1240           eat_separator ();
1241           repeat_count = 0;
1242           if (at_eol)
1243             finish_separator ();
1244           else
1245             return;
1246         }
1247
1248     }
1249   else
1250     {
1251       if (input_complete)
1252         return;
1253
1254       if (repeat_count > 0)
1255         {
1256           if (check_type (type, len))
1257             return;
1258           goto set_value;
1259         }
1260
1261       if (at_eol)
1262         finish_separator ();
1263       else
1264         eat_spaces ();
1265
1266       saved_type = BT_NULL;
1267       repeat_count = 1;
1268     }
1269
1270
1271   switch (type)
1272     {
1273     case BT_INTEGER:
1274       read_integer (len);
1275       break;
1276     case BT_LOGICAL:
1277       read_logical (len);
1278       break;
1279     case BT_CHARACTER:
1280       read_character (len);
1281       break;
1282     case BT_REAL:
1283       read_real (len);
1284       break;
1285     case BT_COMPLEX:
1286       read_complex (len);
1287       break;
1288     default:
1289       internal_error ("Bad type for list read");
1290     }
1291
1292   if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
1293     saved_length = len;
1294
1295   if (ioparm.library_return != LIBRARY_OK)
1296     return;
1297
1298 set_value:
1299   switch (saved_type)
1300     {
1301     case BT_COMPLEX:
1302       len = 2 * len;
1303       /* Fall through.  */
1304
1305     case BT_INTEGER:
1306     case BT_REAL:
1307     case BT_LOGICAL:
1308       memcpy (p, value, len);
1309       break;
1310
1311     case BT_CHARACTER:
1312       if (saved_string)
1313        {
1314           m = (len < saved_used) ? len : saved_used;
1315           memcpy (p, saved_string, m);
1316        }
1317       else
1318         /* Just delimiters encountered, nothing to copy but SPACE.  */
1319         m = 0;
1320
1321       if (m < len)
1322         memset (((char *) p) + m, ' ', len - m);
1323       break;
1324
1325     case BT_NULL:
1326       break;
1327     }
1328
1329   if (--repeat_count <= 0)
1330     free_saved ();
1331 }
1332
1333 void
1334 init_at_eol()
1335 {
1336   at_eol = 0;
1337 }
1338
1339 /* Finish a list read.  */
1340
1341 void
1342 finish_list_read (void)
1343 {
1344   char c;
1345
1346   free_saved ();
1347
1348   if (at_eol)
1349     {
1350       at_eol = 0;
1351       return;
1352     }
1353
1354
1355   do
1356     {
1357       c = next_char ();
1358     }
1359   while (c != '\n');
1360 }
1361
1362 static namelist_info *
1363 find_nml_node (char * var_name)
1364 {
1365    namelist_info * t = ionml;
1366    while (t != NULL)
1367      {
1368        if (strcmp (var_name,t->var_name) == 0)
1369          {
1370            t->value_acquired = 1;
1371            return t;
1372          }
1373        t = t->next;
1374      }
1375   return NULL;
1376 }
1377
1378 static void
1379 match_namelist_name (char *name, int len)
1380 {
1381   int name_len;
1382   char c;
1383   char * namelist_name = name;
1384
1385   name_len = 0;
1386   /* Match the name of the namelist.  */
1387
1388   if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
1389     {
1390     wrong_name:
1391       generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
1392       return;
1393     }
1394
1395   while (name_len < len)
1396     {
1397       c = next_char ();
1398       if (tolower (c) != tolower (namelist_name[name_len++]))
1399         goto wrong_name;
1400     }
1401 }
1402
1403
1404 /********************************************************************
1405       Namelist reads
1406 ********************************************************************/
1407
1408 /* Process a namelist read.  This subroutine initializes things,
1409    positions to the first element and
1410    FIXME: was this comment ever complete?  */
1411
1412 void
1413 namelist_read (void)
1414 {
1415   char c;
1416   int name_matched, next_name ;
1417   namelist_info * nl;
1418   int len, m;
1419   void * p;
1420
1421   namelist_mode = 1;
1422
1423   if (setjmp (g.eof_jump))
1424     {
1425       generate_error (ERROR_END, NULL);
1426       return;
1427     }
1428
1429 restart:
1430   c = next_char ();
1431   switch (c)
1432     {
1433     case ' ':
1434       goto restart;
1435     case '!':
1436       do
1437         c = next_char ();
1438       while (c != '\n');
1439
1440       goto restart;
1441
1442     case '&':
1443       break;
1444
1445     default:
1446       generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
1447       return;
1448     }
1449
1450   /* Match the name of the namelist.  */
1451   match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
1452
1453   /* Ready to read namelist elements.  */
1454   while (!input_complete)
1455     {
1456       c = next_char ();
1457       switch (c)
1458         {
1459         case '/':
1460           input_complete = 1;
1461           next_record (0);
1462           break;
1463         case '&':
1464           match_namelist_name("end",3);
1465           return;
1466         case '\\':
1467           return;
1468         case ' ':
1469         case '\n':
1470         case '\t':
1471           break;
1472         case ',':
1473           next_name = 1;
1474           break;
1475
1476         case '=':
1477           name_matched = 1;
1478           nl = find_nml_node (saved_string);
1479           if (nl == NULL)
1480             internal_error ("Can not match a namelist variable");
1481           free_saved();
1482
1483           len = nl->len;
1484           p = nl->mem_pos;
1485           switch (nl->type)
1486             {
1487             case BT_INTEGER:
1488               read_integer (len);
1489               break;
1490             case BT_LOGICAL:
1491               read_logical (len);
1492               break;
1493             case BT_CHARACTER:
1494               read_character (len);
1495               break;
1496             case BT_REAL:
1497               read_real (len);
1498               break;
1499             case BT_COMPLEX:
1500               read_complex (len);
1501               break;
1502             default:
1503               internal_error ("Bad type for namelist read");
1504             }
1505
1506            switch (saved_type)
1507             {
1508             case BT_COMPLEX:
1509               len = 2 * len;
1510               /* Fall through...  */
1511
1512             case BT_INTEGER:
1513             case BT_REAL:
1514             case BT_LOGICAL:
1515               memcpy (p, value, len);
1516               break;
1517
1518             case BT_CHARACTER:
1519               m = (len < saved_used) ? len : saved_used;
1520               memcpy (p, saved_string, m);
1521
1522               if (m < len)
1523                 memset (((char *) p) + m, ' ', len - m);
1524               break;
1525
1526             case BT_NULL:
1527               break;
1528             }
1529
1530           break;
1531
1532         default :
1533           push_char(tolower(c));
1534           break;
1535         }
1536    }
1537 }