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
)
1437 unget_char (dtp
, c
); /* Single null. */
1438 eat_separator (dtp
);
1451 /* Get the digit string that might be a repeat count. */
1455 c
= next_char (dtp
);
1456 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1482 push_char (dtp
, 'e');
1484 c
= next_char (dtp
);
1488 push_char (dtp
, '\0');
1493 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1494 unget_char (dtp
, c
);
1503 if (convert_integer (dtp
, -1, 0))
1506 /* Now get the number itself. */
1508 if ((c
= next_char (dtp
)) == EOF
)
1510 if (is_separator (c
))
1511 { /* Repeated null value. */
1512 unget_char (dtp
, c
);
1513 eat_separator (dtp
);
1517 if (c
!= '-' && c
!= '+')
1518 push_char (dtp
, '+');
1523 if ((c
= next_char (dtp
)) == EOF
)
1527 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1530 if (!isdigit (c
) && c
!= '.')
1532 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1551 c
= next_char (dtp
);
1552 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1582 push_char (dtp
, 'e');
1584 c
= next_char (dtp
);
1593 push_char (dtp
, 'e');
1595 if ((c
= next_char (dtp
)) == EOF
)
1597 if (c
!= '+' && c
!= '-')
1598 push_char (dtp
, '+');
1602 c
= next_char (dtp
);
1612 c
= next_char (dtp
);
1630 unget_char (dtp
, c
);
1631 eat_separator (dtp
);
1632 push_char (dtp
, '\0');
1633 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1637 dtp
->u
.p
.saved_type
= BT_REAL
;
1641 l_push_char (dtp
, c
);
1644 /* Match INF and Infinity. */
1645 if (c
== 'i' || c
== 'I')
1647 c
= next_char (dtp
);
1648 l_push_char (dtp
, c
);
1649 if (c
!= 'n' && c
!= 'N')
1651 c
= next_char (dtp
);
1652 l_push_char (dtp
, c
);
1653 if (c
!= 'f' && c
!= 'F')
1655 c
= next_char (dtp
);
1656 l_push_char (dtp
, c
);
1657 if (!is_separator (c
) && (c
!= EOF
))
1659 if (c
!= 'i' && c
!= 'I')
1661 c
= next_char (dtp
);
1662 l_push_char (dtp
, c
);
1663 if (c
!= 'n' && c
!= 'N')
1665 c
= next_char (dtp
);
1666 l_push_char (dtp
, c
);
1667 if (c
!= 'i' && c
!= 'I')
1669 c
= next_char (dtp
);
1670 l_push_char (dtp
, c
);
1671 if (c
!= 't' && c
!= 'T')
1673 c
= next_char (dtp
);
1674 l_push_char (dtp
, c
);
1675 if (c
!= 'y' && c
!= 'Y')
1677 c
= next_char (dtp
);
1678 l_push_char (dtp
, c
);
1684 c
= next_char (dtp
);
1685 l_push_char (dtp
, c
);
1686 if (c
!= 'a' && c
!= 'A')
1688 c
= next_char (dtp
);
1689 l_push_char (dtp
, c
);
1690 if (c
!= 'n' && c
!= 'N')
1692 c
= next_char (dtp
);
1693 l_push_char (dtp
, c
);
1695 /* Match NAN(alphanum). */
1698 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1699 if (is_separator (c
))
1702 l_push_char (dtp
, c
);
1704 l_push_char (dtp
, ')');
1705 c
= next_char (dtp
);
1706 l_push_char (dtp
, c
);
1710 if (!is_separator (c
) && (c
!= EOF
))
1713 if (dtp
->u
.p
.namelist_mode
)
1715 if (c
== ' ' || c
=='\n' || c
== '\r')
1719 if ((c
= next_char (dtp
)) == EOF
)
1722 while (c
== ' ' || c
=='\n' || c
== '\r');
1724 l_push_char (dtp
, c
);
1733 push_char (dtp
, 'i');
1734 push_char (dtp
, 'n');
1735 push_char (dtp
, 'f');
1739 push_char (dtp
, 'n');
1740 push_char (dtp
, 'a');
1741 push_char (dtp
, 'n');
1745 unget_char (dtp
, c
);
1746 eat_separator (dtp
);
1747 push_char (dtp
, '\0');
1748 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1752 dtp
->u
.p
.saved_type
= BT_REAL
;
1756 if (dtp
->u
.p
.namelist_mode
)
1758 dtp
->u
.p
.nml_read_error
= 1;
1759 dtp
->u
.p
.line_buffer_enabled
= 1;
1760 dtp
->u
.p
.item_count
= 0;
1766 if (nml_bad_return (dtp
, c
))
1778 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1779 dtp
->u
.p
.item_count
);
1780 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1784 /* Check the current type against the saved type to make sure they are
1785 compatible. Returns nonzero if incompatible. */
1788 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1790 char message
[MSGLEN
];
1792 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1794 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1795 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1796 dtp
->u
.p
.item_count
);
1798 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1802 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1805 if (dtp
->u
.p
.saved_length
!= len
)
1807 snprintf (message
, MSGLEN
,
1808 "Read kind %d %s where kind %d is required for item %d",
1809 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1810 dtp
->u
.p
.item_count
);
1811 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1819 /* Top level data transfer subroutine for list reads. Because we have
1820 to deal with repeat counts, the data item is always saved after
1821 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1822 greater than one, we copy the data item multiple times. */
1825 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1826 int kind
, size_t size
)
1832 dtp
->u
.p
.namelist_mode
= 0;
1834 if (dtp
->u
.p
.first_item
)
1836 dtp
->u
.p
.first_item
= 0;
1837 dtp
->u
.p
.input_complete
= 0;
1838 dtp
->u
.p
.repeat_count
= 1;
1839 dtp
->u
.p
.at_eol
= 0;
1841 if ((c
= eat_spaces (dtp
)) == EOF
)
1846 if (is_separator (c
))
1848 /* Found a null value. */
1849 eat_separator (dtp
);
1850 dtp
->u
.p
.repeat_count
= 0;
1852 /* eat_separator sets this flag if the separator was a comma. */
1853 if (dtp
->u
.p
.comma_flag
)
1856 /* eat_separator sets this flag if the separator was a \n or \r. */
1857 if (dtp
->u
.p
.at_eol
)
1858 finish_separator (dtp
);
1866 if (dtp
->u
.p
.repeat_count
> 0)
1868 if (check_type (dtp
, type
, kind
))
1873 if (dtp
->u
.p
.input_complete
)
1876 if (dtp
->u
.p
.at_eol
)
1877 finish_separator (dtp
);
1881 /* Trailing spaces prior to end of line. */
1882 if (dtp
->u
.p
.at_eol
)
1883 finish_separator (dtp
);
1886 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1887 dtp
->u
.p
.repeat_count
= 1;
1893 read_integer (dtp
, kind
);
1896 read_logical (dtp
, kind
);
1899 read_character (dtp
, kind
);
1902 read_real (dtp
, p
, kind
);
1903 /* Copy value back to temporary if needed. */
1904 if (dtp
->u
.p
.repeat_count
> 0)
1905 memcpy (dtp
->u
.p
.value
, p
, size
);
1908 read_complex (dtp
, p
, kind
, size
);
1909 /* Copy value back to temporary if needed. */
1910 if (dtp
->u
.p
.repeat_count
> 0)
1911 memcpy (dtp
->u
.p
.value
, p
, size
);
1914 internal_error (&dtp
->common
, "Bad type for list read");
1917 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1918 dtp
->u
.p
.saved_length
= size
;
1920 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1924 switch (dtp
->u
.p
.saved_type
)
1928 if (dtp
->u
.p
.repeat_count
> 0)
1929 memcpy (p
, dtp
->u
.p
.value
, size
);
1934 memcpy (p
, dtp
->u
.p
.value
, size
);
1938 if (dtp
->u
.p
.saved_string
)
1940 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1941 ? (int) size
: dtp
->u
.p
.saved_used
;
1943 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1946 q
= (gfc_char4_t
*) p
;
1947 for (i
= 0; i
< m
; i
++)
1948 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1952 /* Just delimiters encountered, nothing to copy but SPACE. */
1958 memset (((char *) p
) + m
, ' ', size
- m
);
1961 q
= (gfc_char4_t
*) p
;
1962 for (i
= m
; i
< (int) size
; i
++)
1963 q
[i
] = (unsigned char) ' ';
1972 internal_error (&dtp
->common
, "Bad type for list read");
1975 if (--dtp
->u
.p
.repeat_count
<= 0)
1979 if (err
== LIBERROR_END
)
1986 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1987 size_t size
, size_t nelems
)
1991 size_t stride
= type
== BT_CHARACTER
?
1992 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1997 /* Big loop over all the elements. */
1998 for (elem
= 0; elem
< nelems
; elem
++)
2000 dtp
->u
.p
.item_count
++;
2001 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2009 /* Finish a list read. */
2012 finish_list_read (st_parameter_dt
*dtp
)
2018 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2020 if (dtp
->u
.p
.at_eol
)
2022 dtp
->u
.p
.at_eol
= 0;
2026 err
= eat_line (dtp
);
2027 if (err
== LIBERROR_END
)
2033 void namelist_read (st_parameter_dt *dtp)
2035 static void nml_match_name (char *name, int len)
2036 static int nml_query (st_parameter_dt *dtp)
2037 static int nml_get_obj_data (st_parameter_dt *dtp,
2038 namelist_info **prev_nl, char *, size_t)
2040 static void nml_untouch_nodes (st_parameter_dt *dtp)
2041 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2043 static int nml_parse_qualifier(descriptor_dimension * ad,
2044 array_loop_spec * ls, int rank, char *)
2045 static void nml_touch_nodes (namelist_info * nl)
2046 static int nml_read_obj (namelist_info *nl, index_type offset,
2047 namelist_info **prev_nl, char *, size_t,
2048 index_type clow, index_type chigh)
2052 /* Inputs a rank-dimensional qualifier, which can contain
2053 singlets, doublets, triplets or ':' with the standard meanings. */
2056 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2057 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2058 size_t parse_err_msg_size
,
2065 int is_array_section
, is_char
;
2069 is_array_section
= 0;
2070 dtp
->u
.p
.expanded_read
= 0;
2072 /* See if this is a character substring qualifier we are looking for. */
2079 /* The next character in the stream should be the '('. */
2081 if ((c
= next_char (dtp
)) == EOF
)
2084 /* Process the qualifier, by dimension and triplet. */
2086 for (dim
=0; dim
< rank
; dim
++ )
2088 for (indx
=0; indx
<3; indx
++)
2094 /* Process a potential sign. */
2095 if ((c
= next_char (dtp
)) == EOF
)
2107 unget_char (dtp
, c
);
2111 /* Process characters up to the next ':' , ',' or ')'. */
2114 if ((c
= next_char (dtp
)) == EOF
)
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':
2143 if ((c
= next_char (dtp
) == EOF
))
2149 snprintf (parse_err_msg
, parse_err_msg_size
,
2150 "Bad character in substring qualifier");
2152 snprintf (parse_err_msg
, parse_err_msg_size
,
2153 "Bad character in index");
2157 if ((c
== ',' || c
== ')') && indx
== 0
2158 && dtp
->u
.p
.saved_string
== 0)
2161 snprintf (parse_err_msg
, parse_err_msg_size
,
2162 "Null substring qualifier");
2164 snprintf (parse_err_msg
, parse_err_msg_size
,
2165 "Null index field");
2169 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2170 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2173 snprintf (parse_err_msg
, parse_err_msg_size
,
2174 "Bad substring qualifier");
2176 snprintf (parse_err_msg
, parse_err_msg_size
,
2177 "Bad index triplet");
2181 if (is_char
&& !is_array_section
)
2183 snprintf (parse_err_msg
, parse_err_msg_size
,
2184 "Missing colon in substring qualifier");
2188 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2190 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2191 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2197 /* Now read the index. */
2198 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2201 snprintf (parse_err_msg
, parse_err_msg_size
,
2202 "Bad integer substring qualifier");
2204 snprintf (parse_err_msg
, parse_err_msg_size
,
2205 "Bad integer in index");
2211 /* Feed the index values to the triplet arrays. */
2215 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2217 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2219 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2222 /* Singlet or doublet indices. */
2223 if (c
==',' || c
==')')
2227 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2229 /* If -std=f95/2003 or an array section is specified,
2230 do not allow excess data to be processed. */
2231 if (is_array_section
== 1
2232 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2233 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2234 ls
[dim
].end
= ls
[dim
].start
;
2236 dtp
->u
.p
.expanded_read
= 1;
2239 /* Check for non-zero rank. */
2240 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2247 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2250 dtp
->u
.p
.expanded_read
= 0;
2251 for (i
= 0; i
< dim
; i
++)
2252 ls
[i
].end
= ls
[i
].start
;
2255 /* Check the values of the triplet indices. */
2256 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2257 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2258 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2259 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2262 snprintf (parse_err_msg
, parse_err_msg_size
,
2263 "Substring out of range");
2265 snprintf (parse_err_msg
, parse_err_msg_size
,
2266 "Index %d out of range", dim
+ 1);
2270 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2271 || (ls
[dim
].step
== 0))
2273 snprintf (parse_err_msg
, parse_err_msg_size
,
2274 "Bad range in index %d", dim
+ 1);
2278 /* Initialise the loop index counter. */
2279 ls
[dim
].idx
= ls
[dim
].start
;
2289 static namelist_info
*
2290 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2292 namelist_info
* t
= dtp
->u
.p
.ionml
;
2295 if (strcmp (var_name
, t
->var_name
) == 0)
2305 /* Visits all the components of a derived type that have
2306 not explicitly been identified in the namelist input.
2307 touched is set and the loop specification initialised
2308 to default values */
2311 nml_touch_nodes (namelist_info
* nl
)
2313 index_type len
= strlen (nl
->var_name
) + 1;
2315 char * ext_name
= (char*)xmalloc (len
+ 1);
2316 memcpy (ext_name
, nl
->var_name
, len
-1);
2317 memcpy (ext_name
+ len
- 1, "%", 2);
2318 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2320 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2323 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2325 nl
->ls
[dim
].step
= 1;
2326 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2327 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2328 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2338 /* Resets touched for the entire list of nml_nodes, ready for a
2342 nml_untouch_nodes (st_parameter_dt
*dtp
)
2345 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2350 /* Attempts to input name to namelist name. Returns
2351 dtp->u.p.nml_read_error = 1 on no match. */
2354 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2359 dtp
->u
.p
.nml_read_error
= 0;
2360 for (i
= 0; i
< len
; i
++)
2362 c
= next_char (dtp
);
2363 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2365 dtp
->u
.p
.nml_read_error
= 1;
2371 /* If the namelist read is from stdin, output the current state of the
2372 namelist to stdout. This is used to implement the non-standard query
2373 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2374 the names alone are printed. */
2377 nml_query (st_parameter_dt
*dtp
, char c
)
2379 gfc_unit
* temp_unit
;
2384 static const index_type endlen
= 3;
2385 static const char endl
[] = "\r\n";
2386 static const char nmlend
[] = "&end\r\n";
2388 static const index_type endlen
= 2;
2389 static const char endl
[] = "\n";
2390 static const char nmlend
[] = "&end\n";
2393 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2396 /* Store the current unit and transfer to stdout. */
2398 temp_unit
= dtp
->u
.p
.current_unit
;
2399 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2401 if (dtp
->u
.p
.current_unit
)
2403 dtp
->u
.p
.mode
= WRITING
;
2404 next_record (dtp
, 0);
2406 /* Write the namelist in its entirety. */
2409 namelist_write (dtp
);
2411 /* Or write the list of names. */
2415 /* "&namelist_name\n" */
2417 len
= dtp
->namelist_name_len
;
2418 p
= write_block (dtp
, len
+ endlen
);
2422 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2423 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2424 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2428 len
= strlen (nl
->var_name
);
2429 p
= write_block (dtp
, len
+ endlen
);
2433 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2434 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2439 p
= write_block (dtp
, endlen
+ 3);
2441 memcpy (p
, &nmlend
, endlen
+ 3);
2444 /* Flush the stream to force immediate output. */
2446 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2447 sflush (dtp
->u
.p
.current_unit
->s
);
2448 unlock_unit (dtp
->u
.p
.current_unit
);
2453 /* Restore the current unit. */
2455 dtp
->u
.p
.current_unit
= temp_unit
;
2456 dtp
->u
.p
.mode
= READING
;
2460 /* Reads and stores the input for the namelist object nl. For an array,
2461 the function loops over the ranges defined by the loop specification.
2462 This default to all the data or to the specification from a qualifier.
2463 nml_read_obj recursively calls itself to read derived types. It visits
2464 all its own components but only reads data for those that were touched
2465 when the name was parsed. If a read error is encountered, an attempt is
2466 made to return to read a new object name because the standard allows too
2467 little data to be available. On the other hand, too much data is an
2471 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2472 namelist_info
**pprev_nl
, char *nml_err_msg
,
2473 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2475 namelist_info
* cmp
;
2482 size_t obj_name_len
;
2485 /* This object not touched in name parsing. */
2490 dtp
->u
.p
.repeat_count
= 0;
2502 dlen
= size_from_real_kind (len
);
2506 dlen
= size_from_complex_kind (len
);
2510 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2519 /* Update the pointer to the data, using the current index vector */
2521 pdata
= (void*)(nl
->mem_pos
+ offset
);
2522 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2523 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2524 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2525 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2527 /* Reset the error flag and try to read next value, if
2528 dtp->u.p.repeat_count=0 */
2530 dtp
->u
.p
.nml_read_error
= 0;
2532 if (--dtp
->u
.p
.repeat_count
<= 0)
2534 if (dtp
->u
.p
.input_complete
)
2536 if (dtp
->u
.p
.at_eol
)
2537 finish_separator (dtp
);
2538 if (dtp
->u
.p
.input_complete
)
2541 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2547 read_integer (dtp
, len
);
2551 read_logical (dtp
, len
);
2555 read_character (dtp
, len
);
2559 /* Need to copy data back from the real location to the temp in order
2560 to handle nml reads into arrays. */
2561 read_real (dtp
, pdata
, len
);
2562 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2566 /* Same as for REAL, copy back to temp. */
2567 read_complex (dtp
, pdata
, len
, dlen
);
2568 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2572 obj_name_len
= strlen (nl
->var_name
) + 1;
2573 obj_name
= xmalloc (obj_name_len
+1);
2574 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2575 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2577 /* If reading a derived type, disable the expanded read warning
2578 since a single object can have multiple reads. */
2579 dtp
->u
.p
.expanded_read
= 0;
2581 /* Now loop over the components. Update the component pointer
2582 with the return value from nml_write_obj. This loop jumps
2583 past nested derived types by testing if the potential
2584 component name contains '%'. */
2586 for (cmp
= nl
->next
;
2588 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2589 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2593 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2594 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2595 clow
, chigh
) == FAILURE
)
2601 if (dtp
->u
.p
.input_complete
)
2612 snprintf (nml_err_msg
, nml_err_msg_size
,
2613 "Bad type for namelist object %s", nl
->var_name
);
2614 internal_error (&dtp
->common
, nml_err_msg
);
2619 /* The standard permits array data to stop short of the number of
2620 elements specified in the loop specification. In this case, we
2621 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2622 nml_get_obj_data and an attempt is made to read object name. */
2625 if (dtp
->u
.p
.nml_read_error
)
2627 dtp
->u
.p
.expanded_read
= 0;
2631 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2633 dtp
->u
.p
.expanded_read
= 0;
2637 switch (dtp
->u
.p
.saved_type
)
2644 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2648 if (dlen
< dtp
->u
.p
.saved_used
)
2650 if (compile_options
.bounds_check
)
2652 snprintf (nml_err_msg
, nml_err_msg_size
,
2653 "Namelist object '%s' truncated on read.",
2655 generate_warning (&dtp
->common
, nml_err_msg
);
2660 m
= dtp
->u
.p
.saved_used
;
2661 pdata
= (void*)( pdata
+ clow
- 1 );
2662 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2664 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2671 /* Warn if a non-standard expanded read occurs. A single read of a
2672 single object is acceptable. If a second read occurs, issue a warning
2673 and set the flag to zero to prevent further warnings. */
2674 if (dtp
->u
.p
.expanded_read
== 2)
2676 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2677 dtp
->u
.p
.expanded_read
= 0;
2680 /* If the expanded read warning flag is set, increment it,
2681 indicating that a single read has occurred. */
2682 if (dtp
->u
.p
.expanded_read
>= 1)
2683 dtp
->u
.p
.expanded_read
++;
2685 /* Break out of loop if scalar. */
2689 /* Now increment the index vector. */
2694 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2696 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2698 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2700 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2702 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2706 } while (!nml_carry
);
2708 if (dtp
->u
.p
.repeat_count
> 1)
2710 snprintf (nml_err_msg
, nml_err_msg_size
,
2711 "Repeat count too large for namelist object %s", nl
->var_name
);
2721 /* Parses the object name, including array and substring qualifiers. It
2722 iterates over derived type components, touching those components and
2723 setting their loop specifications, if there is a qualifier. If the
2724 object is itself a derived type, its components and subcomponents are
2725 touched. nml_read_obj is called at the end and this reads the data in
2726 the manner specified by the object name. */
2729 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2730 char *nml_err_msg
, size_t nml_err_msg_size
)
2734 namelist_info
* first_nl
= NULL
;
2735 namelist_info
* root_nl
= NULL
;
2736 int dim
, parsed_rank
;
2737 int component_flag
, qualifier_flag
;
2738 index_type clow
, chigh
;
2739 int non_zero_rank_count
;
2741 /* Look for end of input or object name. If '?' or '=?' are encountered
2742 in stdin, print the node names or the namelist to stdout. */
2744 eat_separator (dtp
);
2745 if (dtp
->u
.p
.input_complete
)
2748 if (dtp
->u
.p
.at_eol
)
2749 finish_separator (dtp
);
2750 if (dtp
->u
.p
.input_complete
)
2753 if ((c
= next_char (dtp
)) == EOF
)
2758 if ((c
= next_char (dtp
)) == EOF
)
2762 snprintf (nml_err_msg
, nml_err_msg_size
,
2763 "namelist read: misplaced = sign");
2766 nml_query (dtp
, '=');
2770 nml_query (dtp
, '?');
2775 nml_match_name (dtp
, "end", 3);
2776 if (dtp
->u
.p
.nml_read_error
)
2778 snprintf (nml_err_msg
, nml_err_msg_size
,
2779 "namelist not terminated with / or &end");
2783 dtp
->u
.p
.input_complete
= 1;
2790 /* Untouch all nodes of the namelist and reset the flags that are set for
2791 derived type components. */
2793 nml_untouch_nodes (dtp
);
2796 non_zero_rank_count
= 0;
2798 /* Get the object name - should '!' and '\n' be permitted separators? */
2806 if (!is_separator (c
))
2807 push_char (dtp
, tolower(c
));
2808 if ((c
= next_char (dtp
)) == EOF
)
2810 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2812 unget_char (dtp
, c
);
2814 /* Check that the name is in the namelist and get pointer to object.
2815 Three error conditions exist: (i) An attempt is being made to
2816 identify a non-existent object, following a failed data read or
2817 (ii) The object name does not exist or (iii) Too many data items
2818 are present for an object. (iii) gives the same error message
2821 push_char (dtp
, '\0');
2825 size_t var_len
= strlen (root_nl
->var_name
);
2827 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2828 char ext_name
[var_len
+ saved_len
+ 1];
2830 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2831 if (dtp
->u
.p
.saved_string
)
2832 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2833 ext_name
[var_len
+ saved_len
] = '\0';
2834 nl
= find_nml_node (dtp
, ext_name
);
2837 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2841 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2842 snprintf (nml_err_msg
, nml_err_msg_size
,
2843 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2846 snprintf (nml_err_msg
, nml_err_msg_size
,
2847 "Cannot match namelist object name %s",
2848 dtp
->u
.p
.saved_string
);
2853 /* Get the length, data length, base pointer and rank of the variable.
2854 Set the default loop specification first. */
2856 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2858 nl
->ls
[dim
].step
= 1;
2859 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2860 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2861 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2864 /* Check to see if there is a qualifier: if so, parse it.*/
2866 if (c
== '(' && nl
->var_rank
)
2869 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2870 nml_err_msg
, nml_err_msg_size
,
2871 &parsed_rank
) == FAILURE
)
2873 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2874 snprintf (nml_err_msg_end
,
2875 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2876 " for namelist variable %s", nl
->var_name
);
2879 if (parsed_rank
> 0)
2880 non_zero_rank_count
++;
2884 if ((c
= next_char (dtp
)) == EOF
)
2886 unget_char (dtp
, c
);
2888 else if (nl
->var_rank
> 0)
2889 non_zero_rank_count
++;
2891 /* Now parse a derived type component. The root namelist_info address
2892 is backed up, as is the previous component level. The component flag
2893 is set and the iteration is made by jumping back to get_name. */
2897 if (nl
->type
!= BT_DERIVED
)
2899 snprintf (nml_err_msg
, nml_err_msg_size
,
2900 "Attempt to get derived component for %s", nl
->var_name
);
2904 if (*pprev_nl
== NULL
|| !component_flag
)
2910 if ((c
= next_char (dtp
)) == EOF
)
2915 /* Parse a character qualifier, if present. chigh = 0 is a default
2916 that signals that the string length = string_length. */
2921 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2923 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2924 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2926 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
,
2927 nml_err_msg_size
, &parsed_rank
)
2930 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2931 snprintf (nml_err_msg_end
,
2932 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2933 " for namelist variable %s", nl
->var_name
);
2937 clow
= ind
[0].start
;
2940 if (ind
[0].step
!= 1)
2942 snprintf (nml_err_msg
, nml_err_msg_size
,
2943 "Step not allowed in substring qualifier"
2944 " for namelist object %s", nl
->var_name
);
2948 if ((c
= next_char (dtp
)) == EOF
)
2950 unget_char (dtp
, c
);
2953 /* Make sure no extraneous qualifiers are there. */
2957 snprintf (nml_err_msg
, nml_err_msg_size
,
2958 "Qualifier for a scalar or non-character namelist object %s",
2963 /* Make sure there is no more than one non-zero rank object. */
2964 if (non_zero_rank_count
> 1)
2966 snprintf (nml_err_msg
, nml_err_msg_size
,
2967 "Multiple sub-objects with non-zero rank in namelist object %s",
2969 non_zero_rank_count
= 0;
2973 /* According to the standard, an equal sign MUST follow an object name. The
2974 following is possibly lax - it allows comments, blank lines and so on to
2975 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2979 eat_separator (dtp
);
2980 if (dtp
->u
.p
.input_complete
)
2983 if (dtp
->u
.p
.at_eol
)
2984 finish_separator (dtp
);
2985 if (dtp
->u
.p
.input_complete
)
2988 if ((c
= next_char (dtp
)) == EOF
)
2993 snprintf (nml_err_msg
, nml_err_msg_size
,
2994 "Equal sign must follow namelist object name %s",
2998 /* If a derived type, touch its components and restore the root
2999 namelist_info if we have parsed a qualified derived type
3002 if (nl
->type
== BT_DERIVED
)
3003 nml_touch_nodes (nl
);
3007 if (first_nl
->var_rank
== 0)
3009 if (component_flag
&& qualifier_flag
)
3016 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3017 clow
, chigh
) == FAILURE
)
3027 /* Entry point for namelist input. Goes through input until namelist name
3028 is matched. Then cycles through nml_get_obj_data until the input is
3029 completed or there is an error. */
3032 namelist_read (st_parameter_dt
*dtp
)
3035 char nml_err_msg
[200];
3037 /* Initialize the error string buffer just in case we get an unexpected fail
3038 somewhere and end up at nml_err_ret. */
3039 strcpy (nml_err_msg
, "Internal namelist read error");
3041 /* Pointer to the previously read object, in case attempt is made to read
3042 new object name. Should this fail, error message can give previous
3044 namelist_info
*prev_nl
= NULL
;
3046 dtp
->u
.p
.namelist_mode
= 1;
3047 dtp
->u
.p
.input_complete
= 0;
3048 dtp
->u
.p
.expanded_read
= 0;
3050 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3051 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3052 node names or namelist on stdout. */
3055 c
= next_char (dtp
);
3067 c
= next_char (dtp
);
3069 nml_query (dtp
, '=');
3071 unget_char (dtp
, c
);
3075 nml_query (dtp
, '?');
3084 /* Match the name of the namelist. */
3086 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3088 if (dtp
->u
.p
.nml_read_error
)
3091 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3092 c
= next_char (dtp
);
3093 if (!is_separator(c
) && c
!= '!')
3095 unget_char (dtp
, c
);
3099 unget_char (dtp
, c
);
3100 eat_separator (dtp
);
3102 /* Ready to read namelist objects. If there is an error in input
3103 from stdin, output the error message and continue. */
3105 while (!dtp
->u
.p
.input_complete
)
3107 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3110 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3112 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3115 /* Reset the previous namelist pointer if we know we are not going
3116 to be doing multiple reads within a single namelist object. */
3117 if (prev_nl
&& prev_nl
->var_rank
== 0)
3128 /* All namelist error calls return from here */
3131 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);