OSDN Git Service

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