libgfortran/io/list_read.c

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