OSDN Git Service

2011-01-04 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / list_read.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4    Namelist input contributed by Paul Thomas
5    F2003 I/O support contributed by Jerry DeLisle
6
7 This file is part of the GNU Fortran runtime library (libgfortran).
8
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
12 any later version.
13
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 GNU General Public License for more details.
18
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
22
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
26 <http://www.gnu.org/licenses/>.  */
27
28
29 #include "io.h"
30 #include "fbuf.h"
31 #include "unix.h"
32 #include <string.h>
33 #include <stdlib.h>
34 #include <ctype.h>
35
36
37 /* List directed input.  Several parsing subroutines are practically
38    reimplemented from formatted input, the reason being that there are
39    all kinds of small differences between formatted and list directed
40    parsing.  */
41
42
43 /* Subroutines for reading characters from the input.  Because a
44    repeat count is ambiguous with an integer, we have to read the
45    whole digit string before seeing if there is a '*' which signals
46    the repeat count.  Since we can have a lot of potential leading
47    zeros, we have to be able to back up by arbitrary amount.  Because
48    the input might not be seekable, we have to buffer the data
49    ourselves.  */
50
51 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
52                       case '5': case '6': case '7': case '8': case '9'
53
54 #define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t': \
55                          case '\r': case ';'
56
57 /* This macro assumes that we're operating on a variable.  */
58
59 #define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
60                          || c == '\t' || c == '\r' || c == ';')
61
62 /* Maximum repeat count.  Less than ten times the maximum signed int32.  */
63
64 #define MAX_REPEAT 200000000
65
66 #ifndef HAVE_SNPRINTF
67 # undef snprintf
68 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
69 #endif
70
71 /* Save a character to a string buffer, enlarging it as necessary.  */
72
73 static void
74 push_char (st_parameter_dt *dtp, char c)
75 {
76   char *new;
77
78   if (dtp->u.p.saved_string == NULL)
79     {
80       dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
81       // memset below should be commented out.
82       memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
83       dtp->u.p.saved_length = SCRATCH_SIZE;
84       dtp->u.p.saved_used = 0;
85     }
86
87   if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
88     {
89       dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
90       new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
91       if (new == NULL)
92         generate_error (&dtp->common, LIBERROR_OS, NULL);
93       dtp->u.p.saved_string = new;
94       
95       // Also this should not be necessary.
96       memset (new + dtp->u.p.saved_used, 0, 
97               dtp->u.p.saved_length - dtp->u.p.saved_used);
98
99     }
100
101   dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
102 }
103
104
105 /* Free the input buffer if necessary.  */
106
107 static void
108 free_saved (st_parameter_dt *dtp)
109 {
110   if (dtp->u.p.saved_string == NULL)
111     return;
112
113   free (dtp->u.p.saved_string);
114
115   dtp->u.p.saved_string = NULL;
116   dtp->u.p.saved_used = 0;
117 }
118
119
120 /* Free the line buffer if necessary.  */
121
122 static void
123 free_line (st_parameter_dt *dtp)
124 {
125   dtp->u.p.item_count = 0;
126   dtp->u.p.line_buffer_enabled = 0;
127
128   if (dtp->u.p.line_buffer == NULL)
129     return;
130
131   free (dtp->u.p.line_buffer);
132   dtp->u.p.line_buffer = NULL;
133 }
134
135
136 static int
137 next_char (st_parameter_dt *dtp)
138 {
139   ssize_t length;
140   gfc_offset record;
141   int c;
142
143   if (dtp->u.p.last_char != EOF - 1)
144     {
145       dtp->u.p.at_eol = 0;
146       c = dtp->u.p.last_char;
147       dtp->u.p.last_char = EOF - 1;
148       goto done;
149     }
150
151   /* Read from line_buffer if enabled.  */
152
153   if (dtp->u.p.line_buffer_enabled)
154     {
155       dtp->u.p.at_eol = 0;
156
157       c = dtp->u.p.line_buffer[dtp->u.p.item_count];
158       if (c != '\0' && dtp->u.p.item_count < 64)
159         {
160           dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
161           dtp->u.p.item_count++;
162           goto done;
163         }
164
165       dtp->u.p.item_count = 0;
166       dtp->u.p.line_buffer_enabled = 0;
167     }    
168
169   /* Handle the end-of-record and end-of-file conditions for
170      internal array unit.  */
171   if (is_array_io (dtp))
172     {
173       if (dtp->u.p.at_eof)
174         return EOF;
175
176       /* Check for "end-of-record" condition.  */
177       if (dtp->u.p.current_unit->bytes_left == 0)
178         {
179           int finished;
180
181           c = '\n';
182           record = next_array_record (dtp, dtp->u.p.current_unit->ls,
183                                       &finished);
184
185           /* Check for "end-of-file" condition.  */      
186           if (finished)
187             {
188               dtp->u.p.at_eof = 1;
189               goto done;
190             }
191
192           record *= dtp->u.p.current_unit->recl;
193           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
194             return EOF;
195
196           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
197           goto done;
198         }
199     }
200
201   /* Get the next character and handle end-of-record conditions.  */
202
203   if (is_internal_unit (dtp))
204     {
205       char cc;
206       length = sread (dtp->u.p.current_unit->s, &cc, 1);
207       c = cc;
208       if (length < 0)
209         {
210           generate_error (&dtp->common, LIBERROR_OS, NULL);
211           return '\0';
212         }
213   
214       if (is_array_io (dtp))
215         {
216           /* Check whether we hit EOF.  */ 
217           if (length == 0)
218             {
219               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
220               return '\0';
221             } 
222           dtp->u.p.current_unit->bytes_left--;
223         }
224       else
225         {
226           if (dtp->u.p.at_eof) 
227             return EOF;
228           if (length == 0)
229             {
230               c = '\n';
231               dtp->u.p.at_eof = 1;
232             }
233         }
234     }
235   else
236     {
237       c = fbuf_getc (dtp->u.p.current_unit);
238       if (c != EOF && is_stream_io (dtp))
239         dtp->u.p.current_unit->strm_pos++;
240     }
241 done:
242   dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF);
243   return c;
244 }
245
246
247 /* Push a character back onto the input.  */
248
249 static void
250 unget_char (st_parameter_dt *dtp, int c)
251 {
252   dtp->u.p.last_char = c;
253 }
254
255
256 /* Skip over spaces in the input.  Returns the nonspace character that
257    terminated the eating and also places it back on the input.  */
258
259 static int
260 eat_spaces (st_parameter_dt *dtp)
261 {
262   int c;
263
264   do
265     c = next_char (dtp);
266   while (c != EOF && (c == ' ' || c == '\t'));
267
268   unget_char (dtp, c);
269   return c;
270 }
271
272
273 /* This function reads characters through to the end of the current
274    line and just ignores them.  Returns 0 for success and LIBERROR_END
275    if it hit EOF.  */
276
277 static int
278 eat_line (st_parameter_dt *dtp)
279 {
280   int c;
281
282   do
283     c = next_char (dtp);
284   while (c != EOF && c != '\n');
285   if (c == EOF)
286     return LIBERROR_END;
287   return 0;
288 }
289
290
291 /* Skip over a separator.  Technically, we don't always eat the whole
292    separator.  This is because if we've processed the last input item,
293    then a separator is unnecessary.  Plus the fact that operating
294    systems usually deliver console input on a line basis.
295
296    The upshot is that if we see a newline as part of reading a
297    separator, we stop reading.  If there are more input items, we
298    continue reading the separator with finish_separator() which takes
299    care of the fact that we may or may not have seen a comma as part
300    of the separator. 
301
302    Returns 0 for success, and non-zero error code otherwise.  */
303
304 static int
305 eat_separator (st_parameter_dt *dtp)
306 {
307   int c, n;
308   int err = 0;
309
310   eat_spaces (dtp);
311   dtp->u.p.comma_flag = 0;
312
313   if ((c = next_char (dtp)) == EOF)
314     return LIBERROR_END;
315   switch (c)
316     {
317     case ',':
318       if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
319         {
320           unget_char (dtp, c);
321           break;
322         }
323       /* Fall through.  */
324     case ';':
325       dtp->u.p.comma_flag = 1;
326       eat_spaces (dtp);
327       break;
328
329     case '/':
330       dtp->u.p.input_complete = 1;
331       break;
332
333     case '\r':
334       dtp->u.p.at_eol = 1;
335       if ((n = next_char(dtp)) == EOF)
336         return LIBERROR_END;
337       if (n != '\n')
338         {
339           unget_char (dtp, n);
340           break;
341         }
342     /* Fall through.  */
343     case '\n':
344       dtp->u.p.at_eol = 1;
345       if (dtp->u.p.namelist_mode)
346         {
347           do
348             {
349               if ((c = next_char (dtp)) == EOF)
350                   return LIBERROR_END;
351               if (c == '!')
352                 {
353                   err = eat_line (dtp);
354                   if (err)
355                     return err;
356                   if ((c = next_char (dtp)) == EOF)
357                     return LIBERROR_END;
358                   if (c == '!')
359                     {
360                       err = eat_line (dtp);
361                       if (err)
362                         return err;
363                       if ((c = next_char (dtp)) == EOF)
364                         return LIBERROR_END;
365                     }
366                 }
367             }
368           while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
369           unget_char (dtp, c);
370         }
371       break;
372
373     case '!':
374       if (dtp->u.p.namelist_mode)
375         {                       /* Eat a namelist comment.  */
376           err = eat_line (dtp);
377           if (err)
378             return err;
379
380           break;
381         }
382
383       /* Fall Through...  */
384
385     default:
386       unget_char (dtp, c);
387       break;
388     }
389   return err;
390 }
391
392
393 /* Finish processing a separator that was interrupted by a newline.
394    If we're here, then another data item is present, so we finish what
395    we started on the previous line.  Return 0 on success, error code
396    on failure.  */
397
398 static int
399 finish_separator (st_parameter_dt *dtp)
400 {
401   int c;
402   int err;
403
404  restart:
405   eat_spaces (dtp);
406
407   if ((c = next_char (dtp)) == EOF)
408     return LIBERROR_END;
409   switch (c)
410     {
411     case ',':
412       if (dtp->u.p.comma_flag)
413         unget_char (dtp, c);
414       else
415         {
416           if ((c = eat_spaces (dtp)) == EOF)
417             return LIBERROR_END;
418           if (c == '\n' || c == '\r')
419             goto restart;
420         }
421
422       break;
423
424     case '/':
425       dtp->u.p.input_complete = 1;
426       if (!dtp->u.p.namelist_mode)
427         return err;
428       break;
429
430     case '\n':
431     case '\r':
432       goto restart;
433
434     case '!':
435       if (dtp->u.p.namelist_mode)
436         {
437           err = eat_line (dtp);
438           if (err)
439             return err;
440           goto restart;
441         }
442
443     default:
444       unget_char (dtp, c);
445       break;
446     }
447   return err;
448 }
449
450
451 /* This function is needed to catch bad conversions so that namelist can
452    attempt to see if dtp->u.p.saved_string contains a new object name rather
453    than a bad value.  */
454
455 static int
456 nml_bad_return (st_parameter_dt *dtp, char c)
457 {
458   if (dtp->u.p.namelist_mode)
459     {
460       dtp->u.p.nml_read_error = 1;
461       unget_char (dtp, c);
462       return 1;
463     }
464   return 0;
465 }
466
467 /* Convert an unsigned string to an integer.  The length value is -1
468    if we are working on a repeat count.  Returns nonzero if we have a
469    range problem.  As a side effect, frees the dtp->u.p.saved_string.  */
470
471 static int
472 convert_integer (st_parameter_dt *dtp, int length, int negative)
473 {
474   char c, *buffer, message[100];
475   int m;
476   GFC_INTEGER_LARGEST v, max, max10;
477
478   buffer = dtp->u.p.saved_string;
479   v = 0;
480
481   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
482   max10 = max / 10;
483
484   for (;;)
485     {
486       c = *buffer++;
487       if (c == '\0')
488         break;
489       c -= '0';
490
491       if (v > max10)
492         goto overflow;
493       v = 10 * v;
494
495       if (v > max - c)
496         goto overflow;
497       v += c;
498     }
499
500   m = 0;
501
502   if (length != -1)
503     {
504       if (negative)
505         v = -v;
506       set_integer (dtp->u.p.value, v, length);
507     }
508   else
509     {
510       dtp->u.p.repeat_count = v;
511
512       if (dtp->u.p.repeat_count == 0)
513         {
514           sprintf (message, "Zero repeat count in item %d of list input",
515                    dtp->u.p.item_count);
516
517           generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
518           m = 1;
519         }
520     }
521
522   free_saved (dtp);
523   return m;
524
525  overflow:
526   if (length == -1)
527     sprintf (message, "Repeat count overflow in item %d of list input",
528              dtp->u.p.item_count);
529   else
530     sprintf (message, "Integer overflow while reading item %d",
531              dtp->u.p.item_count);
532
533   free_saved (dtp);
534   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
535
536   return 1;
537 }
538
539
540 /* Parse a repeat count for logical and complex values which cannot
541    begin with a digit.  Returns nonzero if we are done, zero if we
542    should continue on.  */
543
544 static int
545 parse_repeat (st_parameter_dt *dtp)
546 {
547   char message[100];
548   int c, repeat;
549
550   if ((c = next_char (dtp)) == EOF)
551     goto bad_repeat;
552   switch (c)
553     {
554     CASE_DIGITS:
555       repeat = c - '0';
556       break;
557
558     CASE_SEPARATORS:
559       unget_char (dtp, c);
560       eat_separator (dtp);
561       return 1;
562
563     default:
564       unget_char (dtp, c);
565       return 0;
566     }
567
568   for (;;)
569     {
570       c = next_char (dtp);
571       switch (c)
572         {
573         CASE_DIGITS:
574           repeat = 10 * repeat + c - '0';
575
576           if (repeat > MAX_REPEAT)
577             {
578               sprintf (message,
579                        "Repeat count overflow in item %d of list input",
580                        dtp->u.p.item_count);
581
582               generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
583               return 1;
584             }
585
586           break;
587
588         case '*':
589           if (repeat == 0)
590             {
591               sprintf (message,
592                        "Zero repeat count in item %d of list input",
593                        dtp->u.p.item_count);
594
595               generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
596               return 1;
597             }
598
599           goto done;
600
601         default:
602           goto bad_repeat;
603         }
604     }
605
606  done:
607   dtp->u.p.repeat_count = repeat;
608   return 0;
609
610  bad_repeat:
611
612   free_saved (dtp);
613   if (c == EOF)
614     {
615       hit_eof (dtp);
616       return 1;
617     }
618   else
619     eat_line (dtp);
620   sprintf (message, "Bad repeat count in item %d of list input",
621            dtp->u.p.item_count);
622   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
623   return 1;
624 }
625
626
627 /* To read a logical we have to look ahead in the input stream to make sure
628     there is not an equal sign indicating a variable name.  To do this we use 
629     line_buffer to point to a temporary buffer, pushing characters there for
630     possible later reading. */
631
632 static void
633 l_push_char (st_parameter_dt *dtp, char c)
634 {
635   if (dtp->u.p.line_buffer == NULL)
636     {
637       dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
638       memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
639     }
640
641   dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
642 }
643
644
645 /* Read a logical character on the input.  */
646
647 static void
648 read_logical (st_parameter_dt *dtp, int length)
649 {
650   char message[100];
651   int c, i, v;
652
653   if (parse_repeat (dtp))
654     return;
655
656   c = tolower (next_char (dtp));
657   l_push_char (dtp, c);
658   switch (c)
659     {
660     case 't':
661       v = 1;
662       if ((c = next_char (dtp)) == EOF)
663         goto bad_logical;
664       l_push_char (dtp, c);
665
666       if (!is_separator(c))
667         goto possible_name;
668
669       unget_char (dtp, c);
670       break;
671     case 'f':
672       v = 0;
673       if ((c = next_char (dtp)) == EOF)
674         goto bad_logical;
675       l_push_char (dtp, c);
676
677       if (!is_separator(c))
678         goto possible_name;
679
680       unget_char (dtp, c);
681       break;
682
683     case '.':
684       c = tolower (next_char (dtp));
685       switch (c)
686         {
687           case 't':
688             v = 1;
689             break;
690           case 'f':
691             v = 0;
692             break;
693           default:
694             goto bad_logical;
695         }
696
697       break;
698
699     CASE_SEPARATORS:
700       unget_char (dtp, c);
701       eat_separator (dtp);
702       return;                   /* Null value.  */
703
704     default:
705       /* Save the character in case it is the beginning
706          of the next object name. */
707       unget_char (dtp, c);
708       goto bad_logical;
709     }
710
711   dtp->u.p.saved_type = BT_LOGICAL;
712   dtp->u.p.saved_length = length;
713
714   /* Eat trailing garbage.  */
715   do
716     c = next_char (dtp);
717   while (c != EOF && !is_separator (c));
718
719   unget_char (dtp, c);
720   eat_separator (dtp);
721   set_integer ((int *) dtp->u.p.value, v, length);
722   free_line (dtp);
723
724   return;
725
726  possible_name:
727
728   for(i = 0; i < 63; i++)
729     {
730       c = next_char (dtp);
731       if (is_separator(c))
732         {
733           /* All done if this is not a namelist read.  */
734           if (!dtp->u.p.namelist_mode)
735             goto logical_done;
736
737           unget_char (dtp, c);
738           eat_separator (dtp);
739           c = next_char (dtp);
740           if (c != '=')
741             {
742               unget_char (dtp, c);
743               goto logical_done;
744             }
745         }
746  
747       l_push_char (dtp, c);
748       if (c == '=')
749         {
750           dtp->u.p.nml_read_error = 1;
751           dtp->u.p.line_buffer_enabled = 1;
752           dtp->u.p.item_count = 0;
753           return;
754         }
755       
756     }
757
758  bad_logical:
759
760   free_line (dtp);
761
762   if (nml_bad_return (dtp, c))
763     return;
764
765   free_saved (dtp);
766   if (c == EOF)
767     {
768       hit_eof (dtp);
769       return;
770     }
771   else
772     eat_line (dtp);
773   sprintf (message, "Bad logical value while reading item %d",
774               dtp->u.p.item_count);
775   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
776   return;
777
778  logical_done:
779
780   dtp->u.p.saved_type = BT_LOGICAL;
781   dtp->u.p.saved_length = length;
782   set_integer ((int *) dtp->u.p.value, v, length);
783   free_saved (dtp);
784   free_line (dtp);
785 }
786
787
788 /* Reading integers is tricky because we can actually be reading a
789    repeat count.  We have to store the characters in a buffer because
790    we could be reading an integer that is larger than the default int
791    used for repeat counts.  */
792
793 static void
794 read_integer (st_parameter_dt *dtp, int length)
795 {
796   char message[100];
797   int c, negative;
798
799   negative = 0;
800
801   c = next_char (dtp);
802   switch (c)
803     {
804     case '-':
805       negative = 1;
806       /* Fall through...  */
807
808     case '+':
809       if ((c = next_char (dtp)) == EOF)
810         goto bad_integer;
811       goto get_integer;
812
813     CASE_SEPARATORS:            /* Single null.  */
814       unget_char (dtp, c);
815       eat_separator (dtp);
816       return;
817
818     CASE_DIGITS:
819       push_char (dtp, c);
820       break;
821
822     default:
823       goto bad_integer;
824     }
825
826   /* Take care of what may be a repeat count.  */
827
828   for (;;)
829     {
830       c = next_char (dtp);
831       switch (c)
832         {
833         CASE_DIGITS:
834           push_char (dtp, c);
835           break;
836
837         case '*':
838           push_char (dtp, '\0');
839           goto repeat;
840
841         CASE_SEPARATORS:        /* Not a repeat count.  */
842           goto done;
843
844         default:
845           goto bad_integer;
846         }
847     }
848
849  repeat:
850   if (convert_integer (dtp, -1, 0))
851     return;
852
853   /* Get the real integer.  */
854
855   if ((c = next_char (dtp)) == EOF)
856     goto bad_integer;
857   switch (c)
858     {
859     CASE_DIGITS:
860       break;
861
862     CASE_SEPARATORS:
863       unget_char (dtp, c);
864       eat_separator (dtp);
865       return;
866
867     case '-':
868       negative = 1;
869       /* Fall through...  */
870
871     case '+':
872       c = next_char (dtp);
873       break;
874     }
875
876  get_integer:
877   if (!isdigit (c))
878     goto bad_integer;
879   push_char (dtp, c);
880
881   for (;;)
882     {
883       c = next_char (dtp);
884       switch (c)
885         {
886         CASE_DIGITS:
887           push_char (dtp, c);
888           break;
889
890         CASE_SEPARATORS:
891           goto done;
892
893         default:
894           goto bad_integer;
895         }
896     }
897
898  bad_integer:
899
900   if (nml_bad_return (dtp, c))
901     return;
902
903   free_saved (dtp);  
904   if (c == EOF)
905     {
906       hit_eof (dtp);
907       return;
908     }
909   else
910     eat_line (dtp);
911   sprintf (message, "Bad integer for item %d in list input",
912               dtp->u.p.item_count);
913   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
914
915   return;
916
917  done:
918   unget_char (dtp, c);
919   eat_separator (dtp);
920
921   push_char (dtp, '\0');
922   if (convert_integer (dtp, length, negative))
923     {
924        free_saved (dtp);
925        return;
926     }
927
928   free_saved (dtp);
929   dtp->u.p.saved_type = BT_INTEGER;
930 }
931
932
933 /* Read a character variable.  */
934
935 static void
936 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
937 {
938   char quote, message[100];
939   int c;
940
941   quote = ' ';                  /* Space means no quote character.  */
942
943   if ((c = next_char (dtp)) == EOF)
944     goto eof;
945   switch (c)
946     {
947     CASE_DIGITS:
948       push_char (dtp, c);
949       break;
950
951     CASE_SEPARATORS:
952       unget_char (dtp, c);              /* NULL value.  */
953       eat_separator (dtp);
954       return;
955
956     case '"':
957     case '\'':
958       quote = c;
959       goto get_string;
960
961     default:
962       if (dtp->u.p.namelist_mode)
963         {
964           unget_char (dtp, c);
965           return;
966         }
967
968       push_char (dtp, c);
969       goto get_string;
970     }
971
972   /* Deal with a possible repeat count.  */
973
974   for (;;)
975     {
976       if ((c = next_char (dtp)) == EOF)
977         goto eof;
978       switch (c)
979         {
980         CASE_DIGITS:
981           push_char (dtp, c);
982           break;
983
984         CASE_SEPARATORS:
985           unget_char (dtp, c);
986           goto done;            /* String was only digits!  */
987
988         case '*':
989           push_char (dtp, '\0');
990           goto got_repeat;
991
992         default:
993           push_char (dtp, c);
994           goto get_string;      /* Not a repeat count after all.  */
995         }
996     }
997
998  got_repeat:
999   if (convert_integer (dtp, -1, 0))
1000     return;
1001
1002   /* Now get the real string.  */
1003
1004   if ((c = next_char (dtp)) == EOF)
1005     goto eof;
1006   switch (c)
1007     {
1008     CASE_SEPARATORS:
1009       unget_char (dtp, c);              /* Repeated NULL values.  */
1010       eat_separator (dtp);
1011       return;
1012
1013     case '"':
1014     case '\'':
1015       quote = c;
1016       break;
1017
1018     default:
1019       push_char (dtp, c);
1020       break;
1021     }
1022
1023  get_string:
1024   for (;;)
1025     {
1026       if ((c = next_char (dtp)) == EOF)
1027         goto eof;
1028       switch (c)
1029         {
1030         case '"':
1031         case '\'':
1032           if (c != quote)
1033             {
1034               push_char (dtp, c);
1035               break;
1036             }
1037
1038           /* See if we have a doubled quote character or the end of
1039              the string.  */
1040
1041           if ((c = next_char (dtp)) == EOF)
1042             goto eof;
1043           if (c == quote)
1044             {
1045               push_char (dtp, quote);
1046               break;
1047             }
1048
1049           unget_char (dtp, c);
1050           goto done;
1051
1052         CASE_SEPARATORS:
1053           if (quote == ' ')
1054             {
1055               unget_char (dtp, c);
1056               goto done;
1057             }
1058
1059           if (c != '\n' && c != '\r')
1060             push_char (dtp, c);
1061           break;
1062
1063         default:
1064           push_char (dtp, c);
1065           break;
1066         }
1067     }
1068
1069   /* At this point, we have to have a separator, or else the string is
1070      invalid.  */
1071  done:
1072   c = next_char (dtp);
1073  eof:
1074   if (is_separator (c) || c == '!')
1075     {
1076       unget_char (dtp, c);
1077       eat_separator (dtp);
1078       dtp->u.p.saved_type = BT_CHARACTER;
1079       free_line (dtp);
1080     }
1081   else
1082     {
1083       free_saved (dtp);
1084       if (c == EOF)
1085         {
1086           hit_eof (dtp);
1087           return;
1088         }
1089       sprintf (message, "Invalid string input in item %d",
1090                   dtp->u.p.item_count);
1091       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1092     }
1093 }
1094
1095
1096 /* Parse a component of a complex constant or a real number that we
1097    are sure is already there.  This is a straight real number parser.  */
1098
1099 static int
1100 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1101 {
1102   char message[100];
1103   int c, m, seen_dp;
1104
1105   if ((c = next_char (dtp)) == EOF)
1106     goto bad;
1107   if (c == '-' || c == '+')
1108     {
1109       push_char (dtp, c);
1110       if ((c = next_char (dtp)) == EOF)
1111         goto bad;
1112     }
1113
1114   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1115     c = '.';
1116   
1117   if (!isdigit (c) && c != '.')
1118     {
1119       if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1120         goto inf_nan;
1121       else
1122         goto bad;
1123     }
1124
1125   push_char (dtp, c);
1126
1127   seen_dp = (c == '.') ? 1 : 0;
1128
1129   for (;;)
1130     {
1131       if ((c = next_char (dtp)) == EOF)
1132         goto bad;
1133       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1134         c = '.';
1135       switch (c)
1136         {
1137         CASE_DIGITS:
1138           push_char (dtp, c);
1139           break;
1140
1141         case '.':
1142           if (seen_dp)
1143             goto bad;
1144
1145           seen_dp = 1;
1146           push_char (dtp, c);
1147           break;
1148
1149         case 'e':
1150         case 'E':
1151         case 'd':
1152         case 'D':
1153           push_char (dtp, 'e');
1154           goto exp1;
1155
1156         case '-':
1157         case '+':
1158           push_char (dtp, 'e');
1159           push_char (dtp, c);
1160           if ((c = next_char (dtp)) == EOF)
1161             goto bad;
1162           goto exp2;
1163
1164         CASE_SEPARATORS:
1165           unget_char (dtp, c);
1166           goto done;
1167
1168         default:
1169           goto done;
1170         }
1171     }
1172
1173  exp1:
1174   if ((c = next_char (dtp)) == EOF)
1175     goto bad;
1176   if (c != '-' && c != '+')
1177     push_char (dtp, '+');
1178   else
1179     {
1180       push_char (dtp, c);
1181       c = next_char (dtp);
1182     }
1183
1184  exp2:
1185   if (!isdigit (c))
1186     goto bad;
1187
1188   push_char (dtp, c);
1189
1190   for (;;)
1191     {
1192       if ((c = next_char (dtp)) == EOF)
1193         goto bad;
1194       switch (c)
1195         {
1196         CASE_DIGITS:
1197           push_char (dtp, c);
1198           break;
1199
1200         CASE_SEPARATORS:
1201           unget_char (dtp, c);
1202           goto done;
1203
1204         default:
1205           goto done;
1206         }
1207     }
1208
1209  done:
1210   unget_char (dtp, c);
1211   push_char (dtp, '\0');
1212
1213   m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1214   free_saved (dtp);
1215
1216   return m;
1217
1218  inf_nan:
1219   /* Match INF and Infinity.  */
1220   if ((c == 'i' || c == 'I')
1221       && ((c = next_char (dtp)) == 'n' || c == 'N')
1222       && ((c = next_char (dtp)) == 'f' || c == 'F'))
1223     {
1224         c = next_char (dtp);
1225         if ((c != 'i' && c != 'I')
1226             || ((c == 'i' || c == 'I')
1227                 && ((c = next_char (dtp)) == 'n' || c == 'N')
1228                 && ((c = next_char (dtp)) == 'i' || c == 'I')
1229                 && ((c = next_char (dtp)) == 't' || c == 'T')
1230                 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1231                 && (c = next_char (dtp))))
1232           {
1233              if (is_separator (c))
1234                unget_char (dtp, c);
1235              push_char (dtp, 'i');
1236              push_char (dtp, 'n');
1237              push_char (dtp, 'f');
1238              goto done;
1239           }
1240     } /* Match NaN.  */
1241   else if (((c = next_char (dtp)) == 'a' || c == 'A')
1242            && ((c = next_char (dtp)) == 'n' || c == 'N')
1243            && (c = next_char (dtp)))
1244     {
1245       if (is_separator (c))
1246         unget_char (dtp, c);
1247       push_char (dtp, 'n');
1248       push_char (dtp, 'a');
1249       push_char (dtp, 'n');
1250       
1251       /* Match "NAN(alphanum)".  */
1252       if (c == '(')
1253         {
1254           for ( ; c != ')'; c = next_char (dtp))
1255             if (is_separator (c))
1256               goto bad;
1257
1258           c = next_char (dtp);
1259           if (is_separator (c))
1260             unget_char (dtp, c);
1261         }
1262       goto done;
1263     }
1264
1265  bad:
1266
1267   if (nml_bad_return (dtp, c))
1268     return 0;
1269
1270   free_saved (dtp);
1271   if (c == EOF)
1272     {
1273       hit_eof (dtp);
1274       return 1;
1275     }
1276   else
1277     eat_line (dtp);
1278   sprintf (message, "Bad floating point number for item %d",
1279               dtp->u.p.item_count);
1280   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1281
1282   return 1;
1283 }
1284
1285
1286 /* Reading a complex number is straightforward because we can tell
1287    what it is right away.  */
1288
1289 static void
1290 read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
1291 {
1292   char message[100];
1293   int c;
1294
1295   if (parse_repeat (dtp))
1296     return;
1297
1298   c = next_char (dtp);
1299   switch (c)
1300     {
1301     case '(':
1302       break;
1303
1304     CASE_SEPARATORS:
1305       unget_char (dtp, c);
1306       eat_separator (dtp);
1307       return;
1308
1309     default:
1310       goto bad_complex;
1311     }
1312
1313   eat_spaces (dtp);
1314   if (parse_real (dtp, dest, kind))
1315     return;
1316
1317 eol_1:
1318   eat_spaces (dtp);
1319   c = next_char (dtp);
1320   if (c == '\n' || c== '\r')
1321     goto eol_1;
1322   else
1323     unget_char (dtp, c);
1324
1325   if (next_char (dtp)
1326       !=  (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
1327     goto bad_complex;
1328
1329 eol_2:
1330   eat_spaces (dtp);
1331   c = next_char (dtp);
1332   if (c == '\n' || c== '\r')
1333     goto eol_2;
1334   else
1335     unget_char (dtp, c);
1336
1337   if (parse_real (dtp, dest + size / 2, kind))
1338     return;
1339
1340   eat_spaces (dtp);
1341   if (next_char (dtp) != ')')
1342     goto bad_complex;
1343
1344   c = next_char (dtp);
1345   if (!is_separator (c))
1346     goto bad_complex;
1347
1348   unget_char (dtp, c);
1349   eat_separator (dtp);
1350
1351   free_saved (dtp);
1352   dtp->u.p.saved_type = BT_COMPLEX;
1353   return;
1354
1355  bad_complex:
1356
1357   if (nml_bad_return (dtp, c))
1358     return;
1359
1360   free_saved (dtp);
1361   if (c == EOF)
1362     {
1363       hit_eof (dtp);
1364       return;
1365     }
1366   else    
1367     eat_line (dtp);
1368   sprintf (message, "Bad complex value in item %d of list input",
1369               dtp->u.p.item_count);
1370   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1371 }
1372
1373
1374 /* Parse a real number with a possible repeat count.  */
1375
1376 static void
1377 read_real (st_parameter_dt *dtp, void * dest, int length)
1378 {
1379   char message[100];
1380   int c;
1381   int seen_dp;
1382   int is_inf;
1383
1384   seen_dp = 0;
1385
1386   c = next_char (dtp);
1387   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1388     c = '.';
1389   switch (c)
1390     {
1391     CASE_DIGITS:
1392       push_char (dtp, c);
1393       break;
1394
1395     case '.':
1396       push_char (dtp, c);
1397       seen_dp = 1;
1398       break;
1399
1400     case '+':
1401     case '-':
1402       goto got_sign;
1403
1404     CASE_SEPARATORS:
1405       unget_char (dtp, c);              /* Single null.  */
1406       eat_separator (dtp);
1407       return;
1408
1409     case 'i':
1410     case 'I':
1411     case 'n':
1412     case 'N':
1413       goto inf_nan;
1414
1415     default:
1416       goto bad_real;
1417     }
1418
1419   /* Get the digit string that might be a repeat count.  */
1420
1421   for (;;)
1422     {
1423       c = next_char (dtp);
1424       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1425         c = '.';
1426       switch (c)
1427         {
1428         CASE_DIGITS:
1429           push_char (dtp, c);
1430           break;
1431
1432         case '.':
1433           if (seen_dp)
1434             goto bad_real;
1435
1436           seen_dp = 1;
1437           push_char (dtp, c);
1438           goto real_loop;
1439
1440         case 'E':
1441         case 'e':
1442         case 'D':
1443         case 'd':
1444           goto exp1;
1445
1446         case '+':
1447         case '-':
1448           push_char (dtp, 'e');
1449           push_char (dtp, c);
1450           c = next_char (dtp);
1451           goto exp2;
1452
1453         case '*':
1454           push_char (dtp, '\0');
1455           goto got_repeat;
1456
1457         CASE_SEPARATORS:
1458           if (c != '\n' && c != ',' && c != '\r' && c != ';')
1459             unget_char (dtp, c);
1460           goto done;
1461
1462         default:
1463           goto bad_real;
1464         }
1465     }
1466
1467  got_repeat:
1468   if (convert_integer (dtp, -1, 0))
1469     return;
1470
1471   /* Now get the number itself.  */
1472
1473   if ((c = next_char (dtp)) == EOF)
1474     goto bad_real;
1475   if (is_separator (c))
1476     {                           /* Repeated null value.  */
1477       unget_char (dtp, c);
1478       eat_separator (dtp);
1479       return;
1480     }
1481
1482   if (c != '-' && c != '+')
1483     push_char (dtp, '+');
1484   else
1485     {
1486     got_sign:
1487       push_char (dtp, c);
1488       if ((c = next_char (dtp)) == EOF)
1489         goto bad_real;
1490     }
1491
1492   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1493     c = '.';
1494
1495   if (!isdigit (c) && c != '.')
1496     {
1497       if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1498         goto inf_nan;
1499       else
1500         goto bad_real;
1501     }
1502
1503   if (c == '.')
1504     {
1505       if (seen_dp)
1506         goto bad_real;
1507       else
1508         seen_dp = 1;
1509     }
1510
1511   push_char (dtp, c);
1512
1513  real_loop:
1514   for (;;)
1515     {
1516       c = next_char (dtp);
1517       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1518         c = '.';
1519       switch (c)
1520         {
1521         CASE_DIGITS:
1522           push_char (dtp, c);
1523           break;
1524
1525         CASE_SEPARATORS:
1526         case EOF:
1527           goto done;
1528
1529         case '.':
1530           if (seen_dp)
1531             goto bad_real;
1532
1533           seen_dp = 1;
1534           push_char (dtp, c);
1535           break;
1536
1537         case 'E':
1538         case 'e':
1539         case 'D':
1540         case 'd':
1541           goto exp1;
1542
1543         case '+':
1544         case '-':
1545           push_char (dtp, 'e');
1546           push_char (dtp, c);
1547           c = next_char (dtp);
1548           goto exp2;
1549
1550         default:
1551           goto bad_real;
1552         }
1553     }
1554
1555  exp1:
1556   push_char (dtp, 'e');
1557
1558   if ((c = next_char (dtp)) == EOF)
1559     goto bad_real;
1560   if (c != '+' && c != '-')
1561     push_char (dtp, '+');
1562   else
1563     {
1564       push_char (dtp, c);
1565       c = next_char (dtp);
1566     }
1567
1568  exp2:
1569   if (!isdigit (c))
1570     goto bad_real;
1571   push_char (dtp, c);
1572
1573   for (;;)
1574     {
1575       c = next_char (dtp);
1576
1577       switch (c)
1578         {
1579         CASE_DIGITS:
1580           push_char (dtp, c);
1581           break;
1582
1583         CASE_SEPARATORS:
1584           goto done;
1585
1586         default:
1587           goto bad_real;
1588         }
1589     }
1590
1591  done:
1592   unget_char (dtp, c);
1593   eat_separator (dtp);
1594   push_char (dtp, '\0');
1595   if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
1596     return;
1597
1598   free_saved (dtp);
1599   dtp->u.p.saved_type = BT_REAL;
1600   return;
1601
1602  inf_nan:
1603   l_push_char (dtp, c);
1604   is_inf = 0;
1605
1606   /* Match INF and Infinity.  */
1607   if (c == 'i' || c == 'I')
1608     {
1609       c = next_char (dtp);
1610       l_push_char (dtp, c);
1611       if (c != 'n' && c != 'N')
1612         goto unwind;
1613       c = next_char (dtp);
1614       l_push_char (dtp, c);
1615       if (c != 'f' && c != 'F')
1616         goto unwind;
1617       c = next_char (dtp);
1618       l_push_char (dtp, c);
1619       if (!is_separator (c))
1620         {
1621           if (c != 'i' && c != 'I')
1622             goto unwind;
1623           c = next_char (dtp);
1624           l_push_char (dtp, c);
1625           if (c != 'n' && c != 'N')
1626             goto unwind;
1627           c = next_char (dtp);
1628           l_push_char (dtp, c);
1629           if (c != 'i' && c != 'I')
1630             goto unwind;
1631           c = next_char (dtp);
1632           l_push_char (dtp, c);
1633           if (c != 't' && c != 'T')
1634             goto unwind;
1635           c = next_char (dtp);
1636           l_push_char (dtp, c);
1637           if (c != 'y' && c != 'Y')
1638             goto unwind;
1639           c = next_char (dtp);
1640           l_push_char (dtp, c);
1641         }
1642         is_inf = 1;
1643     } /* Match NaN.  */
1644   else
1645     {
1646       c = next_char (dtp);
1647       l_push_char (dtp, c);
1648       if (c != 'a' && c != 'A')
1649         goto unwind;
1650       c = next_char (dtp);
1651       l_push_char (dtp, c);
1652       if (c != 'n' && c != 'N')
1653         goto unwind;
1654       c = next_char (dtp);
1655       l_push_char (dtp, c);
1656
1657       /* Match NAN(alphanum).  */
1658       if (c == '(')
1659         {
1660           for (c = next_char (dtp); c != ')'; c = next_char (dtp))
1661             if (is_separator (c))
1662               goto unwind;
1663             else
1664               l_push_char (dtp, c);
1665
1666           l_push_char (dtp, ')');
1667           c = next_char (dtp);
1668           l_push_char (dtp, c);
1669         }
1670     }
1671
1672   if (!is_separator (c))
1673     goto unwind;
1674
1675   if (dtp->u.p.namelist_mode)
1676     {   
1677       if (c == ' ' || c =='\n' || c == '\r')
1678         {
1679           do
1680             {
1681               if ((c = next_char (dtp)) == EOF)
1682                 goto bad_real;
1683             }
1684           while (c == ' ' || c =='\n' || c == '\r');
1685
1686           l_push_char (dtp, c);
1687
1688           if (c == '=')
1689             goto unwind;
1690         }
1691     }
1692
1693   if (is_inf)
1694     {
1695       push_char (dtp, 'i');
1696       push_char (dtp, 'n');
1697       push_char (dtp, 'f');
1698     }
1699   else
1700     {
1701       push_char (dtp, 'n');
1702       push_char (dtp, 'a');
1703       push_char (dtp, 'n');
1704     }
1705
1706   free_line (dtp);
1707   goto done;
1708
1709  unwind:
1710   if (dtp->u.p.namelist_mode)
1711     {
1712       dtp->u.p.nml_read_error = 1;
1713       dtp->u.p.line_buffer_enabled = 1;
1714       dtp->u.p.item_count = 0;
1715       return;
1716     }
1717
1718  bad_real:
1719
1720   if (nml_bad_return (dtp, c))
1721     return;
1722
1723   free_saved (dtp);
1724   if (c == EOF)
1725     {
1726       hit_eof (dtp);
1727       return;
1728     }
1729   else
1730     eat_line (dtp);
1731   sprintf (message, "Bad real number in item %d of list input",
1732               dtp->u.p.item_count);
1733   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1734 }
1735
1736
1737 /* Check the current type against the saved type to make sure they are
1738    compatible.  Returns nonzero if incompatible.  */
1739
1740 static int
1741 check_type (st_parameter_dt *dtp, bt type, int len)
1742 {
1743   char message[100];
1744
1745   if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
1746     {
1747       sprintf (message, "Read type %s where %s was expected for item %d",
1748                   type_name (dtp->u.p.saved_type), type_name (type),
1749                   dtp->u.p.item_count);
1750
1751       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1752       return 1;
1753     }
1754
1755   if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
1756     return 0;
1757
1758   if (dtp->u.p.saved_length != len)
1759     {
1760       sprintf (message,
1761                   "Read kind %d %s where kind %d is required for item %d",
1762                   dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1763                   dtp->u.p.item_count);
1764       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1765       return 1;
1766     }
1767
1768   return 0;
1769 }
1770
1771
1772 /* Top level data transfer subroutine for list reads.  Because we have
1773    to deal with repeat counts, the data item is always saved after
1774    reading, usually in the dtp->u.p.value[] array.  If a repeat count is
1775    greater than one, we copy the data item multiple times.  */
1776
1777 static int
1778 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
1779                             int kind, size_t size)
1780 {
1781   gfc_char4_t *q;
1782   int c, i, m;
1783   int err = 0;
1784
1785   dtp->u.p.namelist_mode = 0;
1786
1787   if (dtp->u.p.first_item)
1788     {
1789       dtp->u.p.first_item = 0;
1790       dtp->u.p.input_complete = 0;
1791       dtp->u.p.repeat_count = 1;
1792       dtp->u.p.at_eol = 0;
1793       
1794       if ((c = eat_spaces (dtp)) == EOF)
1795         {
1796           err = LIBERROR_END;
1797           goto cleanup;
1798         }
1799       if (is_separator (c))
1800         {
1801           /* Found a null value.  */
1802           eat_separator (dtp);
1803           dtp->u.p.repeat_count = 0;
1804
1805           /* eat_separator sets this flag if the separator was a comma.  */
1806           if (dtp->u.p.comma_flag)
1807             goto cleanup;
1808
1809           /* eat_separator sets this flag if the separator was a \n or \r.  */
1810           if (dtp->u.p.at_eol)
1811             finish_separator (dtp);
1812           else
1813             goto cleanup;
1814         }
1815
1816     }
1817   else
1818     {
1819       if (dtp->u.p.repeat_count > 0)
1820         {
1821           if (check_type (dtp, type, kind))
1822             return err;
1823           goto set_value;
1824         }
1825         
1826       if (dtp->u.p.input_complete)
1827         goto cleanup;
1828
1829       if (dtp->u.p.at_eol)
1830         finish_separator (dtp);
1831       else
1832         {
1833           eat_spaces (dtp);
1834           /* Trailing spaces prior to end of line.  */
1835           if (dtp->u.p.at_eol)
1836             finish_separator (dtp);
1837         }
1838
1839       dtp->u.p.saved_type = BT_UNKNOWN;
1840       dtp->u.p.repeat_count = 1;
1841     }
1842
1843   switch (type)
1844     {
1845     case BT_INTEGER:
1846       read_integer (dtp, kind);
1847       break;
1848     case BT_LOGICAL:
1849       read_logical (dtp, kind);
1850       break;
1851     case BT_CHARACTER:
1852       read_character (dtp, kind);
1853       break;
1854     case BT_REAL:
1855       read_real (dtp, p, kind);
1856       /* Copy value back to temporary if needed.  */
1857       if (dtp->u.p.repeat_count > 0)
1858         memcpy (dtp->u.p.value, p, kind);
1859       break;
1860     case BT_COMPLEX:
1861       read_complex (dtp, p, kind, size);
1862       /* Copy value back to temporary if needed.  */
1863       if (dtp->u.p.repeat_count > 0)
1864         memcpy (dtp->u.p.value, p, size);
1865       break;
1866     default:
1867       internal_error (&dtp->common, "Bad type for list read");
1868     }
1869
1870   if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN)
1871     dtp->u.p.saved_length = size;
1872
1873   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1874     goto cleanup;
1875
1876  set_value:
1877   switch (dtp->u.p.saved_type)
1878     {
1879     case BT_COMPLEX:
1880     case BT_REAL:
1881       if (dtp->u.p.repeat_count > 0)
1882         memcpy (p, dtp->u.p.value, size);
1883       break;
1884
1885     case BT_INTEGER:
1886     case BT_LOGICAL:
1887       memcpy (p, dtp->u.p.value, size);
1888       break;
1889
1890     case BT_CHARACTER:
1891       if (dtp->u.p.saved_string)
1892         {
1893           m = ((int) size < dtp->u.p.saved_used)
1894               ? (int) size : dtp->u.p.saved_used;
1895           if (kind == 1)
1896             memcpy (p, dtp->u.p.saved_string, m);
1897           else
1898             {
1899               q = (gfc_char4_t *) p;
1900               for (i = 0; i < m; i++)
1901                 q[i] = (unsigned char) dtp->u.p.saved_string[i];
1902             }
1903         }
1904       else
1905         /* Just delimiters encountered, nothing to copy but SPACE.  */
1906         m = 0;
1907
1908       if (m < (int) size)
1909         {
1910           if (kind == 1)
1911             memset (((char *) p) + m, ' ', size - m);
1912           else
1913             {
1914               q = (gfc_char4_t *) p;
1915               for (i = m; i < (int) size; i++)
1916                 q[i] = (unsigned char) ' ';
1917             }
1918         }
1919       break;
1920
1921     case BT_UNKNOWN:
1922       break;
1923
1924     default:
1925       internal_error (&dtp->common, "Bad type for list read");
1926     }
1927
1928   if (--dtp->u.p.repeat_count <= 0)
1929     free_saved (dtp);
1930
1931 cleanup:
1932   if (err == LIBERROR_END)
1933     hit_eof (dtp);
1934   return err;
1935 }
1936
1937
1938 void
1939 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1940                      size_t size, size_t nelems)
1941 {
1942   size_t elem;
1943   char *tmp;
1944   size_t stride = type == BT_CHARACTER ?
1945                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1946   int err;
1947
1948   tmp = (char *) p;
1949
1950   /* Big loop over all the elements.  */
1951   for (elem = 0; elem < nelems; elem++)
1952     {
1953       dtp->u.p.item_count++;
1954       err = list_formatted_read_scalar (dtp, type, tmp + stride*elem, 
1955                                         kind, size);
1956       if (err)
1957         break;
1958     }
1959 }
1960
1961
1962 /* Finish a list read.  */
1963
1964 void
1965 finish_list_read (st_parameter_dt *dtp)
1966 {
1967   int err;
1968
1969   free_saved (dtp);
1970
1971   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
1972
1973   if (dtp->u.p.at_eol)
1974     {
1975       dtp->u.p.at_eol = 0;
1976       return;
1977     }
1978
1979   err = eat_line (dtp);
1980   if (err == LIBERROR_END)
1981     hit_eof (dtp);
1982 }
1983
1984 /*                      NAMELIST INPUT
1985
1986 void namelist_read (st_parameter_dt *dtp)
1987 calls:
1988    static void nml_match_name (char *name, int len)
1989    static int nml_query (st_parameter_dt *dtp)
1990    static int nml_get_obj_data (st_parameter_dt *dtp,
1991                                 namelist_info **prev_nl, char *, size_t)
1992 calls:
1993       static void nml_untouch_nodes (st_parameter_dt *dtp)
1994       static namelist_info * find_nml_node (st_parameter_dt *dtp,
1995                                             char * var_name)
1996       static int nml_parse_qualifier(descriptor_dimension * ad,
1997                                      array_loop_spec * ls, int rank, char *)
1998       static void nml_touch_nodes (namelist_info * nl)
1999       static int nml_read_obj (namelist_info *nl, index_type offset,
2000                                namelist_info **prev_nl, char *, size_t,
2001                                index_type clow, index_type chigh)
2002 calls:
2003       -itself-  */
2004
2005 /* Inputs a rank-dimensional qualifier, which can contain
2006    singlets, doublets, triplets or ':' with the standard meanings.  */
2007
2008 static try
2009 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
2010                      array_loop_spec *ls, int rank, char *parse_err_msg,
2011                      int *parsed_rank)
2012 {
2013   int dim;
2014   int indx;
2015   int neg;
2016   int null_flag;
2017   int is_array_section, is_char;
2018   int c;
2019
2020   is_char = 0;
2021   is_array_section = 0;
2022   dtp->u.p.expanded_read = 0;
2023
2024   /* See if this is a character substring qualifier we are looking for.  */
2025   if (rank == -1)
2026     {
2027       rank = 1;
2028       is_char = 1;
2029     }
2030
2031   /* The next character in the stream should be the '('.  */
2032
2033   if ((c = next_char (dtp)) == EOF)
2034     return FAILURE;
2035
2036   /* Process the qualifier, by dimension and triplet.  */
2037
2038   for (dim=0; dim < rank; dim++ )
2039     {
2040       for (indx=0; indx<3; indx++)
2041         {
2042           free_saved (dtp);
2043           eat_spaces (dtp);
2044           neg = 0;
2045
2046           /* Process a potential sign.  */
2047           if ((c = next_char (dtp)) == EOF)
2048             return FAILURE;
2049           switch (c)
2050             {
2051             case '-':
2052               neg = 1;
2053               break;
2054
2055             case '+':
2056               break;
2057
2058             default:
2059               unget_char (dtp, c);
2060               break;
2061             }
2062
2063           /* Process characters up to the next ':' , ',' or ')'.  */
2064           for (;;)
2065             {
2066               if ((c = next_char (dtp)) == EOF)
2067                 return FAILURE;
2068
2069               switch (c)
2070                 {
2071                 case ':':
2072                   is_array_section = 1;
2073                   break;
2074
2075                 case ',': case ')':
2076                   if ((c==',' && dim == rank -1)
2077                       || (c==')' && dim < rank -1))
2078                     {
2079                       if (is_char)
2080                         sprintf (parse_err_msg, "Bad substring qualifier");
2081                       else
2082                         sprintf (parse_err_msg, "Bad number of index fields");
2083                       goto err_ret;
2084                     }
2085                   break;
2086
2087                 CASE_DIGITS:
2088                   push_char (dtp, c);
2089                   continue;
2090
2091                 case ' ': case '\t':
2092                   eat_spaces (dtp);
2093                   if ((c = next_char (dtp) == EOF))
2094                     return FAILURE;
2095                   break;
2096
2097                 default:
2098                   if (is_char)
2099                     sprintf (parse_err_msg,
2100                              "Bad character in substring qualifier");
2101                   else
2102                     sprintf (parse_err_msg, "Bad character in index");
2103                   goto err_ret;
2104                 }
2105
2106               if ((c == ',' || c == ')') && indx == 0
2107                   && dtp->u.p.saved_string == 0)
2108                 {
2109                   if (is_char)
2110                     sprintf (parse_err_msg, "Null substring qualifier");
2111                   else
2112                     sprintf (parse_err_msg, "Null index field");
2113                   goto err_ret;
2114                 }
2115
2116               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2117                   || (indx == 2 && dtp->u.p.saved_string == 0))
2118                 {
2119                   if (is_char)
2120                     sprintf (parse_err_msg, "Bad substring qualifier");
2121                   else
2122                     sprintf (parse_err_msg, "Bad index triplet");
2123                   goto err_ret;
2124                 }
2125
2126               if (is_char && !is_array_section)
2127                 {
2128                   sprintf (parse_err_msg,
2129                            "Missing colon in substring qualifier");
2130                   goto err_ret;
2131                 }
2132
2133               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
2134               null_flag = 0;
2135               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2136                   || (indx==1 && dtp->u.p.saved_string == 0))
2137                 {
2138                   null_flag = 1;
2139                   break;
2140                 }
2141
2142               /* Now read the index.  */
2143               if (convert_integer (dtp, sizeof(ssize_t), neg))
2144                 {
2145                   if (is_char)
2146                     sprintf (parse_err_msg, "Bad integer substring qualifier");
2147                   else
2148                     sprintf (parse_err_msg, "Bad integer in index");
2149                   goto err_ret;
2150                 }
2151               break;
2152             }
2153
2154           /* Feed the index values to the triplet arrays.  */
2155           if (!null_flag)
2156             {
2157               if (indx == 0)
2158                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2159               if (indx == 1)
2160                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2161               if (indx == 2)
2162                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2163             }
2164
2165           /* Singlet or doublet indices.  */
2166           if (c==',' || c==')')
2167             {
2168               if (indx == 0)
2169                 {
2170                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2171
2172                   /*  If -std=f95/2003 or an array section is specified,
2173                       do not allow excess data to be processed.  */
2174                   if (is_array_section == 1
2175                       || !(compile_options.allow_std & GFC_STD_GNU)
2176                       || !dtp->u.p.ionml->touched
2177                       || dtp->u.p.ionml->type == BT_DERIVED)
2178                     ls[dim].end = ls[dim].start;
2179                   else
2180                     dtp->u.p.expanded_read = 1;
2181                 }
2182
2183               /* Check for non-zero rank.  */
2184               if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2185                 *parsed_rank = 1;
2186
2187               break;
2188             }
2189         }
2190
2191       if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2192         {
2193           int i;
2194           dtp->u.p.expanded_read = 0;
2195           for (i = 0; i < dim; i++)
2196             ls[i].end = ls[i].start;
2197         }
2198
2199       /* Check the values of the triplet indices.  */
2200       if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2201            || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))
2202            || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2203            || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])))
2204         {
2205           if (is_char)
2206             sprintf (parse_err_msg, "Substring out of range");
2207           else
2208             sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2209           goto err_ret;
2210         }
2211
2212       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2213           || (ls[dim].step == 0))
2214         {
2215           sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2216           goto err_ret;
2217         }
2218
2219       /* Initialise the loop index counter.  */
2220       ls[dim].idx = ls[dim].start;
2221     }
2222   eat_spaces (dtp);
2223   return SUCCESS;
2224
2225 err_ret:
2226
2227   return FAILURE;
2228 }
2229
2230 static namelist_info *
2231 find_nml_node (st_parameter_dt *dtp, char * var_name)
2232 {
2233   namelist_info * t = dtp->u.p.ionml;
2234   while (t != NULL)
2235     {
2236       if (strcmp (var_name, t->var_name) == 0)
2237         {
2238           t->touched = 1;
2239           return t;
2240         }
2241       t = t->next;
2242     }
2243   return NULL;
2244 }
2245
2246 /* Visits all the components of a derived type that have
2247    not explicitly been identified in the namelist input.
2248    touched is set and the loop specification initialised
2249    to default values  */
2250
2251 static void
2252 nml_touch_nodes (namelist_info * nl)
2253 {
2254   index_type len = strlen (nl->var_name) + 1;
2255   int dim;
2256   char * ext_name = (char*)get_mem (len + 1);
2257   memcpy (ext_name, nl->var_name, len-1);
2258   memcpy (ext_name + len - 1, "%", 2);
2259   for (nl = nl->next; nl; nl = nl->next)
2260     {
2261       if (strncmp (nl->var_name, ext_name, len) == 0)
2262         {
2263           nl->touched = 1;
2264           for (dim=0; dim < nl->var_rank; dim++)
2265             {
2266               nl->ls[dim].step = 1;
2267               nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2268               nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2269               nl->ls[dim].idx = nl->ls[dim].start;
2270             }
2271         }
2272       else
2273         break;
2274     }
2275   free (ext_name);
2276   return;
2277 }
2278
2279 /* Resets touched for the entire list of nml_nodes, ready for a
2280    new object.  */
2281
2282 static void
2283 nml_untouch_nodes (st_parameter_dt *dtp)
2284 {
2285   namelist_info * t;
2286   for (t = dtp->u.p.ionml; t; t = t->next)
2287     t->touched = 0;
2288   return;
2289 }
2290
2291 /* Attempts to input name to namelist name.  Returns
2292    dtp->u.p.nml_read_error = 1 on no match.  */
2293
2294 static void
2295 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2296 {
2297   index_type i;
2298   int c;
2299
2300   dtp->u.p.nml_read_error = 0;
2301   for (i = 0; i < len; i++)
2302     {
2303       c = next_char (dtp);
2304       if (c == EOF || (tolower (c) != tolower (name[i])))
2305         {
2306           dtp->u.p.nml_read_error = 1;
2307           break;
2308         }
2309     }
2310 }
2311
2312 /* If the namelist read is from stdin, output the current state of the
2313    namelist to stdout.  This is used to implement the non-standard query
2314    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2315    the names alone are printed.  */
2316
2317 static void
2318 nml_query (st_parameter_dt *dtp, char c)
2319 {
2320   gfc_unit * temp_unit;
2321   namelist_info * nl;
2322   index_type len;
2323   char * p;
2324 #ifdef HAVE_CRLF
2325   static const index_type endlen = 3;
2326   static const char endl[] = "\r\n";
2327   static const char nmlend[] = "&end\r\n";
2328 #else
2329   static const index_type endlen = 2;
2330   static const char endl[] = "\n";
2331   static const char nmlend[] = "&end\n";
2332 #endif
2333
2334   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2335     return;
2336
2337   /* Store the current unit and transfer to stdout.  */
2338
2339   temp_unit = dtp->u.p.current_unit;
2340   dtp->u.p.current_unit = find_unit (options.stdout_unit);
2341
2342   if (dtp->u.p.current_unit)
2343     {
2344       dtp->u.p.mode = WRITING;
2345       next_record (dtp, 0);
2346
2347       /* Write the namelist in its entirety.  */
2348
2349       if (c == '=')
2350         namelist_write (dtp);
2351
2352       /* Or write the list of names.  */
2353
2354       else
2355         {
2356           /* "&namelist_name\n"  */
2357
2358           len = dtp->namelist_name_len;
2359           p = write_block (dtp, len + endlen);
2360           if (!p)
2361             goto query_return;
2362           memcpy (p, "&", 1);
2363           memcpy ((char*)(p + 1), dtp->namelist_name, len);
2364           memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2365           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2366             {
2367               /* " var_name\n"  */
2368
2369               len = strlen (nl->var_name);
2370               p = write_block (dtp, len + endlen);
2371               if (!p)
2372                 goto query_return;
2373               memcpy (p, " ", 1);
2374               memcpy ((char*)(p + 1), nl->var_name, len);
2375               memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2376             }
2377
2378           /* "&end\n"  */
2379
2380           p = write_block (dtp, endlen + 3);
2381             goto query_return;
2382           memcpy (p, &nmlend, endlen + 3);
2383         }
2384
2385       /* Flush the stream to force immediate output.  */
2386
2387       fbuf_flush (dtp->u.p.current_unit, WRITING);
2388       sflush (dtp->u.p.current_unit->s);
2389       unlock_unit (dtp->u.p.current_unit);
2390     }
2391
2392 query_return:
2393
2394   /* Restore the current unit.  */
2395
2396   dtp->u.p.current_unit = temp_unit;
2397   dtp->u.p.mode = READING;
2398   return;
2399 }
2400
2401 /* Reads and stores the input for the namelist object nl.  For an array,
2402    the function loops over the ranges defined by the loop specification.
2403    This default to all the data or to the specification from a qualifier.
2404    nml_read_obj recursively calls itself to read derived types. It visits
2405    all its own components but only reads data for those that were touched
2406    when the name was parsed.  If a read error is encountered, an attempt is
2407    made to return to read a new object name because the standard allows too
2408    little data to be available.  On the other hand, too much data is an
2409    error.  */
2410
2411 static try
2412 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2413               namelist_info **pprev_nl, char *nml_err_msg,
2414               size_t nml_err_msg_size, index_type clow, index_type chigh)
2415 {
2416   namelist_info * cmp;
2417   char * obj_name;
2418   int nml_carry;
2419   int len;
2420   int dim;
2421   index_type dlen;
2422   index_type m;
2423   size_t obj_name_len;
2424   void * pdata;
2425
2426   /* This object not touched in name parsing.  */
2427
2428   if (!nl->touched)
2429     return SUCCESS;
2430
2431   dtp->u.p.repeat_count = 0;
2432   eat_spaces (dtp);
2433
2434   len = nl->len;
2435   switch (nl->type)
2436   {
2437     case BT_INTEGER:
2438     case BT_LOGICAL:
2439       dlen = len;
2440       break;
2441
2442     case BT_REAL:
2443       dlen = size_from_real_kind (len);
2444       break;
2445
2446     case BT_COMPLEX:
2447       dlen = size_from_complex_kind (len);
2448       break;
2449
2450     case BT_CHARACTER:
2451       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2452       break;
2453
2454     default:
2455       dlen = 0;
2456     }
2457
2458   do
2459     {
2460       /* Update the pointer to the data, using the current index vector  */
2461
2462       pdata = (void*)(nl->mem_pos + offset);
2463       for (dim = 0; dim < nl->var_rank; dim++)
2464         pdata = (void*)(pdata + (nl->ls[dim].idx
2465                                  - GFC_DESCRIPTOR_LBOUND(nl,dim))
2466                         * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2467
2468       /* Reset the error flag and try to read next value, if
2469          dtp->u.p.repeat_count=0  */
2470
2471       dtp->u.p.nml_read_error = 0;
2472       nml_carry = 0;
2473       if (--dtp->u.p.repeat_count <= 0)
2474         {
2475           if (dtp->u.p.input_complete)
2476             return SUCCESS;
2477           if (dtp->u.p.at_eol)
2478             finish_separator (dtp);
2479           if (dtp->u.p.input_complete)
2480             return SUCCESS;
2481
2482           dtp->u.p.saved_type = BT_UNKNOWN;
2483           free_saved (dtp);
2484
2485           switch (nl->type)
2486           {
2487           case BT_INTEGER:
2488               read_integer (dtp, len);
2489               break;
2490
2491           case BT_LOGICAL:
2492               read_logical (dtp, len);
2493               break;
2494
2495           case BT_CHARACTER:
2496               read_character (dtp, len);
2497               break;
2498
2499           case BT_REAL:
2500             /* Need to copy data back from the real location to the temp in order
2501                to handle nml reads into arrays.  */
2502             read_real (dtp, pdata, len);
2503             memcpy (dtp->u.p.value, pdata, dlen);
2504             break;
2505
2506           case BT_COMPLEX:
2507             /* Same as for REAL, copy back to temp.  */
2508             read_complex (dtp, pdata, len, dlen);
2509             memcpy (dtp->u.p.value, pdata, dlen);
2510             break;
2511
2512           case BT_DERIVED:
2513             obj_name_len = strlen (nl->var_name) + 1;
2514             obj_name = get_mem (obj_name_len+1);
2515             memcpy (obj_name, nl->var_name, obj_name_len-1);
2516             memcpy (obj_name + obj_name_len - 1, "%", 2);
2517
2518             /* If reading a derived type, disable the expanded read warning
2519                since a single object can have multiple reads.  */
2520             dtp->u.p.expanded_read = 0;
2521
2522             /* Now loop over the components. Update the component pointer
2523                with the return value from nml_write_obj.  This loop jumps
2524                past nested derived types by testing if the potential
2525                component name contains '%'.  */
2526
2527             for (cmp = nl->next;
2528                  cmp &&
2529                    !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2530                    !strchr (cmp->var_name + obj_name_len, '%');
2531                  cmp = cmp->next)
2532               {
2533
2534                 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2535                                   pprev_nl, nml_err_msg, nml_err_msg_size,
2536                                   clow, chigh) == FAILURE)
2537                   {
2538                     free (obj_name);
2539                     return FAILURE;
2540                   }
2541
2542                 if (dtp->u.p.input_complete)
2543                   {
2544                     free (obj_name);
2545                     return SUCCESS;
2546                   }
2547               }
2548
2549             free (obj_name);
2550             goto incr_idx;
2551
2552           default:
2553             snprintf (nml_err_msg, nml_err_msg_size,
2554                       "Bad type for namelist object %s", nl->var_name);
2555             internal_error (&dtp->common, nml_err_msg);
2556             goto nml_err_ret;
2557           }
2558         }
2559
2560       /* The standard permits array data to stop short of the number of
2561          elements specified in the loop specification.  In this case, we
2562          should be here with dtp->u.p.nml_read_error != 0.  Control returns to
2563          nml_get_obj_data and an attempt is made to read object name.  */
2564
2565       *pprev_nl = nl;
2566       if (dtp->u.p.nml_read_error)
2567         {
2568           dtp->u.p.expanded_read = 0;
2569           return SUCCESS;
2570         }
2571
2572       if (dtp->u.p.saved_type == BT_UNKNOWN)
2573         {
2574           dtp->u.p.expanded_read = 0;
2575           goto incr_idx;
2576         }
2577
2578       switch (dtp->u.p.saved_type)
2579       {
2580
2581         case BT_COMPLEX:
2582         case BT_REAL:
2583         case BT_INTEGER:
2584         case BT_LOGICAL:
2585           memcpy (pdata, dtp->u.p.value, dlen);
2586           break;
2587
2588         case BT_CHARACTER:
2589           if (dlen < dtp->u.p.saved_used)
2590             {
2591               if (compile_options.bounds_check)
2592                 {
2593                   snprintf (nml_err_msg, nml_err_msg_size,
2594                             "Namelist object '%s' truncated on read.",
2595                             nl->var_name);
2596                   generate_warning (&dtp->common, nml_err_msg);
2597                 }
2598               m = dlen;
2599             }
2600           else
2601             m = dtp->u.p.saved_used;
2602           pdata = (void*)( pdata + clow - 1 );
2603           memcpy (pdata, dtp->u.p.saved_string, m);
2604           if (m < dlen)
2605             memset ((void*)( pdata + m ), ' ', dlen - m);
2606           break;
2607
2608         default:
2609           break;
2610       }
2611
2612       /* Warn if a non-standard expanded read occurs. A single read of a
2613          single object is acceptable.  If a second read occurs, issue a warning
2614          and set the flag to zero to prevent further warnings.  */
2615       if (dtp->u.p.expanded_read == 2)
2616         {
2617           notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2618           dtp->u.p.expanded_read = 0;
2619         }
2620
2621       /* If the expanded read warning flag is set, increment it,
2622          indicating that a single read has occurred.  */
2623       if (dtp->u.p.expanded_read >= 1)
2624         dtp->u.p.expanded_read++;
2625
2626       /* Break out of loop if scalar.  */
2627       if (!nl->var_rank)
2628         break;
2629
2630       /* Now increment the index vector.  */
2631
2632 incr_idx:
2633
2634       nml_carry = 1;
2635       for (dim = 0; dim < nl->var_rank; dim++)
2636         {
2637           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2638           nml_carry = 0;
2639           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2640               ||
2641               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2642             {
2643               nl->ls[dim].idx = nl->ls[dim].start;
2644               nml_carry = 1;
2645             }
2646         }
2647     } while (!nml_carry);
2648
2649   if (dtp->u.p.repeat_count > 1)
2650     {
2651       snprintf (nml_err_msg, nml_err_msg_size,
2652                 "Repeat count too large for namelist object %s", nl->var_name);
2653       goto nml_err_ret;
2654     }
2655   return SUCCESS;
2656
2657 nml_err_ret:
2658
2659   return FAILURE;
2660 }
2661
2662 /* Parses the object name, including array and substring qualifiers.  It
2663    iterates over derived type components, touching those components and
2664    setting their loop specifications, if there is a qualifier.  If the
2665    object is itself a derived type, its components and subcomponents are
2666    touched.  nml_read_obj is called at the end and this reads the data in
2667    the manner specified by the object name.  */
2668
2669 static try
2670 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2671                   char *nml_err_msg, size_t nml_err_msg_size)
2672 {
2673   int c;
2674   namelist_info * nl;
2675   namelist_info * first_nl = NULL;
2676   namelist_info * root_nl = NULL;
2677   int dim, parsed_rank;
2678   int component_flag, qualifier_flag;
2679   index_type clow, chigh;
2680   int non_zero_rank_count;
2681
2682   /* Look for end of input or object name.  If '?' or '=?' are encountered
2683      in stdin, print the node names or the namelist to stdout.  */
2684
2685   eat_separator (dtp);
2686   if (dtp->u.p.input_complete)
2687     return SUCCESS;
2688
2689   if (dtp->u.p.at_eol)
2690     finish_separator (dtp);
2691   if (dtp->u.p.input_complete)
2692     return SUCCESS;
2693
2694   if ((c = next_char (dtp)) == EOF)
2695     return FAILURE;
2696   switch (c)
2697     {
2698     case '=':
2699       if ((c = next_char (dtp)) == EOF)
2700         return FAILURE;
2701       if (c != '?')
2702         {
2703           sprintf (nml_err_msg, "namelist read: misplaced = sign");
2704           goto nml_err_ret;
2705         }
2706       nml_query (dtp, '=');
2707       return SUCCESS;
2708
2709     case '?':
2710       nml_query (dtp, '?');
2711       return SUCCESS;
2712
2713     case '$':
2714     case '&':
2715       nml_match_name (dtp, "end", 3);
2716       if (dtp->u.p.nml_read_error)
2717         {
2718           sprintf (nml_err_msg, "namelist not terminated with / or &end");
2719           goto nml_err_ret;
2720         }
2721     case '/':
2722       dtp->u.p.input_complete = 1;
2723       return SUCCESS;
2724
2725     default :
2726       break;
2727     }
2728
2729   /* Untouch all nodes of the namelist and reset the flags that are set for
2730      derived type components.  */
2731
2732   nml_untouch_nodes (dtp);
2733   component_flag = 0;
2734   qualifier_flag = 0;
2735   non_zero_rank_count = 0;
2736
2737   /* Get the object name - should '!' and '\n' be permitted separators?  */
2738
2739 get_name:
2740
2741   free_saved (dtp);
2742
2743   do
2744     {
2745       if (!is_separator (c))
2746         push_char (dtp, tolower(c));
2747       if ((c = next_char (dtp)) == EOF)
2748         return FAILURE;
2749     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2750
2751   unget_char (dtp, c);
2752
2753   /* Check that the name is in the namelist and get pointer to object.
2754      Three error conditions exist: (i) An attempt is being made to
2755      identify a non-existent object, following a failed data read or
2756      (ii) The object name does not exist or (iii) Too many data items
2757      are present for an object.  (iii) gives the same error message
2758      as (i)  */
2759
2760   push_char (dtp, '\0');
2761
2762   if (component_flag)
2763     {
2764       size_t var_len = strlen (root_nl->var_name);
2765       size_t saved_len
2766         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2767       char ext_name[var_len + saved_len + 1];
2768
2769       memcpy (ext_name, root_nl->var_name, var_len);
2770       if (dtp->u.p.saved_string)
2771         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2772       ext_name[var_len + saved_len] = '\0';
2773       nl = find_nml_node (dtp, ext_name);
2774     }
2775   else
2776     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2777
2778   if (nl == NULL)
2779     {
2780       if (dtp->u.p.nml_read_error && *pprev_nl)
2781         snprintf (nml_err_msg, nml_err_msg_size,
2782                   "Bad data for namelist object %s", (*pprev_nl)->var_name);
2783
2784       else
2785         snprintf (nml_err_msg, nml_err_msg_size,
2786                   "Cannot match namelist object name %s",
2787                   dtp->u.p.saved_string);
2788
2789       goto nml_err_ret;
2790     }
2791
2792   /* Get the length, data length, base pointer and rank of the variable.
2793      Set the default loop specification first.  */
2794
2795   for (dim=0; dim < nl->var_rank; dim++)
2796     {
2797       nl->ls[dim].step = 1;
2798       nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2799       nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2800       nl->ls[dim].idx = nl->ls[dim].start;
2801     }
2802
2803 /* Check to see if there is a qualifier: if so, parse it.*/
2804
2805   if (c == '(' && nl->var_rank)
2806     {
2807       parsed_rank = 0;
2808       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2809                                nml_err_msg, &parsed_rank) == FAILURE)
2810         {
2811           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2812           snprintf (nml_err_msg_end,
2813                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2814                     " for namelist variable %s", nl->var_name);
2815           goto nml_err_ret;
2816         }
2817       if (parsed_rank > 0)
2818         non_zero_rank_count++;
2819
2820       qualifier_flag = 1;
2821
2822       if ((c = next_char (dtp)) == EOF)
2823         return FAILURE;
2824       unget_char (dtp, c);
2825     }
2826   else if (nl->var_rank > 0)
2827     non_zero_rank_count++;
2828
2829   /* Now parse a derived type component. The root namelist_info address
2830      is backed up, as is the previous component level.  The  component flag
2831      is set and the iteration is made by jumping back to get_name.  */
2832
2833   if (c == '%')
2834     {
2835       if (nl->type != BT_DERIVED)
2836         {
2837           snprintf (nml_err_msg, nml_err_msg_size,
2838                     "Attempt to get derived component for %s", nl->var_name);
2839           goto nml_err_ret;
2840         }
2841
2842       if (*pprev_nl == NULL || !component_flag)
2843         first_nl = nl;
2844
2845       root_nl = nl;
2846
2847       component_flag = 1;
2848       if ((c = next_char (dtp)) == EOF)
2849         return FAILURE;
2850       goto get_name;
2851     }
2852
2853   /* Parse a character qualifier, if present.  chigh = 0 is a default
2854      that signals that the string length = string_length.  */
2855
2856   clow = 1;
2857   chigh = 0;
2858
2859   if (c == '(' && nl->type == BT_CHARACTER)
2860     {
2861       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2862       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2863
2864       if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
2865           == FAILURE)
2866         {
2867           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2868           snprintf (nml_err_msg_end,
2869                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2870                     " for namelist variable %s", nl->var_name);
2871           goto nml_err_ret;
2872         }
2873
2874       clow = ind[0].start;
2875       chigh = ind[0].end;
2876
2877       if (ind[0].step != 1)
2878         {
2879           snprintf (nml_err_msg, nml_err_msg_size,
2880                     "Step not allowed in substring qualifier"
2881                     " for namelist object %s", nl->var_name);
2882           goto nml_err_ret;
2883         }
2884
2885       if ((c = next_char (dtp)) == EOF)
2886         return FAILURE;
2887       unget_char (dtp, c);
2888     }
2889
2890   /* Make sure no extraneous qualifiers are there.  */
2891
2892   if (c == '(')
2893     {
2894       snprintf (nml_err_msg, nml_err_msg_size,
2895                 "Qualifier for a scalar or non-character namelist object %s",
2896                 nl->var_name);
2897       goto nml_err_ret;
2898     }
2899
2900   /* Make sure there is no more than one non-zero rank object.  */
2901   if (non_zero_rank_count > 1)
2902     {
2903       snprintf (nml_err_msg, nml_err_msg_size,
2904                 "Multiple sub-objects with non-zero rank in namelist object %s",
2905                 nl->var_name);
2906       non_zero_rank_count = 0;
2907       goto nml_err_ret;
2908     }
2909
2910 /* According to the standard, an equal sign MUST follow an object name. The
2911    following is possibly lax - it allows comments, blank lines and so on to
2912    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2913
2914   free_saved (dtp);
2915
2916   eat_separator (dtp);
2917   if (dtp->u.p.input_complete)
2918     return SUCCESS;
2919
2920   if (dtp->u.p.at_eol)
2921     finish_separator (dtp);
2922   if (dtp->u.p.input_complete)
2923     return SUCCESS;
2924
2925   if ((c = next_char (dtp)) == EOF)
2926     return FAILURE;
2927
2928   if (c != '=')
2929     {
2930       snprintf (nml_err_msg, nml_err_msg_size,
2931                 "Equal sign must follow namelist object name %s",
2932                 nl->var_name);
2933       goto nml_err_ret;
2934     }
2935   /* If a derived type, touch its components and restore the root
2936      namelist_info if we have parsed a qualified derived type
2937      component.  */
2938
2939   if (nl->type == BT_DERIVED)
2940     nml_touch_nodes (nl);
2941
2942   if (first_nl)
2943     {
2944       if (first_nl->var_rank == 0)
2945         {
2946           if (component_flag && qualifier_flag)
2947             nl = first_nl;
2948         }
2949       else
2950         nl = first_nl;
2951     }
2952
2953   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
2954                     clow, chigh) == FAILURE)
2955     goto nml_err_ret;
2956
2957   return SUCCESS;
2958
2959 nml_err_ret:
2960
2961   return FAILURE;
2962 }
2963
2964 /* Entry point for namelist input.  Goes through input until namelist name
2965   is matched.  Then cycles through nml_get_obj_data until the input is
2966   completed or there is an error.  */
2967
2968 void
2969 namelist_read (st_parameter_dt *dtp)
2970 {
2971   int c;
2972   char nml_err_msg[200];
2973   /* Pointer to the previously read object, in case attempt is made to read
2974      new object name.  Should this fail, error message can give previous
2975      name.  */
2976   namelist_info *prev_nl = NULL;
2977
2978   dtp->u.p.namelist_mode = 1;
2979   dtp->u.p.input_complete = 0;
2980   dtp->u.p.expanded_read = 0;
2981
2982   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
2983      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2984      node names or namelist on stdout.  */
2985
2986 find_nml_name:
2987   c = next_char (dtp);
2988   switch (c)
2989     {
2990     case '$':
2991     case '&':
2992           break;
2993
2994     case '!':
2995       eat_line (dtp);
2996       goto find_nml_name;
2997
2998     case '=':
2999       c = next_char (dtp);
3000       if (c == '?')
3001         nml_query (dtp, '=');
3002       else
3003         unget_char (dtp, c);
3004       goto find_nml_name;
3005
3006     case '?':
3007       nml_query (dtp, '?');
3008
3009     case EOF:
3010       return;
3011
3012     default:
3013       goto find_nml_name;
3014     }
3015
3016   /* Match the name of the namelist.  */
3017
3018   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3019
3020   if (dtp->u.p.nml_read_error)
3021     goto find_nml_name;
3022
3023   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
3024   c = next_char (dtp);
3025   if (!is_separator(c) && c != '!')
3026     {
3027       unget_char (dtp, c);
3028       goto find_nml_name;
3029     }
3030
3031   unget_char (dtp, c);
3032   eat_separator (dtp);
3033
3034   /* Ready to read namelist objects.  If there is an error in input
3035      from stdin, output the error message and continue.  */
3036
3037   while (!dtp->u.p.input_complete)
3038     {
3039       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
3040                             == FAILURE)
3041         {
3042           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3043             goto nml_err_ret;
3044           generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3045         }
3046     }
3047
3048   free_saved (dtp);
3049   free_line (dtp);
3050   return;
3051
3052
3053 nml_err_ret:
3054
3055   /* All namelist error calls return from here */
3056   free_saved (dtp);
3057   free_line (dtp);
3058   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3059   return;
3060 }