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
)
1107 if (c
== '-' || c
== '+')
1110 if ((c
= next_char (dtp
)) == EOF
)
1114 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1117 if (!isdigit (c
) && c
!= '.')
1119 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1127 seen_dp
= (c
== '.') ? 1 : 0;
1131 if ((c
= next_char (dtp
)) == EOF
)
1133 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1153 push_char (dtp
, 'e');
1158 push_char (dtp
, 'e');
1160 if ((c
= next_char (dtp
)) == EOF
)
1165 unget_char (dtp
, c
);
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
);
1314 if (parse_real (dtp
, dest
, kind
))
1319 c
= next_char (dtp
);
1320 if (c
== '\n' || c
== '\r')
1323 unget_char (dtp
, c
);
1326 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1331 c
= next_char (dtp
);
1332 if (c
== '\n' || c
== '\r')
1335 unget_char (dtp
, c
);
1337 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1341 if (next_char (dtp
) != ')')
1344 c
= next_char (dtp
);
1345 if (!is_separator (c
))
1348 unget_char (dtp
, c
);
1349 eat_separator (dtp
);
1352 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1357 if (nml_bad_return (dtp
, c
))
1368 sprintf (message
, "Bad complex value in item %d of list input",
1369 dtp
->u
.p
.item_count
);
1370 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1374 /* Parse a real number with a possible repeat count. */
1377 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1386 c
= next_char (dtp
);
1387 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1405 unget_char (dtp
, c
); /* Single null. */
1406 eat_separator (dtp
);
1419 /* Get the digit string that might be a repeat count. */
1423 c
= next_char (dtp
);
1424 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1448 push_char (dtp
, 'e');
1450 c
= next_char (dtp
);
1454 push_char (dtp
, '\0');
1458 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1459 unget_char (dtp
, c
);
1468 if (convert_integer (dtp
, -1, 0))
1471 /* Now get the number itself. */
1473 if ((c
= next_char (dtp
)) == EOF
)
1475 if (is_separator (c
))
1476 { /* Repeated null value. */
1477 unget_char (dtp
, c
);
1478 eat_separator (dtp
);
1482 if (c
!= '-' && c
!= '+')
1483 push_char (dtp
, '+');
1488 if ((c
= next_char (dtp
)) == EOF
)
1492 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1495 if (!isdigit (c
) && c
!= '.')
1497 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1516 c
= next_char (dtp
);
1517 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1545 push_char (dtp
, 'e');
1547 c
= next_char (dtp
);
1556 push_char (dtp
, 'e');
1558 if ((c
= next_char (dtp
)) == EOF
)
1560 if (c
!= '+' && c
!= '-')
1561 push_char (dtp
, '+');
1565 c
= next_char (dtp
);
1575 c
= next_char (dtp
);
1592 unget_char (dtp
, c
);
1593 eat_separator (dtp
);
1594 push_char (dtp
, '\0');
1595 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1599 dtp
->u
.p
.saved_type
= BT_REAL
;
1603 l_push_char (dtp
, c
);
1606 /* Match INF and Infinity. */
1607 if (c
== 'i' || c
== 'I')
1609 c
= next_char (dtp
);
1610 l_push_char (dtp
, c
);
1611 if (c
!= 'n' && c
!= 'N')
1613 c
= next_char (dtp
);
1614 l_push_char (dtp
, c
);
1615 if (c
!= 'f' && c
!= 'F')
1617 c
= next_char (dtp
);
1618 l_push_char (dtp
, c
);
1619 if (!is_separator (c
))
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
!= 'i' && c
!= 'I')
1631 c
= next_char (dtp
);
1632 l_push_char (dtp
, c
);
1633 if (c
!= 't' && c
!= 'T')
1635 c
= next_char (dtp
);
1636 l_push_char (dtp
, c
);
1637 if (c
!= 'y' && c
!= 'Y')
1639 c
= next_char (dtp
);
1640 l_push_char (dtp
, c
);
1646 c
= next_char (dtp
);
1647 l_push_char (dtp
, c
);
1648 if (c
!= 'a' && c
!= 'A')
1650 c
= next_char (dtp
);
1651 l_push_char (dtp
, c
);
1652 if (c
!= 'n' && c
!= 'N')
1654 c
= next_char (dtp
);
1655 l_push_char (dtp
, c
);
1657 /* Match NAN(alphanum). */
1660 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1661 if (is_separator (c
))
1664 l_push_char (dtp
, c
);
1666 l_push_char (dtp
, ')');
1667 c
= next_char (dtp
);
1668 l_push_char (dtp
, c
);
1672 if (!is_separator (c
))
1675 if (dtp
->u
.p
.namelist_mode
)
1677 if (c
== ' ' || c
=='\n' || c
== '\r')
1681 if ((c
= next_char (dtp
)) == EOF
)
1684 while (c
== ' ' || c
=='\n' || c
== '\r');
1686 l_push_char (dtp
, c
);
1695 push_char (dtp
, 'i');
1696 push_char (dtp
, 'n');
1697 push_char (dtp
, 'f');
1701 push_char (dtp
, 'n');
1702 push_char (dtp
, 'a');
1703 push_char (dtp
, 'n');
1710 if (dtp
->u
.p
.namelist_mode
)
1712 dtp
->u
.p
.nml_read_error
= 1;
1713 dtp
->u
.p
.line_buffer_enabled
= 1;
1714 dtp
->u
.p
.item_count
= 0;
1720 if (nml_bad_return (dtp
, c
))
1731 sprintf (message
, "Bad real number in item %d of list input",
1732 dtp
->u
.p
.item_count
);
1733 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1737 /* Check the current type against the saved type to make sure they are
1738 compatible. Returns nonzero if incompatible. */
1741 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1745 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1747 sprintf (message
, "Read type %s where %s was expected for item %d",
1748 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1749 dtp
->u
.p
.item_count
);
1751 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1755 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1758 if (dtp
->u
.p
.saved_length
!= len
)
1761 "Read kind %d %s where kind %d is required for item %d",
1762 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1763 dtp
->u
.p
.item_count
);
1764 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1772 /* Top level data transfer subroutine for list reads. Because we have
1773 to deal with repeat counts, the data item is always saved after
1774 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1775 greater than one, we copy the data item multiple times. */
1778 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1779 int kind
, size_t size
)
1785 dtp
->u
.p
.namelist_mode
= 0;
1787 if (dtp
->u
.p
.first_item
)
1789 dtp
->u
.p
.first_item
= 0;
1790 dtp
->u
.p
.input_complete
= 0;
1791 dtp
->u
.p
.repeat_count
= 1;
1792 dtp
->u
.p
.at_eol
= 0;
1794 if ((c
= eat_spaces (dtp
)) == EOF
)
1799 if (is_separator (c
))
1801 /* Found a null value. */
1802 eat_separator (dtp
);
1803 dtp
->u
.p
.repeat_count
= 0;
1805 /* eat_separator sets this flag if the separator was a comma. */
1806 if (dtp
->u
.p
.comma_flag
)
1809 /* eat_separator sets this flag if the separator was a \n or \r. */
1810 if (dtp
->u
.p
.at_eol
)
1811 finish_separator (dtp
);
1819 if (dtp
->u
.p
.repeat_count
> 0)
1821 if (check_type (dtp
, type
, kind
))
1826 if (dtp
->u
.p
.input_complete
)
1829 if (dtp
->u
.p
.at_eol
)
1830 finish_separator (dtp
);
1834 /* Trailing spaces prior to end of line. */
1835 if (dtp
->u
.p
.at_eol
)
1836 finish_separator (dtp
);
1839 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1840 dtp
->u
.p
.repeat_count
= 1;
1846 read_integer (dtp
, kind
);
1849 read_logical (dtp
, kind
);
1852 read_character (dtp
, kind
);
1855 read_real (dtp
, p
, kind
);
1856 /* Copy value back to temporary if needed. */
1857 if (dtp
->u
.p
.repeat_count
> 0)
1858 memcpy (dtp
->u
.p
.value
, p
, kind
);
1861 read_complex (dtp
, p
, kind
, size
);
1862 /* Copy value back to temporary if needed. */
1863 if (dtp
->u
.p
.repeat_count
> 0)
1864 memcpy (dtp
->u
.p
.value
, p
, size
);
1867 internal_error (&dtp
->common
, "Bad type for list read");
1870 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1871 dtp
->u
.p
.saved_length
= size
;
1873 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1877 switch (dtp
->u
.p
.saved_type
)
1881 if (dtp
->u
.p
.repeat_count
> 0)
1882 memcpy (p
, dtp
->u
.p
.value
, size
);
1887 memcpy (p
, dtp
->u
.p
.value
, size
);
1891 if (dtp
->u
.p
.saved_string
)
1893 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1894 ? (int) size
: dtp
->u
.p
.saved_used
;
1896 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1899 q
= (gfc_char4_t
*) p
;
1900 for (i
= 0; i
< m
; i
++)
1901 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1905 /* Just delimiters encountered, nothing to copy but SPACE. */
1911 memset (((char *) p
) + m
, ' ', size
- m
);
1914 q
= (gfc_char4_t
*) p
;
1915 for (i
= m
; i
< (int) size
; i
++)
1916 q
[i
] = (unsigned char) ' ';
1925 internal_error (&dtp
->common
, "Bad type for list read");
1928 if (--dtp
->u
.p
.repeat_count
<= 0)
1932 if (err
== LIBERROR_END
)
1939 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1940 size_t size
, size_t nelems
)
1944 size_t stride
= type
== BT_CHARACTER
?
1945 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1950 /* Big loop over all the elements. */
1951 for (elem
= 0; elem
< nelems
; elem
++)
1953 dtp
->u
.p
.item_count
++;
1954 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
1962 /* Finish a list read. */
1965 finish_list_read (st_parameter_dt
*dtp
)
1971 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1973 if (dtp
->u
.p
.at_eol
)
1975 dtp
->u
.p
.at_eol
= 0;
1979 err
= eat_line (dtp
);
1980 if (err
== LIBERROR_END
)
1986 void namelist_read (st_parameter_dt *dtp)
1988 static void nml_match_name (char *name, int len)
1989 static int nml_query (st_parameter_dt *dtp)
1990 static int nml_get_obj_data (st_parameter_dt *dtp,
1991 namelist_info **prev_nl, char *, size_t)
1993 static void nml_untouch_nodes (st_parameter_dt *dtp)
1994 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1996 static int nml_parse_qualifier(descriptor_dimension * ad,
1997 array_loop_spec * ls, int rank, char *)
1998 static void nml_touch_nodes (namelist_info * nl)
1999 static int nml_read_obj (namelist_info *nl, index_type offset,
2000 namelist_info **prev_nl, char *, size_t,
2001 index_type clow, index_type chigh)
2005 /* Inputs a rank-dimensional qualifier, which can contain
2006 singlets, doublets, triplets or ':' with the standard meanings. */
2009 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2010 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2017 int is_array_section
, is_char
;
2021 is_array_section
= 0;
2022 dtp
->u
.p
.expanded_read
= 0;
2024 /* See if this is a character substring qualifier we are looking for. */
2031 /* The next character in the stream should be the '('. */
2033 if ((c
= next_char (dtp
)) == EOF
)
2036 /* Process the qualifier, by dimension and triplet. */
2038 for (dim
=0; dim
< rank
; dim
++ )
2040 for (indx
=0; indx
<3; indx
++)
2046 /* Process a potential sign. */
2047 if ((c
= next_char (dtp
)) == EOF
)
2059 unget_char (dtp
, c
);
2063 /* Process characters up to the next ':' , ',' or ')'. */
2066 if ((c
= next_char (dtp
)) == EOF
)
2072 is_array_section
= 1;
2076 if ((c
==',' && dim
== rank
-1)
2077 || (c
==')' && dim
< rank
-1))
2080 sprintf (parse_err_msg
, "Bad substring qualifier");
2082 sprintf (parse_err_msg
, "Bad number of index fields");
2091 case ' ': case '\t':
2093 if ((c
= next_char (dtp
) == EOF
))
2099 sprintf (parse_err_msg
,
2100 "Bad character in substring qualifier");
2102 sprintf (parse_err_msg
, "Bad character in index");
2106 if ((c
== ',' || c
== ')') && indx
== 0
2107 && dtp
->u
.p
.saved_string
== 0)
2110 sprintf (parse_err_msg
, "Null substring qualifier");
2112 sprintf (parse_err_msg
, "Null index field");
2116 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2117 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2120 sprintf (parse_err_msg
, "Bad substring qualifier");
2122 sprintf (parse_err_msg
, "Bad index triplet");
2126 if (is_char
&& !is_array_section
)
2128 sprintf (parse_err_msg
,
2129 "Missing colon in substring qualifier");
2133 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2135 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2136 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2142 /* Now read the index. */
2143 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2146 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2148 sprintf (parse_err_msg
, "Bad integer in index");
2154 /* Feed the index values to the triplet arrays. */
2158 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2160 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2162 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2165 /* Singlet or doublet indices. */
2166 if (c
==',' || c
==')')
2170 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2172 /* If -std=f95/2003 or an array section is specified,
2173 do not allow excess data to be processed. */
2174 if (is_array_section
== 1
2175 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2176 || !dtp
->u
.p
.ionml
->touched
2177 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2178 ls
[dim
].end
= ls
[dim
].start
;
2180 dtp
->u
.p
.expanded_read
= 1;
2183 /* Check for non-zero rank. */
2184 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2191 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2194 dtp
->u
.p
.expanded_read
= 0;
2195 for (i
= 0; i
< dim
; i
++)
2196 ls
[i
].end
= ls
[i
].start
;
2199 /* Check the values of the triplet indices. */
2200 if ((ls
[dim
].start
> (ssize_t
) GFC_DIMENSION_UBOUND(ad
[dim
]))
2201 || (ls
[dim
].start
< (ssize_t
) GFC_DIMENSION_LBOUND(ad
[dim
]))
2202 || (ls
[dim
].end
> (ssize_t
) GFC_DIMENSION_UBOUND(ad
[dim
]))
2203 || (ls
[dim
].end
< (ssize_t
) GFC_DIMENSION_LBOUND(ad
[dim
])))
2206 sprintf (parse_err_msg
, "Substring out of range");
2208 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2212 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2213 || (ls
[dim
].step
== 0))
2215 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2219 /* Initialise the loop index counter. */
2220 ls
[dim
].idx
= ls
[dim
].start
;
2230 static namelist_info
*
2231 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2233 namelist_info
* t
= dtp
->u
.p
.ionml
;
2236 if (strcmp (var_name
, t
->var_name
) == 0)
2246 /* Visits all the components of a derived type that have
2247 not explicitly been identified in the namelist input.
2248 touched is set and the loop specification initialised
2249 to default values */
2252 nml_touch_nodes (namelist_info
* nl
)
2254 index_type len
= strlen (nl
->var_name
) + 1;
2256 char * ext_name
= (char*)get_mem (len
+ 1);
2257 memcpy (ext_name
, nl
->var_name
, len
-1);
2258 memcpy (ext_name
+ len
- 1, "%", 2);
2259 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2261 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2264 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2266 nl
->ls
[dim
].step
= 1;
2267 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2268 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2269 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2279 /* Resets touched for the entire list of nml_nodes, ready for a
2283 nml_untouch_nodes (st_parameter_dt
*dtp
)
2286 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2291 /* Attempts to input name to namelist name. Returns
2292 dtp->u.p.nml_read_error = 1 on no match. */
2295 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2300 dtp
->u
.p
.nml_read_error
= 0;
2301 for (i
= 0; i
< len
; i
++)
2303 c
= next_char (dtp
);
2304 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2306 dtp
->u
.p
.nml_read_error
= 1;
2312 /* If the namelist read is from stdin, output the current state of the
2313 namelist to stdout. This is used to implement the non-standard query
2314 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2315 the names alone are printed. */
2318 nml_query (st_parameter_dt
*dtp
, char c
)
2320 gfc_unit
* temp_unit
;
2325 static const index_type endlen
= 3;
2326 static const char endl
[] = "\r\n";
2327 static const char nmlend
[] = "&end\r\n";
2329 static const index_type endlen
= 2;
2330 static const char endl
[] = "\n";
2331 static const char nmlend
[] = "&end\n";
2334 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2337 /* Store the current unit and transfer to stdout. */
2339 temp_unit
= dtp
->u
.p
.current_unit
;
2340 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2342 if (dtp
->u
.p
.current_unit
)
2344 dtp
->u
.p
.mode
= WRITING
;
2345 next_record (dtp
, 0);
2347 /* Write the namelist in its entirety. */
2350 namelist_write (dtp
);
2352 /* Or write the list of names. */
2356 /* "&namelist_name\n" */
2358 len
= dtp
->namelist_name_len
;
2359 p
= write_block (dtp
, len
+ endlen
);
2363 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2364 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2365 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2369 len
= strlen (nl
->var_name
);
2370 p
= write_block (dtp
, len
+ endlen
);
2374 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2375 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2380 p
= write_block (dtp
, endlen
+ 3);
2382 memcpy (p
, &nmlend
, endlen
+ 3);
2385 /* Flush the stream to force immediate output. */
2387 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2388 sflush (dtp
->u
.p
.current_unit
->s
);
2389 unlock_unit (dtp
->u
.p
.current_unit
);
2394 /* Restore the current unit. */
2396 dtp
->u
.p
.current_unit
= temp_unit
;
2397 dtp
->u
.p
.mode
= READING
;
2401 /* Reads and stores the input for the namelist object nl. For an array,
2402 the function loops over the ranges defined by the loop specification.
2403 This default to all the data or to the specification from a qualifier.
2404 nml_read_obj recursively calls itself to read derived types. It visits
2405 all its own components but only reads data for those that were touched
2406 when the name was parsed. If a read error is encountered, an attempt is
2407 made to return to read a new object name because the standard allows too
2408 little data to be available. On the other hand, too much data is an
2412 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2413 namelist_info
**pprev_nl
, char *nml_err_msg
,
2414 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2416 namelist_info
* cmp
;
2423 size_t obj_name_len
;
2426 /* This object not touched in name parsing. */
2431 dtp
->u
.p
.repeat_count
= 0;
2443 dlen
= size_from_real_kind (len
);
2447 dlen
= size_from_complex_kind (len
);
2451 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2460 /* Update the pointer to the data, using the current index vector */
2462 pdata
= (void*)(nl
->mem_pos
+ offset
);
2463 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2464 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2465 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2466 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2468 /* Reset the error flag and try to read next value, if
2469 dtp->u.p.repeat_count=0 */
2471 dtp
->u
.p
.nml_read_error
= 0;
2473 if (--dtp
->u
.p
.repeat_count
<= 0)
2475 if (dtp
->u
.p
.input_complete
)
2477 if (dtp
->u
.p
.at_eol
)
2478 finish_separator (dtp
);
2479 if (dtp
->u
.p
.input_complete
)
2482 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2488 read_integer (dtp
, len
);
2492 read_logical (dtp
, len
);
2496 read_character (dtp
, len
);
2500 /* Need to copy data back from the real location to the temp in order
2501 to handle nml reads into arrays. */
2502 read_real (dtp
, pdata
, len
);
2503 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2507 /* Same as for REAL, copy back to temp. */
2508 read_complex (dtp
, pdata
, len
, dlen
);
2509 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2513 obj_name_len
= strlen (nl
->var_name
) + 1;
2514 obj_name
= get_mem (obj_name_len
+1);
2515 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2516 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2518 /* If reading a derived type, disable the expanded read warning
2519 since a single object can have multiple reads. */
2520 dtp
->u
.p
.expanded_read
= 0;
2522 /* Now loop over the components. Update the component pointer
2523 with the return value from nml_write_obj. This loop jumps
2524 past nested derived types by testing if the potential
2525 component name contains '%'. */
2527 for (cmp
= nl
->next
;
2529 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2530 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2534 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2535 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2536 clow
, chigh
) == FAILURE
)
2542 if (dtp
->u
.p
.input_complete
)
2553 snprintf (nml_err_msg
, nml_err_msg_size
,
2554 "Bad type for namelist object %s", nl
->var_name
);
2555 internal_error (&dtp
->common
, nml_err_msg
);
2560 /* The standard permits array data to stop short of the number of
2561 elements specified in the loop specification. In this case, we
2562 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2563 nml_get_obj_data and an attempt is made to read object name. */
2566 if (dtp
->u
.p
.nml_read_error
)
2568 dtp
->u
.p
.expanded_read
= 0;
2572 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2574 dtp
->u
.p
.expanded_read
= 0;
2578 switch (dtp
->u
.p
.saved_type
)
2585 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2589 if (dlen
< dtp
->u
.p
.saved_used
)
2591 if (compile_options
.bounds_check
)
2593 snprintf (nml_err_msg
, nml_err_msg_size
,
2594 "Namelist object '%s' truncated on read.",
2596 generate_warning (&dtp
->common
, nml_err_msg
);
2601 m
= dtp
->u
.p
.saved_used
;
2602 pdata
= (void*)( pdata
+ clow
- 1 );
2603 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2605 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2612 /* Warn if a non-standard expanded read occurs. A single read of a
2613 single object is acceptable. If a second read occurs, issue a warning
2614 and set the flag to zero to prevent further warnings. */
2615 if (dtp
->u
.p
.expanded_read
== 2)
2617 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2618 dtp
->u
.p
.expanded_read
= 0;
2621 /* If the expanded read warning flag is set, increment it,
2622 indicating that a single read has occurred. */
2623 if (dtp
->u
.p
.expanded_read
>= 1)
2624 dtp
->u
.p
.expanded_read
++;
2626 /* Break out of loop if scalar. */
2630 /* Now increment the index vector. */
2635 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2637 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2639 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2641 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2643 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2647 } while (!nml_carry
);
2649 if (dtp
->u
.p
.repeat_count
> 1)
2651 snprintf (nml_err_msg
, nml_err_msg_size
,
2652 "Repeat count too large for namelist object %s", nl
->var_name
);
2662 /* Parses the object name, including array and substring qualifiers. It
2663 iterates over derived type components, touching those components and
2664 setting their loop specifications, if there is a qualifier. If the
2665 object is itself a derived type, its components and subcomponents are
2666 touched. nml_read_obj is called at the end and this reads the data in
2667 the manner specified by the object name. */
2670 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2671 char *nml_err_msg
, size_t nml_err_msg_size
)
2675 namelist_info
* first_nl
= NULL
;
2676 namelist_info
* root_nl
= NULL
;
2677 int dim
, parsed_rank
;
2678 int component_flag
, qualifier_flag
;
2679 index_type clow
, chigh
;
2680 int non_zero_rank_count
;
2682 /* Look for end of input or object name. If '?' or '=?' are encountered
2683 in stdin, print the node names or the namelist to stdout. */
2685 eat_separator (dtp
);
2686 if (dtp
->u
.p
.input_complete
)
2689 if (dtp
->u
.p
.at_eol
)
2690 finish_separator (dtp
);
2691 if (dtp
->u
.p
.input_complete
)
2694 if ((c
= next_char (dtp
)) == EOF
)
2699 if ((c
= next_char (dtp
)) == EOF
)
2703 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2706 nml_query (dtp
, '=');
2710 nml_query (dtp
, '?');
2715 nml_match_name (dtp
, "end", 3);
2716 if (dtp
->u
.p
.nml_read_error
)
2718 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2722 dtp
->u
.p
.input_complete
= 1;
2729 /* Untouch all nodes of the namelist and reset the flags that are set for
2730 derived type components. */
2732 nml_untouch_nodes (dtp
);
2735 non_zero_rank_count
= 0;
2737 /* Get the object name - should '!' and '\n' be permitted separators? */
2745 if (!is_separator (c
))
2746 push_char (dtp
, tolower(c
));
2747 if ((c
= next_char (dtp
)) == EOF
)
2749 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2751 unget_char (dtp
, c
);
2753 /* Check that the name is in the namelist and get pointer to object.
2754 Three error conditions exist: (i) An attempt is being made to
2755 identify a non-existent object, following a failed data read or
2756 (ii) The object name does not exist or (iii) Too many data items
2757 are present for an object. (iii) gives the same error message
2760 push_char (dtp
, '\0');
2764 size_t var_len
= strlen (root_nl
->var_name
);
2766 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2767 char ext_name
[var_len
+ saved_len
+ 1];
2769 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2770 if (dtp
->u
.p
.saved_string
)
2771 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2772 ext_name
[var_len
+ saved_len
] = '\0';
2773 nl
= find_nml_node (dtp
, ext_name
);
2776 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2780 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2781 snprintf (nml_err_msg
, nml_err_msg_size
,
2782 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2785 snprintf (nml_err_msg
, nml_err_msg_size
,
2786 "Cannot match namelist object name %s",
2787 dtp
->u
.p
.saved_string
);
2792 /* Get the length, data length, base pointer and rank of the variable.
2793 Set the default loop specification first. */
2795 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2797 nl
->ls
[dim
].step
= 1;
2798 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2799 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2800 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2803 /* Check to see if there is a qualifier: if so, parse it.*/
2805 if (c
== '(' && nl
->var_rank
)
2808 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2809 nml_err_msg
, &parsed_rank
) == FAILURE
)
2811 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2812 snprintf (nml_err_msg_end
,
2813 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2814 " for namelist variable %s", nl
->var_name
);
2817 if (parsed_rank
> 0)
2818 non_zero_rank_count
++;
2822 if ((c
= next_char (dtp
)) == EOF
)
2824 unget_char (dtp
, c
);
2826 else if (nl
->var_rank
> 0)
2827 non_zero_rank_count
++;
2829 /* Now parse a derived type component. The root namelist_info address
2830 is backed up, as is the previous component level. The component flag
2831 is set and the iteration is made by jumping back to get_name. */
2835 if (nl
->type
!= BT_DERIVED
)
2837 snprintf (nml_err_msg
, nml_err_msg_size
,
2838 "Attempt to get derived component for %s", nl
->var_name
);
2842 if (*pprev_nl
== NULL
|| !component_flag
)
2848 if ((c
= next_char (dtp
)) == EOF
)
2853 /* Parse a character qualifier, if present. chigh = 0 is a default
2854 that signals that the string length = string_length. */
2859 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2861 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2862 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2864 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2867 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2868 snprintf (nml_err_msg_end
,
2869 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2870 " for namelist variable %s", nl
->var_name
);
2874 clow
= ind
[0].start
;
2877 if (ind
[0].step
!= 1)
2879 snprintf (nml_err_msg
, nml_err_msg_size
,
2880 "Step not allowed in substring qualifier"
2881 " for namelist object %s", nl
->var_name
);
2885 if ((c
= next_char (dtp
)) == EOF
)
2887 unget_char (dtp
, c
);
2890 /* Make sure no extraneous qualifiers are there. */
2894 snprintf (nml_err_msg
, nml_err_msg_size
,
2895 "Qualifier for a scalar or non-character namelist object %s",
2900 /* Make sure there is no more than one non-zero rank object. */
2901 if (non_zero_rank_count
> 1)
2903 snprintf (nml_err_msg
, nml_err_msg_size
,
2904 "Multiple sub-objects with non-zero rank in namelist object %s",
2906 non_zero_rank_count
= 0;
2910 /* According to the standard, an equal sign MUST follow an object name. The
2911 following is possibly lax - it allows comments, blank lines and so on to
2912 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2916 eat_separator (dtp
);
2917 if (dtp
->u
.p
.input_complete
)
2920 if (dtp
->u
.p
.at_eol
)
2921 finish_separator (dtp
);
2922 if (dtp
->u
.p
.input_complete
)
2925 if ((c
= next_char (dtp
)) == EOF
)
2930 snprintf (nml_err_msg
, nml_err_msg_size
,
2931 "Equal sign must follow namelist object name %s",
2935 /* If a derived type, touch its components and restore the root
2936 namelist_info if we have parsed a qualified derived type
2939 if (nl
->type
== BT_DERIVED
)
2940 nml_touch_nodes (nl
);
2944 if (first_nl
->var_rank
== 0)
2946 if (component_flag
&& qualifier_flag
)
2953 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2954 clow
, chigh
) == FAILURE
)
2964 /* Entry point for namelist input. Goes through input until namelist name
2965 is matched. Then cycles through nml_get_obj_data until the input is
2966 completed or there is an error. */
2969 namelist_read (st_parameter_dt
*dtp
)
2972 char nml_err_msg
[200];
2973 /* Pointer to the previously read object, in case attempt is made to read
2974 new object name. Should this fail, error message can give previous
2976 namelist_info
*prev_nl
= NULL
;
2978 dtp
->u
.p
.namelist_mode
= 1;
2979 dtp
->u
.p
.input_complete
= 0;
2980 dtp
->u
.p
.expanded_read
= 0;
2982 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2983 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2984 node names or namelist on stdout. */
2987 c
= next_char (dtp
);
2999 c
= next_char (dtp
);
3001 nml_query (dtp
, '=');
3003 unget_char (dtp
, c
);
3007 nml_query (dtp
, '?');
3016 /* Match the name of the namelist. */
3018 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3020 if (dtp
->u
.p
.nml_read_error
)
3023 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
3024 c
= next_char (dtp
);
3025 if (!is_separator(c
) && c
!= '!')
3027 unget_char (dtp
, c
);
3031 unget_char (dtp
, c
);
3032 eat_separator (dtp
);
3034 /* Ready to read namelist objects. If there is an error in input
3035 from stdin, output the error message and continue. */
3037 while (!dtp
->u
.p
.input_complete
)
3039 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3042 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3044 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3055 /* All namelist error calls return from here */
3058 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);