OSDN Git Service

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