1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
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
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt
*dtp
, char c
)
76 if (dtp
->u
.p
.saved_string
== NULL
)
78 dtp
->u
.p
.saved_string
= get_mem (SCRATCH_SIZE
);
79 // memset below should be commented out.
80 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
81 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
82 dtp
->u
.p
.saved_used
= 0;
85 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
87 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
88 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
90 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
91 dtp
->u
.p
.saved_string
= new;
93 // Also this should not be necessary.
94 memset (new + dtp
->u
.p
.saved_used
, 0,
95 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
99 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
103 /* Free the input buffer if necessary. */
106 free_saved (st_parameter_dt
*dtp
)
108 if (dtp
->u
.p
.saved_string
== NULL
)
111 free (dtp
->u
.p
.saved_string
);
113 dtp
->u
.p
.saved_string
= NULL
;
114 dtp
->u
.p
.saved_used
= 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt
*dtp
)
123 dtp
->u
.p
.item_count
= 0;
124 dtp
->u
.p
.line_buffer_enabled
= 0;
126 if (dtp
->u
.p
.line_buffer
== NULL
)
129 free (dtp
->u
.p
.line_buffer
);
130 dtp
->u
.p
.line_buffer
= NULL
;
135 next_char (st_parameter_dt
*dtp
)
141 if (dtp
->u
.p
.last_char
!= EOF
- 1)
144 c
= dtp
->u
.p
.last_char
;
145 dtp
->u
.p
.last_char
= EOF
- 1;
149 /* Read from line_buffer if enabled. */
151 if (dtp
->u
.p
.line_buffer_enabled
)
155 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
156 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
158 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
159 dtp
->u
.p
.item_count
++;
163 dtp
->u
.p
.item_count
= 0;
164 dtp
->u
.p
.line_buffer_enabled
= 0;
167 /* Handle the end-of-record and end-of-file conditions for
168 internal array unit. */
169 if (is_array_io (dtp
))
174 /* Check for "end-of-record" condition. */
175 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
180 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
183 /* Check for "end-of-file" condition. */
190 record
*= dtp
->u
.p
.current_unit
->recl
;
191 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
194 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
199 /* Get the next character and handle end-of-record conditions. */
201 if (is_internal_unit (dtp
))
204 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
208 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
212 if (is_array_io (dtp
))
214 /* Check whether we hit EOF. */
217 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
220 dtp
->u
.p
.current_unit
->bytes_left
--;
235 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
236 if (c
!= EOF
&& is_stream_io (dtp
))
237 dtp
->u
.p
.current_unit
->strm_pos
++;
240 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
245 /* Push a character back onto the input. */
248 unget_char (st_parameter_dt
*dtp
, int c
)
250 dtp
->u
.p
.last_char
= c
;
254 /* Skip over spaces in the input. Returns the nonspace character that
255 terminated the eating and also places it back on the input. */
258 eat_spaces (st_parameter_dt
*dtp
)
264 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
271 /* This function reads characters through to the end of the current
272 line and just ignores them. Returns 0 for success and LIBERROR_END
276 eat_line (st_parameter_dt
*dtp
)
282 while (c
!= EOF
&& c
!= '\n');
289 /* Skip over a separator. Technically, we don't always eat the whole
290 separator. This is because if we've processed the last input item,
291 then a separator is unnecessary. Plus the fact that operating
292 systems usually deliver console input on a line basis.
294 The upshot is that if we see a newline as part of reading a
295 separator, we stop reading. If there are more input items, we
296 continue reading the separator with finish_separator() which takes
297 care of the fact that we may or may not have seen a comma as part
300 Returns 0 for success, and non-zero error code otherwise. */
303 eat_separator (st_parameter_dt
*dtp
)
309 dtp
->u
.p
.comma_flag
= 0;
311 if ((c
= next_char (dtp
)) == EOF
)
316 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
323 dtp
->u
.p
.comma_flag
= 1;
328 dtp
->u
.p
.input_complete
= 1;
333 if ((n
= next_char(dtp
)) == EOF
)
343 if (dtp
->u
.p
.namelist_mode
)
347 if ((c
= next_char (dtp
)) == EOF
)
351 err
= eat_line (dtp
);
357 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
363 if (dtp
->u
.p
.namelist_mode
)
364 { /* Eat a namelist comment. */
365 err
= eat_line (dtp
);
372 /* Fall Through... */
382 /* Finish processing a separator that was interrupted by a newline.
383 If we're here, then another data item is present, so we finish what
384 we started on the previous line. Return 0 on success, error code
388 finish_separator (st_parameter_dt
*dtp
)
396 if ((c
= next_char (dtp
)) == EOF
)
401 if (dtp
->u
.p
.comma_flag
)
405 if ((c
= eat_spaces (dtp
)) == EOF
)
407 if (c
== '\n' || c
== '\r')
414 dtp
->u
.p
.input_complete
= 1;
415 if (!dtp
->u
.p
.namelist_mode
)
424 if (dtp
->u
.p
.namelist_mode
)
426 err
= eat_line (dtp
);
440 /* This function is needed to catch bad conversions so that namelist can
441 attempt to see if dtp->u.p.saved_string contains a new object name rather
445 nml_bad_return (st_parameter_dt
*dtp
, char c
)
447 if (dtp
->u
.p
.namelist_mode
)
449 dtp
->u
.p
.nml_read_error
= 1;
456 /* Convert an unsigned string to an integer. The length value is -1
457 if we are working on a repeat count. Returns nonzero if we have a
458 range problem. As a side effect, frees the dtp->u.p.saved_string. */
461 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
463 char c
, *buffer
, message
[MSGLEN
];
465 GFC_INTEGER_LARGEST v
, max
, max10
;
467 buffer
= dtp
->u
.p
.saved_string
;
470 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
495 set_integer (dtp
->u
.p
.value
, v
, length
);
499 dtp
->u
.p
.repeat_count
= v
;
501 if (dtp
->u
.p
.repeat_count
== 0)
503 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
504 dtp
->u
.p
.item_count
);
506 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
516 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
517 dtp
->u
.p
.item_count
);
519 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
520 dtp
->u
.p
.item_count
);
523 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
529 /* Parse a repeat count for logical and complex values which cannot
530 begin with a digit. Returns nonzero if we are done, zero if we
531 should continue on. */
534 parse_repeat (st_parameter_dt
*dtp
)
536 char message
[MSGLEN
];
539 if ((c
= next_char (dtp
)) == EOF
)
563 repeat
= 10 * repeat
+ c
- '0';
565 if (repeat
> MAX_REPEAT
)
567 snprintf (message
, MSGLEN
,
568 "Repeat count overflow in item %d of list input",
569 dtp
->u
.p
.item_count
);
571 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
580 snprintf (message
, MSGLEN
,
581 "Zero repeat count in item %d of list input",
582 dtp
->u
.p
.item_count
);
584 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
596 dtp
->u
.p
.repeat_count
= repeat
;
609 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
610 dtp
->u
.p
.item_count
);
611 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
616 /* To read a logical we have to look ahead in the input stream to make sure
617 there is not an equal sign indicating a variable name. To do this we use
618 line_buffer to point to a temporary buffer, pushing characters there for
619 possible later reading. */
622 l_push_char (st_parameter_dt
*dtp
, char c
)
624 if (dtp
->u
.p
.line_buffer
== NULL
)
626 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
627 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
630 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
634 /* Read a logical character on the input. */
637 read_logical (st_parameter_dt
*dtp
, int length
)
639 char message
[MSGLEN
];
642 if (parse_repeat (dtp
))
645 c
= tolower (next_char (dtp
));
646 l_push_char (dtp
, c
);
652 l_push_char (dtp
, c
);
654 if (!is_separator(c
) && c
!= EOF
)
662 l_push_char (dtp
, c
);
664 if (!is_separator(c
) && c
!= EOF
)
671 c
= tolower (next_char (dtp
));
689 return; /* Null value. */
692 /* Save the character in case it is the beginning
693 of the next object name. */
698 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
699 dtp
->u
.p
.saved_length
= length
;
701 /* Eat trailing garbage. */
704 while (c
!= EOF
&& !is_separator (c
));
708 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
715 for(i
= 0; i
< 63; i
++)
720 /* All done if this is not a namelist read. */
721 if (!dtp
->u
.p
.namelist_mode
)
734 l_push_char (dtp
, c
);
737 dtp
->u
.p
.nml_read_error
= 1;
738 dtp
->u
.p
.line_buffer_enabled
= 1;
739 dtp
->u
.p
.item_count
= 0;
749 if (nml_bad_return (dtp
, c
))
760 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
761 dtp
->u
.p
.item_count
);
762 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
767 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
768 dtp
->u
.p
.saved_length
= length
;
769 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
775 /* Reading integers is tricky because we can actually be reading a
776 repeat count. We have to store the characters in a buffer because
777 we could be reading an integer that is larger than the default int
778 used for repeat counts. */
781 read_integer (st_parameter_dt
*dtp
, int length
)
783 char message
[MSGLEN
];
793 /* Fall through... */
796 if ((c
= next_char (dtp
)) == EOF
)
800 CASE_SEPARATORS
: /* Single null. */
813 /* Take care of what may be a repeat count. */
825 push_char (dtp
, '\0');
828 CASE_SEPARATORS
: /* Not a repeat count. */
838 if (convert_integer (dtp
, -1, 0))
841 /* Get the real integer. */
843 if ((c
= next_char (dtp
)) == EOF
)
857 /* Fall through... */
889 if (nml_bad_return (dtp
, c
))
900 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
901 dtp
->u
.p
.item_count
);
902 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
910 push_char (dtp
, '\0');
911 if (convert_integer (dtp
, length
, negative
))
918 dtp
->u
.p
.saved_type
= BT_INTEGER
;
922 /* Read a character variable. */
925 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
927 char quote
, message
[MSGLEN
];
930 quote
= ' '; /* Space means no quote character. */
932 if ((c
= next_char (dtp
)) == EOF
)
941 unget_char (dtp
, c
); /* NULL value. */
951 if (dtp
->u
.p
.namelist_mode
)
961 /* Deal with a possible repeat count. */
965 if ((c
= next_char (dtp
)) == EOF
)
975 goto done
; /* String was only digits! */
978 push_char (dtp
, '\0');
983 goto get_string
; /* Not a repeat count after all. */
988 if (convert_integer (dtp
, -1, 0))
991 /* Now get the real string. */
993 if ((c
= next_char (dtp
)) == EOF
)
998 unget_char (dtp
, c
); /* Repeated NULL values. */
1015 if ((c
= next_char (dtp
)) == EOF
)
1027 /* See if we have a doubled quote character or the end of
1030 if ((c
= next_char (dtp
)) == EOF
)
1034 push_char (dtp
, quote
);
1038 unget_char (dtp
, c
);
1044 unget_char (dtp
, c
);
1048 if (c
!= '\n' && c
!= '\r')
1058 /* At this point, we have to have a separator, or else the string is
1061 c
= next_char (dtp
);
1063 if (is_separator (c
) || c
== '!' || c
== EOF
)
1065 unget_char (dtp
, c
);
1066 eat_separator (dtp
);
1067 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1073 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1074 dtp
->u
.p
.item_count
);
1075 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1085 /* Parse a component of a complex constant or a real number that we
1086 are sure is already there. This is a straight real number parser. */
1089 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1091 char message
[MSGLEN
];
1094 if ((c
= next_char (dtp
)) == EOF
)
1097 if (c
== '-' || c
== '+')
1100 if ((c
= next_char (dtp
)) == EOF
)
1104 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1107 if (!isdigit (c
) && c
!= '.')
1109 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1117 seen_dp
= (c
== '.') ? 1 : 0;
1121 if ((c
= next_char (dtp
)) == EOF
)
1123 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1143 push_char (dtp
, 'e');
1148 push_char (dtp
, 'e');
1150 if ((c
= next_char (dtp
)) == EOF
)
1163 if ((c
= next_char (dtp
)) == EOF
)
1165 if (c
!= '-' && c
!= '+')
1166 push_char (dtp
, '+');
1170 c
= next_char (dtp
);
1181 if ((c
= next_char (dtp
)) == EOF
)
1190 unget_char (dtp
, c
);
1199 unget_char (dtp
, c
);
1200 push_char (dtp
, '\0');
1202 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1208 unget_char (dtp
, c
);
1209 push_char (dtp
, '\0');
1211 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1217 /* Match INF and Infinity. */
1218 if ((c
== 'i' || c
== 'I')
1219 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1220 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1222 c
= next_char (dtp
);
1223 if ((c
!= 'i' && c
!= 'I')
1224 || ((c
== 'i' || c
== 'I')
1225 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1226 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1227 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1228 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1229 && (c
= next_char (dtp
))))
1231 if (is_separator (c
))
1232 unget_char (dtp
, c
);
1233 push_char (dtp
, 'i');
1234 push_char (dtp
, 'n');
1235 push_char (dtp
, 'f');
1239 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1240 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1241 && (c
= next_char (dtp
)))
1243 if (is_separator (c
))
1244 unget_char (dtp
, c
);
1245 push_char (dtp
, 'n');
1246 push_char (dtp
, 'a');
1247 push_char (dtp
, 'n');
1249 /* Match "NAN(alphanum)". */
1252 for ( ; c
!= ')'; c
= next_char (dtp
))
1253 if (is_separator (c
))
1256 c
= next_char (dtp
);
1257 if (is_separator (c
))
1258 unget_char (dtp
, c
);
1265 if (nml_bad_return (dtp
, c
))
1276 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1277 dtp
->u
.p
.item_count
);
1278 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1284 /* Reading a complex number is straightforward because we can tell
1285 what it is right away. */
1288 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1290 char message
[MSGLEN
];
1293 if (parse_repeat (dtp
))
1296 c
= next_char (dtp
);
1303 unget_char (dtp
, c
);
1304 eat_separator (dtp
);
1313 c
= next_char (dtp
);
1314 if (c
== '\n' || c
== '\r')
1317 unget_char (dtp
, c
);
1319 if (parse_real (dtp
, dest
, kind
))
1324 c
= next_char (dtp
);
1325 if (c
== '\n' || c
== '\r')
1328 unget_char (dtp
, c
);
1331 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1336 c
= next_char (dtp
);
1337 if (c
== '\n' || c
== '\r')
1340 unget_char (dtp
, c
);
1342 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1347 c
= next_char (dtp
);
1348 if (c
== '\n' || c
== '\r')
1351 unget_char (dtp
, c
);
1353 if (next_char (dtp
) != ')')
1356 c
= next_char (dtp
);
1357 if (!is_separator (c
))
1360 unget_char (dtp
, c
);
1361 eat_separator (dtp
);
1364 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1369 if (nml_bad_return (dtp
, c
))
1380 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1381 dtp
->u
.p
.item_count
);
1382 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1386 /* Parse a real number with a possible repeat count. */
1389 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1391 char message
[MSGLEN
];
1398 c
= next_char (dtp
);
1399 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1417 unget_char (dtp
, c
); /* Single null. */
1418 eat_separator (dtp
);
1431 /* Get the digit string that might be a repeat count. */
1435 c
= next_char (dtp
);
1436 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1460 push_char (dtp
, 'e');
1462 c
= next_char (dtp
);
1466 push_char (dtp
, '\0');
1470 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1471 unget_char (dtp
, c
);
1480 if (convert_integer (dtp
, -1, 0))
1483 /* Now get the number itself. */
1485 if ((c
= next_char (dtp
)) == EOF
)
1487 if (is_separator (c
))
1488 { /* Repeated null value. */
1489 unget_char (dtp
, c
);
1490 eat_separator (dtp
);
1494 if (c
!= '-' && c
!= '+')
1495 push_char (dtp
, '+');
1500 if ((c
= next_char (dtp
)) == EOF
)
1504 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1507 if (!isdigit (c
) && c
!= '.')
1509 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1528 c
= next_char (dtp
);
1529 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1557 push_char (dtp
, 'e');
1559 c
= next_char (dtp
);
1568 push_char (dtp
, 'e');
1570 if ((c
= next_char (dtp
)) == EOF
)
1572 if (c
!= '+' && c
!= '-')
1573 push_char (dtp
, '+');
1577 c
= next_char (dtp
);
1587 c
= next_char (dtp
);
1604 unget_char (dtp
, c
);
1605 eat_separator (dtp
);
1606 push_char (dtp
, '\0');
1607 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1611 dtp
->u
.p
.saved_type
= BT_REAL
;
1615 l_push_char (dtp
, c
);
1618 /* Match INF and Infinity. */
1619 if (c
== 'i' || c
== 'I')
1621 c
= next_char (dtp
);
1622 l_push_char (dtp
, c
);
1623 if (c
!= 'n' && c
!= 'N')
1625 c
= next_char (dtp
);
1626 l_push_char (dtp
, c
);
1627 if (c
!= 'f' && c
!= 'F')
1629 c
= next_char (dtp
);
1630 l_push_char (dtp
, c
);
1631 if (!is_separator (c
))
1633 if (c
!= 'i' && c
!= 'I')
1635 c
= next_char (dtp
);
1636 l_push_char (dtp
, c
);
1637 if (c
!= 'n' && c
!= 'N')
1639 c
= next_char (dtp
);
1640 l_push_char (dtp
, c
);
1641 if (c
!= 'i' && c
!= 'I')
1643 c
= next_char (dtp
);
1644 l_push_char (dtp
, c
);
1645 if (c
!= 't' && c
!= 'T')
1647 c
= next_char (dtp
);
1648 l_push_char (dtp
, c
);
1649 if (c
!= 'y' && c
!= 'Y')
1651 c
= next_char (dtp
);
1652 l_push_char (dtp
, c
);
1658 c
= next_char (dtp
);
1659 l_push_char (dtp
, c
);
1660 if (c
!= 'a' && c
!= 'A')
1662 c
= next_char (dtp
);
1663 l_push_char (dtp
, c
);
1664 if (c
!= 'n' && c
!= 'N')
1666 c
= next_char (dtp
);
1667 l_push_char (dtp
, c
);
1669 /* Match NAN(alphanum). */
1672 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1673 if (is_separator (c
))
1676 l_push_char (dtp
, c
);
1678 l_push_char (dtp
, ')');
1679 c
= next_char (dtp
);
1680 l_push_char (dtp
, c
);
1684 if (!is_separator (c
))
1687 if (dtp
->u
.p
.namelist_mode
)
1689 if (c
== ' ' || c
=='\n' || c
== '\r')
1693 if ((c
= next_char (dtp
)) == EOF
)
1696 while (c
== ' ' || c
=='\n' || c
== '\r');
1698 l_push_char (dtp
, c
);
1707 push_char (dtp
, 'i');
1708 push_char (dtp
, 'n');
1709 push_char (dtp
, 'f');
1713 push_char (dtp
, 'n');
1714 push_char (dtp
, 'a');
1715 push_char (dtp
, 'n');
1719 unget_char (dtp
, c
);
1720 eat_separator (dtp
);
1721 push_char (dtp
, '\0');
1722 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1726 dtp
->u
.p
.saved_type
= BT_REAL
;
1730 if (dtp
->u
.p
.namelist_mode
)
1732 dtp
->u
.p
.nml_read_error
= 1;
1733 dtp
->u
.p
.line_buffer_enabled
= 1;
1734 dtp
->u
.p
.item_count
= 0;
1740 if (nml_bad_return (dtp
, c
))
1752 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1753 dtp
->u
.p
.item_count
);
1754 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1758 /* Check the current type against the saved type to make sure they are
1759 compatible. Returns nonzero if incompatible. */
1762 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1764 char message
[MSGLEN
];
1766 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1768 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1769 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1770 dtp
->u
.p
.item_count
);
1772 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1776 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1779 if (dtp
->u
.p
.saved_length
!= len
)
1781 snprintf (message
, MSGLEN
,
1782 "Read kind %d %s where kind %d is required for item %d",
1783 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1784 dtp
->u
.p
.item_count
);
1785 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1793 /* Top level data transfer subroutine for list reads. Because we have
1794 to deal with repeat counts, the data item is always saved after
1795 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1796 greater than one, we copy the data item multiple times. */
1799 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1800 int kind
, size_t size
)
1806 dtp
->u
.p
.namelist_mode
= 0;
1808 if (dtp
->u
.p
.first_item
)
1810 dtp
->u
.p
.first_item
= 0;
1811 dtp
->u
.p
.input_complete
= 0;
1812 dtp
->u
.p
.repeat_count
= 1;
1813 dtp
->u
.p
.at_eol
= 0;
1815 if ((c
= eat_spaces (dtp
)) == EOF
)
1820 if (is_separator (c
))
1822 /* Found a null value. */
1823 eat_separator (dtp
);
1824 dtp
->u
.p
.repeat_count
= 0;
1826 /* eat_separator sets this flag if the separator was a comma. */
1827 if (dtp
->u
.p
.comma_flag
)
1830 /* eat_separator sets this flag if the separator was a \n or \r. */
1831 if (dtp
->u
.p
.at_eol
)
1832 finish_separator (dtp
);
1840 if (dtp
->u
.p
.repeat_count
> 0)
1842 if (check_type (dtp
, type
, kind
))
1847 if (dtp
->u
.p
.input_complete
)
1850 if (dtp
->u
.p
.at_eol
)
1851 finish_separator (dtp
);
1855 /* Trailing spaces prior to end of line. */
1856 if (dtp
->u
.p
.at_eol
)
1857 finish_separator (dtp
);
1860 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1861 dtp
->u
.p
.repeat_count
= 1;
1867 read_integer (dtp
, kind
);
1870 read_logical (dtp
, kind
);
1873 read_character (dtp
, kind
);
1876 read_real (dtp
, p
, kind
);
1877 /* Copy value back to temporary if needed. */
1878 if (dtp
->u
.p
.repeat_count
> 0)
1879 memcpy (dtp
->u
.p
.value
, p
, kind
);
1882 read_complex (dtp
, p
, kind
, size
);
1883 /* Copy value back to temporary if needed. */
1884 if (dtp
->u
.p
.repeat_count
> 0)
1885 memcpy (dtp
->u
.p
.value
, p
, size
);
1888 internal_error (&dtp
->common
, "Bad type for list read");
1891 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1892 dtp
->u
.p
.saved_length
= size
;
1894 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1898 switch (dtp
->u
.p
.saved_type
)
1902 if (dtp
->u
.p
.repeat_count
> 0)
1903 memcpy (p
, dtp
->u
.p
.value
, size
);
1908 memcpy (p
, dtp
->u
.p
.value
, size
);
1912 if (dtp
->u
.p
.saved_string
)
1914 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1915 ? (int) size
: dtp
->u
.p
.saved_used
;
1917 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1920 q
= (gfc_char4_t
*) p
;
1921 for (i
= 0; i
< m
; i
++)
1922 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1926 /* Just delimiters encountered, nothing to copy but SPACE. */
1932 memset (((char *) p
) + m
, ' ', size
- m
);
1935 q
= (gfc_char4_t
*) p
;
1936 for (i
= m
; i
< (int) size
; i
++)
1937 q
[i
] = (unsigned char) ' ';
1946 internal_error (&dtp
->common
, "Bad type for list read");
1949 if (--dtp
->u
.p
.repeat_count
<= 0)
1953 if (err
== LIBERROR_END
)
1960 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1961 size_t size
, size_t nelems
)
1965 size_t stride
= type
== BT_CHARACTER
?
1966 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1971 /* Big loop over all the elements. */
1972 for (elem
= 0; elem
< nelems
; elem
++)
1974 dtp
->u
.p
.item_count
++;
1975 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
1983 /* Finish a list read. */
1986 finish_list_read (st_parameter_dt
*dtp
)
1992 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1994 if (dtp
->u
.p
.at_eol
)
1996 dtp
->u
.p
.at_eol
= 0;
2000 err
= eat_line (dtp
);
2001 if (err
== LIBERROR_END
)
2007 void namelist_read (st_parameter_dt *dtp)
2009 static void nml_match_name (char *name, int len)
2010 static int nml_query (st_parameter_dt *dtp)
2011 static int nml_get_obj_data (st_parameter_dt *dtp,
2012 namelist_info **prev_nl, char *, size_t)
2014 static void nml_untouch_nodes (st_parameter_dt *dtp)
2015 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2017 static int nml_parse_qualifier(descriptor_dimension * ad,
2018 array_loop_spec * ls, int rank, char *)
2019 static void nml_touch_nodes (namelist_info * nl)
2020 static int nml_read_obj (namelist_info *nl, index_type offset,
2021 namelist_info **prev_nl, char *, size_t,
2022 index_type clow, index_type chigh)
2026 /* Inputs a rank-dimensional qualifier, which can contain
2027 singlets, doublets, triplets or ':' with the standard meanings. */
2030 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2031 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
2032 size_t parse_err_msg_size
,
2039 int is_array_section
, is_char
;
2043 is_array_section
= 0;
2044 dtp
->u
.p
.expanded_read
= 0;
2046 /* See if this is a character substring qualifier we are looking for. */
2053 /* The next character in the stream should be the '('. */
2055 if ((c
= next_char (dtp
)) == EOF
)
2058 /* Process the qualifier, by dimension and triplet. */
2060 for (dim
=0; dim
< rank
; dim
++ )
2062 for (indx
=0; indx
<3; indx
++)
2068 /* Process a potential sign. */
2069 if ((c
= next_char (dtp
)) == EOF
)
2081 unget_char (dtp
, c
);
2085 /* Process characters up to the next ':' , ',' or ')'. */
2088 if ((c
= next_char (dtp
)) == EOF
)
2094 is_array_section
= 1;
2098 if ((c
==',' && dim
== rank
-1)
2099 || (c
==')' && dim
< rank
-1))
2102 snprintf (parse_err_msg
, parse_err_msg_size
,
2103 "Bad substring qualifier");
2105 snprintf (parse_err_msg
, parse_err_msg_size
,
2106 "Bad number of index fields");
2115 case ' ': case '\t':
2117 if ((c
= next_char (dtp
) == EOF
))
2123 snprintf (parse_err_msg
, parse_err_msg_size
,
2124 "Bad character in substring qualifier");
2126 snprintf (parse_err_msg
, parse_err_msg_size
,
2127 "Bad character in index");
2131 if ((c
== ',' || c
== ')') && indx
== 0
2132 && dtp
->u
.p
.saved_string
== 0)
2135 snprintf (parse_err_msg
, parse_err_msg_size
,
2136 "Null substring qualifier");
2138 snprintf (parse_err_msg
, parse_err_msg_size
,
2139 "Null index field");
2143 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2144 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2147 snprintf (parse_err_msg
, parse_err_msg_size
,
2148 "Bad substring qualifier");
2150 snprintf (parse_err_msg
, parse_err_msg_size
,
2151 "Bad index triplet");
2155 if (is_char
&& !is_array_section
)
2157 snprintf (parse_err_msg
, parse_err_msg_size
,
2158 "Missing colon in substring qualifier");
2162 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2164 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2165 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2171 /* Now read the index. */
2172 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2175 snprintf (parse_err_msg
, parse_err_msg_size
,
2176 "Bad integer substring qualifier");
2178 snprintf (parse_err_msg
, parse_err_msg_size
,
2179 "Bad integer in index");
2185 /* Feed the index values to the triplet arrays. */
2189 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2191 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2193 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2196 /* Singlet or doublet indices. */
2197 if (c
==',' || c
==')')
2201 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2203 /* If -std=f95/2003 or an array section is specified,
2204 do not allow excess data to be processed. */
2205 if (is_array_section
== 1
2206 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2207 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2208 ls
[dim
].end
= ls
[dim
].start
;
2210 dtp
->u
.p
.expanded_read
= 1;
2213 /* Check for non-zero rank. */
2214 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2221 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2224 dtp
->u
.p
.expanded_read
= 0;
2225 for (i
= 0; i
< dim
; i
++)
2226 ls
[i
].end
= ls
[i
].start
;
2229 /* Check the values of the triplet indices. */
2230 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2231 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2232 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2233 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2236 snprintf (parse_err_msg
, parse_err_msg_size
,
2237 "Substring out of range");
2239 snprintf (parse_err_msg
, parse_err_msg_size
,
2240 "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 snprintf (parse_err_msg
, parse_err_msg_size
,
2248 "Bad range in index %d", dim
+ 1);
2252 /* Initialise the loop index counter. */
2253 ls
[dim
].idx
= ls
[dim
].start
;
2263 static namelist_info
*
2264 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2266 namelist_info
* t
= dtp
->u
.p
.ionml
;
2269 if (strcmp (var_name
, t
->var_name
) == 0)
2279 /* Visits all the components of a derived type that have
2280 not explicitly been identified in the namelist input.
2281 touched is set and the loop specification initialised
2282 to default values */
2285 nml_touch_nodes (namelist_info
* nl
)
2287 index_type len
= strlen (nl
->var_name
) + 1;
2289 char * ext_name
= (char*)get_mem (len
+ 1);
2290 memcpy (ext_name
, nl
->var_name
, len
-1);
2291 memcpy (ext_name
+ len
- 1, "%", 2);
2292 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2294 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2297 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2299 nl
->ls
[dim
].step
= 1;
2300 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2301 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2302 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2312 /* Resets touched for the entire list of nml_nodes, ready for a
2316 nml_untouch_nodes (st_parameter_dt
*dtp
)
2319 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2324 /* Attempts to input name to namelist name. Returns
2325 dtp->u.p.nml_read_error = 1 on no match. */
2328 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2333 dtp
->u
.p
.nml_read_error
= 0;
2334 for (i
= 0; i
< len
; i
++)
2336 c
= next_char (dtp
);
2337 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2339 dtp
->u
.p
.nml_read_error
= 1;
2345 /* If the namelist read is from stdin, output the current state of the
2346 namelist to stdout. This is used to implement the non-standard query
2347 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2348 the names alone are printed. */
2351 nml_query (st_parameter_dt
*dtp
, char c
)
2353 gfc_unit
* temp_unit
;
2358 static const index_type endlen
= 3;
2359 static const char endl
[] = "\r\n";
2360 static const char nmlend
[] = "&end\r\n";
2362 static const index_type endlen
= 2;
2363 static const char endl
[] = "\n";
2364 static const char nmlend
[] = "&end\n";
2367 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2370 /* Store the current unit and transfer to stdout. */
2372 temp_unit
= dtp
->u
.p
.current_unit
;
2373 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2375 if (dtp
->u
.p
.current_unit
)
2377 dtp
->u
.p
.mode
= WRITING
;
2378 next_record (dtp
, 0);
2380 /* Write the namelist in its entirety. */
2383 namelist_write (dtp
);
2385 /* Or write the list of names. */
2389 /* "&namelist_name\n" */
2391 len
= dtp
->namelist_name_len
;
2392 p
= write_block (dtp
, len
+ endlen
);
2396 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2397 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2398 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2402 len
= strlen (nl
->var_name
);
2403 p
= write_block (dtp
, len
+ endlen
);
2407 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2408 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2413 p
= write_block (dtp
, endlen
+ 3);
2415 memcpy (p
, &nmlend
, endlen
+ 3);
2418 /* Flush the stream to force immediate output. */
2420 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2421 sflush (dtp
->u
.p
.current_unit
->s
);
2422 unlock_unit (dtp
->u
.p
.current_unit
);
2427 /* Restore the current unit. */
2429 dtp
->u
.p
.current_unit
= temp_unit
;
2430 dtp
->u
.p
.mode
= READING
;
2434 /* Reads and stores the input for the namelist object nl. For an array,
2435 the function loops over the ranges defined by the loop specification.
2436 This default to all the data or to the specification from a qualifier.
2437 nml_read_obj recursively calls itself to read derived types. It visits
2438 all its own components but only reads data for those that were touched
2439 when the name was parsed. If a read error is encountered, an attempt is
2440 made to return to read a new object name because the standard allows too
2441 little data to be available. On the other hand, too much data is an
2445 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2446 namelist_info
**pprev_nl
, char *nml_err_msg
,
2447 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2449 namelist_info
* cmp
;
2456 size_t obj_name_len
;
2459 /* This object not touched in name parsing. */
2464 dtp
->u
.p
.repeat_count
= 0;
2476 dlen
= size_from_real_kind (len
);
2480 dlen
= size_from_complex_kind (len
);
2484 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2493 /* Update the pointer to the data, using the current index vector */
2495 pdata
= (void*)(nl
->mem_pos
+ offset
);
2496 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2497 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2498 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2499 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2501 /* Reset the error flag and try to read next value, if
2502 dtp->u.p.repeat_count=0 */
2504 dtp
->u
.p
.nml_read_error
= 0;
2506 if (--dtp
->u
.p
.repeat_count
<= 0)
2508 if (dtp
->u
.p
.input_complete
)
2510 if (dtp
->u
.p
.at_eol
)
2511 finish_separator (dtp
);
2512 if (dtp
->u
.p
.input_complete
)
2515 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2521 read_integer (dtp
, len
);
2525 read_logical (dtp
, len
);
2529 read_character (dtp
, len
);
2533 /* Need to copy data back from the real location to the temp in order
2534 to handle nml reads into arrays. */
2535 read_real (dtp
, pdata
, len
);
2536 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2540 /* Same as for REAL, copy back to temp. */
2541 read_complex (dtp
, pdata
, len
, dlen
);
2542 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2546 obj_name_len
= strlen (nl
->var_name
) + 1;
2547 obj_name
= get_mem (obj_name_len
+1);
2548 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2549 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2551 /* If reading a derived type, disable the expanded read warning
2552 since a single object can have multiple reads. */
2553 dtp
->u
.p
.expanded_read
= 0;
2555 /* Now loop over the components. Update the component pointer
2556 with the return value from nml_write_obj. This loop jumps
2557 past nested derived types by testing if the potential
2558 component name contains '%'. */
2560 for (cmp
= nl
->next
;
2562 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2563 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2567 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2568 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2569 clow
, chigh
) == FAILURE
)
2575 if (dtp
->u
.p
.input_complete
)
2586 snprintf (nml_err_msg
, nml_err_msg_size
,
2587 "Bad type for namelist object %s", nl
->var_name
);
2588 internal_error (&dtp
->common
, nml_err_msg
);
2593 /* The standard permits array data to stop short of the number of
2594 elements specified in the loop specification. In this case, we
2595 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2596 nml_get_obj_data and an attempt is made to read object name. */
2599 if (dtp
->u
.p
.nml_read_error
)
2601 dtp
->u
.p
.expanded_read
= 0;
2605 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2607 dtp
->u
.p
.expanded_read
= 0;
2611 switch (dtp
->u
.p
.saved_type
)
2618 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2622 if (dlen
< dtp
->u
.p
.saved_used
)
2624 if (compile_options
.bounds_check
)
2626 snprintf (nml_err_msg
, nml_err_msg_size
,
2627 "Namelist object '%s' truncated on read.",
2629 generate_warning (&dtp
->common
, nml_err_msg
);
2634 m
= dtp
->u
.p
.saved_used
;
2635 pdata
= (void*)( pdata
+ clow
- 1 );
2636 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2638 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2645 /* Warn if a non-standard expanded read occurs. A single read of a
2646 single object is acceptable. If a second read occurs, issue a warning
2647 and set the flag to zero to prevent further warnings. */
2648 if (dtp
->u
.p
.expanded_read
== 2)
2650 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2651 dtp
->u
.p
.expanded_read
= 0;
2654 /* If the expanded read warning flag is set, increment it,
2655 indicating that a single read has occurred. */
2656 if (dtp
->u
.p
.expanded_read
>= 1)
2657 dtp
->u
.p
.expanded_read
++;
2659 /* Break out of loop if scalar. */
2663 /* Now increment the index vector. */
2668 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2670 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2672 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2674 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2676 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2680 } while (!nml_carry
);
2682 if (dtp
->u
.p
.repeat_count
> 1)
2684 snprintf (nml_err_msg
, nml_err_msg_size
,
2685 "Repeat count too large for namelist object %s", nl
->var_name
);
2695 /* Parses the object name, including array and substring qualifiers. It
2696 iterates over derived type components, touching those components and
2697 setting their loop specifications, if there is a qualifier. If the
2698 object is itself a derived type, its components and subcomponents are
2699 touched. nml_read_obj is called at the end and this reads the data in
2700 the manner specified by the object name. */
2703 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2704 char *nml_err_msg
, size_t nml_err_msg_size
)
2708 namelist_info
* first_nl
= NULL
;
2709 namelist_info
* root_nl
= NULL
;
2710 int dim
, parsed_rank
;
2711 int component_flag
, qualifier_flag
;
2712 index_type clow
, chigh
;
2713 int non_zero_rank_count
;
2715 /* Look for end of input or object name. If '?' or '=?' are encountered
2716 in stdin, print the node names or the namelist to stdout. */
2718 eat_separator (dtp
);
2719 if (dtp
->u
.p
.input_complete
)
2722 if (dtp
->u
.p
.at_eol
)
2723 finish_separator (dtp
);
2724 if (dtp
->u
.p
.input_complete
)
2727 if ((c
= next_char (dtp
)) == EOF
)
2732 if ((c
= next_char (dtp
)) == EOF
)
2736 snprintf (nml_err_msg
, nml_err_msg_size
,
2737 "namelist read: misplaced = sign");
2740 nml_query (dtp
, '=');
2744 nml_query (dtp
, '?');
2749 nml_match_name (dtp
, "end", 3);
2750 if (dtp
->u
.p
.nml_read_error
)
2752 snprintf (nml_err_msg
, nml_err_msg_size
,
2753 "namelist not terminated with / or &end");
2757 dtp
->u
.p
.input_complete
= 1;
2764 /* Untouch all nodes of the namelist and reset the flags that are set for
2765 derived type components. */
2767 nml_untouch_nodes (dtp
);
2770 non_zero_rank_count
= 0;
2772 /* Get the object name - should '!' and '\n' be permitted separators? */
2780 if (!is_separator (c
))
2781 push_char (dtp
, tolower(c
));
2782 if ((c
= next_char (dtp
)) == EOF
)
2784 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2786 unget_char (dtp
, c
);
2788 /* Check that the name is in the namelist and get pointer to object.
2789 Three error conditions exist: (i) An attempt is being made to
2790 identify a non-existent object, following a failed data read or
2791 (ii) The object name does not exist or (iii) Too many data items
2792 are present for an object. (iii) gives the same error message
2795 push_char (dtp
, '\0');
2799 size_t var_len
= strlen (root_nl
->var_name
);
2801 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2802 char ext_name
[var_len
+ saved_len
+ 1];
2804 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2805 if (dtp
->u
.p
.saved_string
)
2806 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2807 ext_name
[var_len
+ saved_len
] = '\0';
2808 nl
= find_nml_node (dtp
, ext_name
);
2811 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2815 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2816 snprintf (nml_err_msg
, nml_err_msg_size
,
2817 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2820 snprintf (nml_err_msg
, nml_err_msg_size
,
2821 "Cannot match namelist object name %s",
2822 dtp
->u
.p
.saved_string
);
2827 /* Get the length, data length, base pointer and rank of the variable.
2828 Set the default loop specification first. */
2830 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2832 nl
->ls
[dim
].step
= 1;
2833 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2834 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2835 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2838 /* Check to see if there is a qualifier: if so, parse it.*/
2840 if (c
== '(' && nl
->var_rank
)
2843 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2844 nml_err_msg
, nml_err_msg_size
,
2845 &parsed_rank
) == FAILURE
)
2847 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2848 snprintf (nml_err_msg_end
,
2849 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2850 " for namelist variable %s", nl
->var_name
);
2853 if (parsed_rank
> 0)
2854 non_zero_rank_count
++;
2858 if ((c
= next_char (dtp
)) == EOF
)
2860 unget_char (dtp
, c
);
2862 else if (nl
->var_rank
> 0)
2863 non_zero_rank_count
++;
2865 /* Now parse a derived type component. The root namelist_info address
2866 is backed up, as is the previous component level. The component flag
2867 is set and the iteration is made by jumping back to get_name. */
2871 if (nl
->type
!= BT_DERIVED
)
2873 snprintf (nml_err_msg
, nml_err_msg_size
,
2874 "Attempt to get derived component for %s", nl
->var_name
);
2878 if (*pprev_nl
== NULL
|| !component_flag
)
2884 if ((c
= next_char (dtp
)) == EOF
)
2889 /* Parse a character qualifier, if present. chigh = 0 is a default
2890 that signals that the string length = string_length. */
2895 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2897 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2898 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2900 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
,
2901 nml_err_msg_size
, &parsed_rank
)
2904 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2905 snprintf (nml_err_msg_end
,
2906 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2907 " for namelist variable %s", nl
->var_name
);
2911 clow
= ind
[0].start
;
2914 if (ind
[0].step
!= 1)
2916 snprintf (nml_err_msg
, nml_err_msg_size
,
2917 "Step not allowed in substring qualifier"
2918 " for namelist object %s", nl
->var_name
);
2922 if ((c
= next_char (dtp
)) == EOF
)
2924 unget_char (dtp
, c
);
2927 /* Make sure no extraneous qualifiers are there. */
2931 snprintf (nml_err_msg
, nml_err_msg_size
,
2932 "Qualifier for a scalar or non-character namelist object %s",
2937 /* Make sure there is no more than one non-zero rank object. */
2938 if (non_zero_rank_count
> 1)
2940 snprintf (nml_err_msg
, nml_err_msg_size
,
2941 "Multiple sub-objects with non-zero rank in namelist object %s",
2943 non_zero_rank_count
= 0;
2947 /* According to the standard, an equal sign MUST follow an object name. The
2948 following is possibly lax - it allows comments, blank lines and so on to
2949 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2953 eat_separator (dtp
);
2954 if (dtp
->u
.p
.input_complete
)
2957 if (dtp
->u
.p
.at_eol
)
2958 finish_separator (dtp
);
2959 if (dtp
->u
.p
.input_complete
)
2962 if ((c
= next_char (dtp
)) == EOF
)
2967 snprintf (nml_err_msg
, nml_err_msg_size
,
2968 "Equal sign must follow namelist object name %s",
2972 /* If a derived type, touch its components and restore the root
2973 namelist_info if we have parsed a qualified derived type
2976 if (nl
->type
== BT_DERIVED
)
2977 nml_touch_nodes (nl
);
2981 if (first_nl
->var_rank
== 0)
2983 if (component_flag
&& qualifier_flag
)
2990 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2991 clow
, chigh
) == FAILURE
)
3001 /* Entry point for namelist input. Goes through input until namelist name
3002 is matched. Then cycles through nml_get_obj_data until the input is
3003 completed or there is an error. */
3006 namelist_read (st_parameter_dt
*dtp
)
3009 char nml_err_msg
[200];
3011 /* Initialize the error string buffer just in case we get an unexpected fail
3012 somewhere and end up at nml_err_ret. */
3013 strcpy (nml_err_msg
, "Internal namelist read error");
3015 /* Pointer to the previously read object, in case attempt is made to read
3016 new object name. Should this fail, error message can give previous
3018 namelist_info
*prev_nl
= NULL
;
3020 dtp
->u
.p
.namelist_mode
= 1;
3021 dtp
->u
.p
.input_complete
= 0;
3022 dtp
->u
.p
.expanded_read
= 0;
3024 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3025 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3026 node names or namelist on stdout. */
3029 c
= next_char (dtp
);
3041 c
= next_char (dtp
);
3043 nml_query (dtp
, '=');
3045 unget_char (dtp
, c
);
3049 nml_query (dtp
, '?');
3058 /* Match the name of the namelist. */
3060 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3062 if (dtp
->u
.p
.nml_read_error
)
3065 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
3066 c
= next_char (dtp
);
3067 if (!is_separator(c
) && c
!= '!')
3069 unget_char (dtp
, c
);
3073 unget_char (dtp
, c
);
3074 eat_separator (dtp
);
3076 /* Ready to read namelist objects. If there is an error in input
3077 from stdin, output the error message and continue. */
3079 while (!dtp
->u
.p
.input_complete
)
3081 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3084 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3086 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3089 /* Reset the previous namelist pointer if we know we are not going
3090 to be doing multiple reads within a single namelist object. */
3091 if (prev_nl
&& prev_nl
->var_rank
== 0)
3102 /* All namelist error calls return from here */
3105 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);