1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
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 95 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 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
39 /* List directed input. Several parsing subroutines are practically
40 reimplemented from formatted input, the reason being that there are
41 all kinds of small differences between formatted and list directed
45 /* Subroutines for reading characters from the input. Because a
46 repeat count is ambiguous with an integer, we have to read the
47 whole digit string before seeing if there is a '*' which signals
48 the repeat count. Since we can have a lot of potential leading
49 zeros, we have to be able to back up by arbitrary amount. Because
50 the input might not be seekable, we have to buffer the data
53 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
54 case '5': case '6': case '7': case '8': case '9'
56 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
59 /* This macro assumes that we're operating on a variable. */
61 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
62 || c == '\t' || c == '\r' || c == ';')
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
70 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
73 /* Save a character to a string buffer, enlarging it as necessary. */
76 push_char (st_parameter_dt
*dtp
, char c
)
80 if (dtp
->u
.p
.saved_string
== NULL
)
82 if (dtp
->u
.p
.scratch
== NULL
)
83 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
84 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
85 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
86 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
87 dtp
->u
.p
.saved_used
= 0;
90 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
92 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
93 new = get_mem (2 * dtp
->u
.p
.saved_length
);
95 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
97 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
98 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
99 free_mem (dtp
->u
.p
.saved_string
);
101 dtp
->u
.p
.saved_string
= new;
104 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
108 /* Free the input buffer if necessary. */
111 free_saved (st_parameter_dt
*dtp
)
113 if (dtp
->u
.p
.saved_string
== NULL
)
116 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
117 free_mem (dtp
->u
.p
.saved_string
);
119 dtp
->u
.p
.saved_string
= NULL
;
120 dtp
->u
.p
.saved_used
= 0;
124 /* Free the line buffer if necessary. */
127 free_line (st_parameter_dt
*dtp
)
129 dtp
->u
.p
.item_count
= 0;
130 dtp
->u
.p
.line_buffer_enabled
= 0;
132 if (dtp
->u
.p
.line_buffer
== NULL
)
135 free_mem (dtp
->u
.p
.line_buffer
);
136 dtp
->u
.p
.line_buffer
= NULL
;
141 next_char (st_parameter_dt
*dtp
)
147 if (dtp
->u
.p
.last_char
!= '\0')
150 c
= dtp
->u
.p
.last_char
;
151 dtp
->u
.p
.last_char
= '\0';
155 /* Read from line_buffer if enabled. */
157 if (dtp
->u
.p
.line_buffer_enabled
)
161 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
162 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
164 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
165 dtp
->u
.p
.item_count
++;
169 dtp
->u
.p
.item_count
= 0;
170 dtp
->u
.p
.line_buffer_enabled
= 0;
173 /* Handle the end-of-record and end-of-file conditions for
174 internal array unit. */
175 if (is_array_io (dtp
))
178 longjmp (*dtp
->u
.p
.eof_jump
, 1);
180 /* Check for "end-of-record" condition. */
181 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
186 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
189 /* Check for "end-of-file" condition. */
196 record
*= dtp
->u
.p
.current_unit
->recl
;
197 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
198 longjmp (*dtp
->u
.p
.eof_jump
, 1);
200 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
205 /* Get the next character and handle end-of-record conditions. */
209 if (sread (dtp
->u
.p
.current_unit
->s
, &c
, &length
) != 0)
211 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
215 if (is_stream_io (dtp
) && length
== 1)
216 dtp
->u
.p
.current_unit
->strm_pos
++;
218 if (is_internal_unit (dtp
))
220 if (is_array_io (dtp
))
222 /* Check whether we hit EOF. */
225 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
228 dtp
->u
.p
.current_unit
->bytes_left
--;
233 longjmp (*dtp
->u
.p
.eof_jump
, 1);
245 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
246 longjmp (*dtp
->u
.p
.eof_jump
, 1);
247 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
252 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
257 /* Push a character back onto the input. */
260 unget_char (st_parameter_dt
*dtp
, char c
)
262 dtp
->u
.p
.last_char
= c
;
266 /* Skip over spaces in the input. Returns the nonspace character that
267 terminated the eating and also places it back on the input. */
270 eat_spaces (st_parameter_dt
*dtp
)
278 while (c
== ' ' || c
== '\t');
285 /* This function reads characters through to the end of the current line and
286 just ignores them. */
289 eat_line (st_parameter_dt
*dtp
)
292 if (!is_internal_unit (dtp
))
299 /* Skip over a separator. Technically, we don't always eat the whole
300 separator. This is because if we've processed the last input item,
301 then a separator is unnecessary. Plus the fact that operating
302 systems usually deliver console input on a line basis.
304 The upshot is that if we see a newline as part of reading a
305 separator, we stop reading. If there are more input items, we
306 continue reading the separator with finish_separator() which takes
307 care of the fact that we may or may not have seen a comma as part
311 eat_separator (st_parameter_dt
*dtp
)
316 dtp
->u
.p
.comma_flag
= 0;
322 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
329 dtp
->u
.p
.comma_flag
= 1;
334 dtp
->u
.p
.input_complete
= 1;
348 if (dtp
->u
.p
.namelist_mode
)
364 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
370 if (dtp
->u
.p
.namelist_mode
)
371 { /* Eat a namelist comment. */
379 /* Fall Through... */
388 /* Finish processing a separator that was interrupted by a newline.
389 If we're here, then another data item is present, so we finish what
390 we started on the previous line. */
393 finish_separator (st_parameter_dt
*dtp
)
404 if (dtp
->u
.p
.comma_flag
)
408 c
= eat_spaces (dtp
);
409 if (c
== '\n' || c
== '\r')
416 dtp
->u
.p
.input_complete
= 1;
417 if (!dtp
->u
.p
.namelist_mode
)
426 if (dtp
->u
.p
.namelist_mode
)
442 /* This function is needed to catch bad conversions so that namelist can
443 attempt to see if dtp->u.p.saved_string contains a new object name rather
447 nml_bad_return (st_parameter_dt
*dtp
, char c
)
449 if (dtp
->u
.p
.namelist_mode
)
451 dtp
->u
.p
.nml_read_error
= 1;
458 /* Convert an unsigned string to an integer. The length value is -1
459 if we are working on a repeat count. Returns nonzero if we have a
460 range problem. As a side effect, frees the dtp->u.p.saved_string. */
463 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
465 char c
, *buffer
, message
[100];
467 GFC_INTEGER_LARGEST v
, max
, max10
;
469 buffer
= dtp
->u
.p
.saved_string
;
472 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
497 set_integer (dtp
->u
.p
.value
, v
, length
);
501 dtp
->u
.p
.repeat_count
= v
;
503 if (dtp
->u
.p
.repeat_count
== 0)
505 sprintf (message
, "Zero repeat count in item %d of list input",
506 dtp
->u
.p
.item_count
);
508 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
518 sprintf (message
, "Repeat count overflow in item %d of list input",
519 dtp
->u
.p
.item_count
);
521 sprintf (message
, "Integer overflow while reading item %d",
522 dtp
->u
.p
.item_count
);
525 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
531 /* Parse a repeat count for logical and complex values which cannot
532 begin with a digit. Returns nonzero if we are done, zero if we
533 should continue on. */
536 parse_repeat (st_parameter_dt
*dtp
)
538 char c
, message
[100];
564 repeat
= 10 * repeat
+ c
- '0';
566 if (repeat
> MAX_REPEAT
)
569 "Repeat count overflow in item %d of list input",
570 dtp
->u
.p
.item_count
);
572 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
582 "Zero repeat count in item %d of list input",
583 dtp
->u
.p
.item_count
);
585 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
597 dtp
->u
.p
.repeat_count
= repeat
;
604 sprintf (message
, "Bad repeat count in item %d of list input",
605 dtp
->u
.p
.item_count
);
606 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
611 /* To read a logical we have to look ahead in the input stream to make sure
612 there is not an equal sign indicating a variable name. To do this we use
613 line_buffer to point to a temporary buffer, pushing characters there for
614 possible later reading. */
617 l_push_char (st_parameter_dt
*dtp
, char c
)
619 if (dtp
->u
.p
.line_buffer
== NULL
)
621 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
622 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
625 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
629 /* Read a logical character on the input. */
632 read_logical (st_parameter_dt
*dtp
, int length
)
634 char c
, message
[100];
637 if (parse_repeat (dtp
))
640 c
= tolower (next_char (dtp
));
641 l_push_char (dtp
, c
);
647 l_push_char (dtp
, c
);
649 if (!is_separator(c
))
657 l_push_char (dtp
, c
);
659 if (!is_separator(c
))
666 c
= tolower (next_char (dtp
));
684 return; /* Null value. */
687 /* Save the character in case it is the beginning
688 of the next object name. */
693 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
694 dtp
->u
.p
.saved_length
= length
;
696 /* Eat trailing garbage. */
701 while (!is_separator (c
));
705 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
712 for(i
= 0; i
< 63; i
++)
717 /* All done if this is not a namelist read. */
718 if (!dtp
->u
.p
.namelist_mode
)
731 l_push_char (dtp
, c
);
734 dtp
->u
.p
.nml_read_error
= 1;
735 dtp
->u
.p
.line_buffer_enabled
= 1;
736 dtp
->u
.p
.item_count
= 0;
746 if (nml_bad_return (dtp
, c
))
751 sprintf (message
, "Bad logical value while reading item %d",
752 dtp
->u
.p
.item_count
);
753 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
758 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
759 dtp
->u
.p
.saved_length
= length
;
760 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
766 /* Reading integers is tricky because we can actually be reading a
767 repeat count. We have to store the characters in a buffer because
768 we could be reading an integer that is larger than the default int
769 used for repeat counts. */
772 read_integer (st_parameter_dt
*dtp
, int length
)
774 char c
, message
[100];
784 /* Fall through... */
790 CASE_SEPARATORS
: /* Single null. */
803 /* Take care of what may be a repeat count. */
815 push_char (dtp
, '\0');
818 CASE_SEPARATORS
: /* Not a repeat count. */
827 if (convert_integer (dtp
, -1, 0))
830 /* Get the real integer. */
845 /* Fall through... */
876 if (nml_bad_return (dtp
, c
))
881 sprintf (message
, "Bad integer for item %d in list input",
882 dtp
->u
.p
.item_count
);
883 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
891 push_char (dtp
, '\0');
892 if (convert_integer (dtp
, length
, negative
))
899 dtp
->u
.p
.saved_type
= BT_INTEGER
;
903 /* Read a character variable. */
906 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
908 char c
, quote
, message
[100];
910 quote
= ' '; /* Space means no quote character. */
920 unget_char (dtp
, c
); /* NULL value. */
930 if (dtp
->u
.p
.namelist_mode
)
940 /* Deal with a possible repeat count. */
953 goto done
; /* String was only digits! */
956 push_char (dtp
, '\0');
961 goto get_string
; /* Not a repeat count after all. */
966 if (convert_integer (dtp
, -1, 0))
969 /* Now get the real string. */
975 unget_char (dtp
, c
); /* Repeated NULL values. */
1003 /* See if we have a doubled quote character or the end of
1006 c
= next_char (dtp
);
1009 push_char (dtp
, quote
);
1013 unget_char (dtp
, c
);
1019 unget_char (dtp
, c
);
1023 if (c
!= '\n' && c
!= '\r')
1033 /* At this point, we have to have a separator, or else the string is
1036 c
= next_char (dtp
);
1037 if (is_separator (c
) || c
== '!')
1039 unget_char (dtp
, c
);
1040 eat_separator (dtp
);
1041 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1047 sprintf (message
, "Invalid string input in item %d",
1048 dtp
->u
.p
.item_count
);
1049 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1054 /* Parse a component of a complex constant or a real number that we
1055 are sure is already there. This is a straight real number parser. */
1058 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1060 char c
, message
[100];
1063 c
= next_char (dtp
);
1064 if (c
== '-' || c
== '+')
1067 c
= next_char (dtp
);
1070 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1073 if (!isdigit (c
) && c
!= '.')
1075 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1083 seen_dp
= (c
== '.') ? 1 : 0;
1087 c
= next_char (dtp
);
1088 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1108 push_char (dtp
, 'e');
1113 push_char (dtp
, 'e');
1115 c
= next_char (dtp
);
1119 unget_char (dtp
, c
);
1128 c
= next_char (dtp
);
1129 if (c
!= '-' && c
!= '+')
1130 push_char (dtp
, '+');
1134 c
= next_char (dtp
);
1145 c
= next_char (dtp
);
1153 unget_char (dtp
, c
);
1162 unget_char (dtp
, c
);
1163 push_char (dtp
, '\0');
1165 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1171 /* Match INF and Infinity. */
1172 if ((c
== 'i' || c
== 'I')
1173 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1174 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1176 c
= next_char (dtp
);
1177 if ((c
!= 'i' && c
!= 'I')
1178 || ((c
== 'i' || c
== 'I')
1179 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1180 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1181 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1182 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1183 && (c
= next_char (dtp
))))
1185 if (is_separator (c
))
1186 unget_char (dtp
, c
);
1187 push_char (dtp
, 'i');
1188 push_char (dtp
, 'n');
1189 push_char (dtp
, 'f');
1193 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1194 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1195 && (c
= next_char (dtp
)))
1197 if (is_separator (c
))
1198 unget_char (dtp
, c
);
1199 push_char (dtp
, 'n');
1200 push_char (dtp
, 'a');
1201 push_char (dtp
, 'n');
1207 if (nml_bad_return (dtp
, c
))
1212 sprintf (message
, "Bad floating point number for item %d",
1213 dtp
->u
.p
.item_count
);
1214 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1220 /* Reading a complex number is straightforward because we can tell
1221 what it is right away. */
1224 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1229 if (parse_repeat (dtp
))
1232 c
= next_char (dtp
);
1239 unget_char (dtp
, c
);
1240 eat_separator (dtp
);
1248 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1253 c
= next_char (dtp
);
1254 if (c
== '\n' || c
== '\r')
1257 unget_char (dtp
, c
);
1260 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1265 c
= next_char (dtp
);
1266 if (c
== '\n' || c
== '\r')
1269 unget_char (dtp
, c
);
1271 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1275 if (next_char (dtp
) != ')')
1278 c
= next_char (dtp
);
1279 if (!is_separator (c
))
1282 unget_char (dtp
, c
);
1283 eat_separator (dtp
);
1286 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1291 if (nml_bad_return (dtp
, c
))
1296 sprintf (message
, "Bad complex value in item %d of list input",
1297 dtp
->u
.p
.item_count
);
1298 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1302 /* Parse a real number with a possible repeat count. */
1305 read_real (st_parameter_dt
*dtp
, int length
)
1307 char c
, message
[100];
1313 c
= next_char (dtp
);
1314 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1332 unget_char (dtp
, c
); /* Single null. */
1333 eat_separator (dtp
);
1346 /* Get the digit string that might be a repeat count. */
1350 c
= next_char (dtp
);
1351 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1375 push_char (dtp
, 'e');
1377 c
= next_char (dtp
);
1381 push_char (dtp
, '\0');
1385 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1386 unget_char (dtp
, c
);
1395 if (convert_integer (dtp
, -1, 0))
1398 /* Now get the number itself. */
1400 c
= next_char (dtp
);
1401 if (is_separator (c
))
1402 { /* Repeated null value. */
1403 unget_char (dtp
, c
);
1404 eat_separator (dtp
);
1408 if (c
!= '-' && c
!= '+')
1409 push_char (dtp
, '+');
1414 c
= next_char (dtp
);
1417 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1420 if (!isdigit (c
) && c
!= '.')
1422 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1441 c
= next_char (dtp
);
1442 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1469 push_char (dtp
, 'e');
1471 c
= next_char (dtp
);
1480 push_char (dtp
, 'e');
1482 c
= next_char (dtp
);
1483 if (c
!= '+' && c
!= '-')
1484 push_char (dtp
, '+');
1488 c
= next_char (dtp
);
1498 c
= next_char (dtp
);
1515 unget_char (dtp
, c
);
1516 eat_separator (dtp
);
1517 push_char (dtp
, '\0');
1518 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1522 dtp
->u
.p
.saved_type
= BT_REAL
;
1526 l_push_char (dtp
, c
);
1529 /* Match INF and Infinity. */
1530 if (c
== 'i' || c
== 'I')
1532 c
= next_char (dtp
);
1533 l_push_char (dtp
, c
);
1534 if (c
!= 'n' && c
!= 'N')
1536 c
= next_char (dtp
);
1537 l_push_char (dtp
, c
);
1538 if (c
!= 'f' && c
!= 'F')
1540 c
= next_char (dtp
);
1541 l_push_char (dtp
, c
);
1542 if (!is_separator (c
))
1544 if (c
!= 'i' && c
!= 'I')
1546 c
= next_char (dtp
);
1547 l_push_char (dtp
, c
);
1548 if (c
!= 'n' && c
!= 'N')
1550 c
= next_char (dtp
);
1551 l_push_char (dtp
, c
);
1552 if (c
!= 'i' && c
!= 'I')
1554 c
= next_char (dtp
);
1555 l_push_char (dtp
, c
);
1556 if (c
!= 't' && c
!= 'T')
1558 c
= next_char (dtp
);
1559 l_push_char (dtp
, c
);
1560 if (c
!= 'y' && c
!= 'Y')
1562 c
= next_char (dtp
);
1563 l_push_char (dtp
, c
);
1569 c
= next_char (dtp
);
1570 l_push_char (dtp
, c
);
1571 if (c
!= 'a' && c
!= 'A')
1573 c
= next_char (dtp
);
1574 l_push_char (dtp
, c
);
1575 if (c
!= 'n' && c
!= 'N')
1577 c
= next_char (dtp
);
1578 l_push_char (dtp
, c
);
1581 if (!is_separator (c
))
1584 if (dtp
->u
.p
.namelist_mode
)
1586 if (c
== ' ' || c
=='\n' || c
== '\r')
1589 c
= next_char (dtp
);
1590 while (c
== ' ' || c
=='\n' || c
== '\r');
1592 l_push_char (dtp
, c
);
1601 push_char (dtp
, 'i');
1602 push_char (dtp
, 'n');
1603 push_char (dtp
, 'f');
1607 push_char (dtp
, 'n');
1608 push_char (dtp
, 'a');
1609 push_char (dtp
, 'n');
1616 if (dtp
->u
.p
.namelist_mode
)
1618 dtp
->u
.p
.nml_read_error
= 1;
1619 dtp
->u
.p
.line_buffer_enabled
= 1;
1620 dtp
->u
.p
.item_count
= 0;
1626 if (nml_bad_return (dtp
, c
))
1631 sprintf (message
, "Bad real number in item %d of list input",
1632 dtp
->u
.p
.item_count
);
1633 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1637 /* Check the current type against the saved type to make sure they are
1638 compatible. Returns nonzero if incompatible. */
1641 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1645 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1647 sprintf (message
, "Read type %s where %s was expected for item %d",
1648 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1649 dtp
->u
.p
.item_count
);
1651 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1655 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1658 if (dtp
->u
.p
.saved_length
!= len
)
1661 "Read kind %d %s where kind %d is required for item %d",
1662 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1663 dtp
->u
.p
.item_count
);
1664 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1672 /* Top level data transfer subroutine for list reads. Because we have
1673 to deal with repeat counts, the data item is always saved after
1674 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1675 greater than one, we copy the data item multiple times. */
1678 list_formatted_read_scalar (st_parameter_dt
*dtp
, volatile bt type
, void *p
,
1679 int kind
, size_t size
)
1686 dtp
->u
.p
.namelist_mode
= 0;
1688 dtp
->u
.p
.eof_jump
= &eof_jump
;
1689 if (setjmp (eof_jump
))
1691 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1695 if (dtp
->u
.p
.first_item
)
1697 dtp
->u
.p
.first_item
= 0;
1698 dtp
->u
.p
.input_complete
= 0;
1699 dtp
->u
.p
.repeat_count
= 1;
1700 dtp
->u
.p
.at_eol
= 0;
1702 c
= eat_spaces (dtp
);
1703 if (is_separator (c
))
1705 /* Found a null value. */
1706 eat_separator (dtp
);
1707 dtp
->u
.p
.repeat_count
= 0;
1709 /* eat_separator sets this flag if the separator was a comma. */
1710 if (dtp
->u
.p
.comma_flag
)
1713 /* eat_separator sets this flag if the separator was a \n or \r. */
1714 if (dtp
->u
.p
.at_eol
)
1715 finish_separator (dtp
);
1723 if (dtp
->u
.p
.repeat_count
> 0)
1725 if (check_type (dtp
, type
, kind
))
1730 if (dtp
->u
.p
.input_complete
)
1733 if (dtp
->u
.p
.at_eol
)
1734 finish_separator (dtp
);
1738 /* Trailing spaces prior to end of line. */
1739 if (dtp
->u
.p
.at_eol
)
1740 finish_separator (dtp
);
1743 dtp
->u
.p
.saved_type
= BT_NULL
;
1744 dtp
->u
.p
.repeat_count
= 1;
1750 read_integer (dtp
, kind
);
1753 read_logical (dtp
, kind
);
1756 read_character (dtp
, kind
);
1759 read_real (dtp
, kind
);
1762 read_complex (dtp
, kind
, size
);
1765 internal_error (&dtp
->common
, "Bad type for list read");
1768 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1769 dtp
->u
.p
.saved_length
= size
;
1771 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1775 switch (dtp
->u
.p
.saved_type
)
1781 memcpy (p
, dtp
->u
.p
.value
, size
);
1785 if (dtp
->u
.p
.saved_string
)
1787 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1788 ? (int) size
: dtp
->u
.p
.saved_used
;
1790 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1793 q
= (gfc_char4_t
*) p
;
1794 for (i
= 0; i
< m
; i
++)
1795 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1799 /* Just delimiters encountered, nothing to copy but SPACE. */
1805 memset (((char *) p
) + m
, ' ', size
- m
);
1808 q
= (gfc_char4_t
*) p
;
1809 for (i
= m
; i
< (int) size
; i
++)
1810 q
[i
] = (unsigned char) ' ';
1819 if (--dtp
->u
.p
.repeat_count
<= 0)
1823 dtp
->u
.p
.eof_jump
= NULL
;
1828 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1829 size_t size
, size_t nelems
)
1833 size_t stride
= type
== BT_CHARACTER
?
1834 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1838 /* Big loop over all the elements. */
1839 for (elem
= 0; elem
< nelems
; elem
++)
1841 dtp
->u
.p
.item_count
++;
1842 list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1847 /* Finish a list read. */
1850 finish_list_read (st_parameter_dt
*dtp
)
1856 if (dtp
->u
.p
.at_eol
)
1858 dtp
->u
.p
.at_eol
= 0;
1864 c
= next_char (dtp
);
1868 if (dtp
->u
.p
.current_unit
->endfile
!= NO_ENDFILE
)
1870 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1871 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1872 dtp
->u
.p
.current_unit
->current_record
= 0;
1878 void namelist_read (st_parameter_dt *dtp)
1880 static void nml_match_name (char *name, int len)
1881 static int nml_query (st_parameter_dt *dtp)
1882 static int nml_get_obj_data (st_parameter_dt *dtp,
1883 namelist_info **prev_nl, char *, size_t)
1885 static void nml_untouch_nodes (st_parameter_dt *dtp)
1886 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1888 static int nml_parse_qualifier(descriptor_dimension * ad,
1889 array_loop_spec * ls, int rank, char *)
1890 static void nml_touch_nodes (namelist_info * nl)
1891 static int nml_read_obj (namelist_info *nl, index_type offset,
1892 namelist_info **prev_nl, char *, size_t,
1893 index_type clow, index_type chigh)
1897 /* Inputs a rank-dimensional qualifier, which can contain
1898 singlets, doublets, triplets or ':' with the standard meanings. */
1901 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1902 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1909 int is_array_section
, is_char
;
1913 is_array_section
= 0;
1914 dtp
->u
.p
.expanded_read
= 0;
1916 /* See if this is a character substring qualifier we are looking for. */
1923 /* The next character in the stream should be the '('. */
1925 c
= next_char (dtp
);
1927 /* Process the qualifier, by dimension and triplet. */
1929 for (dim
=0; dim
< rank
; dim
++ )
1931 for (indx
=0; indx
<3; indx
++)
1937 /* Process a potential sign. */
1938 c
= next_char (dtp
);
1949 unget_char (dtp
, c
);
1953 /* Process characters up to the next ':' , ',' or ')'. */
1956 c
= next_char (dtp
);
1961 is_array_section
= 1;
1965 if ((c
==',' && dim
== rank
-1)
1966 || (c
==')' && dim
< rank
-1))
1969 sprintf (parse_err_msg
, "Bad substring qualifier");
1971 sprintf (parse_err_msg
, "Bad number of index fields");
1980 case ' ': case '\t':
1982 c
= next_char (dtp
);
1987 sprintf (parse_err_msg
,
1988 "Bad character in substring qualifier");
1990 sprintf (parse_err_msg
, "Bad character in index");
1994 if ((c
== ',' || c
== ')') && indx
== 0
1995 && dtp
->u
.p
.saved_string
== 0)
1998 sprintf (parse_err_msg
, "Null substring qualifier");
2000 sprintf (parse_err_msg
, "Null index field");
2004 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2005 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2008 sprintf (parse_err_msg
, "Bad substring qualifier");
2010 sprintf (parse_err_msg
, "Bad index triplet");
2014 if (is_char
&& !is_array_section
)
2016 sprintf (parse_err_msg
,
2017 "Missing colon in substring qualifier");
2021 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2023 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2024 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2030 /* Now read the index. */
2031 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2034 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2036 sprintf (parse_err_msg
, "Bad integer in index");
2042 /* Feed the index values to the triplet arrays. */
2046 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2048 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2050 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2053 /* Singlet or doublet indices. */
2054 if (c
==',' || c
==')')
2058 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2060 /* If -std=f95/2003 or an array section is specified,
2061 do not allow excess data to be processed. */
2062 if (is_array_section
== 1
2063 || compile_options
.allow_std
< GFC_STD_GNU
)
2064 ls
[dim
].end
= ls
[dim
].start
;
2066 dtp
->u
.p
.expanded_read
= 1;
2069 /* Check for non-zero rank. */
2070 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2077 /* Check the values of the triplet indices. */
2078 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2079 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2080 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2081 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2084 sprintf (parse_err_msg
, "Substring out of range");
2086 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2090 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2091 || (ls
[dim
].step
== 0))
2093 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2097 /* Initialise the loop index counter. */
2098 ls
[dim
].idx
= ls
[dim
].start
;
2108 static namelist_info
*
2109 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2111 namelist_info
* t
= dtp
->u
.p
.ionml
;
2114 if (strcmp (var_name
, t
->var_name
) == 0)
2124 /* Visits all the components of a derived type that have
2125 not explicitly been identified in the namelist input.
2126 touched is set and the loop specification initialised
2127 to default values */
2130 nml_touch_nodes (namelist_info
* nl
)
2132 index_type len
= strlen (nl
->var_name
) + 1;
2134 char * ext_name
= (char*)get_mem (len
+ 1);
2135 memcpy (ext_name
, nl
->var_name
, len
-1);
2136 memcpy (ext_name
+ len
- 1, "%", 2);
2137 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2139 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2142 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2144 nl
->ls
[dim
].step
= 1;
2145 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2146 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2147 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2153 free_mem (ext_name
);
2157 /* Resets touched for the entire list of nml_nodes, ready for a
2161 nml_untouch_nodes (st_parameter_dt
*dtp
)
2164 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2169 /* Attempts to input name to namelist name. Returns
2170 dtp->u.p.nml_read_error = 1 on no match. */
2173 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2177 dtp
->u
.p
.nml_read_error
= 0;
2178 for (i
= 0; i
< len
; i
++)
2180 c
= next_char (dtp
);
2181 if (tolower (c
) != tolower (name
[i
]))
2183 dtp
->u
.p
.nml_read_error
= 1;
2189 /* If the namelist read is from stdin, output the current state of the
2190 namelist to stdout. This is used to implement the non-standard query
2191 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2192 the names alone are printed. */
2195 nml_query (st_parameter_dt
*dtp
, char c
)
2197 gfc_unit
* temp_unit
;
2202 static const index_type endlen
= 3;
2203 static const char endl
[] = "\r\n";
2204 static const char nmlend
[] = "&end\r\n";
2206 static const index_type endlen
= 2;
2207 static const char endl
[] = "\n";
2208 static const char nmlend
[] = "&end\n";
2211 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2214 /* Store the current unit and transfer to stdout. */
2216 temp_unit
= dtp
->u
.p
.current_unit
;
2217 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2219 if (dtp
->u
.p
.current_unit
)
2221 dtp
->u
.p
.mode
= WRITING
;
2222 next_record (dtp
, 0);
2224 /* Write the namelist in its entirety. */
2227 namelist_write (dtp
);
2229 /* Or write the list of names. */
2233 /* "&namelist_name\n" */
2235 len
= dtp
->namelist_name_len
;
2236 p
= write_block (dtp
, len
+ endlen
);
2240 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2241 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2242 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2246 len
= strlen (nl
->var_name
);
2247 p
= write_block (dtp
, len
+ endlen
);
2251 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2252 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2257 p
= write_block (dtp
, endlen
+ 3);
2259 memcpy (p
, &nmlend
, endlen
+ 3);
2262 /* Flush the stream to force immediate output. */
2264 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2265 flush (dtp
->u
.p
.current_unit
->s
);
2266 unlock_unit (dtp
->u
.p
.current_unit
);
2271 /* Restore the current unit. */
2273 dtp
->u
.p
.current_unit
= temp_unit
;
2274 dtp
->u
.p
.mode
= READING
;
2278 /* Reads and stores the input for the namelist object nl. For an array,
2279 the function loops over the ranges defined by the loop specification.
2280 This default to all the data or to the specification from a qualifier.
2281 nml_read_obj recursively calls itself to read derived types. It visits
2282 all its own components but only reads data for those that were touched
2283 when the name was parsed. If a read error is encountered, an attempt is
2284 made to return to read a new object name because the standard allows too
2285 little data to be available. On the other hand, too much data is an
2289 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2290 namelist_info
**pprev_nl
, char *nml_err_msg
,
2291 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2293 namelist_info
* cmp
;
2300 index_type obj_name_len
;
2303 /* This object not touched in name parsing. */
2308 dtp
->u
.p
.repeat_count
= 0;
2314 case GFC_DTYPE_INTEGER
:
2315 case GFC_DTYPE_LOGICAL
:
2319 case GFC_DTYPE_REAL
:
2320 dlen
= size_from_real_kind (len
);
2323 case GFC_DTYPE_COMPLEX
:
2324 dlen
= size_from_complex_kind (len
);
2327 case GFC_DTYPE_CHARACTER
:
2328 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2337 /* Update the pointer to the data, using the current index vector */
2339 pdata
= (void*)(nl
->mem_pos
+ offset
);
2340 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2341 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2342 nl
->dim
[dim
].stride
* nl
->size
);
2344 /* Reset the error flag and try to read next value, if
2345 dtp->u.p.repeat_count=0 */
2347 dtp
->u
.p
.nml_read_error
= 0;
2349 if (--dtp
->u
.p
.repeat_count
<= 0)
2351 if (dtp
->u
.p
.input_complete
)
2353 if (dtp
->u
.p
.at_eol
)
2354 finish_separator (dtp
);
2355 if (dtp
->u
.p
.input_complete
)
2358 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2359 after the switch block. */
2361 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2366 case GFC_DTYPE_INTEGER
:
2367 read_integer (dtp
, len
);
2370 case GFC_DTYPE_LOGICAL
:
2371 read_logical (dtp
, len
);
2374 case GFC_DTYPE_CHARACTER
:
2375 read_character (dtp
, len
);
2378 case GFC_DTYPE_REAL
:
2379 read_real (dtp
, len
);
2382 case GFC_DTYPE_COMPLEX
:
2383 read_complex (dtp
, len
, dlen
);
2386 case GFC_DTYPE_DERIVED
:
2387 obj_name_len
= strlen (nl
->var_name
) + 1;
2388 obj_name
= get_mem (obj_name_len
+1);
2389 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2390 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2392 /* If reading a derived type, disable the expanded read warning
2393 since a single object can have multiple reads. */
2394 dtp
->u
.p
.expanded_read
= 0;
2396 /* Now loop over the components. Update the component pointer
2397 with the return value from nml_write_obj. This loop jumps
2398 past nested derived types by testing if the potential
2399 component name contains '%'. */
2401 for (cmp
= nl
->next
;
2403 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2404 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2408 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2409 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2410 clow
, chigh
) == FAILURE
)
2412 free_mem (obj_name
);
2416 if (dtp
->u
.p
.input_complete
)
2418 free_mem (obj_name
);
2423 free_mem (obj_name
);
2427 snprintf (nml_err_msg
, nml_err_msg_size
,
2428 "Bad type for namelist object %s", nl
->var_name
);
2429 internal_error (&dtp
->common
, nml_err_msg
);
2434 /* The standard permits array data to stop short of the number of
2435 elements specified in the loop specification. In this case, we
2436 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2437 nml_get_obj_data and an attempt is made to read object name. */
2440 if (dtp
->u
.p
.nml_read_error
)
2442 dtp
->u
.p
.expanded_read
= 0;
2446 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2448 dtp
->u
.p
.expanded_read
= 0;
2452 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2453 This comes about because the read functions return BT_types. */
2455 switch (dtp
->u
.p
.saved_type
)
2462 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2466 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2467 pdata
= (void*)( pdata
+ clow
- 1 );
2468 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2470 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2477 /* Warn if a non-standard expanded read occurs. A single read of a
2478 single object is acceptable. If a second read occurs, issue a warning
2479 and set the flag to zero to prevent further warnings. */
2480 if (dtp
->u
.p
.expanded_read
== 2)
2482 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2483 dtp
->u
.p
.expanded_read
= 0;
2486 /* If the expanded read warning flag is set, increment it,
2487 indicating that a single read has occurred. */
2488 if (dtp
->u
.p
.expanded_read
>= 1)
2489 dtp
->u
.p
.expanded_read
++;
2491 /* Break out of loop if scalar. */
2495 /* Now increment the index vector. */
2500 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2502 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2504 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2506 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2508 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2512 } while (!nml_carry
);
2514 if (dtp
->u
.p
.repeat_count
> 1)
2516 snprintf (nml_err_msg
, nml_err_msg_size
,
2517 "Repeat count too large for namelist object %s", nl
->var_name
);
2527 /* Parses the object name, including array and substring qualifiers. It
2528 iterates over derived type components, touching those components and
2529 setting their loop specifications, if there is a qualifier. If the
2530 object is itself a derived type, its components and subcomponents are
2531 touched. nml_read_obj is called at the end and this reads the data in
2532 the manner specified by the object name. */
2535 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2536 char *nml_err_msg
, size_t nml_err_msg_size
)
2540 namelist_info
* first_nl
= NULL
;
2541 namelist_info
* root_nl
= NULL
;
2542 int dim
, parsed_rank
;
2544 index_type clow
, chigh
;
2545 int non_zero_rank_count
;
2547 /* Look for end of input or object name. If '?' or '=?' are encountered
2548 in stdin, print the node names or the namelist to stdout. */
2550 eat_separator (dtp
);
2551 if (dtp
->u
.p
.input_complete
)
2554 if (dtp
->u
.p
.at_eol
)
2555 finish_separator (dtp
);
2556 if (dtp
->u
.p
.input_complete
)
2559 c
= next_char (dtp
);
2563 c
= next_char (dtp
);
2566 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2569 nml_query (dtp
, '=');
2573 nml_query (dtp
, '?');
2578 nml_match_name (dtp
, "end", 3);
2579 if (dtp
->u
.p
.nml_read_error
)
2581 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2585 dtp
->u
.p
.input_complete
= 1;
2592 /* Untouch all nodes of the namelist and reset the flag that is set for
2593 derived type components. */
2595 nml_untouch_nodes (dtp
);
2597 non_zero_rank_count
= 0;
2599 /* Get the object name - should '!' and '\n' be permitted separators? */
2607 if (!is_separator (c
))
2608 push_char (dtp
, tolower(c
));
2609 c
= next_char (dtp
);
2610 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2612 unget_char (dtp
, c
);
2614 /* Check that the name is in the namelist and get pointer to object.
2615 Three error conditions exist: (i) An attempt is being made to
2616 identify a non-existent object, following a failed data read or
2617 (ii) The object name does not exist or (iii) Too many data items
2618 are present for an object. (iii) gives the same error message
2621 push_char (dtp
, '\0');
2625 size_t var_len
= strlen (root_nl
->var_name
);
2627 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2628 char ext_name
[var_len
+ saved_len
+ 1];
2630 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2631 if (dtp
->u
.p
.saved_string
)
2632 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2633 ext_name
[var_len
+ saved_len
] = '\0';
2634 nl
= find_nml_node (dtp
, ext_name
);
2637 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2641 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2642 snprintf (nml_err_msg
, nml_err_msg_size
,
2643 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2646 snprintf (nml_err_msg
, nml_err_msg_size
,
2647 "Cannot match namelist object name %s",
2648 dtp
->u
.p
.saved_string
);
2653 /* Get the length, data length, base pointer and rank of the variable.
2654 Set the default loop specification first. */
2656 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2658 nl
->ls
[dim
].step
= 1;
2659 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2660 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2661 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2664 /* Check to see if there is a qualifier: if so, parse it.*/
2666 if (c
== '(' && nl
->var_rank
)
2669 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2670 nml_err_msg
, &parsed_rank
) == FAILURE
)
2672 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2673 snprintf (nml_err_msg_end
,
2674 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2675 " for namelist variable %s", nl
->var_name
);
2679 if (parsed_rank
> 0)
2680 non_zero_rank_count
++;
2682 c
= next_char (dtp
);
2683 unget_char (dtp
, c
);
2685 else if (nl
->var_rank
> 0)
2686 non_zero_rank_count
++;
2688 /* Now parse a derived type component. The root namelist_info address
2689 is backed up, as is the previous component level. The component flag
2690 is set and the iteration is made by jumping back to get_name. */
2694 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2696 snprintf (nml_err_msg
, nml_err_msg_size
,
2697 "Attempt to get derived component for %s", nl
->var_name
);
2701 if (!component_flag
)
2706 c
= next_char (dtp
);
2710 /* Parse a character qualifier, if present. chigh = 0 is a default
2711 that signals that the string length = string_length. */
2716 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2718 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2719 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2721 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2724 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2725 snprintf (nml_err_msg_end
,
2726 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2727 " for namelist variable %s", nl
->var_name
);
2731 clow
= ind
[0].start
;
2734 if (ind
[0].step
!= 1)
2736 snprintf (nml_err_msg
, nml_err_msg_size
,
2737 "Step not allowed in substring qualifier"
2738 " for namelist object %s", nl
->var_name
);
2742 c
= next_char (dtp
);
2743 unget_char (dtp
, c
);
2746 /* If a derived type touch its components and restore the root
2747 namelist_info if we have parsed a qualified derived type
2750 if (nl
->type
== GFC_DTYPE_DERIVED
)
2751 nml_touch_nodes (nl
);
2752 if (component_flag
&& nl
->var_rank
> 0)
2755 /* Make sure no extraneous qualifiers are there. */
2759 snprintf (nml_err_msg
, nml_err_msg_size
,
2760 "Qualifier for a scalar or non-character namelist object %s",
2765 /* Make sure there is no more than one non-zero rank object. */
2766 if (non_zero_rank_count
> 1)
2768 snprintf (nml_err_msg
, nml_err_msg_size
,
2769 "Multiple sub-objects with non-zero rank in namelist object %s",
2771 non_zero_rank_count
= 0;
2775 /* According to the standard, an equal sign MUST follow an object name. The
2776 following is possibly lax - it allows comments, blank lines and so on to
2777 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2781 eat_separator (dtp
);
2782 if (dtp
->u
.p
.input_complete
)
2785 if (dtp
->u
.p
.at_eol
)
2786 finish_separator (dtp
);
2787 if (dtp
->u
.p
.input_complete
)
2790 c
= next_char (dtp
);
2794 snprintf (nml_err_msg
, nml_err_msg_size
,
2795 "Equal sign must follow namelist object name %s",
2800 if (first_nl
!= NULL
&& first_nl
->var_rank
> 0)
2803 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2804 clow
, chigh
) == FAILURE
)
2814 /* Entry point for namelist input. Goes through input until namelist name
2815 is matched. Then cycles through nml_get_obj_data until the input is
2816 completed or there is an error. */
2819 namelist_read (st_parameter_dt
*dtp
)
2823 char nml_err_msg
[200];
2824 /* Pointer to the previously read object, in case attempt is made to read
2825 new object name. Should this fail, error message can give previous
2827 namelist_info
*prev_nl
= NULL
;
2829 dtp
->u
.p
.namelist_mode
= 1;
2830 dtp
->u
.p
.input_complete
= 0;
2831 dtp
->u
.p
.expanded_read
= 0;
2833 dtp
->u
.p
.eof_jump
= &eof_jump
;
2834 if (setjmp (eof_jump
))
2836 dtp
->u
.p
.eof_jump
= NULL
;
2837 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2841 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2842 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2843 node names or namelist on stdout. */
2846 switch (c
= next_char (dtp
))
2857 c
= next_char (dtp
);
2859 nml_query (dtp
, '=');
2861 unget_char (dtp
, c
);
2865 nml_query (dtp
, '?');
2871 /* Match the name of the namelist. */
2873 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2875 if (dtp
->u
.p
.nml_read_error
)
2878 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2879 c
= next_char (dtp
);
2880 if (!is_separator(c
) && c
!= '!')
2882 unget_char (dtp
, c
);
2886 unget_char (dtp
, c
);
2887 eat_separator (dtp
);
2889 /* Ready to read namelist objects. If there is an error in input
2890 from stdin, output the error message and continue. */
2892 while (!dtp
->u
.p
.input_complete
)
2894 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2899 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2902 u
= find_unit (options
.stderr_unit
);
2903 st_printf ("%s\n", nml_err_msg
);
2913 dtp
->u
.p
.eof_jump
= NULL
;
2918 /* All namelist error calls return from here */
2922 dtp
->u
.p
.eof_jump
= NULL
;
2925 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);