1 /* Copyright (C) 2002-2017 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
34 typedef unsigned char uchar
;
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
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
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'
54 #define CASE_SEPARATORS /* Fall through. */ \
55 case ' ': case ',': case '/': case '\n': \
56 case '\t': case '\r': case ';'
58 /* This macro assumes that we're operating on a variable. */
60 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
61 || c == '\t' || c == '\r' || c == ';' || \
62 (dtp->u.p.namelist_mode && c == '!'))
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
72 /* Wrappers for calling the current worker functions. */
74 #define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
75 #define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c))
77 /* Worker function to save a default KIND=1 character to a string
78 buffer, enlarging it as necessary. */
81 push_char_default (st_parameter_dt
*dtp
, int c
)
85 if (dtp
->u
.p
.saved_string
== NULL
)
87 /* Plain malloc should suffice here, zeroing not needed? */
88 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
89 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
90 dtp
->u
.p
.saved_used
= 0;
93 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
95 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
96 dtp
->u
.p
.saved_string
=
97 xrealloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
100 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = (char) c
;
104 /* Worker function to save a KIND=4 character to a string buffer,
105 enlarging the buffer as necessary. */
107 push_char4 (st_parameter_dt
*dtp
, int c
)
109 gfc_char4_t
*p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
113 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, sizeof (gfc_char4_t
));
114 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
115 dtp
->u
.p
.saved_used
= 0;
116 p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
119 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
121 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
122 dtp
->u
.p
.saved_string
=
123 xrealloc (dtp
->u
.p
.saved_string
,
124 dtp
->u
.p
.saved_length
* sizeof (gfc_char4_t
));
125 p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
128 p
[dtp
->u
.p
.saved_used
++] = c
;
132 /* Free the input buffer if necessary. */
135 free_saved (st_parameter_dt
*dtp
)
137 if (dtp
->u
.p
.saved_string
== NULL
)
140 free (dtp
->u
.p
.saved_string
);
142 dtp
->u
.p
.saved_string
= NULL
;
143 dtp
->u
.p
.saved_used
= 0;
147 /* Free the line buffer if necessary. */
150 free_line (st_parameter_dt
*dtp
)
152 dtp
->u
.p
.line_buffer_pos
= 0;
153 dtp
->u
.p
.line_buffer_enabled
= 0;
155 if (dtp
->u
.p
.line_buffer
== NULL
)
158 free (dtp
->u
.p
.line_buffer
);
159 dtp
->u
.p
.line_buffer
= NULL
;
163 /* Unget saves the last character so when reading the next character,
164 we need to check to see if there is a character waiting. Similar,
165 if the line buffer is being used to read_logical, check it too. */
168 check_buffers (st_parameter_dt
*dtp
)
173 if (dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1)
176 c
= dtp
->u
.p
.current_unit
->last_char
;
177 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
181 /* Read from line_buffer if enabled. */
183 if (dtp
->u
.p
.line_buffer_enabled
)
187 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
];
188 if (c
!= '\0' && dtp
->u
.p
.line_buffer_pos
< 64)
190 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
] = '\0';
191 dtp
->u
.p
.line_buffer_pos
++;
195 dtp
->u
.p
.line_buffer_pos
= 0;
196 dtp
->u
.p
.line_buffer_enabled
= 0;
200 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
205 /* Worker function for default character encoded file. */
207 next_char_default (st_parameter_dt
*dtp
)
211 /* Always check the unget and line buffer first. */
212 if ((c
= check_buffers (dtp
)))
215 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
216 if (c
!= EOF
&& is_stream_io (dtp
))
217 dtp
->u
.p
.current_unit
->strm_pos
++;
219 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
224 /* Worker function for internal and array I/O units. */
226 next_char_internal (st_parameter_dt
*dtp
)
232 /* Always check the unget and line buffer first. */
233 if ((c
= check_buffers (dtp
)))
236 /* Handle the end-of-record and end-of-file conditions for
237 internal array unit. */
238 if (is_array_io (dtp
))
243 /* Check for "end-of-record" condition. */
244 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
249 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
252 /* Check for "end-of-file" condition. */
259 record
*= dtp
->u
.p
.current_unit
->recl
;
260 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
263 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
268 /* Get the next character and handle end-of-record conditions. */
270 if (is_char4_unit(dtp
)) /* Check for kind=4 internal unit. */
271 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, 1);
275 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
279 if (unlikely (length
< 0))
281 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
285 if (is_array_io (dtp
))
287 /* Check whether we hit EOF. */
288 if (unlikely (length
== 0))
290 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
293 dtp
->u
.p
.current_unit
->bytes_left
--;
307 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
312 /* Worker function for UTF encoded files. */
314 next_char_utf8 (st_parameter_dt
*dtp
)
316 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
317 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
321 /* Always check the unget and line buffer first. */
322 if (!(c
= check_buffers (dtp
)))
323 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
328 /* The number of leading 1-bits in the first byte indicates how many
330 for (nb
= 2; nb
< 7; nb
++)
331 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
336 c
= (c
& masks
[nb
-1]);
338 /* Decode the bytes read. */
339 for (i
= 1; i
< nb
; i
++)
341 gfc_char4_t n
= fbuf_getc (dtp
->u
.p
.current_unit
);
342 if ((n
& 0xC0) != 0x80)
344 c
= ((c
<< 6) + (n
& 0x3F));
347 /* Make sure the shortest possible encoding was used. */
348 if (c
<= 0x7F && nb
> 1) goto invalid
;
349 if (c
<= 0x7FF && nb
> 2) goto invalid
;
350 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
351 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
352 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
354 /* Make sure the character is valid. */
355 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
359 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== (gfc_char4_t
) EOF
);
363 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
364 return (gfc_char4_t
) '?';
367 /* Push a character back onto the input. */
370 unget_char (st_parameter_dt
*dtp
, int c
)
372 dtp
->u
.p
.current_unit
->last_char
= c
;
376 /* Skip over spaces in the input. Returns the nonspace character that
377 terminated the eating and also places it back on the input. */
380 eat_spaces (st_parameter_dt
*dtp
)
384 /* If internal character array IO, peak ahead and seek past spaces.
385 This is an optimization unique to character arrays with large
386 character lengths (PR38199). This code eliminates numerous calls
387 to next_character. */
388 if (is_array_io (dtp
) && (dtp
->u
.p
.current_unit
->last_char
== EOF
- 1))
390 gfc_offset offset
= stell (dtp
->u
.p
.current_unit
->s
);
393 if (is_char4_unit(dtp
)) /* kind=4 */
395 for (i
= 0; i
< dtp
->u
.p
.current_unit
->bytes_left
; i
++)
397 if (dtp
->internal_unit
[(offset
+ i
) * sizeof (gfc_char4_t
)]
404 for (i
= 0; i
< dtp
->u
.p
.current_unit
->bytes_left
; i
++)
406 if (dtp
->internal_unit
[offset
+ i
] != ' ')
413 sseek (dtp
->u
.p
.current_unit
->s
, offset
+ i
, SEEK_SET
);
414 dtp
->u
.p
.current_unit
->bytes_left
-= i
;
418 /* Now skip spaces, EOF and EOL are handled in next_char. */
421 while (c
!= EOF
&& (c
== ' ' || c
== '\r' || c
== '\t'));
428 /* This function reads characters through to the end of the current
429 line and just ignores them. Returns 0 for success and LIBERROR_END
433 eat_line (st_parameter_dt
*dtp
)
439 while (c
!= EOF
&& c
!= '\n');
446 /* Skip over a separator. Technically, we don't always eat the whole
447 separator. This is because if we've processed the last input item,
448 then a separator is unnecessary. Plus the fact that operating
449 systems usually deliver console input on a line basis.
451 The upshot is that if we see a newline as part of reading a
452 separator, we stop reading. If there are more input items, we
453 continue reading the separator with finish_separator() which takes
454 care of the fact that we may or may not have seen a comma as part
457 Returns 0 for success, and non-zero error code otherwise. */
460 eat_separator (st_parameter_dt
*dtp
)
466 dtp
->u
.p
.comma_flag
= 0;
468 if ((c
= next_char (dtp
)) == EOF
)
473 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
480 dtp
->u
.p
.comma_flag
= 1;
485 dtp
->u
.p
.input_complete
= 1;
489 if ((n
= next_char(dtp
)) == EOF
)
499 if (dtp
->u
.p
.namelist_mode
)
503 if ((c
= next_char (dtp
)) == EOF
)
507 err
= eat_line (dtp
);
513 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
519 /* Eat a namelist comment. */
520 if (dtp
->u
.p
.namelist_mode
)
522 err
= eat_line (dtp
);
529 /* Fall Through... */
539 /* Finish processing a separator that was interrupted by a newline.
540 If we're here, then another data item is present, so we finish what
541 we started on the previous line. Return 0 on success, error code
545 finish_separator (st_parameter_dt
*dtp
)
548 int err
= LIBERROR_OK
;
553 if ((c
= next_char (dtp
)) == EOF
)
558 if (dtp
->u
.p
.comma_flag
)
562 if ((c
= eat_spaces (dtp
)) == EOF
)
564 if (c
== '\n' || c
== '\r')
571 dtp
->u
.p
.input_complete
= 1;
572 if (!dtp
->u
.p
.namelist_mode
)
581 if (dtp
->u
.p
.namelist_mode
)
583 err
= eat_line (dtp
);
597 /* This function is needed to catch bad conversions so that namelist can
598 attempt to see if dtp->u.p.saved_string contains a new object name rather
602 nml_bad_return (st_parameter_dt
*dtp
, char c
)
604 if (dtp
->u
.p
.namelist_mode
)
606 dtp
->u
.p
.nml_read_error
= 1;
613 /* Convert an unsigned string to an integer. The length value is -1
614 if we are working on a repeat count. Returns nonzero if we have a
615 range problem. As a side effect, frees the dtp->u.p.saved_string. */
618 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
620 char c
, *buffer
, message
[MSGLEN
];
622 GFC_UINTEGER_LARGEST v
, max
, max10
;
623 GFC_INTEGER_LARGEST value
;
625 buffer
= dtp
->u
.p
.saved_string
;
632 max
= si_max (length
);
662 set_integer (dtp
->u
.p
.value
, value
, length
);
666 dtp
->u
.p
.repeat_count
= v
;
668 if (dtp
->u
.p
.repeat_count
== 0)
670 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
671 dtp
->u
.p
.item_count
);
673 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
683 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
684 dtp
->u
.p
.item_count
);
686 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
687 dtp
->u
.p
.item_count
);
690 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
696 /* Parse a repeat count for logical and complex values which cannot
697 begin with a digit. Returns nonzero if we are done, zero if we
698 should continue on. */
701 parse_repeat (st_parameter_dt
*dtp
)
703 char message
[MSGLEN
];
706 if ((c
= next_char (dtp
)) == EOF
)
730 repeat
= 10 * repeat
+ c
- '0';
732 if (repeat
> MAX_REPEAT
)
734 snprintf (message
, MSGLEN
,
735 "Repeat count overflow in item %d of list input",
736 dtp
->u
.p
.item_count
);
738 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
747 snprintf (message
, MSGLEN
,
748 "Zero repeat count in item %d of list input",
749 dtp
->u
.p
.item_count
);
751 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
763 dtp
->u
.p
.repeat_count
= repeat
;
777 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
778 dtp
->u
.p
.item_count
);
779 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
784 /* To read a logical we have to look ahead in the input stream to make sure
785 there is not an equal sign indicating a variable name. To do this we use
786 line_buffer to point to a temporary buffer, pushing characters there for
787 possible later reading. */
790 l_push_char (st_parameter_dt
*dtp
, char c
)
792 if (dtp
->u
.p
.line_buffer
== NULL
)
793 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
795 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
++] = c
;
799 /* Read a logical character on the input. */
802 read_logical (st_parameter_dt
*dtp
, int length
)
804 char message
[MSGLEN
];
807 if (parse_repeat (dtp
))
810 c
= tolower (next_char (dtp
));
811 l_push_char (dtp
, c
);
817 l_push_char (dtp
, c
);
819 if (!is_separator(c
) && c
!= EOF
)
827 l_push_char (dtp
, c
);
829 if (!is_separator(c
) && c
!= EOF
)
836 c
= tolower (next_char (dtp
));
852 if (!dtp
->u
.p
.namelist_mode
)
859 return; /* Null value. */
862 /* Save the character in case it is the beginning
863 of the next object name. */
868 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
869 dtp
->u
.p
.saved_length
= length
;
871 /* Eat trailing garbage. */
874 while (c
!= EOF
&& !is_separator (c
));
878 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
885 for(i
= 0; i
< 63; i
++)
890 /* All done if this is not a namelist read. */
891 if (!dtp
->u
.p
.namelist_mode
)
904 l_push_char (dtp
, c
);
907 dtp
->u
.p
.nml_read_error
= 1;
908 dtp
->u
.p
.line_buffer_enabled
= 1;
909 dtp
->u
.p
.line_buffer_pos
= 0;
917 if (nml_bad_return (dtp
, c
))
933 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
934 dtp
->u
.p
.item_count
);
936 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
941 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
942 dtp
->u
.p
.saved_length
= length
;
943 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
949 /* Reading integers is tricky because we can actually be reading a
950 repeat count. We have to store the characters in a buffer because
951 we could be reading an integer that is larger than the default int
952 used for repeat counts. */
955 read_integer (st_parameter_dt
*dtp
, int length
)
957 char message
[MSGLEN
];
967 /* Fall through... */
970 if ((c
= next_char (dtp
)) == EOF
)
975 if (!dtp
->u
.p
.namelist_mode
)
978 CASE_SEPARATORS
: /* Single null. */
991 /* Take care of what may be a repeat count. */
1003 push_char (dtp
, '\0');
1007 if (!dtp
->u
.p
.namelist_mode
)
1010 CASE_SEPARATORS
: /* Not a repeat count. */
1020 if (convert_integer (dtp
, -1, 0))
1023 /* Get the real integer. */
1025 if ((c
= next_char (dtp
)) == EOF
)
1033 if (!dtp
->u
.p
.namelist_mode
)
1037 unget_char (dtp
, c
);
1038 eat_separator (dtp
);
1043 /* Fall through... */
1046 c
= next_char (dtp
);
1057 c
= next_char (dtp
);
1065 if (!dtp
->u
.p
.namelist_mode
)
1079 if (nml_bad_return (dtp
, c
))
1092 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
1093 dtp
->u
.p
.item_count
);
1095 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1100 unget_char (dtp
, c
);
1101 eat_separator (dtp
);
1103 push_char (dtp
, '\0');
1104 if (convert_integer (dtp
, length
, negative
))
1111 dtp
->u
.p
.saved_type
= BT_INTEGER
;
1115 /* Read a character variable. */
1118 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
1120 char quote
, message
[MSGLEN
];
1123 quote
= ' '; /* Space means no quote character. */
1125 if ((c
= next_char (dtp
)) == EOF
)
1135 unget_char (dtp
, c
); /* NULL value. */
1136 eat_separator (dtp
);
1145 if (dtp
->u
.p
.namelist_mode
)
1147 unget_char (dtp
, c
);
1154 /* Deal with a possible repeat count. */
1158 c
= next_char (dtp
);
1167 unget_char (dtp
, c
);
1168 goto done
; /* String was only digits! */
1171 push_char (dtp
, '\0');
1176 goto get_string
; /* Not a repeat count after all. */
1181 if (convert_integer (dtp
, -1, 0))
1184 /* Now get the real string. */
1186 if ((c
= next_char (dtp
)) == EOF
)
1191 unget_char (dtp
, c
); /* Repeated NULL values. */
1192 eat_separator (dtp
);
1209 if ((c
= next_char (dtp
)) == EOF
)
1221 /* See if we have a doubled quote character or the end of
1224 if ((c
= next_char (dtp
)) == EOF
)
1228 push_char (dtp
, quote
);
1232 unget_char (dtp
, c
);
1238 unget_char (dtp
, c
);
1242 if (c
!= '\n' && c
!= '\r')
1252 /* At this point, we have to have a separator, or else the string is
1255 c
= next_char (dtp
);
1257 if (is_separator (c
) || c
== EOF
)
1259 unget_char (dtp
, c
);
1260 eat_separator (dtp
);
1261 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1266 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1267 dtp
->u
.p
.item_count
);
1268 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1280 /* Parse a component of a complex constant or a real number that we
1281 are sure is already there. This is a straight real number parser. */
1284 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1286 char message
[MSGLEN
];
1289 if ((c
= next_char (dtp
)) == EOF
)
1292 if (c
== '-' || c
== '+')
1295 if ((c
= next_char (dtp
)) == EOF
)
1299 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1302 if (!isdigit (c
) && c
!= '.')
1304 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1312 seen_dp
= (c
== '.') ? 1 : 0;
1316 if ((c
= next_char (dtp
)) == EOF
)
1318 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1340 push_char (dtp
, 'e');
1345 push_char (dtp
, 'e');
1347 if ((c
= next_char (dtp
)) == EOF
)
1352 if (!dtp
->u
.p
.namelist_mode
)
1365 if ((c
= next_char (dtp
)) == EOF
)
1367 if (c
!= '-' && c
!= '+')
1368 push_char (dtp
, '+');
1372 c
= next_char (dtp
);
1378 /* Extension: allow default exponent of 0 when omitted. */
1379 if (dtp
->common
.flags
& IOPARM_DT_DEFAULT_EXP
)
1381 push_char (dtp
, '0');
1392 if ((c
= next_char (dtp
)) == EOF
)
1401 if (!dtp
->u
.p
.namelist_mode
)
1406 unget_char (dtp
, c
);
1415 unget_char (dtp
, c
);
1416 push_char (dtp
, '\0');
1418 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1424 unget_char (dtp
, c
);
1425 push_char (dtp
, '\0');
1427 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1433 /* Match INF and Infinity. */
1434 if ((c
== 'i' || c
== 'I')
1435 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1436 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1438 c
= next_char (dtp
);
1439 if ((c
!= 'i' && c
!= 'I')
1440 || ((c
== 'i' || c
== 'I')
1441 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1442 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1443 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1444 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1445 && (c
= next_char (dtp
))))
1447 if (is_separator (c
) || (c
== EOF
))
1448 unget_char (dtp
, c
);
1449 push_char (dtp
, 'i');
1450 push_char (dtp
, 'n');
1451 push_char (dtp
, 'f');
1455 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1456 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1457 && (c
= next_char (dtp
)))
1459 if (is_separator (c
) || (c
== EOF
))
1460 unget_char (dtp
, c
);
1461 push_char (dtp
, 'n');
1462 push_char (dtp
, 'a');
1463 push_char (dtp
, 'n');
1465 /* Match "NAN(alphanum)". */
1468 for ( ; c
!= ')'; c
= next_char (dtp
))
1469 if (is_separator (c
))
1472 c
= next_char (dtp
);
1473 if (is_separator (c
) || (c
== EOF
))
1474 unget_char (dtp
, c
);
1481 if (nml_bad_return (dtp
, c
))
1496 snprintf (message
, MSGLEN
, "Bad complex floating point "
1497 "number for item %d", dtp
->u
.p
.item_count
);
1499 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1505 /* Reading a complex number is straightforward because we can tell
1506 what it is right away. */
1509 read_complex (st_parameter_dt
*dtp
, void *dest
, int kind
, size_t size
)
1511 char message
[MSGLEN
];
1514 if (parse_repeat (dtp
))
1517 c
= next_char (dtp
);
1524 if (!dtp
->u
.p
.namelist_mode
)
1529 unget_char (dtp
, c
);
1530 eat_separator (dtp
);
1539 c
= next_char (dtp
);
1540 if (c
== '\n' || c
== '\r')
1543 unget_char (dtp
, c
);
1545 if (parse_real (dtp
, dest
, kind
))
1550 c
= next_char (dtp
);
1551 if (c
== '\n' || c
== '\r')
1554 unget_char (dtp
, c
);
1557 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1562 c
= next_char (dtp
);
1563 if (c
== '\n' || c
== '\r')
1566 unget_char (dtp
, c
);
1568 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1573 c
= next_char (dtp
);
1574 if (c
== '\n' || c
== '\r')
1577 unget_char (dtp
, c
);
1579 if (next_char (dtp
) != ')')
1582 c
= next_char (dtp
);
1583 if (!is_separator (c
) && (c
!= EOF
))
1586 unget_char (dtp
, c
);
1587 eat_separator (dtp
);
1590 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1595 if (nml_bad_return (dtp
, c
))
1608 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1609 dtp
->u
.p
.item_count
);
1611 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1615 /* Parse a real number with a possible repeat count. */
1618 read_real (st_parameter_dt
*dtp
, void *dest
, int length
)
1620 char message
[MSGLEN
];
1627 c
= next_char (dtp
);
1628 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1646 if (!dtp
->u
.p
.namelist_mode
)
1650 unget_char (dtp
, c
); /* Single null. */
1651 eat_separator (dtp
);
1664 /* Get the digit string that might be a repeat count. */
1668 c
= next_char (dtp
);
1669 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1695 push_char (dtp
, 'e');
1697 c
= next_char (dtp
);
1701 push_char (dtp
, '\0');
1705 if (!dtp
->u
.p
.namelist_mode
)
1710 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1711 unget_char (dtp
, c
);
1720 if (convert_integer (dtp
, -1, 0))
1723 /* Now get the number itself. */
1725 if ((c
= next_char (dtp
)) == EOF
)
1727 if (is_separator (c
))
1728 { /* Repeated null value. */
1729 unget_char (dtp
, c
);
1730 eat_separator (dtp
);
1734 if (c
!= '-' && c
!= '+')
1735 push_char (dtp
, '+');
1740 if ((c
= next_char (dtp
)) == EOF
)
1744 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1747 if (!isdigit (c
) && c
!= '.')
1749 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1768 c
= next_char (dtp
);
1769 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1778 if (!dtp
->u
.p
.namelist_mode
)
1803 push_char (dtp
, 'e');
1805 c
= next_char (dtp
);
1814 push_char (dtp
, 'e');
1816 if ((c
= next_char (dtp
)) == EOF
)
1818 if (c
!= '+' && c
!= '-')
1819 push_char (dtp
, '+');
1823 c
= next_char (dtp
);
1829 /* Extension: allow default exponent of 0 when omitted. */
1830 if (dtp
->common
.flags
& IOPARM_DT_DEFAULT_EXP
)
1832 push_char (dtp
, '0');
1843 c
= next_char (dtp
);
1852 if (!dtp
->u
.p
.namelist_mode
)
1865 unget_char (dtp
, c
);
1866 eat_separator (dtp
);
1867 push_char (dtp
, '\0');
1868 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1875 dtp
->u
.p
.saved_type
= BT_REAL
;
1879 l_push_char (dtp
, c
);
1882 /* Match INF and Infinity. */
1883 if (c
== 'i' || c
== 'I')
1885 c
= next_char (dtp
);
1886 l_push_char (dtp
, c
);
1887 if (c
!= 'n' && c
!= 'N')
1889 c
= next_char (dtp
);
1890 l_push_char (dtp
, c
);
1891 if (c
!= 'f' && c
!= 'F')
1893 c
= next_char (dtp
);
1894 l_push_char (dtp
, c
);
1895 if (!is_separator (c
) && (c
!= EOF
))
1897 if (c
!= 'i' && c
!= 'I')
1899 c
= next_char (dtp
);
1900 l_push_char (dtp
, c
);
1901 if (c
!= 'n' && c
!= 'N')
1903 c
= next_char (dtp
);
1904 l_push_char (dtp
, c
);
1905 if (c
!= 'i' && c
!= 'I')
1907 c
= next_char (dtp
);
1908 l_push_char (dtp
, c
);
1909 if (c
!= 't' && c
!= 'T')
1911 c
= next_char (dtp
);
1912 l_push_char (dtp
, c
);
1913 if (c
!= 'y' && c
!= 'Y')
1915 c
= next_char (dtp
);
1916 l_push_char (dtp
, c
);
1922 c
= next_char (dtp
);
1923 l_push_char (dtp
, c
);
1924 if (c
!= 'a' && c
!= 'A')
1926 c
= next_char (dtp
);
1927 l_push_char (dtp
, c
);
1928 if (c
!= 'n' && c
!= 'N')
1930 c
= next_char (dtp
);
1931 l_push_char (dtp
, c
);
1933 /* Match NAN(alphanum). */
1936 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1937 if (is_separator (c
))
1940 l_push_char (dtp
, c
);
1942 l_push_char (dtp
, ')');
1943 c
= next_char (dtp
);
1944 l_push_char (dtp
, c
);
1948 if (!is_separator (c
) && (c
!= EOF
))
1951 if (dtp
->u
.p
.namelist_mode
)
1953 if (c
== ' ' || c
=='\n' || c
== '\r')
1957 if ((c
= next_char (dtp
)) == EOF
)
1960 while (c
== ' ' || c
=='\n' || c
== '\r');
1962 l_push_char (dtp
, c
);
1971 push_char (dtp
, 'i');
1972 push_char (dtp
, 'n');
1973 push_char (dtp
, 'f');
1977 push_char (dtp
, 'n');
1978 push_char (dtp
, 'a');
1979 push_char (dtp
, 'n');
1983 unget_char (dtp
, c
);
1984 eat_separator (dtp
);
1985 push_char (dtp
, '\0');
1986 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1990 dtp
->u
.p
.saved_type
= BT_REAL
;
1994 if (dtp
->u
.p
.namelist_mode
)
1996 dtp
->u
.p
.nml_read_error
= 1;
1997 dtp
->u
.p
.line_buffer_enabled
= 1;
1998 dtp
->u
.p
.line_buffer_pos
= 0;
2004 if (nml_bad_return (dtp
, c
))
2019 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
2020 dtp
->u
.p
.item_count
);
2022 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2026 /* Check the current type against the saved type to make sure they are
2027 compatible. Returns nonzero if incompatible. */
2030 check_type (st_parameter_dt
*dtp
, bt type
, int kind
)
2032 char message
[MSGLEN
];
2034 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
2036 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
2037 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
2038 dtp
->u
.p
.item_count
);
2040 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2044 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
2047 if ((type
!= BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
)
2048 || (type
== BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
*2))
2050 snprintf (message
, MSGLEN
,
2051 "Read kind %d %s where kind %d is required for item %d",
2052 type
== BT_COMPLEX
? dtp
->u
.p
.saved_length
/ 2
2053 : dtp
->u
.p
.saved_length
,
2054 type_name (dtp
->u
.p
.saved_type
), kind
,
2055 dtp
->u
.p
.item_count
);
2057 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2065 /* Initialize the function pointers to select the correct versions of
2066 next_char and push_char depending on what we are doing. */
2069 set_workers (st_parameter_dt
*dtp
)
2071 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2073 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_utf8
;
2074 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char4
;
2076 else if (is_internal_unit (dtp
))
2078 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_internal
;
2079 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char_default
;
2083 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_default
;
2084 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char_default
;
2089 /* Top level data transfer subroutine for list reads. Because we have
2090 to deal with repeat counts, the data item is always saved after
2091 reading, usually in the dtp->u.p.value[] array. If a repeat count is
2092 greater than one, we copy the data item multiple times. */
2095 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
2096 int kind
, size_t size
)
2102 dtp
->u
.p
.namelist_mode
= 0;
2104 /* Set the next_char and push_char worker functions. */
2107 if (dtp
->u
.p
.first_item
)
2109 dtp
->u
.p
.first_item
= 0;
2110 dtp
->u
.p
.input_complete
= 0;
2111 dtp
->u
.p
.repeat_count
= 1;
2112 dtp
->u
.p
.at_eol
= 0;
2114 if ((c
= eat_spaces (dtp
)) == EOF
)
2119 if (is_separator (c
))
2121 /* Found a null value. */
2122 dtp
->u
.p
.repeat_count
= 0;
2123 eat_separator (dtp
);
2125 /* Set end-of-line flag. */
2126 if (c
== '\n' || c
== '\r')
2128 dtp
->u
.p
.at_eol
= 1;
2129 if (finish_separator (dtp
) == LIBERROR_END
)
2141 if (dtp
->u
.p
.repeat_count
> 0)
2143 if (check_type (dtp
, type
, kind
))
2148 if (dtp
->u
.p
.input_complete
)
2151 if (dtp
->u
.p
.at_eol
)
2152 finish_separator (dtp
);
2156 /* Trailing spaces prior to end of line. */
2157 if (dtp
->u
.p
.at_eol
)
2158 finish_separator (dtp
);
2161 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2162 dtp
->u
.p
.repeat_count
= 1;
2168 read_integer (dtp
, kind
);
2171 read_logical (dtp
, kind
);
2174 read_character (dtp
, kind
);
2177 read_real (dtp
, p
, kind
);
2178 /* Copy value back to temporary if needed. */
2179 if (dtp
->u
.p
.repeat_count
> 0)
2180 memcpy (dtp
->u
.p
.value
, p
, size
);
2183 read_complex (dtp
, p
, kind
, size
);
2184 /* Copy value back to temporary if needed. */
2185 if (dtp
->u
.p
.repeat_count
> 0)
2186 memcpy (dtp
->u
.p
.value
, p
, size
);
2190 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2191 char iotype
[] = "LISTDIRECTED";
2192 gfc_charlen_type iotype_len
= 12;
2193 char tmp_iomsg
[IOMSG_LEN
] = "";
2195 gfc_charlen_type child_iomsg_len
;
2197 int *child_iostat
= NULL
;
2200 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
2201 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2203 /* Set iostat, intent(out). */
2205 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2206 dtp
->common
.iostat
: &noiostat
;
2208 /* Set iomsge, intent(inout). */
2209 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2211 child_iomsg
= dtp
->common
.iomsg
;
2212 child_iomsg_len
= dtp
->common
.iomsg_len
;
2216 child_iomsg
= tmp_iomsg
;
2217 child_iomsg_len
= IOMSG_LEN
;
2220 /* Call the user defined formatted READ procedure. */
2221 dtp
->u
.p
.current_unit
->child_dtio
++;
2222 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
2223 child_iostat
, child_iomsg
,
2224 iotype_len
, child_iomsg_len
);
2225 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
2226 dtp
->u
.p
.current_unit
->child_dtio
--;
2230 internal_error (&dtp
->common
, "Bad type for list read");
2233 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
2234 dtp
->u
.p
.saved_length
= size
;
2236 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2240 switch (dtp
->u
.p
.saved_type
)
2244 if (dtp
->u
.p
.repeat_count
> 0)
2245 memcpy (p
, dtp
->u
.p
.value
, size
);
2250 memcpy (p
, dtp
->u
.p
.value
, size
);
2254 if (dtp
->u
.p
.saved_string
)
2256 m
= ((int) size
< dtp
->u
.p
.saved_used
)
2257 ? (int) size
: dtp
->u
.p
.saved_used
;
2259 q
= (gfc_char4_t
*) p
;
2260 r
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
2261 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2262 for (i
= 0; i
< m
; i
++)
2267 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
2269 for (i
= 0; i
< m
; i
++)
2274 /* Just delimiters encountered, nothing to copy but SPACE. */
2280 memset (((char *) p
) + m
, ' ', size
- m
);
2283 q
= (gfc_char4_t
*) p
;
2284 for (i
= m
; i
< (int) size
; i
++)
2285 q
[i
] = (unsigned char) ' ';
2294 internal_error (&dtp
->common
, "Bad type for list read");
2297 if (--dtp
->u
.p
.repeat_count
<= 0)
2301 /* err may have been set above from finish_separator, so if it is set
2302 trigger the hit_eof. The hit_eof will set bits in common.flags. */
2303 if (err
== LIBERROR_END
)
2308 /* Now we check common.flags for any errors that could have occurred in
2309 a READ elsewhere such as in read_integer. */
2310 err
= dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
;
2311 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_READING
);
2317 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2318 size_t size
, size_t nelems
)
2322 size_t stride
= type
== BT_CHARACTER
?
2323 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2328 /* Big loop over all the elements. */
2329 for (elem
= 0; elem
< nelems
; elem
++)
2331 dtp
->u
.p
.item_count
++;
2332 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2340 /* Finish a list read. */
2343 finish_list_read (st_parameter_dt
*dtp
)
2347 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2349 if (dtp
->u
.p
.at_eol
)
2351 dtp
->u
.p
.at_eol
= 0;
2355 if (!is_internal_unit (dtp
))
2359 /* Set the next_char and push_char worker functions. */
2362 if (likely (dtp
->u
.p
.child_saved_iostat
== LIBERROR_OK
))
2364 c
= next_char (dtp
);
2382 void namelist_read (st_parameter_dt *dtp)
2384 static void nml_match_name (char *name, int len)
2385 static int nml_query (st_parameter_dt *dtp)
2386 static int nml_get_obj_data (st_parameter_dt *dtp,
2387 namelist_info **prev_nl, char *, size_t)
2389 static void nml_untouch_nodes (st_parameter_dt *dtp)
2390 static namelist_info *find_nml_node (st_parameter_dt *dtp,
2392 static int nml_parse_qualifier(descriptor_dimension *ad,
2393 array_loop_spec *ls, int rank, char *)
2394 static void nml_touch_nodes (namelist_info *nl)
2395 static int nml_read_obj (namelist_info *nl, index_type offset,
2396 namelist_info **prev_nl, char *, size_t,
2397 index_type clow, index_type chigh)
2401 /* Inputs a rank-dimensional qualifier, which can contain
2402 singlets, doublets, triplets or ':' with the standard meanings. */
2405 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2406 array_loop_spec
*ls
, int rank
, bt nml_elem_type
,
2407 char *parse_err_msg
, size_t parse_err_msg_size
,
2414 int is_array_section
, is_char
;
2418 is_array_section
= 0;
2419 dtp
->u
.p
.expanded_read
= 0;
2421 /* See if this is a character substring qualifier we are looking for. */
2428 /* The next character in the stream should be the '('. */
2430 if ((c
= next_char (dtp
)) == EOF
)
2433 /* Process the qualifier, by dimension and triplet. */
2435 for (dim
=0; dim
< rank
; dim
++ )
2437 for (indx
=0; indx
<3; indx
++)
2443 /* Process a potential sign. */
2444 if ((c
= next_char (dtp
)) == EOF
)
2456 unget_char (dtp
, c
);
2460 /* Process characters up to the next ':' , ',' or ')'. */
2463 c
= next_char (dtp
);
2470 is_array_section
= 1;
2474 if ((c
==',' && dim
== rank
-1)
2475 || (c
==')' && dim
< rank
-1))
2478 snprintf (parse_err_msg
, parse_err_msg_size
,
2479 "Bad substring qualifier");
2481 snprintf (parse_err_msg
, parse_err_msg_size
,
2482 "Bad number of index fields");
2491 case ' ': case '\t': case '\r': case '\n':
2497 snprintf (parse_err_msg
, parse_err_msg_size
,
2498 "Bad character in substring qualifier");
2500 snprintf (parse_err_msg
, parse_err_msg_size
,
2501 "Bad character in index");
2505 if ((c
== ',' || c
== ')') && indx
== 0
2506 && dtp
->u
.p
.saved_string
== 0)
2509 snprintf (parse_err_msg
, parse_err_msg_size
,
2510 "Null substring qualifier");
2512 snprintf (parse_err_msg
, parse_err_msg_size
,
2513 "Null index field");
2517 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2518 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2521 snprintf (parse_err_msg
, parse_err_msg_size
,
2522 "Bad substring qualifier");
2524 snprintf (parse_err_msg
, parse_err_msg_size
,
2525 "Bad index triplet");
2529 if (is_char
&& !is_array_section
)
2531 snprintf (parse_err_msg
, parse_err_msg_size
,
2532 "Missing colon in substring qualifier");
2536 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2538 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2539 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2545 /* Now read the index. */
2546 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2549 snprintf (parse_err_msg
, parse_err_msg_size
,
2550 "Bad integer substring qualifier");
2552 snprintf (parse_err_msg
, parse_err_msg_size
,
2553 "Bad integer in index");
2559 /* Feed the index values to the triplet arrays. */
2563 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2565 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2567 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2570 /* Singlet or doublet indices. */
2571 if (c
==',' || c
==')')
2575 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2577 /* If -std=f95/2003 or an array section is specified,
2578 do not allow excess data to be processed. */
2579 if (is_array_section
== 1
2580 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2581 || nml_elem_type
== BT_DERIVED
)
2582 ls
[dim
].end
= ls
[dim
].start
;
2584 dtp
->u
.p
.expanded_read
= 1;
2587 /* Check for non-zero rank. */
2588 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2595 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2598 dtp
->u
.p
.expanded_read
= 0;
2599 for (i
= 0; i
< dim
; i
++)
2600 ls
[i
].end
= ls
[i
].start
;
2603 /* Check the values of the triplet indices. */
2604 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2605 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2606 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2607 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2610 snprintf (parse_err_msg
, parse_err_msg_size
,
2611 "Substring out of range");
2613 snprintf (parse_err_msg
, parse_err_msg_size
,
2614 "Index %d out of range", dim
+ 1);
2618 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2619 || (ls
[dim
].step
== 0))
2621 snprintf (parse_err_msg
, parse_err_msg_size
,
2622 "Bad range in index %d", dim
+ 1);
2626 /* Initialise the loop index counter. */
2627 ls
[dim
].idx
= ls
[dim
].start
;
2634 /* The EOF error message is issued by hit_eof. Return true so that the
2635 caller does not use parse_err_msg and parse_err_msg_size to generate
2636 an unrelated error message. */
2640 dtp
->u
.p
.input_complete
= 1;
2648 extended_look_ahead (char *p
, char *q
)
2652 /* Scan ahead to find a '%' in the p string. */
2653 for(r
= p
, s
= q
; *r
&& *s
; s
++)
2654 if ((*s
== '%' || *s
== '+') && strcmp (r
+ 1, s
+ 1) == 0)
2661 strcmp_extended_type (char *p
, char *q
)
2665 for (r
= p
, s
= q
; *r
&& *s
; r
++, s
++)
2669 if (*r
== '%' && *s
== '+' && extended_look_ahead (r
, s
))
2678 static namelist_info
*
2679 find_nml_node (st_parameter_dt
*dtp
, char *var_name
)
2681 namelist_info
*t
= dtp
->u
.p
.ionml
;
2684 if (strcmp (var_name
, t
->var_name
) == 0)
2689 if (strcmp_extended_type (var_name
, t
->var_name
))
2699 /* Visits all the components of a derived type that have
2700 not explicitly been identified in the namelist input.
2701 touched is set and the loop specification initialised
2702 to default values */
2705 nml_touch_nodes (namelist_info
*nl
)
2707 index_type len
= strlen (nl
->var_name
) + 1;
2709 char *ext_name
= xmalloc (len
+ 1);
2710 memcpy (ext_name
, nl
->var_name
, len
-1);
2711 memcpy (ext_name
+ len
- 1, "%", 2);
2712 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2714 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2717 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2719 nl
->ls
[dim
].step
= 1;
2720 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2721 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2722 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2732 /* Resets touched for the entire list of nml_nodes, ready for a
2736 nml_untouch_nodes (st_parameter_dt
*dtp
)
2739 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2744 /* Attempts to input name to namelist name. Returns
2745 dtp->u.p.nml_read_error = 1 on no match. */
2748 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2753 dtp
->u
.p
.nml_read_error
= 0;
2754 for (i
= 0; i
< len
; i
++)
2756 c
= next_char (dtp
);
2757 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2759 dtp
->u
.p
.nml_read_error
= 1;
2765 /* If the namelist read is from stdin, output the current state of the
2766 namelist to stdout. This is used to implement the non-standard query
2767 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2768 the names alone are printed. */
2771 nml_query (st_parameter_dt
*dtp
, char c
)
2773 gfc_unit
*temp_unit
;
2778 static const index_type endlen
= 2;
2779 static const char endl
[] = "\r\n";
2780 static const char nmlend
[] = "&end\r\n";
2782 static const index_type endlen
= 1;
2783 static const char endl
[] = "\n";
2784 static const char nmlend
[] = "&end\n";
2787 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2790 /* Store the current unit and transfer to stdout. */
2792 temp_unit
= dtp
->u
.p
.current_unit
;
2793 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2795 if (dtp
->u
.p
.current_unit
)
2797 dtp
->u
.p
.mode
= WRITING
;
2798 next_record (dtp
, 0);
2800 /* Write the namelist in its entirety. */
2803 namelist_write (dtp
);
2805 /* Or write the list of names. */
2809 /* "&namelist_name\n" */
2811 len
= dtp
->namelist_name_len
;
2812 p
= write_block (dtp
, len
- 1 + endlen
);
2816 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2817 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2818 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2822 len
= strlen (nl
->var_name
);
2823 p
= write_block (dtp
, len
+ endlen
);
2827 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2828 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2833 p
= write_block (dtp
, endlen
+ 4);
2836 memcpy (p
, &nmlend
, endlen
+ 4);
2839 /* Flush the stream to force immediate output. */
2841 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2842 sflush (dtp
->u
.p
.current_unit
->s
);
2843 unlock_unit (dtp
->u
.p
.current_unit
);
2848 /* Restore the current unit. */
2850 dtp
->u
.p
.current_unit
= temp_unit
;
2851 dtp
->u
.p
.mode
= READING
;
2855 /* Reads and stores the input for the namelist object nl. For an array,
2856 the function loops over the ranges defined by the loop specification.
2857 This default to all the data or to the specification from a qualifier.
2858 nml_read_obj recursively calls itself to read derived types. It visits
2859 all its own components but only reads data for those that were touched
2860 when the name was parsed. If a read error is encountered, an attempt is
2861 made to return to read a new object name because the standard allows too
2862 little data to be available. On the other hand, too much data is an
2866 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
*nl
, index_type offset
,
2867 namelist_info
**pprev_nl
, char *nml_err_msg
,
2868 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2877 size_t obj_name_len
;
2881 /* If we have encountered a previous read error or this object has not been
2882 touched in name parsing, just return. */
2883 if (dtp
->u
.p
.nml_read_error
|| !nl
->touched
)
2886 dtp
->u
.p
.item_count
++; /* Used in error messages. */
2887 dtp
->u
.p
.repeat_count
= 0;
2899 dlen
= size_from_real_kind (len
);
2903 dlen
= size_from_complex_kind (len
);
2907 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2916 /* Update the pointer to the data, using the current index vector */
2918 if ((nl
->type
== BT_DERIVED
|| nl
->type
== BT_CLASS
)
2919 && nl
->dtio_sub
!= NULL
)
2921 pdata
= NULL
; /* Not used under these conidtions. */
2922 if (nl
->type
== BT_CLASS
)
2923 list_obj
.data
= ((gfc_class
*)nl
->mem_pos
)->data
;
2925 list_obj
.data
= (void *)nl
->mem_pos
;
2927 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2928 list_obj
.data
= list_obj
.data
+ (nl
->ls
[dim
].idx
2929 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2930 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
;
2934 pdata
= (void*)(nl
->mem_pos
+ offset
);
2935 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2936 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2937 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2938 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2941 /* If we are finished with the repeat count, try to read next value. */
2944 if (--dtp
->u
.p
.repeat_count
<= 0)
2946 if (dtp
->u
.p
.input_complete
)
2948 if (dtp
->u
.p
.at_eol
)
2949 finish_separator (dtp
);
2950 if (dtp
->u
.p
.input_complete
)
2953 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2959 read_integer (dtp
, len
);
2963 read_logical (dtp
, len
);
2967 read_character (dtp
, len
);
2971 /* Need to copy data back from the real location to the temp in
2972 order to handle nml reads into arrays. */
2973 read_real (dtp
, pdata
, len
);
2974 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2978 /* Same as for REAL, copy back to temp. */
2979 read_complex (dtp
, pdata
, len
, dlen
);
2980 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2985 /* If this object has a User Defined procedure, call it. */
2986 if (nl
->dtio_sub
!= NULL
)
2988 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2989 char iotype
[] = "NAMELIST";
2990 gfc_charlen_type iotype_len
= 8;
2991 char tmp_iomsg
[IOMSG_LEN
] = "";
2993 gfc_charlen_type child_iomsg_len
;
2995 int *child_iostat
= NULL
;
2997 formatted_dtio dtio_ptr
= (formatted_dtio
)nl
->dtio_sub
;
2999 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
3000 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
3002 list_obj
.vptr
= nl
->vtable
;
3005 /* Set iostat, intent(out). */
3007 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
3008 dtp
->common
.iostat
: &noiostat
;
3010 /* Set iomsg, intent(inout). */
3011 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
3013 child_iomsg
= dtp
->common
.iomsg
;
3014 child_iomsg_len
= dtp
->common
.iomsg_len
;
3018 child_iomsg
= tmp_iomsg
;
3019 child_iomsg_len
= IOMSG_LEN
;
3022 /* If reading from an internal unit, stash it to allow
3023 the child procedure to access it. */
3024 if (is_internal_unit (dtp
))
3025 stash_internal_unit (dtp
);
3027 /* Call the user defined formatted READ procedure. */
3028 dtp
->u
.p
.current_unit
->child_dtio
++;
3029 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
3030 child_iostat
, child_iomsg
,
3031 iotype_len
, child_iomsg_len
);
3032 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
3033 dtp
->u
.p
.current_unit
->child_dtio
--;
3037 /* Must be default derived type namelist read. */
3038 obj_name_len
= strlen (nl
->var_name
) + 1;
3039 obj_name
= xmalloc (obj_name_len
+1);
3040 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
3041 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
3043 /* If reading a derived type, disable the expanded read warning
3044 since a single object can have multiple reads. */
3045 dtp
->u
.p
.expanded_read
= 0;
3047 /* Now loop over the components. */
3049 for (cmp
= nl
->next
;
3051 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
3054 /* Jump over nested derived type by testing if the potential
3055 component name contains '%'. */
3056 if (strchr (cmp
->var_name
+ obj_name_len
, '%'))
3059 if (!nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
3060 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3067 if (dtp
->u
.p
.input_complete
)
3078 snprintf (nml_err_msg
, nml_err_msg_size
,
3079 "Bad type for namelist object %s", nl
->var_name
);
3080 internal_error (&dtp
->common
, nml_err_msg
);
3085 /* The standard permits array data to stop short of the number of
3086 elements specified in the loop specification. In this case, we
3087 should be here with dtp->u.p.nml_read_error != 0. Control returns to
3088 nml_get_obj_data and an attempt is made to read object name. */
3091 if (dtp
->u
.p
.nml_read_error
)
3093 dtp
->u
.p
.expanded_read
= 0;
3097 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
3099 dtp
->u
.p
.expanded_read
= 0;
3103 switch (dtp
->u
.p
.saved_type
)
3110 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
3114 if (dlen
< dtp
->u
.p
.saved_used
)
3116 if (compile_options
.bounds_check
)
3118 snprintf (nml_err_msg
, nml_err_msg_size
,
3119 "Namelist object '%s' truncated on read.",
3121 generate_warning (&dtp
->common
, nml_err_msg
);
3126 m
= dtp
->u
.p
.saved_used
;
3128 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
3130 gfc_char4_t
*q4
, *p4
= pdata
;
3133 q4
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
3135 for (i
= 0; i
< m
; i
++)
3138 for (i
= 0; i
< dlen
- m
; i
++)
3139 *p4
++ = (gfc_char4_t
) ' ';
3143 pdata
= (void*)( pdata
+ clow
- 1 );
3144 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
3146 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
3154 /* Warn if a non-standard expanded read occurs. A single read of a
3155 single object is acceptable. If a second read occurs, issue a warning
3156 and set the flag to zero to prevent further warnings. */
3157 if (dtp
->u
.p
.expanded_read
== 2)
3159 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
3160 dtp
->u
.p
.expanded_read
= 0;
3163 /* If the expanded read warning flag is set, increment it,
3164 indicating that a single read has occurred. */
3165 if (dtp
->u
.p
.expanded_read
>= 1)
3166 dtp
->u
.p
.expanded_read
++;
3168 /* Break out of loop if scalar. */
3172 /* Now increment the index vector. */
3177 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
3179 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
3181 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
3183 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
3185 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
3189 } while (!nml_carry
);
3191 if (dtp
->u
.p
.repeat_count
> 1)
3193 snprintf (nml_err_msg
, nml_err_msg_size
,
3194 "Repeat count too large for namelist object %s", nl
->var_name
);
3204 /* Parses the object name, including array and substring qualifiers. It
3205 iterates over derived type components, touching those components and
3206 setting their loop specifications, if there is a qualifier. If the
3207 object is itself a derived type, its components and subcomponents are
3208 touched. nml_read_obj is called at the end and this reads the data in
3209 the manner specified by the object name. */
3212 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
3213 char *nml_err_msg
, size_t nml_err_msg_size
)
3217 namelist_info
*first_nl
= NULL
;
3218 namelist_info
*root_nl
= NULL
;
3219 int dim
, parsed_rank
;
3220 int component_flag
, qualifier_flag
;
3221 index_type clow
, chigh
;
3222 int non_zero_rank_count
;
3224 /* Look for end of input or object name. If '?' or '=?' are encountered
3225 in stdin, print the node names or the namelist to stdout. */
3227 eat_separator (dtp
);
3228 if (dtp
->u
.p
.input_complete
)
3231 if (dtp
->u
.p
.at_eol
)
3232 finish_separator (dtp
);
3233 if (dtp
->u
.p
.input_complete
)
3236 if ((c
= next_char (dtp
)) == EOF
)
3241 if ((c
= next_char (dtp
)) == EOF
)
3245 snprintf (nml_err_msg
, nml_err_msg_size
,
3246 "namelist read: misplaced = sign");
3249 nml_query (dtp
, '=');
3253 nml_query (dtp
, '?');
3258 nml_match_name (dtp
, "end", 3);
3259 if (dtp
->u
.p
.nml_read_error
)
3261 snprintf (nml_err_msg
, nml_err_msg_size
,
3262 "namelist not terminated with / or &end");
3267 dtp
->u
.p
.input_complete
= 1;
3274 /* Untouch all nodes of the namelist and reset the flags that are set for
3275 derived type components. */
3277 nml_untouch_nodes (dtp
);
3280 non_zero_rank_count
= 0;
3282 /* Get the object name - should '!' and '\n' be permitted separators? */
3290 if (!is_separator (c
))
3291 push_char_default (dtp
, tolower(c
));
3292 if ((c
= next_char (dtp
)) == EOF
)
3295 while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
3297 unget_char (dtp
, c
);
3299 /* Check that the name is in the namelist and get pointer to object.
3300 Three error conditions exist: (i) An attempt is being made to
3301 identify a non-existent object, following a failed data read or
3302 (ii) The object name does not exist or (iii) Too many data items
3303 are present for an object. (iii) gives the same error message
3306 push_char_default (dtp
, '\0');
3310 #define EXT_STACK_SZ 100
3311 char ext_stack
[EXT_STACK_SZ
];
3313 size_t var_len
= strlen (root_nl
->var_name
);
3315 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
3316 size_t ext_size
= var_len
+ saved_len
+ 1;
3318 if (ext_size
> EXT_STACK_SZ
)
3319 ext_name
= xmalloc (ext_size
);
3321 ext_name
= ext_stack
;
3323 memcpy (ext_name
, root_nl
->var_name
, var_len
);
3324 if (dtp
->u
.p
.saved_string
)
3325 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
3326 ext_name
[var_len
+ saved_len
] = '\0';
3327 nl
= find_nml_node (dtp
, ext_name
);
3329 if (ext_size
> EXT_STACK_SZ
)
3333 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
3337 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
3338 snprintf (nml_err_msg
, nml_err_msg_size
,
3339 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
3342 snprintf (nml_err_msg
, nml_err_msg_size
,
3343 "Cannot match namelist object name %s",
3344 dtp
->u
.p
.saved_string
);
3349 /* Get the length, data length, base pointer and rank of the variable.
3350 Set the default loop specification first. */
3352 for (dim
=0; dim
< nl
->var_rank
; dim
++)
3354 nl
->ls
[dim
].step
= 1;
3355 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
3356 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
3357 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
3360 /* Check to see if there is a qualifier: if so, parse it.*/
3362 if (c
== '(' && nl
->var_rank
)
3365 if (!nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
3366 nl
->type
, nml_err_msg
, nml_err_msg_size
,
3369 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
3370 snprintf (nml_err_msg_end
,
3371 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
3372 " for namelist variable %s", nl
->var_name
);
3375 if (parsed_rank
> 0)
3376 non_zero_rank_count
++;
3380 if ((c
= next_char (dtp
)) == EOF
)
3382 unget_char (dtp
, c
);
3384 else if (nl
->var_rank
> 0)
3385 non_zero_rank_count
++;
3387 /* Now parse a derived type component. The root namelist_info address
3388 is backed up, as is the previous component level. The component flag
3389 is set and the iteration is made by jumping back to get_name. */
3393 if (nl
->type
!= BT_DERIVED
)
3395 snprintf (nml_err_msg
, nml_err_msg_size
,
3396 "Attempt to get derived component for %s", nl
->var_name
);
3400 /* Don't move first_nl further in the list if a qualifier was found. */
3401 if ((*pprev_nl
== NULL
&& !qualifier_flag
) || !component_flag
)
3407 if ((c
= next_char (dtp
)) == EOF
)
3412 /* Parse a character qualifier, if present. chigh = 0 is a default
3413 that signals that the string length = string_length. */
3418 if (c
== '(' && nl
->type
== BT_CHARACTER
)
3420 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
3421 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
3423 if (!nml_parse_qualifier (dtp
, chd
, ind
, -1, nl
->type
,
3424 nml_err_msg
, nml_err_msg_size
, &parsed_rank
))
3426 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
3427 snprintf (nml_err_msg_end
,
3428 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
3429 " for namelist variable %s", nl
->var_name
);
3433 clow
= ind
[0].start
;
3436 if (ind
[0].step
!= 1)
3438 snprintf (nml_err_msg
, nml_err_msg_size
,
3439 "Step not allowed in substring qualifier"
3440 " for namelist object %s", nl
->var_name
);
3444 if ((c
= next_char (dtp
)) == EOF
)
3446 unget_char (dtp
, c
);
3449 /* Make sure no extraneous qualifiers are there. */
3453 snprintf (nml_err_msg
, nml_err_msg_size
,
3454 "Qualifier for a scalar or non-character namelist object %s",
3459 /* Make sure there is no more than one non-zero rank object. */
3460 if (non_zero_rank_count
> 1)
3462 snprintf (nml_err_msg
, nml_err_msg_size
,
3463 "Multiple sub-objects with non-zero rank in namelist object %s",
3465 non_zero_rank_count
= 0;
3469 /* According to the standard, an equal sign MUST follow an object name. The
3470 following is possibly lax - it allows comments, blank lines and so on to
3471 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
3475 eat_separator (dtp
);
3476 if (dtp
->u
.p
.input_complete
)
3479 if (dtp
->u
.p
.at_eol
)
3480 finish_separator (dtp
);
3481 if (dtp
->u
.p
.input_complete
)
3484 if ((c
= next_char (dtp
)) == EOF
)
3489 snprintf (nml_err_msg
, nml_err_msg_size
,
3490 "Equal sign must follow namelist object name %s",
3495 /* If a derived type, touch its components and restore the root
3496 namelist_info if we have parsed a qualified derived type
3499 if (nl
->type
== BT_DERIVED
&& nl
->dtio_sub
== NULL
)
3500 nml_touch_nodes (nl
);
3504 if (first_nl
->var_rank
== 0)
3506 if (component_flag
&& qualifier_flag
)
3513 dtp
->u
.p
.nml_read_error
= 0;
3514 if (!nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3522 /* The EOF error message is issued by hit_eof. Return true so that the
3523 caller does not use nml_err_msg and nml_err_msg_size to generate
3524 an unrelated error message. */
3527 dtp
->u
.p
.input_complete
= 1;
3528 unget_char (dtp
, c
);
3535 /* Entry point for namelist input. Goes through input until namelist name
3536 is matched. Then cycles through nml_get_obj_data until the input is
3537 completed or there is an error. */
3540 namelist_read (st_parameter_dt
*dtp
)
3543 char nml_err_msg
[200];
3545 /* Initialize the error string buffer just in case we get an unexpected fail
3546 somewhere and end up at nml_err_ret. */
3547 strcpy (nml_err_msg
, "Internal namelist read error");
3549 /* Pointer to the previously read object, in case attempt is made to read
3550 new object name. Should this fail, error message can give previous
3552 namelist_info
*prev_nl
= NULL
;
3554 dtp
->u
.p
.namelist_mode
= 1;
3555 dtp
->u
.p
.input_complete
= 0;
3556 dtp
->u
.p
.expanded_read
= 0;
3558 /* Set the next_char and push_char worker functions. */
3561 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3562 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3563 node names or namelist on stdout. */
3566 c
= next_char (dtp
);
3578 c
= next_char (dtp
);
3580 nml_query (dtp
, '=');
3582 unget_char (dtp
, c
);
3586 nml_query (dtp
, '?');
3596 /* Match the name of the namelist. */
3598 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3600 if (dtp
->u
.p
.nml_read_error
)
3603 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3604 c
= next_char (dtp
);
3605 if (!is_separator(c
) && c
!= '!')
3607 unget_char (dtp
, c
);
3611 unget_char (dtp
, c
);
3612 eat_separator (dtp
);
3614 /* Ready to read namelist objects. If there is an error in input
3615 from stdin, output the error message and continue. */
3617 while (!dtp
->u
.p
.input_complete
)
3619 if (!nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
))
3621 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3623 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3626 /* Reset the previous namelist pointer if we know we are not going
3627 to be doing multiple reads within a single namelist object. */
3628 if (prev_nl
&& prev_nl
->var_rank
== 0)
3639 /* All namelist error calls return from here */
3642 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);