1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011, 2012
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist input contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
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 case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r' || c == ';')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt
*dtp
, char c
)
76 if (dtp
->u
.p
.saved_string
== NULL
)
78 // Plain malloc should suffice here, zeroing not needed?
79 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
80 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
81 dtp
->u
.p
.saved_used
= 0;
84 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
86 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
87 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
89 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
90 dtp
->u
.p
.saved_string
= new;
92 // Also this should not be necessary.
93 memset (new + dtp
->u
.p
.saved_used
, 0,
94 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
98 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
102 /* Free the input buffer if necessary. */
105 free_saved (st_parameter_dt
*dtp
)
107 if (dtp
->u
.p
.saved_string
== NULL
)
110 free (dtp
->u
.p
.saved_string
);
112 dtp
->u
.p
.saved_string
= NULL
;
113 dtp
->u
.p
.saved_used
= 0;
117 /* Free the line buffer if necessary. */
120 free_line (st_parameter_dt
*dtp
)
122 dtp
->u
.p
.item_count
= 0;
123 dtp
->u
.p
.line_buffer_enabled
= 0;
125 if (dtp
->u
.p
.line_buffer
== NULL
)
128 free (dtp
->u
.p
.line_buffer
);
129 dtp
->u
.p
.line_buffer
= NULL
;
134 next_char (st_parameter_dt
*dtp
)
140 if (dtp
->u
.p
.last_char
!= EOF
- 1)
143 c
= dtp
->u
.p
.last_char
;
144 dtp
->u
.p
.last_char
= EOF
- 1;
148 /* Read from line_buffer if enabled. */
150 if (dtp
->u
.p
.line_buffer_enabled
)
154 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
155 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
157 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
158 dtp
->u
.p
.item_count
++;
162 dtp
->u
.p
.item_count
= 0;
163 dtp
->u
.p
.line_buffer_enabled
= 0;
166 /* Handle the end-of-record and end-of-file conditions for
167 internal array unit. */
168 if (is_array_io (dtp
))
173 /* Check for "end-of-record" condition. */
174 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
179 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
182 /* Check for "end-of-file" condition. */
189 record
*= dtp
->u
.p
.current_unit
->recl
;
190 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
193 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
198 /* Get the next character and handle end-of-record conditions. */
200 if (is_internal_unit (dtp
))
203 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
207 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
211 if (is_array_io (dtp
))
213 /* Check whether we hit EOF. */
216 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
219 dtp
->u
.p
.current_unit
->bytes_left
--;
234 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
235 if (c
!= EOF
&& is_stream_io (dtp
))
236 dtp
->u
.p
.current_unit
->strm_pos
++;
239 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
244 /* Push a character back onto the input. */
247 unget_char (st_parameter_dt
*dtp
, int c
)
249 dtp
->u
.p
.last_char
= c
;
253 /* Skip over spaces in the input. Returns the nonspace character that
254 terminated the eating and also places it back on the input. */
257 eat_spaces (st_parameter_dt
*dtp
)
263 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
270 /* This function reads characters through to the end of the current
271 line and just ignores them. Returns 0 for success and LIBERROR_END
275 eat_line (st_parameter_dt
*dtp
)
281 while (c
!= EOF
&& c
!= '\n');
288 /* Skip over a separator. Technically, we don't always eat the whole
289 separator. This is because if we've processed the last input item,
290 then a separator is unnecessary. Plus the fact that operating
291 systems usually deliver console input on a line basis.
293 The upshot is that if we see a newline as part of reading a
294 separator, we stop reading. If there are more input items, we
295 continue reading the separator with finish_separator() which takes
296 care of the fact that we may or may not have seen a comma as part
299 Returns 0 for success, and non-zero error code otherwise. */
302 eat_separator (st_parameter_dt
*dtp
)
308 dtp
->u
.p
.comma_flag
= 0;
310 if ((c
= next_char (dtp
)) == EOF
)
315 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
322 dtp
->u
.p
.comma_flag
= 1;
327 dtp
->u
.p
.input_complete
= 1;
332 if ((n
= next_char(dtp
)) == EOF
)
342 if (dtp
->u
.p
.namelist_mode
)
346 if ((c
= next_char (dtp
)) == EOF
)
350 err
= eat_line (dtp
);
356 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
362 if (dtp
->u
.p
.namelist_mode
)
363 { /* Eat a namelist comment. */
364 err
= eat_line (dtp
);
371 /* Fall Through... */
381 /* Finish processing a separator that was interrupted by a newline.
382 If we're here, then another data item is present, so we finish what
383 we started on the previous line. Return 0 on success, error code
387 finish_separator (st_parameter_dt
*dtp
)
395 if ((c
= next_char (dtp
)) == EOF
)
400 if (dtp
->u
.p
.comma_flag
)
404 if ((c
= eat_spaces (dtp
)) == EOF
)
406 if (c
== '\n' || c
== '\r')
413 dtp
->u
.p
.input_complete
= 1;
414 if (!dtp
->u
.p
.namelist_mode
)
423 if (dtp
->u
.p
.namelist_mode
)
425 err
= eat_line (dtp
);
439 /* This function is needed to catch bad conversions so that namelist can
440 attempt to see if dtp->u.p.saved_string contains a new object name rather
444 nml_bad_return (st_parameter_dt
*dtp
, char c
)
446 if (dtp
->u
.p
.namelist_mode
)
448 dtp
->u
.p
.nml_read_error
= 1;
455 /* Convert an unsigned string to an integer. The length value is -1
456 if we are working on a repeat count. Returns nonzero if we have a
457 range problem. As a side effect, frees the dtp->u.p.saved_string. */
460 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
462 char c
, *buffer
, message
[MSGLEN
];
464 GFC_UINTEGER_LARGEST v
, max
, max10
;
465 GFC_INTEGER_LARGEST value
;
467 buffer
= dtp
->u
.p
.saved_string
;
474 max
= si_max (length
);
504 set_integer (dtp
->u
.p
.value
, value
, length
);
508 dtp
->u
.p
.repeat_count
= v
;
510 if (dtp
->u
.p
.repeat_count
== 0)
512 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
513 dtp
->u
.p
.item_count
);
515 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
525 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
526 dtp
->u
.p
.item_count
);
528 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
529 dtp
->u
.p
.item_count
);
532 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
538 /* Parse a repeat count for logical and complex values which cannot
539 begin with a digit. Returns nonzero if we are done, zero if we
540 should continue on. */
543 parse_repeat (st_parameter_dt
*dtp
)
545 char message
[MSGLEN
];
548 if ((c
= next_char (dtp
)) == EOF
)
572 repeat
= 10 * repeat
+ c
- '0';
574 if (repeat
> MAX_REPEAT
)
576 snprintf (message
, MSGLEN
,
577 "Repeat count overflow in item %d of list input",
578 dtp
->u
.p
.item_count
);
580 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
589 snprintf (message
, MSGLEN
,
590 "Zero repeat count in item %d of list input",
591 dtp
->u
.p
.item_count
);
593 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
605 dtp
->u
.p
.repeat_count
= repeat
;
618 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
619 dtp
->u
.p
.item_count
);
620 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
625 /* To read a logical we have to look ahead in the input stream to make sure
626 there is not an equal sign indicating a variable name. To do this we use
627 line_buffer to point to a temporary buffer, pushing characters there for
628 possible later reading. */
631 l_push_char (st_parameter_dt
*dtp
, char c
)
633 if (dtp
->u
.p
.line_buffer
== NULL
)
634 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
636 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
640 /* Read a logical character on the input. */
643 read_logical (st_parameter_dt
*dtp
, int length
)
645 char message
[MSGLEN
];
648 if (parse_repeat (dtp
))
651 c
= tolower (next_char (dtp
));
652 l_push_char (dtp
, c
);
658 l_push_char (dtp
, c
);
660 if (!is_separator(c
) && c
!= EOF
)
668 l_push_char (dtp
, c
);
670 if (!is_separator(c
) && c
!= EOF
)
677 c
= tolower (next_char (dtp
));
695 return; /* Null value. */
698 /* Save the character in case it is the beginning
699 of the next object name. */
704 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
705 dtp
->u
.p
.saved_length
= length
;
707 /* Eat trailing garbage. */
710 while (c
!= EOF
&& !is_separator (c
));
714 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
721 for(i
= 0; i
< 63; i
++)
726 /* All done if this is not a namelist read. */
727 if (!dtp
->u
.p
.namelist_mode
)
740 l_push_char (dtp
, c
);
743 dtp
->u
.p
.nml_read_error
= 1;
744 dtp
->u
.p
.line_buffer_enabled
= 1;
745 dtp
->u
.p
.item_count
= 0;
755 if (nml_bad_return (dtp
, c
))
766 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
767 dtp
->u
.p
.item_count
);
768 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
773 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
774 dtp
->u
.p
.saved_length
= length
;
775 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
781 /* Reading integers is tricky because we can actually be reading a
782 repeat count. We have to store the characters in a buffer because
783 we could be reading an integer that is larger than the default int
784 used for repeat counts. */
787 read_integer (st_parameter_dt
*dtp
, int length
)
789 char message
[MSGLEN
];
799 /* Fall through... */
802 if ((c
= next_char (dtp
)) == EOF
)
806 CASE_SEPARATORS
: /* Single null. */
819 /* Take care of what may be a repeat count. */
831 push_char (dtp
, '\0');
834 CASE_SEPARATORS
: /* Not a repeat count. */
844 if (convert_integer (dtp
, -1, 0))
847 /* Get the real integer. */
849 if ((c
= next_char (dtp
)) == EOF
)
863 /* Fall through... */
895 if (nml_bad_return (dtp
, c
))
906 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
907 dtp
->u
.p
.item_count
);
908 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
916 push_char (dtp
, '\0');
917 if (convert_integer (dtp
, length
, negative
))
924 dtp
->u
.p
.saved_type
= BT_INTEGER
;
928 /* Read a character variable. */
931 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
933 char quote
, message
[MSGLEN
];
936 quote
= ' '; /* Space means no quote character. */
938 if ((c
= next_char (dtp
)) == EOF
)
947 unget_char (dtp
, c
); /* NULL value. */
957 if (dtp
->u
.p
.namelist_mode
)
967 /* Deal with a possible repeat count. */
971 if ((c
= next_char (dtp
)) == EOF
)
981 goto done
; /* String was only digits! */
984 push_char (dtp
, '\0');
989 goto get_string
; /* Not a repeat count after all. */
994 if (convert_integer (dtp
, -1, 0))
997 /* Now get the real string. */
999 if ((c
= next_char (dtp
)) == EOF
)
1004 unget_char (dtp
, c
); /* Repeated NULL values. */
1005 eat_separator (dtp
);
1021 if ((c
= next_char (dtp
)) == EOF
)
1033 /* See if we have a doubled quote character or the end of
1036 if ((c
= next_char (dtp
)) == EOF
)
1040 push_char (dtp
, quote
);
1044 unget_char (dtp
, c
);
1050 unget_char (dtp
, c
);
1054 if (c
!= '\n' && c
!= '\r')
1064 /* At this point, we have to have a separator, or else the string is
1067 c
= next_char (dtp
);
1069 if (is_separator (c
) || c
== '!' || c
== EOF
)
1071 unget_char (dtp
, c
);
1072 eat_separator (dtp
);
1073 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1079 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1080 dtp
->u
.p
.item_count
);
1081 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1091 /* Parse a component of a complex constant or a real number that we
1092 are sure is already there. This is a straight real number parser. */
1095 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1097 char message
[MSGLEN
];
1100 if ((c
= next_char (dtp
)) == EOF
)
1103 if (c
== '-' || c
== '+')
1106 if ((c
= next_char (dtp
)) == EOF
)
1110 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1113 if (!isdigit (c
) && c
!= '.')
1115 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1123 seen_dp
= (c
== '.') ? 1 : 0;
1127 if ((c
= next_char (dtp
)) == EOF
)
1129 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1151 push_char (dtp
, 'e');
1156 push_char (dtp
, 'e');
1158 if ((c
= next_char (dtp
)) == EOF
)
1171 if ((c
= next_char (dtp
)) == EOF
)
1173 if (c
!= '-' && c
!= '+')
1174 push_char (dtp
, '+');
1178 c
= next_char (dtp
);
1189 if ((c
= next_char (dtp
)) == EOF
)
1198 unget_char (dtp
, c
);
1207 unget_char (dtp
, c
);
1208 push_char (dtp
, '\0');
1210 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1216 unget_char (dtp
, c
);
1217 push_char (dtp
, '\0');
1219 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1225 /* Match INF and Infinity. */
1226 if ((c
== 'i' || c
== 'I')
1227 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1228 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1230 c
= next_char (dtp
);
1231 if ((c
!= 'i' && c
!= 'I')
1232 || ((c
== 'i' || c
== 'I')
1233 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1234 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1235 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1236 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1237 && (c
= next_char (dtp
))))
1239 if (is_separator (c
))
1240 unget_char (dtp
, c
);
1241 push_char (dtp
, 'i');
1242 push_char (dtp
, 'n');
1243 push_char (dtp
, 'f');
1247 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1248 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1249 && (c
= next_char (dtp
)))
1251 if (is_separator (c
))
1252 unget_char (dtp
, c
);
1253 push_char (dtp
, 'n');
1254 push_char (dtp
, 'a');
1255 push_char (dtp
, 'n');
1257 /* Match "NAN(alphanum)". */
1260 for ( ; c
!= ')'; c
= next_char (dtp
))
1261 if (is_separator (c
))
1264 c
= next_char (dtp
);
1265 if (is_separator (c
))
1266 unget_char (dtp
, c
);
1273 if (nml_bad_return (dtp
, c
))
1284 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1285 dtp
->u
.p
.item_count
);
1286 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1292 /* Reading a complex number is straightforward because we can tell
1293 what it is right away. */
1296 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1298 char message
[MSGLEN
];
1301 if (parse_repeat (dtp
))
1304 c
= next_char (dtp
);
1311 unget_char (dtp
, c
);
1312 eat_separator (dtp
);
1321 c
= next_char (dtp
);
1322 if (c
== '\n' || c
== '\r')
1325 unget_char (dtp
, c
);
1327 if (parse_real (dtp
, dest
, kind
))
1332 c
= next_char (dtp
);
1333 if (c
== '\n' || c
== '\r')
1336 unget_char (dtp
, c
);
1339 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1344 c
= next_char (dtp
);
1345 if (c
== '\n' || c
== '\r')
1348 unget_char (dtp
, c
);
1350 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1355 c
= next_char (dtp
);
1356 if (c
== '\n' || c
== '\r')
1359 unget_char (dtp
, c
);
1361 if (next_char (dtp
) != ')')
1364 c
= next_char (dtp
);
1365 if (!is_separator (c
))
1368 unget_char (dtp
, c
);
1369 eat_separator (dtp
);
1372 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1377 if (nml_bad_return (dtp
, c
))
1388 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1389 dtp
->u
.p
.item_count
);
1390 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1394 /* Parse a real number with a possible repeat count. */
1397 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1399 char message
[MSGLEN
];
1406 c
= next_char (dtp
);
1407 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1425 unget_char (dtp
, c
); /* Single null. */
1426 eat_separator (dtp
);
1439 /* Get the digit string that might be a repeat count. */
1443 c
= next_char (dtp
);
1444 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1470 push_char (dtp
, 'e');
1472 c
= next_char (dtp
);
1476 push_char (dtp
, '\0');
1480 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1481 unget_char (dtp
, c
);
1490 if (convert_integer (dtp
, -1, 0))
1493 /* Now get the number itself. */
1495 if ((c
= next_char (dtp
)) == EOF
)
1497 if (is_separator (c
))
1498 { /* Repeated null value. */
1499 unget_char (dtp
, c
);
1500 eat_separator (dtp
);
1504 if (c
!= '-' && c
!= '+')
1505 push_char (dtp
, '+');
1510 if ((c
= next_char (dtp
)) == EOF
)
1514 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1517 if (!isdigit (c
) && c
!= '.')
1519 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1538 c
= next_char (dtp
);
1539 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1569 push_char (dtp
, 'e');
1571 c
= next_char (dtp
);
1580 push_char (dtp
, 'e');
1582 if ((c
= next_char (dtp
)) == EOF
)
1584 if (c
!= '+' && c
!= '-')
1585 push_char (dtp
, '+');
1589 c
= next_char (dtp
);
1599 c
= next_char (dtp
);
1616 unget_char (dtp
, c
);
1617 eat_separator (dtp
);
1618 push_char (dtp
, '\0');
1619 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1623 dtp
->u
.p
.saved_type
= BT_REAL
;
1627 l_push_char (dtp
, c
);
1630 /* Match INF and Infinity. */
1631 if (c
== 'i' || c
== 'I')
1633 c
= next_char (dtp
);
1634 l_push_char (dtp
, c
);
1635 if (c
!= 'n' && c
!= 'N')
1637 c
= next_char (dtp
);
1638 l_push_char (dtp
, c
);
1639 if (c
!= 'f' && c
!= 'F')
1641 c
= next_char (dtp
);
1642 l_push_char (dtp
, c
);
1643 if (!is_separator (c
))
1645 if (c
!= 'i' && c
!= 'I')
1647 c
= next_char (dtp
);
1648 l_push_char (dtp
, c
);
1649 if (c
!= 'n' && c
!= 'N')
1651 c
= next_char (dtp
);
1652 l_push_char (dtp
, c
);
1653 if (c
!= 'i' && c
!= 'I')
1655 c
= next_char (dtp
);
1656 l_push_char (dtp
, c
);
1657 if (c
!= 't' && c
!= 'T')
1659 c
= next_char (dtp
);
1660 l_push_char (dtp
, c
);
1661 if (c
!= 'y' && c
!= 'Y')
1663 c
= next_char (dtp
);
1664 l_push_char (dtp
, c
);
1670 c
= next_char (dtp
);
1671 l_push_char (dtp
, c
);
1672 if (c
!= 'a' && c
!= 'A')
1674 c
= next_char (dtp
);
1675 l_push_char (dtp
, c
);
1676 if (c
!= 'n' && c
!= 'N')
1678 c
= next_char (dtp
);
1679 l_push_char (dtp
, c
);
1681 /* Match NAN(alphanum). */
1684 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1685 if (is_separator (c
))
1688 l_push_char (dtp
, c
);
1690 l_push_char (dtp
, ')');
1691 c
= next_char (dtp
);
1692 l_push_char (dtp
, c
);
1696 if (!is_separator (c
))
1699 if (dtp
->u
.p
.namelist_mode
)
1701 if (c
== ' ' || c
=='\n' || c
== '\r')
1705 if ((c
= next_char (dtp
)) == EOF
)
1708 while (c
== ' ' || c
=='\n' || c
== '\r');
1710 l_push_char (dtp
, c
);
1719 push_char (dtp
, 'i');
1720 push_char (dtp
, 'n');
1721 push_char (dtp
, 'f');
1725 push_char (dtp
, 'n');
1726 push_char (dtp
, 'a');
1727 push_char (dtp
, 'n');
1731 unget_char (dtp
, c
);
1732 eat_separator (dtp
);
1733 push_char (dtp
, '\0');
1734 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1738 dtp
->u
.p
.saved_type
= BT_REAL
;
1742 if (dtp
->u
.p
.namelist_mode
)
1744 dtp
->u
.p
.nml_read_error
= 1;
1745 dtp
->u
.p
.line_buffer_enabled
= 1;
1746 dtp
->u
.p
.item_count
= 0;
1752 if (nml_bad_return (dtp
, c
))
1764 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1765 dtp
->u
.p
.item_count
);
1766 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1770 /* Check the current type against the saved type to make sure they are
1771 compatible. Returns nonzero if incompatible. */
1774 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1776 char message
[MSGLEN
];
1778 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1780 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1781 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1782 dtp
->u
.p
.item_count
);
1784 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1788 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1791 if (dtp
->u
.p
.saved_length
!= len
)
1793 snprintf (message
, MSGLEN
,
1794 "Read kind %d %s where kind %d is required for item %d",
1795 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1796 dtp
->u
.p
.item_count
);
1797 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1805 /* Top level data transfer subroutine for list reads. Because we have
1806 to deal with repeat counts, the data item is always saved after
1807 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1808 greater than one, we copy the data item multiple times. */
1811 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1812 int kind
, size_t size
)
1818 dtp
->u
.p
.namelist_mode
= 0;
1820 if (dtp
->u
.p
.first_item
)
1822 dtp
->u
.p
.first_item
= 0;
1823 dtp
->u
.p
.input_complete
= 0;
1824 dtp
->u
.p
.repeat_count
= 1;
1825 dtp
->u
.p
.at_eol
= 0;
1827 if ((c
= eat_spaces (dtp
)) == EOF
)
1832 if (is_separator (c
))
1834 /* Found a null value. */
1835 eat_separator (dtp
);
1836 dtp
->u
.p
.repeat_count
= 0;
1838 /* eat_separator sets this flag if the separator was a comma. */
1839 if (dtp
->u
.p
.comma_flag
)
1842 /* eat_separator sets this flag if the separator was a \n or \r. */
1843 if (dtp
->u
.p
.at_eol
)
1844 finish_separator (dtp
);
1852 if (dtp
->u
.p
.repeat_count
> 0)
1854 if (check_type (dtp
, type
, kind
))
1859 if (dtp
->u
.p
.input_complete
)
1862 if (dtp
->u
.p
.at_eol
)
1863 finish_separator (dtp
);
1867 /* Trailing spaces prior to end of line. */
1868 if (dtp
->u
.p
.at_eol
)
1869 finish_separator (dtp
);
1872 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1873 dtp
->u
.p
.repeat_count
= 1;
1879 read_integer (dtp
, kind
);
1882 read_logical (dtp
, kind
);
1885 read_character (dtp
, kind
);
1888 read_real (dtp
, p
, kind
);
1889 /* Copy value back to temporary if needed. */
1890 if (dtp
->u
.p
.repeat_count
> 0)
1891 memcpy (dtp
->u
.p
.value
, p
, kind
);
1894 read_complex (dtp
, p
, kind
, size
);
1895 /* Copy value back to temporary if needed. */
1896 if (dtp
->u
.p
.repeat_count
> 0)
1897 memcpy (dtp
->u
.p
.value
, p
, size
);
1900 internal_error (&dtp
->common
, "Bad type for list read");
1903 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1904 dtp
->u
.p
.saved_length
= size
;
1906 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1910 switch (dtp
->u
.p
.saved_type
)
1914 if (dtp
->u
.p
.repeat_count
> 0)
1915 memcpy (p
, dtp
->u
.p
.value
, size
);
1920 memcpy (p
, dtp
->u
.p
.value
, size
);
1924 if (dtp
->u
.p
.saved_string
)
1926 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1927 ? (int) size
: dtp
->u
.p
.saved_used
;
1929 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1932 q
= (gfc_char4_t
*) p
;
1933 for (i
= 0; i
< m
; i
++)
1934 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1938 /* Just delimiters encountered, nothing to copy but SPACE. */
1944 memset (((char *) p
) + m
, ' ', size
- m
);
1947 q
= (gfc_char4_t
*) p
;
1948 for (i
= m
; i
< (int) size
; i
++)
1949 q
[i
] = (unsigned char) ' ';
1958 internal_error (&dtp
->common
, "Bad type for list read");
1961 if (--dtp
->u
.p
.repeat_count
<= 0)
1965 if (err
== LIBERROR_END
)
1972 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1973 size_t size
, size_t nelems
)
1977 size_t stride
= type
== BT_CHARACTER
?
1978 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1983 /* Big loop over all the elements. */
1984 for (elem
= 0; elem
< nelems
; elem
++)
1986 dtp
->u
.p
.item_count
++;
1987 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
1995 /* Finish a list read. */
1998 finish_list_read (st_parameter_dt
*dtp
)
2004 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2006 if (dtp
->u
.p
.at_eol
)
2008 dtp
->u
.p
.at_eol
= 0;
2012 err
= eat_line (dtp
);
2013 if (err
== LIBERROR_END
)
2019 void namelist_read (st_parameter_dt *dtp)
2021 static void nml_match_name (char *name, int len)
2022 static int nml_query (st_parameter_dt *dtp)
2023 static int nml_get_obj_data (st_parameter_dt *dtp,
2024 namelist_info **prev_nl, char *, size_t)
2026 static void nml_untouch_nodes (st_parameter_dt *dtp)
2027 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2029 static int nml_parse_qualifier(descriptor_dimension * ad,
2030 array_loop_spec * ls, int rank, char *)
2031 static void nml_touch_nodes (namelist_info * nl)
2032 static int nml_read_obj (namelist_info *nl, index_type offset,
2033 namelist_info **prev_nl, char *, size_t,
2034 index_type clow, index_type chigh)
2038 /* Inputs a rank-dimensional qualifier, which can contain
2039 singlets, doublets, triplets or ':' with the standard meanings. */
2042 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2043 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2044 size_t parse_err_msg_size
,
2051 int is_array_section
, is_char
;
2055 is_array_section
= 0;
2056 dtp
->u
.p
.expanded_read
= 0;
2058 /* See if this is a character substring qualifier we are looking for. */
2065 /* The next character in the stream should be the '('. */
2067 if ((c
= next_char (dtp
)) == EOF
)
2070 /* Process the qualifier, by dimension and triplet. */
2072 for (dim
=0; dim
< rank
; dim
++ )
2074 for (indx
=0; indx
<3; indx
++)
2080 /* Process a potential sign. */
2081 if ((c
= next_char (dtp
)) == EOF
)
2093 unget_char (dtp
, c
);
2097 /* Process characters up to the next ':' , ',' or ')'. */
2100 if ((c
= next_char (dtp
)) == EOF
)
2106 is_array_section
= 1;
2110 if ((c
==',' && dim
== rank
-1)
2111 || (c
==')' && dim
< rank
-1))
2114 snprintf (parse_err_msg
, parse_err_msg_size
,
2115 "Bad substring qualifier");
2117 snprintf (parse_err_msg
, parse_err_msg_size
,
2118 "Bad number of index fields");
2127 case ' ': case '\t':
2129 if ((c
= next_char (dtp
) == EOF
))
2135 snprintf (parse_err_msg
, parse_err_msg_size
,
2136 "Bad character in substring qualifier");
2138 snprintf (parse_err_msg
, parse_err_msg_size
,
2139 "Bad character in index");
2143 if ((c
== ',' || c
== ')') && indx
== 0
2144 && dtp
->u
.p
.saved_string
== 0)
2147 snprintf (parse_err_msg
, parse_err_msg_size
,
2148 "Null substring qualifier");
2150 snprintf (parse_err_msg
, parse_err_msg_size
,
2151 "Null index field");
2155 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2156 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2159 snprintf (parse_err_msg
, parse_err_msg_size
,
2160 "Bad substring qualifier");
2162 snprintf (parse_err_msg
, parse_err_msg_size
,
2163 "Bad index triplet");
2167 if (is_char
&& !is_array_section
)
2169 snprintf (parse_err_msg
, parse_err_msg_size
,
2170 "Missing colon in substring qualifier");
2174 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2176 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2177 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2183 /* Now read the index. */
2184 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2187 snprintf (parse_err_msg
, parse_err_msg_size
,
2188 "Bad integer substring qualifier");
2190 snprintf (parse_err_msg
, parse_err_msg_size
,
2191 "Bad integer in index");
2197 /* Feed the index values to the triplet arrays. */
2201 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2203 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2205 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2208 /* Singlet or doublet indices. */
2209 if (c
==',' || c
==')')
2213 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2215 /* If -std=f95/2003 or an array section is specified,
2216 do not allow excess data to be processed. */
2217 if (is_array_section
== 1
2218 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2219 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2220 ls
[dim
].end
= ls
[dim
].start
;
2222 dtp
->u
.p
.expanded_read
= 1;
2225 /* Check for non-zero rank. */
2226 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2233 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2236 dtp
->u
.p
.expanded_read
= 0;
2237 for (i
= 0; i
< dim
; i
++)
2238 ls
[i
].end
= ls
[i
].start
;
2241 /* Check the values of the triplet indices. */
2242 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2243 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2244 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2245 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2248 snprintf (parse_err_msg
, parse_err_msg_size
,
2249 "Substring out of range");
2251 snprintf (parse_err_msg
, parse_err_msg_size
,
2252 "Index %d out of range", dim
+ 1);
2256 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2257 || (ls
[dim
].step
== 0))
2259 snprintf (parse_err_msg
, parse_err_msg_size
,
2260 "Bad range in index %d", dim
+ 1);
2264 /* Initialise the loop index counter. */
2265 ls
[dim
].idx
= ls
[dim
].start
;
2275 static namelist_info
*
2276 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2278 namelist_info
* t
= dtp
->u
.p
.ionml
;
2281 if (strcmp (var_name
, t
->var_name
) == 0)
2291 /* Visits all the components of a derived type that have
2292 not explicitly been identified in the namelist input.
2293 touched is set and the loop specification initialised
2294 to default values */
2297 nml_touch_nodes (namelist_info
* nl
)
2299 index_type len
= strlen (nl
->var_name
) + 1;
2301 char * ext_name
= (char*)xmalloc (len
+ 1);
2302 memcpy (ext_name
, nl
->var_name
, len
-1);
2303 memcpy (ext_name
+ len
- 1, "%", 2);
2304 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2306 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2309 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2311 nl
->ls
[dim
].step
= 1;
2312 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2313 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2314 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2324 /* Resets touched for the entire list of nml_nodes, ready for a
2328 nml_untouch_nodes (st_parameter_dt
*dtp
)
2331 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2336 /* Attempts to input name to namelist name. Returns
2337 dtp->u.p.nml_read_error = 1 on no match. */
2340 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2345 dtp
->u
.p
.nml_read_error
= 0;
2346 for (i
= 0; i
< len
; i
++)
2348 c
= next_char (dtp
);
2349 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2351 dtp
->u
.p
.nml_read_error
= 1;
2357 /* If the namelist read is from stdin, output the current state of the
2358 namelist to stdout. This is used to implement the non-standard query
2359 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2360 the names alone are printed. */
2363 nml_query (st_parameter_dt
*dtp
, char c
)
2365 gfc_unit
* temp_unit
;
2370 static const index_type endlen
= 3;
2371 static const char endl
[] = "\r\n";
2372 static const char nmlend
[] = "&end\r\n";
2374 static const index_type endlen
= 2;
2375 static const char endl
[] = "\n";
2376 static const char nmlend
[] = "&end\n";
2379 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2382 /* Store the current unit and transfer to stdout. */
2384 temp_unit
= dtp
->u
.p
.current_unit
;
2385 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2387 if (dtp
->u
.p
.current_unit
)
2389 dtp
->u
.p
.mode
= WRITING
;
2390 next_record (dtp
, 0);
2392 /* Write the namelist in its entirety. */
2395 namelist_write (dtp
);
2397 /* Or write the list of names. */
2401 /* "&namelist_name\n" */
2403 len
= dtp
->namelist_name_len
;
2404 p
= write_block (dtp
, len
+ endlen
);
2408 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2409 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2410 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2414 len
= strlen (nl
->var_name
);
2415 p
= write_block (dtp
, len
+ endlen
);
2419 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2420 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2425 p
= write_block (dtp
, endlen
+ 3);
2427 memcpy (p
, &nmlend
, endlen
+ 3);
2430 /* Flush the stream to force immediate output. */
2432 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2433 sflush (dtp
->u
.p
.current_unit
->s
);
2434 unlock_unit (dtp
->u
.p
.current_unit
);
2439 /* Restore the current unit. */
2441 dtp
->u
.p
.current_unit
= temp_unit
;
2442 dtp
->u
.p
.mode
= READING
;
2446 /* Reads and stores the input for the namelist object nl. For an array,
2447 the function loops over the ranges defined by the loop specification.
2448 This default to all the data or to the specification from a qualifier.
2449 nml_read_obj recursively calls itself to read derived types. It visits
2450 all its own components but only reads data for those that were touched
2451 when the name was parsed. If a read error is encountered, an attempt is
2452 made to return to read a new object name because the standard allows too
2453 little data to be available. On the other hand, too much data is an
2457 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2458 namelist_info
**pprev_nl
, char *nml_err_msg
,
2459 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2461 namelist_info
* cmp
;
2468 size_t obj_name_len
;
2471 /* This object not touched in name parsing. */
2476 dtp
->u
.p
.repeat_count
= 0;
2488 dlen
= size_from_real_kind (len
);
2492 dlen
= size_from_complex_kind (len
);
2496 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2505 /* Update the pointer to the data, using the current index vector */
2507 pdata
= (void*)(nl
->mem_pos
+ offset
);
2508 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2509 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2510 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2511 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2513 /* Reset the error flag and try to read next value, if
2514 dtp->u.p.repeat_count=0 */
2516 dtp
->u
.p
.nml_read_error
= 0;
2518 if (--dtp
->u
.p
.repeat_count
<= 0)
2520 if (dtp
->u
.p
.input_complete
)
2522 if (dtp
->u
.p
.at_eol
)
2523 finish_separator (dtp
);
2524 if (dtp
->u
.p
.input_complete
)
2527 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2533 read_integer (dtp
, len
);
2537 read_logical (dtp
, len
);
2541 read_character (dtp
, len
);
2545 /* Need to copy data back from the real location to the temp in order
2546 to handle nml reads into arrays. */
2547 read_real (dtp
, pdata
, len
);
2548 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2552 /* Same as for REAL, copy back to temp. */
2553 read_complex (dtp
, pdata
, len
, dlen
);
2554 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2558 obj_name_len
= strlen (nl
->var_name
) + 1;
2559 obj_name
= xmalloc (obj_name_len
+1);
2560 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2561 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2563 /* If reading a derived type, disable the expanded read warning
2564 since a single object can have multiple reads. */
2565 dtp
->u
.p
.expanded_read
= 0;
2567 /* Now loop over the components. Update the component pointer
2568 with the return value from nml_write_obj. This loop jumps
2569 past nested derived types by testing if the potential
2570 component name contains '%'. */
2572 for (cmp
= nl
->next
;
2574 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2575 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2579 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2580 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2581 clow
, chigh
) == FAILURE
)
2587 if (dtp
->u
.p
.input_complete
)
2598 snprintf (nml_err_msg
, nml_err_msg_size
,
2599 "Bad type for namelist object %s", nl
->var_name
);
2600 internal_error (&dtp
->common
, nml_err_msg
);
2605 /* The standard permits array data to stop short of the number of
2606 elements specified in the loop specification. In this case, we
2607 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2608 nml_get_obj_data and an attempt is made to read object name. */
2611 if (dtp
->u
.p
.nml_read_error
)
2613 dtp
->u
.p
.expanded_read
= 0;
2617 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2619 dtp
->u
.p
.expanded_read
= 0;
2623 switch (dtp
->u
.p
.saved_type
)
2630 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2634 if (dlen
< dtp
->u
.p
.saved_used
)
2636 if (compile_options
.bounds_check
)
2638 snprintf (nml_err_msg
, nml_err_msg_size
,
2639 "Namelist object '%s' truncated on read.",
2641 generate_warning (&dtp
->common
, nml_err_msg
);
2646 m
= dtp
->u
.p
.saved_used
;
2647 pdata
= (void*)( pdata
+ clow
- 1 );
2648 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2650 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2657 /* Warn if a non-standard expanded read occurs. A single read of a
2658 single object is acceptable. If a second read occurs, issue a warning
2659 and set the flag to zero to prevent further warnings. */
2660 if (dtp
->u
.p
.expanded_read
== 2)
2662 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2663 dtp
->u
.p
.expanded_read
= 0;
2666 /* If the expanded read warning flag is set, increment it,
2667 indicating that a single read has occurred. */
2668 if (dtp
->u
.p
.expanded_read
>= 1)
2669 dtp
->u
.p
.expanded_read
++;
2671 /* Break out of loop if scalar. */
2675 /* Now increment the index vector. */
2680 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2682 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2684 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2686 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2688 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2692 } while (!nml_carry
);
2694 if (dtp
->u
.p
.repeat_count
> 1)
2696 snprintf (nml_err_msg
, nml_err_msg_size
,
2697 "Repeat count too large for namelist object %s", nl
->var_name
);
2707 /* Parses the object name, including array and substring qualifiers. It
2708 iterates over derived type components, touching those components and
2709 setting their loop specifications, if there is a qualifier. If the
2710 object is itself a derived type, its components and subcomponents are
2711 touched. nml_read_obj is called at the end and this reads the data in
2712 the manner specified by the object name. */
2715 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2716 char *nml_err_msg
, size_t nml_err_msg_size
)
2720 namelist_info
* first_nl
= NULL
;
2721 namelist_info
* root_nl
= NULL
;
2722 int dim
, parsed_rank
;
2723 int component_flag
, qualifier_flag
;
2724 index_type clow
, chigh
;
2725 int non_zero_rank_count
;
2727 /* Look for end of input or object name. If '?' or '=?' are encountered
2728 in stdin, print the node names or the namelist to stdout. */
2730 eat_separator (dtp
);
2731 if (dtp
->u
.p
.input_complete
)
2734 if (dtp
->u
.p
.at_eol
)
2735 finish_separator (dtp
);
2736 if (dtp
->u
.p
.input_complete
)
2739 if ((c
= next_char (dtp
)) == EOF
)
2744 if ((c
= next_char (dtp
)) == EOF
)
2748 snprintf (nml_err_msg
, nml_err_msg_size
,
2749 "namelist read: misplaced = sign");
2752 nml_query (dtp
, '=');
2756 nml_query (dtp
, '?');
2761 nml_match_name (dtp
, "end", 3);
2762 if (dtp
->u
.p
.nml_read_error
)
2764 snprintf (nml_err_msg
, nml_err_msg_size
,
2765 "namelist not terminated with / or &end");
2769 dtp
->u
.p
.input_complete
= 1;
2776 /* Untouch all nodes of the namelist and reset the flags that are set for
2777 derived type components. */
2779 nml_untouch_nodes (dtp
);
2782 non_zero_rank_count
= 0;
2784 /* Get the object name - should '!' and '\n' be permitted separators? */
2792 if (!is_separator (c
))
2793 push_char (dtp
, tolower(c
));
2794 if ((c
= next_char (dtp
)) == EOF
)
2796 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2798 unget_char (dtp
, c
);
2800 /* Check that the name is in the namelist and get pointer to object.
2801 Three error conditions exist: (i) An attempt is being made to
2802 identify a non-existent object, following a failed data read or
2803 (ii) The object name does not exist or (iii) Too many data items
2804 are present for an object. (iii) gives the same error message
2807 push_char (dtp
, '\0');
2811 size_t var_len
= strlen (root_nl
->var_name
);
2813 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2814 char ext_name
[var_len
+ saved_len
+ 1];
2816 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2817 if (dtp
->u
.p
.saved_string
)
2818 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2819 ext_name
[var_len
+ saved_len
] = '\0';
2820 nl
= find_nml_node (dtp
, ext_name
);
2823 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2827 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2828 snprintf (nml_err_msg
, nml_err_msg_size
,
2829 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2832 snprintf (nml_err_msg
, nml_err_msg_size
,
2833 "Cannot match namelist object name %s",
2834 dtp
->u
.p
.saved_string
);
2839 /* Get the length, data length, base pointer and rank of the variable.
2840 Set the default loop specification first. */
2842 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2844 nl
->ls
[dim
].step
= 1;
2845 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2846 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2847 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2850 /* Check to see if there is a qualifier: if so, parse it.*/
2852 if (c
== '(' && nl
->var_rank
)
2855 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2856 nml_err_msg
, nml_err_msg_size
,
2857 &parsed_rank
) == FAILURE
)
2859 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2860 snprintf (nml_err_msg_end
,
2861 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2862 " for namelist variable %s", nl
->var_name
);
2865 if (parsed_rank
> 0)
2866 non_zero_rank_count
++;
2870 if ((c
= next_char (dtp
)) == EOF
)
2872 unget_char (dtp
, c
);
2874 else if (nl
->var_rank
> 0)
2875 non_zero_rank_count
++;
2877 /* Now parse a derived type component. The root namelist_info address
2878 is backed up, as is the previous component level. The component flag
2879 is set and the iteration is made by jumping back to get_name. */
2883 if (nl
->type
!= BT_DERIVED
)
2885 snprintf (nml_err_msg
, nml_err_msg_size
,
2886 "Attempt to get derived component for %s", nl
->var_name
);
2890 if (*pprev_nl
== NULL
|| !component_flag
)
2896 if ((c
= next_char (dtp
)) == EOF
)
2901 /* Parse a character qualifier, if present. chigh = 0 is a default
2902 that signals that the string length = string_length. */
2907 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2909 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2910 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2912 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
,
2913 nml_err_msg_size
, &parsed_rank
)
2916 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2917 snprintf (nml_err_msg_end
,
2918 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2919 " for namelist variable %s", nl
->var_name
);
2923 clow
= ind
[0].start
;
2926 if (ind
[0].step
!= 1)
2928 snprintf (nml_err_msg
, nml_err_msg_size
,
2929 "Step not allowed in substring qualifier"
2930 " for namelist object %s", nl
->var_name
);
2934 if ((c
= next_char (dtp
)) == EOF
)
2936 unget_char (dtp
, c
);
2939 /* Make sure no extraneous qualifiers are there. */
2943 snprintf (nml_err_msg
, nml_err_msg_size
,
2944 "Qualifier for a scalar or non-character namelist object %s",
2949 /* Make sure there is no more than one non-zero rank object. */
2950 if (non_zero_rank_count
> 1)
2952 snprintf (nml_err_msg
, nml_err_msg_size
,
2953 "Multiple sub-objects with non-zero rank in namelist object %s",
2955 non_zero_rank_count
= 0;
2959 /* According to the standard, an equal sign MUST follow an object name. The
2960 following is possibly lax - it allows comments, blank lines and so on to
2961 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2965 eat_separator (dtp
);
2966 if (dtp
->u
.p
.input_complete
)
2969 if (dtp
->u
.p
.at_eol
)
2970 finish_separator (dtp
);
2971 if (dtp
->u
.p
.input_complete
)
2974 if ((c
= next_char (dtp
)) == EOF
)
2979 snprintf (nml_err_msg
, nml_err_msg_size
,
2980 "Equal sign must follow namelist object name %s",
2984 /* If a derived type, touch its components and restore the root
2985 namelist_info if we have parsed a qualified derived type
2988 if (nl
->type
== BT_DERIVED
)
2989 nml_touch_nodes (nl
);
2993 if (first_nl
->var_rank
== 0)
2995 if (component_flag
&& qualifier_flag
)
3002 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3003 clow
, chigh
) == FAILURE
)
3013 /* Entry point for namelist input. Goes through input until namelist name
3014 is matched. Then cycles through nml_get_obj_data until the input is
3015 completed or there is an error. */
3018 namelist_read (st_parameter_dt
*dtp
)
3021 char nml_err_msg
[200];
3023 /* Initialize the error string buffer just in case we get an unexpected fail
3024 somewhere and end up at nml_err_ret. */
3025 strcpy (nml_err_msg
, "Internal namelist read error");
3027 /* Pointer to the previously read object, in case attempt is made to read
3028 new object name. Should this fail, error message can give previous
3030 namelist_info
*prev_nl
= NULL
;
3032 dtp
->u
.p
.namelist_mode
= 1;
3033 dtp
->u
.p
.input_complete
= 0;
3034 dtp
->u
.p
.expanded_read
= 0;
3036 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3037 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3038 node names or namelist on stdout. */
3041 c
= next_char (dtp
);
3053 c
= next_char (dtp
);
3055 nml_query (dtp
, '=');
3057 unget_char (dtp
, c
);
3061 nml_query (dtp
, '?');
3070 /* Match the name of the namelist. */
3072 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3074 if (dtp
->u
.p
.nml_read_error
)
3077 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3078 c
= next_char (dtp
);
3079 if (!is_separator(c
) && c
!= '!')
3081 unget_char (dtp
, c
);
3085 unget_char (dtp
, c
);
3086 eat_separator (dtp
);
3088 /* Ready to read namelist objects. If there is an error in input
3089 from stdin, output the error message and continue. */
3091 while (!dtp
->u
.p
.input_complete
)
3093 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3096 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3098 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3101 /* Reset the previous namelist pointer if we know we are not going
3102 to be doing multiple reads within a single namelist object. */
3103 if (prev_nl
&& prev_nl
->var_rank
== 0)
3114 /* All namelist error calls return from here */
3117 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);