libgfortran/io/list_read.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    Namelist input contributed by Paul Thomas
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31
  32 #include "io.h"
  33 #include <string.h>
  34 #include <ctype.h>
  35
  36
  37 /* List directed input.  Several parsing subroutines are practically
  38    reimplemented from formatted input, the reason being that there are
  39    all kinds of small differences between formatted and list directed
  40    parsing.  */
  41
  42
  43 /* Subroutines for reading characters from the input.  Because a
  44    repeat count is ambiguous with an integer, we have to read the
  45    whole digit string before seeing if there is a '*' which signals
  46    the repeat count.  Since we can have a lot of potential leading
  47    zeros, we have to be able to back up by arbitrary amount.  Because
  48    the input might not be seekable, we have to buffer the data
  49    ourselves.  */
  50
  51 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
  52                       case '5': case '6': case '7': case '8': case '9'
  53
  54 #define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t': \
  55                          case '\r'
  56
  57 /* This macro assumes that we're operating on a variable.  */
  58
  59 #define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
  60                          || c == '\t' || c == '\r')
  61
  62 /* Maximum repeat count.  Less than ten times the maximum signed int32.  */
  63
  64 #define MAX_REPEAT 200000000
  65
  66
  67 /* Save a character to a string buffer, enlarging it as necessary.  */
  68
  69 static void
  70 push_char (st_parameter_dt *dtp, char c)
  71 {
  72   char *new;
  73
  74   if (dtp->u.p.saved_string == NULL)
  75     {
  76       if (dtp->u.p.scratch == NULL)
  77         dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
  78       dtp->u.p.saved_string = dtp->u.p.scratch;
  79       memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
  80       dtp->u.p.saved_length = SCRATCH_SIZE;
  81       dtp->u.p.saved_used = 0;
  82     }
  83
  84   if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
  85     {
  86       dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
  87       new = get_mem (2 * dtp->u.p.saved_length);
  88
  89       memset (new, 0, 2 * dtp->u.p.saved_length);
  90
  91       memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
  92       if (dtp->u.p.saved_string != dtp->u.p.scratch)
  93         free_mem (dtp->u.p.saved_string);
  94
  95       dtp->u.p.saved_string = new;
  96     }
  97
  98   dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
  99 }
 100
 101
 102 /* Free the input buffer if necessary.  */
 103
 104 static void
 105 free_saved (st_parameter_dt *dtp)
 106 {
 107   if (dtp->u.p.saved_string == NULL)
 108     return;
 109
 110   if (dtp->u.p.saved_string != dtp->u.p.scratch)
 111     free_mem (dtp->u.p.saved_string);
 112
 113   dtp->u.p.saved_string = NULL;
 114   dtp->u.p.saved_used = 0;
 115 }
 116
 117
 118 /* Free the line buffer if necessary.  */
 119
 120 static void
 121 free_line (st_parameter_dt *dtp)
 122 {
 123   if (dtp->u.p.line_buffer == NULL)
 124     return;
 125
 126   free_mem (dtp->u.p.line_buffer);
 127   dtp->u.p.line_buffer = NULL;
 128 }
 129
 130
 131 static char
 132 next_char (st_parameter_dt *dtp)
 133 {
 134   int length;
 135   gfc_offset record;
 136   char c, *p;
 137
 138   if (dtp->u.p.last_char != '\0')
 139     {
 140       dtp->u.p.at_eol = 0;
 141       c = dtp->u.p.last_char;
 142       dtp->u.p.last_char = '\0';
 143       goto done;
 144     }
 145
 146   /* Read from line_buffer if enabled.  */
 147
 148   if (dtp->u.p.line_buffer_enabled)
 149     {
 150       dtp->u.p.at_eol = 0;
 151
 152       c = dtp->u.p.line_buffer[dtp->u.p.item_count];
 153       if (c != '\0' && dtp->u.p.item_count < 64)
 154         {
 155           dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
 156           dtp->u.p.item_count++;
 157           goto done;
 158         }
 159
 160         dtp->u.p.item_count = 0;
 161         dtp->u.p.line_buffer_enabled = 0;
 162     }
 163
 164   /* Handle the end-of-record and end-of-file conditions for
 165      internal array unit.  */
 166   if (is_array_io (dtp))
 167     {
 168       if (dtp->u.p.at_eof)
 169         longjmp (*dtp->u.p.eof_jump, 1);
 170
 171       /* Check for "end-of-record" condition.  */
 172       if (dtp->u.p.current_unit->bytes_left == 0)
 173         {
 174           c = '\n';
 175           record = next_array_record (dtp, dtp->u.p.current_unit->ls);
 176
 177           /* Check for "end-of-file" condition.  */
 178           if (record == 0)
 179             {
 180               dtp->u.p.at_eof = 1;
 181               goto done;
 182             }
 183
 184           record *= dtp->u.p.current_unit->recl;
 185           if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
 186             longjmp (*dtp->u.p.eof_jump, 1);
 187
 188           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
 189           goto done;
 190         }
 191     }
 192
 193   /* Get the next character and handle end-of-record conditions.  */
 194
 195   length = 1;
 196
 197   p = salloc_r (dtp->u.p.current_unit->s, &length);
 198
 199   if (is_stream_io (dtp))
 200     dtp->u.p.current_unit->strm_pos++;
 201
 202   if (is_internal_unit (dtp))
 203     {
 204       if (is_array_io (dtp))
 205         {
 206           /* End of record is handled in the next pass through, above.  The
 207              check for NULL here is cautionary.  */
 208           if (p == NULL)
 209             {
 210               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 211               return '\0';
 212             }
 213
 214           dtp->u.p.current_unit->bytes_left--;
 215           c = *p;
 216         }
 217       else
 218         {
 219           if (p == NULL)
 220             longjmp (*dtp->u.p.eof_jump, 1);
 221           if (length == 0)
 222             c = '\n';
 223           else
 224             c = *p;
 225         }
 226     }
 227   else
 228     {
 229       if (p == NULL)
 230         {
 231           generate_error (&dtp->common, LIBERROR_OS, NULL);
 232           return '\0';
 233         }
 234       if (length == 0)
 235         longjmp (*dtp->u.p.eof_jump, 1);
 236       c = *p;
 237     }
 238 done:
 239   dtp->u.p.at_eol = (c == '\n' || c == '\r');
 240   return c;
 241 }
 242
 243
 244 /* Push a character back onto the input.  */
 245
 246 static void
 247 unget_char (st_parameter_dt *dtp, char c)
 248 {
 249   dtp->u.p.last_char = c;
 250 }
 251
 252
 253 /* Skip over spaces in the input.  Returns the nonspace character that
 254    terminated the eating and also places it back on the input.  */
 255
 256 static char
 257 eat_spaces (st_parameter_dt *dtp)
 258 {
 259   char c;
 260
 261   do
 262     {
 263       c = next_char (dtp);
 264     }
 265   while (c == ' ' || c == '\t');
 266
 267   unget_char (dtp, c);
 268   return c;
 269 }
 270
 271
 272 /* Skip over a separator.  Technically, we don't always eat the whole
 273    separator.  This is because if we've processed the last input item,
 274    then a separator is unnecessary.  Plus the fact that operating
 275    systems usually deliver console input on a line basis.
 276
 277    The upshot is that if we see a newline as part of reading a
 278    separator, we stop reading.  If there are more input items, we
 279    continue reading the separator with finish_separator() which takes
 280    care of the fact that we may or may not have seen a comma as part
 281    of the separator.  */
 282
 283 static void
 284 eat_separator (st_parameter_dt *dtp)
 285 {
 286   char c, n;
 287
 288   eat_spaces (dtp);
 289   dtp->u.p.comma_flag = 0;
 290
 291   c = next_char (dtp);
 292   switch (c)
 293     {
 294     case ',':
 295       dtp->u.p.comma_flag = 1;
 296       eat_spaces (dtp);
 297       break;
 298
 299     case '/':
 300       dtp->u.p.input_complete = 1;
 301       break;
 302
 303     case '\r':
 304       n = next_char(dtp);
 305       if (n == '\n')
 306         dtp->u.p.at_eol = 1;
 307       else
 308         unget_char (dtp, n);
 309       break;
 310
 311     case '\n':
 312       dtp->u.p.at_eol = 1;
 313       break;
 314
 315     case '!':
 316       if (dtp->u.p.namelist_mode)
 317         {                       /* Eat a namelist comment.  */
 318           do
 319             c = next_char (dtp);
 320           while (c != '\n');
 321
 322           break;
 323         }
 324
 325       /* Fall Through...  */
 326
 327     default:
 328       unget_char (dtp, c);
 329       break;
 330     }
 331 }
 332
 333
 334 /* Finish processing a separator that was interrupted by a newline.
 335    If we're here, then another data item is present, so we finish what
 336    we started on the previous line.  */
 337
 338 static void
 339 finish_separator (st_parameter_dt *dtp)
 340 {
 341   char c;
 342
 343  restart:
 344   eat_spaces (dtp);
 345
 346   c = next_char (dtp);
 347   switch (c)
 348     {
 349     case ',':
 350       if (dtp->u.p.comma_flag)
 351         unget_char (dtp, c);
 352       else
 353         {
 354           c = eat_spaces (dtp);
 355           if (c == '\n' || c == '\r')
 356             goto restart;
 357         }
 358
 359       break;
 360
 361     case '/':
 362       dtp->u.p.input_complete = 1;
 363       if (!dtp->u.p.namelist_mode)
 364         return;
 365       break;
 366
 367     case '\n':
 368     case '\r':
 369       goto restart;
 370
 371     case '!':
 372       if (dtp->u.p.namelist_mode)
 373         {
 374           do
 375             c = next_char (dtp);
 376           while (c != '\n');
 377
 378           goto restart;
 379         }
 380
 381     default:
 382       unget_char (dtp, c);
 383       break;
 384     }
 385 }
 386
 387
 388 /* This function reads characters through to the end of the current line and
 389    just ignores them.  */
 390
 391 static void
 392 eat_line (st_parameter_dt *dtp)
 393 {
 394   char c;
 395   if (!is_internal_unit (dtp))
 396     do
 397       c = next_char (dtp);
 398     while (c != '\n');
 399 }
 400
 401
 402 /* This function is needed to catch bad conversions so that namelist can
 403    attempt to see if dtp->u.p.saved_string contains a new object name rather
 404    than a bad value.  */
 405
 406 static int
 407 nml_bad_return (st_parameter_dt *dtp, char c)
 408 {
 409   if (dtp->u.p.namelist_mode)
 410     {
 411       dtp->u.p.nml_read_error = 1;
 412       unget_char (dtp, c);
 413       return 1;
 414     }
 415   return 0;
 416 }
 417
 418 /* Convert an unsigned string to an integer.  The length value is -1
 419    if we are working on a repeat count.  Returns nonzero if we have a
 420    range problem.  As a side effect, frees the dtp->u.p.saved_string.  */
 421
 422 static int
 423 convert_integer (st_parameter_dt *dtp, int length, int negative)
 424 {
 425   char c, *buffer, message[100];
 426   int m;
 427   GFC_INTEGER_LARGEST v, max, max10;
 428
 429   buffer = dtp->u.p.saved_string;
 430   v = 0;
 431
 432   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
 433   max10 = max / 10;
 434
 435   for (;;)
 436     {
 437       c = *buffer++;
 438       if (c == '\0')
 439         break;
 440       c -= '0';
 441
 442       if (v > max10)
 443         goto overflow;
 444       v = 10 * v;
 445
 446       if (v > max - c)
 447         goto overflow;
 448       v += c;
 449     }
 450
 451   m = 0;
 452
 453   if (length != -1)
 454     {
 455       if (negative)
 456         v = -v;
 457       set_integer (dtp->u.p.value, v, length);
 458     }
 459   else
 460     {
 461       dtp->u.p.repeat_count = v;
 462
 463       if (dtp->u.p.repeat_count == 0)
 464         {
 465           sprintf (message, "Zero repeat count in item %d of list input",
 466                    dtp->u.p.item_count);
 467
 468           generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 469           m = 1;
 470         }
 471     }
 472
 473   free_saved (dtp);
 474   return m;
 475
 476  overflow:
 477   if (length == -1)
 478     sprintf (message, "Repeat count overflow in item %d of list input",
 479              dtp->u.p.item_count);
 480   else
 481     sprintf (message, "Integer overflow while reading item %d",
 482              dtp->u.p.item_count);
 483
 484   free_saved (dtp);
 485   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 486
 487   return 1;
 488 }
 489
 490
 491 /* Parse a repeat count for logical and complex values which cannot
 492    begin with a digit.  Returns nonzero if we are done, zero if we
 493    should continue on.  */
 494
 495 static int
 496 parse_repeat (st_parameter_dt *dtp)
 497 {
 498   char c, message[100];
 499   int repeat;
 500
 501   c = next_char (dtp);
 502   switch (c)
 503     {
 504     CASE_DIGITS:
 505       repeat = c - '0';
 506       break;
 507
 508     CASE_SEPARATORS:
 509       unget_char (dtp, c);
 510       eat_separator (dtp);
 511       return 1;
 512
 513     default:
 514       unget_char (dtp, c);
 515       return 0;
 516     }
 517
 518   for (;;)
 519     {
 520       c = next_char (dtp);
 521       switch (c)
 522         {
 523         CASE_DIGITS:
 524           repeat = 10 * repeat + c - '0';
 525
 526           if (repeat > MAX_REPEAT)
 527             {
 528               sprintf (message,
 529                        "Repeat count overflow in item %d of list input",
 530                        dtp->u.p.item_count);
 531
 532               generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 533               return 1;
 534             }
 535
 536           break;
 537
 538         case '*':
 539           if (repeat == 0)
 540             {
 541               sprintf (message,
 542                        "Zero repeat count in item %d of list input",
 543                        dtp->u.p.item_count);
 544
 545               generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 546               return 1;
 547             }
 548
 549           goto done;
 550
 551         default:
 552           goto bad_repeat;
 553         }
 554     }
 555
 556  done:
 557   dtp->u.p.repeat_count = repeat;
 558   return 0;
 559
 560  bad_repeat:
 561
 562   eat_line (dtp);
 563   free_saved (dtp);
 564   sprintf (message, "Bad repeat count in item %d of list input",
 565            dtp->u.p.item_count);
 566   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 567   return 1;
 568 }
 569
 570
 571 /* To read a logical we have to look ahead in the input stream to make sure
 572     there is not an equal sign indicating a variable name.  To do this we use
 573     line_buffer to point to a temporary buffer, pushing characters there for
 574     possible later reading. */
 575
 576 static void
 577 l_push_char (st_parameter_dt *dtp, char c)
 578 {
 579   if (dtp->u.p.line_buffer == NULL)
 580     {
 581       dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
 582       memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
 583     }
 584
 585   dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
 586 }
 587
 588
 589 /* Read a logical character on the input.  */
 590
 591 static void
 592 read_logical (st_parameter_dt *dtp, int length)
 593 {
 594   char c, message[100];
 595   int i, v;
 596
 597   if (parse_repeat (dtp))
 598     return;
 599
 600   c = tolower (next_char (dtp));
 601   l_push_char (dtp, c);
 602   switch (c)
 603     {
 604     case 't':
 605       v = 1;
 606       c = next_char (dtp);
 607       l_push_char (dtp, c);
 608
 609       if (!is_separator(c))
 610         goto possible_name;
 611
 612       unget_char (dtp, c);
 613       break;
 614     case 'f':
 615       v = 0;
 616       c = next_char (dtp);
 617       l_push_char (dtp, c);
 618
 619       if (!is_separator(c))
 620         goto possible_name;
 621
 622       unget_char (dtp, c);
 623       break;
 624     case '.':
 625       c = tolower (next_char (dtp));
 626       switch (c)
 627         {
 628           case 't':
 629             v = 1;
 630             break;
 631           case 'f':
 632             v = 0;
 633             break;
 634           default:
 635             goto bad_logical;
 636         }
 637
 638       break;
 639
 640     CASE_SEPARATORS:
 641       unget_char (dtp, c);
 642       eat_separator (dtp);
 643       return;                   /* Null value.  */
 644
 645     default:
 646       goto bad_logical;
 647     }
 648
 649   dtp->u.p.saved_type = BT_LOGICAL;
 650   dtp->u.p.saved_length = length;
 651
 652   /* Eat trailing garbage.  */
 653   do
 654     {
 655       c = next_char (dtp);
 656     }
 657   while (!is_separator (c));
 658
 659   unget_char (dtp, c);
 660   eat_separator (dtp);
 661   dtp->u.p.item_count = 0;
 662   dtp->u.p.line_buffer_enabled = 0;
 663   set_integer ((int *) dtp->u.p.value, v, length);
 664   free_line (dtp);
 665
 666   return;
 667
 668  possible_name:
 669
 670   for(i = 0; i < 63; i++)
 671     {
 672       c = next_char (dtp);
 673       if (is_separator(c))
 674         {
 675           /* All done if this is not a namelist read.  */
 676           if (!dtp->u.p.namelist_mode)
 677             goto logical_done;
 678
 679           unget_char (dtp, c);
 680           eat_separator (dtp);
 681           c = next_char (dtp);
 682           if (c != '=')
 683             {
 684               unget_char (dtp, c);
 685               goto logical_done;
 686             }
 687         }
 688
 689       l_push_char (dtp, c);
 690       if (c == '=')
 691         {
 692           dtp->u.p.nml_read_error = 1;
 693           dtp->u.p.line_buffer_enabled = 1;
 694           dtp->u.p.item_count = 0;
 695           return;
 696         }
 697
 698     }
 699
 700  bad_logical:
 701
 702   free_line (dtp);
 703
 704   if (nml_bad_return (dtp, c))
 705     return;
 706
 707   eat_line (dtp);
 708   free_saved (dtp);
 709   sprintf (message, "Bad logical value while reading item %d",
 710               dtp->u.p.item_count);
 711   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 712   return;
 713
 714  logical_done:
 715
 716   dtp->u.p.item_count = 0;
 717   dtp->u.p.line_buffer_enabled = 0;
 718   dtp->u.p.saved_type = BT_LOGICAL;
 719   dtp->u.p.saved_length = length;
 720   set_integer ((int *) dtp->u.p.value, v, length);
 721   free_saved (dtp);
 722   free_line (dtp);
 723 }
 724
 725
 726 /* Reading integers is tricky because we can actually be reading a
 727    repeat count.  We have to store the characters in a buffer because
 728    we could be reading an integer that is larger than the default int
 729    used for repeat counts.  */
 730
 731 static void
 732 read_integer (st_parameter_dt *dtp, int length)
 733 {
 734   char c, message[100];
 735   int negative;
 736
 737   negative = 0;
 738
 739   c = next_char (dtp);
 740   switch (c)
 741     {
 742     case '-':
 743       negative = 1;
 744       /* Fall through...  */
 745
 746     case '+':
 747       c = next_char (dtp);
 748       goto get_integer;
 749
 750     CASE_SEPARATORS:            /* Single null.  */
 751       unget_char (dtp, c);
 752       eat_separator (dtp);
 753       return;
 754
 755     CASE_DIGITS:
 756       push_char (dtp, c);
 757       break;
 758
 759     default:
 760       goto bad_integer;
 761     }
 762
 763   /* Take care of what may be a repeat count.  */
 764
 765   for (;;)
 766     {
 767       c = next_char (dtp);
 768       switch (c)
 769         {
 770         CASE_DIGITS:
 771           push_char (dtp, c);
 772           break;
 773
 774         case '*':
 775           push_char (dtp, '\0');
 776           goto repeat;
 777
 778         CASE_SEPARATORS:        /* Not a repeat count.  */
 779           goto done;
 780
 781         default:
 782           goto bad_integer;
 783         }
 784     }
 785
 786  repeat:
 787   if (convert_integer (dtp, -1, 0))
 788     return;
 789
 790   /* Get the real integer.  */
 791
 792   c = next_char (dtp);
 793   switch (c)
 794     {
 795     CASE_DIGITS:
 796       break;
 797
 798     CASE_SEPARATORS:
 799       unget_char (dtp, c);
 800       eat_separator (dtp);
 801       return;
 802
 803     case '-':
 804       negative = 1;
 805       /* Fall through...  */
 806
 807     case '+':
 808       c = next_char (dtp);
 809       break;
 810     }
 811
 812  get_integer:
 813   if (!isdigit (c))
 814     goto bad_integer;
 815   push_char (dtp, c);
 816
 817   for (;;)
 818     {
 819       c = next_char (dtp);
 820       switch (c)
 821         {
 822         CASE_DIGITS:
 823           push_char (dtp, c);
 824           break;
 825
 826         CASE_SEPARATORS:
 827           goto done;
 828
 829         default:
 830           goto bad_integer;
 831         }
 832     }
 833
 834  bad_integer:
 835
 836   if (nml_bad_return (dtp, c))
 837     return;
 838
 839   eat_line (dtp);
 840   free_saved (dtp);
 841   sprintf (message, "Bad integer for item %d in list input",
 842               dtp->u.p.item_count);
 843   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 844
 845   return;
 846
 847  done:
 848   unget_char (dtp, c);
 849   eat_separator (dtp);
 850
 851   push_char (dtp, '\0');
 852   if (convert_integer (dtp, length, negative))
 853     {
 854        free_saved (dtp);
 855        return;
 856     }
 857
 858   free_saved (dtp);
 859   dtp->u.p.saved_type = BT_INTEGER;
 860 }
 861
 862
 863 /* Read a character variable.  */
 864
 865 static void
 866 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
 867 {
 868   char c, quote, message[100];
 869
 870   quote = ' ';                  /* Space means no quote character.  */
 871
 872   c = next_char (dtp);
 873   switch (c)
 874     {
 875     CASE_DIGITS:
 876       push_char (dtp, c);
 877       break;
 878
 879     CASE_SEPARATORS:
 880       unget_char (dtp, c);              /* NULL value.  */
 881       eat_separator (dtp);
 882       return;
 883
 884     case '"':
 885     case '\'':
 886       quote = c;
 887       goto get_string;
 888
 889     default:
 890       if (dtp->u.p.namelist_mode
 891           && (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
 892               || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE))
 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       sprintf (message, "Invalid string input in item %d",
1008                   dtp->u.p.item_count);
1009       generate_error (&dtp->common, LIBERROR_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   sprintf (message, "Bad floating point number for item %d",
1127               dtp->u.p.item_count);
1128   generate_error (&dtp->common, LIBERROR_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   sprintf (message, "Bad complex value in item %d of list input",
1210               dtp->u.p.item_count);
1211   generate_error (&dtp->common, LIBERROR_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   sprintf (message, "Bad real number in item %d of list input",
1425               dtp->u.p.item_count);
1426   generate_error (&dtp->common, LIBERROR_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       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, LIBERROR_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       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, LIBERROR_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, LIBERROR_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                       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                   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                   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                   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                   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           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           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   memcpy (ext_name, nl->var_name, len-1);
1863   memcpy (ext_name + len - 1, "%", 2);
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             memcpy (obj_name, nl->var_name, obj_name_len-1);
2137             memcpy (obj_name + obj_name_len - 1, "%", 2);
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             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        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           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           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         sprintf (nml_err_msg, "Bad data for namelist object %s",
2388                     (*pprev_nl)->var_name);
2389
2390       else
2391         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           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           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           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           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       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       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, LIBERROR_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       eat_line (dtp);
2572       goto find_nml_name;
2573
2574     case '=':
2575       c = next_char (dtp);
2576       if (c == '?')
2577         nml_query (dtp, '=');
2578       else
2579         unget_char (dtp, c);
2580       goto find_nml_name;
2581
2582     case '?':
2583       nml_query (dtp, '?');
2584
2585     default:
2586       goto find_nml_name;
2587     }
2588
2589   /* Match the name of the namelist.  */
2590
2591   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2592
2593   if (dtp->u.p.nml_read_error)
2594     goto find_nml_name;
2595
2596   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */
2597   c = next_char (dtp);
2598   if (!is_separator(c))
2599     {
2600       unget_char (dtp, c);
2601       goto find_nml_name;
2602     }
2603
2604   /* Ready to read namelist objects.  If there is an error in input
2605      from stdin, output the error message and continue.  */
2606
2607   while (!dtp->u.p.input_complete)
2608     {
2609       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
2610         {
2611           gfc_unit *u;
2612
2613           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2614             goto nml_err_ret;
2615
2616           u = find_unit (options.stderr_unit);
2617           st_printf ("%s\n", nml_err_msg);
2618           if (u != NULL)
2619             {
2620               flush (u->s);
2621               unlock_unit (u);
2622             }
2623         }
2624
2625    }
2626
2627   dtp->u.p.eof_jump = NULL;
2628   free_saved (dtp);
2629   free_line (dtp);
2630   return;
2631
2632   /* All namelist error calls return from here */
2633
2634 nml_err_ret:
2635
2636   dtp->u.p.eof_jump = NULL;
2637   free_saved (dtp);
2638   free_line (dtp);
2639   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
2640   return;
2641 }