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           if (dtp->u.p.at_eol)
1357             finish_separator (dtp);
1358           else
1359             goto cleanup;
1360         }
1361
1362     }
1363   else
1364     {
1365       if (dtp->u.p.input_complete)
1366         goto cleanup;
1367
1368       if (dtp->u.p.repeat_count > 0)
1369         {
1370           if (check_type (dtp, type, kind))
1371             return;
1372           goto set_value;
1373         }
1374
1375       if (dtp->u.p.at_eol)
1376         finish_separator (dtp);
1377       else
1378         {
1379           eat_spaces (dtp);
1380           /* trailing spaces prior to end of line */
1381           if (dtp->u.p.at_eol)
1382             finish_separator (dtp);
1383         }
1384
1385       dtp->u.p.saved_type = BT_NULL;
1386       dtp->u.p.repeat_count = 1;
1387     }
1388
1389   switch (type)
1390     {
1391     case BT_INTEGER:
1392       read_integer (dtp, kind);
1393       break;
1394     case BT_LOGICAL:
1395       read_logical (dtp, kind);
1396       break;
1397     case BT_CHARACTER:
1398       read_character (dtp, kind);
1399       break;
1400     case BT_REAL:
1401       read_real (dtp, kind);
1402       break;
1403     case BT_COMPLEX:
1404       read_complex (dtp, kind, size);
1405       break;
1406     default:
1407       internal_error (&dtp->common, "Bad type for list read");
1408     }
1409
1410   if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1411     dtp->u.p.saved_length = size;
1412
1413   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1414     goto cleanup;
1415
1416  set_value:
1417   switch (dtp->u.p.saved_type)
1418     {
1419     case BT_COMPLEX:
1420     case BT_INTEGER:
1421     case BT_REAL:
1422     case BT_LOGICAL:
1423       memcpy (p, dtp->u.p.value, size);
1424       break;
1425
1426     case BT_CHARACTER:
1427       if (dtp->u.p.saved_string)
1428        {
1429           m = ((int) size < dtp->u.p.saved_used)
1430               ? (int) size : dtp->u.p.saved_used;
1431           memcpy (p, dtp->u.p.saved_string, m);
1432        }
1433       else
1434         /* Just delimiters encountered, nothing to copy but SPACE.  */
1435         m = 0;
1436
1437       if (m < (int) size)
1438         memset (((char *) p) + m, ' ', size - m);
1439       break;
1440
1441     case BT_NULL:
1442       break;
1443     }
1444
1445   if (--dtp->u.p.repeat_count <= 0)
1446     free_saved (dtp);
1447
1448 cleanup:
1449   dtp->u.p.eof_jump = NULL;
1450 }
1451
1452
1453 void
1454 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1455                      size_t size, size_t nelems)
1456 {
1457   size_t elem;
1458   char *tmp;
1459
1460   tmp = (char *) p;
1461
1462   /* Big loop over all the elements.  */
1463   for (elem = 0; elem < nelems; elem++)
1464     {
1465       dtp->u.p.item_count++;
1466       list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
1467     }
1468 }
1469
1470
1471 /* Finish a list read.  */
1472
1473 void
1474 finish_list_read (st_parameter_dt *dtp)
1475 {
1476   char c;
1477
1478   free_saved (dtp);
1479
1480   if (dtp->u.p.at_eol)
1481     {
1482       dtp->u.p.at_eol = 0;
1483       return;
1484     }
1485
1486   do
1487     {
1488       c = next_char (dtp);
1489     }
1490   while (c != '\n');
1491 }
1492
1493 /*                      NAMELIST INPUT
1494
1495 void namelist_read (st_parameter_dt *dtp)
1496 calls:
1497    static void nml_match_name (char *name, int len)
1498    static int nml_query (st_parameter_dt *dtp)
1499    static int nml_get_obj_data (st_parameter_dt *dtp,
1500                                 namelist_info **prev_nl, char *)
1501 calls:
1502       static void nml_untouch_nodes (st_parameter_dt *dtp)
1503       static namelist_info * find_nml_node (st_parameter_dt *dtp,
1504                                             char * var_name)
1505       static int nml_parse_qualifier(descriptor_dimension * ad,
1506                                      array_loop_spec * ls, int rank, char *)
1507       static void nml_touch_nodes (namelist_info * nl)
1508       static int nml_read_obj (namelist_info *nl, index_type offset,
1509                                namelist_info **prev_nl, char *,
1510                                index_type clow, index_type chigh)
1511 calls:
1512       -itself-  */
1513
1514 /* Inputs a rank-dimensional qualifier, which can contain
1515    singlets, doublets, triplets or ':' with the standard meanings.  */
1516
1517 static try
1518 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1519                      array_loop_spec *ls, int rank, char *parse_err_msg)
1520 {
1521   int dim;
1522   int indx;
1523   int neg;
1524   int null_flag;
1525   char c;
1526
1527   /* The next character in the stream should be the '('.  */
1528
1529   c = next_char (dtp);
1530
1531   /* Process the qualifier, by dimension and triplet.  */
1532
1533   for (dim=0; dim < rank; dim++ )
1534     {
1535       for (indx=0; indx<3; indx++)
1536         {
1537           free_saved (dtp);
1538           eat_spaces (dtp);
1539           neg = 0;
1540
1541           /* Process a potential sign.  */
1542           c = next_char (dtp);
1543           switch (c)
1544             {
1545             case '-':
1546               neg = 1;
1547               break;
1548
1549             case '+':
1550               break;
1551
1552             default:
1553               unget_char (dtp, c);
1554               break;
1555             }
1556
1557           /* Process characters up to the next ':' , ',' or ')'.  */
1558           for (;;)
1559             {
1560               c = next_char (dtp);
1561
1562               switch (c)
1563                 {
1564                 case ':':
1565                   break;
1566
1567                 case ',': case ')':
1568                   if ((c==',' && dim == rank -1)
1569                       || (c==')' && dim < rank -1))
1570                     {
1571                       st_sprintf (parse_err_msg,
1572                                   "Bad number of index fields");
1573                       goto err_ret;
1574                     }
1575                   break;
1576
1577                 CASE_DIGITS:
1578                   push_char (dtp, c);
1579                   continue;
1580
1581                 case ' ': case '\t':
1582                   eat_spaces (dtp);
1583                   c = next_char (dtp);
1584                   break;
1585
1586                 default:
1587                   st_sprintf (parse_err_msg, "Bad character in index");
1588                   goto err_ret;
1589                 }
1590
1591               if ((c == ',' || c == ')') && indx == 0
1592                   && dtp->u.p.saved_string == 0)
1593                 {
1594                   st_sprintf (parse_err_msg, "Null index field");
1595                   goto err_ret;
1596                 }
1597
1598               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
1599                   || (indx == 2 && dtp->u.p.saved_string == 0))
1600                 {
1601                   st_sprintf(parse_err_msg, "Bad index triplet");
1602                   goto err_ret;
1603                 }
1604
1605               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
1606               null_flag = 0;
1607               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
1608                   || (indx==1 && dtp->u.p.saved_string == 0))
1609                 {
1610                   null_flag = 1;
1611                   break;
1612                 }
1613
1614               /* Now read the index.  */
1615               if (convert_integer (dtp, sizeof(ssize_t), neg))
1616                 {
1617                   st_sprintf (parse_err_msg, "Bad integer in index");
1618                   goto err_ret;
1619                 }
1620               break;
1621             }
1622
1623           /* Feed the index values to the triplet arrays.  */
1624           if (!null_flag)
1625             {
1626               if (indx == 0)
1627                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
1628               if (indx == 1)
1629                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
1630               if (indx == 2)
1631                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
1632             }
1633
1634           /* Singlet or doublet indices.  */
1635           if (c==',' || c==')')
1636             {
1637               if (indx == 0)
1638                 {
1639                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
1640                   ls[dim].end = ls[dim].start;
1641                 }
1642               break;
1643             }
1644         }
1645
1646       /* Check the values of the triplet indices.  */
1647       if ((ls[dim].start > (ssize_t)ad[dim].ubound)
1648           || (ls[dim].start < (ssize_t)ad[dim].lbound)
1649           || (ls[dim].end > (ssize_t)ad[dim].ubound)
1650           || (ls[dim].end < (ssize_t)ad[dim].lbound))
1651         {
1652           st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
1653           goto err_ret;
1654         }
1655       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
1656           || (ls[dim].step == 0))
1657         {
1658           st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
1659           goto err_ret;
1660         }
1661
1662       /* Initialise the loop index counter.  */
1663       ls[dim].idx = ls[dim].start;
1664     }
1665   eat_spaces (dtp);
1666   return SUCCESS;
1667
1668 err_ret:
1669
1670   return FAILURE;
1671 }
1672
1673 static namelist_info *
1674 find_nml_node (st_parameter_dt *dtp, char * var_name)
1675 {
1676   namelist_info * t = dtp->u.p.ionml;
1677   while (t != NULL)
1678     {
1679       if (strcmp (var_name, t->var_name) == 0)
1680         {
1681           t->touched = 1;
1682           return t;
1683         }
1684       t = t->next;
1685     }
1686   return NULL;
1687 }
1688
1689 /* Visits all the components of a derived type that have
1690    not explicitly been identified in the namelist input.
1691    touched is set and the loop specification initialised
1692    to default values  */
1693
1694 static void
1695 nml_touch_nodes (namelist_info * nl)
1696 {
1697   index_type len = strlen (nl->var_name) + 1;
1698   int dim;
1699   char * ext_name = (char*)get_mem (len + 1);
1700   strcpy (ext_name, nl->var_name);
1701   strcat (ext_name, "%");
1702   for (nl = nl->next; nl; nl = nl->next)
1703     {
1704       if (strncmp (nl->var_name, ext_name, len) == 0)
1705         {
1706           nl->touched = 1;
1707           for (dim=0; dim < nl->var_rank; dim++)
1708             {
1709               nl->ls[dim].step = 1;
1710               nl->ls[dim].end = nl->dim[dim].ubound;
1711               nl->ls[dim].start = nl->dim[dim].lbound;
1712               nl->ls[dim].idx = nl->ls[dim].start;
1713             }
1714         }
1715       else
1716         break;
1717     }
1718   free_mem (ext_name);
1719   return;
1720 }
1721
1722 /* Resets touched for the entire list of nml_nodes, ready for a
1723    new object.  */
1724
1725 static void
1726 nml_untouch_nodes (st_parameter_dt *dtp)
1727 {
1728   namelist_info * t;
1729   for (t = dtp->u.p.ionml; t; t = t->next)
1730     t->touched = 0;
1731   return;
1732 }
1733
1734 /* Attempts to input name to namelist name.  Returns
1735    dtp->u.p.nml_read_error = 1 on no match.  */
1736
1737 static void
1738 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
1739 {
1740   index_type i;
1741   char c;
1742   dtp->u.p.nml_read_error = 0;
1743   for (i = 0; i < len; i++)
1744     {
1745       c = next_char (dtp);
1746       if (tolower (c) != tolower (name[i]))
1747         {
1748           dtp->u.p.nml_read_error = 1;
1749           break;
1750         }
1751     }
1752 }
1753
1754 /* If the namelist read is from stdin, output the current state of the
1755    namelist to stdout.  This is used to implement the non-standard query
1756    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1757    the names alone are printed.  */
1758
1759 static void
1760 nml_query (st_parameter_dt *dtp, char c)
1761 {
1762   gfc_unit * temp_unit;
1763   namelist_info * nl;
1764   index_type len;
1765   char * p;
1766
1767   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
1768     return;
1769
1770   /* Store the current unit and transfer to stdout.  */
1771
1772   temp_unit = dtp->u.p.current_unit;
1773   dtp->u.p.current_unit = find_unit (options.stdout_unit);
1774
1775   if (dtp->u.p.current_unit)
1776     {
1777       dtp->u.p.mode = WRITING;
1778       next_record (dtp, 0);
1779
1780       /* Write the namelist in its entirety.  */
1781
1782       if (c == '=')
1783         namelist_write (dtp);
1784
1785       /* Or write the list of names.  */
1786
1787       else
1788         {
1789
1790           /* "&namelist_name\n"  */
1791
1792           len = dtp->namelist_name_len;
1793 #ifdef HAVE_CRLF
1794           p = write_block (dtp, len + 3);
1795 #else
1796           p = write_block (dtp, len + 2);
1797 #endif
1798           if (!p)
1799             goto query_return;
1800           memcpy (p, "&", 1);
1801           memcpy ((char*)(p + 1), dtp->namelist_name, len);
1802 #ifdef HAVE_CRLF
1803           memcpy ((char*)(p + len + 1), "\r\n", 2);
1804 #else
1805           memcpy ((char*)(p + len + 1), "\n", 1);
1806 #endif
1807           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
1808             {
1809
1810               /* " var_name\n"  */
1811
1812               len = strlen (nl->var_name);
1813 #ifdef HAVE_CRLF
1814               p = write_block (dtp, len + 3);
1815 #else
1816               p = write_block (dtp, len + 2);
1817 #endif
1818               if (!p)
1819                 goto query_return;
1820               memcpy (p, " ", 1);
1821               memcpy ((char*)(p + 1), nl->var_name, len);
1822 #ifdef HAVE_CRLF
1823               memcpy ((char*)(p + len + 1), "\r\n", 2);
1824 #else
1825               memcpy ((char*)(p + len + 1), "\n", 1);
1826 #endif
1827             }
1828
1829           /* "&end\n"  */
1830
1831 #ifdef HAVE_CRLF
1832           p = write_block (dtp, 6);
1833 #else
1834           p = write_block (dtp, 5);
1835 #endif
1836           if (!p)
1837             goto query_return;
1838 #ifdef HAVE_CRLF
1839           memcpy (p, "&end\r\n", 6);
1840 #else
1841           memcpy (p, "&end\n", 5);
1842 #endif
1843         }
1844
1845       /* Flush the stream to force immediate output.  */
1846
1847       flush (dtp->u.p.current_unit->s);
1848       unlock_unit (dtp->u.p.current_unit);
1849     }
1850
1851 query_return:
1852
1853   /* Restore the current unit.  */
1854
1855   dtp->u.p.current_unit = temp_unit;
1856   dtp->u.p.mode = READING;
1857   return;
1858 }
1859
1860 /* Reads and stores the input for the namelist object nl.  For an array,
1861    the function loops over the ranges defined by the loop specification.
1862    This default to all the data or to the specification from a qualifier.
1863    nml_read_obj recursively calls itself to read derived types. It visits
1864    all its own components but only reads data for those that were touched
1865    when the name was parsed.  If a read error is encountered, an attempt is
1866    made to return to read a new object name because the standard allows too
1867    little data to be available.  On the other hand, too much data is an
1868    error.  */
1869
1870 static try
1871 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
1872               namelist_info **pprev_nl, char *nml_err_msg,
1873               index_type clow, index_type chigh)
1874 {
1875
1876   namelist_info * cmp;
1877   char * obj_name;
1878   int nml_carry;
1879   int len;
1880   int dim;
1881   index_type dlen;
1882   index_type m;
1883   index_type obj_name_len;
1884   void * pdata ;
1885
1886   /* This object not touched in name parsing.  */
1887
1888   if (!nl->touched)
1889     return SUCCESS;
1890
1891   dtp->u.p.repeat_count = 0;
1892   eat_spaces (dtp);
1893
1894   len = nl->len;
1895   switch (nl->type)
1896   {
1897
1898     case GFC_DTYPE_INTEGER:
1899     case GFC_DTYPE_LOGICAL:
1900       dlen = len;
1901       break;
1902
1903     case GFC_DTYPE_REAL:
1904       dlen = size_from_real_kind (len);
1905       break;
1906
1907     case GFC_DTYPE_COMPLEX:
1908       dlen = size_from_complex_kind (len);
1909       break;
1910
1911     case GFC_DTYPE_CHARACTER:
1912       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
1913       break;
1914
1915     default:
1916       dlen = 0;
1917     }
1918
1919   do
1920     {
1921
1922       /* Update the pointer to the data, using the current index vector  */
1923
1924       pdata = (void*)(nl->mem_pos + offset);
1925       for (dim = 0; dim < nl->var_rank; dim++)
1926         pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
1927                  nl->dim[dim].stride * nl->size);
1928
1929       /* Reset the error flag and try to read next value, if
1930          dtp->u.p.repeat_count=0  */
1931
1932       dtp->u.p.nml_read_error = 0;
1933       nml_carry = 0;
1934       if (--dtp->u.p.repeat_count <= 0)
1935         {
1936           if (dtp->u.p.input_complete)
1937             return SUCCESS;
1938           if (dtp->u.p.at_eol)
1939             finish_separator (dtp);
1940           if (dtp->u.p.input_complete)
1941             return SUCCESS;
1942
1943           /* GFC_TYPE_UNKNOWN through for nulls and is detected
1944              after the switch block.  */
1945
1946           dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
1947           free_saved (dtp);
1948
1949           switch (nl->type)
1950           {
1951           case GFC_DTYPE_INTEGER:
1952               read_integer (dtp, len);
1953               break;
1954
1955           case GFC_DTYPE_LOGICAL:
1956               read_logical (dtp, len);
1957               break;
1958
1959           case GFC_DTYPE_CHARACTER:
1960               read_character (dtp, len);
1961               break;
1962
1963           case GFC_DTYPE_REAL:
1964               read_real (dtp, len);
1965               break;
1966
1967           case GFC_DTYPE_COMPLEX:
1968               read_complex (dtp, len, dlen);
1969               break;
1970
1971           case GFC_DTYPE_DERIVED:
1972             obj_name_len = strlen (nl->var_name) + 1;
1973             obj_name = get_mem (obj_name_len+1);
1974             strcpy (obj_name, nl->var_name);
1975             strcat (obj_name, "%");
1976
1977             /* Now loop over the components. Update the component pointer
1978                with the return value from nml_write_obj.  This loop jumps
1979                past nested derived types by testing if the potential
1980                component name contains '%'.  */
1981
1982             for (cmp = nl->next;
1983                  cmp &&
1984                    !strncmp (cmp->var_name, obj_name, obj_name_len) &&
1985                    !strchr (cmp->var_name + obj_name_len, '%');
1986                  cmp = cmp->next)
1987               {
1988
1989                 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
1990                                   pprev_nl, nml_err_msg, clow, chigh)
1991                     == FAILURE)
1992                   {
1993                     free_mem (obj_name);
1994                     return FAILURE;
1995                   }
1996
1997                 if (dtp->u.p.input_complete)
1998                   {
1999                     free_mem (obj_name);
2000                     return SUCCESS;
2001                   }
2002               }
2003
2004             free_mem (obj_name);
2005             goto incr_idx;
2006
2007           default:
2008             st_sprintf (nml_err_msg, "Bad type for namelist object %s",
2009                         nl->var_name);
2010             internal_error (&dtp->common, nml_err_msg);
2011             goto nml_err_ret;
2012           }
2013         }
2014
2015       /* The standard permits array data to stop short of the number of
2016          elements specified in the loop specification.  In this case, we
2017          should be here with dtp->u.p.nml_read_error != 0.  Control returns to
2018          nml_get_obj_data and an attempt is made to read object name.  */
2019
2020       *pprev_nl = nl;
2021       if (dtp->u.p.nml_read_error)
2022         return SUCCESS;
2023
2024       if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
2025         goto incr_idx;
2026
2027
2028       /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2029          This comes about because the read functions return BT_types.  */
2030
2031       switch (dtp->u.p.saved_type)
2032       {
2033
2034         case BT_COMPLEX:
2035         case BT_REAL:
2036         case BT_INTEGER:
2037         case BT_LOGICAL:
2038           memcpy (pdata, dtp->u.p.value, dlen);
2039           break;
2040
2041         case BT_CHARACTER:
2042           m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2043           pdata = (void*)( pdata + clow - 1 );
2044           memcpy (pdata, dtp->u.p.saved_string, m);
2045           if (m < dlen)
2046             memset ((void*)( pdata + m ), ' ', dlen - m);
2047         break;
2048
2049         default:
2050           break;
2051       }
2052
2053       /* Break out of loop if scalar.  */
2054
2055       if (!nl->var_rank)
2056         break;
2057
2058       /* Now increment the index vector.  */
2059
2060 incr_idx:
2061
2062       nml_carry = 1;
2063       for (dim = 0; dim < nl->var_rank; dim++)
2064         {
2065           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2066           nml_carry = 0;
2067           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2068               ||
2069               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2070             {
2071               nl->ls[dim].idx = nl->ls[dim].start;
2072               nml_carry = 1;
2073             }
2074         }
2075     } while (!nml_carry);
2076
2077   if (dtp->u.p.repeat_count > 1)
2078     {
2079        st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
2080                    nl->var_name );
2081        goto nml_err_ret;
2082     }
2083   return SUCCESS;
2084
2085 nml_err_ret:
2086
2087   return FAILURE;
2088 }
2089
2090 /* Parses the object name, including array and substring qualifiers.  It
2091    iterates over derived type components, touching those components and
2092    setting their loop specifications, if there is a qualifier.  If the
2093    object is itself a derived type, its components and subcomponents are
2094    touched.  nml_read_obj is called at the end and this reads the data in
2095    the manner specified by the object name.  */
2096
2097 static try
2098 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2099                   char *nml_err_msg)
2100 {
2101   char c;
2102   namelist_info * nl;
2103   namelist_info * first_nl = NULL;
2104   namelist_info * root_nl = NULL;
2105   int dim;
2106   int component_flag;
2107   char parse_err_msg[30];
2108   index_type clow, chigh;
2109
2110   /* Look for end of input or object name.  If '?' or '=?' are encountered
2111      in stdin, print the node names or the namelist to stdout.  */
2112
2113   eat_separator (dtp);
2114   if (dtp->u.p.input_complete)
2115     return SUCCESS;
2116
2117   if (dtp->u.p.at_eol)
2118     finish_separator (dtp);
2119   if (dtp->u.p.input_complete)
2120     return SUCCESS;
2121
2122   c = next_char (dtp);
2123   switch (c)
2124     {
2125     case '=':
2126       c = next_char (dtp);
2127       if (c != '?')
2128         {
2129           st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
2130           goto nml_err_ret;
2131         }
2132       nml_query (dtp, '=');
2133       return SUCCESS;
2134
2135     case '?':
2136       nml_query (dtp, '?');
2137       return SUCCESS;
2138
2139     case '$':
2140     case '&':
2141       nml_match_name (dtp, "end", 3);
2142       if (dtp->u.p.nml_read_error)
2143         {
2144           st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
2145           goto nml_err_ret;
2146         }
2147     case '/':
2148       dtp->u.p.input_complete = 1;
2149       return SUCCESS;
2150
2151     default :
2152       break;
2153     }
2154
2155   /* Untouch all nodes of the namelist and reset the flag that is set for
2156      derived type components.  */
2157
2158   nml_untouch_nodes (dtp);
2159   component_flag = 0;
2160
2161   /* Get the object name - should '!' and '\n' be permitted separators?  */
2162
2163 get_name:
2164
2165   free_saved (dtp);
2166
2167   do
2168     {
2169       push_char (dtp, tolower(c));
2170       c = next_char (dtp);
2171     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2172
2173   unget_char (dtp, c);
2174
2175   /* Check that the name is in the namelist and get pointer to object.
2176      Three error conditions exist: (i) An attempt is being made to
2177      identify a non-existent object, following a failed data read or
2178      (ii) The object name does not exist or (iii) Too many data items
2179      are present for an object.  (iii) gives the same error message
2180      as (i)  */
2181
2182   push_char (dtp, '\0');
2183
2184   if (component_flag)
2185     {
2186       size_t var_len = strlen (root_nl->var_name);
2187       size_t saved_len
2188         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2189       char ext_name[var_len + saved_len + 1];
2190
2191       memcpy (ext_name, root_nl->var_name, var_len);
2192       if (dtp->u.p.saved_string)
2193         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2194       ext_name[var_len + saved_len] = '\0';
2195       nl = find_nml_node (dtp, ext_name);
2196     }
2197   else
2198     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2199
2200   if (nl == NULL)
2201     {
2202       if (dtp->u.p.nml_read_error && *pprev_nl)
2203         st_sprintf (nml_err_msg, "Bad data for namelist object %s",
2204                     (*pprev_nl)->var_name);
2205
2206       else
2207         st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
2208                     dtp->u.p.saved_string);
2209
2210       goto nml_err_ret;
2211     }
2212
2213   /* Get the length, data length, base pointer and rank of the variable.
2214      Set the default loop specification first.  */
2215
2216   for (dim=0; dim < nl->var_rank; dim++)
2217     {
2218       nl->ls[dim].step = 1;
2219       nl->ls[dim].end = nl->dim[dim].ubound;
2220       nl->ls[dim].start = nl->dim[dim].lbound;
2221       nl->ls[dim].idx = nl->ls[dim].start;
2222     }
2223
2224 /* Check to see if there is a qualifier: if so, parse it.*/
2225
2226   if (c == '(' && nl->var_rank)
2227     {
2228       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2229                                parse_err_msg) == FAILURE)
2230         {
2231           st_sprintf (nml_err_msg, "%s for namelist variable %s",
2232                       parse_err_msg, nl->var_name);
2233           goto nml_err_ret;
2234         }
2235       c = next_char (dtp);
2236       unget_char (dtp, c);
2237     }
2238
2239   /* Now parse a derived type component. The root namelist_info address
2240      is backed up, as is the previous component level.  The  component flag
2241      is set and the iteration is made by jumping back to get_name.  */
2242
2243   if (c == '%')
2244     {
2245
2246       if (nl->type != GFC_DTYPE_DERIVED)
2247         {
2248           st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
2249                       nl->var_name);
2250           goto nml_err_ret;
2251         }
2252
2253       if (!component_flag)
2254         first_nl = nl;
2255
2256       root_nl = nl;
2257       component_flag = 1;
2258       c = next_char (dtp);
2259       goto get_name;
2260
2261     }
2262
2263   /* Parse a character qualifier, if present.  chigh = 0 is a default
2264      that signals that the string length = string_length.  */
2265
2266   clow = 1;
2267   chigh = 0;
2268
2269   if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2270     {
2271       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2272       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2273
2274       if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
2275         {
2276           st_sprintf (nml_err_msg, "%s for namelist variable %s",
2277                       parse_err_msg, nl->var_name);
2278           goto nml_err_ret;
2279         }
2280
2281       clow = ind[0].start;
2282       chigh = ind[0].end;
2283
2284       if (ind[0].step != 1)
2285         {
2286           st_sprintf (nml_err_msg,
2287                       "Bad step in substring for namelist object %s",
2288                       nl->var_name);
2289           goto nml_err_ret;
2290         }
2291
2292       c = next_char (dtp);
2293       unget_char (dtp, c);
2294     }
2295
2296   /* If a derived type touch its components and restore the root
2297      namelist_info if we have parsed a qualified derived type
2298      component.  */
2299
2300   if (nl->type == GFC_DTYPE_DERIVED)
2301     nml_touch_nodes (nl);
2302   if (component_flag)
2303     nl = first_nl;
2304
2305   /*make sure no extraneous qualifiers are there.*/
2306
2307   if (c == '(')
2308     {
2309       st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
2310                   " namelist object %s", nl->var_name);
2311       goto nml_err_ret;
2312     }
2313
2314 /* According to the standard, an equal sign MUST follow an object name. The
2315    following is possibly lax - it allows comments, blank lines and so on to
2316    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2317
2318   free_saved (dtp);
2319
2320   eat_separator (dtp);
2321   if (dtp->u.p.input_complete)
2322     return SUCCESS;
2323
2324   if (dtp->u.p.at_eol)
2325     finish_separator (dtp);
2326   if (dtp->u.p.input_complete)
2327     return SUCCESS;
2328
2329   c = next_char (dtp);
2330
2331   if (c != '=')
2332     {
2333       st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
2334                   nl->var_name);
2335       goto nml_err_ret;
2336     }
2337
2338   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
2339     goto nml_err_ret;
2340
2341   return SUCCESS;
2342
2343 nml_err_ret:
2344
2345   return FAILURE;
2346 }
2347
2348 /* Entry point for namelist input.  Goes through input until namelist name
2349   is matched.  Then cycles through nml_get_obj_data until the input is
2350   completed or there is an error.  */
2351
2352 void
2353 namelist_read (st_parameter_dt *dtp)
2354 {
2355   char c;
2356   jmp_buf eof_jump;
2357   char nml_err_msg[100];
2358   /* Pointer to the previously read object, in case attempt is made to read
2359      new object name.  Should this fail, error message can give previous
2360      name.  */
2361   namelist_info *prev_nl = NULL;
2362
2363   dtp->u.p.namelist_mode = 1;
2364   dtp->u.p.input_complete = 0;
2365
2366   dtp->u.p.eof_jump = &eof_jump;
2367   if (setjmp (eof_jump))
2368     {
2369       dtp->u.p.eof_jump = NULL;
2370       generate_error (&dtp->common, ERROR_END, NULL);
2371       return;
2372     }
2373
2374   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
2375      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2376      node names or namelist on stdout.  */
2377
2378 find_nml_name:
2379   switch (c = next_char (dtp))
2380     {
2381     case '$':
2382     case '&':
2383           break;
2384
2385     case '=':
2386       c = next_char (dtp);
2387       if (c == '?')
2388         nml_query (dtp, '=');
2389       else
2390         unget_char (dtp, c);
2391       goto find_nml_name;
2392
2393     case '?':
2394       nml_query (dtp, '?');
2395
2396     default:
2397       goto find_nml_name;
2398     }
2399
2400   /* Match the name of the namelist.  */
2401
2402   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2403
2404   if (dtp->u.p.nml_read_error)
2405     goto find_nml_name;
2406
2407   /* Ready to read namelist objects.  If there is an error in input
2408      from stdin, output the error message and continue.  */
2409
2410   while (!dtp->u.p.input_complete)
2411     {
2412       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
2413         {
2414           gfc_unit *u;
2415
2416           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2417             goto nml_err_ret;
2418
2419           u = find_unit (options.stderr_unit);
2420           st_printf ("%s\n", nml_err_msg);
2421           if (u != NULL)
2422             {
2423               flush (u->s);
2424               unlock_unit (u);
2425             }
2426         }
2427
2428    }
2429
2430   dtp->u.p.eof_jump = NULL;
2431   free_saved (dtp);
2432   return;
2433
2434   /* All namelist error calls return from here */
2435
2436 nml_err_ret:
2437
2438   dtp->u.p.eof_jump = NULL;
2439   free_saved (dtp);
2440   generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
2441   return;
2442 }