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