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_INTEGER_LARGEST v
, max
, max10
;
466 buffer
= dtp
->u
.p
.saved_string
;
469 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
494 set_integer (dtp
->u
.p
.value
, v
, length
);
498 dtp
->u
.p
.repeat_count
= v
;
500 if (dtp
->u
.p
.repeat_count
== 0)
502 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
503 dtp
->u
.p
.item_count
);
505 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
515 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
516 dtp
->u
.p
.item_count
);
518 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
519 dtp
->u
.p
.item_count
);
522 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
528 /* Parse a repeat count for logical and complex values which cannot
529 begin with a digit. Returns nonzero if we are done, zero if we
530 should continue on. */
533 parse_repeat (st_parameter_dt
*dtp
)
535 char message
[MSGLEN
];
538 if ((c
= next_char (dtp
)) == EOF
)
562 repeat
= 10 * repeat
+ c
- '0';
564 if (repeat
> MAX_REPEAT
)
566 snprintf (message
, MSGLEN
,
567 "Repeat count overflow in item %d of list input",
568 dtp
->u
.p
.item_count
);
570 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
579 snprintf (message
, MSGLEN
,
580 "Zero repeat count in item %d of list input",
581 dtp
->u
.p
.item_count
);
583 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
595 dtp
->u
.p
.repeat_count
= repeat
;
608 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
609 dtp
->u
.p
.item_count
);
610 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
615 /* To read a logical we have to look ahead in the input stream to make sure
616 there is not an equal sign indicating a variable name. To do this we use
617 line_buffer to point to a temporary buffer, pushing characters there for
618 possible later reading. */
621 l_push_char (st_parameter_dt
*dtp
, char c
)
623 if (dtp
->u
.p
.line_buffer
== NULL
)
624 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
626 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
630 /* Read a logical character on the input. */
633 read_logical (st_parameter_dt
*dtp
, int length
)
635 char message
[MSGLEN
];
638 if (parse_repeat (dtp
))
641 c
= tolower (next_char (dtp
));
642 l_push_char (dtp
, c
);
648 l_push_char (dtp
, c
);
650 if (!is_separator(c
) && c
!= EOF
)
658 l_push_char (dtp
, c
);
660 if (!is_separator(c
) && c
!= EOF
)
667 c
= tolower (next_char (dtp
));
685 return; /* Null value. */
688 /* Save the character in case it is the beginning
689 of the next object name. */
694 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
695 dtp
->u
.p
.saved_length
= length
;
697 /* Eat trailing garbage. */
700 while (c
!= EOF
&& !is_separator (c
));
704 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
711 for(i
= 0; i
< 63; i
++)
716 /* All done if this is not a namelist read. */
717 if (!dtp
->u
.p
.namelist_mode
)
730 l_push_char (dtp
, c
);
733 dtp
->u
.p
.nml_read_error
= 1;
734 dtp
->u
.p
.line_buffer_enabled
= 1;
735 dtp
->u
.p
.item_count
= 0;
745 if (nml_bad_return (dtp
, c
))
756 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
757 dtp
->u
.p
.item_count
);
758 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
763 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
764 dtp
->u
.p
.saved_length
= length
;
765 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
771 /* Reading integers is tricky because we can actually be reading a
772 repeat count. We have to store the characters in a buffer because
773 we could be reading an integer that is larger than the default int
774 used for repeat counts. */
777 read_integer (st_parameter_dt
*dtp
, int length
)
779 char message
[MSGLEN
];
789 /* Fall through... */
792 if ((c
= next_char (dtp
)) == EOF
)
796 CASE_SEPARATORS
: /* Single null. */
809 /* Take care of what may be a repeat count. */
821 push_char (dtp
, '\0');
824 CASE_SEPARATORS
: /* Not a repeat count. */
834 if (convert_integer (dtp
, -1, 0))
837 /* Get the real integer. */
839 if ((c
= next_char (dtp
)) == EOF
)
853 /* Fall through... */
885 if (nml_bad_return (dtp
, c
))
896 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
897 dtp
->u
.p
.item_count
);
898 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
906 push_char (dtp
, '\0');
907 if (convert_integer (dtp
, length
, negative
))
914 dtp
->u
.p
.saved_type
= BT_INTEGER
;
918 /* Read a character variable. */
921 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
923 char quote
, message
[MSGLEN
];
926 quote
= ' '; /* Space means no quote character. */
928 if ((c
= next_char (dtp
)) == EOF
)
937 unget_char (dtp
, c
); /* NULL value. */
947 if (dtp
->u
.p
.namelist_mode
)
957 /* Deal with a possible repeat count. */
961 if ((c
= next_char (dtp
)) == EOF
)
971 goto done
; /* String was only digits! */
974 push_char (dtp
, '\0');
979 goto get_string
; /* Not a repeat count after all. */
984 if (convert_integer (dtp
, -1, 0))
987 /* Now get the real string. */
989 if ((c
= next_char (dtp
)) == EOF
)
994 unget_char (dtp
, c
); /* Repeated NULL values. */
1011 if ((c
= next_char (dtp
)) == EOF
)
1023 /* See if we have a doubled quote character or the end of
1026 if ((c
= next_char (dtp
)) == EOF
)
1030 push_char (dtp
, quote
);
1034 unget_char (dtp
, c
);
1040 unget_char (dtp
, c
);
1044 if (c
!= '\n' && c
!= '\r')
1054 /* At this point, we have to have a separator, or else the string is
1057 c
= next_char (dtp
);
1059 if (is_separator (c
) || c
== '!' || c
== EOF
)
1061 unget_char (dtp
, c
);
1062 eat_separator (dtp
);
1063 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1069 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1070 dtp
->u
.p
.item_count
);
1071 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1081 /* Parse a component of a complex constant or a real number that we
1082 are sure is already there. This is a straight real number parser. */
1085 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1087 char message
[MSGLEN
];
1090 if ((c
= next_char (dtp
)) == EOF
)
1093 if (c
== '-' || c
== '+')
1096 if ((c
= next_char (dtp
)) == EOF
)
1100 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1103 if (!isdigit (c
) && c
!= '.')
1105 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1113 seen_dp
= (c
== '.') ? 1 : 0;
1117 if ((c
= next_char (dtp
)) == EOF
)
1119 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1139 push_char (dtp
, 'e');
1144 push_char (dtp
, 'e');
1146 if ((c
= next_char (dtp
)) == EOF
)
1159 if ((c
= next_char (dtp
)) == EOF
)
1161 if (c
!= '-' && c
!= '+')
1162 push_char (dtp
, '+');
1166 c
= next_char (dtp
);
1177 if ((c
= next_char (dtp
)) == EOF
)
1186 unget_char (dtp
, c
);
1195 unget_char (dtp
, c
);
1196 push_char (dtp
, '\0');
1198 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1204 unget_char (dtp
, c
);
1205 push_char (dtp
, '\0');
1207 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1213 /* Match INF and Infinity. */
1214 if ((c
== 'i' || c
== 'I')
1215 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1216 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1218 c
= next_char (dtp
);
1219 if ((c
!= 'i' && c
!= 'I')
1220 || ((c
== 'i' || c
== 'I')
1221 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1222 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1223 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1224 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1225 && (c
= next_char (dtp
))))
1227 if (is_separator (c
))
1228 unget_char (dtp
, c
);
1229 push_char (dtp
, 'i');
1230 push_char (dtp
, 'n');
1231 push_char (dtp
, 'f');
1235 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1236 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1237 && (c
= next_char (dtp
)))
1239 if (is_separator (c
))
1240 unget_char (dtp
, c
);
1241 push_char (dtp
, 'n');
1242 push_char (dtp
, 'a');
1243 push_char (dtp
, 'n');
1245 /* Match "NAN(alphanum)". */
1248 for ( ; c
!= ')'; c
= next_char (dtp
))
1249 if (is_separator (c
))
1252 c
= next_char (dtp
);
1253 if (is_separator (c
))
1254 unget_char (dtp
, c
);
1261 if (nml_bad_return (dtp
, c
))
1272 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1273 dtp
->u
.p
.item_count
);
1274 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1280 /* Reading a complex number is straightforward because we can tell
1281 what it is right away. */
1284 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1286 char message
[MSGLEN
];
1289 if (parse_repeat (dtp
))
1292 c
= next_char (dtp
);
1299 unget_char (dtp
, c
);
1300 eat_separator (dtp
);
1309 c
= next_char (dtp
);
1310 if (c
== '\n' || c
== '\r')
1313 unget_char (dtp
, c
);
1315 if (parse_real (dtp
, dest
, kind
))
1320 c
= next_char (dtp
);
1321 if (c
== '\n' || c
== '\r')
1324 unget_char (dtp
, c
);
1327 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1332 c
= next_char (dtp
);
1333 if (c
== '\n' || c
== '\r')
1336 unget_char (dtp
, c
);
1338 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1343 c
= next_char (dtp
);
1344 if (c
== '\n' || c
== '\r')
1347 unget_char (dtp
, c
);
1349 if (next_char (dtp
) != ')')
1352 c
= next_char (dtp
);
1353 if (!is_separator (c
))
1356 unget_char (dtp
, c
);
1357 eat_separator (dtp
);
1360 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1365 if (nml_bad_return (dtp
, c
))
1376 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1377 dtp
->u
.p
.item_count
);
1378 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1382 /* Parse a real number with a possible repeat count. */
1385 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1387 char message
[MSGLEN
];
1394 c
= next_char (dtp
);
1395 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1413 unget_char (dtp
, c
); /* Single null. */
1414 eat_separator (dtp
);
1427 /* Get the digit string that might be a repeat count. */
1431 c
= next_char (dtp
);
1432 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1456 push_char (dtp
, 'e');
1458 c
= next_char (dtp
);
1462 push_char (dtp
, '\0');
1466 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1467 unget_char (dtp
, c
);
1476 if (convert_integer (dtp
, -1, 0))
1479 /* Now get the number itself. */
1481 if ((c
= next_char (dtp
)) == EOF
)
1483 if (is_separator (c
))
1484 { /* Repeated null value. */
1485 unget_char (dtp
, c
);
1486 eat_separator (dtp
);
1490 if (c
!= '-' && c
!= '+')
1491 push_char (dtp
, '+');
1496 if ((c
= next_char (dtp
)) == EOF
)
1500 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1503 if (!isdigit (c
) && c
!= '.')
1505 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1524 c
= next_char (dtp
);
1525 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1553 push_char (dtp
, 'e');
1555 c
= next_char (dtp
);
1564 push_char (dtp
, 'e');
1566 if ((c
= next_char (dtp
)) == EOF
)
1568 if (c
!= '+' && c
!= '-')
1569 push_char (dtp
, '+');
1573 c
= next_char (dtp
);
1583 c
= next_char (dtp
);
1600 unget_char (dtp
, c
);
1601 eat_separator (dtp
);
1602 push_char (dtp
, '\0');
1603 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1607 dtp
->u
.p
.saved_type
= BT_REAL
;
1611 l_push_char (dtp
, c
);
1614 /* Match INF and Infinity. */
1615 if (c
== 'i' || c
== 'I')
1617 c
= next_char (dtp
);
1618 l_push_char (dtp
, c
);
1619 if (c
!= 'n' && c
!= 'N')
1621 c
= next_char (dtp
);
1622 l_push_char (dtp
, c
);
1623 if (c
!= 'f' && c
!= 'F')
1625 c
= next_char (dtp
);
1626 l_push_char (dtp
, c
);
1627 if (!is_separator (c
))
1629 if (c
!= 'i' && c
!= 'I')
1631 c
= next_char (dtp
);
1632 l_push_char (dtp
, c
);
1633 if (c
!= 'n' && c
!= 'N')
1635 c
= next_char (dtp
);
1636 l_push_char (dtp
, c
);
1637 if (c
!= 'i' && c
!= 'I')
1639 c
= next_char (dtp
);
1640 l_push_char (dtp
, c
);
1641 if (c
!= 't' && c
!= 'T')
1643 c
= next_char (dtp
);
1644 l_push_char (dtp
, c
);
1645 if (c
!= 'y' && c
!= 'Y')
1647 c
= next_char (dtp
);
1648 l_push_char (dtp
, c
);
1654 c
= next_char (dtp
);
1655 l_push_char (dtp
, c
);
1656 if (c
!= 'a' && c
!= 'A')
1658 c
= next_char (dtp
);
1659 l_push_char (dtp
, c
);
1660 if (c
!= 'n' && c
!= 'N')
1662 c
= next_char (dtp
);
1663 l_push_char (dtp
, c
);
1665 /* Match NAN(alphanum). */
1668 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1669 if (is_separator (c
))
1672 l_push_char (dtp
, c
);
1674 l_push_char (dtp
, ')');
1675 c
= next_char (dtp
);
1676 l_push_char (dtp
, c
);
1680 if (!is_separator (c
))
1683 if (dtp
->u
.p
.namelist_mode
)
1685 if (c
== ' ' || c
=='\n' || c
== '\r')
1689 if ((c
= next_char (dtp
)) == EOF
)
1692 while (c
== ' ' || c
=='\n' || c
== '\r');
1694 l_push_char (dtp
, c
);
1703 push_char (dtp
, 'i');
1704 push_char (dtp
, 'n');
1705 push_char (dtp
, 'f');
1709 push_char (dtp
, 'n');
1710 push_char (dtp
, 'a');
1711 push_char (dtp
, 'n');
1715 unget_char (dtp
, c
);
1716 eat_separator (dtp
);
1717 push_char (dtp
, '\0');
1718 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1722 dtp
->u
.p
.saved_type
= BT_REAL
;
1726 if (dtp
->u
.p
.namelist_mode
)
1728 dtp
->u
.p
.nml_read_error
= 1;
1729 dtp
->u
.p
.line_buffer_enabled
= 1;
1730 dtp
->u
.p
.item_count
= 0;
1736 if (nml_bad_return (dtp
, c
))
1748 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1749 dtp
->u
.p
.item_count
);
1750 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1754 /* Check the current type against the saved type to make sure they are
1755 compatible. Returns nonzero if incompatible. */
1758 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1760 char message
[MSGLEN
];
1762 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1764 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1765 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1766 dtp
->u
.p
.item_count
);
1768 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1772 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1775 if (dtp
->u
.p
.saved_length
!= len
)
1777 snprintf (message
, MSGLEN
,
1778 "Read kind %d %s where kind %d is required for item %d",
1779 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1780 dtp
->u
.p
.item_count
);
1781 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1789 /* Top level data transfer subroutine for list reads. Because we have
1790 to deal with repeat counts, the data item is always saved after
1791 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1792 greater than one, we copy the data item multiple times. */
1795 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1796 int kind
, size_t size
)
1802 dtp
->u
.p
.namelist_mode
= 0;
1804 if (dtp
->u
.p
.first_item
)
1806 dtp
->u
.p
.first_item
= 0;
1807 dtp
->u
.p
.input_complete
= 0;
1808 dtp
->u
.p
.repeat_count
= 1;
1809 dtp
->u
.p
.at_eol
= 0;
1811 if ((c
= eat_spaces (dtp
)) == EOF
)
1816 if (is_separator (c
))
1818 /* Found a null value. */
1819 eat_separator (dtp
);
1820 dtp
->u
.p
.repeat_count
= 0;
1822 /* eat_separator sets this flag if the separator was a comma. */
1823 if (dtp
->u
.p
.comma_flag
)
1826 /* eat_separator sets this flag if the separator was a \n or \r. */
1827 if (dtp
->u
.p
.at_eol
)
1828 finish_separator (dtp
);
1836 if (dtp
->u
.p
.repeat_count
> 0)
1838 if (check_type (dtp
, type
, kind
))
1843 if (dtp
->u
.p
.input_complete
)
1846 if (dtp
->u
.p
.at_eol
)
1847 finish_separator (dtp
);
1851 /* Trailing spaces prior to end of line. */
1852 if (dtp
->u
.p
.at_eol
)
1853 finish_separator (dtp
);
1856 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1857 dtp
->u
.p
.repeat_count
= 1;
1863 read_integer (dtp
, kind
);
1866 read_logical (dtp
, kind
);
1869 read_character (dtp
, kind
);
1872 read_real (dtp
, p
, kind
);
1873 /* Copy value back to temporary if needed. */
1874 if (dtp
->u
.p
.repeat_count
> 0)
1875 memcpy (dtp
->u
.p
.value
, p
, kind
);
1878 read_complex (dtp
, p
, kind
, size
);
1879 /* Copy value back to temporary if needed. */
1880 if (dtp
->u
.p
.repeat_count
> 0)
1881 memcpy (dtp
->u
.p
.value
, p
, size
);
1884 internal_error (&dtp
->common
, "Bad type for list read");
1887 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1888 dtp
->u
.p
.saved_length
= size
;
1890 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1894 switch (dtp
->u
.p
.saved_type
)
1898 if (dtp
->u
.p
.repeat_count
> 0)
1899 memcpy (p
, dtp
->u
.p
.value
, size
);
1904 memcpy (p
, dtp
->u
.p
.value
, size
);
1908 if (dtp
->u
.p
.saved_string
)
1910 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1911 ? (int) size
: dtp
->u
.p
.saved_used
;
1913 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1916 q
= (gfc_char4_t
*) p
;
1917 for (i
= 0; i
< m
; i
++)
1918 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1922 /* Just delimiters encountered, nothing to copy but SPACE. */
1928 memset (((char *) p
) + m
, ' ', size
- m
);
1931 q
= (gfc_char4_t
*) p
;
1932 for (i
= m
; i
< (int) size
; i
++)
1933 q
[i
] = (unsigned char) ' ';
1942 internal_error (&dtp
->common
, "Bad type for list read");
1945 if (--dtp
->u
.p
.repeat_count
<= 0)
1949 if (err
== LIBERROR_END
)
1956 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1957 size_t size
, size_t nelems
)
1961 size_t stride
= type
== BT_CHARACTER
?
1962 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1967 /* Big loop over all the elements. */
1968 for (elem
= 0; elem
< nelems
; elem
++)
1970 dtp
->u
.p
.item_count
++;
1971 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
1979 /* Finish a list read. */
1982 finish_list_read (st_parameter_dt
*dtp
)
1988 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1990 if (dtp
->u
.p
.at_eol
)
1992 dtp
->u
.p
.at_eol
= 0;
1996 err
= eat_line (dtp
);
1997 if (err
== LIBERROR_END
)
2003 void namelist_read (st_parameter_dt *dtp)
2005 static void nml_match_name (char *name, int len)
2006 static int nml_query (st_parameter_dt *dtp)
2007 static int nml_get_obj_data (st_parameter_dt *dtp,
2008 namelist_info **prev_nl, char *, size_t)
2010 static void nml_untouch_nodes (st_parameter_dt *dtp)
2011 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2013 static int nml_parse_qualifier(descriptor_dimension * ad,
2014 array_loop_spec * ls, int rank, char *)
2015 static void nml_touch_nodes (namelist_info * nl)
2016 static int nml_read_obj (namelist_info *nl, index_type offset,
2017 namelist_info **prev_nl, char *, size_t,
2018 index_type clow, index_type chigh)
2022 /* Inputs a rank-dimensional qualifier, which can contain
2023 singlets, doublets, triplets or ':' with the standard meanings. */
2026 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2027 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2028 size_t parse_err_msg_size
,
2035 int is_array_section
, is_char
;
2039 is_array_section
= 0;
2040 dtp
->u
.p
.expanded_read
= 0;
2042 /* See if this is a character substring qualifier we are looking for. */
2049 /* The next character in the stream should be the '('. */
2051 if ((c
= next_char (dtp
)) == EOF
)
2054 /* Process the qualifier, by dimension and triplet. */
2056 for (dim
=0; dim
< rank
; dim
++ )
2058 for (indx
=0; indx
<3; indx
++)
2064 /* Process a potential sign. */
2065 if ((c
= next_char (dtp
)) == EOF
)
2077 unget_char (dtp
, c
);
2081 /* Process characters up to the next ':' , ',' or ')'. */
2084 if ((c
= next_char (dtp
)) == EOF
)
2090 is_array_section
= 1;
2094 if ((c
==',' && dim
== rank
-1)
2095 || (c
==')' && dim
< rank
-1))
2098 snprintf (parse_err_msg
, parse_err_msg_size
,
2099 "Bad substring qualifier");
2101 snprintf (parse_err_msg
, parse_err_msg_size
,
2102 "Bad number of index fields");
2111 case ' ': case '\t':
2113 if ((c
= next_char (dtp
) == EOF
))
2119 snprintf (parse_err_msg
, parse_err_msg_size
,
2120 "Bad character in substring qualifier");
2122 snprintf (parse_err_msg
, parse_err_msg_size
,
2123 "Bad character in index");
2127 if ((c
== ',' || c
== ')') && indx
== 0
2128 && dtp
->u
.p
.saved_string
== 0)
2131 snprintf (parse_err_msg
, parse_err_msg_size
,
2132 "Null substring qualifier");
2134 snprintf (parse_err_msg
, parse_err_msg_size
,
2135 "Null index field");
2139 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2140 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2143 snprintf (parse_err_msg
, parse_err_msg_size
,
2144 "Bad substring qualifier");
2146 snprintf (parse_err_msg
, parse_err_msg_size
,
2147 "Bad index triplet");
2151 if (is_char
&& !is_array_section
)
2153 snprintf (parse_err_msg
, parse_err_msg_size
,
2154 "Missing colon in substring qualifier");
2158 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2160 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2161 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2167 /* Now read the index. */
2168 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2171 snprintf (parse_err_msg
, parse_err_msg_size
,
2172 "Bad integer substring qualifier");
2174 snprintf (parse_err_msg
, parse_err_msg_size
,
2175 "Bad integer in index");
2181 /* Feed the index values to the triplet arrays. */
2185 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2187 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2189 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2192 /* Singlet or doublet indices. */
2193 if (c
==',' || c
==')')
2197 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2199 /* If -std=f95/2003 or an array section is specified,
2200 do not allow excess data to be processed. */
2201 if (is_array_section
== 1
2202 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2203 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2204 ls
[dim
].end
= ls
[dim
].start
;
2206 dtp
->u
.p
.expanded_read
= 1;
2209 /* Check for non-zero rank. */
2210 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2217 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2220 dtp
->u
.p
.expanded_read
= 0;
2221 for (i
= 0; i
< dim
; i
++)
2222 ls
[i
].end
= ls
[i
].start
;
2225 /* Check the values of the triplet indices. */
2226 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2227 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2228 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2229 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2232 snprintf (parse_err_msg
, parse_err_msg_size
,
2233 "Substring out of range");
2235 snprintf (parse_err_msg
, parse_err_msg_size
,
2236 "Index %d out of range", dim
+ 1);
2240 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2241 || (ls
[dim
].step
== 0))
2243 snprintf (parse_err_msg
, parse_err_msg_size
,
2244 "Bad range in index %d", dim
+ 1);
2248 /* Initialise the loop index counter. */
2249 ls
[dim
].idx
= ls
[dim
].start
;
2259 static namelist_info
*
2260 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2262 namelist_info
* t
= dtp
->u
.p
.ionml
;
2265 if (strcmp (var_name
, t
->var_name
) == 0)
2275 /* Visits all the components of a derived type that have
2276 not explicitly been identified in the namelist input.
2277 touched is set and the loop specification initialised
2278 to default values */
2281 nml_touch_nodes (namelist_info
* nl
)
2283 index_type len
= strlen (nl
->var_name
) + 1;
2285 char * ext_name
= (char*)xmalloc (len
+ 1);
2286 memcpy (ext_name
, nl
->var_name
, len
-1);
2287 memcpy (ext_name
+ len
- 1, "%", 2);
2288 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2290 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2293 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2295 nl
->ls
[dim
].step
= 1;
2296 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2297 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2298 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2308 /* Resets touched for the entire list of nml_nodes, ready for a
2312 nml_untouch_nodes (st_parameter_dt
*dtp
)
2315 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2320 /* Attempts to input name to namelist name. Returns
2321 dtp->u.p.nml_read_error = 1 on no match. */
2324 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2329 dtp
->u
.p
.nml_read_error
= 0;
2330 for (i
= 0; i
< len
; i
++)
2332 c
= next_char (dtp
);
2333 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2335 dtp
->u
.p
.nml_read_error
= 1;
2341 /* If the namelist read is from stdin, output the current state of the
2342 namelist to stdout. This is used to implement the non-standard query
2343 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2344 the names alone are printed. */
2347 nml_query (st_parameter_dt
*dtp
, char c
)
2349 gfc_unit
* temp_unit
;
2354 static const index_type endlen
= 3;
2355 static const char endl
[] = "\r\n";
2356 static const char nmlend
[] = "&end\r\n";
2358 static const index_type endlen
= 2;
2359 static const char endl
[] = "\n";
2360 static const char nmlend
[] = "&end\n";
2363 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2366 /* Store the current unit and transfer to stdout. */
2368 temp_unit
= dtp
->u
.p
.current_unit
;
2369 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2371 if (dtp
->u
.p
.current_unit
)
2373 dtp
->u
.p
.mode
= WRITING
;
2374 next_record (dtp
, 0);
2376 /* Write the namelist in its entirety. */
2379 namelist_write (dtp
);
2381 /* Or write the list of names. */
2385 /* "&namelist_name\n" */
2387 len
= dtp
->namelist_name_len
;
2388 p
= write_block (dtp
, len
+ endlen
);
2392 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2393 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2394 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2398 len
= strlen (nl
->var_name
);
2399 p
= write_block (dtp
, len
+ endlen
);
2403 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2404 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2409 p
= write_block (dtp
, endlen
+ 3);
2411 memcpy (p
, &nmlend
, endlen
+ 3);
2414 /* Flush the stream to force immediate output. */
2416 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2417 sflush (dtp
->u
.p
.current_unit
->s
);
2418 unlock_unit (dtp
->u
.p
.current_unit
);
2423 /* Restore the current unit. */
2425 dtp
->u
.p
.current_unit
= temp_unit
;
2426 dtp
->u
.p
.mode
= READING
;
2430 /* Reads and stores the input for the namelist object nl. For an array,
2431 the function loops over the ranges defined by the loop specification.
2432 This default to all the data or to the specification from a qualifier.
2433 nml_read_obj recursively calls itself to read derived types. It visits
2434 all its own components but only reads data for those that were touched
2435 when the name was parsed. If a read error is encountered, an attempt is
2436 made to return to read a new object name because the standard allows too
2437 little data to be available. On the other hand, too much data is an
2441 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2442 namelist_info
**pprev_nl
, char *nml_err_msg
,
2443 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2445 namelist_info
* cmp
;
2452 size_t obj_name_len
;
2455 /* This object not touched in name parsing. */
2460 dtp
->u
.p
.repeat_count
= 0;
2472 dlen
= size_from_real_kind (len
);
2476 dlen
= size_from_complex_kind (len
);
2480 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2489 /* Update the pointer to the data, using the current index vector */
2491 pdata
= (void*)(nl
->mem_pos
+ offset
);
2492 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2493 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2494 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2495 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2497 /* Reset the error flag and try to read next value, if
2498 dtp->u.p.repeat_count=0 */
2500 dtp
->u
.p
.nml_read_error
= 0;
2502 if (--dtp
->u
.p
.repeat_count
<= 0)
2504 if (dtp
->u
.p
.input_complete
)
2506 if (dtp
->u
.p
.at_eol
)
2507 finish_separator (dtp
);
2508 if (dtp
->u
.p
.input_complete
)
2511 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2517 read_integer (dtp
, len
);
2521 read_logical (dtp
, len
);
2525 read_character (dtp
, len
);
2529 /* Need to copy data back from the real location to the temp in order
2530 to handle nml reads into arrays. */
2531 read_real (dtp
, pdata
, len
);
2532 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2536 /* Same as for REAL, copy back to temp. */
2537 read_complex (dtp
, pdata
, len
, dlen
);
2538 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2542 obj_name_len
= strlen (nl
->var_name
) + 1;
2543 obj_name
= xmalloc (obj_name_len
+1);
2544 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2545 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2547 /* If reading a derived type, disable the expanded read warning
2548 since a single object can have multiple reads. */
2549 dtp
->u
.p
.expanded_read
= 0;
2551 /* Now loop over the components. Update the component pointer
2552 with the return value from nml_write_obj. This loop jumps
2553 past nested derived types by testing if the potential
2554 component name contains '%'. */
2556 for (cmp
= nl
->next
;
2558 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2559 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2563 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2564 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2565 clow
, chigh
) == FAILURE
)
2571 if (dtp
->u
.p
.input_complete
)
2582 snprintf (nml_err_msg
, nml_err_msg_size
,
2583 "Bad type for namelist object %s", nl
->var_name
);
2584 internal_error (&dtp
->common
, nml_err_msg
);
2589 /* The standard permits array data to stop short of the number of
2590 elements specified in the loop specification. In this case, we
2591 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2592 nml_get_obj_data and an attempt is made to read object name. */
2595 if (dtp
->u
.p
.nml_read_error
)
2597 dtp
->u
.p
.expanded_read
= 0;
2601 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2603 dtp
->u
.p
.expanded_read
= 0;
2607 switch (dtp
->u
.p
.saved_type
)
2614 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2618 if (dlen
< dtp
->u
.p
.saved_used
)
2620 if (compile_options
.bounds_check
)
2622 snprintf (nml_err_msg
, nml_err_msg_size
,
2623 "Namelist object '%s' truncated on read.",
2625 generate_warning (&dtp
->common
, nml_err_msg
);
2630 m
= dtp
->u
.p
.saved_used
;
2631 pdata
= (void*)( pdata
+ clow
- 1 );
2632 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2634 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2641 /* Warn if a non-standard expanded read occurs. A single read of a
2642 single object is acceptable. If a second read occurs, issue a warning
2643 and set the flag to zero to prevent further warnings. */
2644 if (dtp
->u
.p
.expanded_read
== 2)
2646 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2647 dtp
->u
.p
.expanded_read
= 0;
2650 /* If the expanded read warning flag is set, increment it,
2651 indicating that a single read has occurred. */
2652 if (dtp
->u
.p
.expanded_read
>= 1)
2653 dtp
->u
.p
.expanded_read
++;
2655 /* Break out of loop if scalar. */
2659 /* Now increment the index vector. */
2664 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2666 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2668 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2670 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2672 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2676 } while (!nml_carry
);
2678 if (dtp
->u
.p
.repeat_count
> 1)
2680 snprintf (nml_err_msg
, nml_err_msg_size
,
2681 "Repeat count too large for namelist object %s", nl
->var_name
);
2691 /* Parses the object name, including array and substring qualifiers. It
2692 iterates over derived type components, touching those components and
2693 setting their loop specifications, if there is a qualifier. If the
2694 object is itself a derived type, its components and subcomponents are
2695 touched. nml_read_obj is called at the end and this reads the data in
2696 the manner specified by the object name. */
2699 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2700 char *nml_err_msg
, size_t nml_err_msg_size
)
2704 namelist_info
* first_nl
= NULL
;
2705 namelist_info
* root_nl
= NULL
;
2706 int dim
, parsed_rank
;
2707 int component_flag
, qualifier_flag
;
2708 index_type clow
, chigh
;
2709 int non_zero_rank_count
;
2711 /* Look for end of input or object name. If '?' or '=?' are encountered
2712 in stdin, print the node names or the namelist to stdout. */
2714 eat_separator (dtp
);
2715 if (dtp
->u
.p
.input_complete
)
2718 if (dtp
->u
.p
.at_eol
)
2719 finish_separator (dtp
);
2720 if (dtp
->u
.p
.input_complete
)
2723 if ((c
= next_char (dtp
)) == EOF
)
2728 if ((c
= next_char (dtp
)) == EOF
)
2732 snprintf (nml_err_msg
, nml_err_msg_size
,
2733 "namelist read: misplaced = sign");
2736 nml_query (dtp
, '=');
2740 nml_query (dtp
, '?');
2745 nml_match_name (dtp
, "end", 3);
2746 if (dtp
->u
.p
.nml_read_error
)
2748 snprintf (nml_err_msg
, nml_err_msg_size
,
2749 "namelist not terminated with / or &end");
2753 dtp
->u
.p
.input_complete
= 1;
2760 /* Untouch all nodes of the namelist and reset the flags that are set for
2761 derived type components. */
2763 nml_untouch_nodes (dtp
);
2766 non_zero_rank_count
= 0;
2768 /* Get the object name - should '!' and '\n' be permitted separators? */
2776 if (!is_separator (c
))
2777 push_char (dtp
, tolower(c
));
2778 if ((c
= next_char (dtp
)) == EOF
)
2780 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2782 unget_char (dtp
, c
);
2784 /* Check that the name is in the namelist and get pointer to object.
2785 Three error conditions exist: (i) An attempt is being made to
2786 identify a non-existent object, following a failed data read or
2787 (ii) The object name does not exist or (iii) Too many data items
2788 are present for an object. (iii) gives the same error message
2791 push_char (dtp
, '\0');
2795 size_t var_len
= strlen (root_nl
->var_name
);
2797 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2798 char ext_name
[var_len
+ saved_len
+ 1];
2800 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2801 if (dtp
->u
.p
.saved_string
)
2802 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2803 ext_name
[var_len
+ saved_len
] = '\0';
2804 nl
= find_nml_node (dtp
, ext_name
);
2807 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2811 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2812 snprintf (nml_err_msg
, nml_err_msg_size
,
2813 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2816 snprintf (nml_err_msg
, nml_err_msg_size
,
2817 "Cannot match namelist object name %s",
2818 dtp
->u
.p
.saved_string
);
2823 /* Get the length, data length, base pointer and rank of the variable.
2824 Set the default loop specification first. */
2826 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2828 nl
->ls
[dim
].step
= 1;
2829 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2830 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2831 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2834 /* Check to see if there is a qualifier: if so, parse it.*/
2836 if (c
== '(' && nl
->var_rank
)
2839 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2840 nml_err_msg
, nml_err_msg_size
,
2841 &parsed_rank
) == FAILURE
)
2843 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2844 snprintf (nml_err_msg_end
,
2845 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2846 " for namelist variable %s", nl
->var_name
);
2849 if (parsed_rank
> 0)
2850 non_zero_rank_count
++;
2854 if ((c
= next_char (dtp
)) == EOF
)
2856 unget_char (dtp
, c
);
2858 else if (nl
->var_rank
> 0)
2859 non_zero_rank_count
++;
2861 /* Now parse a derived type component. The root namelist_info address
2862 is backed up, as is the previous component level. The component flag
2863 is set and the iteration is made by jumping back to get_name. */
2867 if (nl
->type
!= BT_DERIVED
)
2869 snprintf (nml_err_msg
, nml_err_msg_size
,
2870 "Attempt to get derived component for %s", nl
->var_name
);
2874 if (*pprev_nl
== NULL
|| !component_flag
)
2880 if ((c
= next_char (dtp
)) == EOF
)
2885 /* Parse a character qualifier, if present. chigh = 0 is a default
2886 that signals that the string length = string_length. */
2891 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2893 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2894 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2896 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
,
2897 nml_err_msg_size
, &parsed_rank
)
2900 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2901 snprintf (nml_err_msg_end
,
2902 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2903 " for namelist variable %s", nl
->var_name
);
2907 clow
= ind
[0].start
;
2910 if (ind
[0].step
!= 1)
2912 snprintf (nml_err_msg
, nml_err_msg_size
,
2913 "Step not allowed in substring qualifier"
2914 " for namelist object %s", nl
->var_name
);
2918 if ((c
= next_char (dtp
)) == EOF
)
2920 unget_char (dtp
, c
);
2923 /* Make sure no extraneous qualifiers are there. */
2927 snprintf (nml_err_msg
, nml_err_msg_size
,
2928 "Qualifier for a scalar or non-character namelist object %s",
2933 /* Make sure there is no more than one non-zero rank object. */
2934 if (non_zero_rank_count
> 1)
2936 snprintf (nml_err_msg
, nml_err_msg_size
,
2937 "Multiple sub-objects with non-zero rank in namelist object %s",
2939 non_zero_rank_count
= 0;
2943 /* According to the standard, an equal sign MUST follow an object name. The
2944 following is possibly lax - it allows comments, blank lines and so on to
2945 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2949 eat_separator (dtp
);
2950 if (dtp
->u
.p
.input_complete
)
2953 if (dtp
->u
.p
.at_eol
)
2954 finish_separator (dtp
);
2955 if (dtp
->u
.p
.input_complete
)
2958 if ((c
= next_char (dtp
)) == EOF
)
2963 snprintf (nml_err_msg
, nml_err_msg_size
,
2964 "Equal sign must follow namelist object name %s",
2968 /* If a derived type, touch its components and restore the root
2969 namelist_info if we have parsed a qualified derived type
2972 if (nl
->type
== BT_DERIVED
)
2973 nml_touch_nodes (nl
);
2977 if (first_nl
->var_rank
== 0)
2979 if (component_flag
&& qualifier_flag
)
2986 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2987 clow
, chigh
) == FAILURE
)
2997 /* Entry point for namelist input. Goes through input until namelist name
2998 is matched. Then cycles through nml_get_obj_data until the input is
2999 completed or there is an error. */
3002 namelist_read (st_parameter_dt
*dtp
)
3005 char nml_err_msg
[200];
3007 /* Initialize the error string buffer just in case we get an unexpected fail
3008 somewhere and end up at nml_err_ret. */
3009 strcpy (nml_err_msg
, "Internal namelist read error");
3011 /* Pointer to the previously read object, in case attempt is made to read
3012 new object name. Should this fail, error message can give previous
3014 namelist_info
*prev_nl
= NULL
;
3016 dtp
->u
.p
.namelist_mode
= 1;
3017 dtp
->u
.p
.input_complete
= 0;
3018 dtp
->u
.p
.expanded_read
= 0;
3020 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3021 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3022 node names or namelist on stdout. */
3025 c
= next_char (dtp
);
3037 c
= next_char (dtp
);
3039 nml_query (dtp
, '=');
3041 unget_char (dtp
, c
);
3045 nml_query (dtp
, '?');
3054 /* Match the name of the namelist. */
3056 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3058 if (dtp
->u
.p
.nml_read_error
)
3061 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
3062 c
= next_char (dtp
);
3063 if (!is_separator(c
) && c
!= '!')
3065 unget_char (dtp
, c
);
3069 unget_char (dtp
, c
);
3070 eat_separator (dtp
);
3072 /* Ready to read namelist objects. If there is an error in input
3073 from stdin, output the error message and continue. */
3075 while (!dtp
->u
.p
.input_complete
)
3077 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3080 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3082 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3085 /* Reset the previous namelist pointer if we know we are not going
3086 to be doing multiple reads within a single namelist object. */
3087 if (prev_nl
&& prev_nl
->var_rank
== 0)
3098 /* All namelist error calls return from here */
3101 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);