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