OSDN Git Service

e44cc14a784efb03d653f1de25b21ff7c423be7a
[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, bt nml_elem_type,
2032                      char *parse_err_msg, 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     goto err_ret;
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             goto err_ret;
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               c = next_char (dtp);
2089               switch (c)
2090                 {
2091                 case EOF:
2092                   goto err_ret;
2093
2094                 case ':':
2095                   is_array_section = 1;
2096                   break;
2097
2098                 case ',': case ')':
2099                   if ((c==',' && dim == rank -1)
2100                       || (c==')' && dim < rank -1))
2101                     {
2102                       if (is_char)
2103                         snprintf (parse_err_msg, parse_err_msg_size, 
2104                                   "Bad substring qualifier");
2105                       else
2106                         snprintf (parse_err_msg, parse_err_msg_size, 
2107                                  "Bad number of index fields");
2108                       goto err_ret;
2109                     }
2110                   break;
2111
2112                 CASE_DIGITS:
2113                   push_char (dtp, c);
2114                   continue;
2115
2116                 case ' ': case '\t': case '\r': case '\n':
2117                   eat_spaces (dtp);
2118                   break;
2119
2120                 default:
2121                   if (is_char)
2122                     snprintf (parse_err_msg, parse_err_msg_size,
2123                              "Bad character in substring qualifier");
2124                   else
2125                     snprintf (parse_err_msg, parse_err_msg_size, 
2126                               "Bad character in index");
2127                   goto err_ret;
2128                 }
2129
2130               if ((c == ',' || c == ')') && indx == 0
2131                   && dtp->u.p.saved_string == 0)
2132                 {
2133                   if (is_char)
2134                     snprintf (parse_err_msg, parse_err_msg_size, 
2135                               "Null substring qualifier");
2136                   else
2137                     snprintf (parse_err_msg, parse_err_msg_size, 
2138                               "Null index field");
2139                   goto err_ret;
2140                 }
2141
2142               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2143                   || (indx == 2 && dtp->u.p.saved_string == 0))
2144                 {
2145                   if (is_char)
2146                     snprintf (parse_err_msg, parse_err_msg_size, 
2147                               "Bad substring qualifier");
2148                   else
2149                     snprintf (parse_err_msg, parse_err_msg_size,
2150                               "Bad index triplet");
2151                   goto err_ret;
2152                 }
2153
2154               if (is_char && !is_array_section)
2155                 {
2156                   snprintf (parse_err_msg, parse_err_msg_size,
2157                            "Missing colon in substring qualifier");
2158                   goto err_ret;
2159                 }
2160
2161               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
2162               null_flag = 0;
2163               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2164                   || (indx==1 && dtp->u.p.saved_string == 0))
2165                 {
2166                   null_flag = 1;
2167                   break;
2168                 }
2169
2170               /* Now read the index.  */
2171               if (convert_integer (dtp, sizeof(index_type), neg))
2172                 {
2173                   if (is_char)
2174                     snprintf (parse_err_msg, parse_err_msg_size,
2175                               "Bad integer substring qualifier");
2176                   else
2177                     snprintf (parse_err_msg, parse_err_msg_size,
2178                               "Bad integer in index");
2179                   goto err_ret;
2180                 }
2181               break;
2182             }
2183
2184           /* Feed the index values to the triplet arrays.  */
2185           if (!null_flag)
2186             {
2187               if (indx == 0)
2188                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2189               if (indx == 1)
2190                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type));
2191               if (indx == 2)
2192                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type));
2193             }
2194
2195           /* Singlet or doublet indices.  */
2196           if (c==',' || c==')')
2197             {
2198               if (indx == 0)
2199                 {
2200                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2201
2202                   /*  If -std=f95/2003 or an array section is specified,
2203                       do not allow excess data to be processed.  */
2204                   if (is_array_section == 1
2205                       || !(compile_options.allow_std & GFC_STD_GNU)
2206                       || nml_elem_type == BT_DERIVED)
2207                     ls[dim].end = ls[dim].start;
2208                   else
2209                     dtp->u.p.expanded_read = 1;
2210                 }
2211
2212               /* Check for non-zero rank.  */
2213               if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2214                 *parsed_rank = 1;
2215
2216               break;
2217             }
2218         }
2219
2220       if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2221         {
2222           int i;
2223           dtp->u.p.expanded_read = 0;
2224           for (i = 0; i < dim; i++)
2225             ls[i].end = ls[i].start;
2226         }
2227
2228       /* Check the values of the triplet indices.  */
2229       if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim]))
2230            || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim]))
2231            || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim]))
2232            || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim])))
2233         {
2234           if (is_char)
2235             snprintf (parse_err_msg, parse_err_msg_size, 
2236                       "Substring out of range");
2237           else
2238             snprintf (parse_err_msg, parse_err_msg_size, 
2239                       "Index %d out of range", dim + 1);
2240           goto err_ret;
2241         }
2242
2243       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2244           || (ls[dim].step == 0))
2245         {
2246           snprintf (parse_err_msg, parse_err_msg_size, 
2247                    "Bad range in index %d", dim + 1);
2248           goto err_ret;
2249         }
2250
2251       /* Initialise the loop index counter.  */
2252       ls[dim].idx = ls[dim].start;
2253     }
2254   eat_spaces (dtp);
2255   return SUCCESS;
2256
2257 err_ret:
2258
2259   /* The EOF error message is issued by hit_eof. Return true so that the
2260      caller does not use parse_err_msg and parse_err_msg_size to generate
2261      an unrelated error message.  */
2262   if (c == EOF)
2263     {
2264       hit_eof (dtp);
2265       dtp->u.p.input_complete = 1;
2266       return SUCCESS;
2267     }
2268   return FAILURE;
2269 }
2270
2271 static namelist_info *
2272 find_nml_node (st_parameter_dt *dtp, char * var_name)
2273 {
2274   namelist_info * t = dtp->u.p.ionml;
2275   while (t != NULL)
2276     {
2277       if (strcmp (var_name, t->var_name) == 0)
2278         {
2279           t->touched = 1;
2280           return t;
2281         }
2282       t = t->next;
2283     }
2284   return NULL;
2285 }
2286
2287 /* Visits all the components of a derived type that have
2288    not explicitly been identified in the namelist input.
2289    touched is set and the loop specification initialised
2290    to default values  */
2291
2292 static void
2293 nml_touch_nodes (namelist_info * nl)
2294 {
2295   index_type len = strlen (nl->var_name) + 1;
2296   int dim;
2297   char * ext_name = (char*)get_mem (len + 1);
2298   memcpy (ext_name, nl->var_name, len-1);
2299   memcpy (ext_name + len - 1, "%", 2);
2300   for (nl = nl->next; nl; nl = nl->next)
2301     {
2302       if (strncmp (nl->var_name, ext_name, len) == 0)
2303         {
2304           nl->touched = 1;
2305           for (dim=0; dim < nl->var_rank; dim++)
2306             {
2307               nl->ls[dim].step = 1;
2308               nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2309               nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2310               nl->ls[dim].idx = nl->ls[dim].start;
2311             }
2312         }
2313       else
2314         break;
2315     }
2316   free (ext_name);
2317   return;
2318 }
2319
2320 /* Resets touched for the entire list of nml_nodes, ready for a
2321    new object.  */
2322
2323 static void
2324 nml_untouch_nodes (st_parameter_dt *dtp)
2325 {
2326   namelist_info * t;
2327   for (t = dtp->u.p.ionml; t; t = t->next)
2328     t->touched = 0;
2329   return;
2330 }
2331
2332 /* Attempts to input name to namelist name.  Returns
2333    dtp->u.p.nml_read_error = 1 on no match.  */
2334
2335 static void
2336 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2337 {
2338   index_type i;
2339   int c;
2340
2341   dtp->u.p.nml_read_error = 0;
2342   for (i = 0; i < len; i++)
2343     {
2344       c = next_char (dtp);
2345       if (c == EOF || (tolower (c) != tolower (name[i])))
2346         {
2347           dtp->u.p.nml_read_error = 1;
2348           break;
2349         }
2350     }
2351 }
2352
2353 /* If the namelist read is from stdin, output the current state of the
2354    namelist to stdout.  This is used to implement the non-standard query
2355    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2356    the names alone are printed.  */
2357
2358 static void
2359 nml_query (st_parameter_dt *dtp, char c)
2360 {
2361   gfc_unit * temp_unit;
2362   namelist_info * nl;
2363   index_type len;
2364   char * p;
2365 #ifdef HAVE_CRLF
2366   static const index_type endlen = 2;
2367   static const char endl[] = "\r\n";
2368   static const char nmlend[] = "&end\r\n";
2369 #else
2370   static const index_type endlen = 1;
2371   static const char endl[] = "\n";
2372   static const char nmlend[] = "&end\n";
2373 #endif
2374
2375   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2376     return;
2377
2378   /* Store the current unit and transfer to stdout.  */
2379
2380   temp_unit = dtp->u.p.current_unit;
2381   dtp->u.p.current_unit = find_unit (options.stdout_unit);
2382
2383   if (dtp->u.p.current_unit)
2384     {
2385       dtp->u.p.mode = WRITING;
2386       next_record (dtp, 0);
2387
2388       /* Write the namelist in its entirety.  */
2389
2390       if (c == '=')
2391         namelist_write (dtp);
2392
2393       /* Or write the list of names.  */
2394
2395       else
2396         {
2397           /* "&namelist_name\n"  */
2398
2399           len = dtp->namelist_name_len;
2400           p = write_block (dtp, len - 1 + endlen);
2401           if (!p)
2402             goto query_return;
2403           memcpy (p, "&", 1);
2404           memcpy ((char*)(p + 1), dtp->namelist_name, len);
2405           memcpy ((char*)(p + len + 1), &endl, endlen);
2406           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2407             {
2408               /* " var_name\n"  */
2409
2410               len = strlen (nl->var_name);
2411               p = write_block (dtp, len + endlen);
2412               if (!p)
2413                 goto query_return;
2414               memcpy (p, " ", 1);
2415               memcpy ((char*)(p + 1), nl->var_name, len);
2416               memcpy ((char*)(p + len + 1), &endl, endlen);
2417             }
2418
2419           /* "&end\n"  */
2420
2421           p = write_block (dtp, endlen + 4);
2422           if (!p)
2423             goto query_return;
2424           memcpy (p, &nmlend, endlen + 4);
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.  */
2565
2566             for (cmp = nl->next;
2567                  cmp &&
2568                    !strncmp (cmp->var_name, obj_name, obj_name_len);
2569                  cmp = cmp->next)
2570               {
2571                 /* Jump over nested derived type by testing if the potential
2572                    component name contains '%'.  */
2573                 if (strchr (cmp->var_name + obj_name_len, '%'))
2574                     continue;
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     goto nml_err_ret;
2738   switch (c)
2739     {
2740     case '=':
2741       if ((c = next_char (dtp)) == EOF)
2742         goto nml_err_ret;
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         goto nml_err_ret;
2793     }
2794   while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2795
2796   unget_char (dtp, c);
2797
2798   /* Check that the name is in the namelist and get pointer to object.
2799      Three error conditions exist: (i) An attempt is being made to
2800      identify a non-existent object, following a failed data read or
2801      (ii) The object name does not exist or (iii) Too many data items
2802      are present for an object.  (iii) gives the same error message
2803      as (i)  */
2804
2805   push_char (dtp, '\0');
2806
2807   if (component_flag)
2808     {
2809       size_t var_len = strlen (root_nl->var_name);
2810       size_t saved_len
2811         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2812       char ext_name[var_len + saved_len + 1];
2813
2814       memcpy (ext_name, root_nl->var_name, var_len);
2815       if (dtp->u.p.saved_string)
2816         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2817       ext_name[var_len + saved_len] = '\0';
2818       nl = find_nml_node (dtp, ext_name);
2819     }
2820   else
2821     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2822
2823   if (nl == NULL)
2824     {
2825       if (dtp->u.p.nml_read_error && *pprev_nl)
2826         snprintf (nml_err_msg, nml_err_msg_size,
2827                   "Bad data for namelist object %s", (*pprev_nl)->var_name);
2828
2829       else
2830         snprintf (nml_err_msg, nml_err_msg_size,
2831                   "Cannot match namelist object name %s",
2832                   dtp->u.p.saved_string);
2833
2834       goto nml_err_ret;
2835     }
2836
2837   /* Get the length, data length, base pointer and rank of the variable.
2838      Set the default loop specification first.  */
2839
2840   for (dim=0; dim < nl->var_rank; dim++)
2841     {
2842       nl->ls[dim].step = 1;
2843       nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2844       nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2845       nl->ls[dim].idx = nl->ls[dim].start;
2846     }
2847
2848 /* Check to see if there is a qualifier: if so, parse it.*/
2849
2850   if (c == '(' && nl->var_rank)
2851     {
2852       parsed_rank = 0;
2853       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2854                                nl->type, nml_err_msg, nml_err_msg_size,
2855                                &parsed_rank) == FAILURE)
2856         {
2857           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2858           snprintf (nml_err_msg_end,
2859                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2860                     " for namelist variable %s", nl->var_name);
2861           goto nml_err_ret;
2862         }
2863       if (parsed_rank > 0)
2864         non_zero_rank_count++;
2865
2866       qualifier_flag = 1;
2867
2868       if ((c = next_char (dtp)) == EOF)
2869         goto nml_err_ret;
2870       unget_char (dtp, c);
2871     }
2872   else if (nl->var_rank > 0)
2873     non_zero_rank_count++;
2874
2875   /* Now parse a derived type component. The root namelist_info address
2876      is backed up, as is the previous component level.  The  component flag
2877      is set and the iteration is made by jumping back to get_name.  */
2878
2879   if (c == '%')
2880     {
2881       if (nl->type != BT_DERIVED)
2882         {
2883           snprintf (nml_err_msg, nml_err_msg_size,
2884                     "Attempt to get derived component for %s", nl->var_name);
2885           goto nml_err_ret;
2886         }
2887
2888       /* Don't move first_nl further in the list if a qualifier was found.  */
2889       if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag)
2890         first_nl = nl;
2891
2892       root_nl = nl;
2893
2894       component_flag = 1;
2895       if ((c = next_char (dtp)) == EOF)
2896         goto nml_err_ret;
2897       goto get_name;
2898     }
2899
2900   /* Parse a character qualifier, if present.  chigh = 0 is a default
2901      that signals that the string length = string_length.  */
2902
2903   clow = 1;
2904   chigh = 0;
2905
2906   if (c == '(' && nl->type == BT_CHARACTER)
2907     {
2908       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2909       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2910
2911       if (nml_parse_qualifier (dtp, chd, ind, -1, nl->type,
2912                                nml_err_msg, nml_err_msg_size, &parsed_rank)
2913           == FAILURE)
2914         {
2915           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2916           snprintf (nml_err_msg_end,
2917                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2918                     " for namelist variable %s", nl->var_name);
2919           goto nml_err_ret;
2920         }
2921
2922       clow = ind[0].start;
2923       chigh = ind[0].end;
2924
2925       if (ind[0].step != 1)
2926         {
2927           snprintf (nml_err_msg, nml_err_msg_size,
2928                     "Step not allowed in substring qualifier"
2929                     " for namelist object %s", nl->var_name);
2930           goto nml_err_ret;
2931         }
2932
2933       if ((c = next_char (dtp)) == EOF)
2934         goto nml_err_ret;
2935       unget_char (dtp, c);
2936     }
2937
2938   /* Make sure no extraneous qualifiers are there.  */
2939
2940   if (c == '(')
2941     {
2942       snprintf (nml_err_msg, nml_err_msg_size,
2943                 "Qualifier for a scalar or non-character namelist object %s",
2944                 nl->var_name);
2945       goto nml_err_ret;
2946     }
2947
2948   /* Make sure there is no more than one non-zero rank object.  */
2949   if (non_zero_rank_count > 1)
2950     {
2951       snprintf (nml_err_msg, nml_err_msg_size,
2952                 "Multiple sub-objects with non-zero rank in namelist object %s",
2953                 nl->var_name);
2954       non_zero_rank_count = 0;
2955       goto nml_err_ret;
2956     }
2957
2958 /* According to the standard, an equal sign MUST follow an object name. The
2959    following is possibly lax - it allows comments, blank lines and so on to
2960    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2961
2962   free_saved (dtp);
2963
2964   eat_separator (dtp);
2965   if (dtp->u.p.input_complete)
2966     return SUCCESS;
2967
2968   if (dtp->u.p.at_eol)
2969     finish_separator (dtp);
2970   if (dtp->u.p.input_complete)
2971     return SUCCESS;
2972
2973   if ((c = next_char (dtp)) == EOF)
2974     goto nml_err_ret;
2975
2976   if (c != '=')
2977     {
2978       snprintf (nml_err_msg, nml_err_msg_size,
2979                 "Equal sign must follow namelist object name %s",
2980                 nl->var_name);
2981       goto nml_err_ret;
2982     }
2983   /* If a derived type, touch its components and restore the root
2984      namelist_info if we have parsed a qualified derived type
2985      component.  */
2986
2987   if (nl->type == BT_DERIVED)
2988     nml_touch_nodes (nl);
2989
2990   if (first_nl)
2991     {
2992       if (first_nl->var_rank == 0)
2993         {
2994           if (component_flag && qualifier_flag)
2995             nl = first_nl;
2996         }
2997       else
2998         nl = first_nl;
2999     }
3000
3001   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
3002                     clow, chigh) == FAILURE)
3003     goto nml_err_ret;
3004
3005   return SUCCESS;
3006
3007 nml_err_ret:
3008
3009   /* The EOF error message is issued by hit_eof. Return true so that the
3010      caller does not use nml_err_msg and nml_err_msg_size to generate
3011      an unrelated error message.  */
3012   if (c == EOF)
3013     {
3014       dtp->u.p.input_complete = 1;
3015       unget_char (dtp, c);
3016       hit_eof (dtp);
3017       return SUCCESS;
3018     }
3019
3020   return FAILURE;
3021 }
3022
3023 /* Entry point for namelist input.  Goes through input until namelist name
3024   is matched.  Then cycles through nml_get_obj_data until the input is
3025   completed or there is an error.  */
3026
3027 void
3028 namelist_read (st_parameter_dt *dtp)
3029 {
3030   int c;
3031   char nml_err_msg[200];
3032
3033   /* Initialize the error string buffer just in case we get an unexpected fail
3034      somewhere and end up at nml_err_ret.  */
3035   strcpy (nml_err_msg, "Internal namelist read error");
3036
3037   /* Pointer to the previously read object, in case attempt is made to read
3038      new object name.  Should this fail, error message can give previous
3039      name.  */
3040   namelist_info *prev_nl = NULL;
3041
3042   dtp->u.p.namelist_mode = 1;
3043   dtp->u.p.input_complete = 0;
3044   dtp->u.p.expanded_read = 0;
3045
3046   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
3047      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3048      node names or namelist on stdout.  */
3049
3050 find_nml_name:
3051   c = next_char (dtp);
3052   switch (c)
3053     {
3054     case '$':
3055     case '&':
3056           break;
3057
3058     case '!':
3059       eat_line (dtp);
3060       goto find_nml_name;
3061
3062     case '=':
3063       c = next_char (dtp);
3064       if (c == '?')
3065         nml_query (dtp, '=');
3066       else
3067         unget_char (dtp, c);
3068       goto find_nml_name;
3069
3070     case '?':
3071       nml_query (dtp, '?');
3072       goto find_nml_name;
3073
3074     case EOF:
3075       return;
3076
3077     default:
3078       goto find_nml_name;
3079     }
3080
3081   /* Match the name of the namelist.  */
3082
3083   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3084
3085   if (dtp->u.p.nml_read_error)
3086     goto find_nml_name;
3087
3088   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
3089   c = next_char (dtp);
3090   if (!is_separator(c) && c != '!')
3091     {
3092       unget_char (dtp, c);
3093       goto find_nml_name;
3094     }
3095
3096   unget_char (dtp, c);
3097   eat_separator (dtp);
3098
3099   /* Ready to read namelist objects.  If there is an error in input
3100      from stdin, output the error message and continue.  */
3101
3102   while (!dtp->u.p.input_complete)
3103     {
3104       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
3105                             == FAILURE)
3106         {
3107           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3108             goto nml_err_ret;
3109           generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3110         }
3111
3112       /* Reset the previous namelist pointer if we know we are not going
3113          to be doing multiple reads within a single namelist object.  */
3114       if (prev_nl && prev_nl->var_rank == 0)
3115         prev_nl = NULL;
3116     }
3117
3118   free_saved (dtp);
3119   free_line (dtp);
3120   return;
3121
3122
3123 nml_err_ret:
3124
3125   /* All namelist error calls return from here */
3126   free_saved (dtp);
3127   free_line (dtp);
3128   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3129   return;
3130 }