OSDN Git Service

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