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