1 /* Copyright (C) 2002-2014 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/>. */
36 /* List directed input. Several parsing subroutines are practically
37 reimplemented from formatted input, the reason being that there are
38 all kinds of small differences between formatted and list directed
42 /* Subroutines for reading characters from the input. Because a
43 repeat count is ambiguous with an integer, we have to read the
44 whole digit string before seeing if there is a '*' which signals
45 the repeat count. Since we can have a lot of potential leading
46 zeros, we have to be able to back up by arbitrary amount. Because
47 the input might not be seekable, we have to buffer the data
50 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
51 case '5': case '6': case '7': case '8': case '9'
53 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
56 /* This macro assumes that we're operating on a variable. */
58 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
59 || c == '\t' || c == '\r' || c == ';')
61 /* Maximum repeat count. Less than ten times the maximum signed int32. */
63 #define MAX_REPEAT 200000000
68 /* Save a character to a string buffer, enlarging it as necessary. */
71 push_char (st_parameter_dt
*dtp
, char c
)
75 if (dtp
->u
.p
.saved_string
== NULL
)
77 // Plain malloc should suffice here, zeroing not needed?
78 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
79 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
80 dtp
->u
.p
.saved_used
= 0;
83 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
85 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
86 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
88 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
89 dtp
->u
.p
.saved_string
= new;
91 // Also this should not be necessary.
92 memset (new + dtp
->u
.p
.saved_used
, 0,
93 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
97 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
101 /* Free the input buffer if necessary. */
104 free_saved (st_parameter_dt
*dtp
)
106 if (dtp
->u
.p
.saved_string
== NULL
)
109 free (dtp
->u
.p
.saved_string
);
111 dtp
->u
.p
.saved_string
= NULL
;
112 dtp
->u
.p
.saved_used
= 0;
116 /* Free the line buffer if necessary. */
119 free_line (st_parameter_dt
*dtp
)
121 dtp
->u
.p
.line_buffer_pos
= 0;
122 dtp
->u
.p
.line_buffer_enabled
= 0;
124 if (dtp
->u
.p
.line_buffer
== NULL
)
127 free (dtp
->u
.p
.line_buffer
);
128 dtp
->u
.p
.line_buffer
= NULL
;
133 next_char (st_parameter_dt
*dtp
)
139 if (dtp
->u
.p
.last_char
!= EOF
- 1)
142 c
= dtp
->u
.p
.last_char
;
143 dtp
->u
.p
.last_char
= EOF
- 1;
147 /* Read from line_buffer if enabled. */
149 if (dtp
->u
.p
.line_buffer_enabled
)
153 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
];
154 if (c
!= '\0' && dtp
->u
.p
.line_buffer_pos
< 64)
156 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
] = '\0';
157 dtp
->u
.p
.line_buffer_pos
++;
161 dtp
->u
.p
.line_buffer_pos
= 0;
162 dtp
->u
.p
.line_buffer_enabled
= 0;
165 /* Handle the end-of-record and end-of-file conditions for
166 internal array unit. */
167 if (is_array_io (dtp
))
172 /* Check for "end-of-record" condition. */
173 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
178 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
181 /* Check for "end-of-file" condition. */
188 record
*= dtp
->u
.p
.current_unit
->recl
;
189 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
192 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
197 /* Get the next character and handle end-of-record conditions. */
199 if (is_internal_unit (dtp
))
201 /* Check for kind=4 internal unit. */
202 if (dtp
->common
.unit
)
203 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, sizeof (gfc_char4_t
));
207 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
213 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
217 if (is_array_io (dtp
))
219 /* Check whether we hit EOF. */
222 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
225 dtp
->u
.p
.current_unit
->bytes_left
--;
240 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
241 if (c
!= EOF
&& is_stream_io (dtp
))
242 dtp
->u
.p
.current_unit
->strm_pos
++;
245 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt
*dtp
, int c
)
255 dtp
->u
.p
.last_char
= c
;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt
*dtp
)
269 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
276 /* This function reads characters through to the end of the current
277 line and just ignores them. Returns 0 for success and LIBERROR_END
281 eat_line (st_parameter_dt
*dtp
)
287 while (c
!= EOF
&& c
!= '\n');
294 /* Skip over a separator. Technically, we don't always eat the whole
295 separator. This is because if we've processed the last input item,
296 then a separator is unnecessary. Plus the fact that operating
297 systems usually deliver console input on a line basis.
299 The upshot is that if we see a newline as part of reading a
300 separator, we stop reading. If there are more input items, we
301 continue reading the separator with finish_separator() which takes
302 care of the fact that we may or may not have seen a comma as part
305 Returns 0 for success, and non-zero error code otherwise. */
308 eat_separator (st_parameter_dt
*dtp
)
314 dtp
->u
.p
.comma_flag
= 0;
316 if ((c
= next_char (dtp
)) == EOF
)
321 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
328 dtp
->u
.p
.comma_flag
= 1;
333 dtp
->u
.p
.input_complete
= 1;
337 if ((n
= next_char(dtp
)) == EOF
)
347 if (dtp
->u
.p
.namelist_mode
)
351 if ((c
= next_char (dtp
)) == EOF
)
355 err
= eat_line (dtp
);
361 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
367 if (dtp
->u
.p
.namelist_mode
)
368 { /* Eat a namelist comment. */
369 err
= eat_line (dtp
);
376 /* Fall Through... */
386 /* Finish processing a separator that was interrupted by a newline.
387 If we're here, then another data item is present, so we finish what
388 we started on the previous line. Return 0 on success, error code
392 finish_separator (st_parameter_dt
*dtp
)
395 int err
= LIBERROR_OK
;
400 if ((c
= next_char (dtp
)) == EOF
)
405 if (dtp
->u
.p
.comma_flag
)
409 if ((c
= eat_spaces (dtp
)) == EOF
)
411 if (c
== '\n' || c
== '\r')
418 dtp
->u
.p
.input_complete
= 1;
419 if (!dtp
->u
.p
.namelist_mode
)
428 if (dtp
->u
.p
.namelist_mode
)
430 err
= eat_line (dtp
);
444 /* This function is needed to catch bad conversions so that namelist can
445 attempt to see if dtp->u.p.saved_string contains a new object name rather
449 nml_bad_return (st_parameter_dt
*dtp
, char c
)
451 if (dtp
->u
.p
.namelist_mode
)
453 dtp
->u
.p
.nml_read_error
= 1;
460 /* Convert an unsigned string to an integer. The length value is -1
461 if we are working on a repeat count. Returns nonzero if we have a
462 range problem. As a side effect, frees the dtp->u.p.saved_string. */
465 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
467 char c
, *buffer
, message
[MSGLEN
];
469 GFC_UINTEGER_LARGEST v
, max
, max10
;
470 GFC_INTEGER_LARGEST value
;
472 buffer
= dtp
->u
.p
.saved_string
;
479 max
= si_max (length
);
509 set_integer (dtp
->u
.p
.value
, value
, length
);
513 dtp
->u
.p
.repeat_count
= v
;
515 if (dtp
->u
.p
.repeat_count
== 0)
517 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
518 dtp
->u
.p
.item_count
);
520 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
530 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
531 dtp
->u
.p
.item_count
);
533 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
534 dtp
->u
.p
.item_count
);
537 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
543 /* Parse a repeat count for logical and complex values which cannot
544 begin with a digit. Returns nonzero if we are done, zero if we
545 should continue on. */
548 parse_repeat (st_parameter_dt
*dtp
)
550 char message
[MSGLEN
];
553 if ((c
= next_char (dtp
)) == EOF
)
577 repeat
= 10 * repeat
+ c
- '0';
579 if (repeat
> MAX_REPEAT
)
581 snprintf (message
, MSGLEN
,
582 "Repeat count overflow in item %d of list input",
583 dtp
->u
.p
.item_count
);
585 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
594 snprintf (message
, MSGLEN
,
595 "Zero repeat count in item %d of list input",
596 dtp
->u
.p
.item_count
);
598 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
610 dtp
->u
.p
.repeat_count
= repeat
;
624 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
625 dtp
->u
.p
.item_count
);
626 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
631 /* To read a logical we have to look ahead in the input stream to make sure
632 there is not an equal sign indicating a variable name. To do this we use
633 line_buffer to point to a temporary buffer, pushing characters there for
634 possible later reading. */
637 l_push_char (st_parameter_dt
*dtp
, char c
)
639 if (dtp
->u
.p
.line_buffer
== NULL
)
640 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
642 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
++] = c
;
646 /* Read a logical character on the input. */
649 read_logical (st_parameter_dt
*dtp
, int length
)
651 char message
[MSGLEN
];
654 if (parse_repeat (dtp
))
657 c
= tolower (next_char (dtp
));
658 l_push_char (dtp
, c
);
664 l_push_char (dtp
, c
);
666 if (!is_separator(c
) && c
!= EOF
)
674 l_push_char (dtp
, c
);
676 if (!is_separator(c
) && c
!= EOF
)
683 c
= tolower (next_char (dtp
));
702 return; /* Null value. */
705 /* Save the character in case it is the beginning
706 of the next object name. */
711 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
712 dtp
->u
.p
.saved_length
= length
;
714 /* Eat trailing garbage. */
717 while (c
!= EOF
&& !is_separator (c
));
721 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
728 for(i
= 0; i
< 63; i
++)
733 /* All done if this is not a namelist read. */
734 if (!dtp
->u
.p
.namelist_mode
)
747 l_push_char (dtp
, c
);
750 dtp
->u
.p
.nml_read_error
= 1;
751 dtp
->u
.p
.line_buffer_enabled
= 1;
752 dtp
->u
.p
.line_buffer_pos
= 0;
760 if (nml_bad_return (dtp
, c
))
776 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
777 dtp
->u
.p
.item_count
);
779 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
784 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
785 dtp
->u
.p
.saved_length
= length
;
786 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
792 /* Reading integers is tricky because we can actually be reading a
793 repeat count. We have to store the characters in a buffer because
794 we could be reading an integer that is larger than the default int
795 used for repeat counts. */
798 read_integer (st_parameter_dt
*dtp
, int length
)
800 char message
[MSGLEN
];
810 /* Fall through... */
813 if ((c
= next_char (dtp
)) == EOF
)
817 CASE_SEPARATORS
: /* Single null. */
830 /* Take care of what may be a repeat count. */
842 push_char (dtp
, '\0');
845 CASE_SEPARATORS
: /* Not a repeat count. */
855 if (convert_integer (dtp
, -1, 0))
858 /* Get the real integer. */
860 if ((c
= next_char (dtp
)) == EOF
)
874 /* Fall through... */
906 if (nml_bad_return (dtp
, c
))
919 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
920 dtp
->u
.p
.item_count
);
922 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
930 push_char (dtp
, '\0');
931 if (convert_integer (dtp
, length
, negative
))
938 dtp
->u
.p
.saved_type
= BT_INTEGER
;
942 /* Read a character variable. */
945 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
947 char quote
, message
[MSGLEN
];
950 quote
= ' '; /* Space means no quote character. */
952 if ((c
= next_char (dtp
)) == EOF
)
962 unget_char (dtp
, c
); /* NULL value. */
972 if (dtp
->u
.p
.namelist_mode
)
974 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_NONE
)
976 /* No delimiters so finish reading the string now. */
979 for (i
= dtp
->u
.p
.ionml
->string_length
; i
> 1; i
--)
981 if ((c
= next_char (dtp
)) == EOF
)
985 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
996 /* Deal with a possible repeat count. */
1000 c
= next_char (dtp
);
1009 unget_char (dtp
, c
);
1010 goto done
; /* String was only digits! */
1013 push_char (dtp
, '\0');
1018 goto get_string
; /* Not a repeat count after all. */
1023 if (convert_integer (dtp
, -1, 0))
1026 /* Now get the real string. */
1028 if ((c
= next_char (dtp
)) == EOF
)
1033 unget_char (dtp
, c
); /* Repeated NULL values. */
1034 eat_separator (dtp
);
1050 if ((c
= next_char (dtp
)) == EOF
)
1062 /* See if we have a doubled quote character or the end of
1065 if ((c
= next_char (dtp
)) == EOF
)
1069 push_char (dtp
, quote
);
1073 unget_char (dtp
, c
);
1079 unget_char (dtp
, c
);
1083 if (c
!= '\n' && c
!= '\r')
1093 /* At this point, we have to have a separator, or else the string is
1096 c
= next_char (dtp
);
1098 if (is_separator (c
) || c
== '!' || c
== EOF
)
1100 unget_char (dtp
, c
);
1101 eat_separator (dtp
);
1102 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1107 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1108 dtp
->u
.p
.item_count
);
1109 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1121 /* Parse a component of a complex constant or a real number that we
1122 are sure is already there. This is a straight real number parser. */
1125 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1127 char message
[MSGLEN
];
1130 if ((c
= next_char (dtp
)) == EOF
)
1133 if (c
== '-' || c
== '+')
1136 if ((c
= next_char (dtp
)) == EOF
)
1140 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1143 if (!isdigit (c
) && c
!= '.')
1145 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1153 seen_dp
= (c
== '.') ? 1 : 0;
1157 if ((c
= next_char (dtp
)) == EOF
)
1159 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1181 push_char (dtp
, 'e');
1186 push_char (dtp
, 'e');
1188 if ((c
= next_char (dtp
)) == EOF
)
1202 if ((c
= next_char (dtp
)) == EOF
)
1204 if (c
!= '-' && c
!= '+')
1205 push_char (dtp
, '+');
1209 c
= next_char (dtp
);
1220 if ((c
= next_char (dtp
)) == EOF
)
1230 unget_char (dtp
, c
);
1239 unget_char (dtp
, c
);
1240 push_char (dtp
, '\0');
1242 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1248 unget_char (dtp
, c
);
1249 push_char (dtp
, '\0');
1251 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1257 /* Match INF and Infinity. */
1258 if ((c
== 'i' || c
== 'I')
1259 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1260 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1262 c
= next_char (dtp
);
1263 if ((c
!= 'i' && c
!= 'I')
1264 || ((c
== 'i' || c
== 'I')
1265 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1266 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1267 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1268 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1269 && (c
= next_char (dtp
))))
1271 if (is_separator (c
) || (c
== EOF
))
1272 unget_char (dtp
, c
);
1273 push_char (dtp
, 'i');
1274 push_char (dtp
, 'n');
1275 push_char (dtp
, 'f');
1279 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1280 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1281 && (c
= next_char (dtp
)))
1283 if (is_separator (c
) || (c
== EOF
))
1284 unget_char (dtp
, c
);
1285 push_char (dtp
, 'n');
1286 push_char (dtp
, 'a');
1287 push_char (dtp
, 'n');
1289 /* Match "NAN(alphanum)". */
1292 for ( ; c
!= ')'; c
= next_char (dtp
))
1293 if (is_separator (c
))
1296 c
= next_char (dtp
);
1297 if (is_separator (c
) || (c
== EOF
))
1298 unget_char (dtp
, c
);
1305 if (nml_bad_return (dtp
, c
))
1318 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1319 dtp
->u
.p
.item_count
);
1321 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1327 /* Reading a complex number is straightforward because we can tell
1328 what it is right away. */
1331 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1333 char message
[MSGLEN
];
1336 if (parse_repeat (dtp
))
1339 c
= next_char (dtp
);
1347 unget_char (dtp
, c
);
1348 eat_separator (dtp
);
1357 c
= next_char (dtp
);
1358 if (c
== '\n' || c
== '\r')
1361 unget_char (dtp
, c
);
1363 if (parse_real (dtp
, dest
, kind
))
1368 c
= next_char (dtp
);
1369 if (c
== '\n' || c
== '\r')
1372 unget_char (dtp
, c
);
1375 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1380 c
= next_char (dtp
);
1381 if (c
== '\n' || c
== '\r')
1384 unget_char (dtp
, c
);
1386 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1391 c
= next_char (dtp
);
1392 if (c
== '\n' || c
== '\r')
1395 unget_char (dtp
, c
);
1397 if (next_char (dtp
) != ')')
1400 c
= next_char (dtp
);
1401 if (!is_separator (c
) && (c
!= EOF
))
1404 unget_char (dtp
, c
);
1405 eat_separator (dtp
);
1408 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1413 if (nml_bad_return (dtp
, c
))
1426 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1427 dtp
->u
.p
.item_count
);
1429 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1433 /* Parse a real number with a possible repeat count. */
1436 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1438 char message
[MSGLEN
];
1445 c
= next_char (dtp
);
1446 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1464 unget_char (dtp
, c
); /* Single null. */
1465 eat_separator (dtp
);
1478 /* Get the digit string that might be a repeat count. */
1482 c
= next_char (dtp
);
1483 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1509 push_char (dtp
, 'e');
1511 c
= next_char (dtp
);
1515 push_char (dtp
, '\0');
1520 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1521 unget_char (dtp
, c
);
1530 if (convert_integer (dtp
, -1, 0))
1533 /* Now get the number itself. */
1535 if ((c
= next_char (dtp
)) == EOF
)
1537 if (is_separator (c
))
1538 { /* Repeated null value. */
1539 unget_char (dtp
, c
);
1540 eat_separator (dtp
);
1544 if (c
!= '-' && c
!= '+')
1545 push_char (dtp
, '+');
1550 if ((c
= next_char (dtp
)) == EOF
)
1554 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1557 if (!isdigit (c
) && c
!= '.')
1559 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1578 c
= next_char (dtp
);
1579 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1609 push_char (dtp
, 'e');
1611 c
= next_char (dtp
);
1620 push_char (dtp
, 'e');
1622 if ((c
= next_char (dtp
)) == EOF
)
1624 if (c
!= '+' && c
!= '-')
1625 push_char (dtp
, '+');
1629 c
= next_char (dtp
);
1639 c
= next_char (dtp
);
1657 unget_char (dtp
, c
);
1658 eat_separator (dtp
);
1659 push_char (dtp
, '\0');
1660 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1667 dtp
->u
.p
.saved_type
= BT_REAL
;
1671 l_push_char (dtp
, c
);
1674 /* Match INF and Infinity. */
1675 if (c
== 'i' || c
== 'I')
1677 c
= next_char (dtp
);
1678 l_push_char (dtp
, c
);
1679 if (c
!= 'n' && c
!= 'N')
1681 c
= next_char (dtp
);
1682 l_push_char (dtp
, c
);
1683 if (c
!= 'f' && c
!= 'F')
1685 c
= next_char (dtp
);
1686 l_push_char (dtp
, c
);
1687 if (!is_separator (c
) && (c
!= EOF
))
1689 if (c
!= 'i' && c
!= 'I')
1691 c
= next_char (dtp
);
1692 l_push_char (dtp
, c
);
1693 if (c
!= 'n' && c
!= 'N')
1695 c
= next_char (dtp
);
1696 l_push_char (dtp
, c
);
1697 if (c
!= 'i' && c
!= 'I')
1699 c
= next_char (dtp
);
1700 l_push_char (dtp
, c
);
1701 if (c
!= 't' && c
!= 'T')
1703 c
= next_char (dtp
);
1704 l_push_char (dtp
, c
);
1705 if (c
!= 'y' && c
!= 'Y')
1707 c
= next_char (dtp
);
1708 l_push_char (dtp
, c
);
1714 c
= next_char (dtp
);
1715 l_push_char (dtp
, c
);
1716 if (c
!= 'a' && c
!= 'A')
1718 c
= next_char (dtp
);
1719 l_push_char (dtp
, c
);
1720 if (c
!= 'n' && c
!= 'N')
1722 c
= next_char (dtp
);
1723 l_push_char (dtp
, c
);
1725 /* Match NAN(alphanum). */
1728 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1729 if (is_separator (c
))
1732 l_push_char (dtp
, c
);
1734 l_push_char (dtp
, ')');
1735 c
= next_char (dtp
);
1736 l_push_char (dtp
, c
);
1740 if (!is_separator (c
) && (c
!= EOF
))
1743 if (dtp
->u
.p
.namelist_mode
)
1745 if (c
== ' ' || c
=='\n' || c
== '\r')
1749 if ((c
= next_char (dtp
)) == EOF
)
1752 while (c
== ' ' || c
=='\n' || c
== '\r');
1754 l_push_char (dtp
, c
);
1763 push_char (dtp
, 'i');
1764 push_char (dtp
, 'n');
1765 push_char (dtp
, 'f');
1769 push_char (dtp
, 'n');
1770 push_char (dtp
, 'a');
1771 push_char (dtp
, 'n');
1775 unget_char (dtp
, c
);
1776 eat_separator (dtp
);
1777 push_char (dtp
, '\0');
1778 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1782 dtp
->u
.p
.saved_type
= BT_REAL
;
1786 if (dtp
->u
.p
.namelist_mode
)
1788 dtp
->u
.p
.nml_read_error
= 1;
1789 dtp
->u
.p
.line_buffer_enabled
= 1;
1790 dtp
->u
.p
.line_buffer_pos
= 0;
1796 if (nml_bad_return (dtp
, c
))
1809 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1810 dtp
->u
.p
.item_count
);
1812 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1816 /* Check the current type against the saved type to make sure they are
1817 compatible. Returns nonzero if incompatible. */
1820 check_type (st_parameter_dt
*dtp
, bt type
, int kind
)
1822 char message
[MSGLEN
];
1824 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1826 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1827 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1828 dtp
->u
.p
.item_count
);
1830 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1834 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1837 if ((type
!= BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
)
1838 || (type
== BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
*2))
1840 snprintf (message
, MSGLEN
,
1841 "Read kind %d %s where kind %d is required for item %d",
1842 type
== BT_COMPLEX
? dtp
->u
.p
.saved_length
/ 2
1843 : dtp
->u
.p
.saved_length
,
1844 type_name (dtp
->u
.p
.saved_type
), kind
,
1845 dtp
->u
.p
.item_count
);
1847 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1855 /* Top level data transfer subroutine for list reads. Because we have
1856 to deal with repeat counts, the data item is always saved after
1857 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1858 greater than one, we copy the data item multiple times. */
1861 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1862 int kind
, size_t size
)
1868 dtp
->u
.p
.namelist_mode
= 0;
1870 if (dtp
->u
.p
.first_item
)
1872 dtp
->u
.p
.first_item
= 0;
1873 dtp
->u
.p
.input_complete
= 0;
1874 dtp
->u
.p
.repeat_count
= 1;
1875 dtp
->u
.p
.at_eol
= 0;
1877 if ((c
= eat_spaces (dtp
)) == EOF
)
1882 if (is_separator (c
))
1884 /* Found a null value. */
1885 eat_separator (dtp
);
1886 dtp
->u
.p
.repeat_count
= 0;
1888 /* eat_separator sets this flag if the separator was a comma. */
1889 if (dtp
->u
.p
.comma_flag
)
1892 /* eat_separator sets this flag if the separator was a \n or \r. */
1893 if (dtp
->u
.p
.at_eol
)
1894 finish_separator (dtp
);
1902 if (dtp
->u
.p
.repeat_count
> 0)
1904 if (check_type (dtp
, type
, kind
))
1909 if (dtp
->u
.p
.input_complete
)
1912 if (dtp
->u
.p
.at_eol
)
1913 finish_separator (dtp
);
1917 /* Trailing spaces prior to end of line. */
1918 if (dtp
->u
.p
.at_eol
)
1919 finish_separator (dtp
);
1922 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1923 dtp
->u
.p
.repeat_count
= 1;
1929 read_integer (dtp
, kind
);
1932 read_logical (dtp
, kind
);
1935 read_character (dtp
, kind
);
1938 read_real (dtp
, p
, kind
);
1939 /* Copy value back to temporary if needed. */
1940 if (dtp
->u
.p
.repeat_count
> 0)
1941 memcpy (dtp
->u
.p
.value
, p
, size
);
1944 read_complex (dtp
, p
, kind
, size
);
1945 /* Copy value back to temporary if needed. */
1946 if (dtp
->u
.p
.repeat_count
> 0)
1947 memcpy (dtp
->u
.p
.value
, p
, size
);
1950 internal_error (&dtp
->common
, "Bad type for list read");
1953 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1954 dtp
->u
.p
.saved_length
= size
;
1956 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1960 switch (dtp
->u
.p
.saved_type
)
1964 if (dtp
->u
.p
.repeat_count
> 0)
1965 memcpy (p
, dtp
->u
.p
.value
, size
);
1970 memcpy (p
, dtp
->u
.p
.value
, size
);
1974 if (dtp
->u
.p
.saved_string
)
1976 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1977 ? (int) size
: dtp
->u
.p
.saved_used
;
1979 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1982 q
= (gfc_char4_t
*) p
;
1983 for (i
= 0; i
< m
; i
++)
1984 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1988 /* Just delimiters encountered, nothing to copy but SPACE. */
1994 memset (((char *) p
) + m
, ' ', size
- m
);
1997 q
= (gfc_char4_t
*) p
;
1998 for (i
= m
; i
< (int) size
; i
++)
1999 q
[i
] = (unsigned char) ' ';
2008 internal_error (&dtp
->common
, "Bad type for list read");
2011 if (--dtp
->u
.p
.repeat_count
<= 0)
2015 if (err
== LIBERROR_END
)
2025 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2026 size_t size
, size_t nelems
)
2030 size_t stride
= type
== BT_CHARACTER
?
2031 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2036 /* Big loop over all the elements. */
2037 for (elem
= 0; elem
< nelems
; elem
++)
2039 dtp
->u
.p
.item_count
++;
2040 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2048 /* Finish a list read. */
2051 finish_list_read (st_parameter_dt
*dtp
)
2057 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2059 if (dtp
->u
.p
.at_eol
)
2061 dtp
->u
.p
.at_eol
= 0;
2065 err
= eat_line (dtp
);
2066 if (err
== LIBERROR_END
)
2075 void namelist_read (st_parameter_dt *dtp)
2077 static void nml_match_name (char *name, int len)
2078 static int nml_query (st_parameter_dt *dtp)
2079 static int nml_get_obj_data (st_parameter_dt *dtp,
2080 namelist_info **prev_nl, char *, size_t)
2082 static void nml_untouch_nodes (st_parameter_dt *dtp)
2083 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2085 static int nml_parse_qualifier(descriptor_dimension * ad,
2086 array_loop_spec * ls, int rank, char *)
2087 static void nml_touch_nodes (namelist_info * nl)
2088 static int nml_read_obj (namelist_info *nl, index_type offset,
2089 namelist_info **prev_nl, char *, size_t,
2090 index_type clow, index_type chigh)
2094 /* Inputs a rank-dimensional qualifier, which can contain
2095 singlets, doublets, triplets or ':' with the standard meanings. */
2098 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2099 array_loop_spec
*ls
, int rank
, bt nml_elem_type
,
2100 char *parse_err_msg
, size_t parse_err_msg_size
,
2107 int is_array_section
, is_char
;
2111 is_array_section
= 0;
2112 dtp
->u
.p
.expanded_read
= 0;
2114 /* See if this is a character substring qualifier we are looking for. */
2121 /* The next character in the stream should be the '('. */
2123 if ((c
= next_char (dtp
)) == EOF
)
2126 /* Process the qualifier, by dimension and triplet. */
2128 for (dim
=0; dim
< rank
; dim
++ )
2130 for (indx
=0; indx
<3; indx
++)
2136 /* Process a potential sign. */
2137 if ((c
= next_char (dtp
)) == EOF
)
2149 unget_char (dtp
, c
);
2153 /* Process characters up to the next ':' , ',' or ')'. */
2156 c
= next_char (dtp
);
2163 is_array_section
= 1;
2167 if ((c
==',' && dim
== rank
-1)
2168 || (c
==')' && dim
< rank
-1))
2171 snprintf (parse_err_msg
, parse_err_msg_size
,
2172 "Bad substring qualifier");
2174 snprintf (parse_err_msg
, parse_err_msg_size
,
2175 "Bad number of index fields");
2184 case ' ': case '\t': case '\r': case '\n':
2190 snprintf (parse_err_msg
, parse_err_msg_size
,
2191 "Bad character in substring qualifier");
2193 snprintf (parse_err_msg
, parse_err_msg_size
,
2194 "Bad character in index");
2198 if ((c
== ',' || c
== ')') && indx
== 0
2199 && dtp
->u
.p
.saved_string
== 0)
2202 snprintf (parse_err_msg
, parse_err_msg_size
,
2203 "Null substring qualifier");
2205 snprintf (parse_err_msg
, parse_err_msg_size
,
2206 "Null index field");
2210 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2211 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2214 snprintf (parse_err_msg
, parse_err_msg_size
,
2215 "Bad substring qualifier");
2217 snprintf (parse_err_msg
, parse_err_msg_size
,
2218 "Bad index triplet");
2222 if (is_char
&& !is_array_section
)
2224 snprintf (parse_err_msg
, parse_err_msg_size
,
2225 "Missing colon in substring qualifier");
2229 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2231 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2232 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2238 /* Now read the index. */
2239 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2242 snprintf (parse_err_msg
, parse_err_msg_size
,
2243 "Bad integer substring qualifier");
2245 snprintf (parse_err_msg
, parse_err_msg_size
,
2246 "Bad integer in index");
2252 /* Feed the index values to the triplet arrays. */
2256 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2258 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2260 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2263 /* Singlet or doublet indices. */
2264 if (c
==',' || c
==')')
2268 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2270 /* If -std=f95/2003 or an array section is specified,
2271 do not allow excess data to be processed. */
2272 if (is_array_section
== 1
2273 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2274 || nml_elem_type
== BT_DERIVED
)
2275 ls
[dim
].end
= ls
[dim
].start
;
2277 dtp
->u
.p
.expanded_read
= 1;
2280 /* Check for non-zero rank. */
2281 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2288 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2291 dtp
->u
.p
.expanded_read
= 0;
2292 for (i
= 0; i
< dim
; i
++)
2293 ls
[i
].end
= ls
[i
].start
;
2296 /* Check the values of the triplet indices. */
2297 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2298 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2299 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2300 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2303 snprintf (parse_err_msg
, parse_err_msg_size
,
2304 "Substring out of range");
2306 snprintf (parse_err_msg
, parse_err_msg_size
,
2307 "Index %d out of range", dim
+ 1);
2311 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2312 || (ls
[dim
].step
== 0))
2314 snprintf (parse_err_msg
, parse_err_msg_size
,
2315 "Bad range in index %d", dim
+ 1);
2319 /* Initialise the loop index counter. */
2320 ls
[dim
].idx
= ls
[dim
].start
;
2327 /* The EOF error message is issued by hit_eof. Return true so that the
2328 caller does not use parse_err_msg and parse_err_msg_size to generate
2329 an unrelated error message. */
2333 dtp
->u
.p
.input_complete
= 1;
2339 static namelist_info
*
2340 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2342 namelist_info
* t
= dtp
->u
.p
.ionml
;
2345 if (strcmp (var_name
, t
->var_name
) == 0)
2355 /* Visits all the components of a derived type that have
2356 not explicitly been identified in the namelist input.
2357 touched is set and the loop specification initialised
2358 to default values */
2361 nml_touch_nodes (namelist_info
* nl
)
2363 index_type len
= strlen (nl
->var_name
) + 1;
2365 char * ext_name
= (char*)xmalloc (len
+ 1);
2366 memcpy (ext_name
, nl
->var_name
, len
-1);
2367 memcpy (ext_name
+ len
- 1, "%", 2);
2368 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2370 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2373 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2375 nl
->ls
[dim
].step
= 1;
2376 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2377 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2378 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2388 /* Resets touched for the entire list of nml_nodes, ready for a
2392 nml_untouch_nodes (st_parameter_dt
*dtp
)
2395 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2400 /* Attempts to input name to namelist name. Returns
2401 dtp->u.p.nml_read_error = 1 on no match. */
2404 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2409 dtp
->u
.p
.nml_read_error
= 0;
2410 for (i
= 0; i
< len
; i
++)
2412 c
= next_char (dtp
);
2413 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2415 dtp
->u
.p
.nml_read_error
= 1;
2421 /* If the namelist read is from stdin, output the current state of the
2422 namelist to stdout. This is used to implement the non-standard query
2423 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2424 the names alone are printed. */
2427 nml_query (st_parameter_dt
*dtp
, char c
)
2429 gfc_unit
* temp_unit
;
2434 static const index_type endlen
= 2;
2435 static const char endl
[] = "\r\n";
2436 static const char nmlend
[] = "&end\r\n";
2438 static const index_type endlen
= 1;
2439 static const char endl
[] = "\n";
2440 static const char nmlend
[] = "&end\n";
2443 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2446 /* Store the current unit and transfer to stdout. */
2448 temp_unit
= dtp
->u
.p
.current_unit
;
2449 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2451 if (dtp
->u
.p
.current_unit
)
2453 dtp
->u
.p
.mode
= WRITING
;
2454 next_record (dtp
, 0);
2456 /* Write the namelist in its entirety. */
2459 namelist_write (dtp
);
2461 /* Or write the list of names. */
2465 /* "&namelist_name\n" */
2467 len
= dtp
->namelist_name_len
;
2468 p
= write_block (dtp
, len
- 1 + endlen
);
2472 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2473 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2474 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2478 len
= strlen (nl
->var_name
);
2479 p
= write_block (dtp
, len
+ endlen
);
2483 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2484 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2489 p
= write_block (dtp
, endlen
+ 4);
2492 memcpy (p
, &nmlend
, endlen
+ 4);
2495 /* Flush the stream to force immediate output. */
2497 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2498 sflush (dtp
->u
.p
.current_unit
->s
);
2499 unlock_unit (dtp
->u
.p
.current_unit
);
2504 /* Restore the current unit. */
2506 dtp
->u
.p
.current_unit
= temp_unit
;
2507 dtp
->u
.p
.mode
= READING
;
2511 /* Reads and stores the input for the namelist object nl. For an array,
2512 the function loops over the ranges defined by the loop specification.
2513 This default to all the data or to the specification from a qualifier.
2514 nml_read_obj recursively calls itself to read derived types. It visits
2515 all its own components but only reads data for those that were touched
2516 when the name was parsed. If a read error is encountered, an attempt is
2517 made to return to read a new object name because the standard allows too
2518 little data to be available. On the other hand, too much data is an
2522 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2523 namelist_info
**pprev_nl
, char *nml_err_msg
,
2524 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2526 namelist_info
* cmp
;
2533 size_t obj_name_len
;
2536 /* If we have encountered a previous read error or this object has not been
2537 touched in name parsing, just return. */
2538 if (dtp
->u
.p
.nml_read_error
|| !nl
->touched
)
2541 dtp
->u
.p
.repeat_count
= 0;
2553 dlen
= size_from_real_kind (len
);
2557 dlen
= size_from_complex_kind (len
);
2561 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2570 /* Update the pointer to the data, using the current index vector */
2572 pdata
= (void*)(nl
->mem_pos
+ offset
);
2573 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2574 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2575 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2576 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2578 /* If we are finished with the repeat count, try to read next value. */
2581 if (--dtp
->u
.p
.repeat_count
<= 0)
2583 if (dtp
->u
.p
.input_complete
)
2585 if (dtp
->u
.p
.at_eol
)
2586 finish_separator (dtp
);
2587 if (dtp
->u
.p
.input_complete
)
2590 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2596 read_integer (dtp
, len
);
2600 read_logical (dtp
, len
);
2604 read_character (dtp
, len
);
2608 /* Need to copy data back from the real location to the temp in
2609 order to handle nml reads into arrays. */
2610 read_real (dtp
, pdata
, len
);
2611 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2615 /* Same as for REAL, copy back to temp. */
2616 read_complex (dtp
, pdata
, len
, dlen
);
2617 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2621 obj_name_len
= strlen (nl
->var_name
) + 1;
2622 obj_name
= xmalloc (obj_name_len
+1);
2623 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2624 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2626 /* If reading a derived type, disable the expanded read warning
2627 since a single object can have multiple reads. */
2628 dtp
->u
.p
.expanded_read
= 0;
2630 /* Now loop over the components. */
2632 for (cmp
= nl
->next
;
2634 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2637 /* Jump over nested derived type by testing if the potential
2638 component name contains '%'. */
2639 if (strchr (cmp
->var_name
+ obj_name_len
, '%'))
2642 if (!nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2643 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2650 if (dtp
->u
.p
.input_complete
)
2661 snprintf (nml_err_msg
, nml_err_msg_size
,
2662 "Bad type for namelist object %s", nl
->var_name
);
2663 internal_error (&dtp
->common
, nml_err_msg
);
2668 /* The standard permits array data to stop short of the number of
2669 elements specified in the loop specification. In this case, we
2670 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2671 nml_get_obj_data and an attempt is made to read object name. */
2674 if (dtp
->u
.p
.nml_read_error
)
2676 dtp
->u
.p
.expanded_read
= 0;
2680 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2682 dtp
->u
.p
.expanded_read
= 0;
2686 switch (dtp
->u
.p
.saved_type
)
2693 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2697 if (dlen
< dtp
->u
.p
.saved_used
)
2699 if (compile_options
.bounds_check
)
2701 snprintf (nml_err_msg
, nml_err_msg_size
,
2702 "Namelist object '%s' truncated on read.",
2704 generate_warning (&dtp
->common
, nml_err_msg
);
2709 m
= dtp
->u
.p
.saved_used
;
2710 pdata
= (void*)( pdata
+ clow
- 1 );
2711 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2713 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2720 /* Warn if a non-standard expanded read occurs. A single read of a
2721 single object is acceptable. If a second read occurs, issue a warning
2722 and set the flag to zero to prevent further warnings. */
2723 if (dtp
->u
.p
.expanded_read
== 2)
2725 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2726 dtp
->u
.p
.expanded_read
= 0;
2729 /* If the expanded read warning flag is set, increment it,
2730 indicating that a single read has occurred. */
2731 if (dtp
->u
.p
.expanded_read
>= 1)
2732 dtp
->u
.p
.expanded_read
++;
2734 /* Break out of loop if scalar. */
2738 /* Now increment the index vector. */
2743 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2745 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2747 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2749 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2751 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2755 } while (!nml_carry
);
2757 if (dtp
->u
.p
.repeat_count
> 1)
2759 snprintf (nml_err_msg
, nml_err_msg_size
,
2760 "Repeat count too large for namelist object %s", nl
->var_name
);
2770 /* Parses the object name, including array and substring qualifiers. It
2771 iterates over derived type components, touching those components and
2772 setting their loop specifications, if there is a qualifier. If the
2773 object is itself a derived type, its components and subcomponents are
2774 touched. nml_read_obj is called at the end and this reads the data in
2775 the manner specified by the object name. */
2778 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2779 char *nml_err_msg
, size_t nml_err_msg_size
)
2783 namelist_info
* first_nl
= NULL
;
2784 namelist_info
* root_nl
= NULL
;
2785 int dim
, parsed_rank
;
2786 int component_flag
, qualifier_flag
;
2787 index_type clow
, chigh
;
2788 int non_zero_rank_count
;
2790 /* Look for end of input or object name. If '?' or '=?' are encountered
2791 in stdin, print the node names or the namelist to stdout. */
2793 eat_separator (dtp
);
2794 if (dtp
->u
.p
.input_complete
)
2797 if (dtp
->u
.p
.at_eol
)
2798 finish_separator (dtp
);
2799 if (dtp
->u
.p
.input_complete
)
2802 if ((c
= next_char (dtp
)) == EOF
)
2807 if ((c
= next_char (dtp
)) == EOF
)
2811 snprintf (nml_err_msg
, nml_err_msg_size
,
2812 "namelist read: misplaced = sign");
2815 nml_query (dtp
, '=');
2819 nml_query (dtp
, '?');
2824 nml_match_name (dtp
, "end", 3);
2825 if (dtp
->u
.p
.nml_read_error
)
2827 snprintf (nml_err_msg
, nml_err_msg_size
,
2828 "namelist not terminated with / or &end");
2833 dtp
->u
.p
.input_complete
= 1;
2840 /* Untouch all nodes of the namelist and reset the flags that are set for
2841 derived type components. */
2843 nml_untouch_nodes (dtp
);
2846 non_zero_rank_count
= 0;
2848 /* Get the object name - should '!' and '\n' be permitted separators? */
2856 if (!is_separator (c
))
2857 push_char (dtp
, tolower(c
));
2858 if ((c
= next_char (dtp
)) == EOF
)
2861 while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2863 unget_char (dtp
, c
);
2865 /* Check that the name is in the namelist and get pointer to object.
2866 Three error conditions exist: (i) An attempt is being made to
2867 identify a non-existent object, following a failed data read or
2868 (ii) The object name does not exist or (iii) Too many data items
2869 are present for an object. (iii) gives the same error message
2872 push_char (dtp
, '\0');
2876 size_t var_len
= strlen (root_nl
->var_name
);
2878 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2879 char ext_name
[var_len
+ saved_len
+ 1];
2881 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2882 if (dtp
->u
.p
.saved_string
)
2883 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2884 ext_name
[var_len
+ saved_len
] = '\0';
2885 nl
= find_nml_node (dtp
, ext_name
);
2888 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2892 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2893 snprintf (nml_err_msg
, nml_err_msg_size
,
2894 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2897 snprintf (nml_err_msg
, nml_err_msg_size
,
2898 "Cannot match namelist object name %s",
2899 dtp
->u
.p
.saved_string
);
2904 /* Get the length, data length, base pointer and rank of the variable.
2905 Set the default loop specification first. */
2907 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2909 nl
->ls
[dim
].step
= 1;
2910 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2911 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2912 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2915 /* Check to see if there is a qualifier: if so, parse it.*/
2917 if (c
== '(' && nl
->var_rank
)
2920 if (!nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2921 nl
->type
, nml_err_msg
, nml_err_msg_size
,
2924 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2925 snprintf (nml_err_msg_end
,
2926 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2927 " for namelist variable %s", nl
->var_name
);
2930 if (parsed_rank
> 0)
2931 non_zero_rank_count
++;
2935 if ((c
= next_char (dtp
)) == EOF
)
2937 unget_char (dtp
, c
);
2939 else if (nl
->var_rank
> 0)
2940 non_zero_rank_count
++;
2942 /* Now parse a derived type component. The root namelist_info address
2943 is backed up, as is the previous component level. The component flag
2944 is set and the iteration is made by jumping back to get_name. */
2948 if (nl
->type
!= BT_DERIVED
)
2950 snprintf (nml_err_msg
, nml_err_msg_size
,
2951 "Attempt to get derived component for %s", nl
->var_name
);
2955 /* Don't move first_nl further in the list if a qualifier was found. */
2956 if ((*pprev_nl
== NULL
&& !qualifier_flag
) || !component_flag
)
2962 if ((c
= next_char (dtp
)) == EOF
)
2967 /* Parse a character qualifier, if present. chigh = 0 is a default
2968 that signals that the string length = string_length. */
2973 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2975 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2976 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2978 if (!nml_parse_qualifier (dtp
, chd
, ind
, -1, nl
->type
,
2979 nml_err_msg
, nml_err_msg_size
, &parsed_rank
))
2981 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2982 snprintf (nml_err_msg_end
,
2983 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2984 " for namelist variable %s", nl
->var_name
);
2988 clow
= ind
[0].start
;
2991 if (ind
[0].step
!= 1)
2993 snprintf (nml_err_msg
, nml_err_msg_size
,
2994 "Step not allowed in substring qualifier"
2995 " for namelist object %s", nl
->var_name
);
2999 if ((c
= next_char (dtp
)) == EOF
)
3001 unget_char (dtp
, c
);
3004 /* Make sure no extraneous qualifiers are there. */
3008 snprintf (nml_err_msg
, nml_err_msg_size
,
3009 "Qualifier for a scalar or non-character namelist object %s",
3014 /* Make sure there is no more than one non-zero rank object. */
3015 if (non_zero_rank_count
> 1)
3017 snprintf (nml_err_msg
, nml_err_msg_size
,
3018 "Multiple sub-objects with non-zero rank in namelist object %s",
3020 non_zero_rank_count
= 0;
3024 /* According to the standard, an equal sign MUST follow an object name. The
3025 following is possibly lax - it allows comments, blank lines and so on to
3026 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
3030 eat_separator (dtp
);
3031 if (dtp
->u
.p
.input_complete
)
3034 if (dtp
->u
.p
.at_eol
)
3035 finish_separator (dtp
);
3036 if (dtp
->u
.p
.input_complete
)
3039 if ((c
= next_char (dtp
)) == EOF
)
3044 snprintf (nml_err_msg
, nml_err_msg_size
,
3045 "Equal sign must follow namelist object name %s",
3049 /* If a derived type, touch its components and restore the root
3050 namelist_info if we have parsed a qualified derived type
3053 if (nl
->type
== BT_DERIVED
)
3054 nml_touch_nodes (nl
);
3058 if (first_nl
->var_rank
== 0)
3060 if (component_flag
&& qualifier_flag
)
3067 dtp
->u
.p
.nml_read_error
= 0;
3068 if (!nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3076 /* The EOF error message is issued by hit_eof. Return true so that the
3077 caller does not use nml_err_msg and nml_err_msg_size to generate
3078 an unrelated error message. */
3081 dtp
->u
.p
.input_complete
= 1;
3082 unget_char (dtp
, c
);
3089 /* Entry point for namelist input. Goes through input until namelist name
3090 is matched. Then cycles through nml_get_obj_data until the input is
3091 completed or there is an error. */
3094 namelist_read (st_parameter_dt
*dtp
)
3097 char nml_err_msg
[200];
3099 /* Initialize the error string buffer just in case we get an unexpected fail
3100 somewhere and end up at nml_err_ret. */
3101 strcpy (nml_err_msg
, "Internal namelist read error");
3103 /* Pointer to the previously read object, in case attempt is made to read
3104 new object name. Should this fail, error message can give previous
3106 namelist_info
*prev_nl
= NULL
;
3108 dtp
->u
.p
.namelist_mode
= 1;
3109 dtp
->u
.p
.input_complete
= 0;
3110 dtp
->u
.p
.expanded_read
= 0;
3112 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3113 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3114 node names or namelist on stdout. */
3117 c
= next_char (dtp
);
3129 c
= next_char (dtp
);
3131 nml_query (dtp
, '=');
3133 unget_char (dtp
, c
);
3137 nml_query (dtp
, '?');
3147 /* Match the name of the namelist. */
3149 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3151 if (dtp
->u
.p
.nml_read_error
)
3154 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3155 c
= next_char (dtp
);
3156 if (!is_separator(c
) && c
!= '!')
3158 unget_char (dtp
, c
);
3162 unget_char (dtp
, c
);
3163 eat_separator (dtp
);
3165 /* Ready to read namelist objects. If there is an error in input
3166 from stdin, output the error message and continue. */
3168 while (!dtp
->u
.p
.input_complete
)
3170 if (!nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
))
3172 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3174 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3177 /* Reset the previous namelist pointer if we know we are not going
3178 to be doing multiple reads within a single namelist object. */
3179 if (prev_nl
&& prev_nl
->var_rank
== 0)
3190 /* All namelist error calls return from here */
3193 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);