OSDN Git Service

PR 43839
[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       goto done;
1203     }
1204
1205  bad:
1206
1207   if (nml_bad_return (dtp, c))
1208     return 0;
1209
1210   eat_line (dtp);
1211   free_saved (dtp);
1212   sprintf (message, "Bad floating point number for item %d",
1213               dtp->u.p.item_count);
1214   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1215
1216   return 1;
1217 }
1218
1219
1220 /* Reading a complex number is straightforward because we can tell
1221    what it is right away.  */
1222
1223 static void
1224 read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
1225 {
1226   char message[100];
1227   char c;
1228
1229   if (parse_repeat (dtp))
1230     return;
1231
1232   c = next_char (dtp);
1233   switch (c)
1234     {
1235     case '(':
1236       break;
1237
1238     CASE_SEPARATORS:
1239       unget_char (dtp, c);
1240       eat_separator (dtp);
1241       return;
1242
1243     default:
1244       goto bad_complex;
1245     }
1246
1247   eat_spaces (dtp);
1248   if (parse_real (dtp, dest, kind))
1249     return;
1250
1251 eol_1:
1252   eat_spaces (dtp);
1253   c = next_char (dtp);
1254   if (c == '\n' || c== '\r')
1255     goto eol_1;
1256   else
1257     unget_char (dtp, c);
1258
1259   if (next_char (dtp)
1260       !=  (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
1261     goto bad_complex;
1262
1263 eol_2:
1264   eat_spaces (dtp);
1265   c = next_char (dtp);
1266   if (c == '\n' || c== '\r')
1267     goto eol_2;
1268   else
1269     unget_char (dtp, c);
1270
1271   if (parse_real (dtp, dest + size / 2, kind))
1272     return;
1273
1274   eat_spaces (dtp);
1275   if (next_char (dtp) != ')')
1276     goto bad_complex;
1277
1278   c = next_char (dtp);
1279   if (!is_separator (c))
1280     goto bad_complex;
1281
1282   unget_char (dtp, c);
1283   eat_separator (dtp);
1284
1285   free_saved (dtp);
1286   dtp->u.p.saved_type = BT_COMPLEX;
1287   return;
1288
1289  bad_complex:
1290
1291   if (nml_bad_return (dtp, c))
1292     return;
1293
1294   eat_line (dtp);
1295   free_saved (dtp);
1296   sprintf (message, "Bad complex value in item %d of list input",
1297               dtp->u.p.item_count);
1298   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1299 }
1300
1301
1302 /* Parse a real number with a possible repeat count.  */
1303
1304 static void
1305 read_real (st_parameter_dt *dtp, void * dest, int length)
1306 {
1307   char c, message[100];
1308   int seen_dp;
1309   int is_inf;
1310
1311   seen_dp = 0;
1312
1313   c = next_char (dtp);
1314   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1315     c = '.';
1316   switch (c)
1317     {
1318     CASE_DIGITS:
1319       push_char (dtp, c);
1320       break;
1321
1322     case '.':
1323       push_char (dtp, c);
1324       seen_dp = 1;
1325       break;
1326
1327     case '+':
1328     case '-':
1329       goto got_sign;
1330
1331     CASE_SEPARATORS:
1332       unget_char (dtp, c);              /* Single null.  */
1333       eat_separator (dtp);
1334       return;
1335
1336     case 'i':
1337     case 'I':
1338     case 'n':
1339     case 'N':
1340       goto inf_nan;
1341
1342     default:
1343       goto bad_real;
1344     }
1345
1346   /* Get the digit string that might be a repeat count.  */
1347
1348   for (;;)
1349     {
1350       c = next_char (dtp);
1351       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1352         c = '.';
1353       switch (c)
1354         {
1355         CASE_DIGITS:
1356           push_char (dtp, c);
1357           break;
1358
1359         case '.':
1360           if (seen_dp)
1361             goto bad_real;
1362
1363           seen_dp = 1;
1364           push_char (dtp, c);
1365           goto real_loop;
1366
1367         case 'E':
1368         case 'e':
1369         case 'D':
1370         case 'd':
1371           goto exp1;
1372
1373         case '+':
1374         case '-':
1375           push_char (dtp, 'e');
1376           push_char (dtp, c);
1377           c = next_char (dtp);
1378           goto exp2;
1379
1380         case '*':
1381           push_char (dtp, '\0');
1382           goto got_repeat;
1383
1384         CASE_SEPARATORS:
1385           if (c != '\n' && c != ',' && c != '\r' && c != ';')
1386             unget_char (dtp, c);
1387           goto done;
1388
1389         default:
1390           goto bad_real;
1391         }
1392     }
1393
1394  got_repeat:
1395   if (convert_integer (dtp, -1, 0))
1396     return;
1397
1398   /* Now get the number itself.  */
1399
1400   c = next_char (dtp);
1401   if (is_separator (c))
1402     {                           /* Repeated null value.  */
1403       unget_char (dtp, c);
1404       eat_separator (dtp);
1405       return;
1406     }
1407
1408   if (c != '-' && c != '+')
1409     push_char (dtp, '+');
1410   else
1411     {
1412     got_sign:
1413       push_char (dtp, c);
1414       c = next_char (dtp);
1415     }
1416
1417   if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1418     c = '.';
1419
1420   if (!isdigit (c) && c != '.')
1421     {
1422       if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1423         goto inf_nan;
1424       else
1425         goto bad_real;
1426     }
1427
1428   if (c == '.')
1429     {
1430       if (seen_dp)
1431         goto bad_real;
1432       else
1433         seen_dp = 1;
1434     }
1435
1436   push_char (dtp, c);
1437
1438  real_loop:
1439   for (;;)
1440     {
1441       c = next_char (dtp);
1442       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1443         c = '.';
1444       switch (c)
1445         {
1446         CASE_DIGITS:
1447           push_char (dtp, c);
1448           break;
1449
1450         CASE_SEPARATORS:
1451           goto done;
1452
1453         case '.':
1454           if (seen_dp)
1455             goto bad_real;
1456
1457           seen_dp = 1;
1458           push_char (dtp, c);
1459           break;
1460
1461         case 'E':
1462         case 'e':
1463         case 'D':
1464         case 'd':
1465           goto exp1;
1466
1467         case '+':
1468         case '-':
1469           push_char (dtp, 'e');
1470           push_char (dtp, c);
1471           c = next_char (dtp);
1472           goto exp2;
1473
1474         default:
1475           goto bad_real;
1476         }
1477     }
1478
1479  exp1:
1480   push_char (dtp, 'e');
1481
1482   c = next_char (dtp);
1483   if (c != '+' && c != '-')
1484     push_char (dtp, '+');
1485   else
1486     {
1487       push_char (dtp, c);
1488       c = next_char (dtp);
1489     }
1490
1491  exp2:
1492   if (!isdigit (c))
1493     goto bad_real;
1494   push_char (dtp, c);
1495
1496   for (;;)
1497     {
1498       c = next_char (dtp);
1499
1500       switch (c)
1501         {
1502         CASE_DIGITS:
1503           push_char (dtp, c);
1504           break;
1505
1506         CASE_SEPARATORS:
1507           goto done;
1508
1509         default:
1510           goto bad_real;
1511         }
1512     }
1513
1514  done:
1515   unget_char (dtp, c);
1516   eat_separator (dtp);
1517   push_char (dtp, '\0');
1518   if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
1519     return;
1520
1521   free_saved (dtp);
1522   dtp->u.p.saved_type = BT_REAL;
1523   return;
1524
1525  inf_nan:
1526   l_push_char (dtp, c);
1527   is_inf = 0;
1528
1529   /* Match INF and Infinity.  */
1530   if (c == 'i' || c == 'I')
1531     {
1532       c = next_char (dtp);
1533       l_push_char (dtp, c);
1534       if (c != 'n' && c != 'N')
1535         goto unwind;
1536       c = next_char (dtp);
1537       l_push_char (dtp, c);
1538       if (c != 'f' && c != 'F')
1539         goto unwind;
1540       c = next_char (dtp);
1541       l_push_char (dtp, c);
1542       if (!is_separator (c))
1543         {
1544           if (c != 'i' && c != 'I')
1545             goto unwind;
1546           c = next_char (dtp);
1547           l_push_char (dtp, c);
1548           if (c != 'n' && c != 'N')
1549             goto unwind;
1550           c = next_char (dtp);
1551           l_push_char (dtp, c);
1552           if (c != 'i' && c != 'I')
1553             goto unwind;
1554           c = next_char (dtp);
1555           l_push_char (dtp, c);
1556           if (c != 't' && c != 'T')
1557             goto unwind;
1558           c = next_char (dtp);
1559           l_push_char (dtp, c);
1560           if (c != 'y' && c != 'Y')
1561             goto unwind;
1562           c = next_char (dtp);
1563           l_push_char (dtp, c);
1564         }
1565         is_inf = 1;
1566     } /* Match NaN.  */
1567   else
1568     {
1569       c = next_char (dtp);
1570       l_push_char (dtp, c);
1571       if (c != 'a' && c != 'A')
1572         goto unwind;
1573       c = next_char (dtp);
1574       l_push_char (dtp, c);
1575       if (c != 'n' && c != 'N')
1576         goto unwind;
1577       c = next_char (dtp);
1578       l_push_char (dtp, c);
1579     }
1580
1581   if (!is_separator (c))
1582     goto unwind;
1583
1584   if (dtp->u.p.namelist_mode)
1585     {   
1586       if (c == ' ' || c =='\n' || c == '\r')
1587         {
1588           do
1589             c = next_char (dtp);
1590           while (c == ' ' || c =='\n' || c == '\r');
1591
1592           l_push_char (dtp, c);
1593
1594           if (c == '=')
1595             goto unwind;
1596         }
1597     }
1598
1599   if (is_inf)
1600     {
1601       push_char (dtp, 'i');
1602       push_char (dtp, 'n');
1603       push_char (dtp, 'f');
1604     }
1605   else
1606     {
1607       push_char (dtp, 'n');
1608       push_char (dtp, 'a');
1609       push_char (dtp, 'n');
1610     }
1611
1612   free_line (dtp);
1613   goto done;
1614
1615  unwind:
1616   if (dtp->u.p.namelist_mode)
1617     {
1618       dtp->u.p.nml_read_error = 1;
1619       dtp->u.p.line_buffer_enabled = 1;
1620       dtp->u.p.item_count = 0;
1621       return;
1622     }
1623
1624  bad_real:
1625
1626   if (nml_bad_return (dtp, c))
1627     return;
1628
1629   eat_line (dtp);
1630   free_saved (dtp);
1631   sprintf (message, "Bad real number in item %d of list input",
1632               dtp->u.p.item_count);
1633   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1634 }
1635
1636
1637 /* Check the current type against the saved type to make sure they are
1638    compatible.  Returns nonzero if incompatible.  */
1639
1640 static int
1641 check_type (st_parameter_dt *dtp, bt type, int len)
1642 {
1643   char message[100];
1644
1645   if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
1646     {
1647       sprintf (message, "Read type %s where %s was expected for item %d",
1648                   type_name (dtp->u.p.saved_type), type_name (type),
1649                   dtp->u.p.item_count);
1650
1651       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1652       return 1;
1653     }
1654
1655   if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
1656     return 0;
1657
1658   if (dtp->u.p.saved_length != len)
1659     {
1660       sprintf (message,
1661                   "Read kind %d %s where kind %d is required for item %d",
1662                   dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1663                   dtp->u.p.item_count);
1664       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1665       return 1;
1666     }
1667
1668   return 0;
1669 }
1670
1671
1672 /* Top level data transfer subroutine for list reads.  Because we have
1673    to deal with repeat counts, the data item is always saved after
1674    reading, usually in the dtp->u.p.value[] array.  If a repeat count is
1675    greater than one, we copy the data item multiple times.  */
1676
1677 static void
1678 list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
1679                             int kind, size_t size)
1680 {
1681   char c;
1682   gfc_char4_t *q;
1683   int i, m;
1684   jmp_buf eof_jump;
1685
1686   dtp->u.p.namelist_mode = 0;
1687
1688   dtp->u.p.eof_jump = &eof_jump;
1689   if (setjmp (eof_jump))
1690     {
1691       generate_error (&dtp->common, LIBERROR_END, NULL);
1692       if (!is_internal_unit (dtp))
1693         {
1694           dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
1695           dtp->u.p.current_unit->current_record = 0;
1696         }
1697       goto cleanup;
1698     }
1699
1700   if (dtp->u.p.first_item)
1701     {
1702       dtp->u.p.first_item = 0;
1703       dtp->u.p.input_complete = 0;
1704       dtp->u.p.repeat_count = 1;
1705       dtp->u.p.at_eol = 0;
1706       
1707       c = eat_spaces (dtp);
1708       if (is_separator (c))
1709         {
1710           /* Found a null value.  */
1711           eat_separator (dtp);
1712           dtp->u.p.repeat_count = 0;
1713
1714           /* eat_separator sets this flag if the separator was a comma.  */
1715           if (dtp->u.p.comma_flag)
1716             goto cleanup;
1717
1718           /* eat_separator sets this flag if the separator was a \n or \r.  */
1719           if (dtp->u.p.at_eol)
1720             finish_separator (dtp);
1721           else
1722             goto cleanup;
1723         }
1724
1725     }
1726   else
1727     {
1728       if (dtp->u.p.repeat_count > 0)
1729         {
1730           if (check_type (dtp, type, kind))
1731             return;
1732           goto set_value;
1733         }
1734         
1735       if (dtp->u.p.input_complete)
1736         goto cleanup;
1737
1738       if (dtp->u.p.at_eol)
1739         finish_separator (dtp);
1740       else
1741         {
1742           eat_spaces (dtp);
1743           /* Trailing spaces prior to end of line.  */
1744           if (dtp->u.p.at_eol)
1745             finish_separator (dtp);
1746         }
1747
1748       dtp->u.p.saved_type = BT_NULL;
1749       dtp->u.p.repeat_count = 1;
1750     }
1751
1752   switch (type)
1753     {
1754     case BT_INTEGER:
1755       read_integer (dtp, kind);
1756       break;
1757     case BT_LOGICAL:
1758       read_logical (dtp, kind);
1759       break;
1760     case BT_CHARACTER:
1761       read_character (dtp, kind);
1762       break;
1763     case BT_REAL:
1764       read_real (dtp, p, kind);
1765       /* Copy value back to temporary if needed.  */
1766       if (dtp->u.p.repeat_count > 0)
1767         memcpy (dtp->u.p.value, p, kind);
1768       break;
1769     case BT_COMPLEX:
1770       read_complex (dtp, p, kind, size);
1771       /* Copy value back to temporary if needed.  */
1772       if (dtp->u.p.repeat_count > 0)
1773         memcpy (dtp->u.p.value, p, size);
1774       break;
1775     default:
1776       internal_error (&dtp->common, "Bad type for list read");
1777     }
1778
1779   if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1780     dtp->u.p.saved_length = size;
1781
1782   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1783     goto cleanup;
1784
1785  set_value:
1786   switch (dtp->u.p.saved_type)
1787     {
1788     case BT_COMPLEX:
1789     case BT_REAL:
1790       if (dtp->u.p.repeat_count > 0)
1791         memcpy (p, dtp->u.p.value, size);
1792       break;
1793
1794     case BT_INTEGER:
1795     case BT_LOGICAL:
1796       memcpy (p, dtp->u.p.value, size);
1797       break;
1798
1799     case BT_CHARACTER:
1800       if (dtp->u.p.saved_string)
1801         {
1802           m = ((int) size < dtp->u.p.saved_used)
1803               ? (int) size : dtp->u.p.saved_used;
1804           if (kind == 1)
1805             memcpy (p, dtp->u.p.saved_string, m);
1806           else
1807             {
1808               q = (gfc_char4_t *) p;
1809               for (i = 0; i < m; i++)
1810                 q[i] = (unsigned char) dtp->u.p.saved_string[i];
1811             }
1812         }
1813       else
1814         /* Just delimiters encountered, nothing to copy but SPACE.  */
1815         m = 0;
1816
1817       if (m < (int) size)
1818         {
1819           if (kind == 1)
1820             memset (((char *) p) + m, ' ', size - m);
1821           else
1822             {
1823               q = (gfc_char4_t *) p;
1824               for (i = m; i < (int) size; i++)
1825                 q[i] = (unsigned char) ' ';
1826             }
1827         }
1828       break;
1829
1830     case BT_NULL:
1831       break;
1832     }
1833
1834   if (--dtp->u.p.repeat_count <= 0)
1835     free_saved (dtp);
1836
1837 cleanup:
1838   dtp->u.p.eof_jump = NULL;
1839 }
1840
1841
1842 void
1843 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1844                      size_t size, size_t nelems)
1845 {
1846   size_t elem;
1847   char *tmp;
1848   size_t stride = type == BT_CHARACTER ?
1849                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1850
1851   tmp = (char *) p;
1852
1853   /* Big loop over all the elements.  */
1854   for (elem = 0; elem < nelems; elem++)
1855     {
1856       dtp->u.p.item_count++;
1857       list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
1858     }
1859 }
1860
1861
1862 /* Finish a list read.  */
1863
1864 void
1865 finish_list_read (st_parameter_dt *dtp)
1866 {
1867   char c;
1868
1869   free_saved (dtp);
1870
1871   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
1872
1873   if (dtp->u.p.at_eol)
1874     {
1875       dtp->u.p.at_eol = 0;
1876       return;
1877     }
1878
1879   do
1880     {
1881       c = next_char (dtp);
1882     }
1883   while (c != '\n');
1884
1885   if (dtp->u.p.current_unit->endfile != NO_ENDFILE)
1886     {
1887       generate_error (&dtp->common, LIBERROR_END, NULL);
1888       dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
1889       dtp->u.p.current_unit->current_record = 0;
1890     }
1891 }
1892
1893 /*                      NAMELIST INPUT
1894
1895 void namelist_read (st_parameter_dt *dtp)
1896 calls:
1897    static void nml_match_name (char *name, int len)
1898    static int nml_query (st_parameter_dt *dtp)
1899    static int nml_get_obj_data (st_parameter_dt *dtp,
1900                                 namelist_info **prev_nl, char *, size_t)
1901 calls:
1902       static void nml_untouch_nodes (st_parameter_dt *dtp)
1903       static namelist_info * find_nml_node (st_parameter_dt *dtp,
1904                                             char * var_name)
1905       static int nml_parse_qualifier(descriptor_dimension * ad,
1906                                      array_loop_spec * ls, int rank, char *)
1907       static void nml_touch_nodes (namelist_info * nl)
1908       static int nml_read_obj (namelist_info *nl, index_type offset,
1909                                namelist_info **prev_nl, char *, size_t,
1910                                index_type clow, index_type chigh)
1911 calls:
1912       -itself-  */
1913
1914 /* Inputs a rank-dimensional qualifier, which can contain
1915    singlets, doublets, triplets or ':' with the standard meanings.  */
1916
1917 static try
1918 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1919                      array_loop_spec *ls, int rank, char *parse_err_msg,
1920                      int *parsed_rank)
1921 {
1922   int dim;
1923   int indx;
1924   int neg;
1925   int null_flag;
1926   int is_array_section, is_char;
1927   char c;
1928
1929   is_char = 0;
1930   is_array_section = 0;
1931   dtp->u.p.expanded_read = 0;
1932
1933   /* See if this is a character substring qualifier we are looking for.  */
1934   if (rank == -1)
1935     {
1936       rank = 1;
1937       is_char = 1;
1938     }
1939
1940   /* The next character in the stream should be the '('.  */
1941
1942   c = next_char (dtp);
1943
1944   /* Process the qualifier, by dimension and triplet.  */
1945
1946   for (dim=0; dim < rank; dim++ )
1947     {
1948       for (indx=0; indx<3; indx++)
1949         {
1950           free_saved (dtp);
1951           eat_spaces (dtp);
1952           neg = 0;
1953
1954           /* Process a potential sign.  */
1955           c = next_char (dtp);
1956           switch (c)
1957             {
1958             case '-':
1959               neg = 1;
1960               break;
1961
1962             case '+':
1963               break;
1964
1965             default:
1966               unget_char (dtp, c);
1967               break;
1968             }
1969
1970           /* Process characters up to the next ':' , ',' or ')'.  */
1971           for (;;)
1972             {
1973               c = next_char (dtp);
1974
1975               switch (c)
1976                 {
1977                 case ':':
1978                   is_array_section = 1;
1979                   break;
1980
1981                 case ',': case ')':
1982                   if ((c==',' && dim == rank -1)
1983                       || (c==')' && dim < rank -1))
1984                     {
1985                       if (is_char)
1986                         sprintf (parse_err_msg, "Bad substring qualifier");
1987                       else
1988                         sprintf (parse_err_msg, "Bad number of index fields");
1989                       goto err_ret;
1990                     }
1991                   break;
1992
1993                 CASE_DIGITS:
1994                   push_char (dtp, c);
1995                   continue;
1996
1997                 case ' ': case '\t':
1998                   eat_spaces (dtp);
1999                   c = next_char (dtp);
2000                   break;
2001
2002                 default:
2003                   if (is_char)
2004                     sprintf (parse_err_msg,
2005                              "Bad character in substring qualifier");
2006                   else
2007                     sprintf (parse_err_msg, "Bad character in index");
2008                   goto err_ret;
2009                 }
2010
2011               if ((c == ',' || c == ')') && indx == 0
2012                   && dtp->u.p.saved_string == 0)
2013                 {
2014                   if (is_char)
2015                     sprintf (parse_err_msg, "Null substring qualifier");
2016                   else
2017                     sprintf (parse_err_msg, "Null index field");
2018                   goto err_ret;
2019                 }
2020
2021               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2022                   || (indx == 2 && dtp->u.p.saved_string == 0))
2023                 {
2024                   if (is_char)
2025                     sprintf (parse_err_msg, "Bad substring qualifier");
2026                   else
2027                     sprintf (parse_err_msg, "Bad index triplet");
2028                   goto err_ret;
2029                 }
2030
2031               if (is_char && !is_array_section)
2032                 {
2033                   sprintf (parse_err_msg,
2034                            "Missing colon in substring qualifier");
2035                   goto err_ret;
2036                 }
2037
2038               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
2039               null_flag = 0;
2040               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2041                   || (indx==1 && dtp->u.p.saved_string == 0))
2042                 {
2043                   null_flag = 1;
2044                   break;
2045                 }
2046
2047               /* Now read the index.  */
2048               if (convert_integer (dtp, sizeof(ssize_t), neg))
2049                 {
2050                   if (is_char)
2051                     sprintf (parse_err_msg, "Bad integer substring qualifier");
2052                   else
2053                     sprintf (parse_err_msg, "Bad integer in index");
2054                   goto err_ret;
2055                 }
2056               break;
2057             }
2058
2059           /* Feed the index values to the triplet arrays.  */
2060           if (!null_flag)
2061             {
2062               if (indx == 0)
2063                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2064               if (indx == 1)
2065                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2066               if (indx == 2)
2067                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2068             }
2069
2070           /* Singlet or doublet indices.  */
2071           if (c==',' || c==')')
2072             {
2073               if (indx == 0)
2074                 {
2075                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2076
2077                   /*  If -std=f95/2003 or an array section is specified,
2078                       do not allow excess data to be processed.  */
2079                   if (is_array_section == 1
2080                       || compile_options.allow_std < GFC_STD_GNU)
2081                     ls[dim].end = ls[dim].start;
2082                   else
2083                     dtp->u.p.expanded_read = 1;
2084                 }
2085
2086               /* Check for non-zero rank.  */
2087               if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2088                 *parsed_rank = 1;
2089
2090               break;
2091             }
2092         }
2093
2094       if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2095         {
2096           int i;
2097           dtp->u.p.expanded_read = 0;
2098           for (i = 0; i < dim; i++)
2099             ls[i].end = ls[i].start;
2100         }
2101
2102       /* Check the values of the triplet indices.  */
2103       if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2104            || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))
2105            || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2106            || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])))
2107         {
2108           if (is_char)
2109             sprintf (parse_err_msg, "Substring out of range");
2110           else
2111             sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2112           goto err_ret;
2113         }
2114
2115       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2116           || (ls[dim].step == 0))
2117         {
2118           sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2119           goto err_ret;
2120         }
2121
2122       /* Initialise the loop index counter.  */
2123       ls[dim].idx = ls[dim].start;
2124     }
2125   eat_spaces (dtp);
2126   return SUCCESS;
2127
2128 err_ret:
2129
2130   return FAILURE;
2131 }
2132
2133 static namelist_info *
2134 find_nml_node (st_parameter_dt *dtp, char * var_name)
2135 {
2136   namelist_info * t = dtp->u.p.ionml;
2137   while (t != NULL)
2138     {
2139       if (strcmp (var_name, t->var_name) == 0)
2140         {
2141           t->touched = 1;
2142           return t;
2143         }
2144       t = t->next;
2145     }
2146   return NULL;
2147 }
2148
2149 /* Visits all the components of a derived type that have
2150    not explicitly been identified in the namelist input.
2151    touched is set and the loop specification initialised
2152    to default values  */
2153
2154 static void
2155 nml_touch_nodes (namelist_info * nl)
2156 {
2157   index_type len = strlen (nl->var_name) + 1;
2158   int dim;
2159   char * ext_name = (char*)get_mem (len + 1);
2160   memcpy (ext_name, nl->var_name, len-1);
2161   memcpy (ext_name + len - 1, "%", 2);
2162   for (nl = nl->next; nl; nl = nl->next)
2163     {
2164       if (strncmp (nl->var_name, ext_name, len) == 0)
2165         {
2166           nl->touched = 1;
2167           for (dim=0; dim < nl->var_rank; dim++)
2168             {
2169               nl->ls[dim].step = 1;
2170               nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2171               nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2172               nl->ls[dim].idx = nl->ls[dim].start;
2173             }
2174         }
2175       else
2176         break;
2177     }
2178   free (ext_name);
2179   return;
2180 }
2181
2182 /* Resets touched for the entire list of nml_nodes, ready for a
2183    new object.  */
2184
2185 static void
2186 nml_untouch_nodes (st_parameter_dt *dtp)
2187 {
2188   namelist_info * t;
2189   for (t = dtp->u.p.ionml; t; t = t->next)
2190     t->touched = 0;
2191   return;
2192 }
2193
2194 /* Attempts to input name to namelist name.  Returns
2195    dtp->u.p.nml_read_error = 1 on no match.  */
2196
2197 static void
2198 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2199 {
2200   index_type i;
2201   char c;
2202   dtp->u.p.nml_read_error = 0;
2203   for (i = 0; i < len; i++)
2204     {
2205       c = next_char (dtp);
2206       if (tolower (c) != tolower (name[i]))
2207         {
2208           dtp->u.p.nml_read_error = 1;
2209           break;
2210         }
2211     }
2212 }
2213
2214 /* If the namelist read is from stdin, output the current state of the
2215    namelist to stdout.  This is used to implement the non-standard query
2216    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2217    the names alone are printed.  */
2218
2219 static void
2220 nml_query (st_parameter_dt *dtp, char c)
2221 {
2222   gfc_unit * temp_unit;
2223   namelist_info * nl;
2224   index_type len;
2225   char * p;
2226 #ifdef HAVE_CRLF
2227   static const index_type endlen = 3;
2228   static const char endl[] = "\r\n";
2229   static const char nmlend[] = "&end\r\n";
2230 #else
2231   static const index_type endlen = 2;
2232   static const char endl[] = "\n";
2233   static const char nmlend[] = "&end\n";
2234 #endif
2235
2236   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2237     return;
2238
2239   /* Store the current unit and transfer to stdout.  */
2240
2241   temp_unit = dtp->u.p.current_unit;
2242   dtp->u.p.current_unit = find_unit (options.stdout_unit);
2243
2244   if (dtp->u.p.current_unit)
2245     {
2246       dtp->u.p.mode = WRITING;
2247       next_record (dtp, 0);
2248
2249       /* Write the namelist in its entirety.  */
2250
2251       if (c == '=')
2252         namelist_write (dtp);
2253
2254       /* Or write the list of names.  */
2255
2256       else
2257         {
2258           /* "&namelist_name\n"  */
2259
2260           len = dtp->namelist_name_len;
2261           p = write_block (dtp, len + endlen);
2262           if (!p)
2263             goto query_return;
2264           memcpy (p, "&", 1);
2265           memcpy ((char*)(p + 1), dtp->namelist_name, len);
2266           memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2267           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2268             {
2269               /* " var_name\n"  */
2270
2271               len = strlen (nl->var_name);
2272               p = write_block (dtp, len + endlen);
2273               if (!p)
2274                 goto query_return;
2275               memcpy (p, " ", 1);
2276               memcpy ((char*)(p + 1), nl->var_name, len);
2277               memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2278             }
2279
2280           /* "&end\n"  */
2281
2282           p = write_block (dtp, endlen + 3);
2283             goto query_return;
2284           memcpy (p, &nmlend, endlen + 3);
2285         }
2286
2287       /* Flush the stream to force immediate output.  */
2288
2289       fbuf_flush (dtp->u.p.current_unit, WRITING);
2290       sflush (dtp->u.p.current_unit->s);
2291       unlock_unit (dtp->u.p.current_unit);
2292     }
2293
2294 query_return:
2295
2296   /* Restore the current unit.  */
2297
2298   dtp->u.p.current_unit = temp_unit;
2299   dtp->u.p.mode = READING;
2300   return;
2301 }
2302
2303 /* Reads and stores the input for the namelist object nl.  For an array,
2304    the function loops over the ranges defined by the loop specification.
2305    This default to all the data or to the specification from a qualifier.
2306    nml_read_obj recursively calls itself to read derived types. It visits
2307    all its own components but only reads data for those that were touched
2308    when the name was parsed.  If a read error is encountered, an attempt is
2309    made to return to read a new object name because the standard allows too
2310    little data to be available.  On the other hand, too much data is an
2311    error.  */
2312
2313 static try
2314 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2315               namelist_info **pprev_nl, char *nml_err_msg,
2316               size_t nml_err_msg_size, index_type clow, index_type chigh)
2317 {
2318   namelist_info * cmp;
2319   char * obj_name;
2320   int nml_carry;
2321   int len;
2322   int dim;
2323   index_type dlen;
2324   index_type m;
2325   size_t obj_name_len;
2326   void * pdata;
2327
2328   /* This object not touched in name parsing.  */
2329
2330   if (!nl->touched)
2331     return SUCCESS;
2332
2333   dtp->u.p.repeat_count = 0;
2334   eat_spaces (dtp);
2335
2336   len = nl->len;
2337   switch (nl->type)
2338   {
2339     case GFC_DTYPE_INTEGER:
2340     case GFC_DTYPE_LOGICAL:
2341       dlen = len;
2342       break;
2343
2344     case GFC_DTYPE_REAL:
2345       dlen = size_from_real_kind (len);
2346       break;
2347
2348     case GFC_DTYPE_COMPLEX:
2349       dlen = size_from_complex_kind (len);
2350       break;
2351
2352     case GFC_DTYPE_CHARACTER:
2353       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2354       break;
2355
2356     default:
2357       dlen = 0;
2358     }
2359
2360   do
2361     {
2362       /* Update the pointer to the data, using the current index vector  */
2363
2364       pdata = (void*)(nl->mem_pos + offset);
2365       for (dim = 0; dim < nl->var_rank; dim++)
2366         pdata = (void*)(pdata + (nl->ls[dim].idx
2367                                  - GFC_DESCRIPTOR_LBOUND(nl,dim))
2368                         * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2369
2370       /* Reset the error flag and try to read next value, if
2371          dtp->u.p.repeat_count=0  */
2372
2373       dtp->u.p.nml_read_error = 0;
2374       nml_carry = 0;
2375       if (--dtp->u.p.repeat_count <= 0)
2376         {
2377           if (dtp->u.p.input_complete)
2378             return SUCCESS;
2379           if (dtp->u.p.at_eol)
2380             finish_separator (dtp);
2381           if (dtp->u.p.input_complete)
2382             return SUCCESS;
2383
2384           /* BT_NULL (equivalent to GFC_DTYPE_UNKNOWN) falls through
2385              for nulls and is detected at default: of switch block.  */
2386
2387           dtp->u.p.saved_type = BT_NULL;
2388           free_saved (dtp);
2389
2390           switch (nl->type)
2391           {
2392           case GFC_DTYPE_INTEGER:
2393               read_integer (dtp, len);
2394               break;
2395
2396           case GFC_DTYPE_LOGICAL:
2397               read_logical (dtp, len);
2398               break;
2399
2400           case GFC_DTYPE_CHARACTER:
2401               read_character (dtp, len);
2402               break;
2403
2404           case GFC_DTYPE_REAL:
2405             /* Need to copy data back from the real location to the temp in order
2406                to handle nml reads into arrays.  */
2407             read_real (dtp, pdata, len);
2408             memcpy (dtp->u.p.value, pdata, dlen);
2409             break;
2410
2411           case GFC_DTYPE_COMPLEX:
2412             /* Same as for REAL, copy back to temp.  */
2413             read_complex (dtp, pdata, len, dlen);
2414             memcpy (dtp->u.p.value, pdata, dlen);
2415             break;
2416
2417           case GFC_DTYPE_DERIVED:
2418             obj_name_len = strlen (nl->var_name) + 1;
2419             obj_name = get_mem (obj_name_len+1);
2420             memcpy (obj_name, nl->var_name, obj_name_len-1);
2421             memcpy (obj_name + obj_name_len - 1, "%", 2);
2422
2423             /* If reading a derived type, disable the expanded read warning
2424                since a single object can have multiple reads.  */
2425             dtp->u.p.expanded_read = 0;
2426
2427             /* Now loop over the components. Update the component pointer
2428                with the return value from nml_write_obj.  This loop jumps
2429                past nested derived types by testing if the potential
2430                component name contains '%'.  */
2431
2432             for (cmp = nl->next;
2433                  cmp &&
2434                    !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2435                    !strchr (cmp->var_name + obj_name_len, '%');
2436                  cmp = cmp->next)
2437               {
2438
2439                 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2440                                   pprev_nl, nml_err_msg, nml_err_msg_size,
2441                                   clow, chigh) == FAILURE)
2442                   {
2443                     free (obj_name);
2444                     return FAILURE;
2445                   }
2446
2447                 if (dtp->u.p.input_complete)
2448                   {
2449                     free (obj_name);
2450                     return SUCCESS;
2451                   }
2452               }
2453
2454             free (obj_name);
2455             goto incr_idx;
2456
2457           default:
2458             snprintf (nml_err_msg, nml_err_msg_size,
2459                       "Bad type for namelist object %s", nl->var_name);
2460             internal_error (&dtp->common, nml_err_msg);
2461             goto nml_err_ret;
2462           }
2463         }
2464
2465       /* The standard permits array data to stop short of the number of
2466          elements specified in the loop specification.  In this case, we
2467          should be here with dtp->u.p.nml_read_error != 0.  Control returns to
2468          nml_get_obj_data and an attempt is made to read object name.  */
2469
2470       *pprev_nl = nl;
2471       if (dtp->u.p.nml_read_error)
2472         {
2473           dtp->u.p.expanded_read = 0;
2474           return SUCCESS;
2475         }
2476
2477       if (dtp->u.p.saved_type == BT_NULL)
2478         {
2479           dtp->u.p.expanded_read = 0;
2480           goto incr_idx;
2481         }
2482
2483       /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2484          This comes about because the read functions return BT_types.  */
2485
2486       switch (dtp->u.p.saved_type)
2487       {
2488
2489         case BT_COMPLEX:
2490         case BT_REAL:
2491         case BT_INTEGER:
2492         case BT_LOGICAL:
2493           memcpy (pdata, dtp->u.p.value, dlen);
2494           break;
2495
2496         case BT_CHARACTER:
2497           m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2498           pdata = (void*)( pdata + clow - 1 );
2499           memcpy (pdata, dtp->u.p.saved_string, m);
2500           if (m < dlen)
2501             memset ((void*)( pdata + m ), ' ', dlen - m);
2502           break;
2503
2504         default:
2505           break;
2506       }
2507
2508       /* Warn if a non-standard expanded read occurs. A single read of a
2509          single object is acceptable.  If a second read occurs, issue a warning
2510          and set the flag to zero to prevent further warnings.  */
2511       if (dtp->u.p.expanded_read == 2)
2512         {
2513           notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2514           dtp->u.p.expanded_read = 0;
2515         }
2516
2517       /* If the expanded read warning flag is set, increment it,
2518          indicating that a single read has occurred.  */
2519       if (dtp->u.p.expanded_read >= 1)
2520         dtp->u.p.expanded_read++;
2521
2522       /* Break out of loop if scalar.  */
2523       if (!nl->var_rank)
2524         break;
2525
2526       /* Now increment the index vector.  */
2527
2528 incr_idx:
2529
2530       nml_carry = 1;
2531       for (dim = 0; dim < nl->var_rank; dim++)
2532         {
2533           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2534           nml_carry = 0;
2535           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2536               ||
2537               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2538             {
2539               nl->ls[dim].idx = nl->ls[dim].start;
2540               nml_carry = 1;
2541             }
2542         }
2543     } while (!nml_carry);
2544
2545   if (dtp->u.p.repeat_count > 1)
2546     {
2547       snprintf (nml_err_msg, nml_err_msg_size,
2548                 "Repeat count too large for namelist object %s", nl->var_name);
2549       goto nml_err_ret;
2550     }
2551   return SUCCESS;
2552
2553 nml_err_ret:
2554
2555   return FAILURE;
2556 }
2557
2558 /* Parses the object name, including array and substring qualifiers.  It
2559    iterates over derived type components, touching those components and
2560    setting their loop specifications, if there is a qualifier.  If the
2561    object is itself a derived type, its components and subcomponents are
2562    touched.  nml_read_obj is called at the end and this reads the data in
2563    the manner specified by the object name.  */
2564
2565 static try
2566 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2567                   char *nml_err_msg, size_t nml_err_msg_size)
2568 {
2569   char c;
2570   namelist_info * nl;
2571   namelist_info * first_nl = NULL;
2572   namelist_info * root_nl = NULL;
2573   int dim, parsed_rank;
2574   int component_flag, qualifier_flag;
2575   index_type clow, chigh;
2576   int non_zero_rank_count;
2577
2578   /* Look for end of input or object name.  If '?' or '=?' are encountered
2579      in stdin, print the node names or the namelist to stdout.  */
2580
2581   eat_separator (dtp);
2582   if (dtp->u.p.input_complete)
2583     return SUCCESS;
2584
2585   if (dtp->u.p.at_eol)
2586     finish_separator (dtp);
2587   if (dtp->u.p.input_complete)
2588     return SUCCESS;
2589
2590   c = next_char (dtp);
2591   switch (c)
2592     {
2593     case '=':
2594       c = next_char (dtp);
2595       if (c != '?')
2596         {
2597           sprintf (nml_err_msg, "namelist read: misplaced = sign");
2598           goto nml_err_ret;
2599         }
2600       nml_query (dtp, '=');
2601       return SUCCESS;
2602
2603     case '?':
2604       nml_query (dtp, '?');
2605       return SUCCESS;
2606
2607     case '$':
2608     case '&':
2609       nml_match_name (dtp, "end", 3);
2610       if (dtp->u.p.nml_read_error)
2611         {
2612           sprintf (nml_err_msg, "namelist not terminated with / or &end");
2613           goto nml_err_ret;
2614         }
2615     case '/':
2616       dtp->u.p.input_complete = 1;
2617       return SUCCESS;
2618
2619     default :
2620       break;
2621     }
2622
2623   /* Untouch all nodes of the namelist and reset the flags that are set for
2624      derived type components.  */
2625
2626   nml_untouch_nodes (dtp);
2627   component_flag = 0;
2628   qualifier_flag = 0;
2629   non_zero_rank_count = 0;
2630
2631   /* Get the object name - should '!' and '\n' be permitted separators?  */
2632
2633 get_name:
2634
2635   free_saved (dtp);
2636
2637   do
2638     {
2639       if (!is_separator (c))
2640         push_char (dtp, tolower(c));
2641       c = next_char (dtp);
2642     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2643
2644   unget_char (dtp, c);
2645
2646   /* Check that the name is in the namelist and get pointer to object.
2647      Three error conditions exist: (i) An attempt is being made to
2648      identify a non-existent object, following a failed data read or
2649      (ii) The object name does not exist or (iii) Too many data items
2650      are present for an object.  (iii) gives the same error message
2651      as (i)  */
2652
2653   push_char (dtp, '\0');
2654
2655   if (component_flag)
2656     {
2657       size_t var_len = strlen (root_nl->var_name);
2658       size_t saved_len
2659         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2660       char ext_name[var_len + saved_len + 1];
2661
2662       memcpy (ext_name, root_nl->var_name, var_len);
2663       if (dtp->u.p.saved_string)
2664         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2665       ext_name[var_len + saved_len] = '\0';
2666       nl = find_nml_node (dtp, ext_name);
2667     }
2668   else
2669     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2670
2671   if (nl == NULL)
2672     {
2673       if (dtp->u.p.nml_read_error && *pprev_nl)
2674         snprintf (nml_err_msg, nml_err_msg_size,
2675                   "Bad data for namelist object %s", (*pprev_nl)->var_name);
2676
2677       else
2678         snprintf (nml_err_msg, nml_err_msg_size,
2679                   "Cannot match namelist object name %s",
2680                   dtp->u.p.saved_string);
2681
2682       goto nml_err_ret;
2683     }
2684
2685   /* Get the length, data length, base pointer and rank of the variable.
2686      Set the default loop specification first.  */
2687
2688   for (dim=0; dim < nl->var_rank; dim++)
2689     {
2690       nl->ls[dim].step = 1;
2691       nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2692       nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2693       nl->ls[dim].idx = nl->ls[dim].start;
2694     }
2695
2696 /* Check to see if there is a qualifier: if so, parse it.*/
2697
2698   if (c == '(' && nl->var_rank)
2699     {
2700       parsed_rank = 0;
2701       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2702                                nml_err_msg, &parsed_rank) == FAILURE)
2703         {
2704           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2705           snprintf (nml_err_msg_end,
2706                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2707                     " for namelist variable %s", nl->var_name);
2708           goto nml_err_ret;
2709         }
2710       if (parsed_rank > 0)
2711         non_zero_rank_count++;
2712
2713       qualifier_flag = 1;
2714
2715       c = next_char (dtp);
2716       unget_char (dtp, c);
2717     }
2718   else if (nl->var_rank > 0)
2719     non_zero_rank_count++;
2720
2721   /* Now parse a derived type component. The root namelist_info address
2722      is backed up, as is the previous component level.  The  component flag
2723      is set and the iteration is made by jumping back to get_name.  */
2724
2725   if (c == '%')
2726     {
2727       if (nl->type != GFC_DTYPE_DERIVED)
2728         {
2729           snprintf (nml_err_msg, nml_err_msg_size,
2730                     "Attempt to get derived component for %s", nl->var_name);
2731           goto nml_err_ret;
2732         }
2733
2734       if (!component_flag)
2735         first_nl = nl;
2736
2737       root_nl = nl;
2738       component_flag = 1;
2739
2740       c = next_char (dtp);
2741       goto get_name;
2742     }
2743
2744   /* Parse a character qualifier, if present.  chigh = 0 is a default
2745      that signals that the string length = string_length.  */
2746
2747   clow = 1;
2748   chigh = 0;
2749
2750   if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2751     {
2752       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2753       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2754
2755       if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
2756           == FAILURE)
2757         {
2758           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2759           snprintf (nml_err_msg_end,
2760                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2761                     " for namelist variable %s", nl->var_name);
2762           goto nml_err_ret;
2763         }
2764
2765       clow = ind[0].start;
2766       chigh = ind[0].end;
2767
2768       if (ind[0].step != 1)
2769         {
2770           snprintf (nml_err_msg, nml_err_msg_size,
2771                     "Step not allowed in substring qualifier"
2772                     " for namelist object %s", nl->var_name);
2773           goto nml_err_ret;
2774         }
2775
2776       c = next_char (dtp);
2777       unget_char (dtp, c);
2778     }
2779
2780   /* Make sure no extraneous qualifiers are there.  */
2781
2782   if (c == '(')
2783     {
2784       snprintf (nml_err_msg, nml_err_msg_size,
2785                 "Qualifier for a scalar or non-character namelist object %s",
2786                 nl->var_name);
2787       goto nml_err_ret;
2788     }
2789
2790   /* Make sure there is no more than one non-zero rank object.  */
2791   if (non_zero_rank_count > 1)
2792     {
2793       snprintf (nml_err_msg, nml_err_msg_size,
2794                 "Multiple sub-objects with non-zero rank in namelist object %s",
2795                 nl->var_name);
2796       non_zero_rank_count = 0;
2797       goto nml_err_ret;
2798     }
2799
2800 /* According to the standard, an equal sign MUST follow an object name. The
2801    following is possibly lax - it allows comments, blank lines and so on to
2802    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2803
2804   free_saved (dtp);
2805
2806   eat_separator (dtp);
2807   if (dtp->u.p.input_complete)
2808     return SUCCESS;
2809
2810   if (dtp->u.p.at_eol)
2811     finish_separator (dtp);
2812   if (dtp->u.p.input_complete)
2813     return SUCCESS;
2814
2815   c = next_char (dtp);
2816
2817   if (c != '=')
2818     {
2819       snprintf (nml_err_msg, nml_err_msg_size,
2820                 "Equal sign must follow namelist object name %s",
2821                 nl->var_name);
2822       goto nml_err_ret;
2823     }
2824   /* If a derived type, touch its components and restore the root
2825      namelist_info if we have parsed a qualified derived type
2826      component.  */
2827
2828   if (nl->type == GFC_DTYPE_DERIVED)
2829     nml_touch_nodes (nl);
2830
2831   if (first_nl)
2832     {
2833       if (first_nl->var_rank == 0)
2834         {
2835           if (component_flag && qualifier_flag)
2836             nl = first_nl;
2837         }
2838       else
2839         nl = first_nl;
2840     }
2841
2842   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
2843                     clow, chigh) == FAILURE)
2844     goto nml_err_ret;
2845
2846   return SUCCESS;
2847
2848 nml_err_ret:
2849
2850   return FAILURE;
2851 }
2852
2853 /* Entry point for namelist input.  Goes through input until namelist name
2854   is matched.  Then cycles through nml_get_obj_data until the input is
2855   completed or there is an error.  */
2856
2857 void
2858 namelist_read (st_parameter_dt *dtp)
2859 {
2860   char c;
2861   jmp_buf eof_jump;
2862   char nml_err_msg[200];
2863   /* Pointer to the previously read object, in case attempt is made to read
2864      new object name.  Should this fail, error message can give previous
2865      name.  */
2866   namelist_info *prev_nl = NULL;
2867
2868   dtp->u.p.namelist_mode = 1;
2869   dtp->u.p.input_complete = 0;
2870   dtp->u.p.expanded_read = 0;
2871
2872   dtp->u.p.eof_jump = &eof_jump;
2873   if (setjmp (eof_jump))
2874     {
2875       dtp->u.p.eof_jump = NULL;
2876       generate_error (&dtp->common, LIBERROR_END, NULL);
2877       return;
2878     }
2879
2880   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
2881      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2882      node names or namelist on stdout.  */
2883
2884 find_nml_name:
2885   switch (c = next_char (dtp))
2886     {
2887     case '$':
2888     case '&':
2889           break;
2890
2891     case '!':
2892       eat_line (dtp);
2893       goto find_nml_name;
2894
2895     case '=':
2896       c = next_char (dtp);
2897       if (c == '?')
2898         nml_query (dtp, '=');
2899       else
2900         unget_char (dtp, c);
2901       goto find_nml_name;
2902
2903     case '?':
2904       nml_query (dtp, '?');
2905
2906     default:
2907       goto find_nml_name;
2908     }
2909
2910   /* Match the name of the namelist.  */
2911
2912   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2913
2914   if (dtp->u.p.nml_read_error)
2915     goto find_nml_name;
2916
2917   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
2918   c = next_char (dtp);
2919   if (!is_separator(c) && c != '!')
2920     {
2921       unget_char (dtp, c);
2922       goto find_nml_name;
2923     }
2924
2925   unget_char (dtp, c);
2926   eat_separator (dtp);
2927
2928   /* Ready to read namelist objects.  If there is an error in input
2929      from stdin, output the error message and continue.  */
2930
2931   while (!dtp->u.p.input_complete)
2932     {
2933       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
2934                             == FAILURE)
2935         {
2936           gfc_unit *u;
2937
2938           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2939             goto nml_err_ret;
2940
2941           u = find_unit (options.stderr_unit);
2942           st_printf ("%s\n", nml_err_msg);
2943           if (u != NULL)
2944             {
2945               sflush (u->s);
2946               unlock_unit (u);
2947             }
2948         }
2949
2950    }
2951
2952   dtp->u.p.eof_jump = NULL;
2953   free_saved (dtp);
2954   free_line (dtp);
2955   return;
2956
2957   /* All namelist error calls return from here */
2958
2959 nml_err_ret:
2960
2961   dtp->u.p.eof_jump = NULL;
2962   free_saved (dtp);
2963   free_line (dtp);
2964   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
2965   return;
2966 }