OSDN Git Service

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