libgfortran/io/list_read.c

   1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with Libgfortran; see the file COPYING.  If not, write to
  27 the Free Software Foundation, 59 Temple Place - Suite 330,
  28 Boston, MA 02111-1307, USA.  */
  29
  30
  31 #include "config.h"
  32 #include <string.h>
  33 #include <ctype.h>
  34 #include "libgfortran.h"
  35 #include "io.h"
  36
  37
  38 /* List directed input.  Several parsing subroutines are practically
  39    reimplemented from formatted input, the reason being that there are
  40    all kinds of small differences between formatted and list directed
  41    parsing.  */
  42
  43
  44 /* Subroutines for reading characters from the input.  Because a
  45    repeat count is ambiguous with an integer, we have to read the
  46    whole digit string before seeing if there is a '*' which signals
  47    the repeat count.  Since we can have a lot of potential leading
  48    zeros, we have to be able to back up by arbitrary amount.  Because
  49    the input might not be seekable, we have to buffer the data
  50    ourselves.  Data is buffered in scratch[] until it becomes too
  51    large, after which we start allocating memory on the heap.  */
  52
  53 static int repeat_count, saved_length, saved_used, input_complete, at_eol;
  54 static int comma_flag, namelist_mode;
  55
  56 static char last_char, *saved_string;
  57 static bt saved_type;
  58
  59
  60
  61 /* Storage area for values except for strings.  Must be large enough
  62    to hold a complex value (two reals) of the largest kind.  */
  63
  64 static char value[20];
  65
  66 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
  67                       case '5': case '6': case '7': case '8': case '9'
  68
  69 #define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t'
  70
  71 /* This macro assumes that we're operating on a variable.  */
  72
  73 #define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
  74                          || c == '\t')
  75
  76 /* Maximum repeat count.  Less than ten times the maximum signed int32.  */
  77
  78 #define MAX_REPEAT 200000000
  79
  80
  81 /* Save a character to a string buffer, enlarging it as necessary.  */
  82
  83 static void
  84 push_char (char c)
  85 {
  86   char *new;
  87
  88   if (saved_string == NULL)
  89     {
  90       saved_string = scratch;
  91       memset (saved_string,0,SCRATCH_SIZE);
  92       saved_length = SCRATCH_SIZE;
  93       saved_used = 0;
  94     }
  95
  96   if (saved_used >= saved_length)
  97     {
  98       saved_length = 2 * saved_length;
  99       new = get_mem (2 * saved_length);
 100
 101       memset (new,0,2 * saved_length);
 102
 103       memcpy (new, saved_string, saved_used);
 104       if (saved_string != scratch)
 105         free_mem (saved_string);
 106
 107       saved_string = new;
 108     }
 109
 110   saved_string[saved_used++] = c;
 111 }
 112
 113
 114 /* Free the input buffer if necessary.  */
 115
 116 static void
 117 free_saved (void)
 118 {
 119   if (saved_string == NULL)
 120     return;
 121
 122   if (saved_string != scratch)
 123     free_mem (saved_string);
 124
 125   saved_string = NULL;
 126 }
 127
 128
 129 static char
 130 next_char (void)
 131 {
 132   int length;
 133   char c, *p;
 134
 135   if (last_char != '\0')
 136     {
 137       at_eol = 0;
 138       c = last_char;
 139       last_char = '\0';
 140       goto done;
 141     }
 142
 143   length = 1;
 144
 145   p = salloc_r (current_unit->s, &length);
 146   if (p == NULL)
 147     {
 148       generate_error (ERROR_OS, NULL);
 149       return '\0';
 150     }
 151
 152   if (length == 0)
 153     {
 154       /* For internal files return a newline instead of signalling EOF.  */
 155       /* ??? This isn't quite right, but we don't handle internal files
 156          with multiple records.  */
 157       if (is_internal_unit ())
 158         c = '\n';
 159       else
 160         longjmp (g.eof_jump, 1);
 161     }
 162   else
 163     c = *p;
 164
 165 done:
 166   at_eol = (c == '\n');
 167   return c;
 168 }
 169
 170
 171 /* Push a character back onto the input.  */
 172
 173 static void
 174 unget_char (char c)
 175 {
 176   last_char = c;
 177 }
 178
 179
 180 /* Skip over spaces in the input.  Returns the nonspace character that
 181    terminated the eating and also places it back on the input.  */
 182
 183 static char
 184 eat_spaces (void)
 185 {
 186   char c;
 187
 188   do
 189     {
 190       c = next_char ();
 191     }
 192   while (c == ' ' || c == '\t');
 193
 194   unget_char (c);
 195   return c;
 196 }
 197
 198
 199 /* Skip over a separator.  Technically, we don't always eat the whole
 200    separator.  This is because if we've processed the last input item,
 201    then a separator is unnecessary.  Plus the fact that operating
 202    systems usually deliver console input on a line basis.
 203
 204    The upshot is that if we see a newline as part of reading a
 205    separator, we stop reading.  If there are more input items, we
 206    continue reading the separator with finish_separator() which takes
 207    care of the fact that we may or may not have seen a comma as part
 208    of the separator.  */
 209
 210 static void
 211 eat_separator (void)
 212 {
 213   char c;
 214
 215   eat_spaces ();
 216   comma_flag = 0;
 217
 218   c = next_char ();
 219   switch (c)
 220     {
 221     case ',':
 222       comma_flag = 1;
 223       eat_spaces ();
 224       break;
 225
 226     case '/':
 227       input_complete = 1;
 228       next_record (0);
 229       at_eol = 1;
 230       break;
 231
 232     case '\n':
 233       break;
 234
 235     case '!':
 236       if (namelist_mode)
 237         {                       /* Eat a namelist comment.  */
 238           do
 239             c = next_char ();
 240           while (c != '\n');
 241
 242           break;
 243         }
 244
 245       /* Fall Through...  */
 246
 247     default:
 248       unget_char (c);
 249       break;
 250     }
 251 }
 252
 253
 254 /* Finish processing a separator that was interrupted by a newline.
 255    If we're here, then another data item is present, so we finish what
 256    we started on the previous line.  */
 257
 258 static void
 259 finish_separator (void)
 260 {
 261   char c;
 262
 263  restart:
 264   eat_spaces ();
 265
 266   c = next_char ();
 267   switch (c)
 268     {
 269     case ',':
 270       if (comma_flag)
 271         unget_char (c);
 272       else
 273         {
 274           c = eat_spaces ();
 275           if (c == '\n')
 276             goto restart;
 277         }
 278
 279       break;
 280
 281     case '/':
 282       input_complete = 1;
 283       next_record (0);
 284       break;
 285
 286     case '\n':
 287       goto restart;
 288
 289     case '!':
 290       if (namelist_mode)
 291         {
 292           do
 293             c = next_char ();
 294           while (c != '\n');
 295
 296           goto restart;
 297         }
 298
 299     default:
 300       unget_char (c);
 301       break;
 302     }
 303 }
 304
 305
 306 /* Convert an unsigned string to an integer.  The length value is -1
 307    if we are working on a repeat count.  Returns nonzero if we have a
 308    range problem.  As a side effect, frees the saved_string.  */
 309
 310 static int
 311 convert_integer (int length, int negative)
 312 {
 313   char c, *buffer, message[100];
 314   int m;
 315   int64_t v, max, max10;
 316
 317   buffer = saved_string;
 318   v = 0;
 319
 320   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
 321   max10 = max / 10;
 322
 323   for (;;)
 324     {
 325       c = *buffer++;
 326       if (c == '\0')
 327         break;
 328       c -= '0';
 329
 330       if (v > max10)
 331         goto overflow;
 332       v = 10 * v;
 333
 334       if (v > max - c)
 335         goto overflow;
 336       v += c;
 337     }
 338
 339   m = 0;
 340
 341   if (length != -1)
 342     {
 343       if (negative)
 344         v = -v;
 345       set_integer (value, v, length);
 346     }
 347   else
 348     {
 349       repeat_count = v;
 350
 351       if (repeat_count == 0)
 352         {
 353           st_sprintf (message, "Zero repeat count in item %d of list input",
 354                       g.item_count);
 355
 356           generate_error (ERROR_READ_VALUE, message);
 357           m = 1;
 358         }
 359     }
 360
 361   free_saved ();
 362   return m;
 363
 364  overflow:
 365   if (length == -1)
 366     st_sprintf (message, "Repeat count overflow in item %d of list input",
 367                 g.item_count);
 368   else
 369     st_sprintf (message, "Integer overflow while reading item %d",
 370                 g.item_count);
 371
 372   free_saved ();
 373   generate_error (ERROR_READ_VALUE, message);
 374
 375   return 1;
 376 }
 377
 378
 379 /* Parse a repeat count for logical and complex values which cannot
 380    begin with a digit.  Returns nonzero if we are done, zero if we
 381    should continue on.  */
 382
 383 static int
 384 parse_repeat (void)
 385 {
 386   char c, message[100];
 387   int repeat;
 388
 389   c = next_char ();
 390   switch (c)
 391     {
 392     CASE_DIGITS:
 393       repeat = c - '0';
 394       break;
 395
 396     CASE_SEPARATORS:
 397       unget_char (c);
 398       eat_separator ();
 399       return 1;
 400
 401     default:
 402       unget_char (c);
 403       return 0;
 404     }
 405
 406   for (;;)
 407     {
 408       c = next_char ();
 409       switch (c)
 410         {
 411         CASE_DIGITS:
 412           repeat = 10 * repeat + c - '0';
 413
 414           if (repeat > MAX_REPEAT)
 415             {
 416               st_sprintf (message,
 417                           "Repeat count overflow in item %d of list input",
 418                           g.item_count);
 419
 420               generate_error (ERROR_READ_VALUE, message);
 421               return 1;
 422             }
 423
 424           break;
 425
 426         case '*':
 427           if (repeat == 0)
 428             {
 429               st_sprintf (message,
 430                           "Zero repeat count in item %d of list input",
 431                           g.item_count);
 432
 433               generate_error (ERROR_READ_VALUE, message);
 434               return 1;
 435             }
 436
 437           goto done;
 438
 439         default:
 440           goto bad_repeat;
 441         }
 442     }
 443
 444  done:
 445   repeat_count = repeat;
 446   return 0;
 447
 448  bad_repeat:
 449   st_sprintf (message, "Bad repeat count in item %d of list input",
 450               g.item_count);
 451
 452   generate_error (ERROR_READ_VALUE, message);
 453   return 1;
 454 }
 455
 456
 457 /* Read a logical character on the input.  */
 458
 459 static void
 460 read_logical (int length)
 461 {
 462   char c, message[100];
 463   int v;
 464
 465   if (parse_repeat ())
 466     return;
 467
 468   c = next_char ();
 469   switch (c)
 470     {
 471     case 't':
 472     case 'T':
 473       v = 1;
 474       break;
 475     case 'f':
 476     case 'F':
 477       v = 0;
 478       break;
 479
 480     case '.':
 481       c = next_char ();
 482       switch (c)
 483         {
 484         case 't':
 485         case 'T':
 486           v = 1;
 487           break;
 488         case 'f':
 489         case 'F':
 490           v = 0;
 491           break;
 492         default:
 493           goto bad_logical;
 494         }
 495
 496       break;
 497
 498     CASE_SEPARATORS:
 499       unget_char (c);
 500       eat_separator ();
 501       return;                   /* Null value.  */
 502
 503     default:
 504       goto bad_logical;
 505     }
 506
 507   saved_type = BT_LOGICAL;
 508   saved_length = length;
 509
 510   /* Eat trailing garbage.  */
 511   do
 512     {
 513       c = next_char ();
 514     }
 515   while (!is_separator (c));
 516
 517   unget_char (c);
 518   eat_separator ();
 519   free_saved ();
 520   set_integer ((int *) value, v, length);
 521
 522   return;
 523
 524  bad_logical:
 525   st_sprintf (message, "Bad logical value while reading item %d",
 526               g.item_count);
 527
 528   generate_error (ERROR_READ_VALUE, message);
 529 }
 530
 531
 532 /* Reading integers is tricky because we can actually be reading a
 533    repeat count.  We have to store the characters in a buffer because
 534    we could be reading an integer that is larger than the default int
 535    used for repeat counts.  */
 536
 537 static void
 538 read_integer (int length)
 539 {
 540   char c, message[100];
 541   int negative;
 542
 543   negative = 0;
 544
 545   c = next_char ();
 546   switch (c)
 547     {
 548     case '-':
 549       negative = 1;
 550       /* Fall through...  */
 551
 552     case '+':
 553       c = next_char ();
 554       goto get_integer;
 555
 556     CASE_SEPARATORS:            /* Single null.  */
 557       unget_char (c);
 558       eat_separator ();
 559       return;
 560
 561     CASE_DIGITS:
 562       push_char (c);
 563       break;
 564
 565     default:
 566       goto bad_integer;
 567     }
 568
 569   /* Take care of what may be a repeat count.  */
 570
 571   for (;;)
 572     {
 573       c = next_char ();
 574       switch (c)
 575         {
 576         CASE_DIGITS:
 577           push_char (c);
 578           break;
 579
 580         case '*':
 581           push_char ('\0');
 582           goto repeat;
 583
 584         CASE_SEPARATORS:        /* Not a repeat count.  */
 585           goto done;
 586
 587         default:
 588           goto bad_integer;
 589         }
 590     }
 591
 592  repeat:
 593   if (convert_integer (-1, 0))
 594     return;
 595
 596   /* Get the real integer.  */
 597
 598   c = next_char ();
 599   switch (c)
 600     {
 601     CASE_DIGITS:
 602       break;
 603
 604     CASE_SEPARATORS:
 605       unget_char (c);
 606       eat_separator ();
 607       return;
 608
 609     case '-':
 610       negative = 1;
 611       /* Fall through...  */
 612
 613     case '+':
 614       c = next_char ();
 615       break;
 616     }
 617
 618  get_integer:
 619   if (!isdigit (c))
 620     goto bad_integer;
 621   push_char (c);
 622
 623   for (;;)
 624     {
 625       c = next_char ();
 626       switch (c)
 627         {
 628         CASE_DIGITS:
 629           push_char (c);
 630           break;
 631
 632         CASE_SEPARATORS:
 633           goto done;
 634
 635         default:
 636           goto bad_integer;
 637         }
 638     }
 639
 640  bad_integer:
 641   free_saved ();
 642
 643   st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
 644   generate_error (ERROR_READ_VALUE, message);
 645
 646   return;
 647
 648  done:
 649   unget_char (c);
 650   eat_separator ();
 651
 652   push_char ('\0');
 653   if (convert_integer (length, negative))
 654     {
 655        free_saved ();
 656        return;
 657     }
 658
 659   free_saved ();
 660   saved_type = BT_INTEGER;
 661 }
 662
 663
 664 /* Read a character variable.  */
 665
 666 static void
 667 read_character (int length)
 668 {
 669   char c, quote, message[100];
 670
 671   quote = ' ';                  /* Space means no quote character.  */
 672
 673   c = next_char ();
 674   switch (c)
 675     {
 676     CASE_DIGITS:
 677       push_char (c);
 678       break;
 679
 680     CASE_SEPARATORS:
 681       unget_char (c);           /* NULL value.  */
 682       eat_separator ();
 683       return;
 684
 685     case '"':
 686     case '\'':
 687       quote = c;
 688       goto get_string;
 689
 690     default:
 691       push_char (c);
 692       goto get_string;
 693     }
 694
 695   /* Deal with a possible repeat count.  */
 696
 697   for (;;)
 698     {
 699       c = next_char ();
 700       switch (c)
 701         {
 702         CASE_DIGITS:
 703           push_char (c);
 704           break;
 705
 706         CASE_SEPARATORS:
 707           unget_char (c);
 708           goto done;            /* String was only digits!  */
 709
 710         case '*':
 711           push_char ('\0');
 712           goto got_repeat;
 713
 714         default:
 715           push_char (c);
 716           goto get_string;      /* Not a repeat count after all.  */
 717         }
 718     }
 719
 720  got_repeat:
 721   if (convert_integer (-1, 0))
 722     return;
 723
 724   /* Now get the real string.  */
 725
 726   c = next_char ();
 727   switch (c)
 728     {
 729     CASE_SEPARATORS:
 730       unget_char (c);           /* Repeated NULL values.  */
 731       eat_separator ();
 732       return;
 733
 734     case '"':
 735     case '\'':
 736       quote = c;
 737       break;
 738
 739     default:
 740       push_char (c);
 741       break;
 742     }
 743
 744  get_string:
 745   for (;;)
 746     {
 747       c = next_char ();
 748       switch (c)
 749         {
 750         case '"':
 751         case '\'':
 752           if (c != quote)
 753             {
 754               push_char (c);
 755               break;
 756             }
 757
 758           /* See if we have a doubled quote character or the end of
 759              the string.  */
 760
 761           c = next_char ();
 762           if (c == quote)
 763             {
 764               push_char (quote);
 765               break;
 766             }
 767
 768           unget_char (c);
 769           goto done;
 770
 771         CASE_SEPARATORS:
 772           if (quote == ' ')
 773             {
 774               unget_char (c);
 775               goto done;
 776             }
 777
 778           if (c != '\n')
 779             push_char (c);
 780           break;
 781
 782         default:
 783           push_char (c);
 784           break;
 785         }
 786     }
 787
 788   /* At this point, we have to have a separator, or else the string is
 789      invalid.  */
 790  done:
 791   c = next_char ();
 792   if (is_separator (c))
 793     {
 794       unget_char (c);
 795       eat_separator ();
 796       saved_type = BT_CHARACTER;
 797     }
 798   else
 799     {
 800       free_saved ();
 801       st_sprintf (message, "Invalid string input in item %d", g.item_count);
 802       generate_error (ERROR_READ_VALUE, message);
 803     }
 804 }
 805
 806
 807 /* Parse a component of a complex constant or a real number that we
 808    are sure is already there.  This is a straight real number parser.  */
 809
 810 static int
 811 parse_real (void *buffer, int length)
 812 {
 813   char c, message[100];
 814   int m, seen_dp;
 815
 816   c = next_char ();
 817   if (c == '-' || c == '+')
 818     {
 819       push_char (c);
 820       c = next_char ();
 821     }
 822
 823   if (!isdigit (c) && c != '.')
 824     goto bad;
 825
 826   push_char (c);
 827
 828   seen_dp = (c == '.') ? 1 : 0;
 829
 830   for (;;)
 831     {
 832       c = next_char ();
 833       switch (c)
 834         {
 835         CASE_DIGITS:
 836           push_char (c);
 837           break;
 838
 839         case '.':
 840           if (seen_dp)
 841             goto bad;
 842
 843           seen_dp = 1;
 844           push_char (c);
 845           break;
 846
 847         case 'e':
 848         case 'E':
 849         case 'd':
 850         case 'D':
 851           push_char ('e');
 852           goto exp1;
 853
 854         case '-':
 855         case '+':
 856           push_char ('e');
 857           push_char (c);
 858           c = next_char ();
 859           goto exp2;
 860
 861         CASE_SEPARATORS:
 862           unget_char (c);
 863           goto done;
 864
 865         default:
 866           goto done;
 867         }
 868     }
 869
 870  exp1:
 871   c = next_char ();
 872   if (c != '-' && c != '+')
 873     push_char ('+');
 874   else
 875     {
 876       push_char (c);
 877       c = next_char ();
 878     }
 879
 880  exp2:
 881   if (!isdigit (c))
 882     goto bad;
 883   push_char (c);
 884
 885   for (;;)
 886     {
 887       c = next_char ();
 888       switch (c)
 889         {
 890         CASE_DIGITS:
 891           push_char (c);
 892           break;
 893
 894         CASE_SEPARATORS:
 895           unget_char (c);
 896           goto done;
 897
 898         default:
 899           goto done;
 900         }
 901     }
 902
 903  done:
 904   unget_char (c);
 905   push_char ('\0');
 906
 907   m = convert_real (buffer, saved_string, length);
 908   free_saved ();
 909
 910   return m;
 911
 912  bad:
 913   free_saved ();
 914   st_sprintf (message, "Bad floating point number for item %d", g.item_count);
 915   generate_error (ERROR_READ_VALUE, message);
 916
 917   return 1;
 918 }
 919
 920
 921 /* Reading a complex number is straightforward because we can tell
 922    what it is right away.  */
 923
 924 static void
 925 read_complex (int length)
 926 {
 927   char message[100];
 928   char c;
 929
 930   if (parse_repeat ())
 931     return;
 932
 933   c = next_char ();
 934   switch (c)
 935     {
 936     case '(':
 937       break;
 938
 939     CASE_SEPARATORS:
 940       unget_char (c);
 941       eat_separator ();
 942       return;
 943
 944     default:
 945       goto bad_complex;
 946     }
 947
 948   eat_spaces ();
 949   if (parse_real (value, length))
 950     return;
 951
 952   eat_spaces ();
 953   if (next_char () != ',')
 954     goto bad_complex;
 955
 956   eat_spaces ();
 957   if (parse_real (value + length, length))
 958     return;
 959
 960   eat_spaces ();
 961   if (next_char () != ')')
 962     goto bad_complex;
 963
 964   c = next_char ();
 965   if (!is_separator (c))
 966     goto bad_complex;
 967
 968   unget_char (c);
 969   eat_separator ();
 970
 971   free_saved ();
 972   saved_type = BT_COMPLEX;
 973   return;
 974
 975  bad_complex:
 976   st_sprintf (message, "Bad complex value in item %d of list input",
 977               g.item_count);
 978
 979   generate_error (ERROR_READ_VALUE, message);
 980 }
 981
 982
 983 /* Parse a real number with a possible repeat count.  */
 984
 985 static void
 986 read_real (int length)
 987 {
 988   char c, message[100];
 989   int seen_dp;
 990
 991   seen_dp = 0;
 992
 993   c = next_char ();
 994   switch (c)
 995     {
 996     CASE_DIGITS:
 997       push_char (c);
 998       break;
 999
1000     case '.':
1001       push_char (c);
1002       seen_dp = 1;
1003       break;
1004
1005     case '+':
1006     case '-':
1007       goto got_sign;
1008
1009     CASE_SEPARATORS:
1010       unget_char (c);           /* Single null.  */
1011       eat_separator ();
1012       return;
1013
1014     default:
1015       goto bad_real;
1016     }
1017
1018   /* Get the digit string that might be a repeat count.  */
1019
1020   for (;;)
1021     {
1022       c = next_char ();
1023       switch (c)
1024         {
1025         CASE_DIGITS:
1026           push_char (c);
1027           break;
1028
1029         case '.':
1030           if (seen_dp)
1031             goto bad_real;
1032
1033           seen_dp = 1;
1034           push_char (c);
1035           goto real_loop;
1036
1037         case 'E':
1038         case 'e':
1039         case 'D':
1040         case 'd':
1041           goto exp1;
1042
1043         case '+':
1044         case '-':
1045           push_char ('e');
1046           push_char (c);
1047           c = next_char ();
1048           goto exp2;
1049
1050         case '*':
1051           push_char ('\0');
1052           goto got_repeat;
1053
1054         CASE_SEPARATORS:
1055           goto done;
1056
1057         default:
1058           goto bad_real;
1059         }
1060     }
1061
1062  got_repeat:
1063   if (convert_integer (-1, 0))
1064     return;
1065
1066   /* Now get the number itself.  */
1067
1068   c = next_char ();
1069   if (is_separator (c))
1070     {                           /* Repeated null value.  */
1071       unget_char (c);
1072       eat_separator ();
1073       return;
1074     }
1075
1076   if (c != '-' && c != '+')
1077     push_char ('+');
1078   else
1079     {
1080     got_sign:
1081       push_char (c);
1082       c = next_char ();
1083     }
1084
1085   if (!isdigit (c) && c != '.')
1086     goto bad_real;
1087
1088   if (c == '.')
1089     {
1090       if (seen_dp)
1091         goto bad_real;
1092       else
1093         seen_dp = 1;
1094     }
1095
1096   push_char (c);
1097
1098  real_loop:
1099   for (;;)
1100     {
1101       c = next_char ();
1102       switch (c)
1103         {
1104         CASE_DIGITS:
1105           push_char (c);
1106           break;
1107
1108         CASE_SEPARATORS:
1109           goto done;
1110
1111         case '.':
1112           if (seen_dp)
1113             goto bad_real;
1114
1115           seen_dp = 1;
1116           push_char (c);
1117           break;
1118
1119         case 'E':
1120         case 'e':
1121         case 'D':
1122         case 'd':
1123           goto exp1;
1124
1125         case '+':
1126         case '-':
1127           push_char ('e');
1128           push_char (c);
1129           c = next_char ();
1130           goto exp2;
1131
1132         default:
1133           goto bad_real;
1134         }
1135     }
1136
1137  exp1:
1138   push_char ('e');
1139
1140   c = next_char ();
1141   if (c != '+' && c != '-')
1142     push_char ('+');
1143   else
1144     {
1145       push_char (c);
1146       c = next_char ();
1147     }
1148
1149  exp2:
1150   if (!isdigit (c))
1151     goto bad_real;
1152   push_char (c);
1153
1154   for (;;)
1155     {
1156       c = next_char ();
1157
1158       switch (c)
1159         {
1160         CASE_DIGITS:
1161           push_char (c);
1162           break;
1163
1164         CASE_SEPARATORS:
1165           goto done;
1166
1167         default:
1168           goto bad_real;
1169         }
1170     }
1171
1172  done:
1173   unget_char (c);
1174   eat_separator ();
1175   push_char ('\0');
1176   if (convert_real (value, saved_string, length))
1177     return;
1178
1179   free_saved ();
1180   saved_type = BT_REAL;
1181   return;
1182
1183  bad_real:
1184   st_sprintf (message, "Bad real number in item %d of list input",
1185               g.item_count);
1186
1187   generate_error (ERROR_READ_VALUE, message);
1188 }
1189
1190
1191 /* Check the current type against the saved type to make sure they are
1192    compatible.  Returns nonzero if incompatible.  */
1193
1194 static int
1195 check_type (bt type, int len)
1196 {
1197   char message[100];
1198
1199   if (saved_type != BT_NULL && saved_type != type)
1200     {
1201       st_sprintf (message, "Read type %s where %s was expected for item %d",
1202                   type_name (saved_type), type_name (type), g.item_count);
1203
1204       generate_error (ERROR_READ_VALUE, message);
1205       return 1;
1206     }
1207
1208   if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
1209     return 0;
1210
1211   if (saved_length != len)
1212     {
1213       st_sprintf (message,
1214                   "Read kind %d %s where kind %d is required for item %d",
1215                   saved_length, type_name (saved_type), len, g.item_count);
1216       generate_error (ERROR_READ_VALUE, message);
1217       return 1;
1218     }
1219
1220   return 0;
1221 }
1222
1223
1224 /* Top level data transfer subroutine for list reads.  Because we have
1225    to deal with repeat counts, the data item is always saved after
1226    reading, usually in the value[] array.  If a repeat count is
1227    greater than one, we copy the data item multiple times.  */
1228
1229 void
1230 list_formatted_read (bt type, void *p, int len)
1231 {
1232   char c;
1233   int m;
1234
1235   namelist_mode = 0;
1236
1237   if (setjmp (g.eof_jump))
1238     {
1239       generate_error (ERROR_END, NULL);
1240       return;
1241     }
1242
1243   if (g.first_item)
1244     {
1245       g.first_item = 0;
1246       input_complete = 0;
1247       repeat_count = 1;
1248       at_eol = 0;
1249
1250       c = eat_spaces ();
1251       if (is_separator (c))
1252         {                       /* Found a null value.  */
1253           eat_separator ();
1254           repeat_count = 0;
1255           if (at_eol)
1256             finish_separator ();
1257           else
1258             return;
1259         }
1260
1261     }
1262   else
1263     {
1264       if (input_complete)
1265         return;
1266
1267       if (repeat_count > 0)
1268         {
1269           if (check_type (type, len))
1270             return;
1271           goto set_value;
1272         }
1273
1274       if (at_eol)
1275         finish_separator ();
1276       else
1277         {
1278           eat_spaces ();
1279           /* trailing spaces prior to end of line */
1280           if (at_eol)
1281             finish_separator ();
1282         }
1283
1284       saved_type = BT_NULL;
1285       repeat_count = 1;
1286     }
1287
1288   switch (type)
1289     {
1290     case BT_INTEGER:
1291       read_integer (len);
1292       break;
1293     case BT_LOGICAL:
1294       read_logical (len);
1295       break;
1296     case BT_CHARACTER:
1297       read_character (len);
1298       break;
1299     case BT_REAL:
1300       read_real (len);
1301       break;
1302     case BT_COMPLEX:
1303       read_complex (len);
1304       break;
1305     default:
1306       internal_error ("Bad type for list read");
1307     }
1308
1309   if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
1310     saved_length = len;
1311
1312   if (ioparm.library_return != LIBRARY_OK)
1313     return;
1314
1315  set_value:
1316   switch (saved_type)
1317     {
1318     case BT_COMPLEX:
1319       len = 2 * len;
1320       /* Fall through.  */
1321
1322     case BT_INTEGER:
1323     case BT_REAL:
1324     case BT_LOGICAL:
1325       memcpy (p, value, len);
1326       break;
1327
1328     case BT_CHARACTER:
1329       if (saved_string)
1330        {
1331           m = (len < saved_used) ? len : saved_used;
1332           memcpy (p, saved_string, m);
1333        }
1334       else
1335         /* Just delimiters encountered, nothing to copy but SPACE.  */
1336         m = 0;
1337
1338       if (m < len)
1339         memset (((char *) p) + m, ' ', len - m);
1340       break;
1341
1342     case BT_NULL:
1343       break;
1344     }
1345
1346   if (--repeat_count <= 0)
1347     free_saved ();
1348 }
1349
1350 void
1351 init_at_eol(void)
1352 {
1353   at_eol = 0;
1354 }
1355
1356 /* Finish a list read.  */
1357
1358 void
1359 finish_list_read (void)
1360 {
1361   char c;
1362
1363   free_saved ();
1364
1365   if (at_eol)
1366     {
1367       at_eol = 0;
1368       return;
1369     }
1370
1371   do
1372     {
1373       c = next_char ();
1374     }
1375   while (c != '\n');
1376 }
1377
1378 static namelist_info *
1379 find_nml_node (char * var_name)
1380 {
1381    namelist_info * t = ionml;
1382    while (t != NULL)
1383      {
1384        if (strcmp (var_name,t->var_name) == 0)
1385          {
1386            t->value_acquired = 1;
1387            return t;
1388          }
1389        t = t->next;
1390      }
1391   return NULL;
1392 }
1393
1394 static void
1395 match_namelist_name (char *name, int len)
1396 {
1397   int name_len;
1398   char c;
1399   char * namelist_name = name;
1400
1401   name_len = 0;
1402   /* Match the name of the namelist.  */
1403
1404   if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
1405     {
1406     wrong_name:
1407       generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
1408       return;
1409     }
1410
1411   while (name_len < len)
1412     {
1413       c = next_char ();
1414       if (tolower (c) != tolower (namelist_name[name_len++]))
1415         goto wrong_name;
1416     }
1417 }
1418
1419
1420 /********************************************************************
1421       Namelist reads
1422 ********************************************************************/
1423
1424 /* Process a namelist read.  This subroutine initializes things,
1425    positions to the first element and
1426    FIXME: was this comment ever complete?  */
1427
1428 void
1429 namelist_read (void)
1430 {
1431   char c;
1432   int name_matched, next_name ;
1433   namelist_info * nl;
1434   int len, m;
1435   void * p;
1436
1437   namelist_mode = 1;
1438
1439   if (setjmp (g.eof_jump))
1440     {
1441       generate_error (ERROR_END, NULL);
1442       return;
1443     }
1444
1445  restart:
1446   c = next_char ();
1447   switch (c)
1448     {
1449     case ' ':
1450       goto restart;
1451     case '!':
1452       do
1453         c = next_char ();
1454       while (c != '\n');
1455
1456       goto restart;
1457
1458     case '&':
1459       break;
1460
1461     default:
1462       generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
1463       return;
1464     }
1465
1466   /* Match the name of the namelist.  */
1467   match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
1468
1469   /* Ready to read namelist elements.  */
1470   while (!input_complete)
1471     {
1472       c = next_char ();
1473       switch (c)
1474         {
1475         case '/':
1476           input_complete = 1;
1477           next_record (0);
1478           break;
1479         case '&':
1480           match_namelist_name("end",3);
1481           return;
1482         case '\\':
1483           return;
1484         case ' ':
1485         case '\n':
1486         case '\t':
1487           break;
1488         case ',':
1489           next_name = 1;
1490           break;
1491
1492         case '=':
1493           name_matched = 1;
1494           nl = find_nml_node (saved_string);
1495           if (nl == NULL)
1496             internal_error ("Can not match a namelist variable");
1497           free_saved();
1498
1499           len = nl->len;
1500           p = nl->mem_pos;
1501
1502           /* skip any blanks or tabs after the = */
1503           eat_spaces ();
1504
1505           switch (nl->type)
1506             {
1507             case BT_INTEGER:
1508               read_integer (len);
1509               break;
1510             case BT_LOGICAL:
1511               read_logical (len);
1512               break;
1513             case BT_CHARACTER:
1514               read_character (len);
1515               break;
1516             case BT_REAL:
1517               read_real (len);
1518               break;
1519             case BT_COMPLEX:
1520               read_complex (len);
1521               break;
1522             default:
1523               internal_error ("Bad type for namelist read");
1524             }
1525
1526            switch (saved_type)
1527             {
1528             case BT_COMPLEX:
1529               len = 2 * len;
1530               /* Fall through...  */
1531
1532             case BT_INTEGER:
1533             case BT_REAL:
1534             case BT_LOGICAL:
1535               memcpy (p, value, len);
1536               break;
1537
1538             case BT_CHARACTER:
1539               m = (len < saved_used) ? len : saved_used;
1540               memcpy (p, saved_string, m);
1541
1542               if (m < len)
1543                 memset (((char *) p) + m, ' ', len - m);
1544               break;
1545
1546             case BT_NULL:
1547               break;
1548             }
1549
1550           break;
1551
1552         default :
1553           push_char(tolower(c));
1554           break;
1555         }
1556    }
1557 }