OSDN Git Service

2014-03-15 Jerry DeLisle <jvdelisle@gcc.gnu>
[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   free_saved (dtp);
1989
1990   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
1991
1992   if (dtp->u.p.at_eol)
1993     {
1994       dtp->u.p.at_eol = 0;
1995       return;
1996     }
1997
1998   if (!is_internal_unit (dtp))
1999     {
2000       int c;
2001       c = next_char (dtp);
2002       if (c == EOF)
2003         {
2004           free_line (dtp);
2005           hit_eof (dtp);
2006           return;
2007         }
2008       if (c != '\n')
2009         eat_line (dtp);
2010     }
2011
2012   free_line (dtp);
2013
2014 }
2015
2016 /*                      NAMELIST INPUT
2017
2018 void namelist_read (st_parameter_dt *dtp)
2019 calls:
2020    static void nml_match_name (char *name, int len)
2021    static int nml_query (st_parameter_dt *dtp)
2022    static int nml_get_obj_data (st_parameter_dt *dtp,
2023                                 namelist_info **prev_nl, char *, size_t)
2024 calls:
2025       static void nml_untouch_nodes (st_parameter_dt *dtp)
2026       static namelist_info * find_nml_node (st_parameter_dt *dtp,
2027                                             char * var_name)
2028       static int nml_parse_qualifier(descriptor_dimension * ad,
2029                                      array_loop_spec * ls, int rank, char *)
2030       static void nml_touch_nodes (namelist_info * nl)
2031       static int nml_read_obj (namelist_info *nl, index_type offset,
2032                                namelist_info **prev_nl, char *, size_t,
2033                                index_type clow, index_type chigh)
2034 calls:
2035       -itself-  */
2036
2037 /* Inputs a rank-dimensional qualifier, which can contain
2038    singlets, doublets, triplets or ':' with the standard meanings.  */
2039
2040 static try
2041 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
2042                      array_loop_spec *ls, int rank, bt nml_elem_type,
2043                      char *parse_err_msg, size_t parse_err_msg_size,
2044                      int *parsed_rank)
2045 {
2046   int dim;
2047   int indx;
2048   int neg;
2049   int null_flag;
2050   int is_array_section, is_char;
2051   int c;
2052
2053   is_char = 0;
2054   is_array_section = 0;
2055   dtp->u.p.expanded_read = 0;
2056
2057   /* See if this is a character substring qualifier we are looking for.  */
2058   if (rank == -1)
2059     {
2060       rank = 1;
2061       is_char = 1;
2062     }
2063
2064   /* The next character in the stream should be the '('.  */
2065
2066   if ((c = next_char (dtp)) == EOF)
2067     goto err_ret;
2068
2069   /* Process the qualifier, by dimension and triplet.  */
2070
2071   for (dim=0; dim < rank; dim++ )
2072     {
2073       for (indx=0; indx<3; indx++)
2074         {
2075           free_saved (dtp);
2076           eat_spaces (dtp);
2077           neg = 0;
2078
2079           /* Process a potential sign.  */
2080           if ((c = next_char (dtp)) == EOF)
2081             goto err_ret;
2082           switch (c)
2083             {
2084             case '-':
2085               neg = 1;
2086               break;
2087
2088             case '+':
2089               break;
2090
2091             default:
2092               unget_char (dtp, c);
2093               break;
2094             }
2095
2096           /* Process characters up to the next ':' , ',' or ')'.  */
2097           for (;;)
2098             {
2099               c = next_char (dtp);
2100               switch (c)
2101                 {
2102                 case EOF:
2103                   goto err_ret;
2104
2105                 case ':':
2106                   is_array_section = 1;
2107                   break;
2108
2109                 case ',': case ')':
2110                   if ((c==',' && dim == rank -1)
2111                       || (c==')' && dim < rank -1))
2112                     {
2113                       if (is_char)
2114                         snprintf (parse_err_msg, parse_err_msg_size, 
2115                                   "Bad substring qualifier");
2116                       else
2117                         snprintf (parse_err_msg, parse_err_msg_size, 
2118                                  "Bad number of index fields");
2119                       goto err_ret;
2120                     }
2121                   break;
2122
2123                 CASE_DIGITS:
2124                   push_char (dtp, c);
2125                   continue;
2126
2127                 case ' ': case '\t': case '\r': case '\n':
2128                   eat_spaces (dtp);
2129                   break;
2130
2131                 default:
2132                   if (is_char)
2133                     snprintf (parse_err_msg, parse_err_msg_size,
2134                              "Bad character in substring qualifier");
2135                   else
2136                     snprintf (parse_err_msg, parse_err_msg_size, 
2137                               "Bad character in index");
2138                   goto err_ret;
2139                 }
2140
2141               if ((c == ',' || c == ')') && indx == 0
2142                   && dtp->u.p.saved_string == 0)
2143                 {
2144                   if (is_char)
2145                     snprintf (parse_err_msg, parse_err_msg_size, 
2146                               "Null substring qualifier");
2147                   else
2148                     snprintf (parse_err_msg, parse_err_msg_size, 
2149                               "Null index field");
2150                   goto err_ret;
2151                 }
2152
2153               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2154                   || (indx == 2 && dtp->u.p.saved_string == 0))
2155                 {
2156                   if (is_char)
2157                     snprintf (parse_err_msg, parse_err_msg_size, 
2158                               "Bad substring qualifier");
2159                   else
2160                     snprintf (parse_err_msg, parse_err_msg_size,
2161                               "Bad index triplet");
2162                   goto err_ret;
2163                 }
2164
2165               if (is_char && !is_array_section)
2166                 {
2167                   snprintf (parse_err_msg, parse_err_msg_size,
2168                            "Missing colon in substring qualifier");
2169                   goto err_ret;
2170                 }
2171
2172               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
2173               null_flag = 0;
2174               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2175                   || (indx==1 && dtp->u.p.saved_string == 0))
2176                 {
2177                   null_flag = 1;
2178                   break;
2179                 }
2180
2181               /* Now read the index.  */
2182               if (convert_integer (dtp, sizeof(index_type), neg))
2183                 {
2184                   if (is_char)
2185                     snprintf (parse_err_msg, parse_err_msg_size,
2186                               "Bad integer substring qualifier");
2187                   else
2188                     snprintf (parse_err_msg, parse_err_msg_size,
2189                               "Bad integer in index");
2190                   goto err_ret;
2191                 }
2192               break;
2193             }
2194
2195           /* Feed the index values to the triplet arrays.  */
2196           if (!null_flag)
2197             {
2198               if (indx == 0)
2199                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2200               if (indx == 1)
2201                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type));
2202               if (indx == 2)
2203                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type));
2204             }
2205
2206           /* Singlet or doublet indices.  */
2207           if (c==',' || c==')')
2208             {
2209               if (indx == 0)
2210                 {
2211                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2212
2213                   /*  If -std=f95/2003 or an array section is specified,
2214                       do not allow excess data to be processed.  */
2215                   if (is_array_section == 1
2216                       || !(compile_options.allow_std & GFC_STD_GNU)
2217                       || nml_elem_type == BT_DERIVED)
2218                     ls[dim].end = ls[dim].start;
2219                   else
2220                     dtp->u.p.expanded_read = 1;
2221                 }
2222
2223               /* Check for non-zero rank.  */
2224               if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2225                 *parsed_rank = 1;
2226
2227               break;
2228             }
2229         }
2230
2231       if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2232         {
2233           int i;
2234           dtp->u.p.expanded_read = 0;
2235           for (i = 0; i < dim; i++)
2236             ls[i].end = ls[i].start;
2237         }
2238
2239       /* Check the values of the triplet indices.  */
2240       if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim]))
2241            || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim]))
2242            || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim]))
2243            || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim])))
2244         {
2245           if (is_char)
2246             snprintf (parse_err_msg, parse_err_msg_size, 
2247                       "Substring out of range");
2248           else
2249             snprintf (parse_err_msg, parse_err_msg_size, 
2250                       "Index %d out of range", dim + 1);
2251           goto err_ret;
2252         }
2253
2254       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2255           || (ls[dim].step == 0))
2256         {
2257           snprintf (parse_err_msg, parse_err_msg_size, 
2258                    "Bad range in index %d", dim + 1);
2259           goto err_ret;
2260         }
2261
2262       /* Initialise the loop index counter.  */
2263       ls[dim].idx = ls[dim].start;
2264     }
2265   eat_spaces (dtp);
2266   return SUCCESS;
2267
2268 err_ret:
2269
2270   /* The EOF error message is issued by hit_eof. Return true so that the
2271      caller does not use parse_err_msg and parse_err_msg_size to generate
2272      an unrelated error message.  */
2273   if (c == EOF)
2274     {
2275       hit_eof (dtp);
2276       dtp->u.p.input_complete = 1;
2277       return SUCCESS;
2278     }
2279   return FAILURE;
2280 }
2281
2282 static namelist_info *
2283 find_nml_node (st_parameter_dt *dtp, char * var_name)
2284 {
2285   namelist_info * t = dtp->u.p.ionml;
2286   while (t != NULL)
2287     {
2288       if (strcmp (var_name, t->var_name) == 0)
2289         {
2290           t->touched = 1;
2291           return t;
2292         }
2293       t = t->next;
2294     }
2295   return NULL;
2296 }
2297
2298 /* Visits all the components of a derived type that have
2299    not explicitly been identified in the namelist input.
2300    touched is set and the loop specification initialised
2301    to default values  */
2302
2303 static void
2304 nml_touch_nodes (namelist_info * nl)
2305 {
2306   index_type len = strlen (nl->var_name) + 1;
2307   int dim;
2308   char * ext_name = (char*)get_mem (len + 1);
2309   memcpy (ext_name, nl->var_name, len-1);
2310   memcpy (ext_name + len - 1, "%", 2);
2311   for (nl = nl->next; nl; nl = nl->next)
2312     {
2313       if (strncmp (nl->var_name, ext_name, len) == 0)
2314         {
2315           nl->touched = 1;
2316           for (dim=0; dim < nl->var_rank; dim++)
2317             {
2318               nl->ls[dim].step = 1;
2319               nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2320               nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2321               nl->ls[dim].idx = nl->ls[dim].start;
2322             }
2323         }
2324       else
2325         break;
2326     }
2327   free (ext_name);
2328   return;
2329 }
2330
2331 /* Resets touched for the entire list of nml_nodes, ready for a
2332    new object.  */
2333
2334 static void
2335 nml_untouch_nodes (st_parameter_dt *dtp)
2336 {
2337   namelist_info * t;
2338   for (t = dtp->u.p.ionml; t; t = t->next)
2339     t->touched = 0;
2340   return;
2341 }
2342
2343 /* Attempts to input name to namelist name.  Returns
2344    dtp->u.p.nml_read_error = 1 on no match.  */
2345
2346 static void
2347 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2348 {
2349   index_type i;
2350   int c;
2351
2352   dtp->u.p.nml_read_error = 0;
2353   for (i = 0; i < len; i++)
2354     {
2355       c = next_char (dtp);
2356       if (c == EOF || (tolower (c) != tolower (name[i])))
2357         {
2358           dtp->u.p.nml_read_error = 1;
2359           break;
2360         }
2361     }
2362 }
2363
2364 /* If the namelist read is from stdin, output the current state of the
2365    namelist to stdout.  This is used to implement the non-standard query
2366    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2367    the names alone are printed.  */
2368
2369 static void
2370 nml_query (st_parameter_dt *dtp, char c)
2371 {
2372   gfc_unit * temp_unit;
2373   namelist_info * nl;
2374   index_type len;
2375   char * p;
2376 #ifdef HAVE_CRLF
2377   static const index_type endlen = 2;
2378   static const char endl[] = "\r\n";
2379   static const char nmlend[] = "&end\r\n";
2380 #else
2381   static const index_type endlen = 1;
2382   static const char endl[] = "\n";
2383   static const char nmlend[] = "&end\n";
2384 #endif
2385
2386   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2387     return;
2388
2389   /* Store the current unit and transfer to stdout.  */
2390
2391   temp_unit = dtp->u.p.current_unit;
2392   dtp->u.p.current_unit = find_unit (options.stdout_unit);
2393
2394   if (dtp->u.p.current_unit)
2395     {
2396       dtp->u.p.mode = WRITING;
2397       next_record (dtp, 0);
2398
2399       /* Write the namelist in its entirety.  */
2400
2401       if (c == '=')
2402         namelist_write (dtp);
2403
2404       /* Or write the list of names.  */
2405
2406       else
2407         {
2408           /* "&namelist_name\n"  */
2409
2410           len = dtp->namelist_name_len;
2411           p = write_block (dtp, len - 1 + endlen);
2412           if (!p)
2413             goto query_return;
2414           memcpy (p, "&", 1);
2415           memcpy ((char*)(p + 1), dtp->namelist_name, len);
2416           memcpy ((char*)(p + len + 1), &endl, endlen);
2417           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2418             {
2419               /* " var_name\n"  */
2420
2421               len = strlen (nl->var_name);
2422               p = write_block (dtp, len + endlen);
2423               if (!p)
2424                 goto query_return;
2425               memcpy (p, " ", 1);
2426               memcpy ((char*)(p + 1), nl->var_name, len);
2427               memcpy ((char*)(p + len + 1), &endl, endlen);
2428             }
2429
2430           /* "&end\n"  */
2431
2432           p = write_block (dtp, endlen + 4);
2433           if (!p)
2434             goto query_return;
2435           memcpy (p, &nmlend, endlen + 4);
2436         }
2437
2438       /* Flush the stream to force immediate output.  */
2439
2440       fbuf_flush (dtp->u.p.current_unit, WRITING);
2441       sflush (dtp->u.p.current_unit->s);
2442       unlock_unit (dtp->u.p.current_unit);
2443     }
2444
2445 query_return:
2446
2447   /* Restore the current unit.  */
2448
2449   dtp->u.p.current_unit = temp_unit;
2450   dtp->u.p.mode = READING;
2451   return;
2452 }
2453
2454 /* Reads and stores the input for the namelist object nl.  For an array,
2455    the function loops over the ranges defined by the loop specification.
2456    This default to all the data or to the specification from a qualifier.
2457    nml_read_obj recursively calls itself to read derived types. It visits
2458    all its own components but only reads data for those that were touched
2459    when the name was parsed.  If a read error is encountered, an attempt is
2460    made to return to read a new object name because the standard allows too
2461    little data to be available.  On the other hand, too much data is an
2462    error.  */
2463
2464 static try
2465 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2466               namelist_info **pprev_nl, char *nml_err_msg,
2467               size_t nml_err_msg_size, index_type clow, index_type chigh)
2468 {
2469   namelist_info * cmp;
2470   char * obj_name;
2471   int nml_carry;
2472   int len;
2473   int dim;
2474   index_type dlen;
2475   index_type m;
2476   size_t obj_name_len;
2477   void * pdata;
2478
2479   /* This object not touched in name parsing.  */
2480
2481   if (!nl->touched)
2482     return SUCCESS;
2483
2484   dtp->u.p.repeat_count = 0;
2485   eat_spaces (dtp);
2486
2487   len = nl->len;
2488   switch (nl->type)
2489   {
2490     case BT_INTEGER:
2491     case BT_LOGICAL:
2492       dlen = len;
2493       break;
2494
2495     case BT_REAL:
2496       dlen = size_from_real_kind (len);
2497       break;
2498
2499     case BT_COMPLEX:
2500       dlen = size_from_complex_kind (len);
2501       break;
2502
2503     case BT_CHARACTER:
2504       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2505       break;
2506
2507     default:
2508       dlen = 0;
2509     }
2510
2511   do
2512     {
2513       /* Update the pointer to the data, using the current index vector  */
2514
2515       pdata = (void*)(nl->mem_pos + offset);
2516       for (dim = 0; dim < nl->var_rank; dim++)
2517         pdata = (void*)(pdata + (nl->ls[dim].idx
2518                                  - GFC_DESCRIPTOR_LBOUND(nl,dim))
2519                         * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2520
2521       /* Reset the error flag and try to read next value, if
2522          dtp->u.p.repeat_count=0  */
2523
2524       dtp->u.p.nml_read_error = 0;
2525       nml_carry = 0;
2526       if (--dtp->u.p.repeat_count <= 0)
2527         {
2528           if (dtp->u.p.input_complete)
2529             return SUCCESS;
2530           if (dtp->u.p.at_eol)
2531             finish_separator (dtp);
2532           if (dtp->u.p.input_complete)
2533             return SUCCESS;
2534
2535           dtp->u.p.saved_type = BT_UNKNOWN;
2536           free_saved (dtp);
2537
2538           switch (nl->type)
2539           {
2540           case BT_INTEGER:
2541               read_integer (dtp, len);
2542               break;
2543
2544           case BT_LOGICAL:
2545               read_logical (dtp, len);
2546               break;
2547
2548           case BT_CHARACTER:
2549               read_character (dtp, len);
2550               break;
2551
2552           case BT_REAL:
2553             /* Need to copy data back from the real location to the temp in order
2554                to handle nml reads into arrays.  */
2555             read_real (dtp, pdata, len);
2556             memcpy (dtp->u.p.value, pdata, dlen);
2557             break;
2558
2559           case BT_COMPLEX:
2560             /* Same as for REAL, copy back to temp.  */
2561             read_complex (dtp, pdata, len, dlen);
2562             memcpy (dtp->u.p.value, pdata, dlen);
2563             break;
2564
2565           case BT_DERIVED:
2566             obj_name_len = strlen (nl->var_name) + 1;
2567             obj_name = get_mem (obj_name_len+1);
2568             memcpy (obj_name, nl->var_name, obj_name_len-1);
2569             memcpy (obj_name + obj_name_len - 1, "%", 2);
2570
2571             /* If reading a derived type, disable the expanded read warning
2572                since a single object can have multiple reads.  */
2573             dtp->u.p.expanded_read = 0;
2574
2575             /* Now loop over the components.  */
2576
2577             for (cmp = nl->next;
2578                  cmp &&
2579                    !strncmp (cmp->var_name, obj_name, obj_name_len);
2580                  cmp = cmp->next)
2581               {
2582                 /* Jump over nested derived type by testing if the potential
2583                    component name contains '%'.  */
2584                 if (strchr (cmp->var_name + obj_name_len, '%'))
2585                     continue;
2586
2587                 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2588                                   pprev_nl, nml_err_msg, nml_err_msg_size,
2589                                   clow, chigh) == FAILURE)
2590                   {
2591                     free (obj_name);
2592                     return FAILURE;
2593                   }
2594
2595                 if (dtp->u.p.input_complete)
2596                   {
2597                     free (obj_name);
2598                     return SUCCESS;
2599                   }
2600               }
2601
2602             free (obj_name);
2603             goto incr_idx;
2604
2605           default:
2606             snprintf (nml_err_msg, nml_err_msg_size,
2607                       "Bad type for namelist object %s", nl->var_name);
2608             internal_error (&dtp->common, nml_err_msg);
2609             goto nml_err_ret;
2610           }
2611         }
2612
2613       /* The standard permits array data to stop short of the number of
2614          elements specified in the loop specification.  In this case, we
2615          should be here with dtp->u.p.nml_read_error != 0.  Control returns to
2616          nml_get_obj_data and an attempt is made to read object name.  */
2617
2618       *pprev_nl = nl;
2619       if (dtp->u.p.nml_read_error)
2620         {
2621           dtp->u.p.expanded_read = 0;
2622           return SUCCESS;
2623         }
2624
2625       if (dtp->u.p.saved_type == BT_UNKNOWN)
2626         {
2627           dtp->u.p.expanded_read = 0;
2628           goto incr_idx;
2629         }
2630
2631       switch (dtp->u.p.saved_type)
2632       {
2633
2634         case BT_COMPLEX:
2635         case BT_REAL:
2636         case BT_INTEGER:
2637         case BT_LOGICAL:
2638           memcpy (pdata, dtp->u.p.value, dlen);
2639           break;
2640
2641         case BT_CHARACTER:
2642           if (dlen < dtp->u.p.saved_used)
2643             {
2644               if (compile_options.bounds_check)
2645                 {
2646                   snprintf (nml_err_msg, nml_err_msg_size,
2647                             "Namelist object '%s' truncated on read.",
2648                             nl->var_name);
2649                   generate_warning (&dtp->common, nml_err_msg);
2650                 }
2651               m = dlen;
2652             }
2653           else
2654             m = dtp->u.p.saved_used;
2655           pdata = (void*)( pdata + clow - 1 );
2656           memcpy (pdata, dtp->u.p.saved_string, m);
2657           if (m < dlen)
2658             memset ((void*)( pdata + m ), ' ', dlen - m);
2659           break;
2660
2661         default:
2662           break;
2663       }
2664
2665       /* Warn if a non-standard expanded read occurs. A single read of a
2666          single object is acceptable.  If a second read occurs, issue a warning
2667          and set the flag to zero to prevent further warnings.  */
2668       if (dtp->u.p.expanded_read == 2)
2669         {
2670           notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2671           dtp->u.p.expanded_read = 0;
2672         }
2673
2674       /* If the expanded read warning flag is set, increment it,
2675          indicating that a single read has occurred.  */
2676       if (dtp->u.p.expanded_read >= 1)
2677         dtp->u.p.expanded_read++;
2678
2679       /* Break out of loop if scalar.  */
2680       if (!nl->var_rank)
2681         break;
2682
2683       /* Now increment the index vector.  */
2684
2685 incr_idx:
2686
2687       nml_carry = 1;
2688       for (dim = 0; dim < nl->var_rank; dim++)
2689         {
2690           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2691           nml_carry = 0;
2692           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2693               ||
2694               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2695             {
2696               nl->ls[dim].idx = nl->ls[dim].start;
2697               nml_carry = 1;
2698             }
2699         }
2700     } while (!nml_carry);
2701
2702   if (dtp->u.p.repeat_count > 1)
2703     {
2704       snprintf (nml_err_msg, nml_err_msg_size,
2705                 "Repeat count too large for namelist object %s", nl->var_name);
2706       goto nml_err_ret;
2707     }
2708   return SUCCESS;
2709
2710 nml_err_ret:
2711
2712   return FAILURE;
2713 }
2714
2715 /* Parses the object name, including array and substring qualifiers.  It
2716    iterates over derived type components, touching those components and
2717    setting their loop specifications, if there is a qualifier.  If the
2718    object is itself a derived type, its components and subcomponents are
2719    touched.  nml_read_obj is called at the end and this reads the data in
2720    the manner specified by the object name.  */
2721
2722 static try
2723 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2724                   char *nml_err_msg, size_t nml_err_msg_size)
2725 {
2726   int c;
2727   namelist_info * nl;
2728   namelist_info * first_nl = NULL;
2729   namelist_info * root_nl = NULL;
2730   int dim, parsed_rank;
2731   int component_flag, qualifier_flag;
2732   index_type clow, chigh;
2733   int non_zero_rank_count;
2734
2735   /* Look for end of input or object name.  If '?' or '=?' are encountered
2736      in stdin, print the node names or the namelist to stdout.  */
2737
2738   eat_separator (dtp);
2739   if (dtp->u.p.input_complete)
2740     return SUCCESS;
2741
2742   if (dtp->u.p.at_eol)
2743     finish_separator (dtp);
2744   if (dtp->u.p.input_complete)
2745     return SUCCESS;
2746
2747   if ((c = next_char (dtp)) == EOF)
2748     goto nml_err_ret;
2749   switch (c)
2750     {
2751     case '=':
2752       if ((c = next_char (dtp)) == EOF)
2753         goto nml_err_ret;
2754       if (c != '?')
2755         {
2756           snprintf (nml_err_msg, nml_err_msg_size, 
2757                     "namelist read: misplaced = sign");
2758           goto nml_err_ret;
2759         }
2760       nml_query (dtp, '=');
2761       return SUCCESS;
2762
2763     case '?':
2764       nml_query (dtp, '?');
2765       return SUCCESS;
2766
2767     case '$':
2768     case '&':
2769       nml_match_name (dtp, "end", 3);
2770       if (dtp->u.p.nml_read_error)
2771         {
2772           snprintf (nml_err_msg, nml_err_msg_size, 
2773                     "namelist not terminated with / or &end");
2774           goto nml_err_ret;
2775         }
2776     case '/':
2777       dtp->u.p.input_complete = 1;
2778       return SUCCESS;
2779
2780     default :
2781       break;
2782     }
2783
2784   /* Untouch all nodes of the namelist and reset the flags that are set for
2785      derived type components.  */
2786
2787   nml_untouch_nodes (dtp);
2788   component_flag = 0;
2789   qualifier_flag = 0;
2790   non_zero_rank_count = 0;
2791
2792   /* Get the object name - should '!' and '\n' be permitted separators?  */
2793
2794 get_name:
2795
2796   free_saved (dtp);
2797
2798   do
2799     {
2800       if (!is_separator (c))
2801         push_char (dtp, tolower(c));
2802       if ((c = next_char (dtp)) == EOF)
2803         goto nml_err_ret;
2804     }
2805   while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2806
2807   unget_char (dtp, c);
2808
2809   /* Check that the name is in the namelist and get pointer to object.
2810      Three error conditions exist: (i) An attempt is being made to
2811      identify a non-existent object, following a failed data read or
2812      (ii) The object name does not exist or (iii) Too many data items
2813      are present for an object.  (iii) gives the same error message
2814      as (i)  */
2815
2816   push_char (dtp, '\0');
2817
2818   if (component_flag)
2819     {
2820       size_t var_len = strlen (root_nl->var_name);
2821       size_t saved_len
2822         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2823       char ext_name[var_len + saved_len + 1];
2824
2825       memcpy (ext_name, root_nl->var_name, var_len);
2826       if (dtp->u.p.saved_string)
2827         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2828       ext_name[var_len + saved_len] = '\0';
2829       nl = find_nml_node (dtp, ext_name);
2830     }
2831   else
2832     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2833
2834   if (nl == NULL)
2835     {
2836       if (dtp->u.p.nml_read_error && *pprev_nl)
2837         snprintf (nml_err_msg, nml_err_msg_size,
2838                   "Bad data for namelist object %s", (*pprev_nl)->var_name);
2839
2840       else
2841         snprintf (nml_err_msg, nml_err_msg_size,
2842                   "Cannot match namelist object name %s",
2843                   dtp->u.p.saved_string);
2844
2845       goto nml_err_ret;
2846     }
2847
2848   /* Get the length, data length, base pointer and rank of the variable.
2849      Set the default loop specification first.  */
2850
2851   for (dim=0; dim < nl->var_rank; dim++)
2852     {
2853       nl->ls[dim].step = 1;
2854       nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2855       nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2856       nl->ls[dim].idx = nl->ls[dim].start;
2857     }
2858
2859 /* Check to see if there is a qualifier: if so, parse it.*/
2860
2861   if (c == '(' && nl->var_rank)
2862     {
2863       parsed_rank = 0;
2864       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2865                                nl->type, nml_err_msg, nml_err_msg_size,
2866                                &parsed_rank) == FAILURE)
2867         {
2868           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2869           snprintf (nml_err_msg_end,
2870                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2871                     " for namelist variable %s", nl->var_name);
2872           goto nml_err_ret;
2873         }
2874       if (parsed_rank > 0)
2875         non_zero_rank_count++;
2876
2877       qualifier_flag = 1;
2878
2879       if ((c = next_char (dtp)) == EOF)
2880         goto nml_err_ret;
2881       unget_char (dtp, c);
2882     }
2883   else if (nl->var_rank > 0)
2884     non_zero_rank_count++;
2885
2886   /* Now parse a derived type component. The root namelist_info address
2887      is backed up, as is the previous component level.  The  component flag
2888      is set and the iteration is made by jumping back to get_name.  */
2889
2890   if (c == '%')
2891     {
2892       if (nl->type != BT_DERIVED)
2893         {
2894           snprintf (nml_err_msg, nml_err_msg_size,
2895                     "Attempt to get derived component for %s", nl->var_name);
2896           goto nml_err_ret;
2897         }
2898
2899       /* Don't move first_nl further in the list if a qualifier was found.  */
2900       if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag)
2901         first_nl = nl;
2902
2903       root_nl = nl;
2904
2905       component_flag = 1;
2906       if ((c = next_char (dtp)) == EOF)
2907         goto nml_err_ret;
2908       goto get_name;
2909     }
2910
2911   /* Parse a character qualifier, if present.  chigh = 0 is a default
2912      that signals that the string length = string_length.  */
2913
2914   clow = 1;
2915   chigh = 0;
2916
2917   if (c == '(' && nl->type == BT_CHARACTER)
2918     {
2919       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2920       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2921
2922       if (nml_parse_qualifier (dtp, chd, ind, -1, nl->type,
2923                                nml_err_msg, nml_err_msg_size, &parsed_rank)
2924           == FAILURE)
2925         {
2926           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2927           snprintf (nml_err_msg_end,
2928                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2929                     " for namelist variable %s", nl->var_name);
2930           goto nml_err_ret;
2931         }
2932
2933       clow = ind[0].start;
2934       chigh = ind[0].end;
2935
2936       if (ind[0].step != 1)
2937         {
2938           snprintf (nml_err_msg, nml_err_msg_size,
2939                     "Step not allowed in substring qualifier"
2940                     " for namelist object %s", nl->var_name);
2941           goto nml_err_ret;
2942         }
2943
2944       if ((c = next_char (dtp)) == EOF)
2945         goto nml_err_ret;
2946       unget_char (dtp, c);
2947     }
2948
2949   /* Make sure no extraneous qualifiers are there.  */
2950
2951   if (c == '(')
2952     {
2953       snprintf (nml_err_msg, nml_err_msg_size,
2954                 "Qualifier for a scalar or non-character namelist object %s",
2955                 nl->var_name);
2956       goto nml_err_ret;
2957     }
2958
2959   /* Make sure there is no more than one non-zero rank object.  */
2960   if (non_zero_rank_count > 1)
2961     {
2962       snprintf (nml_err_msg, nml_err_msg_size,
2963                 "Multiple sub-objects with non-zero rank in namelist object %s",
2964                 nl->var_name);
2965       non_zero_rank_count = 0;
2966       goto nml_err_ret;
2967     }
2968
2969 /* According to the standard, an equal sign MUST follow an object name. The
2970    following is possibly lax - it allows comments, blank lines and so on to
2971    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2972
2973   free_saved (dtp);
2974
2975   eat_separator (dtp);
2976   if (dtp->u.p.input_complete)
2977     return SUCCESS;
2978
2979   if (dtp->u.p.at_eol)
2980     finish_separator (dtp);
2981   if (dtp->u.p.input_complete)
2982     return SUCCESS;
2983
2984   if ((c = next_char (dtp)) == EOF)
2985     goto nml_err_ret;
2986
2987   if (c != '=')
2988     {
2989       snprintf (nml_err_msg, nml_err_msg_size,
2990                 "Equal sign must follow namelist object name %s",
2991                 nl->var_name);
2992       goto nml_err_ret;
2993     }
2994   /* If a derived type, touch its components and restore the root
2995      namelist_info if we have parsed a qualified derived type
2996      component.  */
2997
2998   if (nl->type == BT_DERIVED)
2999     nml_touch_nodes (nl);
3000
3001   if (first_nl)
3002     {
3003       if (first_nl->var_rank == 0)
3004         {
3005           if (component_flag && qualifier_flag)
3006             nl = first_nl;
3007         }
3008       else
3009         nl = first_nl;
3010     }
3011
3012   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
3013                     clow, chigh) == FAILURE)
3014     goto nml_err_ret;
3015
3016   return SUCCESS;
3017
3018 nml_err_ret:
3019
3020   /* The EOF error message is issued by hit_eof. Return true so that the
3021      caller does not use nml_err_msg and nml_err_msg_size to generate
3022      an unrelated error message.  */
3023   if (c == EOF)
3024     {
3025       dtp->u.p.input_complete = 1;
3026       unget_char (dtp, c);
3027       hit_eof (dtp);
3028       return SUCCESS;
3029     }
3030
3031   return FAILURE;
3032 }
3033
3034 /* Entry point for namelist input.  Goes through input until namelist name
3035   is matched.  Then cycles through nml_get_obj_data until the input is
3036   completed or there is an error.  */
3037
3038 void
3039 namelist_read (st_parameter_dt *dtp)
3040 {
3041   int c;
3042   char nml_err_msg[200];
3043
3044   /* Initialize the error string buffer just in case we get an unexpected fail
3045      somewhere and end up at nml_err_ret.  */
3046   strcpy (nml_err_msg, "Internal namelist read error");
3047
3048   /* Pointer to the previously read object, in case attempt is made to read
3049      new object name.  Should this fail, error message can give previous
3050      name.  */
3051   namelist_info *prev_nl = NULL;
3052
3053   dtp->u.p.namelist_mode = 1;
3054   dtp->u.p.input_complete = 0;
3055   dtp->u.p.expanded_read = 0;
3056
3057   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
3058      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3059      node names or namelist on stdout.  */
3060
3061 find_nml_name:
3062   c = next_char (dtp);
3063   switch (c)
3064     {
3065     case '$':
3066     case '&':
3067           break;
3068
3069     case '!':
3070       eat_line (dtp);
3071       goto find_nml_name;
3072
3073     case '=':
3074       c = next_char (dtp);
3075       if (c == '?')
3076         nml_query (dtp, '=');
3077       else
3078         unget_char (dtp, c);
3079       goto find_nml_name;
3080
3081     case '?':
3082       nml_query (dtp, '?');
3083       goto find_nml_name;
3084
3085     case EOF:
3086       return;
3087
3088     default:
3089       goto find_nml_name;
3090     }
3091
3092   /* Match the name of the namelist.  */
3093
3094   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3095
3096   if (dtp->u.p.nml_read_error)
3097     goto find_nml_name;
3098
3099   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
3100   c = next_char (dtp);
3101   if (!is_separator(c) && c != '!')
3102     {
3103       unget_char (dtp, c);
3104       goto find_nml_name;
3105     }
3106
3107   unget_char (dtp, c);
3108   eat_separator (dtp);
3109
3110   /* Ready to read namelist objects.  If there is an error in input
3111      from stdin, output the error message and continue.  */
3112
3113   while (!dtp->u.p.input_complete)
3114     {
3115       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
3116                             == FAILURE)
3117         {
3118           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3119             goto nml_err_ret;
3120           generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3121         }
3122
3123       /* Reset the previous namelist pointer if we know we are not going
3124          to be doing multiple reads within a single namelist object.  */
3125       if (prev_nl && prev_nl->var_rank == 0)
3126         prev_nl = NULL;
3127     }
3128
3129   free_saved (dtp);
3130   free_line (dtp);
3131   return;
3132
3133
3134 nml_err_ret:
3135
3136   /* All namelist error calls return from here */
3137   free_saved (dtp);
3138   free_line (dtp);
3139   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3140   return;
3141 }