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