OSDN Git Service

2011-02-27 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 if (c != '\n')
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 if (c != '\n')
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     
1108   if (c == '-' || c == '+')
1109     {
1110       push_char (dtp, c);
1111       if ((c = next_char (dtp)) == EOF)
1112         goto bad;
1113     }
1114
1115   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1116     c = '.';
1117   
1118   if (!isdigit (c) && c != '.')
1119     {
1120       if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1121         goto inf_nan;
1122       else
1123         goto bad;
1124     }
1125
1126   push_char (dtp, c);
1127
1128   seen_dp = (c == '.') ? 1 : 0;
1129
1130   for (;;)
1131     {
1132       if ((c = next_char (dtp)) == EOF)
1133         goto bad;
1134       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1135         c = '.';
1136       switch (c)
1137         {
1138         CASE_DIGITS:
1139           push_char (dtp, c);
1140           break;
1141
1142         case '.':
1143           if (seen_dp)
1144             goto bad;
1145
1146           seen_dp = 1;
1147           push_char (dtp, c);
1148           break;
1149
1150         case 'e':
1151         case 'E':
1152         case 'd':
1153         case 'D':
1154           push_char (dtp, 'e');
1155           goto exp1;
1156
1157         case '-':
1158         case '+':
1159           push_char (dtp, 'e');
1160           push_char (dtp, c);
1161           if ((c = next_char (dtp)) == EOF)
1162             goto bad;
1163           goto exp2;
1164
1165         CASE_SEPARATORS:
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 if (c != '\n')
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 eol_1:
1314   eat_spaces (dtp);
1315   c = next_char (dtp);
1316   if (c == '\n' || c== '\r')
1317     goto eol_1;
1318   else
1319     unget_char (dtp, c);
1320
1321   if (parse_real (dtp, dest, kind))
1322     return;
1323
1324 eol_2:
1325   eat_spaces (dtp);
1326   c = next_char (dtp);
1327   if (c == '\n' || c== '\r')
1328     goto eol_2;
1329   else
1330     unget_char (dtp, c);
1331
1332   if (next_char (dtp)
1333       !=  (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
1334     goto bad_complex;
1335
1336 eol_3:
1337   eat_spaces (dtp);
1338   c = next_char (dtp);
1339   if (c == '\n' || c== '\r')
1340     goto eol_3;
1341   else
1342     unget_char (dtp, c);
1343
1344   if (parse_real (dtp, dest + size / 2, kind))
1345     return;
1346     
1347 eol_4:
1348   eat_spaces (dtp);
1349   c = next_char (dtp);
1350   if (c == '\n' || c== '\r')
1351     goto eol_4;
1352   else
1353     unget_char (dtp, c);
1354
1355   if (next_char (dtp) != ')')
1356     goto bad_complex;
1357
1358   c = next_char (dtp);
1359   if (!is_separator (c))
1360     goto bad_complex;
1361
1362   unget_char (dtp, c);
1363   eat_separator (dtp);
1364
1365   free_saved (dtp);
1366   dtp->u.p.saved_type = BT_COMPLEX;
1367   return;
1368
1369  bad_complex:
1370
1371   if (nml_bad_return (dtp, c))
1372     return;
1373
1374   free_saved (dtp);
1375   if (c == EOF)
1376     {
1377       hit_eof (dtp);
1378       return;
1379     }
1380   else if (c != '\n')   
1381     eat_line (dtp);
1382   sprintf (message, "Bad complex value in item %d of list input",
1383               dtp->u.p.item_count);
1384   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1385 }
1386
1387
1388 /* Parse a real number with a possible repeat count.  */
1389
1390 static void
1391 read_real (st_parameter_dt *dtp, void * dest, int length)
1392 {
1393   char message[100];
1394   int c;
1395   int seen_dp;
1396   int is_inf;
1397
1398   seen_dp = 0;
1399
1400   c = next_char (dtp);
1401   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1402     c = '.';
1403   switch (c)
1404     {
1405     CASE_DIGITS:
1406       push_char (dtp, c);
1407       break;
1408
1409     case '.':
1410       push_char (dtp, c);
1411       seen_dp = 1;
1412       break;
1413
1414     case '+':
1415     case '-':
1416       goto got_sign;
1417
1418     CASE_SEPARATORS:
1419       unget_char (dtp, c);              /* Single null.  */
1420       eat_separator (dtp);
1421       return;
1422
1423     case 'i':
1424     case 'I':
1425     case 'n':
1426     case 'N':
1427       goto inf_nan;
1428
1429     default:
1430       goto bad_real;
1431     }
1432
1433   /* Get the digit string that might be a repeat count.  */
1434
1435   for (;;)
1436     {
1437       c = next_char (dtp);
1438       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1439         c = '.';
1440       switch (c)
1441         {
1442         CASE_DIGITS:
1443           push_char (dtp, c);
1444           break;
1445
1446         case '.':
1447           if (seen_dp)
1448             goto bad_real;
1449
1450           seen_dp = 1;
1451           push_char (dtp, c);
1452           goto real_loop;
1453
1454         case 'E':
1455         case 'e':
1456         case 'D':
1457         case 'd':
1458           goto exp1;
1459
1460         case '+':
1461         case '-':
1462           push_char (dtp, 'e');
1463           push_char (dtp, c);
1464           c = next_char (dtp);
1465           goto exp2;
1466
1467         case '*':
1468           push_char (dtp, '\0');
1469           goto got_repeat;
1470
1471         CASE_SEPARATORS:
1472           if (c != '\n' && c != ',' && c != '\r' && c != ';')
1473             unget_char (dtp, c);
1474           goto done;
1475
1476         default:
1477           goto bad_real;
1478         }
1479     }
1480
1481  got_repeat:
1482   if (convert_integer (dtp, -1, 0))
1483     return;
1484
1485   /* Now get the number itself.  */
1486
1487   if ((c = next_char (dtp)) == EOF)
1488     goto bad_real;
1489   if (is_separator (c))
1490     {                           /* Repeated null value.  */
1491       unget_char (dtp, c);
1492       eat_separator (dtp);
1493       return;
1494     }
1495
1496   if (c != '-' && c != '+')
1497     push_char (dtp, '+');
1498   else
1499     {
1500     got_sign:
1501       push_char (dtp, c);
1502       if ((c = next_char (dtp)) == EOF)
1503         goto bad_real;
1504     }
1505
1506   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1507     c = '.';
1508
1509   if (!isdigit (c) && c != '.')
1510     {
1511       if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1512         goto inf_nan;
1513       else
1514         goto bad_real;
1515     }
1516
1517   if (c == '.')
1518     {
1519       if (seen_dp)
1520         goto bad_real;
1521       else
1522         seen_dp = 1;
1523     }
1524
1525   push_char (dtp, c);
1526
1527  real_loop:
1528   for (;;)
1529     {
1530       c = next_char (dtp);
1531       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1532         c = '.';
1533       switch (c)
1534         {
1535         CASE_DIGITS:
1536           push_char (dtp, c);
1537           break;
1538
1539         CASE_SEPARATORS:
1540         case EOF:
1541           goto done;
1542
1543         case '.':
1544           if (seen_dp)
1545             goto bad_real;
1546
1547           seen_dp = 1;
1548           push_char (dtp, c);
1549           break;
1550
1551         case 'E':
1552         case 'e':
1553         case 'D':
1554         case 'd':
1555           goto exp1;
1556
1557         case '+':
1558         case '-':
1559           push_char (dtp, 'e');
1560           push_char (dtp, c);
1561           c = next_char (dtp);
1562           goto exp2;
1563
1564         default:
1565           goto bad_real;
1566         }
1567     }
1568
1569  exp1:
1570   push_char (dtp, 'e');
1571
1572   if ((c = next_char (dtp)) == EOF)
1573     goto bad_real;
1574   if (c != '+' && c != '-')
1575     push_char (dtp, '+');
1576   else
1577     {
1578       push_char (dtp, c);
1579       c = next_char (dtp);
1580     }
1581
1582  exp2:
1583   if (!isdigit (c))
1584     goto bad_real;
1585   push_char (dtp, c);
1586
1587   for (;;)
1588     {
1589       c = next_char (dtp);
1590
1591       switch (c)
1592         {
1593         CASE_DIGITS:
1594           push_char (dtp, c);
1595           break;
1596
1597         CASE_SEPARATORS:
1598           goto done;
1599
1600         default:
1601           goto bad_real;
1602         }
1603     }
1604
1605  done:
1606   unget_char (dtp, c);
1607   eat_separator (dtp);
1608   push_char (dtp, '\0');
1609   if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
1610     return;
1611
1612   free_saved (dtp);
1613   dtp->u.p.saved_type = BT_REAL;
1614   return;
1615
1616  inf_nan:
1617   l_push_char (dtp, c);
1618   is_inf = 0;
1619
1620   /* Match INF and Infinity.  */
1621   if (c == 'i' || c == 'I')
1622     {
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 != 'f' && c != 'F')
1630         goto unwind;
1631       c = next_char (dtp);
1632       l_push_char (dtp, c);
1633       if (!is_separator (c))
1634         {
1635           if (c != 'i' && c != 'I')
1636             goto unwind;
1637           c = next_char (dtp);
1638           l_push_char (dtp, c);
1639           if (c != 'n' && c != 'N')
1640             goto unwind;
1641           c = next_char (dtp);
1642           l_push_char (dtp, c);
1643           if (c != 'i' && c != 'I')
1644             goto unwind;
1645           c = next_char (dtp);
1646           l_push_char (dtp, c);
1647           if (c != 't' && c != 'T')
1648             goto unwind;
1649           c = next_char (dtp);
1650           l_push_char (dtp, c);
1651           if (c != 'y' && c != 'Y')
1652             goto unwind;
1653           c = next_char (dtp);
1654           l_push_char (dtp, c);
1655         }
1656         is_inf = 1;
1657     } /* Match NaN.  */
1658   else
1659     {
1660       c = next_char (dtp);
1661       l_push_char (dtp, c);
1662       if (c != 'a' && c != 'A')
1663         goto unwind;
1664       c = next_char (dtp);
1665       l_push_char (dtp, c);
1666       if (c != 'n' && c != 'N')
1667         goto unwind;
1668       c = next_char (dtp);
1669       l_push_char (dtp, c);
1670
1671       /* Match NAN(alphanum).  */
1672       if (c == '(')
1673         {
1674           for (c = next_char (dtp); c != ')'; c = next_char (dtp))
1675             if (is_separator (c))
1676               goto unwind;
1677             else
1678               l_push_char (dtp, c);
1679
1680           l_push_char (dtp, ')');
1681           c = next_char (dtp);
1682           l_push_char (dtp, c);
1683         }
1684     }
1685
1686   if (!is_separator (c))
1687     goto unwind;
1688
1689   if (dtp->u.p.namelist_mode)
1690     {   
1691       if (c == ' ' || c =='\n' || c == '\r')
1692         {
1693           do
1694             {
1695               if ((c = next_char (dtp)) == EOF)
1696                 goto bad_real;
1697             }
1698           while (c == ' ' || c =='\n' || c == '\r');
1699
1700           l_push_char (dtp, c);
1701
1702           if (c == '=')
1703             goto unwind;
1704         }
1705     }
1706
1707   if (is_inf)
1708     {
1709       push_char (dtp, 'i');
1710       push_char (dtp, 'n');
1711       push_char (dtp, 'f');
1712     }
1713   else
1714     {
1715       push_char (dtp, 'n');
1716       push_char (dtp, 'a');
1717       push_char (dtp, 'n');
1718     }
1719
1720   free_line (dtp);
1721   goto done;
1722
1723  unwind:
1724   if (dtp->u.p.namelist_mode)
1725     {
1726       dtp->u.p.nml_read_error = 1;
1727       dtp->u.p.line_buffer_enabled = 1;
1728       dtp->u.p.item_count = 0;
1729       return;
1730     }
1731
1732  bad_real:
1733
1734   if (nml_bad_return (dtp, c))
1735     return;
1736
1737   free_saved (dtp);
1738   if (c == EOF)
1739     {
1740       hit_eof (dtp);
1741       return;
1742     }
1743   else if (c != '\n')
1744     eat_line (dtp);
1745
1746   sprintf (message, "Bad real number in item %d of list input",
1747               dtp->u.p.item_count);
1748   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1749 }
1750
1751
1752 /* Check the current type against the saved type to make sure they are
1753    compatible.  Returns nonzero if incompatible.  */
1754
1755 static int
1756 check_type (st_parameter_dt *dtp, bt type, int len)
1757 {
1758   char message[100];
1759
1760   if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
1761     {
1762       sprintf (message, "Read type %s where %s was expected for item %d",
1763                   type_name (dtp->u.p.saved_type), type_name (type),
1764                   dtp->u.p.item_count);
1765
1766       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1767       return 1;
1768     }
1769
1770   if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
1771     return 0;
1772
1773   if (dtp->u.p.saved_length != len)
1774     {
1775       sprintf (message,
1776                   "Read kind %d %s where kind %d is required for item %d",
1777                   dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1778                   dtp->u.p.item_count);
1779       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1780       return 1;
1781     }
1782
1783   return 0;
1784 }
1785
1786
1787 /* Top level data transfer subroutine for list reads.  Because we have
1788    to deal with repeat counts, the data item is always saved after
1789    reading, usually in the dtp->u.p.value[] array.  If a repeat count is
1790    greater than one, we copy the data item multiple times.  */
1791
1792 static int
1793 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
1794                             int kind, size_t size)
1795 {
1796   gfc_char4_t *q;
1797   int c, i, m;
1798   int err = 0;
1799
1800   dtp->u.p.namelist_mode = 0;
1801
1802   if (dtp->u.p.first_item)
1803     {
1804       dtp->u.p.first_item = 0;
1805       dtp->u.p.input_complete = 0;
1806       dtp->u.p.repeat_count = 1;
1807       dtp->u.p.at_eol = 0;
1808       
1809       if ((c = eat_spaces (dtp)) == EOF)
1810         {
1811           err = LIBERROR_END;
1812           goto cleanup;
1813         }
1814       if (is_separator (c))
1815         {
1816           /* Found a null value.  */
1817           eat_separator (dtp);
1818           dtp->u.p.repeat_count = 0;
1819
1820           /* eat_separator sets this flag if the separator was a comma.  */
1821           if (dtp->u.p.comma_flag)
1822             goto cleanup;
1823
1824           /* eat_separator sets this flag if the separator was a \n or \r.  */
1825           if (dtp->u.p.at_eol)
1826             finish_separator (dtp);
1827           else
1828             goto cleanup;
1829         }
1830
1831     }
1832   else
1833     {
1834       if (dtp->u.p.repeat_count > 0)
1835         {
1836           if (check_type (dtp, type, kind))
1837             return err;
1838           goto set_value;
1839         }
1840         
1841       if (dtp->u.p.input_complete)
1842         goto cleanup;
1843
1844       if (dtp->u.p.at_eol)
1845         finish_separator (dtp);
1846       else
1847         {
1848           eat_spaces (dtp);
1849           /* Trailing spaces prior to end of line.  */
1850           if (dtp->u.p.at_eol)
1851             finish_separator (dtp);
1852         }
1853
1854       dtp->u.p.saved_type = BT_UNKNOWN;
1855       dtp->u.p.repeat_count = 1;
1856     }
1857
1858   switch (type)
1859     {
1860     case BT_INTEGER:
1861       read_integer (dtp, kind);
1862       break;
1863     case BT_LOGICAL:
1864       read_logical (dtp, kind);
1865       break;
1866     case BT_CHARACTER:
1867       read_character (dtp, kind);
1868       break;
1869     case BT_REAL:
1870       read_real (dtp, p, kind);
1871       /* Copy value back to temporary if needed.  */
1872       if (dtp->u.p.repeat_count > 0)
1873         memcpy (dtp->u.p.value, p, kind);
1874       break;
1875     case BT_COMPLEX:
1876       read_complex (dtp, p, kind, size);
1877       /* Copy value back to temporary if needed.  */
1878       if (dtp->u.p.repeat_count > 0)
1879         memcpy (dtp->u.p.value, p, size);
1880       break;
1881     default:
1882       internal_error (&dtp->common, "Bad type for list read");
1883     }
1884
1885   if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN)
1886     dtp->u.p.saved_length = size;
1887
1888   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1889     goto cleanup;
1890
1891  set_value:
1892   switch (dtp->u.p.saved_type)
1893     {
1894     case BT_COMPLEX:
1895     case BT_REAL:
1896       if (dtp->u.p.repeat_count > 0)
1897         memcpy (p, dtp->u.p.value, size);
1898       break;
1899
1900     case BT_INTEGER:
1901     case BT_LOGICAL:
1902       memcpy (p, dtp->u.p.value, size);
1903       break;
1904
1905     case BT_CHARACTER:
1906       if (dtp->u.p.saved_string)
1907         {
1908           m = ((int) size < dtp->u.p.saved_used)
1909               ? (int) size : dtp->u.p.saved_used;
1910           if (kind == 1)
1911             memcpy (p, dtp->u.p.saved_string, m);
1912           else
1913             {
1914               q = (gfc_char4_t *) p;
1915               for (i = 0; i < m; i++)
1916                 q[i] = (unsigned char) dtp->u.p.saved_string[i];
1917             }
1918         }
1919       else
1920         /* Just delimiters encountered, nothing to copy but SPACE.  */
1921         m = 0;
1922
1923       if (m < (int) size)
1924         {
1925           if (kind == 1)
1926             memset (((char *) p) + m, ' ', size - m);
1927           else
1928             {
1929               q = (gfc_char4_t *) p;
1930               for (i = m; i < (int) size; i++)
1931                 q[i] = (unsigned char) ' ';
1932             }
1933         }
1934       break;
1935
1936     case BT_UNKNOWN:
1937       break;
1938
1939     default:
1940       internal_error (&dtp->common, "Bad type for list read");
1941     }
1942
1943   if (--dtp->u.p.repeat_count <= 0)
1944     free_saved (dtp);
1945
1946 cleanup:
1947   if (err == LIBERROR_END)
1948     hit_eof (dtp);
1949   return err;
1950 }
1951
1952
1953 void
1954 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1955                      size_t size, size_t nelems)
1956 {
1957   size_t elem;
1958   char *tmp;
1959   size_t stride = type == BT_CHARACTER ?
1960                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1961   int err;
1962
1963   tmp = (char *) p;
1964
1965   /* Big loop over all the elements.  */
1966   for (elem = 0; elem < nelems; elem++)
1967     {
1968       dtp->u.p.item_count++;
1969       err = list_formatted_read_scalar (dtp, type, tmp + stride*elem, 
1970                                         kind, size);
1971       if (err)
1972         break;
1973     }
1974 }
1975
1976
1977 /* Finish a list read.  */
1978
1979 void
1980 finish_list_read (st_parameter_dt *dtp)
1981 {
1982   int err;
1983
1984   free_saved (dtp);
1985
1986   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
1987
1988   if (dtp->u.p.at_eol)
1989     {
1990       dtp->u.p.at_eol = 0;
1991       return;
1992     }
1993
1994   err = eat_line (dtp);
1995   if (err == LIBERROR_END)
1996     hit_eof (dtp);
1997 }
1998
1999 /*                      NAMELIST INPUT
2000
2001 void namelist_read (st_parameter_dt *dtp)
2002 calls:
2003    static void nml_match_name (char *name, int len)
2004    static int nml_query (st_parameter_dt *dtp)
2005    static int nml_get_obj_data (st_parameter_dt *dtp,
2006                                 namelist_info **prev_nl, char *, size_t)
2007 calls:
2008       static void nml_untouch_nodes (st_parameter_dt *dtp)
2009       static namelist_info * find_nml_node (st_parameter_dt *dtp,
2010                                             char * var_name)
2011       static int nml_parse_qualifier(descriptor_dimension * ad,
2012                                      array_loop_spec * ls, int rank, char *)
2013       static void nml_touch_nodes (namelist_info * nl)
2014       static int nml_read_obj (namelist_info *nl, index_type offset,
2015                                namelist_info **prev_nl, char *, size_t,
2016                                index_type clow, index_type chigh)
2017 calls:
2018       -itself-  */
2019
2020 /* Inputs a rank-dimensional qualifier, which can contain
2021    singlets, doublets, triplets or ':' with the standard meanings.  */
2022
2023 static try
2024 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
2025                      array_loop_spec *ls, int rank, char *parse_err_msg,
2026                      int *parsed_rank)
2027 {
2028   int dim;
2029   int indx;
2030   int neg;
2031   int null_flag;
2032   int is_array_section, is_char;
2033   int c;
2034
2035   is_char = 0;
2036   is_array_section = 0;
2037   dtp->u.p.expanded_read = 0;
2038
2039   /* See if this is a character substring qualifier we are looking for.  */
2040   if (rank == -1)
2041     {
2042       rank = 1;
2043       is_char = 1;
2044     }
2045
2046   /* The next character in the stream should be the '('.  */
2047
2048   if ((c = next_char (dtp)) == EOF)
2049     return FAILURE;
2050
2051   /* Process the qualifier, by dimension and triplet.  */
2052
2053   for (dim=0; dim < rank; dim++ )
2054     {
2055       for (indx=0; indx<3; indx++)
2056         {
2057           free_saved (dtp);
2058           eat_spaces (dtp);
2059           neg = 0;
2060
2061           /* Process a potential sign.  */
2062           if ((c = next_char (dtp)) == EOF)
2063             return FAILURE;
2064           switch (c)
2065             {
2066             case '-':
2067               neg = 1;
2068               break;
2069
2070             case '+':
2071               break;
2072
2073             default:
2074               unget_char (dtp, c);
2075               break;
2076             }
2077
2078           /* Process characters up to the next ':' , ',' or ')'.  */
2079           for (;;)
2080             {
2081               if ((c = next_char (dtp)) == EOF)
2082                 return FAILURE;
2083
2084               switch (c)
2085                 {
2086                 case ':':
2087                   is_array_section = 1;
2088                   break;
2089
2090                 case ',': case ')':
2091                   if ((c==',' && dim == rank -1)
2092                       || (c==')' && dim < rank -1))
2093                     {
2094                       if (is_char)
2095                         sprintf (parse_err_msg, "Bad substring qualifier");
2096                       else
2097                         sprintf (parse_err_msg, "Bad number of index fields");
2098                       goto err_ret;
2099                     }
2100                   break;
2101
2102                 CASE_DIGITS:
2103                   push_char (dtp, c);
2104                   continue;
2105
2106                 case ' ': case '\t':
2107                   eat_spaces (dtp);
2108                   if ((c = next_char (dtp) == EOF))
2109                     return FAILURE;
2110                   break;
2111
2112                 default:
2113                   if (is_char)
2114                     sprintf (parse_err_msg,
2115                              "Bad character in substring qualifier");
2116                   else
2117                     sprintf (parse_err_msg, "Bad character in index");
2118                   goto err_ret;
2119                 }
2120
2121               if ((c == ',' || c == ')') && indx == 0
2122                   && dtp->u.p.saved_string == 0)
2123                 {
2124                   if (is_char)
2125                     sprintf (parse_err_msg, "Null substring qualifier");
2126                   else
2127                     sprintf (parse_err_msg, "Null index field");
2128                   goto err_ret;
2129                 }
2130
2131               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2132                   || (indx == 2 && dtp->u.p.saved_string == 0))
2133                 {
2134                   if (is_char)
2135                     sprintf (parse_err_msg, "Bad substring qualifier");
2136                   else
2137                     sprintf (parse_err_msg, "Bad index triplet");
2138                   goto err_ret;
2139                 }
2140
2141               if (is_char && !is_array_section)
2142                 {
2143                   sprintf (parse_err_msg,
2144                            "Missing colon in substring qualifier");
2145                   goto err_ret;
2146                 }
2147
2148               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
2149               null_flag = 0;
2150               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2151                   || (indx==1 && dtp->u.p.saved_string == 0))
2152                 {
2153                   null_flag = 1;
2154                   break;
2155                 }
2156
2157               /* Now read the index.  */
2158               if (convert_integer (dtp, sizeof(ssize_t), neg))
2159                 {
2160                   if (is_char)
2161                     sprintf (parse_err_msg, "Bad integer substring qualifier");
2162                   else
2163                     sprintf (parse_err_msg, "Bad integer in index");
2164                   goto err_ret;
2165                 }
2166               break;
2167             }
2168
2169           /* Feed the index values to the triplet arrays.  */
2170           if (!null_flag)
2171             {
2172               if (indx == 0)
2173                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2174               if (indx == 1)
2175                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2176               if (indx == 2)
2177                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2178             }
2179
2180           /* Singlet or doublet indices.  */
2181           if (c==',' || c==')')
2182             {
2183               if (indx == 0)
2184                 {
2185                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2186
2187                   /*  If -std=f95/2003 or an array section is specified,
2188                       do not allow excess data to be processed.  */
2189                   if (is_array_section == 1
2190                       || !(compile_options.allow_std & GFC_STD_GNU)
2191                       || !dtp->u.p.ionml->touched
2192                       || dtp->u.p.ionml->type == BT_DERIVED)
2193                     ls[dim].end = ls[dim].start;
2194                   else
2195                     dtp->u.p.expanded_read = 1;
2196                 }
2197
2198               /* Check for non-zero rank.  */
2199               if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2200                 *parsed_rank = 1;
2201
2202               break;
2203             }
2204         }
2205
2206       if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2207         {
2208           int i;
2209           dtp->u.p.expanded_read = 0;
2210           for (i = 0; i < dim; i++)
2211             ls[i].end = ls[i].start;
2212         }
2213
2214       /* Check the values of the triplet indices.  */
2215       if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2216            || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))
2217            || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2218            || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])))
2219         {
2220           if (is_char)
2221             sprintf (parse_err_msg, "Substring out of range");
2222           else
2223             sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2224           goto err_ret;
2225         }
2226
2227       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2228           || (ls[dim].step == 0))
2229         {
2230           sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2231           goto err_ret;
2232         }
2233
2234       /* Initialise the loop index counter.  */
2235       ls[dim].idx = ls[dim].start;
2236     }
2237   eat_spaces (dtp);
2238   return SUCCESS;
2239
2240 err_ret:
2241
2242   return FAILURE;
2243 }
2244
2245 static namelist_info *
2246 find_nml_node (st_parameter_dt *dtp, char * var_name)
2247 {
2248   namelist_info * t = dtp->u.p.ionml;
2249   while (t != NULL)
2250     {
2251       if (strcmp (var_name, t->var_name) == 0)
2252         {
2253           t->touched = 1;
2254           return t;
2255         }
2256       t = t->next;
2257     }
2258   return NULL;
2259 }
2260
2261 /* Visits all the components of a derived type that have
2262    not explicitly been identified in the namelist input.
2263    touched is set and the loop specification initialised
2264    to default values  */
2265
2266 static void
2267 nml_touch_nodes (namelist_info * nl)
2268 {
2269   index_type len = strlen (nl->var_name) + 1;
2270   int dim;
2271   char * ext_name = (char*)get_mem (len + 1);
2272   memcpy (ext_name, nl->var_name, len-1);
2273   memcpy (ext_name + len - 1, "%", 2);
2274   for (nl = nl->next; nl; nl = nl->next)
2275     {
2276       if (strncmp (nl->var_name, ext_name, len) == 0)
2277         {
2278           nl->touched = 1;
2279           for (dim=0; dim < nl->var_rank; dim++)
2280             {
2281               nl->ls[dim].step = 1;
2282               nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2283               nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2284               nl->ls[dim].idx = nl->ls[dim].start;
2285             }
2286         }
2287       else
2288         break;
2289     }
2290   free (ext_name);
2291   return;
2292 }
2293
2294 /* Resets touched for the entire list of nml_nodes, ready for a
2295    new object.  */
2296
2297 static void
2298 nml_untouch_nodes (st_parameter_dt *dtp)
2299 {
2300   namelist_info * t;
2301   for (t = dtp->u.p.ionml; t; t = t->next)
2302     t->touched = 0;
2303   return;
2304 }
2305
2306 /* Attempts to input name to namelist name.  Returns
2307    dtp->u.p.nml_read_error = 1 on no match.  */
2308
2309 static void
2310 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2311 {
2312   index_type i;
2313   int c;
2314
2315   dtp->u.p.nml_read_error = 0;
2316   for (i = 0; i < len; i++)
2317     {
2318       c = next_char (dtp);
2319       if (c == EOF || (tolower (c) != tolower (name[i])))
2320         {
2321           dtp->u.p.nml_read_error = 1;
2322           break;
2323         }
2324     }
2325 }
2326
2327 /* If the namelist read is from stdin, output the current state of the
2328    namelist to stdout.  This is used to implement the non-standard query
2329    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2330    the names alone are printed.  */
2331
2332 static void
2333 nml_query (st_parameter_dt *dtp, char c)
2334 {
2335   gfc_unit * temp_unit;
2336   namelist_info * nl;
2337   index_type len;
2338   char * p;
2339 #ifdef HAVE_CRLF
2340   static const index_type endlen = 3;
2341   static const char endl[] = "\r\n";
2342   static const char nmlend[] = "&end\r\n";
2343 #else
2344   static const index_type endlen = 2;
2345   static const char endl[] = "\n";
2346   static const char nmlend[] = "&end\n";
2347 #endif
2348
2349   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2350     return;
2351
2352   /* Store the current unit and transfer to stdout.  */
2353
2354   temp_unit = dtp->u.p.current_unit;
2355   dtp->u.p.current_unit = find_unit (options.stdout_unit);
2356
2357   if (dtp->u.p.current_unit)
2358     {
2359       dtp->u.p.mode = WRITING;
2360       next_record (dtp, 0);
2361
2362       /* Write the namelist in its entirety.  */
2363
2364       if (c == '=')
2365         namelist_write (dtp);
2366
2367       /* Or write the list of names.  */
2368
2369       else
2370         {
2371           /* "&namelist_name\n"  */
2372
2373           len = dtp->namelist_name_len;
2374           p = write_block (dtp, len + endlen);
2375           if (!p)
2376             goto query_return;
2377           memcpy (p, "&", 1);
2378           memcpy ((char*)(p + 1), dtp->namelist_name, len);
2379           memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2380           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2381             {
2382               /* " var_name\n"  */
2383
2384               len = strlen (nl->var_name);
2385               p = write_block (dtp, len + endlen);
2386               if (!p)
2387                 goto query_return;
2388               memcpy (p, " ", 1);
2389               memcpy ((char*)(p + 1), nl->var_name, len);
2390               memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2391             }
2392
2393           /* "&end\n"  */
2394
2395           p = write_block (dtp, endlen + 3);
2396             goto query_return;
2397           memcpy (p, &nmlend, endlen + 3);
2398         }
2399
2400       /* Flush the stream to force immediate output.  */
2401
2402       fbuf_flush (dtp->u.p.current_unit, WRITING);
2403       sflush (dtp->u.p.current_unit->s);
2404       unlock_unit (dtp->u.p.current_unit);
2405     }
2406
2407 query_return:
2408
2409   /* Restore the current unit.  */
2410
2411   dtp->u.p.current_unit = temp_unit;
2412   dtp->u.p.mode = READING;
2413   return;
2414 }
2415
2416 /* Reads and stores the input for the namelist object nl.  For an array,
2417    the function loops over the ranges defined by the loop specification.
2418    This default to all the data or to the specification from a qualifier.
2419    nml_read_obj recursively calls itself to read derived types. It visits
2420    all its own components but only reads data for those that were touched
2421    when the name was parsed.  If a read error is encountered, an attempt is
2422    made to return to read a new object name because the standard allows too
2423    little data to be available.  On the other hand, too much data is an
2424    error.  */
2425
2426 static try
2427 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2428               namelist_info **pprev_nl, char *nml_err_msg,
2429               size_t nml_err_msg_size, index_type clow, index_type chigh)
2430 {
2431   namelist_info * cmp;
2432   char * obj_name;
2433   int nml_carry;
2434   int len;
2435   int dim;
2436   index_type dlen;
2437   index_type m;
2438   size_t obj_name_len;
2439   void * pdata;
2440
2441   /* This object not touched in name parsing.  */
2442
2443   if (!nl->touched)
2444     return SUCCESS;
2445
2446   dtp->u.p.repeat_count = 0;
2447   eat_spaces (dtp);
2448
2449   len = nl->len;
2450   switch (nl->type)
2451   {
2452     case BT_INTEGER:
2453     case BT_LOGICAL:
2454       dlen = len;
2455       break;
2456
2457     case BT_REAL:
2458       dlen = size_from_real_kind (len);
2459       break;
2460
2461     case BT_COMPLEX:
2462       dlen = size_from_complex_kind (len);
2463       break;
2464
2465     case BT_CHARACTER:
2466       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2467       break;
2468
2469     default:
2470       dlen = 0;
2471     }
2472
2473   do
2474     {
2475       /* Update the pointer to the data, using the current index vector  */
2476
2477       pdata = (void*)(nl->mem_pos + offset);
2478       for (dim = 0; dim < nl->var_rank; dim++)
2479         pdata = (void*)(pdata + (nl->ls[dim].idx
2480                                  - GFC_DESCRIPTOR_LBOUND(nl,dim))
2481                         * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2482
2483       /* Reset the error flag and try to read next value, if
2484          dtp->u.p.repeat_count=0  */
2485
2486       dtp->u.p.nml_read_error = 0;
2487       nml_carry = 0;
2488       if (--dtp->u.p.repeat_count <= 0)
2489         {
2490           if (dtp->u.p.input_complete)
2491             return SUCCESS;
2492           if (dtp->u.p.at_eol)
2493             finish_separator (dtp);
2494           if (dtp->u.p.input_complete)
2495             return SUCCESS;
2496
2497           dtp->u.p.saved_type = BT_UNKNOWN;
2498           free_saved (dtp);
2499
2500           switch (nl->type)
2501           {
2502           case BT_INTEGER:
2503               read_integer (dtp, len);
2504               break;
2505
2506           case BT_LOGICAL:
2507               read_logical (dtp, len);
2508               break;
2509
2510           case BT_CHARACTER:
2511               read_character (dtp, len);
2512               break;
2513
2514           case BT_REAL:
2515             /* Need to copy data back from the real location to the temp in order
2516                to handle nml reads into arrays.  */
2517             read_real (dtp, pdata, len);
2518             memcpy (dtp->u.p.value, pdata, dlen);
2519             break;
2520
2521           case BT_COMPLEX:
2522             /* Same as for REAL, copy back to temp.  */
2523             read_complex (dtp, pdata, len, dlen);
2524             memcpy (dtp->u.p.value, pdata, dlen);
2525             break;
2526
2527           case BT_DERIVED:
2528             obj_name_len = strlen (nl->var_name) + 1;
2529             obj_name = get_mem (obj_name_len+1);
2530             memcpy (obj_name, nl->var_name, obj_name_len-1);
2531             memcpy (obj_name + obj_name_len - 1, "%", 2);
2532
2533             /* If reading a derived type, disable the expanded read warning
2534                since a single object can have multiple reads.  */
2535             dtp->u.p.expanded_read = 0;
2536
2537             /* Now loop over the components. Update the component pointer
2538                with the return value from nml_write_obj.  This loop jumps
2539                past nested derived types by testing if the potential
2540                component name contains '%'.  */
2541
2542             for (cmp = nl->next;
2543                  cmp &&
2544                    !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2545                    !strchr (cmp->var_name + obj_name_len, '%');
2546                  cmp = cmp->next)
2547               {
2548
2549                 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2550                                   pprev_nl, nml_err_msg, nml_err_msg_size,
2551                                   clow, chigh) == FAILURE)
2552                   {
2553                     free (obj_name);
2554                     return FAILURE;
2555                   }
2556
2557                 if (dtp->u.p.input_complete)
2558                   {
2559                     free (obj_name);
2560                     return SUCCESS;
2561                   }
2562               }
2563
2564             free (obj_name);
2565             goto incr_idx;
2566
2567           default:
2568             snprintf (nml_err_msg, nml_err_msg_size,
2569                       "Bad type for namelist object %s", nl->var_name);
2570             internal_error (&dtp->common, nml_err_msg);
2571             goto nml_err_ret;
2572           }
2573         }
2574
2575       /* The standard permits array data to stop short of the number of
2576          elements specified in the loop specification.  In this case, we
2577          should be here with dtp->u.p.nml_read_error != 0.  Control returns to
2578          nml_get_obj_data and an attempt is made to read object name.  */
2579
2580       *pprev_nl = nl;
2581       if (dtp->u.p.nml_read_error)
2582         {
2583           dtp->u.p.expanded_read = 0;
2584           return SUCCESS;
2585         }
2586
2587       if (dtp->u.p.saved_type == BT_UNKNOWN)
2588         {
2589           dtp->u.p.expanded_read = 0;
2590           goto incr_idx;
2591         }
2592
2593       switch (dtp->u.p.saved_type)
2594       {
2595
2596         case BT_COMPLEX:
2597         case BT_REAL:
2598         case BT_INTEGER:
2599         case BT_LOGICAL:
2600           memcpy (pdata, dtp->u.p.value, dlen);
2601           break;
2602
2603         case BT_CHARACTER:
2604           if (dlen < dtp->u.p.saved_used)
2605             {
2606               if (compile_options.bounds_check)
2607                 {
2608                   snprintf (nml_err_msg, nml_err_msg_size,
2609                             "Namelist object '%s' truncated on read.",
2610                             nl->var_name);
2611                   generate_warning (&dtp->common, nml_err_msg);
2612                 }
2613               m = dlen;
2614             }
2615           else
2616             m = dtp->u.p.saved_used;
2617           pdata = (void*)( pdata + clow - 1 );
2618           memcpy (pdata, dtp->u.p.saved_string, m);
2619           if (m < dlen)
2620             memset ((void*)( pdata + m ), ' ', dlen - m);
2621           break;
2622
2623         default:
2624           break;
2625       }
2626
2627       /* Warn if a non-standard expanded read occurs. A single read of a
2628          single object is acceptable.  If a second read occurs, issue a warning
2629          and set the flag to zero to prevent further warnings.  */
2630       if (dtp->u.p.expanded_read == 2)
2631         {
2632           notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2633           dtp->u.p.expanded_read = 0;
2634         }
2635
2636       /* If the expanded read warning flag is set, increment it,
2637          indicating that a single read has occurred.  */
2638       if (dtp->u.p.expanded_read >= 1)
2639         dtp->u.p.expanded_read++;
2640
2641       /* Break out of loop if scalar.  */
2642       if (!nl->var_rank)
2643         break;
2644
2645       /* Now increment the index vector.  */
2646
2647 incr_idx:
2648
2649       nml_carry = 1;
2650       for (dim = 0; dim < nl->var_rank; dim++)
2651         {
2652           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2653           nml_carry = 0;
2654           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2655               ||
2656               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2657             {
2658               nl->ls[dim].idx = nl->ls[dim].start;
2659               nml_carry = 1;
2660             }
2661         }
2662     } while (!nml_carry);
2663
2664   if (dtp->u.p.repeat_count > 1)
2665     {
2666       snprintf (nml_err_msg, nml_err_msg_size,
2667                 "Repeat count too large for namelist object %s", nl->var_name);
2668       goto nml_err_ret;
2669     }
2670   return SUCCESS;
2671
2672 nml_err_ret:
2673
2674   return FAILURE;
2675 }
2676
2677 /* Parses the object name, including array and substring qualifiers.  It
2678    iterates over derived type components, touching those components and
2679    setting their loop specifications, if there is a qualifier.  If the
2680    object is itself a derived type, its components and subcomponents are
2681    touched.  nml_read_obj is called at the end and this reads the data in
2682    the manner specified by the object name.  */
2683
2684 static try
2685 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2686                   char *nml_err_msg, size_t nml_err_msg_size)
2687 {
2688   int c;
2689   namelist_info * nl;
2690   namelist_info * first_nl = NULL;
2691   namelist_info * root_nl = NULL;
2692   int dim, parsed_rank;
2693   int component_flag, qualifier_flag;
2694   index_type clow, chigh;
2695   int non_zero_rank_count;
2696
2697   /* Look for end of input or object name.  If '?' or '=?' are encountered
2698      in stdin, print the node names or the namelist to stdout.  */
2699
2700   eat_separator (dtp);
2701   if (dtp->u.p.input_complete)
2702     return SUCCESS;
2703
2704   if (dtp->u.p.at_eol)
2705     finish_separator (dtp);
2706   if (dtp->u.p.input_complete)
2707     return SUCCESS;
2708
2709   if ((c = next_char (dtp)) == EOF)
2710     return FAILURE;
2711   switch (c)
2712     {
2713     case '=':
2714       if ((c = next_char (dtp)) == EOF)
2715         return FAILURE;
2716       if (c != '?')
2717         {
2718           sprintf (nml_err_msg, "namelist read: misplaced = sign");
2719           goto nml_err_ret;
2720         }
2721       nml_query (dtp, '=');
2722       return SUCCESS;
2723
2724     case '?':
2725       nml_query (dtp, '?');
2726       return SUCCESS;
2727
2728     case '$':
2729     case '&':
2730       nml_match_name (dtp, "end", 3);
2731       if (dtp->u.p.nml_read_error)
2732         {
2733           sprintf (nml_err_msg, "namelist not terminated with / or &end");
2734           goto nml_err_ret;
2735         }
2736     case '/':
2737       dtp->u.p.input_complete = 1;
2738       return SUCCESS;
2739
2740     default :
2741       break;
2742     }
2743
2744   /* Untouch all nodes of the namelist and reset the flags that are set for
2745      derived type components.  */
2746
2747   nml_untouch_nodes (dtp);
2748   component_flag = 0;
2749   qualifier_flag = 0;
2750   non_zero_rank_count = 0;
2751
2752   /* Get the object name - should '!' and '\n' be permitted separators?  */
2753
2754 get_name:
2755
2756   free_saved (dtp);
2757
2758   do
2759     {
2760       if (!is_separator (c))
2761         push_char (dtp, tolower(c));
2762       if ((c = next_char (dtp)) == EOF)
2763         return FAILURE;
2764     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2765
2766   unget_char (dtp, c);
2767
2768   /* Check that the name is in the namelist and get pointer to object.
2769      Three error conditions exist: (i) An attempt is being made to
2770      identify a non-existent object, following a failed data read or
2771      (ii) The object name does not exist or (iii) Too many data items
2772      are present for an object.  (iii) gives the same error message
2773      as (i)  */
2774
2775   push_char (dtp, '\0');
2776
2777   if (component_flag)
2778     {
2779       size_t var_len = strlen (root_nl->var_name);
2780       size_t saved_len
2781         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2782       char ext_name[var_len + saved_len + 1];
2783
2784       memcpy (ext_name, root_nl->var_name, var_len);
2785       if (dtp->u.p.saved_string)
2786         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2787       ext_name[var_len + saved_len] = '\0';
2788       nl = find_nml_node (dtp, ext_name);
2789     }
2790   else
2791     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2792
2793   if (nl == NULL)
2794     {
2795       if (dtp->u.p.nml_read_error && *pprev_nl)
2796         snprintf (nml_err_msg, nml_err_msg_size,
2797                   "Bad data for namelist object %s", (*pprev_nl)->var_name);
2798
2799       else
2800         snprintf (nml_err_msg, nml_err_msg_size,
2801                   "Cannot match namelist object name %s",
2802                   dtp->u.p.saved_string);
2803
2804       goto nml_err_ret;
2805     }
2806
2807   /* Get the length, data length, base pointer and rank of the variable.
2808      Set the default loop specification first.  */
2809
2810   for (dim=0; dim < nl->var_rank; dim++)
2811     {
2812       nl->ls[dim].step = 1;
2813       nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2814       nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2815       nl->ls[dim].idx = nl->ls[dim].start;
2816     }
2817
2818 /* Check to see if there is a qualifier: if so, parse it.*/
2819
2820   if (c == '(' && nl->var_rank)
2821     {
2822       parsed_rank = 0;
2823       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2824                                nml_err_msg, &parsed_rank) == FAILURE)
2825         {
2826           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2827           snprintf (nml_err_msg_end,
2828                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2829                     " for namelist variable %s", nl->var_name);
2830           goto nml_err_ret;
2831         }
2832       if (parsed_rank > 0)
2833         non_zero_rank_count++;
2834
2835       qualifier_flag = 1;
2836
2837       if ((c = next_char (dtp)) == EOF)
2838         return FAILURE;
2839       unget_char (dtp, c);
2840     }
2841   else if (nl->var_rank > 0)
2842     non_zero_rank_count++;
2843
2844   /* Now parse a derived type component. The root namelist_info address
2845      is backed up, as is the previous component level.  The  component flag
2846      is set and the iteration is made by jumping back to get_name.  */
2847
2848   if (c == '%')
2849     {
2850       if (nl->type != BT_DERIVED)
2851         {
2852           snprintf (nml_err_msg, nml_err_msg_size,
2853                     "Attempt to get derived component for %s", nl->var_name);
2854           goto nml_err_ret;
2855         }
2856
2857       if (*pprev_nl == NULL || !component_flag)
2858         first_nl = nl;
2859
2860       root_nl = nl;
2861
2862       component_flag = 1;
2863       if ((c = next_char (dtp)) == EOF)
2864         return FAILURE;
2865       goto get_name;
2866     }
2867
2868   /* Parse a character qualifier, if present.  chigh = 0 is a default
2869      that signals that the string length = string_length.  */
2870
2871   clow = 1;
2872   chigh = 0;
2873
2874   if (c == '(' && nl->type == BT_CHARACTER)
2875     {
2876       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2877       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2878
2879       if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
2880           == FAILURE)
2881         {
2882           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2883           snprintf (nml_err_msg_end,
2884                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2885                     " for namelist variable %s", nl->var_name);
2886           goto nml_err_ret;
2887         }
2888
2889       clow = ind[0].start;
2890       chigh = ind[0].end;
2891
2892       if (ind[0].step != 1)
2893         {
2894           snprintf (nml_err_msg, nml_err_msg_size,
2895                     "Step not allowed in substring qualifier"
2896                     " for namelist object %s", nl->var_name);
2897           goto nml_err_ret;
2898         }
2899
2900       if ((c = next_char (dtp)) == EOF)
2901         return FAILURE;
2902       unget_char (dtp, c);
2903     }
2904
2905   /* Make sure no extraneous qualifiers are there.  */
2906
2907   if (c == '(')
2908     {
2909       snprintf (nml_err_msg, nml_err_msg_size,
2910                 "Qualifier for a scalar or non-character namelist object %s",
2911                 nl->var_name);
2912       goto nml_err_ret;
2913     }
2914
2915   /* Make sure there is no more than one non-zero rank object.  */
2916   if (non_zero_rank_count > 1)
2917     {
2918       snprintf (nml_err_msg, nml_err_msg_size,
2919                 "Multiple sub-objects with non-zero rank in namelist object %s",
2920                 nl->var_name);
2921       non_zero_rank_count = 0;
2922       goto nml_err_ret;
2923     }
2924
2925 /* According to the standard, an equal sign MUST follow an object name. The
2926    following is possibly lax - it allows comments, blank lines and so on to
2927    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2928
2929   free_saved (dtp);
2930
2931   eat_separator (dtp);
2932   if (dtp->u.p.input_complete)
2933     return SUCCESS;
2934
2935   if (dtp->u.p.at_eol)
2936     finish_separator (dtp);
2937   if (dtp->u.p.input_complete)
2938     return SUCCESS;
2939
2940   if ((c = next_char (dtp)) == EOF)
2941     return FAILURE;
2942
2943   if (c != '=')
2944     {
2945       snprintf (nml_err_msg, nml_err_msg_size,
2946                 "Equal sign must follow namelist object name %s",
2947                 nl->var_name);
2948       goto nml_err_ret;
2949     }
2950   /* If a derived type, touch its components and restore the root
2951      namelist_info if we have parsed a qualified derived type
2952      component.  */
2953
2954   if (nl->type == BT_DERIVED)
2955     nml_touch_nodes (nl);
2956
2957   if (first_nl)
2958     {
2959       if (first_nl->var_rank == 0)
2960         {
2961           if (component_flag && qualifier_flag)
2962             nl = first_nl;
2963         }
2964       else
2965         nl = first_nl;
2966     }
2967
2968   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
2969                     clow, chigh) == FAILURE)
2970     goto nml_err_ret;
2971
2972   return SUCCESS;
2973
2974 nml_err_ret:
2975
2976   return FAILURE;
2977 }
2978
2979 /* Entry point for namelist input.  Goes through input until namelist name
2980   is matched.  Then cycles through nml_get_obj_data until the input is
2981   completed or there is an error.  */
2982
2983 void
2984 namelist_read (st_parameter_dt *dtp)
2985 {
2986   int c;
2987   char nml_err_msg[200];
2988
2989   /* Initialize the error string buffer just in case we get an unexpected fail
2990      somewhere and end up at nml_err_ret.  */
2991   strcpy (nml_err_msg, "Internal namelist read error");
2992
2993   /* Pointer to the previously read object, in case attempt is made to read
2994      new object name.  Should this fail, error message can give previous
2995      name.  */
2996   namelist_info *prev_nl = NULL;
2997
2998   dtp->u.p.namelist_mode = 1;
2999   dtp->u.p.input_complete = 0;
3000   dtp->u.p.expanded_read = 0;
3001
3002   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
3003      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3004      node names or namelist on stdout.  */
3005
3006 find_nml_name:
3007   c = next_char (dtp);
3008   switch (c)
3009     {
3010     case '$':
3011     case '&':
3012           break;
3013
3014     case '!':
3015       eat_line (dtp);
3016       goto find_nml_name;
3017
3018     case '=':
3019       c = next_char (dtp);
3020       if (c == '?')
3021         nml_query (dtp, '=');
3022       else
3023         unget_char (dtp, c);
3024       goto find_nml_name;
3025
3026     case '?':
3027       nml_query (dtp, '?');
3028
3029     case EOF:
3030       return;
3031
3032     default:
3033       goto find_nml_name;
3034     }
3035
3036   /* Match the name of the namelist.  */
3037
3038   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3039
3040   if (dtp->u.p.nml_read_error)
3041     goto find_nml_name;
3042
3043   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
3044   c = next_char (dtp);
3045   if (!is_separator(c) && c != '!')
3046     {
3047       unget_char (dtp, c);
3048       goto find_nml_name;
3049     }
3050
3051   unget_char (dtp, c);
3052   eat_separator (dtp);
3053
3054   /* Ready to read namelist objects.  If there is an error in input
3055      from stdin, output the error message and continue.  */
3056
3057   while (!dtp->u.p.input_complete)
3058     {
3059       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
3060                             == FAILURE)
3061         {
3062           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3063             goto nml_err_ret;
3064           generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3065         }
3066
3067       /* Reset the previous namelist pointer if we know we are not going
3068          to be doing multiple reads within a single namelist object.  */
3069       if (prev_nl && prev_nl->var_rank == 0)
3070         prev_nl = NULL;
3071     }
3072
3073   free_saved (dtp);
3074   free_line (dtp);
3075   return;
3076
3077
3078 nml_err_ret:
3079
3080   /* All namelist error calls return from here */
3081   free_saved (dtp);
3082   free_line (dtp);
3083   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3084   return;
3085 }