OSDN Git Service

2010-06-28 Tobias Burnus <burnus@net-b.de>
[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_NULL && 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_NULL || 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_NULL;
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_NULL)
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_NULL:
1857       break;
1858     }
1859
1860   if (--dtp->u.p.repeat_count <= 0)
1861     free_saved (dtp);
1862
1863 cleanup:
1864   dtp->u.p.eof_jump = NULL;
1865 }
1866
1867
1868 void
1869 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1870                      size_t size, size_t nelems)
1871 {
1872   size_t elem;
1873   char *tmp;
1874   size_t stride = type == BT_CHARACTER ?
1875                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1876
1877   tmp = (char *) p;
1878
1879   /* Big loop over all the elements.  */
1880   for (elem = 0; elem < nelems; elem++)
1881     {
1882       dtp->u.p.item_count++;
1883       list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
1884     }
1885 }
1886
1887
1888 /* Finish a list read.  */
1889
1890 void
1891 finish_list_read (st_parameter_dt *dtp)
1892 {
1893   char c;
1894
1895   free_saved (dtp);
1896
1897   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
1898
1899   if (dtp->u.p.at_eol)
1900     {
1901       dtp->u.p.at_eol = 0;
1902       return;
1903     }
1904
1905   do
1906     {
1907       c = next_char (dtp);
1908     }
1909   while (c != '\n');
1910
1911   if (dtp->u.p.current_unit->endfile != NO_ENDFILE)
1912     {
1913       generate_error (&dtp->common, LIBERROR_END, NULL);
1914       dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
1915       dtp->u.p.current_unit->current_record = 0;
1916     }
1917 }
1918
1919 /*                      NAMELIST INPUT
1920
1921 void namelist_read (st_parameter_dt *dtp)
1922 calls:
1923    static void nml_match_name (char *name, int len)
1924    static int nml_query (st_parameter_dt *dtp)
1925    static int nml_get_obj_data (st_parameter_dt *dtp,
1926                                 namelist_info **prev_nl, char *, size_t)
1927 calls:
1928       static void nml_untouch_nodes (st_parameter_dt *dtp)
1929       static namelist_info * find_nml_node (st_parameter_dt *dtp,
1930                                             char * var_name)
1931       static int nml_parse_qualifier(descriptor_dimension * ad,
1932                                      array_loop_spec * ls, int rank, char *)
1933       static void nml_touch_nodes (namelist_info * nl)
1934       static int nml_read_obj (namelist_info *nl, index_type offset,
1935                                namelist_info **prev_nl, char *, size_t,
1936                                index_type clow, index_type chigh)
1937 calls:
1938       -itself-  */
1939
1940 /* Inputs a rank-dimensional qualifier, which can contain
1941    singlets, doublets, triplets or ':' with the standard meanings.  */
1942
1943 static try
1944 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1945                      array_loop_spec *ls, int rank, char *parse_err_msg,
1946                      int *parsed_rank)
1947 {
1948   int dim;
1949   int indx;
1950   int neg;
1951   int null_flag;
1952   int is_array_section, is_char;
1953   char c;
1954
1955   is_char = 0;
1956   is_array_section = 0;
1957   dtp->u.p.expanded_read = 0;
1958
1959   /* See if this is a character substring qualifier we are looking for.  */
1960   if (rank == -1)
1961     {
1962       rank = 1;
1963       is_char = 1;
1964     }
1965
1966   /* The next character in the stream should be the '('.  */
1967
1968   c = next_char (dtp);
1969
1970   /* Process the qualifier, by dimension and triplet.  */
1971
1972   for (dim=0; dim < rank; dim++ )
1973     {
1974       for (indx=0; indx<3; indx++)
1975         {
1976           free_saved (dtp);
1977           eat_spaces (dtp);
1978           neg = 0;
1979
1980           /* Process a potential sign.  */
1981           c = next_char (dtp);
1982           switch (c)
1983             {
1984             case '-':
1985               neg = 1;
1986               break;
1987
1988             case '+':
1989               break;
1990
1991             default:
1992               unget_char (dtp, c);
1993               break;
1994             }
1995
1996           /* Process characters up to the next ':' , ',' or ')'.  */
1997           for (;;)
1998             {
1999               c = next_char (dtp);
2000
2001               switch (c)
2002                 {
2003                 case ':':
2004                   is_array_section = 1;
2005                   break;
2006
2007                 case ',': case ')':
2008                   if ((c==',' && dim == rank -1)
2009                       || (c==')' && dim < rank -1))
2010                     {
2011                       if (is_char)
2012                         sprintf (parse_err_msg, "Bad substring qualifier");
2013                       else
2014                         sprintf (parse_err_msg, "Bad number of index fields");
2015                       goto err_ret;
2016                     }
2017                   break;
2018
2019                 CASE_DIGITS:
2020                   push_char (dtp, c);
2021                   continue;
2022
2023                 case ' ': case '\t':
2024                   eat_spaces (dtp);
2025                   c = next_char (dtp);
2026                   break;
2027
2028                 default:
2029                   if (is_char)
2030                     sprintf (parse_err_msg,
2031                              "Bad character in substring qualifier");
2032                   else
2033                     sprintf (parse_err_msg, "Bad character in index");
2034                   goto err_ret;
2035                 }
2036
2037               if ((c == ',' || c == ')') && indx == 0
2038                   && dtp->u.p.saved_string == 0)
2039                 {
2040                   if (is_char)
2041                     sprintf (parse_err_msg, "Null substring qualifier");
2042                   else
2043                     sprintf (parse_err_msg, "Null index field");
2044                   goto err_ret;
2045                 }
2046
2047               if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2048                   || (indx == 2 && dtp->u.p.saved_string == 0))
2049                 {
2050                   if (is_char)
2051                     sprintf (parse_err_msg, "Bad substring qualifier");
2052                   else
2053                     sprintf (parse_err_msg, "Bad index triplet");
2054                   goto err_ret;
2055                 }
2056
2057               if (is_char && !is_array_section)
2058                 {
2059                   sprintf (parse_err_msg,
2060                            "Missing colon in substring qualifier");
2061                   goto err_ret;
2062                 }
2063
2064               /* If '( : ? )' or '( ? : )' break and flag read failure.  */
2065               null_flag = 0;
2066               if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2067                   || (indx==1 && dtp->u.p.saved_string == 0))
2068                 {
2069                   null_flag = 1;
2070                   break;
2071                 }
2072
2073               /* Now read the index.  */
2074               if (convert_integer (dtp, sizeof(ssize_t), neg))
2075                 {
2076                   if (is_char)
2077                     sprintf (parse_err_msg, "Bad integer substring qualifier");
2078                   else
2079                     sprintf (parse_err_msg, "Bad integer in index");
2080                   goto err_ret;
2081                 }
2082               break;
2083             }
2084
2085           /* Feed the index values to the triplet arrays.  */
2086           if (!null_flag)
2087             {
2088               if (indx == 0)
2089                 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2090               if (indx == 1)
2091                 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2092               if (indx == 2)
2093                 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2094             }
2095
2096           /* Singlet or doublet indices.  */
2097           if (c==',' || c==')')
2098             {
2099               if (indx == 0)
2100                 {
2101                   memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2102
2103                   /*  If -std=f95/2003 or an array section is specified,
2104                       do not allow excess data to be processed.  */
2105                   if (is_array_section == 1
2106                       || !(compile_options.allow_std & GFC_STD_GNU))
2107                     ls[dim].end = ls[dim].start;
2108                   else
2109                     dtp->u.p.expanded_read = 1;
2110                 }
2111
2112               /* Check for non-zero rank.  */
2113               if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2114                 *parsed_rank = 1;
2115
2116               break;
2117             }
2118         }
2119
2120       if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2121         {
2122           int i;
2123           dtp->u.p.expanded_read = 0;
2124           for (i = 0; i < dim; i++)
2125             ls[i].end = ls[i].start;
2126         }
2127
2128       /* Check the values of the triplet indices.  */
2129       if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2130            || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))
2131            || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
2132            || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])))
2133         {
2134           if (is_char)
2135             sprintf (parse_err_msg, "Substring out of range");
2136           else
2137             sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2138           goto err_ret;
2139         }
2140
2141       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2142           || (ls[dim].step == 0))
2143         {
2144           sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2145           goto err_ret;
2146         }
2147
2148       /* Initialise the loop index counter.  */
2149       ls[dim].idx = ls[dim].start;
2150     }
2151   eat_spaces (dtp);
2152   return SUCCESS;
2153
2154 err_ret:
2155
2156   return FAILURE;
2157 }
2158
2159 static namelist_info *
2160 find_nml_node (st_parameter_dt *dtp, char * var_name)
2161 {
2162   namelist_info * t = dtp->u.p.ionml;
2163   while (t != NULL)
2164     {
2165       if (strcmp (var_name, t->var_name) == 0)
2166         {
2167           t->touched = 1;
2168           return t;
2169         }
2170       t = t->next;
2171     }
2172   return NULL;
2173 }
2174
2175 /* Visits all the components of a derived type that have
2176    not explicitly been identified in the namelist input.
2177    touched is set and the loop specification initialised
2178    to default values  */
2179
2180 static void
2181 nml_touch_nodes (namelist_info * nl)
2182 {
2183   index_type len = strlen (nl->var_name) + 1;
2184   int dim;
2185   char * ext_name = (char*)get_mem (len + 1);
2186   memcpy (ext_name, nl->var_name, len-1);
2187   memcpy (ext_name + len - 1, "%", 2);
2188   for (nl = nl->next; nl; nl = nl->next)
2189     {
2190       if (strncmp (nl->var_name, ext_name, len) == 0)
2191         {
2192           nl->touched = 1;
2193           for (dim=0; dim < nl->var_rank; dim++)
2194             {
2195               nl->ls[dim].step = 1;
2196               nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2197               nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2198               nl->ls[dim].idx = nl->ls[dim].start;
2199             }
2200         }
2201       else
2202         break;
2203     }
2204   free (ext_name);
2205   return;
2206 }
2207
2208 /* Resets touched for the entire list of nml_nodes, ready for a
2209    new object.  */
2210
2211 static void
2212 nml_untouch_nodes (st_parameter_dt *dtp)
2213 {
2214   namelist_info * t;
2215   for (t = dtp->u.p.ionml; t; t = t->next)
2216     t->touched = 0;
2217   return;
2218 }
2219
2220 /* Attempts to input name to namelist name.  Returns
2221    dtp->u.p.nml_read_error = 1 on no match.  */
2222
2223 static void
2224 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2225 {
2226   index_type i;
2227   char c;
2228   dtp->u.p.nml_read_error = 0;
2229   for (i = 0; i < len; i++)
2230     {
2231       c = next_char (dtp);
2232       if (tolower (c) != tolower (name[i]))
2233         {
2234           dtp->u.p.nml_read_error = 1;
2235           break;
2236         }
2237     }
2238 }
2239
2240 /* If the namelist read is from stdin, output the current state of the
2241    namelist to stdout.  This is used to implement the non-standard query
2242    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2243    the names alone are printed.  */
2244
2245 static void
2246 nml_query (st_parameter_dt *dtp, char c)
2247 {
2248   gfc_unit * temp_unit;
2249   namelist_info * nl;
2250   index_type len;
2251   char * p;
2252 #ifdef HAVE_CRLF
2253   static const index_type endlen = 3;
2254   static const char endl[] = "\r\n";
2255   static const char nmlend[] = "&end\r\n";
2256 #else
2257   static const index_type endlen = 2;
2258   static const char endl[] = "\n";
2259   static const char nmlend[] = "&end\n";
2260 #endif
2261
2262   if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2263     return;
2264
2265   /* Store the current unit and transfer to stdout.  */
2266
2267   temp_unit = dtp->u.p.current_unit;
2268   dtp->u.p.current_unit = find_unit (options.stdout_unit);
2269
2270   if (dtp->u.p.current_unit)
2271     {
2272       dtp->u.p.mode = WRITING;
2273       next_record (dtp, 0);
2274
2275       /* Write the namelist in its entirety.  */
2276
2277       if (c == '=')
2278         namelist_write (dtp);
2279
2280       /* Or write the list of names.  */
2281
2282       else
2283         {
2284           /* "&namelist_name\n"  */
2285
2286           len = dtp->namelist_name_len;
2287           p = write_block (dtp, len + endlen);
2288           if (!p)
2289             goto query_return;
2290           memcpy (p, "&", 1);
2291           memcpy ((char*)(p + 1), dtp->namelist_name, len);
2292           memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2293           for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2294             {
2295               /* " var_name\n"  */
2296
2297               len = strlen (nl->var_name);
2298               p = write_block (dtp, len + endlen);
2299               if (!p)
2300                 goto query_return;
2301               memcpy (p, " ", 1);
2302               memcpy ((char*)(p + 1), nl->var_name, len);
2303               memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2304             }
2305
2306           /* "&end\n"  */
2307
2308           p = write_block (dtp, endlen + 3);
2309             goto query_return;
2310           memcpy (p, &nmlend, endlen + 3);
2311         }
2312
2313       /* Flush the stream to force immediate output.  */
2314
2315       fbuf_flush (dtp->u.p.current_unit, WRITING);
2316       sflush (dtp->u.p.current_unit->s);
2317       unlock_unit (dtp->u.p.current_unit);
2318     }
2319
2320 query_return:
2321
2322   /* Restore the current unit.  */
2323
2324   dtp->u.p.current_unit = temp_unit;
2325   dtp->u.p.mode = READING;
2326   return;
2327 }
2328
2329 /* Reads and stores the input for the namelist object nl.  For an array,
2330    the function loops over the ranges defined by the loop specification.
2331    This default to all the data or to the specification from a qualifier.
2332    nml_read_obj recursively calls itself to read derived types. It visits
2333    all its own components but only reads data for those that were touched
2334    when the name was parsed.  If a read error is encountered, an attempt is
2335    made to return to read a new object name because the standard allows too
2336    little data to be available.  On the other hand, too much data is an
2337    error.  */
2338
2339 static try
2340 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2341               namelist_info **pprev_nl, char *nml_err_msg,
2342               size_t nml_err_msg_size, index_type clow, index_type chigh)
2343 {
2344   namelist_info * cmp;
2345   char * obj_name;
2346   int nml_carry;
2347   int len;
2348   int dim;
2349   index_type dlen;
2350   index_type m;
2351   size_t obj_name_len;
2352   void * pdata;
2353
2354   /* This object not touched in name parsing.  */
2355
2356   if (!nl->touched)
2357     return SUCCESS;
2358
2359   dtp->u.p.repeat_count = 0;
2360   eat_spaces (dtp);
2361
2362   len = nl->len;
2363   switch (nl->type)
2364   {
2365     case GFC_DTYPE_INTEGER:
2366     case GFC_DTYPE_LOGICAL:
2367       dlen = len;
2368       break;
2369
2370     case GFC_DTYPE_REAL:
2371       dlen = size_from_real_kind (len);
2372       break;
2373
2374     case GFC_DTYPE_COMPLEX:
2375       dlen = size_from_complex_kind (len);
2376       break;
2377
2378     case GFC_DTYPE_CHARACTER:
2379       dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2380       break;
2381
2382     default:
2383       dlen = 0;
2384     }
2385
2386   do
2387     {
2388       /* Update the pointer to the data, using the current index vector  */
2389
2390       pdata = (void*)(nl->mem_pos + offset);
2391       for (dim = 0; dim < nl->var_rank; dim++)
2392         pdata = (void*)(pdata + (nl->ls[dim].idx
2393                                  - GFC_DESCRIPTOR_LBOUND(nl,dim))
2394                         * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2395
2396       /* Reset the error flag and try to read next value, if
2397          dtp->u.p.repeat_count=0  */
2398
2399       dtp->u.p.nml_read_error = 0;
2400       nml_carry = 0;
2401       if (--dtp->u.p.repeat_count <= 0)
2402         {
2403           if (dtp->u.p.input_complete)
2404             return SUCCESS;
2405           if (dtp->u.p.at_eol)
2406             finish_separator (dtp);
2407           if (dtp->u.p.input_complete)
2408             return SUCCESS;
2409
2410           /* BT_NULL (equivalent to GFC_DTYPE_UNKNOWN) falls through
2411              for nulls and is detected at default: of switch block.  */
2412
2413           dtp->u.p.saved_type = BT_NULL;
2414           free_saved (dtp);
2415
2416           switch (nl->type)
2417           {
2418           case GFC_DTYPE_INTEGER:
2419               read_integer (dtp, len);
2420               break;
2421
2422           case GFC_DTYPE_LOGICAL:
2423               read_logical (dtp, len);
2424               break;
2425
2426           case GFC_DTYPE_CHARACTER:
2427               read_character (dtp, len);
2428               break;
2429
2430           case GFC_DTYPE_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 GFC_DTYPE_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 GFC_DTYPE_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_NULL)
2504         {
2505           dtp->u.p.expanded_read = 0;
2506           goto incr_idx;
2507         }
2508
2509       /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2510          This comes about because the read functions return BT_types.  */
2511
2512       switch (dtp->u.p.saved_type)
2513       {
2514
2515         case BT_COMPLEX:
2516         case BT_REAL:
2517         case BT_INTEGER:
2518         case BT_LOGICAL:
2519           memcpy (pdata, dtp->u.p.value, dlen);
2520           break;
2521
2522         case BT_CHARACTER:
2523           m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2524           pdata = (void*)( pdata + clow - 1 );
2525           memcpy (pdata, dtp->u.p.saved_string, m);
2526           if (m < dlen)
2527             memset ((void*)( pdata + m ), ' ', dlen - m);
2528           break;
2529
2530         default:
2531           break;
2532       }
2533
2534       /* Warn if a non-standard expanded read occurs. A single read of a
2535          single object is acceptable.  If a second read occurs, issue a warning
2536          and set the flag to zero to prevent further warnings.  */
2537       if (dtp->u.p.expanded_read == 2)
2538         {
2539           notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2540           dtp->u.p.expanded_read = 0;
2541         }
2542
2543       /* If the expanded read warning flag is set, increment it,
2544          indicating that a single read has occurred.  */
2545       if (dtp->u.p.expanded_read >= 1)
2546         dtp->u.p.expanded_read++;
2547
2548       /* Break out of loop if scalar.  */
2549       if (!nl->var_rank)
2550         break;
2551
2552       /* Now increment the index vector.  */
2553
2554 incr_idx:
2555
2556       nml_carry = 1;
2557       for (dim = 0; dim < nl->var_rank; dim++)
2558         {
2559           nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2560           nml_carry = 0;
2561           if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2562               ||
2563               ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2564             {
2565               nl->ls[dim].idx = nl->ls[dim].start;
2566               nml_carry = 1;
2567             }
2568         }
2569     } while (!nml_carry);
2570
2571   if (dtp->u.p.repeat_count > 1)
2572     {
2573       snprintf (nml_err_msg, nml_err_msg_size,
2574                 "Repeat count too large for namelist object %s", nl->var_name);
2575       goto nml_err_ret;
2576     }
2577   return SUCCESS;
2578
2579 nml_err_ret:
2580
2581   return FAILURE;
2582 }
2583
2584 /* Parses the object name, including array and substring qualifiers.  It
2585    iterates over derived type components, touching those components and
2586    setting their loop specifications, if there is a qualifier.  If the
2587    object is itself a derived type, its components and subcomponents are
2588    touched.  nml_read_obj is called at the end and this reads the data in
2589    the manner specified by the object name.  */
2590
2591 static try
2592 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2593                   char *nml_err_msg, size_t nml_err_msg_size)
2594 {
2595   char c;
2596   namelist_info * nl;
2597   namelist_info * first_nl = NULL;
2598   namelist_info * root_nl = NULL;
2599   int dim, parsed_rank;
2600   int component_flag, qualifier_flag;
2601   index_type clow, chigh;
2602   int non_zero_rank_count;
2603
2604   /* Look for end of input or object name.  If '?' or '=?' are encountered
2605      in stdin, print the node names or the namelist to stdout.  */
2606
2607   eat_separator (dtp);
2608   if (dtp->u.p.input_complete)
2609     return SUCCESS;
2610
2611   if (dtp->u.p.at_eol)
2612     finish_separator (dtp);
2613   if (dtp->u.p.input_complete)
2614     return SUCCESS;
2615
2616   c = next_char (dtp);
2617   switch (c)
2618     {
2619     case '=':
2620       c = next_char (dtp);
2621       if (c != '?')
2622         {
2623           sprintf (nml_err_msg, "namelist read: misplaced = sign");
2624           goto nml_err_ret;
2625         }
2626       nml_query (dtp, '=');
2627       return SUCCESS;
2628
2629     case '?':
2630       nml_query (dtp, '?');
2631       return SUCCESS;
2632
2633     case '$':
2634     case '&':
2635       nml_match_name (dtp, "end", 3);
2636       if (dtp->u.p.nml_read_error)
2637         {
2638           sprintf (nml_err_msg, "namelist not terminated with / or &end");
2639           goto nml_err_ret;
2640         }
2641     case '/':
2642       dtp->u.p.input_complete = 1;
2643       return SUCCESS;
2644
2645     default :
2646       break;
2647     }
2648
2649   /* Untouch all nodes of the namelist and reset the flags that are set for
2650      derived type components.  */
2651
2652   nml_untouch_nodes (dtp);
2653   component_flag = 0;
2654   qualifier_flag = 0;
2655   non_zero_rank_count = 0;
2656
2657   /* Get the object name - should '!' and '\n' be permitted separators?  */
2658
2659 get_name:
2660
2661   free_saved (dtp);
2662
2663   do
2664     {
2665       if (!is_separator (c))
2666         push_char (dtp, tolower(c));
2667       c = next_char (dtp);
2668     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2669
2670   unget_char (dtp, c);
2671
2672   /* Check that the name is in the namelist and get pointer to object.
2673      Three error conditions exist: (i) An attempt is being made to
2674      identify a non-existent object, following a failed data read or
2675      (ii) The object name does not exist or (iii) Too many data items
2676      are present for an object.  (iii) gives the same error message
2677      as (i)  */
2678
2679   push_char (dtp, '\0');
2680
2681   if (component_flag)
2682     {
2683       size_t var_len = strlen (root_nl->var_name);
2684       size_t saved_len
2685         = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2686       char ext_name[var_len + saved_len + 1];
2687
2688       memcpy (ext_name, root_nl->var_name, var_len);
2689       if (dtp->u.p.saved_string)
2690         memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2691       ext_name[var_len + saved_len] = '\0';
2692       nl = find_nml_node (dtp, ext_name);
2693     }
2694   else
2695     nl = find_nml_node (dtp, dtp->u.p.saved_string);
2696
2697   if (nl == NULL)
2698     {
2699       if (dtp->u.p.nml_read_error && *pprev_nl)
2700         snprintf (nml_err_msg, nml_err_msg_size,
2701                   "Bad data for namelist object %s", (*pprev_nl)->var_name);
2702
2703       else
2704         snprintf (nml_err_msg, nml_err_msg_size,
2705                   "Cannot match namelist object name %s",
2706                   dtp->u.p.saved_string);
2707
2708       goto nml_err_ret;
2709     }
2710
2711   /* Get the length, data length, base pointer and rank of the variable.
2712      Set the default loop specification first.  */
2713
2714   for (dim=0; dim < nl->var_rank; dim++)
2715     {
2716       nl->ls[dim].step = 1;
2717       nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2718       nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2719       nl->ls[dim].idx = nl->ls[dim].start;
2720     }
2721
2722 /* Check to see if there is a qualifier: if so, parse it.*/
2723
2724   if (c == '(' && nl->var_rank)
2725     {
2726       parsed_rank = 0;
2727       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2728                                nml_err_msg, &parsed_rank) == FAILURE)
2729         {
2730           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2731           snprintf (nml_err_msg_end,
2732                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2733                     " for namelist variable %s", nl->var_name);
2734           goto nml_err_ret;
2735         }
2736       if (parsed_rank > 0)
2737         non_zero_rank_count++;
2738
2739       qualifier_flag = 1;
2740
2741       c = next_char (dtp);
2742       unget_char (dtp, c);
2743     }
2744   else if (nl->var_rank > 0)
2745     non_zero_rank_count++;
2746
2747   /* Now parse a derived type component. The root namelist_info address
2748      is backed up, as is the previous component level.  The  component flag
2749      is set and the iteration is made by jumping back to get_name.  */
2750
2751   if (c == '%')
2752     {
2753       if (nl->type != GFC_DTYPE_DERIVED)
2754         {
2755           snprintf (nml_err_msg, nml_err_msg_size,
2756                     "Attempt to get derived component for %s", nl->var_name);
2757           goto nml_err_ret;
2758         }
2759
2760       if (!component_flag)
2761         first_nl = nl;
2762
2763       root_nl = nl;
2764       component_flag = 1;
2765
2766       c = next_char (dtp);
2767       goto get_name;
2768     }
2769
2770   /* Parse a character qualifier, if present.  chigh = 0 is a default
2771      that signals that the string length = string_length.  */
2772
2773   clow = 1;
2774   chigh = 0;
2775
2776   if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2777     {
2778       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2779       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2780
2781       if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
2782           == FAILURE)
2783         {
2784           char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2785           snprintf (nml_err_msg_end,
2786                     nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2787                     " for namelist variable %s", nl->var_name);
2788           goto nml_err_ret;
2789         }
2790
2791       clow = ind[0].start;
2792       chigh = ind[0].end;
2793
2794       if (ind[0].step != 1)
2795         {
2796           snprintf (nml_err_msg, nml_err_msg_size,
2797                     "Step not allowed in substring qualifier"
2798                     " for namelist object %s", nl->var_name);
2799           goto nml_err_ret;
2800         }
2801
2802       c = next_char (dtp);
2803       unget_char (dtp, c);
2804     }
2805
2806   /* Make sure no extraneous qualifiers are there.  */
2807
2808   if (c == '(')
2809     {
2810       snprintf (nml_err_msg, nml_err_msg_size,
2811                 "Qualifier for a scalar or non-character namelist object %s",
2812                 nl->var_name);
2813       goto nml_err_ret;
2814     }
2815
2816   /* Make sure there is no more than one non-zero rank object.  */
2817   if (non_zero_rank_count > 1)
2818     {
2819       snprintf (nml_err_msg, nml_err_msg_size,
2820                 "Multiple sub-objects with non-zero rank in namelist object %s",
2821                 nl->var_name);
2822       non_zero_rank_count = 0;
2823       goto nml_err_ret;
2824     }
2825
2826 /* According to the standard, an equal sign MUST follow an object name. The
2827    following is possibly lax - it allows comments, blank lines and so on to
2828    intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2829
2830   free_saved (dtp);
2831
2832   eat_separator (dtp);
2833   if (dtp->u.p.input_complete)
2834     return SUCCESS;
2835
2836   if (dtp->u.p.at_eol)
2837     finish_separator (dtp);
2838   if (dtp->u.p.input_complete)
2839     return SUCCESS;
2840
2841   c = next_char (dtp);
2842
2843   if (c != '=')
2844     {
2845       snprintf (nml_err_msg, nml_err_msg_size,
2846                 "Equal sign must follow namelist object name %s",
2847                 nl->var_name);
2848       goto nml_err_ret;
2849     }
2850   /* If a derived type, touch its components and restore the root
2851      namelist_info if we have parsed a qualified derived type
2852      component.  */
2853
2854   if (nl->type == GFC_DTYPE_DERIVED)
2855     nml_touch_nodes (nl);
2856
2857   if (first_nl)
2858     {
2859       if (first_nl->var_rank == 0)
2860         {
2861           if (component_flag && qualifier_flag)
2862             nl = first_nl;
2863         }
2864       else
2865         nl = first_nl;
2866     }
2867
2868   if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
2869                     clow, chigh) == FAILURE)
2870     goto nml_err_ret;
2871
2872   return SUCCESS;
2873
2874 nml_err_ret:
2875
2876   return FAILURE;
2877 }
2878
2879 /* Entry point for namelist input.  Goes through input until namelist name
2880   is matched.  Then cycles through nml_get_obj_data until the input is
2881   completed or there is an error.  */
2882
2883 void
2884 namelist_read (st_parameter_dt *dtp)
2885 {
2886   char c;
2887   jmp_buf eof_jump;
2888   char nml_err_msg[200];
2889   /* Pointer to the previously read object, in case attempt is made to read
2890      new object name.  Should this fail, error message can give previous
2891      name.  */
2892   namelist_info *prev_nl = NULL;
2893
2894   dtp->u.p.namelist_mode = 1;
2895   dtp->u.p.input_complete = 0;
2896   dtp->u.p.expanded_read = 0;
2897
2898   dtp->u.p.eof_jump = &eof_jump;
2899   if (setjmp (eof_jump))
2900     {
2901       dtp->u.p.eof_jump = NULL;
2902       generate_error (&dtp->common, LIBERROR_END, NULL);
2903       return;
2904     }
2905
2906   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
2907      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2908      node names or namelist on stdout.  */
2909
2910 find_nml_name:
2911   switch (c = next_char (dtp))
2912     {
2913     case '$':
2914     case '&':
2915           break;
2916
2917     case '!':
2918       eat_line (dtp);
2919       goto find_nml_name;
2920
2921     case '=':
2922       c = next_char (dtp);
2923       if (c == '?')
2924         nml_query (dtp, '=');
2925       else
2926         unget_char (dtp, c);
2927       goto find_nml_name;
2928
2929     case '?':
2930       nml_query (dtp, '?');
2931
2932     default:
2933       goto find_nml_name;
2934     }
2935
2936   /* Match the name of the namelist.  */
2937
2938   nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2939
2940   if (dtp->u.p.nml_read_error)
2941     goto find_nml_name;
2942
2943   /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
2944   c = next_char (dtp);
2945   if (!is_separator(c) && c != '!')
2946     {
2947       unget_char (dtp, c);
2948       goto find_nml_name;
2949     }
2950
2951   unget_char (dtp, c);
2952   eat_separator (dtp);
2953
2954   /* Ready to read namelist objects.  If there is an error in input
2955      from stdin, output the error message and continue.  */
2956
2957   while (!dtp->u.p.input_complete)
2958     {
2959       if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
2960                             == FAILURE)
2961         {
2962           gfc_unit *u;
2963
2964           if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2965             goto nml_err_ret;
2966
2967           u = find_unit (options.stderr_unit);
2968           st_printf ("%s\n", nml_err_msg);
2969           if (u != NULL)
2970             {
2971               sflush (u->s);
2972               unlock_unit (u);
2973             }
2974         }
2975
2976    }
2977
2978   dtp->u.p.eof_jump = NULL;
2979   free_saved (dtp);
2980   free_line (dtp);
2981   return;
2982
2983   /* All namelist error calls return from here */
2984
2985 nml_err_ret:
2986
2987   dtp->u.p.eof_jump = NULL;
2988   free_saved (dtp);
2989   free_line (dtp);
2990   generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
2991   return;
2992 }