libgfortran/io/list_read.c

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