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
))
202 /* Check for kind=4 internal unit. */
203 if (dtp
->common
.unit
)
204 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, sizeof (gfc_char4_t
));
208 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
214 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
218 if (is_array_io (dtp
))
220 /* Check whether we hit EOF. */
223 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
226 dtp
->u
.p
.current_unit
->bytes_left
--;
241 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
242 if (c
!= EOF
&& is_stream_io (dtp
))
243 dtp
->u
.p
.current_unit
->strm_pos
++;
246 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
251 /* Push a character back onto the input. */
254 unget_char (st_parameter_dt
*dtp
, int c
)
256 dtp
->u
.p
.last_char
= c
;
260 /* Skip over spaces in the input. Returns the nonspace character that
261 terminated the eating and also places it back on the input. */
264 eat_spaces (st_parameter_dt
*dtp
)
270 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
277 /* This function reads characters through to the end of the current
278 line and just ignores them. Returns 0 for success and LIBERROR_END
282 eat_line (st_parameter_dt
*dtp
)
288 while (c
!= EOF
&& c
!= '\n');
295 /* Skip over a separator. Technically, we don't always eat the whole
296 separator. This is because if we've processed the last input item,
297 then a separator is unnecessary. Plus the fact that operating
298 systems usually deliver console input on a line basis.
300 The upshot is that if we see a newline as part of reading a
301 separator, we stop reading. If there are more input items, we
302 continue reading the separator with finish_separator() which takes
303 care of the fact that we may or may not have seen a comma as part
306 Returns 0 for success, and non-zero error code otherwise. */
309 eat_separator (st_parameter_dt
*dtp
)
315 dtp
->u
.p
.comma_flag
= 0;
317 if ((c
= next_char (dtp
)) == EOF
)
322 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
329 dtp
->u
.p
.comma_flag
= 1;
334 dtp
->u
.p
.input_complete
= 1;
339 if ((n
= next_char(dtp
)) == EOF
)
349 if (dtp
->u
.p
.namelist_mode
)
353 if ((c
= next_char (dtp
)) == EOF
)
357 err
= eat_line (dtp
);
363 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
369 if (dtp
->u
.p
.namelist_mode
)
370 { /* Eat a namelist comment. */
371 err
= eat_line (dtp
);
378 /* Fall Through... */
388 /* Finish processing a separator that was interrupted by a newline.
389 If we're here, then another data item is present, so we finish what
390 we started on the previous line. Return 0 on success, error code
394 finish_separator (st_parameter_dt
*dtp
)
402 if ((c
= next_char (dtp
)) == EOF
)
407 if (dtp
->u
.p
.comma_flag
)
411 if ((c
= eat_spaces (dtp
)) == EOF
)
413 if (c
== '\n' || c
== '\r')
420 dtp
->u
.p
.input_complete
= 1;
421 if (!dtp
->u
.p
.namelist_mode
)
430 if (dtp
->u
.p
.namelist_mode
)
432 err
= eat_line (dtp
);
446 /* This function is needed to catch bad conversions so that namelist can
447 attempt to see if dtp->u.p.saved_string contains a new object name rather
451 nml_bad_return (st_parameter_dt
*dtp
, char c
)
453 if (dtp
->u
.p
.namelist_mode
)
455 dtp
->u
.p
.nml_read_error
= 1;
462 /* Convert an unsigned string to an integer. The length value is -1
463 if we are working on a repeat count. Returns nonzero if we have a
464 range problem. As a side effect, frees the dtp->u.p.saved_string. */
467 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
469 char c
, *buffer
, message
[MSGLEN
];
471 GFC_UINTEGER_LARGEST v
, max
, max10
;
472 GFC_INTEGER_LARGEST value
;
474 buffer
= dtp
->u
.p
.saved_string
;
481 max
= si_max (length
);
511 set_integer (dtp
->u
.p
.value
, value
, length
);
515 dtp
->u
.p
.repeat_count
= v
;
517 if (dtp
->u
.p
.repeat_count
== 0)
519 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
520 dtp
->u
.p
.item_count
);
522 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
532 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
533 dtp
->u
.p
.item_count
);
535 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
536 dtp
->u
.p
.item_count
);
539 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
545 /* Parse a repeat count for logical and complex values which cannot
546 begin with a digit. Returns nonzero if we are done, zero if we
547 should continue on. */
550 parse_repeat (st_parameter_dt
*dtp
)
552 char message
[MSGLEN
];
555 if ((c
= next_char (dtp
)) == EOF
)
579 repeat
= 10 * repeat
+ c
- '0';
581 if (repeat
> MAX_REPEAT
)
583 snprintf (message
, MSGLEN
,
584 "Repeat count overflow in item %d of list input",
585 dtp
->u
.p
.item_count
);
587 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
596 snprintf (message
, MSGLEN
,
597 "Zero repeat count in item %d of list input",
598 dtp
->u
.p
.item_count
);
600 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
612 dtp
->u
.p
.repeat_count
= repeat
;
625 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
626 dtp
->u
.p
.item_count
);
627 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
632 /* To read a logical we have to look ahead in the input stream to make sure
633 there is not an equal sign indicating a variable name. To do this we use
634 line_buffer to point to a temporary buffer, pushing characters there for
635 possible later reading. */
638 l_push_char (st_parameter_dt
*dtp
, char c
)
640 if (dtp
->u
.p
.line_buffer
== NULL
)
641 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
643 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
647 /* Read a logical character on the input. */
650 read_logical (st_parameter_dt
*dtp
, int length
)
652 char message
[MSGLEN
];
655 if (parse_repeat (dtp
))
658 c
= tolower (next_char (dtp
));
659 l_push_char (dtp
, c
);
665 l_push_char (dtp
, c
);
667 if (!is_separator(c
) && c
!= EOF
)
675 l_push_char (dtp
, c
);
677 if (!is_separator(c
) && c
!= EOF
)
684 c
= tolower (next_char (dtp
));
702 return; /* Null value. */
705 /* Save the character in case it is the beginning
706 of the next object name. */
711 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
712 dtp
->u
.p
.saved_length
= length
;
714 /* Eat trailing garbage. */
717 while (c
!= EOF
&& !is_separator (c
));
721 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
728 for(i
= 0; i
< 63; i
++)
733 /* All done if this is not a namelist read. */
734 if (!dtp
->u
.p
.namelist_mode
)
747 l_push_char (dtp
, c
);
750 dtp
->u
.p
.nml_read_error
= 1;
751 dtp
->u
.p
.line_buffer_enabled
= 1;
752 dtp
->u
.p
.item_count
= 0;
762 if (nml_bad_return (dtp
, c
))
773 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
774 dtp
->u
.p
.item_count
);
775 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
780 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
781 dtp
->u
.p
.saved_length
= length
;
782 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
788 /* Reading integers is tricky because we can actually be reading a
789 repeat count. We have to store the characters in a buffer because
790 we could be reading an integer that is larger than the default int
791 used for repeat counts. */
794 read_integer (st_parameter_dt
*dtp
, int length
)
796 char message
[MSGLEN
];
806 /* Fall through... */
809 if ((c
= next_char (dtp
)) == EOF
)
813 CASE_SEPARATORS
: /* Single null. */
826 /* Take care of what may be a repeat count. */
838 push_char (dtp
, '\0');
841 CASE_SEPARATORS
: /* Not a repeat count. */
851 if (convert_integer (dtp
, -1, 0))
854 /* Get the real integer. */
856 if ((c
= next_char (dtp
)) == EOF
)
870 /* Fall through... */
902 if (nml_bad_return (dtp
, c
))
913 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
914 dtp
->u
.p
.item_count
);
915 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
923 push_char (dtp
, '\0');
924 if (convert_integer (dtp
, length
, negative
))
931 dtp
->u
.p
.saved_type
= BT_INTEGER
;
935 /* Read a character variable. */
938 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
940 char quote
, message
[MSGLEN
];
943 quote
= ' '; /* Space means no quote character. */
945 if ((c
= next_char (dtp
)) == EOF
)
954 unget_char (dtp
, c
); /* NULL value. */
964 if (dtp
->u
.p
.namelist_mode
)
974 /* Deal with a possible repeat count. */
978 if ((c
= next_char (dtp
)) == EOF
)
988 goto done
; /* String was only digits! */
991 push_char (dtp
, '\0');
996 goto get_string
; /* Not a repeat count after all. */
1001 if (convert_integer (dtp
, -1, 0))
1004 /* Now get the real string. */
1006 if ((c
= next_char (dtp
)) == EOF
)
1011 unget_char (dtp
, c
); /* Repeated NULL values. */
1012 eat_separator (dtp
);
1028 if ((c
= next_char (dtp
)) == EOF
)
1040 /* See if we have a doubled quote character or the end of
1043 if ((c
= next_char (dtp
)) == EOF
)
1047 push_char (dtp
, quote
);
1051 unget_char (dtp
, c
);
1057 unget_char (dtp
, c
);
1061 if (c
!= '\n' && c
!= '\r')
1071 /* At this point, we have to have a separator, or else the string is
1074 c
= next_char (dtp
);
1076 if (is_separator (c
) || c
== '!' || c
== EOF
)
1078 unget_char (dtp
, c
);
1079 eat_separator (dtp
);
1080 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1086 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1087 dtp
->u
.p
.item_count
);
1088 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1098 /* Parse a component of a complex constant or a real number that we
1099 are sure is already there. This is a straight real number parser. */
1102 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1104 char message
[MSGLEN
];
1107 if ((c
= next_char (dtp
)) == EOF
)
1110 if (c
== '-' || c
== '+')
1113 if ((c
= next_char (dtp
)) == EOF
)
1117 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1120 if (!isdigit (c
) && c
!= '.')
1122 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1130 seen_dp
= (c
== '.') ? 1 : 0;
1134 if ((c
= next_char (dtp
)) == EOF
)
1136 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1158 push_char (dtp
, 'e');
1163 push_char (dtp
, 'e');
1165 if ((c
= next_char (dtp
)) == EOF
)
1178 if ((c
= next_char (dtp
)) == EOF
)
1180 if (c
!= '-' && c
!= '+')
1181 push_char (dtp
, '+');
1185 c
= next_char (dtp
);
1196 if ((c
= next_char (dtp
)) == EOF
)
1205 unget_char (dtp
, c
);
1214 unget_char (dtp
, c
);
1215 push_char (dtp
, '\0');
1217 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1223 unget_char (dtp
, c
);
1224 push_char (dtp
, '\0');
1226 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1232 /* Match INF and Infinity. */
1233 if ((c
== 'i' || c
== 'I')
1234 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1235 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1237 c
= next_char (dtp
);
1238 if ((c
!= 'i' && c
!= 'I')
1239 || ((c
== 'i' || c
== 'I')
1240 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1241 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1242 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1243 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1244 && (c
= next_char (dtp
))))
1246 if (is_separator (c
))
1247 unget_char (dtp
, c
);
1248 push_char (dtp
, 'i');
1249 push_char (dtp
, 'n');
1250 push_char (dtp
, 'f');
1254 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1255 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1256 && (c
= next_char (dtp
)))
1258 if (is_separator (c
))
1259 unget_char (dtp
, c
);
1260 push_char (dtp
, 'n');
1261 push_char (dtp
, 'a');
1262 push_char (dtp
, 'n');
1264 /* Match "NAN(alphanum)". */
1267 for ( ; c
!= ')'; c
= next_char (dtp
))
1268 if (is_separator (c
))
1271 c
= next_char (dtp
);
1272 if (is_separator (c
))
1273 unget_char (dtp
, c
);
1280 if (nml_bad_return (dtp
, c
))
1291 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1292 dtp
->u
.p
.item_count
);
1293 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1299 /* Reading a complex number is straightforward because we can tell
1300 what it is right away. */
1303 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1305 char message
[MSGLEN
];
1308 if (parse_repeat (dtp
))
1311 c
= next_char (dtp
);
1318 unget_char (dtp
, c
);
1319 eat_separator (dtp
);
1328 c
= next_char (dtp
);
1329 if (c
== '\n' || c
== '\r')
1332 unget_char (dtp
, c
);
1334 if (parse_real (dtp
, dest
, kind
))
1339 c
= next_char (dtp
);
1340 if (c
== '\n' || c
== '\r')
1343 unget_char (dtp
, c
);
1346 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1351 c
= next_char (dtp
);
1352 if (c
== '\n' || c
== '\r')
1355 unget_char (dtp
, c
);
1357 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1362 c
= next_char (dtp
);
1363 if (c
== '\n' || c
== '\r')
1366 unget_char (dtp
, c
);
1368 if (next_char (dtp
) != ')')
1371 c
= next_char (dtp
);
1372 if (!is_separator (c
))
1375 unget_char (dtp
, c
);
1376 eat_separator (dtp
);
1379 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1384 if (nml_bad_return (dtp
, c
))
1395 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1396 dtp
->u
.p
.item_count
);
1397 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1401 /* Parse a real number with a possible repeat count. */
1404 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1406 char message
[MSGLEN
];
1413 c
= next_char (dtp
);
1414 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1432 unget_char (dtp
, c
); /* Single null. */
1433 eat_separator (dtp
);
1446 /* Get the digit string that might be a repeat count. */
1450 c
= next_char (dtp
);
1451 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1477 push_char (dtp
, 'e');
1479 c
= next_char (dtp
);
1483 push_char (dtp
, '\0');
1487 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1488 unget_char (dtp
, c
);
1497 if (convert_integer (dtp
, -1, 0))
1500 /* Now get the number itself. */
1502 if ((c
= next_char (dtp
)) == EOF
)
1504 if (is_separator (c
))
1505 { /* Repeated null value. */
1506 unget_char (dtp
, c
);
1507 eat_separator (dtp
);
1511 if (c
!= '-' && c
!= '+')
1512 push_char (dtp
, '+');
1517 if ((c
= next_char (dtp
)) == EOF
)
1521 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1524 if (!isdigit (c
) && c
!= '.')
1526 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1545 c
= next_char (dtp
);
1546 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1576 push_char (dtp
, 'e');
1578 c
= next_char (dtp
);
1587 push_char (dtp
, 'e');
1589 if ((c
= next_char (dtp
)) == EOF
)
1591 if (c
!= '+' && c
!= '-')
1592 push_char (dtp
, '+');
1596 c
= next_char (dtp
);
1606 c
= next_char (dtp
);
1623 unget_char (dtp
, c
);
1624 eat_separator (dtp
);
1625 push_char (dtp
, '\0');
1626 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1630 dtp
->u
.p
.saved_type
= BT_REAL
;
1634 l_push_char (dtp
, c
);
1637 /* Match INF and Infinity. */
1638 if (c
== 'i' || c
== 'I')
1640 c
= next_char (dtp
);
1641 l_push_char (dtp
, c
);
1642 if (c
!= 'n' && c
!= 'N')
1644 c
= next_char (dtp
);
1645 l_push_char (dtp
, c
);
1646 if (c
!= 'f' && c
!= 'F')
1648 c
= next_char (dtp
);
1649 l_push_char (dtp
, c
);
1650 if (!is_separator (c
))
1652 if (c
!= 'i' && c
!= 'I')
1654 c
= next_char (dtp
);
1655 l_push_char (dtp
, c
);
1656 if (c
!= 'n' && c
!= 'N')
1658 c
= next_char (dtp
);
1659 l_push_char (dtp
, c
);
1660 if (c
!= 'i' && c
!= 'I')
1662 c
= next_char (dtp
);
1663 l_push_char (dtp
, c
);
1664 if (c
!= 't' && c
!= 'T')
1666 c
= next_char (dtp
);
1667 l_push_char (dtp
, c
);
1668 if (c
!= 'y' && c
!= 'Y')
1670 c
= next_char (dtp
);
1671 l_push_char (dtp
, c
);
1677 c
= next_char (dtp
);
1678 l_push_char (dtp
, c
);
1679 if (c
!= 'a' && c
!= 'A')
1681 c
= next_char (dtp
);
1682 l_push_char (dtp
, c
);
1683 if (c
!= 'n' && c
!= 'N')
1685 c
= next_char (dtp
);
1686 l_push_char (dtp
, c
);
1688 /* Match NAN(alphanum). */
1691 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1692 if (is_separator (c
))
1695 l_push_char (dtp
, c
);
1697 l_push_char (dtp
, ')');
1698 c
= next_char (dtp
);
1699 l_push_char (dtp
, c
);
1703 if (!is_separator (c
))
1706 if (dtp
->u
.p
.namelist_mode
)
1708 if (c
== ' ' || c
=='\n' || c
== '\r')
1712 if ((c
= next_char (dtp
)) == EOF
)
1715 while (c
== ' ' || c
=='\n' || c
== '\r');
1717 l_push_char (dtp
, c
);
1726 push_char (dtp
, 'i');
1727 push_char (dtp
, 'n');
1728 push_char (dtp
, 'f');
1732 push_char (dtp
, 'n');
1733 push_char (dtp
, 'a');
1734 push_char (dtp
, 'n');
1738 unget_char (dtp
, c
);
1739 eat_separator (dtp
);
1740 push_char (dtp
, '\0');
1741 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1745 dtp
->u
.p
.saved_type
= BT_REAL
;
1749 if (dtp
->u
.p
.namelist_mode
)
1751 dtp
->u
.p
.nml_read_error
= 1;
1752 dtp
->u
.p
.line_buffer_enabled
= 1;
1753 dtp
->u
.p
.item_count
= 0;
1759 if (nml_bad_return (dtp
, c
))
1771 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1772 dtp
->u
.p
.item_count
);
1773 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1777 /* Check the current type against the saved type to make sure they are
1778 compatible. Returns nonzero if incompatible. */
1781 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1783 char message
[MSGLEN
];
1785 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1787 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1788 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1789 dtp
->u
.p
.item_count
);
1791 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1795 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1798 if (dtp
->u
.p
.saved_length
!= len
)
1800 snprintf (message
, MSGLEN
,
1801 "Read kind %d %s where kind %d is required for item %d",
1802 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1803 dtp
->u
.p
.item_count
);
1804 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1812 /* Top level data transfer subroutine for list reads. Because we have
1813 to deal with repeat counts, the data item is always saved after
1814 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1815 greater than one, we copy the data item multiple times. */
1818 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1819 int kind
, size_t size
)
1825 dtp
->u
.p
.namelist_mode
= 0;
1827 if (dtp
->u
.p
.first_item
)
1829 dtp
->u
.p
.first_item
= 0;
1830 dtp
->u
.p
.input_complete
= 0;
1831 dtp
->u
.p
.repeat_count
= 1;
1832 dtp
->u
.p
.at_eol
= 0;
1834 if ((c
= eat_spaces (dtp
)) == EOF
)
1839 if (is_separator (c
))
1841 /* Found a null value. */
1842 eat_separator (dtp
);
1843 dtp
->u
.p
.repeat_count
= 0;
1845 /* eat_separator sets this flag if the separator was a comma. */
1846 if (dtp
->u
.p
.comma_flag
)
1849 /* eat_separator sets this flag if the separator was a \n or \r. */
1850 if (dtp
->u
.p
.at_eol
)
1851 finish_separator (dtp
);
1859 if (dtp
->u
.p
.repeat_count
> 0)
1861 if (check_type (dtp
, type
, kind
))
1866 if (dtp
->u
.p
.input_complete
)
1869 if (dtp
->u
.p
.at_eol
)
1870 finish_separator (dtp
);
1874 /* Trailing spaces prior to end of line. */
1875 if (dtp
->u
.p
.at_eol
)
1876 finish_separator (dtp
);
1879 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1880 dtp
->u
.p
.repeat_count
= 1;
1886 read_integer (dtp
, kind
);
1889 read_logical (dtp
, kind
);
1892 read_character (dtp
, kind
);
1895 read_real (dtp
, p
, kind
);
1896 /* Copy value back to temporary if needed. */
1897 if (dtp
->u
.p
.repeat_count
> 0)
1898 memcpy (dtp
->u
.p
.value
, p
, size
);
1901 read_complex (dtp
, p
, kind
, size
);
1902 /* Copy value back to temporary if needed. */
1903 if (dtp
->u
.p
.repeat_count
> 0)
1904 memcpy (dtp
->u
.p
.value
, p
, size
);
1907 internal_error (&dtp
->common
, "Bad type for list read");
1910 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1911 dtp
->u
.p
.saved_length
= size
;
1913 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1917 switch (dtp
->u
.p
.saved_type
)
1921 if (dtp
->u
.p
.repeat_count
> 0)
1922 memcpy (p
, dtp
->u
.p
.value
, size
);
1927 memcpy (p
, dtp
->u
.p
.value
, size
);
1931 if (dtp
->u
.p
.saved_string
)
1933 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1934 ? (int) size
: dtp
->u
.p
.saved_used
;
1936 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1939 q
= (gfc_char4_t
*) p
;
1940 for (i
= 0; i
< m
; i
++)
1941 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1945 /* Just delimiters encountered, nothing to copy but SPACE. */
1951 memset (((char *) p
) + m
, ' ', size
- m
);
1954 q
= (gfc_char4_t
*) p
;
1955 for (i
= m
; i
< (int) size
; i
++)
1956 q
[i
] = (unsigned char) ' ';
1965 internal_error (&dtp
->common
, "Bad type for list read");
1968 if (--dtp
->u
.p
.repeat_count
<= 0)
1972 if (err
== LIBERROR_END
)
1979 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1980 size_t size
, size_t nelems
)
1984 size_t stride
= type
== BT_CHARACTER
?
1985 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1990 /* Big loop over all the elements. */
1991 for (elem
= 0; elem
< nelems
; elem
++)
1993 dtp
->u
.p
.item_count
++;
1994 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2002 /* Finish a list read. */
2005 finish_list_read (st_parameter_dt
*dtp
)
2011 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2013 if (dtp
->u
.p
.at_eol
)
2015 dtp
->u
.p
.at_eol
= 0;
2019 err
= eat_line (dtp
);
2020 if (err
== LIBERROR_END
)
2026 void namelist_read (st_parameter_dt *dtp)
2028 static void nml_match_name (char *name, int len)
2029 static int nml_query (st_parameter_dt *dtp)
2030 static int nml_get_obj_data (st_parameter_dt *dtp,
2031 namelist_info **prev_nl, char *, size_t)
2033 static void nml_untouch_nodes (st_parameter_dt *dtp)
2034 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2036 static int nml_parse_qualifier(descriptor_dimension * ad,
2037 array_loop_spec * ls, int rank, char *)
2038 static void nml_touch_nodes (namelist_info * nl)
2039 static int nml_read_obj (namelist_info *nl, index_type offset,
2040 namelist_info **prev_nl, char *, size_t,
2041 index_type clow, index_type chigh)
2045 /* Inputs a rank-dimensional qualifier, which can contain
2046 singlets, doublets, triplets or ':' with the standard meanings. */
2049 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2050 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2051 size_t parse_err_msg_size
,
2058 int is_array_section
, is_char
;
2062 is_array_section
= 0;
2063 dtp
->u
.p
.expanded_read
= 0;
2065 /* See if this is a character substring qualifier we are looking for. */
2072 /* The next character in the stream should be the '('. */
2074 if ((c
= next_char (dtp
)) == EOF
)
2077 /* Process the qualifier, by dimension and triplet. */
2079 for (dim
=0; dim
< rank
; dim
++ )
2081 for (indx
=0; indx
<3; indx
++)
2087 /* Process a potential sign. */
2088 if ((c
= next_char (dtp
)) == EOF
)
2100 unget_char (dtp
, c
);
2104 /* Process characters up to the next ':' , ',' or ')'. */
2107 if ((c
= next_char (dtp
)) == EOF
)
2113 is_array_section
= 1;
2117 if ((c
==',' && dim
== rank
-1)
2118 || (c
==')' && dim
< rank
-1))
2121 snprintf (parse_err_msg
, parse_err_msg_size
,
2122 "Bad substring qualifier");
2124 snprintf (parse_err_msg
, parse_err_msg_size
,
2125 "Bad number of index fields");
2134 case ' ': case '\t':
2136 if ((c
= next_char (dtp
) == EOF
))
2142 snprintf (parse_err_msg
, parse_err_msg_size
,
2143 "Bad character in substring qualifier");
2145 snprintf (parse_err_msg
, parse_err_msg_size
,
2146 "Bad character in index");
2150 if ((c
== ',' || c
== ')') && indx
== 0
2151 && dtp
->u
.p
.saved_string
== 0)
2154 snprintf (parse_err_msg
, parse_err_msg_size
,
2155 "Null substring qualifier");
2157 snprintf (parse_err_msg
, parse_err_msg_size
,
2158 "Null index field");
2162 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2163 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2166 snprintf (parse_err_msg
, parse_err_msg_size
,
2167 "Bad substring qualifier");
2169 snprintf (parse_err_msg
, parse_err_msg_size
,
2170 "Bad index triplet");
2174 if (is_char
&& !is_array_section
)
2176 snprintf (parse_err_msg
, parse_err_msg_size
,
2177 "Missing colon in substring qualifier");
2181 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2183 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2184 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2190 /* Now read the index. */
2191 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2194 snprintf (parse_err_msg
, parse_err_msg_size
,
2195 "Bad integer substring qualifier");
2197 snprintf (parse_err_msg
, parse_err_msg_size
,
2198 "Bad integer in index");
2204 /* Feed the index values to the triplet arrays. */
2208 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2210 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2212 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2215 /* Singlet or doublet indices. */
2216 if (c
==',' || c
==')')
2220 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2222 /* If -std=f95/2003 or an array section is specified,
2223 do not allow excess data to be processed. */
2224 if (is_array_section
== 1
2225 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2226 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2227 ls
[dim
].end
= ls
[dim
].start
;
2229 dtp
->u
.p
.expanded_read
= 1;
2232 /* Check for non-zero rank. */
2233 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2240 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2243 dtp
->u
.p
.expanded_read
= 0;
2244 for (i
= 0; i
< dim
; i
++)
2245 ls
[i
].end
= ls
[i
].start
;
2248 /* Check the values of the triplet indices. */
2249 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2250 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2251 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2252 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2255 snprintf (parse_err_msg
, parse_err_msg_size
,
2256 "Substring out of range");
2258 snprintf (parse_err_msg
, parse_err_msg_size
,
2259 "Index %d out of range", dim
+ 1);
2263 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2264 || (ls
[dim
].step
== 0))
2266 snprintf (parse_err_msg
, parse_err_msg_size
,
2267 "Bad range in index %d", dim
+ 1);
2271 /* Initialise the loop index counter. */
2272 ls
[dim
].idx
= ls
[dim
].start
;
2282 static namelist_info
*
2283 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2285 namelist_info
* t
= dtp
->u
.p
.ionml
;
2288 if (strcmp (var_name
, t
->var_name
) == 0)
2298 /* Visits all the components of a derived type that have
2299 not explicitly been identified in the namelist input.
2300 touched is set and the loop specification initialised
2301 to default values */
2304 nml_touch_nodes (namelist_info
* nl
)
2306 index_type len
= strlen (nl
->var_name
) + 1;
2308 char * ext_name
= (char*)xmalloc (len
+ 1);
2309 memcpy (ext_name
, nl
->var_name
, len
-1);
2310 memcpy (ext_name
+ len
- 1, "%", 2);
2311 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2313 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2316 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2318 nl
->ls
[dim
].step
= 1;
2319 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2320 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2321 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2331 /* Resets touched for the entire list of nml_nodes, ready for a
2335 nml_untouch_nodes (st_parameter_dt
*dtp
)
2338 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2343 /* Attempts to input name to namelist name. Returns
2344 dtp->u.p.nml_read_error = 1 on no match. */
2347 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2352 dtp
->u
.p
.nml_read_error
= 0;
2353 for (i
= 0; i
< len
; i
++)
2355 c
= next_char (dtp
);
2356 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2358 dtp
->u
.p
.nml_read_error
= 1;
2364 /* If the namelist read is from stdin, output the current state of the
2365 namelist to stdout. This is used to implement the non-standard query
2366 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2367 the names alone are printed. */
2370 nml_query (st_parameter_dt
*dtp
, char c
)
2372 gfc_unit
* temp_unit
;
2377 static const index_type endlen
= 3;
2378 static const char endl
[] = "\r\n";
2379 static const char nmlend
[] = "&end\r\n";
2381 static const index_type endlen
= 2;
2382 static const char endl
[] = "\n";
2383 static const char nmlend
[] = "&end\n";
2386 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2389 /* Store the current unit and transfer to stdout. */
2391 temp_unit
= dtp
->u
.p
.current_unit
;
2392 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2394 if (dtp
->u
.p
.current_unit
)
2396 dtp
->u
.p
.mode
= WRITING
;
2397 next_record (dtp
, 0);
2399 /* Write the namelist in its entirety. */
2402 namelist_write (dtp
);
2404 /* Or write the list of names. */
2408 /* "&namelist_name\n" */
2410 len
= dtp
->namelist_name_len
;
2411 p
= write_block (dtp
, len
+ endlen
);
2415 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2416 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2417 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2421 len
= strlen (nl
->var_name
);
2422 p
= write_block (dtp
, len
+ endlen
);
2426 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2427 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2432 p
= write_block (dtp
, endlen
+ 3);
2434 memcpy (p
, &nmlend
, endlen
+ 3);
2437 /* Flush the stream to force immediate output. */
2439 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2440 sflush (dtp
->u
.p
.current_unit
->s
);
2441 unlock_unit (dtp
->u
.p
.current_unit
);
2446 /* Restore the current unit. */
2448 dtp
->u
.p
.current_unit
= temp_unit
;
2449 dtp
->u
.p
.mode
= READING
;
2453 /* Reads and stores the input for the namelist object nl. For an array,
2454 the function loops over the ranges defined by the loop specification.
2455 This default to all the data or to the specification from a qualifier.
2456 nml_read_obj recursively calls itself to read derived types. It visits
2457 all its own components but only reads data for those that were touched
2458 when the name was parsed. If a read error is encountered, an attempt is
2459 made to return to read a new object name because the standard allows too
2460 little data to be available. On the other hand, too much data is an
2464 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2465 namelist_info
**pprev_nl
, char *nml_err_msg
,
2466 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2468 namelist_info
* cmp
;
2475 size_t obj_name_len
;
2478 /* This object not touched in name parsing. */
2483 dtp
->u
.p
.repeat_count
= 0;
2495 dlen
= size_from_real_kind (len
);
2499 dlen
= size_from_complex_kind (len
);
2503 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2512 /* Update the pointer to the data, using the current index vector */
2514 pdata
= (void*)(nl
->mem_pos
+ offset
);
2515 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2516 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2517 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2518 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2520 /* Reset the error flag and try to read next value, if
2521 dtp->u.p.repeat_count=0 */
2523 dtp
->u
.p
.nml_read_error
= 0;
2525 if (--dtp
->u
.p
.repeat_count
<= 0)
2527 if (dtp
->u
.p
.input_complete
)
2529 if (dtp
->u
.p
.at_eol
)
2530 finish_separator (dtp
);
2531 if (dtp
->u
.p
.input_complete
)
2534 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2540 read_integer (dtp
, len
);
2544 read_logical (dtp
, len
);
2548 read_character (dtp
, len
);
2552 /* Need to copy data back from the real location to the temp in order
2553 to handle nml reads into arrays. */
2554 read_real (dtp
, pdata
, len
);
2555 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2559 /* Same as for REAL, copy back to temp. */
2560 read_complex (dtp
, pdata
, len
, dlen
);
2561 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2565 obj_name_len
= strlen (nl
->var_name
) + 1;
2566 obj_name
= xmalloc (obj_name_len
+1);
2567 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2568 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2570 /* If reading a derived type, disable the expanded read warning
2571 since a single object can have multiple reads. */
2572 dtp
->u
.p
.expanded_read
= 0;
2574 /* Now loop over the components. Update the component pointer
2575 with the return value from nml_write_obj. This loop jumps
2576 past nested derived types by testing if the potential
2577 component name contains '%'. */
2579 for (cmp
= nl
->next
;
2581 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2582 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2586 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2587 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2588 clow
, chigh
) == FAILURE
)
2594 if (dtp
->u
.p
.input_complete
)
2605 snprintf (nml_err_msg
, nml_err_msg_size
,
2606 "Bad type for namelist object %s", nl
->var_name
);
2607 internal_error (&dtp
->common
, nml_err_msg
);
2612 /* The standard permits array data to stop short of the number of
2613 elements specified in the loop specification. In this case, we
2614 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2615 nml_get_obj_data and an attempt is made to read object name. */
2618 if (dtp
->u
.p
.nml_read_error
)
2620 dtp
->u
.p
.expanded_read
= 0;
2624 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2626 dtp
->u
.p
.expanded_read
= 0;
2630 switch (dtp
->u
.p
.saved_type
)
2637 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2641 if (dlen
< dtp
->u
.p
.saved_used
)
2643 if (compile_options
.bounds_check
)
2645 snprintf (nml_err_msg
, nml_err_msg_size
,
2646 "Namelist object '%s' truncated on read.",
2648 generate_warning (&dtp
->common
, nml_err_msg
);
2653 m
= dtp
->u
.p
.saved_used
;
2654 pdata
= (void*)( pdata
+ clow
- 1 );
2655 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2657 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2664 /* Warn if a non-standard expanded read occurs. A single read of a
2665 single object is acceptable. If a second read occurs, issue a warning
2666 and set the flag to zero to prevent further warnings. */
2667 if (dtp
->u
.p
.expanded_read
== 2)
2669 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2670 dtp
->u
.p
.expanded_read
= 0;
2673 /* If the expanded read warning flag is set, increment it,
2674 indicating that a single read has occurred. */
2675 if (dtp
->u
.p
.expanded_read
>= 1)
2676 dtp
->u
.p
.expanded_read
++;
2678 /* Break out of loop if scalar. */
2682 /* Now increment the index vector. */
2687 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2689 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2691 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2693 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2695 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2699 } while (!nml_carry
);
2701 if (dtp
->u
.p
.repeat_count
> 1)
2703 snprintf (nml_err_msg
, nml_err_msg_size
,
2704 "Repeat count too large for namelist object %s", nl
->var_name
);
2714 /* Parses the object name, including array and substring qualifiers. It
2715 iterates over derived type components, touching those components and
2716 setting their loop specifications, if there is a qualifier. If the
2717 object is itself a derived type, its components and subcomponents are
2718 touched. nml_read_obj is called at the end and this reads the data in
2719 the manner specified by the object name. */
2722 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2723 char *nml_err_msg
, size_t nml_err_msg_size
)
2727 namelist_info
* first_nl
= NULL
;
2728 namelist_info
* root_nl
= NULL
;
2729 int dim
, parsed_rank
;
2730 int component_flag
, qualifier_flag
;
2731 index_type clow
, chigh
;
2732 int non_zero_rank_count
;
2734 /* Look for end of input or object name. If '?' or '=?' are encountered
2735 in stdin, print the node names or the namelist to stdout. */
2737 eat_separator (dtp
);
2738 if (dtp
->u
.p
.input_complete
)
2741 if (dtp
->u
.p
.at_eol
)
2742 finish_separator (dtp
);
2743 if (dtp
->u
.p
.input_complete
)
2746 if ((c
= next_char (dtp
)) == EOF
)
2751 if ((c
= next_char (dtp
)) == EOF
)
2755 snprintf (nml_err_msg
, nml_err_msg_size
,
2756 "namelist read: misplaced = sign");
2759 nml_query (dtp
, '=');
2763 nml_query (dtp
, '?');
2768 nml_match_name (dtp
, "end", 3);
2769 if (dtp
->u
.p
.nml_read_error
)
2771 snprintf (nml_err_msg
, nml_err_msg_size
,
2772 "namelist not terminated with / or &end");
2776 dtp
->u
.p
.input_complete
= 1;
2783 /* Untouch all nodes of the namelist and reset the flags that are set for
2784 derived type components. */
2786 nml_untouch_nodes (dtp
);
2789 non_zero_rank_count
= 0;
2791 /* Get the object name - should '!' and '\n' be permitted separators? */
2799 if (!is_separator (c
))
2800 push_char (dtp
, tolower(c
));
2801 if ((c
= next_char (dtp
)) == EOF
)
2803 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2805 unget_char (dtp
, c
);
2807 /* Check that the name is in the namelist and get pointer to object.
2808 Three error conditions exist: (i) An attempt is being made to
2809 identify a non-existent object, following a failed data read or
2810 (ii) The object name does not exist or (iii) Too many data items
2811 are present for an object. (iii) gives the same error message
2814 push_char (dtp
, '\0');
2818 size_t var_len
= strlen (root_nl
->var_name
);
2820 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2821 char ext_name
[var_len
+ saved_len
+ 1];
2823 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2824 if (dtp
->u
.p
.saved_string
)
2825 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2826 ext_name
[var_len
+ saved_len
] = '\0';
2827 nl
= find_nml_node (dtp
, ext_name
);
2830 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2834 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2835 snprintf (nml_err_msg
, nml_err_msg_size
,
2836 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2839 snprintf (nml_err_msg
, nml_err_msg_size
,
2840 "Cannot match namelist object name %s",
2841 dtp
->u
.p
.saved_string
);
2846 /* Get the length, data length, base pointer and rank of the variable.
2847 Set the default loop specification first. */
2849 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2851 nl
->ls
[dim
].step
= 1;
2852 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2853 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2854 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2857 /* Check to see if there is a qualifier: if so, parse it.*/
2859 if (c
== '(' && nl
->var_rank
)
2862 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2863 nml_err_msg
, nml_err_msg_size
,
2864 &parsed_rank
) == FAILURE
)
2866 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2867 snprintf (nml_err_msg_end
,
2868 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2869 " for namelist variable %s", nl
->var_name
);
2872 if (parsed_rank
> 0)
2873 non_zero_rank_count
++;
2877 if ((c
= next_char (dtp
)) == EOF
)
2879 unget_char (dtp
, c
);
2881 else if (nl
->var_rank
> 0)
2882 non_zero_rank_count
++;
2884 /* Now parse a derived type component. The root namelist_info address
2885 is backed up, as is the previous component level. The component flag
2886 is set and the iteration is made by jumping back to get_name. */
2890 if (nl
->type
!= BT_DERIVED
)
2892 snprintf (nml_err_msg
, nml_err_msg_size
,
2893 "Attempt to get derived component for %s", nl
->var_name
);
2897 if (*pprev_nl
== NULL
|| !component_flag
)
2903 if ((c
= next_char (dtp
)) == EOF
)
2908 /* Parse a character qualifier, if present. chigh = 0 is a default
2909 that signals that the string length = string_length. */
2914 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2916 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2917 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2919 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
,
2920 nml_err_msg_size
, &parsed_rank
)
2923 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2924 snprintf (nml_err_msg_end
,
2925 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2926 " for namelist variable %s", nl
->var_name
);
2930 clow
= ind
[0].start
;
2933 if (ind
[0].step
!= 1)
2935 snprintf (nml_err_msg
, nml_err_msg_size
,
2936 "Step not allowed in substring qualifier"
2937 " for namelist object %s", nl
->var_name
);
2941 if ((c
= next_char (dtp
)) == EOF
)
2943 unget_char (dtp
, c
);
2946 /* Make sure no extraneous qualifiers are there. */
2950 snprintf (nml_err_msg
, nml_err_msg_size
,
2951 "Qualifier for a scalar or non-character namelist object %s",
2956 /* Make sure there is no more than one non-zero rank object. */
2957 if (non_zero_rank_count
> 1)
2959 snprintf (nml_err_msg
, nml_err_msg_size
,
2960 "Multiple sub-objects with non-zero rank in namelist object %s",
2962 non_zero_rank_count
= 0;
2966 /* According to the standard, an equal sign MUST follow an object name. The
2967 following is possibly lax - it allows comments, blank lines and so on to
2968 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2972 eat_separator (dtp
);
2973 if (dtp
->u
.p
.input_complete
)
2976 if (dtp
->u
.p
.at_eol
)
2977 finish_separator (dtp
);
2978 if (dtp
->u
.p
.input_complete
)
2981 if ((c
= next_char (dtp
)) == EOF
)
2986 snprintf (nml_err_msg
, nml_err_msg_size
,
2987 "Equal sign must follow namelist object name %s",
2991 /* If a derived type, touch its components and restore the root
2992 namelist_info if we have parsed a qualified derived type
2995 if (nl
->type
== BT_DERIVED
)
2996 nml_touch_nodes (nl
);
3000 if (first_nl
->var_rank
== 0)
3002 if (component_flag
&& qualifier_flag
)
3009 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3010 clow
, chigh
) == FAILURE
)
3020 /* Entry point for namelist input. Goes through input until namelist name
3021 is matched. Then cycles through nml_get_obj_data until the input is
3022 completed or there is an error. */
3025 namelist_read (st_parameter_dt
*dtp
)
3028 char nml_err_msg
[200];
3030 /* Initialize the error string buffer just in case we get an unexpected fail
3031 somewhere and end up at nml_err_ret. */
3032 strcpy (nml_err_msg
, "Internal namelist read error");
3034 /* Pointer to the previously read object, in case attempt is made to read
3035 new object name. Should this fail, error message can give previous
3037 namelist_info
*prev_nl
= NULL
;
3039 dtp
->u
.p
.namelist_mode
= 1;
3040 dtp
->u
.p
.input_complete
= 0;
3041 dtp
->u
.p
.expanded_read
= 0;
3043 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3044 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3045 node names or namelist on stdout. */
3048 c
= next_char (dtp
);
3060 c
= next_char (dtp
);
3062 nml_query (dtp
, '=');
3064 unget_char (dtp
, c
);
3068 nml_query (dtp
, '?');
3077 /* Match the name of the namelist. */
3079 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3081 if (dtp
->u
.p
.nml_read_error
)
3084 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3085 c
= next_char (dtp
);
3086 if (!is_separator(c
) && c
!= '!')
3088 unget_char (dtp
, c
);
3092 unget_char (dtp
, c
);
3093 eat_separator (dtp
);
3095 /* Ready to read namelist objects. If there is an error in input
3096 from stdin, output the error message and continue. */
3098 while (!dtp
->u
.p
.input_complete
)
3100 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3103 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3105 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3108 /* Reset the previous namelist pointer if we know we are not going
3109 to be doing multiple reads within a single namelist object. */
3110 if (prev_nl
&& prev_nl
->var_rank
== 0)
3121 /* All namelist error calls return from here */
3124 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);