OSDN Git Service

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