1 /* Copyright (C) 2002-2013 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
36 /* List directed input. Several parsing subroutines are practically
37 reimplemented from formatted input, the reason being that there are
38 all kinds of small differences between formatted and list directed
42 /* Subroutines for reading characters from the input. Because a
43 repeat count is ambiguous with an integer, we have to read the
44 whole digit string before seeing if there is a '*' which signals
45 the repeat count. Since we can have a lot of potential leading
46 zeros, we have to be able to back up by arbitrary amount. Because
47 the input might not be seekable, we have to buffer the data
50 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
51 case '5': case '6': case '7': case '8': case '9'
53 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
56 /* This macro assumes that we're operating on a variable. */
58 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
59 || c == '\t' || c == '\r' || c == ';')
61 /* Maximum repeat count. Less than ten times the maximum signed int32. */
63 #define MAX_REPEAT 200000000
68 /* Save a character to a string buffer, enlarging it as necessary. */
71 push_char (st_parameter_dt
*dtp
, char c
)
75 if (dtp
->u
.p
.saved_string
== NULL
)
77 // Plain malloc should suffice here, zeroing not needed?
78 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
79 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
80 dtp
->u
.p
.saved_used
= 0;
83 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
85 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
86 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
88 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
89 dtp
->u
.p
.saved_string
= new;
91 // Also this should not be necessary.
92 memset (new + dtp
->u
.p
.saved_used
, 0,
93 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
97 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
101 /* Free the input buffer if necessary. */
104 free_saved (st_parameter_dt
*dtp
)
106 if (dtp
->u
.p
.saved_string
== NULL
)
109 free (dtp
->u
.p
.saved_string
);
111 dtp
->u
.p
.saved_string
= NULL
;
112 dtp
->u
.p
.saved_used
= 0;
116 /* Free the line buffer if necessary. */
119 free_line (st_parameter_dt
*dtp
)
121 dtp
->u
.p
.item_count
= 0;
122 dtp
->u
.p
.line_buffer_enabled
= 0;
124 if (dtp
->u
.p
.line_buffer
== NULL
)
127 free (dtp
->u
.p
.line_buffer
);
128 dtp
->u
.p
.line_buffer
= NULL
;
133 next_char (st_parameter_dt
*dtp
)
139 if (dtp
->u
.p
.last_char
!= EOF
- 1)
142 c
= dtp
->u
.p
.last_char
;
143 dtp
->u
.p
.last_char
= EOF
- 1;
147 /* Read from line_buffer if enabled. */
149 if (dtp
->u
.p
.line_buffer_enabled
)
153 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
154 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
156 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
157 dtp
->u
.p
.item_count
++;
161 dtp
->u
.p
.item_count
= 0;
162 dtp
->u
.p
.line_buffer_enabled
= 0;
165 /* Handle the end-of-record and end-of-file conditions for
166 internal array unit. */
167 if (is_array_io (dtp
))
172 /* Check for "end-of-record" condition. */
173 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
178 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
181 /* Check for "end-of-file" condition. */
188 record
*= dtp
->u
.p
.current_unit
->recl
;
189 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
192 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
197 /* Get the next character and handle end-of-record conditions. */
199 if (is_internal_unit (dtp
))
201 /* Check for kind=4 internal unit. */
202 if (dtp
->common
.unit
)
203 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, sizeof (gfc_char4_t
));
207 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
213 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
217 if (is_array_io (dtp
))
219 /* Check whether we hit EOF. */
222 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
225 dtp
->u
.p
.current_unit
->bytes_left
--;
240 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
241 if (c
!= EOF
&& is_stream_io (dtp
))
242 dtp
->u
.p
.current_unit
->strm_pos
++;
245 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt
*dtp
, int c
)
255 dtp
->u
.p
.last_char
= c
;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt
*dtp
)
269 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
276 /* This function reads characters through to the end of the current
277 line and just ignores them. Returns 0 for success and LIBERROR_END
281 eat_line (st_parameter_dt
*dtp
)
287 while (c
!= EOF
&& c
!= '\n');
294 /* Skip over a separator. Technically, we don't always eat the whole
295 separator. This is because if we've processed the last input item,
296 then a separator is unnecessary. Plus the fact that operating
297 systems usually deliver console input on a line basis.
299 The upshot is that if we see a newline as part of reading a
300 separator, we stop reading. If there are more input items, we
301 continue reading the separator with finish_separator() which takes
302 care of the fact that we may or may not have seen a comma as part
305 Returns 0 for success, and non-zero error code otherwise. */
308 eat_separator (st_parameter_dt
*dtp
)
314 dtp
->u
.p
.comma_flag
= 0;
316 if ((c
= next_char (dtp
)) == EOF
)
321 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
328 dtp
->u
.p
.comma_flag
= 1;
333 dtp
->u
.p
.input_complete
= 1;
338 if ((n
= next_char(dtp
)) == EOF
)
348 if (dtp
->u
.p
.namelist_mode
)
352 if ((c
= next_char (dtp
)) == EOF
)
356 err
= eat_line (dtp
);
362 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
368 if (dtp
->u
.p
.namelist_mode
)
369 { /* Eat a namelist comment. */
370 err
= eat_line (dtp
);
377 /* Fall Through... */
387 /* Finish processing a separator that was interrupted by a newline.
388 If we're here, then another data item is present, so we finish what
389 we started on the previous line. Return 0 on success, error code
393 finish_separator (st_parameter_dt
*dtp
)
401 if ((c
= next_char (dtp
)) == EOF
)
406 if (dtp
->u
.p
.comma_flag
)
410 if ((c
= eat_spaces (dtp
)) == EOF
)
412 if (c
== '\n' || c
== '\r')
419 dtp
->u
.p
.input_complete
= 1;
420 if (!dtp
->u
.p
.namelist_mode
)
429 if (dtp
->u
.p
.namelist_mode
)
431 err
= eat_line (dtp
);
445 /* This function is needed to catch bad conversions so that namelist can
446 attempt to see if dtp->u.p.saved_string contains a new object name rather
450 nml_bad_return (st_parameter_dt
*dtp
, char c
)
452 if (dtp
->u
.p
.namelist_mode
)
454 dtp
->u
.p
.nml_read_error
= 1;
461 /* Convert an unsigned string to an integer. The length value is -1
462 if we are working on a repeat count. Returns nonzero if we have a
463 range problem. As a side effect, frees the dtp->u.p.saved_string. */
466 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
468 char c
, *buffer
, message
[MSGLEN
];
470 GFC_UINTEGER_LARGEST v
, max
, max10
;
471 GFC_INTEGER_LARGEST value
;
473 buffer
= dtp
->u
.p
.saved_string
;
480 max
= si_max (length
);
510 set_integer (dtp
->u
.p
.value
, value
, length
);
514 dtp
->u
.p
.repeat_count
= v
;
516 if (dtp
->u
.p
.repeat_count
== 0)
518 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
519 dtp
->u
.p
.item_count
);
521 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
531 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
532 dtp
->u
.p
.item_count
);
534 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
535 dtp
->u
.p
.item_count
);
538 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
544 /* Parse a repeat count for logical and complex values which cannot
545 begin with a digit. Returns nonzero if we are done, zero if we
546 should continue on. */
549 parse_repeat (st_parameter_dt
*dtp
)
551 char message
[MSGLEN
];
554 if ((c
= next_char (dtp
)) == EOF
)
578 repeat
= 10 * repeat
+ c
- '0';
580 if (repeat
> MAX_REPEAT
)
582 snprintf (message
, MSGLEN
,
583 "Repeat count overflow in item %d of list input",
584 dtp
->u
.p
.item_count
);
586 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
595 snprintf (message
, MSGLEN
,
596 "Zero repeat count in item %d of list input",
597 dtp
->u
.p
.item_count
);
599 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
611 dtp
->u
.p
.repeat_count
= repeat
;
624 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
625 dtp
->u
.p
.item_count
);
626 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
631 /* To read a logical we have to look ahead in the input stream to make sure
632 there is not an equal sign indicating a variable name. To do this we use
633 line_buffer to point to a temporary buffer, pushing characters there for
634 possible later reading. */
637 l_push_char (st_parameter_dt
*dtp
, char c
)
639 if (dtp
->u
.p
.line_buffer
== NULL
)
640 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
642 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
646 /* Read a logical character on the input. */
649 read_logical (st_parameter_dt
*dtp
, int length
)
651 char message
[MSGLEN
];
654 if (parse_repeat (dtp
))
657 c
= tolower (next_char (dtp
));
658 l_push_char (dtp
, c
);
664 l_push_char (dtp
, c
);
666 if (!is_separator(c
) && c
!= EOF
)
674 l_push_char (dtp
, c
);
676 if (!is_separator(c
) && c
!= EOF
)
683 c
= tolower (next_char (dtp
));
702 return; /* Null value. */
705 /* Save the character in case it is the beginning
706 of the next object name. */
711 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
712 dtp
->u
.p
.saved_length
= length
;
714 /* Eat trailing garbage. */
717 while (c
!= EOF
&& !is_separator (c
));
721 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
728 for(i
= 0; i
< 63; i
++)
733 /* All done if this is not a namelist read. */
734 if (!dtp
->u
.p
.namelist_mode
)
747 l_push_char (dtp
, c
);
750 dtp
->u
.p
.nml_read_error
= 1;
751 dtp
->u
.p
.line_buffer_enabled
= 1;
752 dtp
->u
.p
.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
)
955 unget_char (dtp
, c
); /* NULL value. */
965 if (dtp
->u
.p
.namelist_mode
)
975 /* Deal with a possible repeat count. */
989 goto done
; /* String was only digits! */
992 push_char (dtp
, '\0');
997 goto get_string
; /* Not a repeat count after all. */
1002 if (convert_integer (dtp
, -1, 0))
1005 /* Now get the real string. */
1007 if ((c
= next_char (dtp
)) == EOF
)
1012 unget_char (dtp
, c
); /* Repeated NULL values. */
1013 eat_separator (dtp
);
1029 if ((c
= next_char (dtp
)) == EOF
)
1041 /* See if we have a doubled quote character or the end of
1044 if ((c
= next_char (dtp
)) == EOF
)
1048 push_char (dtp
, quote
);
1052 unget_char (dtp
, c
);
1058 unget_char (dtp
, c
);
1062 if (c
!= '\n' && c
!= '\r')
1072 /* At this point, we have to have a separator, or else the string is
1075 c
= next_char (dtp
);
1077 if (is_separator (c
) || c
== '!' || c
== EOF
)
1079 unget_char (dtp
, c
);
1080 eat_separator (dtp
);
1081 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1087 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1088 dtp
->u
.p
.item_count
);
1089 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1099 /* Parse a component of a complex constant or a real number that we
1100 are sure is already there. This is a straight real number parser. */
1103 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1105 char message
[MSGLEN
];
1108 if ((c
= next_char (dtp
)) == EOF
)
1111 if (c
== '-' || c
== '+')
1114 if ((c
= next_char (dtp
)) == EOF
)
1118 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1121 if (!isdigit (c
) && c
!= '.')
1123 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1131 seen_dp
= (c
== '.') ? 1 : 0;
1135 if ((c
= next_char (dtp
)) == EOF
)
1137 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1159 push_char (dtp
, 'e');
1164 push_char (dtp
, 'e');
1166 if ((c
= next_char (dtp
)) == EOF
)
1180 if ((c
= next_char (dtp
)) == EOF
)
1182 if (c
!= '-' && c
!= '+')
1183 push_char (dtp
, '+');
1187 c
= next_char (dtp
);
1198 if ((c
= next_char (dtp
)) == EOF
)
1208 unget_char (dtp
, c
);
1217 unget_char (dtp
, c
);
1218 push_char (dtp
, '\0');
1220 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1226 unget_char (dtp
, c
);
1227 push_char (dtp
, '\0');
1229 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1235 /* Match INF and Infinity. */
1236 if ((c
== 'i' || c
== 'I')
1237 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1238 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1240 c
= next_char (dtp
);
1241 if ((c
!= 'i' && c
!= 'I')
1242 || ((c
== 'i' || c
== 'I')
1243 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1244 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1245 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1246 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1247 && (c
= next_char (dtp
))))
1249 if (is_separator (c
) || (c
== EOF
))
1250 unget_char (dtp
, c
);
1251 push_char (dtp
, 'i');
1252 push_char (dtp
, 'n');
1253 push_char (dtp
, 'f');
1257 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1258 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1259 && (c
= next_char (dtp
)))
1261 if (is_separator (c
) || (c
== EOF
))
1262 unget_char (dtp
, c
);
1263 push_char (dtp
, 'n');
1264 push_char (dtp
, 'a');
1265 push_char (dtp
, 'n');
1267 /* Match "NAN(alphanum)". */
1270 for ( ; c
!= ')'; c
= next_char (dtp
))
1271 if (is_separator (c
))
1274 c
= next_char (dtp
);
1275 if (is_separator (c
) || (c
== EOF
))
1276 unget_char (dtp
, c
);
1283 if (nml_bad_return (dtp
, c
))
1294 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1295 dtp
->u
.p
.item_count
);
1296 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1302 /* Reading a complex number is straightforward because we can tell
1303 what it is right away. */
1306 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1308 char message
[MSGLEN
];
1311 if (parse_repeat (dtp
))
1314 c
= next_char (dtp
);
1322 unget_char (dtp
, c
);
1323 eat_separator (dtp
);
1332 c
= next_char (dtp
);
1333 if (c
== '\n' || c
== '\r')
1336 unget_char (dtp
, c
);
1338 if (parse_real (dtp
, dest
, kind
))
1343 c
= next_char (dtp
);
1344 if (c
== '\n' || c
== '\r')
1347 unget_char (dtp
, c
);
1350 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1355 c
= next_char (dtp
);
1356 if (c
== '\n' || c
== '\r')
1359 unget_char (dtp
, c
);
1361 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1366 c
= next_char (dtp
);
1367 if (c
== '\n' || c
== '\r')
1370 unget_char (dtp
, c
);
1372 if (next_char (dtp
) != ')')
1375 c
= next_char (dtp
);
1376 if (!is_separator (c
) && (c
!= EOF
))
1379 unget_char (dtp
, c
);
1380 eat_separator (dtp
);
1383 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1388 if (nml_bad_return (dtp
, c
))
1399 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1400 dtp
->u
.p
.item_count
);
1401 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1405 /* Parse a real number with a possible repeat count. */
1408 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1410 char message
[MSGLEN
];
1417 c
= next_char (dtp
);
1418 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1436 unget_char (dtp
, c
); /* Single null. */
1437 eat_separator (dtp
);
1450 /* Get the digit string that might be a repeat count. */
1454 c
= next_char (dtp
);
1455 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1481 push_char (dtp
, 'e');
1483 c
= next_char (dtp
);
1487 push_char (dtp
, '\0');
1492 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1493 unget_char (dtp
, c
);
1502 if (convert_integer (dtp
, -1, 0))
1505 /* Now get the number itself. */
1507 if ((c
= next_char (dtp
)) == EOF
)
1509 if (is_separator (c
))
1510 { /* Repeated null value. */
1511 unget_char (dtp
, c
);
1512 eat_separator (dtp
);
1516 if (c
!= '-' && c
!= '+')
1517 push_char (dtp
, '+');
1522 if ((c
= next_char (dtp
)) == EOF
)
1526 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1529 if (!isdigit (c
) && c
!= '.')
1531 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1550 c
= next_char (dtp
);
1551 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1581 push_char (dtp
, 'e');
1583 c
= next_char (dtp
);
1592 push_char (dtp
, 'e');
1594 if ((c
= next_char (dtp
)) == EOF
)
1596 if (c
!= '+' && c
!= '-')
1597 push_char (dtp
, '+');
1601 c
= next_char (dtp
);
1611 c
= next_char (dtp
);
1629 unget_char (dtp
, c
);
1630 eat_separator (dtp
);
1631 push_char (dtp
, '\0');
1632 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1636 dtp
->u
.p
.saved_type
= BT_REAL
;
1640 l_push_char (dtp
, c
);
1643 /* Match INF and Infinity. */
1644 if (c
== 'i' || c
== 'I')
1646 c
= next_char (dtp
);
1647 l_push_char (dtp
, c
);
1648 if (c
!= 'n' && c
!= 'N')
1650 c
= next_char (dtp
);
1651 l_push_char (dtp
, c
);
1652 if (c
!= 'f' && c
!= 'F')
1654 c
= next_char (dtp
);
1655 l_push_char (dtp
, c
);
1656 if (!is_separator (c
) && (c
!= EOF
))
1658 if (c
!= 'i' && c
!= 'I')
1660 c
= next_char (dtp
);
1661 l_push_char (dtp
, c
);
1662 if (c
!= 'n' && c
!= 'N')
1664 c
= next_char (dtp
);
1665 l_push_char (dtp
, c
);
1666 if (c
!= 'i' && c
!= 'I')
1668 c
= next_char (dtp
);
1669 l_push_char (dtp
, c
);
1670 if (c
!= 't' && c
!= 'T')
1672 c
= next_char (dtp
);
1673 l_push_char (dtp
, c
);
1674 if (c
!= 'y' && c
!= 'Y')
1676 c
= next_char (dtp
);
1677 l_push_char (dtp
, c
);
1683 c
= next_char (dtp
);
1684 l_push_char (dtp
, c
);
1685 if (c
!= 'a' && c
!= 'A')
1687 c
= next_char (dtp
);
1688 l_push_char (dtp
, c
);
1689 if (c
!= 'n' && c
!= 'N')
1691 c
= next_char (dtp
);
1692 l_push_char (dtp
, c
);
1694 /* Match NAN(alphanum). */
1697 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1698 if (is_separator (c
))
1701 l_push_char (dtp
, c
);
1703 l_push_char (dtp
, ')');
1704 c
= next_char (dtp
);
1705 l_push_char (dtp
, c
);
1709 if (!is_separator (c
) && (c
!= EOF
))
1712 if (dtp
->u
.p
.namelist_mode
)
1714 if (c
== ' ' || c
=='\n' || c
== '\r')
1718 if ((c
= next_char (dtp
)) == EOF
)
1721 while (c
== ' ' || c
=='\n' || c
== '\r');
1723 l_push_char (dtp
, c
);
1732 push_char (dtp
, 'i');
1733 push_char (dtp
, 'n');
1734 push_char (dtp
, 'f');
1738 push_char (dtp
, 'n');
1739 push_char (dtp
, 'a');
1740 push_char (dtp
, 'n');
1744 unget_char (dtp
, c
);
1745 eat_separator (dtp
);
1746 push_char (dtp
, '\0');
1747 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1751 dtp
->u
.p
.saved_type
= BT_REAL
;
1755 if (dtp
->u
.p
.namelist_mode
)
1757 dtp
->u
.p
.nml_read_error
= 1;
1758 dtp
->u
.p
.line_buffer_enabled
= 1;
1759 dtp
->u
.p
.item_count
= 0;
1765 if (nml_bad_return (dtp
, c
))
1777 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1778 dtp
->u
.p
.item_count
);
1779 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1783 /* Check the current type against the saved type to make sure they are
1784 compatible. Returns nonzero if incompatible. */
1787 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1789 char message
[MSGLEN
];
1791 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1793 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1794 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1795 dtp
->u
.p
.item_count
);
1797 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1801 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1804 if (dtp
->u
.p
.saved_length
!= len
)
1806 snprintf (message
, MSGLEN
,
1807 "Read kind %d %s where kind %d is required for item %d",
1808 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1809 dtp
->u
.p
.item_count
);
1810 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1818 /* Top level data transfer subroutine for list reads. Because we have
1819 to deal with repeat counts, the data item is always saved after
1820 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1821 greater than one, we copy the data item multiple times. */
1824 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1825 int kind
, size_t size
)
1831 dtp
->u
.p
.namelist_mode
= 0;
1833 if (dtp
->u
.p
.first_item
)
1835 dtp
->u
.p
.first_item
= 0;
1836 dtp
->u
.p
.input_complete
= 0;
1837 dtp
->u
.p
.repeat_count
= 1;
1838 dtp
->u
.p
.at_eol
= 0;
1840 if ((c
= eat_spaces (dtp
)) == EOF
)
1845 if (is_separator (c
))
1847 /* Found a null value. */
1848 eat_separator (dtp
);
1849 dtp
->u
.p
.repeat_count
= 0;
1851 /* eat_separator sets this flag if the separator was a comma. */
1852 if (dtp
->u
.p
.comma_flag
)
1855 /* eat_separator sets this flag if the separator was a \n or \r. */
1856 if (dtp
->u
.p
.at_eol
)
1857 finish_separator (dtp
);
1865 if (dtp
->u
.p
.repeat_count
> 0)
1867 if (check_type (dtp
, type
, kind
))
1872 if (dtp
->u
.p
.input_complete
)
1875 if (dtp
->u
.p
.at_eol
)
1876 finish_separator (dtp
);
1880 /* Trailing spaces prior to end of line. */
1881 if (dtp
->u
.p
.at_eol
)
1882 finish_separator (dtp
);
1885 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1886 dtp
->u
.p
.repeat_count
= 1;
1892 read_integer (dtp
, kind
);
1895 read_logical (dtp
, kind
);
1898 read_character (dtp
, kind
);
1901 read_real (dtp
, p
, kind
);
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 read_complex (dtp
, p
, kind
, size
);
1908 /* Copy value back to temporary if needed. */
1909 if (dtp
->u
.p
.repeat_count
> 0)
1910 memcpy (dtp
->u
.p
.value
, p
, size
);
1913 internal_error (&dtp
->common
, "Bad type for list read");
1916 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1917 dtp
->u
.p
.saved_length
= size
;
1919 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1923 switch (dtp
->u
.p
.saved_type
)
1927 if (dtp
->u
.p
.repeat_count
> 0)
1928 memcpy (p
, dtp
->u
.p
.value
, size
);
1933 memcpy (p
, dtp
->u
.p
.value
, size
);
1937 if (dtp
->u
.p
.saved_string
)
1939 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1940 ? (int) size
: dtp
->u
.p
.saved_used
;
1942 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1945 q
= (gfc_char4_t
*) p
;
1946 for (i
= 0; i
< m
; i
++)
1947 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1951 /* Just delimiters encountered, nothing to copy but SPACE. */
1957 memset (((char *) p
) + m
, ' ', size
- m
);
1960 q
= (gfc_char4_t
*) p
;
1961 for (i
= m
; i
< (int) size
; i
++)
1962 q
[i
] = (unsigned char) ' ';
1971 internal_error (&dtp
->common
, "Bad type for list read");
1974 if (--dtp
->u
.p
.repeat_count
<= 0)
1978 if (err
== LIBERROR_END
)
1985 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1986 size_t size
, size_t nelems
)
1990 size_t stride
= type
== BT_CHARACTER
?
1991 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1996 /* Big loop over all the elements. */
1997 for (elem
= 0; elem
< nelems
; elem
++)
1999 dtp
->u
.p
.item_count
++;
2000 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2008 /* Finish a list read. */
2011 finish_list_read (st_parameter_dt
*dtp
)
2017 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2019 if (dtp
->u
.p
.at_eol
)
2021 dtp
->u
.p
.at_eol
= 0;
2025 err
= eat_line (dtp
);
2026 if (err
== LIBERROR_END
)
2032 void namelist_read (st_parameter_dt *dtp)
2034 static void nml_match_name (char *name, int len)
2035 static int nml_query (st_parameter_dt *dtp)
2036 static int nml_get_obj_data (st_parameter_dt *dtp,
2037 namelist_info **prev_nl, char *, size_t)
2039 static void nml_untouch_nodes (st_parameter_dt *dtp)
2040 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2042 static int nml_parse_qualifier(descriptor_dimension * ad,
2043 array_loop_spec * ls, int rank, char *)
2044 static void nml_touch_nodes (namelist_info * nl)
2045 static int nml_read_obj (namelist_info *nl, index_type offset,
2046 namelist_info **prev_nl, char *, size_t,
2047 index_type clow, index_type chigh)
2051 /* Inputs a rank-dimensional qualifier, which can contain
2052 singlets, doublets, triplets or ':' with the standard meanings. */
2055 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2056 array_loop_spec
*ls
, int rank
, bt nml_elem_type
,
2057 char *parse_err_msg
, size_t parse_err_msg_size
,
2064 int is_array_section
, is_char
;
2068 is_array_section
= 0;
2069 dtp
->u
.p
.expanded_read
= 0;
2071 /* See if this is a character substring qualifier we are looking for. */
2078 /* The next character in the stream should be the '('. */
2080 if ((c
= next_char (dtp
)) == EOF
)
2083 /* Process the qualifier, by dimension and triplet. */
2085 for (dim
=0; dim
< rank
; dim
++ )
2087 for (indx
=0; indx
<3; indx
++)
2093 /* Process a potential sign. */
2094 if ((c
= next_char (dtp
)) == EOF
)
2106 unget_char (dtp
, c
);
2110 /* Process characters up to the next ':' , ',' or ')'. */
2113 c
= next_char (dtp
);
2120 is_array_section
= 1;
2124 if ((c
==',' && dim
== rank
-1)
2125 || (c
==')' && dim
< rank
-1))
2128 snprintf (parse_err_msg
, parse_err_msg_size
,
2129 "Bad substring qualifier");
2131 snprintf (parse_err_msg
, parse_err_msg_size
,
2132 "Bad number of index fields");
2141 case ' ': case '\t': case '\r': case '\n':
2147 snprintf (parse_err_msg
, parse_err_msg_size
,
2148 "Bad character in substring qualifier");
2150 snprintf (parse_err_msg
, parse_err_msg_size
,
2151 "Bad character in index");
2155 if ((c
== ',' || c
== ')') && indx
== 0
2156 && dtp
->u
.p
.saved_string
== 0)
2159 snprintf (parse_err_msg
, parse_err_msg_size
,
2160 "Null substring qualifier");
2162 snprintf (parse_err_msg
, parse_err_msg_size
,
2163 "Null index field");
2167 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2168 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2171 snprintf (parse_err_msg
, parse_err_msg_size
,
2172 "Bad substring qualifier");
2174 snprintf (parse_err_msg
, parse_err_msg_size
,
2175 "Bad index triplet");
2179 if (is_char
&& !is_array_section
)
2181 snprintf (parse_err_msg
, parse_err_msg_size
,
2182 "Missing colon in substring qualifier");
2186 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2188 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2189 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2195 /* Now read the index. */
2196 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2199 snprintf (parse_err_msg
, parse_err_msg_size
,
2200 "Bad integer substring qualifier");
2202 snprintf (parse_err_msg
, parse_err_msg_size
,
2203 "Bad integer in index");
2209 /* Feed the index values to the triplet arrays. */
2213 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2215 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2217 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2220 /* Singlet or doublet indices. */
2221 if (c
==',' || c
==')')
2225 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2227 /* If -std=f95/2003 or an array section is specified,
2228 do not allow excess data to be processed. */
2229 if (is_array_section
== 1
2230 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2231 || nml_elem_type
== BT_DERIVED
)
2232 ls
[dim
].end
= ls
[dim
].start
;
2234 dtp
->u
.p
.expanded_read
= 1;
2237 /* Check for non-zero rank. */
2238 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2245 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2248 dtp
->u
.p
.expanded_read
= 0;
2249 for (i
= 0; i
< dim
; i
++)
2250 ls
[i
].end
= ls
[i
].start
;
2253 /* Check the values of the triplet indices. */
2254 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2255 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2256 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2257 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2260 snprintf (parse_err_msg
, parse_err_msg_size
,
2261 "Substring out of range");
2263 snprintf (parse_err_msg
, parse_err_msg_size
,
2264 "Index %d out of range", dim
+ 1);
2268 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2269 || (ls
[dim
].step
== 0))
2271 snprintf (parse_err_msg
, parse_err_msg_size
,
2272 "Bad range in index %d", dim
+ 1);
2276 /* Initialise the loop index counter. */
2277 ls
[dim
].idx
= ls
[dim
].start
;
2284 /* The EOF error message is issued by hit_eof. Return true so that the
2285 caller does not use parse_err_msg and parse_err_msg_size to generate
2286 an unrelated error message. */
2290 dtp
->u
.p
.input_complete
= 1;
2296 static namelist_info
*
2297 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2299 namelist_info
* t
= dtp
->u
.p
.ionml
;
2302 if (strcmp (var_name
, t
->var_name
) == 0)
2312 /* Visits all the components of a derived type that have
2313 not explicitly been identified in the namelist input.
2314 touched is set and the loop specification initialised
2315 to default values */
2318 nml_touch_nodes (namelist_info
* nl
)
2320 index_type len
= strlen (nl
->var_name
) + 1;
2322 char * ext_name
= (char*)xmalloc (len
+ 1);
2323 memcpy (ext_name
, nl
->var_name
, len
-1);
2324 memcpy (ext_name
+ len
- 1, "%", 2);
2325 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2327 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2330 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2332 nl
->ls
[dim
].step
= 1;
2333 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2334 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2335 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2345 /* Resets touched for the entire list of nml_nodes, ready for a
2349 nml_untouch_nodes (st_parameter_dt
*dtp
)
2352 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2357 /* Attempts to input name to namelist name. Returns
2358 dtp->u.p.nml_read_error = 1 on no match. */
2361 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2366 dtp
->u
.p
.nml_read_error
= 0;
2367 for (i
= 0; i
< len
; i
++)
2369 c
= next_char (dtp
);
2370 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2372 dtp
->u
.p
.nml_read_error
= 1;
2378 /* If the namelist read is from stdin, output the current state of the
2379 namelist to stdout. This is used to implement the non-standard query
2380 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2381 the names alone are printed. */
2384 nml_query (st_parameter_dt
*dtp
, char c
)
2386 gfc_unit
* temp_unit
;
2391 static const index_type endlen
= 2;
2392 static const char endl
[] = "\r\n";
2393 static const char nmlend
[] = "&end\r\n";
2395 static const index_type endlen
= 1;
2396 static const char endl
[] = "\n";
2397 static const char nmlend
[] = "&end\n";
2400 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2403 /* Store the current unit and transfer to stdout. */
2405 temp_unit
= dtp
->u
.p
.current_unit
;
2406 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2408 if (dtp
->u
.p
.current_unit
)
2410 dtp
->u
.p
.mode
= WRITING
;
2411 next_record (dtp
, 0);
2413 /* Write the namelist in its entirety. */
2416 namelist_write (dtp
);
2418 /* Or write the list of names. */
2422 /* "&namelist_name\n" */
2424 len
= dtp
->namelist_name_len
;
2425 p
= write_block (dtp
, len
- 1 + endlen
);
2429 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2430 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2431 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2435 len
= strlen (nl
->var_name
);
2436 p
= write_block (dtp
, len
+ endlen
);
2440 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2441 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2446 p
= write_block (dtp
, endlen
+ 4);
2449 memcpy (p
, &nmlend
, endlen
+ 4);
2452 /* Flush the stream to force immediate output. */
2454 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2455 sflush (dtp
->u
.p
.current_unit
->s
);
2456 unlock_unit (dtp
->u
.p
.current_unit
);
2461 /* Restore the current unit. */
2463 dtp
->u
.p
.current_unit
= temp_unit
;
2464 dtp
->u
.p
.mode
= READING
;
2468 /* Reads and stores the input for the namelist object nl. For an array,
2469 the function loops over the ranges defined by the loop specification.
2470 This default to all the data or to the specification from a qualifier.
2471 nml_read_obj recursively calls itself to read derived types. It visits
2472 all its own components but only reads data for those that were touched
2473 when the name was parsed. If a read error is encountered, an attempt is
2474 made to return to read a new object name because the standard allows too
2475 little data to be available. On the other hand, too much data is an
2479 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2480 namelist_info
**pprev_nl
, char *nml_err_msg
,
2481 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2483 namelist_info
* cmp
;
2490 size_t obj_name_len
;
2493 /* If we have encountered a previous read error or this object has not been
2494 touched in name parsing, just return. */
2495 if (dtp
->u
.p
.nml_read_error
|| !nl
->touched
)
2498 dtp
->u
.p
.repeat_count
= 0;
2510 dlen
= size_from_real_kind (len
);
2514 dlen
= size_from_complex_kind (len
);
2518 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2527 /* Update the pointer to the data, using the current index vector */
2529 pdata
= (void*)(nl
->mem_pos
+ offset
);
2530 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2531 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2532 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2533 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2535 /* If we are finished with the repeat count, try to read next value. */
2538 if (--dtp
->u
.p
.repeat_count
<= 0)
2540 if (dtp
->u
.p
.input_complete
)
2542 if (dtp
->u
.p
.at_eol
)
2543 finish_separator (dtp
);
2544 if (dtp
->u
.p
.input_complete
)
2547 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2553 read_integer (dtp
, len
);
2557 read_logical (dtp
, len
);
2561 read_character (dtp
, len
);
2565 /* Need to copy data back from the real location to the temp in
2566 order to handle nml reads into arrays. */
2567 read_real (dtp
, pdata
, len
);
2568 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2572 /* Same as for REAL, copy back to temp. */
2573 read_complex (dtp
, pdata
, len
, dlen
);
2574 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2578 obj_name_len
= strlen (nl
->var_name
) + 1;
2579 obj_name
= xmalloc (obj_name_len
+1);
2580 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2581 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2583 /* If reading a derived type, disable the expanded read warning
2584 since a single object can have multiple reads. */
2585 dtp
->u
.p
.expanded_read
= 0;
2587 /* Now loop over the components. */
2589 for (cmp
= nl
->next
;
2591 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2594 /* Jump over nested derived type by testing if the potential
2595 component name contains '%'. */
2596 if (strchr (cmp
->var_name
+ obj_name_len
, '%'))
2599 if (!nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2600 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2607 if (dtp
->u
.p
.input_complete
)
2618 snprintf (nml_err_msg
, nml_err_msg_size
,
2619 "Bad type for namelist object %s", nl
->var_name
);
2620 internal_error (&dtp
->common
, nml_err_msg
);
2625 /* The standard permits array data to stop short of the number of
2626 elements specified in the loop specification. In this case, we
2627 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2628 nml_get_obj_data and an attempt is made to read object name. */
2631 if (dtp
->u
.p
.nml_read_error
)
2633 dtp
->u
.p
.expanded_read
= 0;
2637 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2639 dtp
->u
.p
.expanded_read
= 0;
2643 switch (dtp
->u
.p
.saved_type
)
2650 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2654 if (dlen
< dtp
->u
.p
.saved_used
)
2656 if (compile_options
.bounds_check
)
2658 snprintf (nml_err_msg
, nml_err_msg_size
,
2659 "Namelist object '%s' truncated on read.",
2661 generate_warning (&dtp
->common
, nml_err_msg
);
2666 m
= dtp
->u
.p
.saved_used
;
2667 pdata
= (void*)( pdata
+ clow
- 1 );
2668 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2670 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2677 /* Warn if a non-standard expanded read occurs. A single read of a
2678 single object is acceptable. If a second read occurs, issue a warning
2679 and set the flag to zero to prevent further warnings. */
2680 if (dtp
->u
.p
.expanded_read
== 2)
2682 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2683 dtp
->u
.p
.expanded_read
= 0;
2686 /* If the expanded read warning flag is set, increment it,
2687 indicating that a single read has occurred. */
2688 if (dtp
->u
.p
.expanded_read
>= 1)
2689 dtp
->u
.p
.expanded_read
++;
2691 /* Break out of loop if scalar. */
2695 /* Now increment the index vector. */
2700 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2702 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2704 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2706 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2708 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2712 } while (!nml_carry
);
2714 if (dtp
->u
.p
.repeat_count
> 1)
2716 snprintf (nml_err_msg
, nml_err_msg_size
,
2717 "Repeat count too large for namelist object %s", nl
->var_name
);
2727 /* Parses the object name, including array and substring qualifiers. It
2728 iterates over derived type components, touching those components and
2729 setting their loop specifications, if there is a qualifier. If the
2730 object is itself a derived type, its components and subcomponents are
2731 touched. nml_read_obj is called at the end and this reads the data in
2732 the manner specified by the object name. */
2735 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2736 char *nml_err_msg
, size_t nml_err_msg_size
)
2740 namelist_info
* first_nl
= NULL
;
2741 namelist_info
* root_nl
= NULL
;
2742 int dim
, parsed_rank
;
2743 int component_flag
, qualifier_flag
;
2744 index_type clow
, chigh
;
2745 int non_zero_rank_count
;
2747 /* Look for end of input or object name. If '?' or '=?' are encountered
2748 in stdin, print the node names or the namelist to stdout. */
2750 eat_separator (dtp
);
2751 if (dtp
->u
.p
.input_complete
)
2754 if (dtp
->u
.p
.at_eol
)
2755 finish_separator (dtp
);
2756 if (dtp
->u
.p
.input_complete
)
2759 if ((c
= next_char (dtp
)) == EOF
)
2764 if ((c
= next_char (dtp
)) == EOF
)
2768 snprintf (nml_err_msg
, nml_err_msg_size
,
2769 "namelist read: misplaced = sign");
2772 nml_query (dtp
, '=');
2776 nml_query (dtp
, '?');
2781 nml_match_name (dtp
, "end", 3);
2782 if (dtp
->u
.p
.nml_read_error
)
2784 snprintf (nml_err_msg
, nml_err_msg_size
,
2785 "namelist not terminated with / or &end");
2789 dtp
->u
.p
.input_complete
= 1;
2796 /* Untouch all nodes of the namelist and reset the flags that are set for
2797 derived type components. */
2799 nml_untouch_nodes (dtp
);
2802 non_zero_rank_count
= 0;
2804 /* Get the object name - should '!' and '\n' be permitted separators? */
2812 if (!is_separator (c
))
2813 push_char (dtp
, tolower(c
));
2814 if ((c
= next_char (dtp
)) == EOF
)
2817 while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2819 unget_char (dtp
, c
);
2821 /* Check that the name is in the namelist and get pointer to object.
2822 Three error conditions exist: (i) An attempt is being made to
2823 identify a non-existent object, following a failed data read or
2824 (ii) The object name does not exist or (iii) Too many data items
2825 are present for an object. (iii) gives the same error message
2828 push_char (dtp
, '\0');
2832 size_t var_len
= strlen (root_nl
->var_name
);
2834 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2835 char ext_name
[var_len
+ saved_len
+ 1];
2837 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2838 if (dtp
->u
.p
.saved_string
)
2839 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2840 ext_name
[var_len
+ saved_len
] = '\0';
2841 nl
= find_nml_node (dtp
, ext_name
);
2844 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2848 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2849 snprintf (nml_err_msg
, nml_err_msg_size
,
2850 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2853 snprintf (nml_err_msg
, nml_err_msg_size
,
2854 "Cannot match namelist object name %s",
2855 dtp
->u
.p
.saved_string
);
2860 /* Get the length, data length, base pointer and rank of the variable.
2861 Set the default loop specification first. */
2863 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2865 nl
->ls
[dim
].step
= 1;
2866 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2867 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2868 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2871 /* Check to see if there is a qualifier: if so, parse it.*/
2873 if (c
== '(' && nl
->var_rank
)
2876 if (!nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2877 nl
->type
, nml_err_msg
, nml_err_msg_size
,
2880 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2881 snprintf (nml_err_msg_end
,
2882 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2883 " for namelist variable %s", nl
->var_name
);
2886 if (parsed_rank
> 0)
2887 non_zero_rank_count
++;
2891 if ((c
= next_char (dtp
)) == EOF
)
2893 unget_char (dtp
, c
);
2895 else if (nl
->var_rank
> 0)
2896 non_zero_rank_count
++;
2898 /* Now parse a derived type component. The root namelist_info address
2899 is backed up, as is the previous component level. The component flag
2900 is set and the iteration is made by jumping back to get_name. */
2904 if (nl
->type
!= BT_DERIVED
)
2906 snprintf (nml_err_msg
, nml_err_msg_size
,
2907 "Attempt to get derived component for %s", nl
->var_name
);
2911 /* Don't move first_nl further in the list if a qualifier was found. */
2912 if ((*pprev_nl
== NULL
&& !qualifier_flag
) || !component_flag
)
2918 if ((c
= next_char (dtp
)) == EOF
)
2923 /* Parse a character qualifier, if present. chigh = 0 is a default
2924 that signals that the string length = string_length. */
2929 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2931 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2932 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2934 if (!nml_parse_qualifier (dtp
, chd
, ind
, -1, nl
->type
,
2935 nml_err_msg
, nml_err_msg_size
, &parsed_rank
))
2937 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2938 snprintf (nml_err_msg_end
,
2939 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2940 " for namelist variable %s", nl
->var_name
);
2944 clow
= ind
[0].start
;
2947 if (ind
[0].step
!= 1)
2949 snprintf (nml_err_msg
, nml_err_msg_size
,
2950 "Step not allowed in substring qualifier"
2951 " for namelist object %s", nl
->var_name
);
2955 if ((c
= next_char (dtp
)) == EOF
)
2957 unget_char (dtp
, c
);
2960 /* Make sure no extraneous qualifiers are there. */
2964 snprintf (nml_err_msg
, nml_err_msg_size
,
2965 "Qualifier for a scalar or non-character namelist object %s",
2970 /* Make sure there is no more than one non-zero rank object. */
2971 if (non_zero_rank_count
> 1)
2973 snprintf (nml_err_msg
, nml_err_msg_size
,
2974 "Multiple sub-objects with non-zero rank in namelist object %s",
2976 non_zero_rank_count
= 0;
2980 /* According to the standard, an equal sign MUST follow an object name. The
2981 following is possibly lax - it allows comments, blank lines and so on to
2982 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2986 eat_separator (dtp
);
2987 if (dtp
->u
.p
.input_complete
)
2990 if (dtp
->u
.p
.at_eol
)
2991 finish_separator (dtp
);
2992 if (dtp
->u
.p
.input_complete
)
2995 if ((c
= next_char (dtp
)) == EOF
)
3000 snprintf (nml_err_msg
, nml_err_msg_size
,
3001 "Equal sign must follow namelist object name %s",
3005 /* If a derived type, touch its components and restore the root
3006 namelist_info if we have parsed a qualified derived type
3009 if (nl
->type
== BT_DERIVED
)
3010 nml_touch_nodes (nl
);
3014 if (first_nl
->var_rank
== 0)
3016 if (component_flag
&& qualifier_flag
)
3023 dtp
->u
.p
.nml_read_error
= 0;
3024 if (!nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3032 /* The EOF error message is issued by hit_eof. Return true so that the
3033 caller does not use nml_err_msg and nml_err_msg_size to generate
3034 an unrelated error message. */
3037 dtp
->u
.p
.input_complete
= 1;
3038 unget_char (dtp
, c
);
3045 /* Entry point for namelist input. Goes through input until namelist name
3046 is matched. Then cycles through nml_get_obj_data until the input is
3047 completed or there is an error. */
3050 namelist_read (st_parameter_dt
*dtp
)
3053 char nml_err_msg
[200];
3055 /* Initialize the error string buffer just in case we get an unexpected fail
3056 somewhere and end up at nml_err_ret. */
3057 strcpy (nml_err_msg
, "Internal namelist read error");
3059 /* Pointer to the previously read object, in case attempt is made to read
3060 new object name. Should this fail, error message can give previous
3062 namelist_info
*prev_nl
= NULL
;
3064 dtp
->u
.p
.namelist_mode
= 1;
3065 dtp
->u
.p
.input_complete
= 0;
3066 dtp
->u
.p
.expanded_read
= 0;
3068 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3069 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3070 node names or namelist on stdout. */
3073 c
= next_char (dtp
);
3085 c
= next_char (dtp
);
3087 nml_query (dtp
, '=');
3089 unget_char (dtp
, c
);
3093 nml_query (dtp
, '?');
3103 /* Match the name of the namelist. */
3105 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3107 if (dtp
->u
.p
.nml_read_error
)
3110 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3111 c
= next_char (dtp
);
3112 if (!is_separator(c
) && c
!= '!')
3114 unget_char (dtp
, c
);
3118 unget_char (dtp
, c
);
3119 eat_separator (dtp
);
3121 /* Ready to read namelist objects. If there is an error in input
3122 from stdin, output the error message and continue. */
3124 while (!dtp
->u
.p
.input_complete
)
3126 if (!nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
))
3128 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3130 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3133 /* Reset the previous namelist pointer if we know we are not going
3134 to be doing multiple reads within a single namelist object. */
3135 if (prev_nl
&& prev_nl
->var_rank
== 0)
3146 /* All namelist error calls return from here */
3149 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);