libgfortran/io/list_read.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    Namelist input contributed by Paul Thomas
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31
  32 #include "config.h"
  33 #include <string.h>
  34 #include <ctype.h>
  35 #include "libgfortran.h"
  36 #include "io.h"
  37
  38
  39 /* List directed input.  Several parsing subroutines are practically
  40    reimplemented from formatted input, the reason being that there are
  41    all kinds of small differences between formatted and list directed
  42    parsing.  */
  43
  44
  45 /* Subroutines for reading characters from the input.  Because a
  46    repeat count is ambiguous with an integer, we have to read the
  47    whole digit string before seeing if there is a '*' which signals
  48    the repeat count.  Since we can have a lot of potential leading
  49    zeros, we have to be able to back up by arbitrary amount.  Because
  50    the input might not be seekable, we have to buffer the data
  51    ourselves.  Data is buffered in scratch[] until it becomes too
  52    large, after which we start allocating memory on the heap.  */
  53
  54 static int repeat_count, saved_length, saved_used;
  55 static int input_complete, at_eol, comma_flag;
  56 static char last_char, *saved_string;
  57 static bt saved_type;
  58
  59 /* A namelist specific flag used in the list directed library
  60    to flag that calls are being made from namelist read (eg. to ignore
  61    comments or to treat '/' as a terminator)  */
  62
  63 static int namelist_mode;
  64
  65 /* A namelist specific flag used in the list directed library to flag
  66    read errors and return, so that an attempt can be made to read a
  67    new object name.  */
  68
  69 static int nml_read_error;
  70
  71 /* Storage area for values except for strings.  Must be large enough
  72    to hold a complex value (two reals) of the largest kind.  */
  73
  74 static char value[20];
  75
  76 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
  77                       case '5': case '6': case '7': case '8': case '9'
  78
  79 #define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t': \
  80                          case '\r'
  81
  82 /* This macro assumes that we're operating on a variable.  */
  83
  84 #define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
  85                          || c == '\t' || c == '\r')
  86
  87 /* Maximum repeat count.  Less than ten times the maximum signed int32.  */
  88
  89 #define MAX_REPEAT 200000000
  90
  91
  92 /* Save a character to a string buffer, enlarging it as necessary.  */
  93
  94 static void
  95 push_char (char c)
  96 {
  97   char *new;
  98
  99   if (saved_string == NULL)
 100     {
 101       saved_string = scratch;
 102       memset (saved_string,0,SCRATCH_SIZE);
 103       saved_length = SCRATCH_SIZE;
 104       saved_used = 0;
 105     }
 106
 107   if (saved_used >= saved_length)
 108     {
 109       saved_length = 2 * saved_length;
 110       new = get_mem (2 * saved_length);
 111
 112       memset (new,0,2 * saved_length);
 113
 114       memcpy (new, saved_string, saved_used);
 115       if (saved_string != scratch)
 116         free_mem (saved_string);
 117
 118       saved_string = new;
 119     }
 120
 121   saved_string[saved_used++] = c;
 122 }
 123
 124
 125 /* Free the input buffer if necessary.  */
 126
 127 static void
 128 free_saved (void)
 129 {
 130   if (saved_string == NULL)
 131     return;
 132
 133   if (saved_string != scratch)
 134     free_mem (saved_string);
 135
 136   saved_string = NULL;
 137 }
 138
 139
 140 static char
 141 next_char (void)
 142 {
 143   int length;
 144   char c, *p;
 145
 146   if (last_char != '\0')
 147     {
 148       at_eol = 0;
 149       c = last_char;
 150       last_char = '\0';
 151       goto done;
 152     }
 153
 154   length = 1;
 155
 156   p = salloc_r (current_unit->s, &length);
 157   if (p == NULL)
 158     {
 159       generate_error (ERROR_OS, NULL);
 160       return '\0';
 161     }
 162
 163   if (length == 0)
 164     {
 165       /* For internal files return a newline instead of signalling EOF.  */
 166       /* ??? This isn't quite right, but we don't handle internal files
 167          with multiple records.  */
 168       if (is_internal_unit ())
 169         c = '\n';
 170       else
 171         longjmp (g.eof_jump, 1);
 172     }
 173   else
 174     c = *p;
 175
 176 done:
 177   at_eol = (c == '\n' || c == '\r');
 178   return c;
 179 }
 180
 181
 182 /* Push a character back onto the input.  */
 183
 184 static void
 185 unget_char (char c)
 186 {
 187   last_char = c;
 188 }
 189
 190
 191 /* Skip over spaces in the input.  Returns the nonspace character that
 192    terminated the eating and also places it back on the input.  */
 193
 194 static char
 195 eat_spaces (void)
 196 {
 197   char c;
 198
 199   do
 200     {
 201       c = next_char ();
 202     }
 203   while (c == ' ' || c == '\t');
 204
 205   unget_char (c);
 206   return c;
 207 }
 208
 209
 210 /* Skip over a separator.  Technically, we don't always eat the whole
 211    separator.  This is because if we've processed the last input item,
 212    then a separator is unnecessary.  Plus the fact that operating
 213    systems usually deliver console input on a line basis.
 214
 215    The upshot is that if we see a newline as part of reading a
 216    separator, we stop reading.  If there are more input items, we
 217    continue reading the separator with finish_separator() which takes
 218    care of the fact that we may or may not have seen a comma as part
 219    of the separator.  */
 220
 221 static void
 222 eat_separator (void)
 223 {
 224   char c;
 225
 226   eat_spaces ();
 227   comma_flag = 0;
 228
 229   c = next_char ();
 230   switch (c)
 231     {
 232     case ',':
 233       comma_flag = 1;
 234       eat_spaces ();
 235       break;
 236
 237     case '/':
 238       input_complete = 1;
 239       break;
 240
 241     case '\n':
 242     case '\r':
 243       at_eol = 1;
 244       break;
 245
 246     case '!':
 247       if (namelist_mode)
 248         {                       /* Eat a namelist comment.  */
 249           do
 250             c = next_char ();
 251           while (c != '\n');
 252
 253           break;
 254         }
 255
 256       /* Fall Through...  */
 257
 258     default:
 259       unget_char (c);
 260       break;
 261     }
 262 }
 263
 264
 265 /* Finish processing a separator that was interrupted by a newline.
 266    If we're here, then another data item is present, so we finish what
 267    we started on the previous line.  */
 268
 269 static void
 270 finish_separator (void)
 271 {
 272   char c;
 273
 274  restart:
 275   eat_spaces ();
 276
 277   c = next_char ();
 278   switch (c)
 279     {
 280     case ',':
 281       if (comma_flag)
 282         unget_char (c);
 283       else
 284         {
 285           c = eat_spaces ();
 286           if (c == '\n')
 287             goto restart;
 288         }
 289
 290       break;
 291
 292     case '/':
 293       input_complete = 1;
 294       if (!namelist_mode) next_record (0);
 295       break;
 296
 297     case '\n':
 298     case '\r':
 299       goto restart;
 300
 301     case '!':
 302       if (namelist_mode)
 303         {
 304           do
 305             c = next_char ();
 306           while (c != '\n');
 307
 308           goto restart;
 309         }
 310
 311     default:
 312       unget_char (c);
 313       break;
 314     }
 315 }
 316
 317 /* This function is needed to catch bad conversions so that namelist can
 318    attempt to see if saved_string contains a new object name rather than
 319    a bad value.  */
 320
 321 static int
 322 nml_bad_return (char c)
 323 {
 324   if (namelist_mode)
 325     {
 326       nml_read_error = 1;
 327       unget_char(c);
 328       return 1;
 329     }
 330   return 0;
 331 }
 332
 333 /* Convert an unsigned string to an integer.  The length value is -1
 334    if we are working on a repeat count.  Returns nonzero if we have a
 335    range problem.  As a side effect, frees the saved_string.  */
 336
 337 static int
 338 convert_integer (int length, int negative)
 339 {
 340   char c, *buffer, message[100];
 341   int m;
 342   GFC_INTEGER_LARGEST v, max, max10;
 343
 344   buffer = saved_string;
 345   v = 0;
 346
 347   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
 348   max10 = max / 10;
 349
 350   for (;;)
 351     {
 352       c = *buffer++;
 353       if (c == '\0')
 354         break;
 355       c -= '0';
 356
 357       if (v > max10)
 358         goto overflow;
 359       v = 10 * v;
 360
 361       if (v > max - c)
 362         goto overflow;
 363       v += c;
 364     }
 365
 366   m = 0;
 367
 368   if (length != -1)
 369     {
 370       if (negative)
 371         v = -v;
 372       set_integer (value, v, length);
 373     }
 374   else
 375     {
 376       repeat_count = v;
 377
 378       if (repeat_count == 0)
 379         {
 380           st_sprintf (message, "Zero repeat count in item %d of list input",
 381                       g.item_count);
 382
 383           generate_error (ERROR_READ_VALUE, message);
 384           m = 1;
 385         }
 386     }
 387
 388   free_saved ();
 389   return m;
 390
 391  overflow:
 392   if (length == -1)
 393     st_sprintf (message, "Repeat count overflow in item %d of list input",
 394                 g.item_count);
 395   else
 396     st_sprintf (message, "Integer overflow while reading item %d",
 397                 g.item_count);
 398
 399   free_saved ();
 400   generate_error (ERROR_READ_VALUE, message);
 401
 402   return 1;
 403 }
 404
 405
 406 /* Parse a repeat count for logical and complex values which cannot
 407    begin with a digit.  Returns nonzero if we are done, zero if we
 408    should continue on.  */
 409
 410 static int
 411 parse_repeat (void)
 412 {
 413   char c, message[100];
 414   int repeat;
 415
 416   c = next_char ();
 417   switch (c)
 418     {
 419     CASE_DIGITS:
 420       repeat = c - '0';
 421       break;
 422
 423     CASE_SEPARATORS:
 424       unget_char (c);
 425       eat_separator ();
 426       return 1;
 427
 428     default:
 429       unget_char (c);
 430       return 0;
 431     }
 432
 433   for (;;)
 434     {
 435       c = next_char ();
 436       switch (c)
 437         {
 438         CASE_DIGITS:
 439           repeat = 10 * repeat + c - '0';
 440
 441           if (repeat > MAX_REPEAT)
 442             {
 443               st_sprintf (message,
 444                           "Repeat count overflow in item %d of list input",
 445                           g.item_count);
 446
 447               generate_error (ERROR_READ_VALUE, message);
 448               return 1;
 449             }
 450
 451           break;
 452
 453         case '*':
 454           if (repeat == 0)
 455             {
 456               st_sprintf (message,
 457                           "Zero repeat count in item %d of list input",
 458                           g.item_count);
 459
 460               generate_error (ERROR_READ_VALUE, message);
 461               return 1;
 462             }
 463
 464           goto done;
 465
 466         default:
 467           goto bad_repeat;
 468         }
 469     }
 470
 471  done:
 472   repeat_count = repeat;
 473   return 0;
 474
 475  bad_repeat:
 476   st_sprintf (message, "Bad repeat count in item %d of list input",
 477               g.item_count);
 478
 479   generate_error (ERROR_READ_VALUE, message);
 480   return 1;
 481 }
 482
 483
 484 /* Read a logical character on the input.  */
 485
 486 static void
 487 read_logical (int length)
 488 {
 489   char c, message[100];
 490   int v;
 491
 492   if (parse_repeat ())
 493     return;
 494
 495   c = next_char ();
 496   switch (c)
 497     {
 498     case 't':
 499     case 'T':
 500       v = 1;
 501       break;
 502     case 'f':
 503     case 'F':
 504       v = 0;
 505       break;
 506
 507     case '.':
 508       c = next_char ();
 509       switch (c)
 510         {
 511         case 't':
 512         case 'T':
 513           v = 1;
 514           break;
 515         case 'f':
 516         case 'F':
 517           v = 0;
 518           break;
 519         default:
 520           goto bad_logical;
 521         }
 522
 523       break;
 524
 525     CASE_SEPARATORS:
 526       unget_char (c);
 527       eat_separator ();
 528       return;                   /* Null value.  */
 529
 530     default:
 531       goto bad_logical;
 532     }
 533
 534   saved_type = BT_LOGICAL;
 535   saved_length = length;
 536
 537   /* Eat trailing garbage.  */
 538   do
 539     {
 540       c = next_char ();
 541     }
 542   while (!is_separator (c));
 543
 544   unget_char (c);
 545   eat_separator ();
 546   free_saved ();
 547   set_integer ((int *) value, v, length);
 548
 549   return;
 550
 551  bad_logical:
 552
 553   if (nml_bad_return (c))
 554     return;
 555
 556   st_sprintf (message, "Bad logical value while reading item %d",
 557               g.item_count);
 558
 559   generate_error (ERROR_READ_VALUE, message);
 560 }
 561
 562
 563 /* Reading integers is tricky because we can actually be reading a
 564    repeat count.  We have to store the characters in a buffer because
 565    we could be reading an integer that is larger than the default int
 566    used for repeat counts.  */
 567
 568 static void
 569 read_integer (int length)
 570 {
 571   char c, message[100];
 572   int negative;
 573
 574   negative = 0;
 575
 576   c = next_char ();
 577   switch (c)
 578     {
 579     case '-':
 580       negative = 1;
 581       /* Fall through...  */
 582
 583     case '+':
 584       c = next_char ();
 585       goto get_integer;
 586
 587     CASE_SEPARATORS:            /* Single null.  */
 588       unget_char (c);
 589       eat_separator ();
 590       return;
 591
 592     CASE_DIGITS:
 593       push_char (c);
 594       break;
 595
 596     default:
 597       goto bad_integer;
 598     }
 599
 600   /* Take care of what may be a repeat count.  */
 601
 602   for (;;)
 603     {
 604       c = next_char ();
 605       switch (c)
 606         {
 607         CASE_DIGITS:
 608           push_char (c);
 609           break;
 610
 611         case '*':
 612           push_char ('\0');
 613           goto repeat;
 614
 615         CASE_SEPARATORS:        /* Not a repeat count.  */
 616           goto done;
 617
 618         default:
 619           goto bad_integer;
 620         }
 621     }
 622
 623  repeat:
 624   if (convert_integer (-1, 0))
 625     return;
 626
 627   /* Get the real integer.  */
 628
 629   c = next_char ();
 630   switch (c)
 631     {
 632     CASE_DIGITS:
 633       break;
 634
 635     CASE_SEPARATORS:
 636       unget_char (c);
 637       eat_separator ();
 638       return;
 639
 640     case '-':
 641       negative = 1;
 642       /* Fall through...  */
 643
 644     case '+':
 645       c = next_char ();
 646       break;
 647     }
 648
 649  get_integer:
 650   if (!isdigit (c))
 651     goto bad_integer;
 652   push_char (c);
 653
 654   for (;;)
 655     {
 656       c = next_char ();
 657       switch (c)
 658         {
 659         CASE_DIGITS:
 660           push_char (c);
 661           break;
 662
 663         CASE_SEPARATORS:
 664           goto done;
 665
 666         default:
 667           goto bad_integer;
 668         }
 669     }
 670
 671  bad_integer:
 672
 673   if (nml_bad_return (c))
 674     return;
 675
 676   free_saved ();
 677
 678   st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
 679   generate_error (ERROR_READ_VALUE, message);
 680
 681   return;
 682
 683  done:
 684   unget_char (c);
 685   eat_separator ();
 686
 687   push_char ('\0');
 688   if (convert_integer (length, negative))
 689     {
 690        free_saved ();
 691        return;
 692     }
 693
 694   free_saved ();
 695   saved_type = BT_INTEGER;
 696 }
 697
 698
 699 /* Read a character variable.  */
 700
 701 static void
 702 read_character (int length __attribute__ ((unused)))
 703 {
 704   char c, quote, message[100];
 705
 706   quote = ' ';                  /* Space means no quote character.  */
 707
 708   c = next_char ();
 709   switch (c)
 710     {
 711     CASE_DIGITS:
 712       push_char (c);
 713       break;
 714
 715     CASE_SEPARATORS:
 716       unget_char (c);           /* NULL value.  */
 717       eat_separator ();
 718       return;
 719
 720     case '"':
 721     case '\'':
 722       quote = c;
 723       goto get_string;
 724
 725     default:
 726       push_char (c);
 727       goto get_string;
 728     }
 729
 730   /* Deal with a possible repeat count.  */
 731
 732   for (;;)
 733     {
 734       c = next_char ();
 735       switch (c)
 736         {
 737         CASE_DIGITS:
 738           push_char (c);
 739           break;
 740
 741         CASE_SEPARATORS:
 742           unget_char (c);
 743           goto done;            /* String was only digits!  */
 744
 745         case '*':
 746           push_char ('\0');
 747           goto got_repeat;
 748
 749         default:
 750           push_char (c);
 751           goto get_string;      /* Not a repeat count after all.  */
 752         }
 753     }
 754
 755  got_repeat:
 756   if (convert_integer (-1, 0))
 757     return;
 758
 759   /* Now get the real string.  */
 760
 761   c = next_char ();
 762   switch (c)
 763     {
 764     CASE_SEPARATORS:
 765       unget_char (c);           /* Repeated NULL values.  */
 766       eat_separator ();
 767       return;
 768
 769     case '"':
 770     case '\'':
 771       quote = c;
 772       break;
 773
 774     default:
 775       push_char (c);
 776       break;
 777     }
 778
 779  get_string:
 780   for (;;)
 781     {
 782       c = next_char ();
 783       switch (c)
 784         {
 785         case '"':
 786         case '\'':
 787           if (c != quote)
 788             {
 789               push_char (c);
 790               break;
 791             }
 792
 793           /* See if we have a doubled quote character or the end of
 794              the string.  */
 795
 796           c = next_char ();
 797           if (c == quote)
 798             {
 799               push_char (quote);
 800               break;
 801             }
 802
 803           unget_char (c);
 804           goto done;
 805
 806         CASE_SEPARATORS:
 807           if (quote == ' ')
 808             {
 809               unget_char (c);
 810               goto done;
 811             }
 812
 813           if (c != '\n')
 814             push_char (c);
 815           break;
 816
 817         default:
 818           push_char (c);
 819           break;
 820         }
 821     }
 822
 823   /* At this point, we have to have a separator, or else the string is
 824      invalid.  */
 825  done:
 826   c = next_char ();
 827   if (is_separator (c))
 828     {
 829       unget_char (c);
 830       eat_separator ();
 831       saved_type = BT_CHARACTER;
 832     }
 833   else
 834     {
 835       free_saved ();
 836       st_sprintf (message, "Invalid string input in item %d", g.item_count);
 837       generate_error (ERROR_READ_VALUE, message);
 838     }
 839 }
 840
 841
 842 /* Parse a component of a complex constant or a real number that we
 843    are sure is already there.  This is a straight real number parser.  */
 844
 845 static int
 846 parse_real (void *buffer, int length)
 847 {
 848   char c, message[100];
 849   int m, seen_dp;
 850
 851   c = next_char ();
 852   if (c == '-' || c == '+')
 853     {
 854       push_char (c);
 855       c = next_char ();
 856     }
 857
 858   if (!isdigit (c) && c != '.')
 859     goto bad;
 860
 861   push_char (c);
 862
 863   seen_dp = (c == '.') ? 1 : 0;
 864
 865   for (;;)
 866     {
 867       c = next_char ();
 868       switch (c)
 869         {
 870         CASE_DIGITS:
 871           push_char (c);
 872           break;
 873
 874         case '.':
 875           if (seen_dp)
 876             goto bad;
 877
 878           seen_dp = 1;
 879           push_char (c);
 880           break;
 881
 882         case 'e':
 883         case 'E':
 884         case 'd':
 885         case 'D':
 886           push_char ('e');
 887           goto exp1;
 888
 889         case '-':
 890         case '+':
 891           push_char ('e');
 892           push_char (c);
 893           c = next_char ();
 894           goto exp2;
 895
 896         CASE_SEPARATORS:
 897           unget_char (c);
 898           goto done;
 899
 900         default:
 901           goto done;
 902         }
 903     }
 904
 905  exp1:
 906   c = next_char ();
 907   if (c != '-' && c != '+')
 908     push_char ('+');
 909   else
 910     {
 911       push_char (c);
 912       c = next_char ();
 913     }
 914
 915  exp2:
 916   if (!isdigit (c))
 917     goto bad;
 918   push_char (c);
 919
 920   for (;;)
 921     {
 922       c = next_char ();
 923       switch (c)
 924         {
 925         CASE_DIGITS:
 926           push_char (c);
 927           break;
 928
 929         CASE_SEPARATORS:
 930           unget_char (c);
 931           goto done;
 932
 933         default:
 934           goto done;
 935         }
 936     }
 937
 938  done:
 939   unget_char (c);
 940   push_char ('\0');
 941
 942   m = convert_real (buffer, saved_string, length);
 943   free_saved ();
 944
 945   return m;
 946
 947  bad:
 948   free_saved ();
 949   st_sprintf (message, "Bad floating point number for item %d", g.item_count);
 950   generate_error (ERROR_READ_VALUE, message);
 951
 952   return 1;
 953 }
 954
 955
 956 /* Reading a complex number is straightforward because we can tell
 957    what it is right away.  */
 958
 959 static void
 960 read_complex (int length)
 961 {
 962   char message[100];
 963   char c;
 964
 965   if (parse_repeat ())
 966     return;
 967
 968   c = next_char ();
 969   switch (c)
 970     {
 971     case '(':
 972       break;
 973
 974     CASE_SEPARATORS:
 975       unget_char (c);
 976       eat_separator ();
 977       return;
 978
 979     default:
 980       goto bad_complex;
 981     }
 982
 983   eat_spaces ();
 984   if (parse_real (value, length))
 985     return;
 986
 987 eol_1:
 988   eat_spaces ();
 989   c = next_char ();
 990   if (c == '\n' || c== '\r')
 991     goto eol_1;
 992   else
 993     unget_char (c);
 994
 995   if (next_char () != ',')
 996     goto bad_complex;
 997
 998 eol_2:
 999   eat_spaces ();
1000   c = next_char ();
1001   if (c == '\n' || c== '\r')
1002     goto eol_2;
1003   else
1004     unget_char (c);
1005
1006   if (parse_real (value + length, length))
1007     return;
1008
1009   eat_spaces ();
1010   if (next_char () != ')')
1011     goto bad_complex;
1012
1013   c = next_char ();
1014   if (!is_separator (c))
1015     goto bad_complex;
1016
1017   unget_char (c);
1018   eat_separator ();
1019
1020   free_saved ();
1021   saved_type = BT_COMPLEX;
1022   return;
1023
1024  bad_complex:
1025
1026   if (nml_bad_return (c))
1027     return;
1028
1029   st_sprintf (message, "Bad complex value in item %d of list input",
1030               g.item_count);
1031
1032   generate_error (ERROR_READ_VALUE, message);
1033 }
1034
1035
1036 /* Parse a real number with a possible repeat count.  */
1037
1038 static void
1039 read_real (int length)
1040 {
1041   char c, message[100];
1042   int seen_dp;
1043
1044   seen_dp = 0;
1045
1046   c = next_char ();
1047   switch (c)
1048     {
1049     CASE_DIGITS:
1050       push_char (c);
1051       break;
1052
1053     case '.':
1054       push_char (c);
1055       seen_dp = 1;
1056       break;
1057
1058     case '+':
1059     case '-':
1060       goto got_sign;
1061
1062     CASE_SEPARATORS:
1063       unget_char (c);           /* Single null.  */
1064       eat_separator ();
1065       return;
1066
1067     default:
1068       goto bad_real;
1069     }
1070
1071   /* Get the digit string that might be a repeat count.  */
1072
1073   for (;;)
1074     {
1075       c = next_char ();
1076       switch (c)
1077         {
1078         CASE_DIGITS:
1079           push_char (c);
1080           break;
1081
1082         case '.':
1083           if (seen_dp)
1084             goto bad_real;
1085
1086           seen_dp = 1;
1087           push_char (c);
1088           goto real_loop;
1089
1090         case 'E':
1091         case 'e':
1092         case 'D':
1093         case 'd':
1094           goto exp1;
1095
1096         case '+':
1097         case '-':
1098           push_char ('e');
1099           push_char (c);
1100           c = next_char ();
1101           goto exp2;
1102
1103         case '*':
1104           push_char ('\0');
1105           goto got_repeat;
1106
1107         CASE_SEPARATORS:
1108           if (c != '\n' &&  c != ',' && c != '\r')
1109             unget_char (c);
1110           goto done;
1111
1112         default:
1113           goto bad_real;
1114         }
1115     }
1116
1117  got_repeat:
1118   if (convert_integer (-1, 0))
1119     return;
1120
1121   /* Now get the number itself.  */
1122
1123   c = next_char ();
1124   if (is_separator (c))
1125     {                           /* Repeated null value.  */
1126       unget_char (c);
1127       eat_separator ();
1128       return;
1129     }
1130
1131   if (c != '-' && c != '+')
1132     push_char ('+');
1133   else
1134     {
1135     got_sign:
1136       push_char (c);
1137       c = next_char ();
1138     }
1139
1140   if (!isdigit (c) && c != '.')
1141     goto bad_real;
1142
1143   if (c == '.')
1144     {
1145       if (seen_dp)
1146         goto bad_real;
1147       else
1148         seen_dp = 1;
1149     }
1150
1151   push_char (c);
1152
1153  real_loop:
1154   for (;;)
1155     {
1156       c = next_char ();
1157       switch (c)
1158         {
1159         CASE_DIGITS:
1160           push_char (c);
1161           break;
1162
1163         CASE_SEPARATORS:
1164           goto done;
1165
1166         case '.':
1167           if (seen_dp)
1168             goto bad_real;
1169
1170           seen_dp = 1;
1171           push_char (c);
1172           break;
1173
1174         case 'E':
1175         case 'e':
1176         case 'D':
1177         case 'd':
1178           goto exp1;
1179
1180         case '+':
1181         case '-':
1182           push_char ('e');
1183           push_char (c);
1184           c = next_char ();
1185           goto exp2;
1186
1187         default:
1188           goto bad_real;
1189         }
1190     }
1191
1192  exp1:
1193   push_char ('e');
1194
1195   c = next_char ();
1196   if (c != '+' && c != '-')
1197     push_char ('+');
1198   else
1199     {
1200       push_char (c);
1201       c = next_char ();
1202     }
1203
1204  exp2:
1205   if (!isdigit (c))
1206     goto bad_real;
1207   push_char (c);
1208
1209   for (;;)
1210     {
1211       c = next_char ();
1212
1213       switch (c)
1214         {
1215         CASE_DIGITS:
1216           push_char (c);
1217           break;
1218
1219         CASE_SEPARATORS:
1220           goto done;
1221
1222         default:
1223           goto bad_real;
1224         }
1225     }
1226
1227  done:
1228   unget_char (c);
1229   eat_separator ();
1230   push_char ('\0');
1231   if (convert_real (value, saved_string, length))
1232     return;
1233
1234   free_saved ();
1235   saved_type = BT_REAL;
1236   return;
1237
1238  bad_real:
1239
1240   if (nml_bad_return (c))
1241     return;
1242
1243   st_sprintf (message, "Bad real number in item %d of list input",
1244               g.item_count);
1245
1246   generate_error (ERROR_READ_VALUE, message);
1247 }
1248
1249
1250 /* Check the current type against the saved type to make sure they are
1251    compatible.  Returns nonzero if incompatible.  */
1252
1253 static int
1254 check_type (bt type, int len)
1255 {
1256   char message[100];
1257
1258   if (saved_type != BT_NULL && saved_type != type)
1259     {
1260       st_sprintf (message, "Read type %s where %s was expected for item %d",
1261                   type_name (saved_type), type_name (type), g.item_count);
1262
1263       generate_error (ERROR_READ_VALUE, message);
1264       return 1;
1265     }
1266
1267   if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
1268     return 0;
1269
1270   if (saved_length != len)
1271     {
1272       st_sprintf (message,
1273                   "Read kind %d %s where kind %d is required for item %d",
1274                   saved_length, type_name (saved_type), len, g.item_count);
1275       generate_error (ERROR_READ_VALUE, message);
1276       return 1;
1277     }
1278
1279   return 0;
1280 }
1281
1282
1283 /* Top level data transfer subroutine for list reads.  Because we have
1284    to deal with repeat counts, the data item is always saved after
1285    reading, usually in the value[] array.  If a repeat count is
1286    greater than one, we copy the data item multiple times.  */
1287
1288 void
1289 list_formatted_read (bt type, void *p, int len)
1290 {
1291   char c;
1292   int m;
1293
1294   namelist_mode = 0;
1295
1296   if (setjmp (g.eof_jump))
1297     {
1298       generate_error (ERROR_END, NULL);
1299       return;
1300     }
1301
1302   if (g.first_item)
1303     {
1304       g.first_item = 0;
1305       input_complete = 0;
1306       repeat_count = 1;
1307       at_eol = 0;
1308
1309       c = eat_spaces ();
1310       if (is_separator (c))
1311         {                       /* Found a null value.  */
1312           eat_separator ();
1313           repeat_count = 0;
1314           if (at_eol)
1315             finish_separator ();
1316           else
1317             return;
1318         }
1319
1320     }
1321   else
1322     {
1323       if (input_complete)
1324         return;
1325
1326       if (repeat_count > 0)
1327         {
1328           if (check_type (type, len))
1329             return;
1330           goto set_value;
1331         }
1332
1333       if (at_eol)
1334         finish_separator ();
1335       else
1336         {
1337           eat_spaces ();
1338           /* trailing spaces prior to end of line */
1339           if (at_eol)
1340             finish_separator ();
1341         }
1342
1343       saved_type = BT_NULL;
1344       repeat_count = 1;
1345     }
1346
1347   switch (type)
1348     {
1349     case BT_INTEGER:
1350       read_integer (len);
1351       break;
1352     case BT_LOGICAL:
1353       read_logical (len);
1354       break;
1355     case BT_CHARACTER:
1356       read_character (len);
1357       break;
1358     case BT_REAL:
1359       read_real (len);
1360       break;
1361     case BT_COMPLEX:
1362       read_complex (len);
1363       break;
1364     default:
1365       internal_error ("Bad type for list read");
1366     }
1367
1368   if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
1369     saved_length = len;
1370
1371   if (ioparm.library_return != LIBRARY_OK)
1372     return;
1373
1374  set_value:
1375   switch (saved_type)
1376     {
1377     case BT_COMPLEX:
1378       len = 2 * len;
1379       /* Fall through.  */
1380
1381     case BT_INTEGER:
1382     case BT_REAL:
1383     case BT_LOGICAL:
1384       memcpy (p, value, len);
1385       break;
1386
1387     case BT_CHARACTER:
1388       if (saved_string)
1389        {
1390           m = (len < saved_used) ? len : saved_used;
1391           memcpy (p, saved_string, m);
1392        }
1393       else
1394         /* Just delimiters encountered, nothing to copy but SPACE.  */
1395         m = 0;
1396
1397       if (m < len)
1398         memset (((char *) p) + m, ' ', len - m);
1399       break;
1400
1401     case BT_NULL:
1402       break;
1403     }
1404
1405   if (--repeat_count <= 0)
1406     free_saved ();
1407 }
1408
1409 void
1410 init_at_eol(void)
1411 {
1412   at_eol = 0;
1413 }
1414
1415 /* Finish a list read.  */
1416
1417 void
1418 finish_list_read (void)
1419 {
1420   char c;
1421
1422   free_saved ();
1423
1424   if (at_eol)
1425     {
1426       at_eol = 0;
1427       return;
1428     }
1429
1430   do
1431     {
1432       c = next_char ();
1433     }
1434   while (c != '\n');
1435 }
1436
1437 /*                      NAMELIST INPUT
1438
1439 void namelist_read (void)
1440 calls:
1441    static void nml_match_name (char *name, int len)
1442    static int nml_query (void)
1443    static int nml_get_obj_data (void)
1444 calls:
1445       static void nml_untouch_nodes (void)
1446       static namelist_info * find_nml_node (char * var_name)
1447       static int nml_parse_qualifier(descriptor_dimension * ad,
1448                                      nml_loop_spec * ls, int rank)
1449       static void nml_touch_nodes (namelist_info * nl)
1450       static int nml_read_obj (namelist_info * nl, index_type offset)
1451 calls:
1452       -itself-  */
1453
1454 /* Carries error messages from the qualifier parser.  */
1455 static char parse_err_msg[30];
1456
1457 /* Carries error messages for error returns.  */
1458 static char nml_err_msg[100];
1459
1460 /* Pointer to the previously read object, in case attempt is made to read
1461    new object name.  Should this fail, error message can give previous
1462    name.  */
1463
1464 static namelist_info * prev_nl;
1465
1466 /* Lower index for substring qualifier.  */
1467
1468 static index_type clow;
1469
1470 /* Upper index for substring qualifier.  */
1471
1472 static index_type chigh;
1473
1474 /* Inputs a rank-dimensional qualifier, which can contain
1475    singlets, doublets, triplets or ':' with the standard meanings.  */
1476
1477 static try
1478 nml_parse_qualifier(descriptor_dimension * ad,
1479                     nml_loop_spec * ls, int rank)
1480 {
1481   int dim;
1482   int indx;
1483   int neg;
1484   int null_flag;
1485   char c;
1486
1487   /* The next character in the stream should be the '('.  */
1488
1489   c = next_char ();
1490
1491   /* Process the qualifier, by dimension and triplet.  */
1492
1493   for (dim=0; dim < rank; dim++ )
1494     {
1495       for (indx=0; indx<3; indx++)
1496         {
1497           free_saved ();
1498           eat_spaces ();
1499           neg = 0;
1500
1501           /*process a potential sign.  */
1502
1503           c = next_char ();
1504           switch (c)
1505             {
1506             case '-':
1507               neg = 1;
1508               break;
1509
1510             case '+':
1511               break;
1512
1513             default:
1514               unget_char (c);
1515               break;
1516             }
1517
1518           /*process characters up to the next ':' , ',' or ')'  */
1519
1520           for (;;)
1521             {
1522               c = next_char ();
1523
1524               switch (c)
1525                 {
1526                 case ':':
1527                   break;
1528
1529                 case ',': case ')':
1530                   if ( (c==',' && dim == rank -1)
1531                     || (c==')' && dim  < rank -1))
1532                     {
1533                       st_sprintf (parse_err_msg,
1534                                   "Bad number of index fields");
1535                       goto err_ret;
1536                     }
1537                   break;
1538
1539                 CASE_DIGITS:
1540                   push_char (c);
1541                   continue;
1542
1543                 case ' ': case '\t':
1544                   eat_spaces ();
1545                   c = next_char ();
1546                   break;
1547
1548                 default:
1549                   st_sprintf (parse_err_msg, "Bad character in index");
1550                   goto err_ret;
1551                 }
1552
1553               if (( c==',' || c==')') && indx==0 && saved_string == 0 )
1554                 {
1555                   st_sprintf (parse_err_msg, "Null index field");
1556                   goto err_ret;
1557                 }
1558
1559               if ( ( c==':' && indx==1 && saved_string == 0)
1560                 || (indx==2 && saved_string == 0))
1561                 {
1562                   st_sprintf(parse_err_msg, "Bad index triplet");
1563                   goto err_ret;
1564                 }
1565
1566               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
1567               null_flag = 0;
1568               if ( (c==':'  && indx==0 && saved_string == 0)
1569                 || (indx==1 && saved_string == 0))
1570                 {
1571                   null_flag = 1;
1572                   break;
1573                 }
1574
1575               /* Now read the index.  */
1576
1577               if (convert_integer (sizeof(int),neg))
1578                 {
1579                   st_sprintf (parse_err_msg, "Bad integer in index");
1580                   goto err_ret;
1581                 }
1582               break;
1583             }
1584
1585           /*feed the index values to the triplet arrays.  */
1586
1587           if (!null_flag)
1588             {
1589               if (indx == 0)
1590                 ls[dim].start = *(int *)value;
1591               if (indx == 1)
1592                 ls[dim].end   = *(int *)value;
1593               if (indx == 2)
1594                 ls[dim].step  = *(int *)value;
1595             }
1596
1597           /*singlet or doublet indices  */
1598
1599           if (c==',' || c==')')
1600             {
1601               if (indx == 0)
1602                 {
1603                   ls[dim].start = *(int *)value;
1604                   ls[dim].end = *(int *)value;
1605                 }
1606               break;
1607             }
1608         }
1609
1610       /*Check the values of the triplet indices.  */
1611
1612       if ( (ls[dim].start > (ssize_t)ad[dim].ubound)
1613         || (ls[dim].start < (ssize_t)ad[dim].lbound)
1614         || (ls[dim].end   > (ssize_t)ad[dim].ubound)
1615         || (ls[dim].end   < (ssize_t)ad[dim].lbound))
1616         {
1617           st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
1618           goto err_ret;
1619         }
1620       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
1621         || (ls[dim].step == 0))
1622         {
1623           st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
1624           goto err_ret;
1625         }
1626
1627       /* Initialise the loop index counter.  */
1628
1629       ls[dim].idx = ls[dim].start;
1630
1631     }
1632   eat_spaces ();
1633   return SUCCESS;
1634
1635 err_ret:
1636
1637   return FAILURE;
1638 }
1639
1640 static namelist_info *
1641 find_nml_node (char * var_name)
1642 {
1643   namelist_info * t = ionml;
1644   while (t != NULL)
1645     {
1646       if (strcmp (var_name,t->var_name) == 0)
1647         {
1648           t->touched = 1;
1649           return t;
1650         }
1651       t = t->next;
1652     }
1653   return NULL;
1654 }
1655
1656 /* Visits all the components of a derived type that have
1657    not explicitly been identified in the namelist input.
1658    touched is set and the loop specification initialised
1659    to default values  */
1660
1661 static void
1662 nml_touch_nodes (namelist_info * nl)
1663 {
1664   index_type len = strlen (nl->var_name) + 1;
1665   int dim;
1666   char * ext_name = (char*)get_mem (len + 1);
1667   strcpy (ext_name, nl->var_name);
1668   strcat (ext_name, "%");
1669   for (nl = nl->next; nl; nl = nl->next)
1670     {
1671       if (strncmp (nl->var_name, ext_name, len) == 0)
1672         {
1673           nl->touched = 1;
1674           for (dim=0; dim < nl->var_rank; dim++)
1675             {
1676               nl->ls[dim].step = 1;
1677               nl->ls[dim].end = nl->dim[dim].ubound;
1678               nl->ls[dim].start = nl->dim[dim].lbound;
1679               nl->ls[dim].idx = nl->ls[dim].start;
1680             }
1681         }
1682       else
1683         break;
1684     }
1685   free_mem (ext_name);
1686   return;
1687 }
1688
1689 /* Resets touched for the entire list of nml_nodes, ready for a
1690    new object.  */
1691
1692 static void
1693 nml_untouch_nodes (void)
1694 {
1695   namelist_info * t;
1696   for (t = ionml; t; t = t->next)
1697     t->touched = 0;
1698   return;
1699 }
1700
1701 /* Attempts to input name to namelist name.  Returns nml_read_error = 1
1702    on no match.  */
1703
1704 static void
1705 nml_match_name (const char *name, index_type len)
1706 {
1707   index_type i;
1708   char c;
1709   nml_read_error = 0;
1710   for (i = 0; i < len; i++)
1711     {
1712       c = next_char ();
1713       if (tolower (c) != tolower (name[i]))
1714         {
1715           nml_read_error = 1;
1716           break;
1717         }
1718     }
1719 }
1720
1721 /* If the namelist read is from stdin, output the current state of the
1722    namelist to stdout.  This is used to implement the non-standard query
1723    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1724    the names alone are printed.  */
1725
1726 static void
1727 nml_query (char c)
1728 {
1729   gfc_unit * temp_unit;
1730   namelist_info * nl;
1731   index_type len;
1732   char * p;
1733
1734   if (current_unit->unit_number != options.stdin_unit)
1735     return;
1736
1737   /* Store the current unit and transfer to stdout.  */
1738
1739   temp_unit = current_unit;
1740   current_unit = find_unit (options.stdout_unit);
1741
1742   if (current_unit)
1743     {
1744       g.mode =WRITING;
1745       next_record (0);
1746
1747       /* Write the namelist in its entirety.  */
1748
1749       if (c == '=')
1750         namelist_write ();
1751
1752       /* Or write the list of names.  */
1753
1754       else
1755         {
1756
1757           /* "&namelist_name\n"  */
1758
1759           len = ioparm.namelist_name_len;
1760           p = write_block (len + 2);
1761           if (!p)
1762             goto query_return;
1763           memcpy (p, "&", 1);
1764           memcpy ((char*)(p + 1), ioparm.namelist_name, len);
1765           memcpy ((char*)(p + len + 1), "\n", 1);
1766           for (nl =ionml; nl; nl = nl->next)
1767             {
1768
1769               /* " var_name\n"  */
1770
1771               len = strlen (nl->var_name);
1772               p = write_block (len + 2);
1773               if (!p)
1774                 goto query_return;
1775               memcpy (p, " ", 1);
1776               memcpy ((char*)(p + 1), nl->var_name, len);
1777               memcpy ((char*)(p + len + 1), "\n", 1);
1778             }
1779
1780           /* "&end\n"  */
1781
1782           p = write_block (5);
1783           if (!p)
1784             goto query_return;
1785           memcpy (p, "&end\n", 5);
1786         }
1787
1788       /* Flush the stream to force immediate output.  */
1789
1790       flush (current_unit->s);
1791     }
1792
1793 query_return:
1794
1795   /* Restore the current unit.  */
1796
1797   current_unit = temp_unit;
1798   g.mode = READING;
1799   return;
1800 }
1801
1802 /* Reads and stores the input for the namelist object nl.  For an array,
1803    the function loops over the ranges defined by the loop specification.
1804    This default to all the data or to the specification from a qualifier.
1805    nml_read_obj recursively calls itself to read derived types. It visits
1806    all its own components but only reads data for those that were touched
1807    when the name was parsed.  If a read error is encountered, an attempt is
1808    made to return to read a new object name because the standard allows too
1809    little data to be available.  On the other hand, too much data is an
1810    error.  */
1811
1812 static try
1813 nml_read_obj (namelist_info * nl, index_type offset)
1814 {
1815
1816   namelist_info * cmp;
1817   char * obj_name;
1818   int nml_carry;
1819   int len;
1820   int dim;
1821   index_type dlen;
1822   index_type m;
1823   index_type obj_name_len;
1824   void * pdata ;
1825
1826   /* This object not touched in name parsing.  */
1827
1828   if (!nl->touched)
1829     return SUCCESS;
1830
1831   repeat_count = 0;
1832   eat_spaces();
1833
1834   len = nl->len;
1835   switch (nl->type)
1836   {
1837
1838     case GFC_DTYPE_INTEGER:
1839     case GFC_DTYPE_LOGICAL:
1840     case GFC_DTYPE_REAL:
1841       dlen = len;
1842       break;
1843
1844     case GFC_DTYPE_COMPLEX:
1845       dlen = 2* len;
1846       break;
1847
1848     case GFC_DTYPE_CHARACTER:
1849       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
1850       break;
1851
1852     default:
1853       dlen = 0;
1854     }
1855
1856   do
1857     {
1858
1859       /* Update the pointer to the data, using the current index vector  */
1860
1861       pdata = (void*)(nl->mem_pos + offset);
1862       for (dim = 0; dim < nl->var_rank; dim++)
1863         pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
1864                  nl->dim[dim].stride * nl->size);
1865
1866       /* Reset the error flag and try to read next value, if
1867          repeat_count=0  */
1868
1869       nml_read_error = 0;
1870       nml_carry = 0;
1871       if (--repeat_count <= 0)
1872         {
1873           if (input_complete)
1874             return SUCCESS;
1875           if (at_eol)
1876             finish_separator ();
1877           if (input_complete)
1878             return SUCCESS;
1879
1880           /* GFC_TYPE_UNKNOWN through for nulls and is detected
1881              after the switch block.  */
1882
1883           saved_type = GFC_DTYPE_UNKNOWN;
1884           free_saved ();
1885
1886           switch (nl->type)
1887           {
1888           case GFC_DTYPE_INTEGER:
1889               read_integer (len);
1890               break;
1891
1892           case GFC_DTYPE_LOGICAL:
1893               read_logical (len);
1894               break;
1895
1896           case GFC_DTYPE_CHARACTER:
1897               read_character (len);
1898               break;
1899
1900           case GFC_DTYPE_REAL:
1901               read_real (len);
1902               break;
1903
1904           case GFC_DTYPE_COMPLEX:
1905               read_complex (len);
1906               break;
1907
1908           case GFC_DTYPE_DERIVED:
1909             obj_name_len = strlen (nl->var_name) + 1;
1910             obj_name = get_mem (obj_name_len+1);
1911             strcpy (obj_name, nl->var_name);
1912             strcat (obj_name, "%");
1913
1914             /* Now loop over the components. Update the component pointer
1915                with the return value from nml_write_obj.  This loop jumps
1916                past nested derived types by testing if the potential
1917                component name contains '%'.  */
1918
1919             for (cmp = nl->next;
1920                  cmp &&
1921                    !strncmp (cmp->var_name, obj_name, obj_name_len) &&
1922                    !strchr (cmp->var_name + obj_name_len, '%');
1923                  cmp = cmp->next)
1924               {
1925
1926                 if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
1927                   {
1928                     free_mem (obj_name);
1929                     return FAILURE;
1930                   }
1931
1932                 if (input_complete)
1933                   {
1934                     free_mem (obj_name);
1935                     return SUCCESS;
1936                   }
1937               }
1938
1939             free_mem (obj_name);
1940             goto incr_idx;
1941
1942           default:
1943             st_sprintf (nml_err_msg, "Bad type for namelist object %s",
1944                         nl->var_name );
1945             internal_error (nml_err_msg);
1946             goto nml_err_ret;
1947           }
1948         }
1949
1950       /* The standard permits array data to stop short of the number of
1951          elements specified in the loop specification.  In this case, we
1952          should be here with nml_read_error != 0.  Control returns to
1953          nml_get_obj_data and an attempt is made to read object name.  */
1954
1955       prev_nl = nl;
1956       if (nml_read_error)
1957         return SUCCESS;
1958
1959       if (saved_type == GFC_DTYPE_UNKNOWN)
1960         goto incr_idx;
1961
1962
1963       /* Note the switch from GFC_DTYPE_type to BT_type at this point.
1964          This comes about because the read functions return BT_types.  */
1965
1966       switch (saved_type)
1967       {
1968
1969         case BT_COMPLEX:
1970         case BT_REAL:
1971         case BT_INTEGER:
1972         case BT_LOGICAL:
1973           memcpy (pdata, value, dlen);
1974           break;
1975
1976         case BT_CHARACTER:
1977           m = (dlen < saved_used) ? dlen : saved_used;
1978           pdata = (void*)( pdata + clow - 1 );
1979           memcpy (pdata, saved_string, m);
1980           if (m < dlen)
1981             memset ((void*)( pdata + m ), ' ', dlen - m);
1982         break;
1983
1984         default:
1985           break;
1986       }
1987
1988       /* Break out of loop if scalar.  */
1989
1990       if (!nl->var_rank)
1991         break;
1992
1993       /* Now increment the index vector.  */
1994
1995 incr_idx:
1996
1997       nml_carry = 1;
1998       for (dim = 0; dim < nl->var_rank; dim++)
1999         {
2000           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2001           nml_carry = 0;
2002           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2003               ||
2004               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2005             {
2006               nl->ls[dim].idx = nl->ls[dim].start;
2007               nml_carry = 1;
2008             }
2009         }
2010     } while (!nml_carry);
2011
2012   if (repeat_count > 1)
2013     {
2014        st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
2015                    nl->var_name );
2016        goto nml_err_ret;
2017     }
2018   return SUCCESS;
2019
2020 nml_err_ret:
2021
2022   return FAILURE;
2023 }
2024
2025 /* Parses the object name, including array and substring qualifiers.  It
2026    iterates over derived type components, touching those components and
2027    setting their loop specifications, if there is a qualifier.  If the
2028    object is itself a derived type, its components and subcomponents are
2029    touched.  nml_read_obj is called at the end and this reads the data in
2030    the manner specified by the object name.  */
2031
2032 static try
2033 nml_get_obj_data (void)
2034 {
2035   char c;
2036   char * ext_name;
2037   namelist_info * nl;
2038   namelist_info * first_nl = NULL;
2039   namelist_info * root_nl = NULL;
2040   int dim;
2041   int component_flag;
2042
2043   /* Look for end of input or object name.  If '?' or '=?' are encountered
2044      in stdin, print the node names or the namelist to stdout.  */
2045
2046   eat_separator ();
2047   if (input_complete)
2048     return SUCCESS;
2049
2050   if ( at_eol )
2051     finish_separator ();
2052   if (input_complete)
2053     return SUCCESS;
2054
2055   c = next_char ();
2056   switch (c)
2057     {
2058     case '=':
2059       c = next_char ();
2060       if (c != '?')
2061         {
2062           st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
2063           goto nml_err_ret;
2064         }
2065       nml_query ('=');
2066       return SUCCESS;
2067
2068     case '?':
2069       nml_query ('?');
2070       return SUCCESS;
2071
2072     case '$':
2073     case '&':
2074       nml_match_name ("end", 3);
2075       if (nml_read_error)
2076         {
2077           st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
2078           goto nml_err_ret;
2079         }
2080     case '/':
2081       input_complete = 1;
2082       return SUCCESS;
2083
2084     default :
2085       break;
2086     }
2087
2088   /* Untouch all nodes of the namelist and reset the flag that is set for
2089      derived type components.  */
2090
2091   nml_untouch_nodes();
2092   component_flag = 0;
2093
2094   /* Get the object name - should '!' and '\n' be permitted separators?  */
2095
2096 get_name:
2097
2098   free_saved ();
2099
2100   do
2101     {
2102       push_char(tolower(c));
2103       c = next_char ();
2104     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2105
2106   unget_char (c);
2107
2108   /* Check that the name is in the namelist and get pointer to object.
2109      Three error conditions exist: (i) An attempt is being made to
2110      identify a non-existent object, following a failed data read or
2111      (ii) The object name does not exist or (iii) Too many data items
2112      are present for an object.  (iii) gives the same error message
2113      as (i)  */
2114
2115   push_char ('\0');
2116
2117   if (component_flag)
2118     {
2119       ext_name = (char*)get_mem (strlen (root_nl->var_name)
2120                                   + (saved_string ? strlen (saved_string) : 0)
2121                                   + 1);
2122       strcpy (ext_name, root_nl->var_name);
2123       strcat (ext_name, saved_string);
2124       nl = find_nml_node (ext_name);
2125       free_mem (ext_name);
2126     }
2127   else
2128     nl = find_nml_node (saved_string);
2129
2130   if (nl == NULL)
2131     {
2132       if (nml_read_error && prev_nl)
2133         st_sprintf (nml_err_msg, "Bad data for namelist object %s",
2134                     prev_nl->var_name);
2135
2136       else
2137         st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
2138                     saved_string);
2139
2140       goto nml_err_ret;
2141     }
2142
2143   /* Get the length, data length, base pointer and rank of the variable.
2144      Set the default loop specification first.  */
2145
2146   for (dim=0; dim < nl->var_rank; dim++)
2147     {
2148       nl->ls[dim].step = 1;
2149       nl->ls[dim].end = nl->dim[dim].ubound;
2150       nl->ls[dim].start = nl->dim[dim].lbound;
2151       nl->ls[dim].idx = nl->ls[dim].start;
2152     }
2153
2154 /* Check to see if there is a qualifier: if so, parse it.*/
2155
2156   if (c == '(' && nl->var_rank)
2157     {
2158       if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
2159         {
2160           st_sprintf (nml_err_msg, "%s for namelist variable %s",
2161                       parse_err_msg, nl->var_name);
2162           goto nml_err_ret;
2163         }
2164       c = next_char ();
2165       unget_char (c);
2166     }
2167
2168   /* Now parse a derived type component. The root namelist_info address
2169      is backed up, as is the previous component level.  The  component flag
2170      is set and the iteration is made by jumping back to get_name.  */
2171
2172   if (c == '%')
2173     {
2174
2175       if (nl->type != GFC_DTYPE_DERIVED)
2176         {
2177           st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
2178                       nl->var_name);
2179           goto nml_err_ret;
2180         }
2181
2182       if (!component_flag)
2183         first_nl = nl;
2184
2185       root_nl = nl;
2186       component_flag = 1;
2187       c = next_char ();
2188       goto get_name;
2189
2190     }
2191
2192   /* Parse a character qualifier, if present.  chigh = 0 is a default
2193      that signals that the string length = string_length.  */
2194
2195   clow = 1;
2196   chigh = 0;
2197
2198   if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2199     {
2200       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2201       nml_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2202
2203       if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
2204         {
2205           st_sprintf (nml_err_msg, "%s for namelist variable %s",
2206                       parse_err_msg, nl->var_name);
2207           goto nml_err_ret;
2208         }
2209
2210       clow = ind[0].start;
2211       chigh = ind[0].end;
2212
2213       if (ind[0].step != 1)
2214         {
2215           st_sprintf (nml_err_msg,
2216                       "Bad step in substring for namelist object %s",
2217                       nl->var_name);
2218           goto nml_err_ret;
2219         }
2220
2221       c = next_char ();
2222       unget_char (c);
2223     }
2224
2225   /* If a derived type touch its components and restore the root
2226      namelist_info if we have parsed a qualified derived type
2227      component.  */
2228
2229   if (nl->type == GFC_DTYPE_DERIVED)
2230     nml_touch_nodes (nl);
2231   if (component_flag)
2232     nl = first_nl;
2233
2234   /*make sure no extraneous qualifiers are there.*/
2235
2236   if (c == '(')
2237     {
2238       st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
2239                   " namelist object %s", nl->var_name);
2240       goto nml_err_ret;
2241     }
2242
2243 /* According to the standard, an equal sign MUST follow an object name. The
2244    following is possibly lax - it allows comments, blank lines and so on to
2245    intervene.  eat_spaces (); c = next_char (); would be compliant*/
2246
2247   free_saved ();
2248
2249   eat_separator ();
2250   if (input_complete)
2251     return SUCCESS;
2252
2253   if (at_eol)
2254     finish_separator ();
2255   if (input_complete)
2256     return SUCCESS;
2257
2258   c = next_char ();
2259
2260   if (c != '=')
2261     {
2262       st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
2263                   nl->var_name);
2264       goto nml_err_ret;
2265     }
2266
2267   if (nml_read_obj (nl, 0) == FAILURE)
2268     goto nml_err_ret;
2269
2270   return SUCCESS;
2271
2272 nml_err_ret:
2273
2274   return FAILURE;
2275 }
2276
2277 /* Entry point for namelist input.  Goes through input until namelist name
2278   is matched.  Then cycles through nml_get_obj_data until the input is
2279   completed or there is an error.  */
2280
2281 void
2282 namelist_read (void)
2283 {
2284   char c;
2285
2286   namelist_mode = 1;
2287   input_complete = 0;
2288
2289   if (setjmp (g.eof_jump))
2290     {
2291       generate_error (ERROR_END, NULL);
2292       return;
2293     }
2294
2295   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
2296      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2297      node names or namelist on stdout.  */
2298
2299 find_nml_name:
2300   switch (c = next_char ())
2301     {
2302     case '$':
2303     case '&':
2304           break;
2305
2306     case '=':
2307       c = next_char ();
2308       if (c == '?')
2309         nml_query ('=');
2310       else
2311         unget_char (c);
2312       goto find_nml_name;
2313
2314     case '?':
2315       nml_query ('?');
2316
2317     default:
2318       goto find_nml_name;
2319     }
2320
2321   /* Match the name of the namelist.  */
2322
2323   nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
2324
2325   if (nml_read_error)
2326     goto find_nml_name;
2327
2328   /* Ready to read namelist objects.  If there is an error in input
2329      from stdin, output the error message and continue.  */
2330
2331   while (!input_complete)
2332     {
2333       if (nml_get_obj_data ()  == FAILURE)
2334         {
2335           if (current_unit->unit_number != options.stdin_unit)
2336             goto nml_err_ret;
2337
2338           st_printf ("%s\n", nml_err_msg);
2339           flush (find_unit (options.stderr_unit)->s);
2340         }
2341
2342    }
2343
2344   return;
2345
2346   /* All namelist error calls return from here */
2347
2348 nml_err_ret:
2349
2350   generate_error (ERROR_READ_VALUE , nml_err_msg);
2351   return;
2352 }