libgfortran/io/list_read.c

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