libgfortran/io/list_read.c

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