1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist input contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r' || c == ';')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
68 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
71 /* Save a character to a string buffer, enlarging it as necessary. */
74 push_char (st_parameter_dt
*dtp
, char c
)
78 if (dtp
->u
.p
.saved_string
== NULL
)
80 dtp
->u
.p
.saved_string
= get_mem (SCRATCH_SIZE
);
81 // memset below should be commented out.
82 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
83 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
84 dtp
->u
.p
.saved_used
= 0;
87 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
89 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
90 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
92 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
93 dtp
->u
.p
.saved_string
= new;
95 // Also this should not be necessary.
96 memset (new + dtp
->u
.p
.saved_used
, 0,
97 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
101 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
105 /* Free the input buffer if necessary. */
108 free_saved (st_parameter_dt
*dtp
)
110 if (dtp
->u
.p
.saved_string
== NULL
)
113 free (dtp
->u
.p
.saved_string
);
115 dtp
->u
.p
.saved_string
= NULL
;
116 dtp
->u
.p
.saved_used
= 0;
120 /* Free the line buffer if necessary. */
123 free_line (st_parameter_dt
*dtp
)
125 dtp
->u
.p
.item_count
= 0;
126 dtp
->u
.p
.line_buffer_enabled
= 0;
128 if (dtp
->u
.p
.line_buffer
== NULL
)
131 free (dtp
->u
.p
.line_buffer
);
132 dtp
->u
.p
.line_buffer
= NULL
;
137 next_char (st_parameter_dt
*dtp
)
143 if (dtp
->u
.p
.last_char
!= EOF
- 1)
146 c
= dtp
->u
.p
.last_char
;
147 dtp
->u
.p
.last_char
= EOF
- 1;
151 /* Read from line_buffer if enabled. */
153 if (dtp
->u
.p
.line_buffer_enabled
)
157 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
158 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
160 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
161 dtp
->u
.p
.item_count
++;
165 dtp
->u
.p
.item_count
= 0;
166 dtp
->u
.p
.line_buffer_enabled
= 0;
169 /* Handle the end-of-record and end-of-file conditions for
170 internal array unit. */
171 if (is_array_io (dtp
))
176 /* Check for "end-of-record" condition. */
177 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
182 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
185 /* Check for "end-of-file" condition. */
192 record
*= dtp
->u
.p
.current_unit
->recl
;
193 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
196 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
201 /* Get the next character and handle end-of-record conditions. */
203 if (is_internal_unit (dtp
))
206 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
210 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
214 if (is_array_io (dtp
))
216 /* Check whether we hit EOF. */
219 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
222 dtp
->u
.p
.current_unit
->bytes_left
--;
237 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
238 if (c
!= EOF
&& is_stream_io (dtp
))
239 dtp
->u
.p
.current_unit
->strm_pos
++;
242 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
247 /* Push a character back onto the input. */
250 unget_char (st_parameter_dt
*dtp
, int c
)
252 dtp
->u
.p
.last_char
= c
;
256 /* Skip over spaces in the input. Returns the nonspace character that
257 terminated the eating and also places it back on the input. */
260 eat_spaces (st_parameter_dt
*dtp
)
266 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
273 /* This function reads characters through to the end of the current
274 line and just ignores them. Returns 0 for success and LIBERROR_END
278 eat_line (st_parameter_dt
*dtp
)
284 while (c
!= EOF
&& c
!= '\n');
291 /* Skip over a separator. Technically, we don't always eat the whole
292 separator. This is because if we've processed the last input item,
293 then a separator is unnecessary. Plus the fact that operating
294 systems usually deliver console input on a line basis.
296 The upshot is that if we see a newline as part of reading a
297 separator, we stop reading. If there are more input items, we
298 continue reading the separator with finish_separator() which takes
299 care of the fact that we may or may not have seen a comma as part
302 Returns 0 for success, and non-zero error code otherwise. */
305 eat_separator (st_parameter_dt
*dtp
)
311 dtp
->u
.p
.comma_flag
= 0;
313 if ((c
= next_char (dtp
)) == EOF
)
318 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
325 dtp
->u
.p
.comma_flag
= 1;
330 dtp
->u
.p
.input_complete
= 1;
335 if ((n
= next_char(dtp
)) == EOF
)
345 if (dtp
->u
.p
.namelist_mode
)
349 if ((c
= next_char (dtp
)) == EOF
)
353 err
= eat_line (dtp
);
356 if ((c
= next_char (dtp
)) == EOF
)
360 err
= eat_line (dtp
);
363 if ((c
= next_char (dtp
)) == EOF
)
368 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
374 if (dtp
->u
.p
.namelist_mode
)
375 { /* Eat a namelist comment. */
376 err
= eat_line (dtp
);
383 /* Fall Through... */
393 /* Finish processing a separator that was interrupted by a newline.
394 If we're here, then another data item is present, so we finish what
395 we started on the previous line. Return 0 on success, error code
399 finish_separator (st_parameter_dt
*dtp
)
407 if ((c
= next_char (dtp
)) == EOF
)
412 if (dtp
->u
.p
.comma_flag
)
416 if ((c
= eat_spaces (dtp
)) == EOF
)
418 if (c
== '\n' || c
== '\r')
425 dtp
->u
.p
.input_complete
= 1;
426 if (!dtp
->u
.p
.namelist_mode
)
435 if (dtp
->u
.p
.namelist_mode
)
437 err
= eat_line (dtp
);
451 /* This function is needed to catch bad conversions so that namelist can
452 attempt to see if dtp->u.p.saved_string contains a new object name rather
456 nml_bad_return (st_parameter_dt
*dtp
, char c
)
458 if (dtp
->u
.p
.namelist_mode
)
460 dtp
->u
.p
.nml_read_error
= 1;
467 /* Convert an unsigned string to an integer. The length value is -1
468 if we are working on a repeat count. Returns nonzero if we have a
469 range problem. As a side effect, frees the dtp->u.p.saved_string. */
472 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
474 char c
, *buffer
, message
[100];
476 GFC_INTEGER_LARGEST v
, max
, max10
;
478 buffer
= dtp
->u
.p
.saved_string
;
481 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
506 set_integer (dtp
->u
.p
.value
, v
, length
);
510 dtp
->u
.p
.repeat_count
= v
;
512 if (dtp
->u
.p
.repeat_count
== 0)
514 sprintf (message
, "Zero repeat count in item %d of list input",
515 dtp
->u
.p
.item_count
);
517 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
527 sprintf (message
, "Repeat count overflow in item %d of list input",
528 dtp
->u
.p
.item_count
);
530 sprintf (message
, "Integer overflow while reading item %d",
531 dtp
->u
.p
.item_count
);
534 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
540 /* Parse a repeat count for logical and complex values which cannot
541 begin with a digit. Returns nonzero if we are done, zero if we
542 should continue on. */
545 parse_repeat (st_parameter_dt
*dtp
)
550 if ((c
= next_char (dtp
)) == EOF
)
574 repeat
= 10 * repeat
+ c
- '0';
576 if (repeat
> MAX_REPEAT
)
579 "Repeat count overflow in item %d of list input",
580 dtp
->u
.p
.item_count
);
582 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
592 "Zero repeat count in item %d of list input",
593 dtp
->u
.p
.item_count
);
595 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
607 dtp
->u
.p
.repeat_count
= repeat
;
620 sprintf (message
, "Bad repeat count in item %d of list input",
621 dtp
->u
.p
.item_count
);
622 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
627 /* To read a logical we have to look ahead in the input stream to make sure
628 there is not an equal sign indicating a variable name. To do this we use
629 line_buffer to point to a temporary buffer, pushing characters there for
630 possible later reading. */
633 l_push_char (st_parameter_dt
*dtp
, char c
)
635 if (dtp
->u
.p
.line_buffer
== NULL
)
637 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
638 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
641 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
645 /* Read a logical character on the input. */
648 read_logical (st_parameter_dt
*dtp
, int length
)
653 if (parse_repeat (dtp
))
656 c
= tolower (next_char (dtp
));
657 l_push_char (dtp
, c
);
662 if ((c
= next_char (dtp
)) == EOF
)
664 l_push_char (dtp
, c
);
666 if (!is_separator(c
))
673 if ((c
= next_char (dtp
)) == EOF
)
675 l_push_char (dtp
, c
);
677 if (!is_separator(c
))
684 c
= tolower (next_char (dtp
));
702 return; /* Null value. */
705 /* Save the character in case it is the beginning
706 of the next object name. */
711 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
712 dtp
->u
.p
.saved_length
= length
;
714 /* Eat trailing garbage. */
717 while (c
!= EOF
&& !is_separator (c
));
721 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
728 for(i
= 0; i
< 63; i
++)
733 /* All done if this is not a namelist read. */
734 if (!dtp
->u
.p
.namelist_mode
)
747 l_push_char (dtp
, c
);
750 dtp
->u
.p
.nml_read_error
= 1;
751 dtp
->u
.p
.line_buffer_enabled
= 1;
752 dtp
->u
.p
.item_count
= 0;
762 if (nml_bad_return (dtp
, c
))
773 sprintf (message
, "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
)
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. */
850 if (convert_integer (dtp
, -1, 0))
853 /* Get the real integer. */
855 if ((c
= next_char (dtp
)) == EOF
)
869 /* Fall through... */
900 if (nml_bad_return (dtp
, c
))
911 sprintf (message
, "Bad integer for item %d in list input",
912 dtp
->u
.p
.item_count
);
913 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
921 push_char (dtp
, '\0');
922 if (convert_integer (dtp
, length
, negative
))
929 dtp
->u
.p
.saved_type
= BT_INTEGER
;
933 /* Read a character variable. */
936 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
938 char quote
, message
[100];
941 quote
= ' '; /* Space means no quote character. */
943 if ((c
= next_char (dtp
)) == EOF
)
952 unget_char (dtp
, c
); /* NULL value. */
962 if (dtp
->u
.p
.namelist_mode
)
972 /* Deal with a possible repeat count. */
976 if ((c
= next_char (dtp
)) == EOF
)
986 goto done
; /* String was only digits! */
989 push_char (dtp
, '\0');
994 goto get_string
; /* Not a repeat count after all. */
999 if (convert_integer (dtp
, -1, 0))
1002 /* Now get the real string. */
1004 if ((c
= next_char (dtp
)) == EOF
)
1009 unget_char (dtp
, c
); /* Repeated NULL values. */
1010 eat_separator (dtp
);
1026 if ((c
= next_char (dtp
)) == EOF
)
1038 /* See if we have a doubled quote character or the end of
1041 if ((c
= next_char (dtp
)) == EOF
)
1045 push_char (dtp
, quote
);
1049 unget_char (dtp
, c
);
1055 unget_char (dtp
, c
);
1059 if (c
!= '\n' && c
!= '\r')
1069 /* At this point, we have to have a separator, or else the string is
1072 c
= next_char (dtp
);
1074 if (is_separator (c
) || c
== '!')
1076 unget_char (dtp
, c
);
1077 eat_separator (dtp
);
1078 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1089 sprintf (message
, "Invalid string input in item %d",
1090 dtp
->u
.p
.item_count
);
1091 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1096 /* Parse a component of a complex constant or a real number that we
1097 are sure is already there. This is a straight real number parser. */
1100 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1105 if ((c
= next_char (dtp
)) == EOF
)
1108 if (c
== '-' || c
== '+')
1111 if ((c
= next_char (dtp
)) == EOF
)
1115 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1118 if (!isdigit (c
) && c
!= '.')
1120 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1128 seen_dp
= (c
== '.') ? 1 : 0;
1132 if ((c
= next_char (dtp
)) == EOF
)
1134 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1154 push_char (dtp
, 'e');
1159 push_char (dtp
, 'e');
1161 if ((c
= next_char (dtp
)) == EOF
)
1174 if ((c
= next_char (dtp
)) == EOF
)
1176 if (c
!= '-' && c
!= '+')
1177 push_char (dtp
, '+');
1181 c
= next_char (dtp
);
1192 if ((c
= next_char (dtp
)) == EOF
)
1201 unget_char (dtp
, c
);
1210 unget_char (dtp
, c
);
1211 push_char (dtp
, '\0');
1213 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1219 /* Match INF and Infinity. */
1220 if ((c
== 'i' || c
== 'I')
1221 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1222 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1224 c
= next_char (dtp
);
1225 if ((c
!= 'i' && c
!= 'I')
1226 || ((c
== 'i' || c
== 'I')
1227 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1228 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1229 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1230 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1231 && (c
= next_char (dtp
))))
1233 if (is_separator (c
))
1234 unget_char (dtp
, c
);
1235 push_char (dtp
, 'i');
1236 push_char (dtp
, 'n');
1237 push_char (dtp
, 'f');
1241 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1242 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1243 && (c
= next_char (dtp
)))
1245 if (is_separator (c
))
1246 unget_char (dtp
, c
);
1247 push_char (dtp
, 'n');
1248 push_char (dtp
, 'a');
1249 push_char (dtp
, 'n');
1251 /* Match "NAN(alphanum)". */
1254 for ( ; c
!= ')'; c
= next_char (dtp
))
1255 if (is_separator (c
))
1258 c
= next_char (dtp
);
1259 if (is_separator (c
))
1260 unget_char (dtp
, c
);
1267 if (nml_bad_return (dtp
, c
))
1278 sprintf (message
, "Bad floating point number for item %d",
1279 dtp
->u
.p
.item_count
);
1280 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1286 /* Reading a complex number is straightforward because we can tell
1287 what it is right away. */
1290 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1295 if (parse_repeat (dtp
))
1298 c
= next_char (dtp
);
1305 unget_char (dtp
, c
);
1306 eat_separator (dtp
);
1315 c
= next_char (dtp
);
1316 if (c
== '\n' || c
== '\r')
1319 unget_char (dtp
, c
);
1321 if (parse_real (dtp
, dest
, kind
))
1326 c
= next_char (dtp
);
1327 if (c
== '\n' || c
== '\r')
1330 unget_char (dtp
, c
);
1333 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1338 c
= next_char (dtp
);
1339 if (c
== '\n' || c
== '\r')
1342 unget_char (dtp
, c
);
1344 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1349 c
= next_char (dtp
);
1350 if (c
== '\n' || c
== '\r')
1353 unget_char (dtp
, c
);
1355 if (next_char (dtp
) != ')')
1358 c
= next_char (dtp
);
1359 if (!is_separator (c
))
1362 unget_char (dtp
, c
);
1363 eat_separator (dtp
);
1366 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1371 if (nml_bad_return (dtp
, c
))
1382 sprintf (message
, "Bad complex value in item %d of list input",
1383 dtp
->u
.p
.item_count
);
1384 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1388 /* Parse a real number with a possible repeat count. */
1391 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1400 c
= next_char (dtp
);
1401 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1419 unget_char (dtp
, c
); /* Single null. */
1420 eat_separator (dtp
);
1433 /* Get the digit string that might be a repeat count. */
1437 c
= next_char (dtp
);
1438 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1462 push_char (dtp
, 'e');
1464 c
= next_char (dtp
);
1468 push_char (dtp
, '\0');
1472 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1473 unget_char (dtp
, c
);
1482 if (convert_integer (dtp
, -1, 0))
1485 /* Now get the number itself. */
1487 if ((c
= next_char (dtp
)) == EOF
)
1489 if (is_separator (c
))
1490 { /* Repeated null value. */
1491 unget_char (dtp
, c
);
1492 eat_separator (dtp
);
1496 if (c
!= '-' && c
!= '+')
1497 push_char (dtp
, '+');
1502 if ((c
= next_char (dtp
)) == EOF
)
1506 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1509 if (!isdigit (c
) && c
!= '.')
1511 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1530 c
= next_char (dtp
);
1531 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1559 push_char (dtp
, 'e');
1561 c
= next_char (dtp
);
1570 push_char (dtp
, 'e');
1572 if ((c
= next_char (dtp
)) == EOF
)
1574 if (c
!= '+' && c
!= '-')
1575 push_char (dtp
, '+');
1579 c
= next_char (dtp
);
1589 c
= next_char (dtp
);
1606 unget_char (dtp
, c
);
1607 eat_separator (dtp
);
1608 push_char (dtp
, '\0');
1609 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1613 dtp
->u
.p
.saved_type
= BT_REAL
;
1617 l_push_char (dtp
, c
);
1620 /* Match INF and Infinity. */
1621 if (c
== 'i' || c
== 'I')
1623 c
= next_char (dtp
);
1624 l_push_char (dtp
, c
);
1625 if (c
!= 'n' && c
!= 'N')
1627 c
= next_char (dtp
);
1628 l_push_char (dtp
, c
);
1629 if (c
!= 'f' && c
!= 'F')
1631 c
= next_char (dtp
);
1632 l_push_char (dtp
, c
);
1633 if (!is_separator (c
))
1635 if (c
!= 'i' && c
!= 'I')
1637 c
= next_char (dtp
);
1638 l_push_char (dtp
, c
);
1639 if (c
!= 'n' && c
!= 'N')
1641 c
= next_char (dtp
);
1642 l_push_char (dtp
, c
);
1643 if (c
!= 'i' && c
!= 'I')
1645 c
= next_char (dtp
);
1646 l_push_char (dtp
, c
);
1647 if (c
!= 't' && c
!= 'T')
1649 c
= next_char (dtp
);
1650 l_push_char (dtp
, c
);
1651 if (c
!= 'y' && c
!= 'Y')
1653 c
= next_char (dtp
);
1654 l_push_char (dtp
, c
);
1660 c
= next_char (dtp
);
1661 l_push_char (dtp
, c
);
1662 if (c
!= 'a' && c
!= 'A')
1664 c
= next_char (dtp
);
1665 l_push_char (dtp
, c
);
1666 if (c
!= 'n' && c
!= 'N')
1668 c
= next_char (dtp
);
1669 l_push_char (dtp
, c
);
1671 /* Match NAN(alphanum). */
1674 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1675 if (is_separator (c
))
1678 l_push_char (dtp
, c
);
1680 l_push_char (dtp
, ')');
1681 c
= next_char (dtp
);
1682 l_push_char (dtp
, c
);
1686 if (!is_separator (c
))
1689 if (dtp
->u
.p
.namelist_mode
)
1691 if (c
== ' ' || c
=='\n' || c
== '\r')
1695 if ((c
= next_char (dtp
)) == EOF
)
1698 while (c
== ' ' || c
=='\n' || c
== '\r');
1700 l_push_char (dtp
, c
);
1709 push_char (dtp
, 'i');
1710 push_char (dtp
, 'n');
1711 push_char (dtp
, 'f');
1715 push_char (dtp
, 'n');
1716 push_char (dtp
, 'a');
1717 push_char (dtp
, 'n');
1724 if (dtp
->u
.p
.namelist_mode
)
1726 dtp
->u
.p
.nml_read_error
= 1;
1727 dtp
->u
.p
.line_buffer_enabled
= 1;
1728 dtp
->u
.p
.item_count
= 0;
1734 if (nml_bad_return (dtp
, c
))
1746 sprintf (message
, "Bad real number in item %d of list input",
1747 dtp
->u
.p
.item_count
);
1748 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1752 /* Check the current type against the saved type to make sure they are
1753 compatible. Returns nonzero if incompatible. */
1756 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1760 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1762 sprintf (message
, "Read type %s where %s was expected for item %d",
1763 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1764 dtp
->u
.p
.item_count
);
1766 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1770 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1773 if (dtp
->u
.p
.saved_length
!= len
)
1776 "Read kind %d %s where kind %d is required for item %d",
1777 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1778 dtp
->u
.p
.item_count
);
1779 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1787 /* Top level data transfer subroutine for list reads. Because we have
1788 to deal with repeat counts, the data item is always saved after
1789 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1790 greater than one, we copy the data item multiple times. */
1793 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1794 int kind
, size_t size
)
1800 dtp
->u
.p
.namelist_mode
= 0;
1802 if (dtp
->u
.p
.first_item
)
1804 dtp
->u
.p
.first_item
= 0;
1805 dtp
->u
.p
.input_complete
= 0;
1806 dtp
->u
.p
.repeat_count
= 1;
1807 dtp
->u
.p
.at_eol
= 0;
1809 if ((c
= eat_spaces (dtp
)) == EOF
)
1814 if (is_separator (c
))
1816 /* Found a null value. */
1817 eat_separator (dtp
);
1818 dtp
->u
.p
.repeat_count
= 0;
1820 /* eat_separator sets this flag if the separator was a comma. */
1821 if (dtp
->u
.p
.comma_flag
)
1824 /* eat_separator sets this flag if the separator was a \n or \r. */
1825 if (dtp
->u
.p
.at_eol
)
1826 finish_separator (dtp
);
1834 if (dtp
->u
.p
.repeat_count
> 0)
1836 if (check_type (dtp
, type
, kind
))
1841 if (dtp
->u
.p
.input_complete
)
1844 if (dtp
->u
.p
.at_eol
)
1845 finish_separator (dtp
);
1849 /* Trailing spaces prior to end of line. */
1850 if (dtp
->u
.p
.at_eol
)
1851 finish_separator (dtp
);
1854 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1855 dtp
->u
.p
.repeat_count
= 1;
1861 read_integer (dtp
, kind
);
1864 read_logical (dtp
, kind
);
1867 read_character (dtp
, kind
);
1870 read_real (dtp
, p
, kind
);
1871 /* Copy value back to temporary if needed. */
1872 if (dtp
->u
.p
.repeat_count
> 0)
1873 memcpy (dtp
->u
.p
.value
, p
, kind
);
1876 read_complex (dtp
, p
, kind
, size
);
1877 /* Copy value back to temporary if needed. */
1878 if (dtp
->u
.p
.repeat_count
> 0)
1879 memcpy (dtp
->u
.p
.value
, p
, size
);
1882 internal_error (&dtp
->common
, "Bad type for list read");
1885 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1886 dtp
->u
.p
.saved_length
= size
;
1888 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1892 switch (dtp
->u
.p
.saved_type
)
1896 if (dtp
->u
.p
.repeat_count
> 0)
1897 memcpy (p
, dtp
->u
.p
.value
, size
);
1902 memcpy (p
, dtp
->u
.p
.value
, size
);
1906 if (dtp
->u
.p
.saved_string
)
1908 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1909 ? (int) size
: dtp
->u
.p
.saved_used
;
1911 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1914 q
= (gfc_char4_t
*) p
;
1915 for (i
= 0; i
< m
; i
++)
1916 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1920 /* Just delimiters encountered, nothing to copy but SPACE. */
1926 memset (((char *) p
) + m
, ' ', size
- m
);
1929 q
= (gfc_char4_t
*) p
;
1930 for (i
= m
; i
< (int) size
; i
++)
1931 q
[i
] = (unsigned char) ' ';
1940 internal_error (&dtp
->common
, "Bad type for list read");
1943 if (--dtp
->u
.p
.repeat_count
<= 0)
1947 if (err
== LIBERROR_END
)
1954 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1955 size_t size
, size_t nelems
)
1959 size_t stride
= type
== BT_CHARACTER
?
1960 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1965 /* Big loop over all the elements. */
1966 for (elem
= 0; elem
< nelems
; elem
++)
1968 dtp
->u
.p
.item_count
++;
1969 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
1977 /* Finish a list read. */
1980 finish_list_read (st_parameter_dt
*dtp
)
1986 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1988 if (dtp
->u
.p
.at_eol
)
1990 dtp
->u
.p
.at_eol
= 0;
1994 err
= eat_line (dtp
);
1995 if (err
== LIBERROR_END
)
2001 void namelist_read (st_parameter_dt *dtp)
2003 static void nml_match_name (char *name, int len)
2004 static int nml_query (st_parameter_dt *dtp)
2005 static int nml_get_obj_data (st_parameter_dt *dtp,
2006 namelist_info **prev_nl, char *, size_t)
2008 static void nml_untouch_nodes (st_parameter_dt *dtp)
2009 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2011 static int nml_parse_qualifier(descriptor_dimension * ad,
2012 array_loop_spec * ls, int rank, char *)
2013 static void nml_touch_nodes (namelist_info * nl)
2014 static int nml_read_obj (namelist_info *nl, index_type offset,
2015 namelist_info **prev_nl, char *, size_t,
2016 index_type clow, index_type chigh)
2020 /* Inputs a rank-dimensional qualifier, which can contain
2021 singlets, doublets, triplets or ':' with the standard meanings. */
2024 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2025 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2032 int is_array_section
, is_char
;
2036 is_array_section
= 0;
2037 dtp
->u
.p
.expanded_read
= 0;
2039 /* See if this is a character substring qualifier we are looking for. */
2046 /* The next character in the stream should be the '('. */
2048 if ((c
= next_char (dtp
)) == EOF
)
2051 /* Process the qualifier, by dimension and triplet. */
2053 for (dim
=0; dim
< rank
; dim
++ )
2055 for (indx
=0; indx
<3; indx
++)
2061 /* Process a potential sign. */
2062 if ((c
= next_char (dtp
)) == EOF
)
2074 unget_char (dtp
, c
);
2078 /* Process characters up to the next ':' , ',' or ')'. */
2081 if ((c
= next_char (dtp
)) == EOF
)
2087 is_array_section
= 1;
2091 if ((c
==',' && dim
== rank
-1)
2092 || (c
==')' && dim
< rank
-1))
2095 sprintf (parse_err_msg
, "Bad substring qualifier");
2097 sprintf (parse_err_msg
, "Bad number of index fields");
2106 case ' ': case '\t':
2108 if ((c
= next_char (dtp
) == EOF
))
2114 sprintf (parse_err_msg
,
2115 "Bad character in substring qualifier");
2117 sprintf (parse_err_msg
, "Bad character in index");
2121 if ((c
== ',' || c
== ')') && indx
== 0
2122 && dtp
->u
.p
.saved_string
== 0)
2125 sprintf (parse_err_msg
, "Null substring qualifier");
2127 sprintf (parse_err_msg
, "Null index field");
2131 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2132 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2135 sprintf (parse_err_msg
, "Bad substring qualifier");
2137 sprintf (parse_err_msg
, "Bad index triplet");
2141 if (is_char
&& !is_array_section
)
2143 sprintf (parse_err_msg
,
2144 "Missing colon in substring qualifier");
2148 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2150 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2151 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2157 /* Now read the index. */
2158 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2161 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2163 sprintf (parse_err_msg
, "Bad integer in index");
2169 /* Feed the index values to the triplet arrays. */
2173 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2175 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2177 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2180 /* Singlet or doublet indices. */
2181 if (c
==',' || c
==')')
2185 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2187 /* If -std=f95/2003 or an array section is specified,
2188 do not allow excess data to be processed. */
2189 if (is_array_section
== 1
2190 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2191 || !dtp
->u
.p
.ionml
->touched
2192 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2193 ls
[dim
].end
= ls
[dim
].start
;
2195 dtp
->u
.p
.expanded_read
= 1;
2198 /* Check for non-zero rank. */
2199 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2206 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2209 dtp
->u
.p
.expanded_read
= 0;
2210 for (i
= 0; i
< dim
; i
++)
2211 ls
[i
].end
= ls
[i
].start
;
2214 /* Check the values of the triplet indices. */
2215 if ((ls
[dim
].start
> (ssize_t
) GFC_DIMENSION_UBOUND(ad
[dim
]))
2216 || (ls
[dim
].start
< (ssize_t
) GFC_DIMENSION_LBOUND(ad
[dim
]))
2217 || (ls
[dim
].end
> (ssize_t
) GFC_DIMENSION_UBOUND(ad
[dim
]))
2218 || (ls
[dim
].end
< (ssize_t
) GFC_DIMENSION_LBOUND(ad
[dim
])))
2221 sprintf (parse_err_msg
, "Substring out of range");
2223 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2227 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2228 || (ls
[dim
].step
== 0))
2230 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2234 /* Initialise the loop index counter. */
2235 ls
[dim
].idx
= ls
[dim
].start
;
2245 static namelist_info
*
2246 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2248 namelist_info
* t
= dtp
->u
.p
.ionml
;
2251 if (strcmp (var_name
, t
->var_name
) == 0)
2261 /* Visits all the components of a derived type that have
2262 not explicitly been identified in the namelist input.
2263 touched is set and the loop specification initialised
2264 to default values */
2267 nml_touch_nodes (namelist_info
* nl
)
2269 index_type len
= strlen (nl
->var_name
) + 1;
2271 char * ext_name
= (char*)get_mem (len
+ 1);
2272 memcpy (ext_name
, nl
->var_name
, len
-1);
2273 memcpy (ext_name
+ len
- 1, "%", 2);
2274 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2276 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2279 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2281 nl
->ls
[dim
].step
= 1;
2282 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2283 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2284 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2294 /* Resets touched for the entire list of nml_nodes, ready for a
2298 nml_untouch_nodes (st_parameter_dt
*dtp
)
2301 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2306 /* Attempts to input name to namelist name. Returns
2307 dtp->u.p.nml_read_error = 1 on no match. */
2310 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2315 dtp
->u
.p
.nml_read_error
= 0;
2316 for (i
= 0; i
< len
; i
++)
2318 c
= next_char (dtp
);
2319 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2321 dtp
->u
.p
.nml_read_error
= 1;
2327 /* If the namelist read is from stdin, output the current state of the
2328 namelist to stdout. This is used to implement the non-standard query
2329 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2330 the names alone are printed. */
2333 nml_query (st_parameter_dt
*dtp
, char c
)
2335 gfc_unit
* temp_unit
;
2340 static const index_type endlen
= 3;
2341 static const char endl
[] = "\r\n";
2342 static const char nmlend
[] = "&end\r\n";
2344 static const index_type endlen
= 2;
2345 static const char endl
[] = "\n";
2346 static const char nmlend
[] = "&end\n";
2349 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2352 /* Store the current unit and transfer to stdout. */
2354 temp_unit
= dtp
->u
.p
.current_unit
;
2355 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2357 if (dtp
->u
.p
.current_unit
)
2359 dtp
->u
.p
.mode
= WRITING
;
2360 next_record (dtp
, 0);
2362 /* Write the namelist in its entirety. */
2365 namelist_write (dtp
);
2367 /* Or write the list of names. */
2371 /* "&namelist_name\n" */
2373 len
= dtp
->namelist_name_len
;
2374 p
= write_block (dtp
, len
+ endlen
);
2378 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2379 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2380 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2384 len
= strlen (nl
->var_name
);
2385 p
= write_block (dtp
, len
+ endlen
);
2389 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2390 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2395 p
= write_block (dtp
, endlen
+ 3);
2397 memcpy (p
, &nmlend
, endlen
+ 3);
2400 /* Flush the stream to force immediate output. */
2402 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2403 sflush (dtp
->u
.p
.current_unit
->s
);
2404 unlock_unit (dtp
->u
.p
.current_unit
);
2409 /* Restore the current unit. */
2411 dtp
->u
.p
.current_unit
= temp_unit
;
2412 dtp
->u
.p
.mode
= READING
;
2416 /* Reads and stores the input for the namelist object nl. For an array,
2417 the function loops over the ranges defined by the loop specification.
2418 This default to all the data or to the specification from a qualifier.
2419 nml_read_obj recursively calls itself to read derived types. It visits
2420 all its own components but only reads data for those that were touched
2421 when the name was parsed. If a read error is encountered, an attempt is
2422 made to return to read a new object name because the standard allows too
2423 little data to be available. On the other hand, too much data is an
2427 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2428 namelist_info
**pprev_nl
, char *nml_err_msg
,
2429 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2431 namelist_info
* cmp
;
2438 size_t obj_name_len
;
2441 /* This object not touched in name parsing. */
2446 dtp
->u
.p
.repeat_count
= 0;
2458 dlen
= size_from_real_kind (len
);
2462 dlen
= size_from_complex_kind (len
);
2466 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2475 /* Update the pointer to the data, using the current index vector */
2477 pdata
= (void*)(nl
->mem_pos
+ offset
);
2478 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2479 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2480 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2481 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2483 /* Reset the error flag and try to read next value, if
2484 dtp->u.p.repeat_count=0 */
2486 dtp
->u
.p
.nml_read_error
= 0;
2488 if (--dtp
->u
.p
.repeat_count
<= 0)
2490 if (dtp
->u
.p
.input_complete
)
2492 if (dtp
->u
.p
.at_eol
)
2493 finish_separator (dtp
);
2494 if (dtp
->u
.p
.input_complete
)
2497 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2503 read_integer (dtp
, len
);
2507 read_logical (dtp
, len
);
2511 read_character (dtp
, len
);
2515 /* Need to copy data back from the real location to the temp in order
2516 to handle nml reads into arrays. */
2517 read_real (dtp
, pdata
, len
);
2518 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2522 /* Same as for REAL, copy back to temp. */
2523 read_complex (dtp
, pdata
, len
, dlen
);
2524 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2528 obj_name_len
= strlen (nl
->var_name
) + 1;
2529 obj_name
= get_mem (obj_name_len
+1);
2530 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2531 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2533 /* If reading a derived type, disable the expanded read warning
2534 since a single object can have multiple reads. */
2535 dtp
->u
.p
.expanded_read
= 0;
2537 /* Now loop over the components. Update the component pointer
2538 with the return value from nml_write_obj. This loop jumps
2539 past nested derived types by testing if the potential
2540 component name contains '%'. */
2542 for (cmp
= nl
->next
;
2544 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2545 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2549 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2550 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2551 clow
, chigh
) == FAILURE
)
2557 if (dtp
->u
.p
.input_complete
)
2568 snprintf (nml_err_msg
, nml_err_msg_size
,
2569 "Bad type for namelist object %s", nl
->var_name
);
2570 internal_error (&dtp
->common
, nml_err_msg
);
2575 /* The standard permits array data to stop short of the number of
2576 elements specified in the loop specification. In this case, we
2577 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2578 nml_get_obj_data and an attempt is made to read object name. */
2581 if (dtp
->u
.p
.nml_read_error
)
2583 dtp
->u
.p
.expanded_read
= 0;
2587 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2589 dtp
->u
.p
.expanded_read
= 0;
2593 switch (dtp
->u
.p
.saved_type
)
2600 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2604 if (dlen
< dtp
->u
.p
.saved_used
)
2606 if (compile_options
.bounds_check
)
2608 snprintf (nml_err_msg
, nml_err_msg_size
,
2609 "Namelist object '%s' truncated on read.",
2611 generate_warning (&dtp
->common
, nml_err_msg
);
2616 m
= dtp
->u
.p
.saved_used
;
2617 pdata
= (void*)( pdata
+ clow
- 1 );
2618 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2620 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2627 /* Warn if a non-standard expanded read occurs. A single read of a
2628 single object is acceptable. If a second read occurs, issue a warning
2629 and set the flag to zero to prevent further warnings. */
2630 if (dtp
->u
.p
.expanded_read
== 2)
2632 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2633 dtp
->u
.p
.expanded_read
= 0;
2636 /* If the expanded read warning flag is set, increment it,
2637 indicating that a single read has occurred. */
2638 if (dtp
->u
.p
.expanded_read
>= 1)
2639 dtp
->u
.p
.expanded_read
++;
2641 /* Break out of loop if scalar. */
2645 /* Now increment the index vector. */
2650 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2652 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2654 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2656 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2658 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2662 } while (!nml_carry
);
2664 if (dtp
->u
.p
.repeat_count
> 1)
2666 snprintf (nml_err_msg
, nml_err_msg_size
,
2667 "Repeat count too large for namelist object %s", nl
->var_name
);
2677 /* Parses the object name, including array and substring qualifiers. It
2678 iterates over derived type components, touching those components and
2679 setting their loop specifications, if there is a qualifier. If the
2680 object is itself a derived type, its components and subcomponents are
2681 touched. nml_read_obj is called at the end and this reads the data in
2682 the manner specified by the object name. */
2685 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2686 char *nml_err_msg
, size_t nml_err_msg_size
)
2690 namelist_info
* first_nl
= NULL
;
2691 namelist_info
* root_nl
= NULL
;
2692 int dim
, parsed_rank
;
2693 int component_flag
, qualifier_flag
;
2694 index_type clow
, chigh
;
2695 int non_zero_rank_count
;
2697 /* Look for end of input or object name. If '?' or '=?' are encountered
2698 in stdin, print the node names or the namelist to stdout. */
2700 eat_separator (dtp
);
2701 if (dtp
->u
.p
.input_complete
)
2704 if (dtp
->u
.p
.at_eol
)
2705 finish_separator (dtp
);
2706 if (dtp
->u
.p
.input_complete
)
2709 if ((c
= next_char (dtp
)) == EOF
)
2714 if ((c
= next_char (dtp
)) == EOF
)
2718 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2721 nml_query (dtp
, '=');
2725 nml_query (dtp
, '?');
2730 nml_match_name (dtp
, "end", 3);
2731 if (dtp
->u
.p
.nml_read_error
)
2733 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2737 dtp
->u
.p
.input_complete
= 1;
2744 /* Untouch all nodes of the namelist and reset the flags that are set for
2745 derived type components. */
2747 nml_untouch_nodes (dtp
);
2750 non_zero_rank_count
= 0;
2752 /* Get the object name - should '!' and '\n' be permitted separators? */
2760 if (!is_separator (c
))
2761 push_char (dtp
, tolower(c
));
2762 if ((c
= next_char (dtp
)) == EOF
)
2764 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2766 unget_char (dtp
, c
);
2768 /* Check that the name is in the namelist and get pointer to object.
2769 Three error conditions exist: (i) An attempt is being made to
2770 identify a non-existent object, following a failed data read or
2771 (ii) The object name does not exist or (iii) Too many data items
2772 are present for an object. (iii) gives the same error message
2775 push_char (dtp
, '\0');
2779 size_t var_len
= strlen (root_nl
->var_name
);
2781 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2782 char ext_name
[var_len
+ saved_len
+ 1];
2784 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2785 if (dtp
->u
.p
.saved_string
)
2786 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2787 ext_name
[var_len
+ saved_len
] = '\0';
2788 nl
= find_nml_node (dtp
, ext_name
);
2791 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2795 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2796 snprintf (nml_err_msg
, nml_err_msg_size
,
2797 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2800 snprintf (nml_err_msg
, nml_err_msg_size
,
2801 "Cannot match namelist object name %s",
2802 dtp
->u
.p
.saved_string
);
2807 /* Get the length, data length, base pointer and rank of the variable.
2808 Set the default loop specification first. */
2810 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2812 nl
->ls
[dim
].step
= 1;
2813 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2814 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2815 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2818 /* Check to see if there is a qualifier: if so, parse it.*/
2820 if (c
== '(' && nl
->var_rank
)
2823 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2824 nml_err_msg
, &parsed_rank
) == FAILURE
)
2826 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2827 snprintf (nml_err_msg_end
,
2828 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2829 " for namelist variable %s", nl
->var_name
);
2832 if (parsed_rank
> 0)
2833 non_zero_rank_count
++;
2837 if ((c
= next_char (dtp
)) == EOF
)
2839 unget_char (dtp
, c
);
2841 else if (nl
->var_rank
> 0)
2842 non_zero_rank_count
++;
2844 /* Now parse a derived type component. The root namelist_info address
2845 is backed up, as is the previous component level. The component flag
2846 is set and the iteration is made by jumping back to get_name. */
2850 if (nl
->type
!= BT_DERIVED
)
2852 snprintf (nml_err_msg
, nml_err_msg_size
,
2853 "Attempt to get derived component for %s", nl
->var_name
);
2857 if (*pprev_nl
== NULL
|| !component_flag
)
2863 if ((c
= next_char (dtp
)) == EOF
)
2868 /* Parse a character qualifier, if present. chigh = 0 is a default
2869 that signals that the string length = string_length. */
2874 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2876 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2877 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2879 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2882 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2883 snprintf (nml_err_msg_end
,
2884 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2885 " for namelist variable %s", nl
->var_name
);
2889 clow
= ind
[0].start
;
2892 if (ind
[0].step
!= 1)
2894 snprintf (nml_err_msg
, nml_err_msg_size
,
2895 "Step not allowed in substring qualifier"
2896 " for namelist object %s", nl
->var_name
);
2900 if ((c
= next_char (dtp
)) == EOF
)
2902 unget_char (dtp
, c
);
2905 /* Make sure no extraneous qualifiers are there. */
2909 snprintf (nml_err_msg
, nml_err_msg_size
,
2910 "Qualifier for a scalar or non-character namelist object %s",
2915 /* Make sure there is no more than one non-zero rank object. */
2916 if (non_zero_rank_count
> 1)
2918 snprintf (nml_err_msg
, nml_err_msg_size
,
2919 "Multiple sub-objects with non-zero rank in namelist object %s",
2921 non_zero_rank_count
= 0;
2925 /* According to the standard, an equal sign MUST follow an object name. The
2926 following is possibly lax - it allows comments, blank lines and so on to
2927 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2931 eat_separator (dtp
);
2932 if (dtp
->u
.p
.input_complete
)
2935 if (dtp
->u
.p
.at_eol
)
2936 finish_separator (dtp
);
2937 if (dtp
->u
.p
.input_complete
)
2940 if ((c
= next_char (dtp
)) == EOF
)
2945 snprintf (nml_err_msg
, nml_err_msg_size
,
2946 "Equal sign must follow namelist object name %s",
2950 /* If a derived type, touch its components and restore the root
2951 namelist_info if we have parsed a qualified derived type
2954 if (nl
->type
== BT_DERIVED
)
2955 nml_touch_nodes (nl
);
2959 if (first_nl
->var_rank
== 0)
2961 if (component_flag
&& qualifier_flag
)
2968 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2969 clow
, chigh
) == FAILURE
)
2979 /* Entry point for namelist input. Goes through input until namelist name
2980 is matched. Then cycles through nml_get_obj_data until the input is
2981 completed or there is an error. */
2984 namelist_read (st_parameter_dt
*dtp
)
2987 char nml_err_msg
[200];
2989 /* Initialize the error string buffer just in case we get an unexpected fail
2990 somewhere and end up at nml_err_ret. */
2991 strcpy (nml_err_msg
, "Internal namelist read error");
2993 /* Pointer to the previously read object, in case attempt is made to read
2994 new object name. Should this fail, error message can give previous
2996 namelist_info
*prev_nl
= NULL
;
2998 dtp
->u
.p
.namelist_mode
= 1;
2999 dtp
->u
.p
.input_complete
= 0;
3000 dtp
->u
.p
.expanded_read
= 0;
3002 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3003 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3004 node names or namelist on stdout. */
3007 c
= next_char (dtp
);
3019 c
= next_char (dtp
);
3021 nml_query (dtp
, '=');
3023 unget_char (dtp
, c
);
3027 nml_query (dtp
, '?');
3036 /* Match the name of the namelist. */
3038 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3040 if (dtp
->u
.p
.nml_read_error
)
3043 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
3044 c
= next_char (dtp
);
3045 if (!is_separator(c
) && c
!= '!')
3047 unget_char (dtp
, c
);
3051 unget_char (dtp
, c
);
3052 eat_separator (dtp
);
3054 /* Ready to read namelist objects. If there is an error in input
3055 from stdin, output the error message and continue. */
3057 while (!dtp
->u
.p
.input_complete
)
3059 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3062 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3064 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3067 /* Reset the previous namelist pointer if we know we are not going
3068 to be doing multiple reads within a single namelist object. */
3069 if (prev_nl
&& prev_nl
->var_rank
== 0)
3080 /* All namelist error calls return from here */
3083 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);