OSDN Git Service

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