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