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