OSDN Git Service

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