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