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 unget_char (dtp
, c
);
1220 push_char (dtp
, '\0');
1222 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1228 /* Match INF and Infinity. */
1229 if ((c
== 'i' || c
== 'I')
1230 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1231 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1233 c
= next_char (dtp
);
1234 if ((c
!= 'i' && c
!= 'I')
1235 || ((c
== 'i' || c
== 'I')
1236 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1237 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1238 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1239 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1240 && (c
= next_char (dtp
))))
1242 if (is_separator (c
))
1243 unget_char (dtp
, c
);
1244 push_char (dtp
, 'i');
1245 push_char (dtp
, 'n');
1246 push_char (dtp
, 'f');
1250 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1251 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1252 && (c
= next_char (dtp
)))
1254 if (is_separator (c
))
1255 unget_char (dtp
, c
);
1256 push_char (dtp
, 'n');
1257 push_char (dtp
, 'a');
1258 push_char (dtp
, 'n');
1260 /* Match "NAN(alphanum)". */
1263 for ( ; c
!= ')'; c
= next_char (dtp
))
1264 if (is_separator (c
))
1267 c
= next_char (dtp
);
1268 if (is_separator (c
))
1269 unget_char (dtp
, c
);
1276 if (nml_bad_return (dtp
, c
))
1287 sprintf (message
, "Bad floating point number for item %d",
1288 dtp
->u
.p
.item_count
);
1289 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1295 /* Reading a complex number is straightforward because we can tell
1296 what it is right away. */
1299 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1304 if (parse_repeat (dtp
))
1307 c
= next_char (dtp
);
1314 unget_char (dtp
, c
);
1315 eat_separator (dtp
);
1324 c
= next_char (dtp
);
1325 if (c
== '\n' || c
== '\r')
1328 unget_char (dtp
, c
);
1330 if (parse_real (dtp
, dest
, kind
))
1335 c
= next_char (dtp
);
1336 if (c
== '\n' || c
== '\r')
1339 unget_char (dtp
, c
);
1342 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1347 c
= next_char (dtp
);
1348 if (c
== '\n' || c
== '\r')
1351 unget_char (dtp
, c
);
1353 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1358 c
= next_char (dtp
);
1359 if (c
== '\n' || c
== '\r')
1362 unget_char (dtp
, c
);
1364 if (next_char (dtp
) != ')')
1367 c
= next_char (dtp
);
1368 if (!is_separator (c
))
1371 unget_char (dtp
, c
);
1372 eat_separator (dtp
);
1375 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1380 if (nml_bad_return (dtp
, c
))
1391 sprintf (message
, "Bad complex value in item %d of list input",
1392 dtp
->u
.p
.item_count
);
1393 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1397 /* Parse a real number with a possible repeat count. */
1400 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1409 c
= next_char (dtp
);
1410 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1428 unget_char (dtp
, c
); /* Single null. */
1429 eat_separator (dtp
);
1442 /* Get the digit string that might be a repeat count. */
1446 c
= next_char (dtp
);
1447 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1471 push_char (dtp
, 'e');
1473 c
= next_char (dtp
);
1477 push_char (dtp
, '\0');
1481 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1482 unget_char (dtp
, c
);
1491 if (convert_integer (dtp
, -1, 0))
1494 /* Now get the number itself. */
1496 if ((c
= next_char (dtp
)) == EOF
)
1498 if (is_separator (c
))
1499 { /* Repeated null value. */
1500 unget_char (dtp
, c
);
1501 eat_separator (dtp
);
1505 if (c
!= '-' && c
!= '+')
1506 push_char (dtp
, '+');
1511 if ((c
= next_char (dtp
)) == EOF
)
1515 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1518 if (!isdigit (c
) && c
!= '.')
1520 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1539 c
= next_char (dtp
);
1540 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1568 push_char (dtp
, 'e');
1570 c
= next_char (dtp
);
1579 push_char (dtp
, 'e');
1581 if ((c
= next_char (dtp
)) == EOF
)
1583 if (c
!= '+' && c
!= '-')
1584 push_char (dtp
, '+');
1588 c
= next_char (dtp
);
1598 c
= next_char (dtp
);
1615 unget_char (dtp
, c
);
1616 eat_separator (dtp
);
1617 push_char (dtp
, '\0');
1618 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1622 dtp
->u
.p
.saved_type
= BT_REAL
;
1626 l_push_char (dtp
, c
);
1629 /* Match INF and Infinity. */
1630 if (c
== 'i' || c
== 'I')
1632 c
= next_char (dtp
);
1633 l_push_char (dtp
, c
);
1634 if (c
!= 'n' && c
!= 'N')
1636 c
= next_char (dtp
);
1637 l_push_char (dtp
, c
);
1638 if (c
!= 'f' && c
!= 'F')
1640 c
= next_char (dtp
);
1641 l_push_char (dtp
, c
);
1642 if (!is_separator (c
))
1644 if (c
!= 'i' && c
!= 'I')
1646 c
= next_char (dtp
);
1647 l_push_char (dtp
, c
);
1648 if (c
!= 'n' && c
!= 'N')
1650 c
= next_char (dtp
);
1651 l_push_char (dtp
, c
);
1652 if (c
!= 'i' && c
!= 'I')
1654 c
= next_char (dtp
);
1655 l_push_char (dtp
, c
);
1656 if (c
!= 't' && c
!= 'T')
1658 c
= next_char (dtp
);
1659 l_push_char (dtp
, c
);
1660 if (c
!= 'y' && c
!= 'Y')
1662 c
= next_char (dtp
);
1663 l_push_char (dtp
, c
);
1669 c
= next_char (dtp
);
1670 l_push_char (dtp
, c
);
1671 if (c
!= 'a' && c
!= 'A')
1673 c
= next_char (dtp
);
1674 l_push_char (dtp
, c
);
1675 if (c
!= 'n' && c
!= 'N')
1677 c
= next_char (dtp
);
1678 l_push_char (dtp
, c
);
1680 /* Match NAN(alphanum). */
1683 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1684 if (is_separator (c
))
1687 l_push_char (dtp
, c
);
1689 l_push_char (dtp
, ')');
1690 c
= next_char (dtp
);
1691 l_push_char (dtp
, c
);
1695 if (!is_separator (c
))
1698 if (dtp
->u
.p
.namelist_mode
)
1700 if (c
== ' ' || c
=='\n' || c
== '\r')
1704 if ((c
= next_char (dtp
)) == EOF
)
1707 while (c
== ' ' || c
=='\n' || c
== '\r');
1709 l_push_char (dtp
, c
);
1718 push_char (dtp
, 'i');
1719 push_char (dtp
, 'n');
1720 push_char (dtp
, 'f');
1724 push_char (dtp
, 'n');
1725 push_char (dtp
, 'a');
1726 push_char (dtp
, 'n');
1730 unget_char (dtp
, c
);
1731 eat_separator (dtp
);
1732 push_char (dtp
, '\0');
1733 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1737 dtp
->u
.p
.saved_type
= BT_REAL
;
1741 if (dtp
->u
.p
.namelist_mode
)
1743 dtp
->u
.p
.nml_read_error
= 1;
1744 dtp
->u
.p
.line_buffer_enabled
= 1;
1745 dtp
->u
.p
.item_count
= 0;
1751 if (nml_bad_return (dtp
, c
))
1763 sprintf (message
, "Bad real number in item %d of list input",
1764 dtp
->u
.p
.item_count
);
1765 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1769 /* Check the current type against the saved type to make sure they are
1770 compatible. Returns nonzero if incompatible. */
1773 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1777 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1779 sprintf (message
, "Read type %s where %s was expected for item %d",
1780 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1781 dtp
->u
.p
.item_count
);
1783 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1787 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1790 if (dtp
->u
.p
.saved_length
!= len
)
1793 "Read kind %d %s where kind %d is required for item %d",
1794 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1795 dtp
->u
.p
.item_count
);
1796 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1804 /* Top level data transfer subroutine for list reads. Because we have
1805 to deal with repeat counts, the data item is always saved after
1806 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1807 greater than one, we copy the data item multiple times. */
1810 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1811 int kind
, size_t size
)
1817 dtp
->u
.p
.namelist_mode
= 0;
1819 if (dtp
->u
.p
.first_item
)
1821 dtp
->u
.p
.first_item
= 0;
1822 dtp
->u
.p
.input_complete
= 0;
1823 dtp
->u
.p
.repeat_count
= 1;
1824 dtp
->u
.p
.at_eol
= 0;
1826 if ((c
= eat_spaces (dtp
)) == EOF
)
1831 if (is_separator (c
))
1833 /* Found a null value. */
1834 eat_separator (dtp
);
1835 dtp
->u
.p
.repeat_count
= 0;
1837 /* eat_separator sets this flag if the separator was a comma. */
1838 if (dtp
->u
.p
.comma_flag
)
1841 /* eat_separator sets this flag if the separator was a \n or \r. */
1842 if (dtp
->u
.p
.at_eol
)
1843 finish_separator (dtp
);
1851 if (dtp
->u
.p
.repeat_count
> 0)
1853 if (check_type (dtp
, type
, kind
))
1858 if (dtp
->u
.p
.input_complete
)
1861 if (dtp
->u
.p
.at_eol
)
1862 finish_separator (dtp
);
1866 /* Trailing spaces prior to end of line. */
1867 if (dtp
->u
.p
.at_eol
)
1868 finish_separator (dtp
);
1871 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1872 dtp
->u
.p
.repeat_count
= 1;
1878 read_integer (dtp
, kind
);
1881 read_logical (dtp
, kind
);
1884 read_character (dtp
, kind
);
1887 read_real (dtp
, p
, kind
);
1888 /* Copy value back to temporary if needed. */
1889 if (dtp
->u
.p
.repeat_count
> 0)
1890 memcpy (dtp
->u
.p
.value
, p
, kind
);
1893 read_complex (dtp
, p
, kind
, size
);
1894 /* Copy value back to temporary if needed. */
1895 if (dtp
->u
.p
.repeat_count
> 0)
1896 memcpy (dtp
->u
.p
.value
, p
, size
);
1899 internal_error (&dtp
->common
, "Bad type for list read");
1902 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1903 dtp
->u
.p
.saved_length
= size
;
1905 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1909 switch (dtp
->u
.p
.saved_type
)
1913 if (dtp
->u
.p
.repeat_count
> 0)
1914 memcpy (p
, dtp
->u
.p
.value
, size
);
1919 memcpy (p
, dtp
->u
.p
.value
, size
);
1923 if (dtp
->u
.p
.saved_string
)
1925 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1926 ? (int) size
: dtp
->u
.p
.saved_used
;
1928 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1931 q
= (gfc_char4_t
*) p
;
1932 for (i
= 0; i
< m
; i
++)
1933 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1937 /* Just delimiters encountered, nothing to copy but SPACE. */
1943 memset (((char *) p
) + m
, ' ', size
- m
);
1946 q
= (gfc_char4_t
*) p
;
1947 for (i
= m
; i
< (int) size
; i
++)
1948 q
[i
] = (unsigned char) ' ';
1957 internal_error (&dtp
->common
, "Bad type for list read");
1960 if (--dtp
->u
.p
.repeat_count
<= 0)
1964 if (err
== LIBERROR_END
)
1971 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1972 size_t size
, size_t nelems
)
1976 size_t stride
= type
== BT_CHARACTER
?
1977 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1982 /* Big loop over all the elements. */
1983 for (elem
= 0; elem
< nelems
; elem
++)
1985 dtp
->u
.p
.item_count
++;
1986 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
1994 /* Finish a list read. */
1997 finish_list_read (st_parameter_dt
*dtp
)
2003 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2005 if (dtp
->u
.p
.at_eol
)
2007 dtp
->u
.p
.at_eol
= 0;
2011 err
= eat_line (dtp
);
2012 if (err
== LIBERROR_END
)
2018 void namelist_read (st_parameter_dt *dtp)
2020 static void nml_match_name (char *name, int len)
2021 static int nml_query (st_parameter_dt *dtp)
2022 static int nml_get_obj_data (st_parameter_dt *dtp,
2023 namelist_info **prev_nl, char *, size_t)
2025 static void nml_untouch_nodes (st_parameter_dt *dtp)
2026 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2028 static int nml_parse_qualifier(descriptor_dimension * ad,
2029 array_loop_spec * ls, int rank, char *)
2030 static void nml_touch_nodes (namelist_info * nl)
2031 static int nml_read_obj (namelist_info *nl, index_type offset,
2032 namelist_info **prev_nl, char *, size_t,
2033 index_type clow, index_type chigh)
2037 /* Inputs a rank-dimensional qualifier, which can contain
2038 singlets, doublets, triplets or ':' with the standard meanings. */
2041 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2042 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2049 int is_array_section
, is_char
;
2053 is_array_section
= 0;
2054 dtp
->u
.p
.expanded_read
= 0;
2056 /* See if this is a character substring qualifier we are looking for. */
2063 /* The next character in the stream should be the '('. */
2065 if ((c
= next_char (dtp
)) == EOF
)
2068 /* Process the qualifier, by dimension and triplet. */
2070 for (dim
=0; dim
< rank
; dim
++ )
2072 for (indx
=0; indx
<3; indx
++)
2078 /* Process a potential sign. */
2079 if ((c
= next_char (dtp
)) == EOF
)
2091 unget_char (dtp
, c
);
2095 /* Process characters up to the next ':' , ',' or ')'. */
2098 if ((c
= next_char (dtp
)) == EOF
)
2104 is_array_section
= 1;
2108 if ((c
==',' && dim
== rank
-1)
2109 || (c
==')' && dim
< rank
-1))
2112 sprintf (parse_err_msg
, "Bad substring qualifier");
2114 sprintf (parse_err_msg
, "Bad number of index fields");
2123 case ' ': case '\t':
2125 if ((c
= next_char (dtp
) == EOF
))
2131 sprintf (parse_err_msg
,
2132 "Bad character in substring qualifier");
2134 sprintf (parse_err_msg
, "Bad character in index");
2138 if ((c
== ',' || c
== ')') && indx
== 0
2139 && dtp
->u
.p
.saved_string
== 0)
2142 sprintf (parse_err_msg
, "Null substring qualifier");
2144 sprintf (parse_err_msg
, "Null index field");
2148 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2149 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2152 sprintf (parse_err_msg
, "Bad substring qualifier");
2154 sprintf (parse_err_msg
, "Bad index triplet");
2158 if (is_char
&& !is_array_section
)
2160 sprintf (parse_err_msg
,
2161 "Missing colon in substring qualifier");
2165 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2167 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2168 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2174 /* Now read the index. */
2175 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2178 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2180 sprintf (parse_err_msg
, "Bad integer in index");
2186 /* Feed the index values to the triplet arrays. */
2190 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2192 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2194 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2197 /* Singlet or doublet indices. */
2198 if (c
==',' || c
==')')
2202 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2204 /* If -std=f95/2003 or an array section is specified,
2205 do not allow excess data to be processed. */
2206 if (is_array_section
== 1
2207 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2208 || !dtp
->u
.p
.ionml
->touched
2209 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2210 ls
[dim
].end
= ls
[dim
].start
;
2212 dtp
->u
.p
.expanded_read
= 1;
2215 /* Check for non-zero rank. */
2216 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2223 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2226 dtp
->u
.p
.expanded_read
= 0;
2227 for (i
= 0; i
< dim
; i
++)
2228 ls
[i
].end
= ls
[i
].start
;
2231 /* Check the values of the triplet indices. */
2232 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2233 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2234 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2235 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2238 sprintf (parse_err_msg
, "Substring out of range");
2240 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2244 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2245 || (ls
[dim
].step
== 0))
2247 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2251 /* Initialise the loop index counter. */
2252 ls
[dim
].idx
= ls
[dim
].start
;
2262 static namelist_info
*
2263 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2265 namelist_info
* t
= dtp
->u
.p
.ionml
;
2268 if (strcmp (var_name
, t
->var_name
) == 0)
2278 /* Visits all the components of a derived type that have
2279 not explicitly been identified in the namelist input.
2280 touched is set and the loop specification initialised
2281 to default values */
2284 nml_touch_nodes (namelist_info
* nl
)
2286 index_type len
= strlen (nl
->var_name
) + 1;
2288 char * ext_name
= (char*)get_mem (len
+ 1);
2289 memcpy (ext_name
, nl
->var_name
, len
-1);
2290 memcpy (ext_name
+ len
- 1, "%", 2);
2291 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2293 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2296 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2298 nl
->ls
[dim
].step
= 1;
2299 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2300 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2301 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2311 /* Resets touched for the entire list of nml_nodes, ready for a
2315 nml_untouch_nodes (st_parameter_dt
*dtp
)
2318 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2323 /* Attempts to input name to namelist name. Returns
2324 dtp->u.p.nml_read_error = 1 on no match. */
2327 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2332 dtp
->u
.p
.nml_read_error
= 0;
2333 for (i
= 0; i
< len
; i
++)
2335 c
= next_char (dtp
);
2336 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2338 dtp
->u
.p
.nml_read_error
= 1;
2344 /* If the namelist read is from stdin, output the current state of the
2345 namelist to stdout. This is used to implement the non-standard query
2346 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2347 the names alone are printed. */
2350 nml_query (st_parameter_dt
*dtp
, char c
)
2352 gfc_unit
* temp_unit
;
2357 static const index_type endlen
= 3;
2358 static const char endl
[] = "\r\n";
2359 static const char nmlend
[] = "&end\r\n";
2361 static const index_type endlen
= 2;
2362 static const char endl
[] = "\n";
2363 static const char nmlend
[] = "&end\n";
2366 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2369 /* Store the current unit and transfer to stdout. */
2371 temp_unit
= dtp
->u
.p
.current_unit
;
2372 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2374 if (dtp
->u
.p
.current_unit
)
2376 dtp
->u
.p
.mode
= WRITING
;
2377 next_record (dtp
, 0);
2379 /* Write the namelist in its entirety. */
2382 namelist_write (dtp
);
2384 /* Or write the list of names. */
2388 /* "&namelist_name\n" */
2390 len
= dtp
->namelist_name_len
;
2391 p
= write_block (dtp
, len
+ endlen
);
2395 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2396 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2397 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2401 len
= strlen (nl
->var_name
);
2402 p
= write_block (dtp
, len
+ endlen
);
2406 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2407 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2412 p
= write_block (dtp
, endlen
+ 3);
2414 memcpy (p
, &nmlend
, endlen
+ 3);
2417 /* Flush the stream to force immediate output. */
2419 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2420 sflush (dtp
->u
.p
.current_unit
->s
);
2421 unlock_unit (dtp
->u
.p
.current_unit
);
2426 /* Restore the current unit. */
2428 dtp
->u
.p
.current_unit
= temp_unit
;
2429 dtp
->u
.p
.mode
= READING
;
2433 /* Reads and stores the input for the namelist object nl. For an array,
2434 the function loops over the ranges defined by the loop specification.
2435 This default to all the data or to the specification from a qualifier.
2436 nml_read_obj recursively calls itself to read derived types. It visits
2437 all its own components but only reads data for those that were touched
2438 when the name was parsed. If a read error is encountered, an attempt is
2439 made to return to read a new object name because the standard allows too
2440 little data to be available. On the other hand, too much data is an
2444 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2445 namelist_info
**pprev_nl
, char *nml_err_msg
,
2446 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2448 namelist_info
* cmp
;
2455 size_t obj_name_len
;
2458 /* This object not touched in name parsing. */
2463 dtp
->u
.p
.repeat_count
= 0;
2475 dlen
= size_from_real_kind (len
);
2479 dlen
= size_from_complex_kind (len
);
2483 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2492 /* Update the pointer to the data, using the current index vector */
2494 pdata
= (void*)(nl
->mem_pos
+ offset
);
2495 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2496 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2497 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2498 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2500 /* Reset the error flag and try to read next value, if
2501 dtp->u.p.repeat_count=0 */
2503 dtp
->u
.p
.nml_read_error
= 0;
2505 if (--dtp
->u
.p
.repeat_count
<= 0)
2507 if (dtp
->u
.p
.input_complete
)
2509 if (dtp
->u
.p
.at_eol
)
2510 finish_separator (dtp
);
2511 if (dtp
->u
.p
.input_complete
)
2514 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2520 read_integer (dtp
, len
);
2524 read_logical (dtp
, len
);
2528 read_character (dtp
, len
);
2532 /* Need to copy data back from the real location to the temp in order
2533 to handle nml reads into arrays. */
2534 read_real (dtp
, pdata
, len
);
2535 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2539 /* Same as for REAL, copy back to temp. */
2540 read_complex (dtp
, pdata
, len
, dlen
);
2541 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2545 obj_name_len
= strlen (nl
->var_name
) + 1;
2546 obj_name
= get_mem (obj_name_len
+1);
2547 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2548 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2550 /* If reading a derived type, disable the expanded read warning
2551 since a single object can have multiple reads. */
2552 dtp
->u
.p
.expanded_read
= 0;
2554 /* Now loop over the components. Update the component pointer
2555 with the return value from nml_write_obj. This loop jumps
2556 past nested derived types by testing if the potential
2557 component name contains '%'. */
2559 for (cmp
= nl
->next
;
2561 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2562 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2566 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2567 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2568 clow
, chigh
) == FAILURE
)
2574 if (dtp
->u
.p
.input_complete
)
2585 snprintf (nml_err_msg
, nml_err_msg_size
,
2586 "Bad type for namelist object %s", nl
->var_name
);
2587 internal_error (&dtp
->common
, nml_err_msg
);
2592 /* The standard permits array data to stop short of the number of
2593 elements specified in the loop specification. In this case, we
2594 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2595 nml_get_obj_data and an attempt is made to read object name. */
2598 if (dtp
->u
.p
.nml_read_error
)
2600 dtp
->u
.p
.expanded_read
= 0;
2604 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2606 dtp
->u
.p
.expanded_read
= 0;
2610 switch (dtp
->u
.p
.saved_type
)
2617 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2621 if (dlen
< dtp
->u
.p
.saved_used
)
2623 if (compile_options
.bounds_check
)
2625 snprintf (nml_err_msg
, nml_err_msg_size
,
2626 "Namelist object '%s' truncated on read.",
2628 generate_warning (&dtp
->common
, nml_err_msg
);
2633 m
= dtp
->u
.p
.saved_used
;
2634 pdata
= (void*)( pdata
+ clow
- 1 );
2635 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2637 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2644 /* Warn if a non-standard expanded read occurs. A single read of a
2645 single object is acceptable. If a second read occurs, issue a warning
2646 and set the flag to zero to prevent further warnings. */
2647 if (dtp
->u
.p
.expanded_read
== 2)
2649 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2650 dtp
->u
.p
.expanded_read
= 0;
2653 /* If the expanded read warning flag is set, increment it,
2654 indicating that a single read has occurred. */
2655 if (dtp
->u
.p
.expanded_read
>= 1)
2656 dtp
->u
.p
.expanded_read
++;
2658 /* Break out of loop if scalar. */
2662 /* Now increment the index vector. */
2667 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2669 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2671 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2673 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2675 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2679 } while (!nml_carry
);
2681 if (dtp
->u
.p
.repeat_count
> 1)
2683 snprintf (nml_err_msg
, nml_err_msg_size
,
2684 "Repeat count too large for namelist object %s", nl
->var_name
);
2694 /* Parses the object name, including array and substring qualifiers. It
2695 iterates over derived type components, touching those components and
2696 setting their loop specifications, if there is a qualifier. If the
2697 object is itself a derived type, its components and subcomponents are
2698 touched. nml_read_obj is called at the end and this reads the data in
2699 the manner specified by the object name. */
2702 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2703 char *nml_err_msg
, size_t nml_err_msg_size
)
2707 namelist_info
* first_nl
= NULL
;
2708 namelist_info
* root_nl
= NULL
;
2709 int dim
, parsed_rank
;
2710 int component_flag
, qualifier_flag
;
2711 index_type clow
, chigh
;
2712 int non_zero_rank_count
;
2714 /* Look for end of input or object name. If '?' or '=?' are encountered
2715 in stdin, print the node names or the namelist to stdout. */
2717 eat_separator (dtp
);
2718 if (dtp
->u
.p
.input_complete
)
2721 if (dtp
->u
.p
.at_eol
)
2722 finish_separator (dtp
);
2723 if (dtp
->u
.p
.input_complete
)
2726 if ((c
= next_char (dtp
)) == EOF
)
2731 if ((c
= next_char (dtp
)) == EOF
)
2735 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2738 nml_query (dtp
, '=');
2742 nml_query (dtp
, '?');
2747 nml_match_name (dtp
, "end", 3);
2748 if (dtp
->u
.p
.nml_read_error
)
2750 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2754 dtp
->u
.p
.input_complete
= 1;
2761 /* Untouch all nodes of the namelist and reset the flags that are set for
2762 derived type components. */
2764 nml_untouch_nodes (dtp
);
2767 non_zero_rank_count
= 0;
2769 /* Get the object name - should '!' and '\n' be permitted separators? */
2777 if (!is_separator (c
))
2778 push_char (dtp
, tolower(c
));
2779 if ((c
= next_char (dtp
)) == EOF
)
2781 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2783 unget_char (dtp
, c
);
2785 /* Check that the name is in the namelist and get pointer to object.
2786 Three error conditions exist: (i) An attempt is being made to
2787 identify a non-existent object, following a failed data read or
2788 (ii) The object name does not exist or (iii) Too many data items
2789 are present for an object. (iii) gives the same error message
2792 push_char (dtp
, '\0');
2796 size_t var_len
= strlen (root_nl
->var_name
);
2798 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2799 char ext_name
[var_len
+ saved_len
+ 1];
2801 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2802 if (dtp
->u
.p
.saved_string
)
2803 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2804 ext_name
[var_len
+ saved_len
] = '\0';
2805 nl
= find_nml_node (dtp
, ext_name
);
2808 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2812 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2813 snprintf (nml_err_msg
, nml_err_msg_size
,
2814 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2817 snprintf (nml_err_msg
, nml_err_msg_size
,
2818 "Cannot match namelist object name %s",
2819 dtp
->u
.p
.saved_string
);
2824 /* Get the length, data length, base pointer and rank of the variable.
2825 Set the default loop specification first. */
2827 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2829 nl
->ls
[dim
].step
= 1;
2830 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2831 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2832 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2835 /* Check to see if there is a qualifier: if so, parse it.*/
2837 if (c
== '(' && nl
->var_rank
)
2840 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2841 nml_err_msg
, &parsed_rank
) == FAILURE
)
2843 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2844 snprintf (nml_err_msg_end
,
2845 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2846 " for namelist variable %s", nl
->var_name
);
2849 if (parsed_rank
> 0)
2850 non_zero_rank_count
++;
2854 if ((c
= next_char (dtp
)) == EOF
)
2856 unget_char (dtp
, c
);
2858 else if (nl
->var_rank
> 0)
2859 non_zero_rank_count
++;
2861 /* Now parse a derived type component. The root namelist_info address
2862 is backed up, as is the previous component level. The component flag
2863 is set and the iteration is made by jumping back to get_name. */
2867 if (nl
->type
!= BT_DERIVED
)
2869 snprintf (nml_err_msg
, nml_err_msg_size
,
2870 "Attempt to get derived component for %s", nl
->var_name
);
2874 if (*pprev_nl
== NULL
|| !component_flag
)
2880 if ((c
= next_char (dtp
)) == EOF
)
2885 /* Parse a character qualifier, if present. chigh = 0 is a default
2886 that signals that the string length = string_length. */
2891 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2893 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2894 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2896 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2899 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2900 snprintf (nml_err_msg_end
,
2901 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2902 " for namelist variable %s", nl
->var_name
);
2906 clow
= ind
[0].start
;
2909 if (ind
[0].step
!= 1)
2911 snprintf (nml_err_msg
, nml_err_msg_size
,
2912 "Step not allowed in substring qualifier"
2913 " for namelist object %s", nl
->var_name
);
2917 if ((c
= next_char (dtp
)) == EOF
)
2919 unget_char (dtp
, c
);
2922 /* Make sure no extraneous qualifiers are there. */
2926 snprintf (nml_err_msg
, nml_err_msg_size
,
2927 "Qualifier for a scalar or non-character namelist object %s",
2932 /* Make sure there is no more than one non-zero rank object. */
2933 if (non_zero_rank_count
> 1)
2935 snprintf (nml_err_msg
, nml_err_msg_size
,
2936 "Multiple sub-objects with non-zero rank in namelist object %s",
2938 non_zero_rank_count
= 0;
2942 /* According to the standard, an equal sign MUST follow an object name. The
2943 following is possibly lax - it allows comments, blank lines and so on to
2944 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2948 eat_separator (dtp
);
2949 if (dtp
->u
.p
.input_complete
)
2952 if (dtp
->u
.p
.at_eol
)
2953 finish_separator (dtp
);
2954 if (dtp
->u
.p
.input_complete
)
2957 if ((c
= next_char (dtp
)) == EOF
)
2962 snprintf (nml_err_msg
, nml_err_msg_size
,
2963 "Equal sign must follow namelist object name %s",
2967 /* If a derived type, touch its components and restore the root
2968 namelist_info if we have parsed a qualified derived type
2971 if (nl
->type
== BT_DERIVED
)
2972 nml_touch_nodes (nl
);
2976 if (first_nl
->var_rank
== 0)
2978 if (component_flag
&& qualifier_flag
)
2985 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2986 clow
, chigh
) == FAILURE
)
2996 /* Entry point for namelist input. Goes through input until namelist name
2997 is matched. Then cycles through nml_get_obj_data until the input is
2998 completed or there is an error. */
3001 namelist_read (st_parameter_dt
*dtp
)
3004 char nml_err_msg
[200];
3006 /* Initialize the error string buffer just in case we get an unexpected fail
3007 somewhere and end up at nml_err_ret. */
3008 strcpy (nml_err_msg
, "Internal namelist read error");
3010 /* Pointer to the previously read object, in case attempt is made to read
3011 new object name. Should this fail, error message can give previous
3013 namelist_info
*prev_nl
= NULL
;
3015 dtp
->u
.p
.namelist_mode
= 1;
3016 dtp
->u
.p
.input_complete
= 0;
3017 dtp
->u
.p
.expanded_read
= 0;
3019 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3020 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3021 node names or namelist on stdout. */
3024 c
= next_char (dtp
);
3036 c
= next_char (dtp
);
3038 nml_query (dtp
, '=');
3040 unget_char (dtp
, c
);
3044 nml_query (dtp
, '?');
3053 /* Match the name of the namelist. */
3055 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3057 if (dtp
->u
.p
.nml_read_error
)
3060 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
3061 c
= next_char (dtp
);
3062 if (!is_separator(c
) && c
!= '!')
3064 unget_char (dtp
, c
);
3068 unget_char (dtp
, c
);
3069 eat_separator (dtp
);
3071 /* Ready to read namelist objects. If there is an error in input
3072 from stdin, output the error message and continue. */
3074 while (!dtp
->u
.p
.input_complete
)
3076 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3079 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3081 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3084 /* Reset the previous namelist pointer if we know we are not going
3085 to be doing multiple reads within a single namelist object. */
3086 if (prev_nl
&& prev_nl
->var_rank
== 0)
3097 /* All namelist error calls return from here */
3100 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);