ba8de9750e1e35367116b7ff64bb4405640ff5dc
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
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
.advance_status
== ADVANCE_NO
)
247 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
248 longjmp (*dtp
->u
.p
.eof_jump
, 1);
249 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
253 longjmp (*dtp
->u
.p
.eof_jump
, 1);
257 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
262 /* Push a character back onto the input. */
265 unget_char (st_parameter_dt
*dtp
, char c
)
267 dtp
->u
.p
.last_char
= c
;
271 /* Skip over spaces in the input. Returns the nonspace character that
272 terminated the eating and also places it back on the input. */
275 eat_spaces (st_parameter_dt
*dtp
)
283 while (c
== ' ' || c
== '\t');
290 /* This function reads characters through to the end of the current line and
291 just ignores them. */
294 eat_line (st_parameter_dt
*dtp
)
297 if (!is_internal_unit (dtp
))
304 /* Skip over a separator. Technically, we don't always eat the whole
305 separator. This is because if we've processed the last input item,
306 then a separator is unnecessary. Plus the fact that operating
307 systems usually deliver console input on a line basis.
309 The upshot is that if we see a newline as part of reading a
310 separator, we stop reading. If there are more input items, we
311 continue reading the separator with finish_separator() which takes
312 care of the fact that we may or may not have seen a comma as part
316 eat_separator (st_parameter_dt
*dtp
)
321 dtp
->u
.p
.comma_flag
= 0;
327 if (dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
334 dtp
->u
.p
.comma_flag
= 1;
339 dtp
->u
.p
.input_complete
= 1;
353 if (dtp
->u
.p
.namelist_mode
)
369 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
375 if (dtp
->u
.p
.namelist_mode
)
376 { /* Eat a namelist comment. */
384 /* Fall Through... */
393 /* Finish processing a separator that was interrupted by a newline.
394 If we're here, then another data item is present, so we finish what
395 we started on the previous line. */
398 finish_separator (st_parameter_dt
*dtp
)
409 if (dtp
->u
.p
.comma_flag
)
413 c
= eat_spaces (dtp
);
414 if (c
== '\n' || c
== '\r')
421 dtp
->u
.p
.input_complete
= 1;
422 if (!dtp
->u
.p
.namelist_mode
)
431 if (dtp
->u
.p
.namelist_mode
)
447 /* This function is needed to catch bad conversions so that namelist can
448 attempt to see if dtp->u.p.saved_string contains a new object name rather
452 nml_bad_return (st_parameter_dt
*dtp
, char c
)
454 if (dtp
->u
.p
.namelist_mode
)
456 dtp
->u
.p
.nml_read_error
= 1;
463 /* Convert an unsigned string to an integer. The length value is -1
464 if we are working on a repeat count. Returns nonzero if we have a
465 range problem. As a side effect, frees the dtp->u.p.saved_string. */
468 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
470 char c
, *buffer
, message
[100];
472 GFC_INTEGER_LARGEST v
, max
, max10
;
474 buffer
= dtp
->u
.p
.saved_string
;
477 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
502 set_integer (dtp
->u
.p
.value
, v
, length
);
506 dtp
->u
.p
.repeat_count
= v
;
508 if (dtp
->u
.p
.repeat_count
== 0)
510 sprintf (message
, "Zero repeat count in item %d of list input",
511 dtp
->u
.p
.item_count
);
513 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
523 sprintf (message
, "Repeat count overflow in item %d of list input",
524 dtp
->u
.p
.item_count
);
526 sprintf (message
, "Integer overflow while reading item %d",
527 dtp
->u
.p
.item_count
);
530 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
536 /* Parse a repeat count for logical and complex values which cannot
537 begin with a digit. Returns nonzero if we are done, zero if we
538 should continue on. */
541 parse_repeat (st_parameter_dt
*dtp
)
543 char c
, message
[100];
569 repeat
= 10 * repeat
+ c
- '0';
571 if (repeat
> MAX_REPEAT
)
574 "Repeat count overflow in item %d of list input",
575 dtp
->u
.p
.item_count
);
577 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
587 "Zero repeat count in item %d of list input",
588 dtp
->u
.p
.item_count
);
590 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
602 dtp
->u
.p
.repeat_count
= repeat
;
609 sprintf (message
, "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 c
, message
[100];
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
))
662 l_push_char (dtp
, c
);
664 if (!is_separator(c
))
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. */
706 while (!is_separator (c
));
710 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
717 for(i
= 0; i
< 63; i
++)
722 /* All done if this is not a namelist read. */
723 if (!dtp
->u
.p
.namelist_mode
)
736 l_push_char (dtp
, c
);
739 dtp
->u
.p
.nml_read_error
= 1;
740 dtp
->u
.p
.line_buffer_enabled
= 1;
741 dtp
->u
.p
.item_count
= 0;
751 if (nml_bad_return (dtp
, c
))
756 sprintf (message
, "Bad logical value while reading item %d",
757 dtp
->u
.p
.item_count
);
758 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
763 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
764 dtp
->u
.p
.saved_length
= length
;
765 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
771 /* Reading integers is tricky because we can actually be reading a
772 repeat count. We have to store the characters in a buffer because
773 we could be reading an integer that is larger than the default int
774 used for repeat counts. */
777 read_integer (st_parameter_dt
*dtp
, int length
)
779 char c
, message
[100];
789 /* Fall through... */
795 CASE_SEPARATORS
: /* Single null. */
808 /* Take care of what may be a repeat count. */
820 push_char (dtp
, '\0');
823 CASE_SEPARATORS
: /* Not a repeat count. */
832 if (convert_integer (dtp
, -1, 0))
835 /* Get the real integer. */
850 /* Fall through... */
881 if (nml_bad_return (dtp
, c
))
886 sprintf (message
, "Bad integer for item %d in list input",
887 dtp
->u
.p
.item_count
);
888 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
896 push_char (dtp
, '\0');
897 if (convert_integer (dtp
, length
, negative
))
904 dtp
->u
.p
.saved_type
= BT_INTEGER
;
908 /* Read a character variable. */
911 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
913 char c
, quote
, message
[100];
915 quote
= ' '; /* Space means no quote character. */
925 unget_char (dtp
, c
); /* NULL value. */
935 if (dtp
->u
.p
.namelist_mode
)
937 if (dtp
->u
.p
.delim_status
== DELIM_APOSTROPHE
938 || dtp
->u
.p
.delim_status
== DELIM_QUOTE
939 || c
== '&' || c
== '$' || c
== '/')
945 /* Check to see if we are seeing a namelist object name by using the
946 line buffer and looking ahead for an '=' or '('. */
947 l_push_char (dtp
, c
);
950 for(i
= 0; i
< 63; i
++)
960 l_push_char (dtp
, c
);
961 dtp
->u
.p
.item_count
= 0;
962 dtp
->u
.p
.line_buffer_enabled
= 1;
967 l_push_char (dtp
, c
);
969 if (c
== '=' || c
== '(')
971 dtp
->u
.p
.item_count
= 0;
972 dtp
->u
.p
.nml_read_error
= 1;
973 dtp
->u
.p
.line_buffer_enabled
= 1;
978 /* The string is too long to be a valid object name so assume that it
979 is a string to be read in as a value. */
980 dtp
->u
.p
.item_count
= 0;
981 dtp
->u
.p
.line_buffer_enabled
= 1;
989 /* Deal with a possible repeat count. */
1001 unget_char (dtp
, c
);
1002 goto done
; /* String was only digits! */
1005 push_char (dtp
, '\0');
1010 goto get_string
; /* Not a repeat count after all. */
1015 if (convert_integer (dtp
, -1, 0))
1018 /* Now get the real string. */
1020 c
= next_char (dtp
);
1024 unget_char (dtp
, c
); /* Repeated NULL values. */
1025 eat_separator (dtp
);
1041 c
= next_char (dtp
);
1052 /* See if we have a doubled quote character or the end of
1055 c
= next_char (dtp
);
1058 push_char (dtp
, quote
);
1062 unget_char (dtp
, c
);
1068 unget_char (dtp
, c
);
1072 if (c
!= '\n' && c
!= '\r')
1082 /* At this point, we have to have a separator, or else the string is
1085 c
= next_char (dtp
);
1086 if (is_separator (c
) || c
== '!')
1088 unget_char (dtp
, c
);
1089 eat_separator (dtp
);
1090 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1096 sprintf (message
, "Invalid string input in item %d",
1097 dtp
->u
.p
.item_count
);
1098 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1103 /* Parse a component of a complex constant or a real number that we
1104 are sure is already there. This is a straight real number parser. */
1107 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1109 char c
, message
[100];
1112 c
= next_char (dtp
);
1113 if (c
== '-' || c
== '+')
1116 c
= next_char (dtp
);
1119 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1122 if (!isdigit (c
) && c
!= '.')
1124 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1132 seen_dp
= (c
== '.') ? 1 : 0;
1136 c
= next_char (dtp
);
1137 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1157 push_char (dtp
, 'e');
1162 push_char (dtp
, 'e');
1164 c
= next_char (dtp
);
1168 unget_char (dtp
, c
);
1177 c
= next_char (dtp
);
1178 if (c
!= '-' && c
!= '+')
1179 push_char (dtp
, '+');
1183 c
= next_char (dtp
);
1194 c
= next_char (dtp
);
1202 unget_char (dtp
, c
);
1211 unget_char (dtp
, c
);
1212 push_char (dtp
, '\0');
1214 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1220 /* Match INF and Infinity. */
1221 if ((c
== 'i' || c
== 'I')
1222 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1223 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1225 c
= next_char (dtp
);
1226 if ((c
!= 'i' && c
!= 'I')
1227 || ((c
== 'i' || c
== 'I')
1228 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1229 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1230 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1231 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1232 && (c
= next_char (dtp
))))
1234 if (is_separator (c
))
1235 unget_char (dtp
, c
);
1236 push_char (dtp
, 'i');
1237 push_char (dtp
, 'n');
1238 push_char (dtp
, 'f');
1242 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1243 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1244 && (c
= next_char (dtp
)))
1246 if (is_separator (c
))
1247 unget_char (dtp
, c
);
1248 push_char (dtp
, 'n');
1249 push_char (dtp
, 'a');
1250 push_char (dtp
, 'n');
1256 if (nml_bad_return (dtp
, c
))
1261 sprintf (message
, "Bad floating point number for item %d",
1262 dtp
->u
.p
.item_count
);
1263 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1269 /* Reading a complex number is straightforward because we can tell
1270 what it is right away. */
1273 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1278 if (parse_repeat (dtp
))
1281 c
= next_char (dtp
);
1288 unget_char (dtp
, c
);
1289 eat_separator (dtp
);
1297 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1302 c
= next_char (dtp
);
1303 if (c
== '\n' || c
== '\r')
1306 unget_char (dtp
, c
);
1309 != (dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';'))
1314 c
= next_char (dtp
);
1315 if (c
== '\n' || c
== '\r')
1318 unget_char (dtp
, c
);
1320 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1324 if (next_char (dtp
) != ')')
1327 c
= next_char (dtp
);
1328 if (!is_separator (c
))
1331 unget_char (dtp
, c
);
1332 eat_separator (dtp
);
1335 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1340 if (nml_bad_return (dtp
, c
))
1345 sprintf (message
, "Bad complex value in item %d of list input",
1346 dtp
->u
.p
.item_count
);
1347 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1351 /* Parse a real number with a possible repeat count. */
1354 read_real (st_parameter_dt
*dtp
, int length
)
1356 char c
, message
[100];
1362 c
= next_char (dtp
);
1363 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1381 unget_char (dtp
, c
); /* Single null. */
1382 eat_separator (dtp
);
1395 /* Get the digit string that might be a repeat count. */
1399 c
= next_char (dtp
);
1400 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1424 push_char (dtp
, 'e');
1426 c
= next_char (dtp
);
1430 push_char (dtp
, '\0');
1434 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1435 unget_char (dtp
, c
);
1444 if (convert_integer (dtp
, -1, 0))
1447 /* Now get the number itself. */
1449 c
= next_char (dtp
);
1450 if (is_separator (c
))
1451 { /* Repeated null value. */
1452 unget_char (dtp
, c
);
1453 eat_separator (dtp
);
1457 if (c
!= '-' && c
!= '+')
1458 push_char (dtp
, '+');
1463 c
= next_char (dtp
);
1466 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1469 if (!isdigit (c
) && c
!= '.')
1471 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1490 c
= next_char (dtp
);
1491 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1518 push_char (dtp
, 'e');
1520 c
= next_char (dtp
);
1529 push_char (dtp
, 'e');
1531 c
= next_char (dtp
);
1532 if (c
!= '+' && c
!= '-')
1533 push_char (dtp
, '+');
1537 c
= next_char (dtp
);
1547 c
= next_char (dtp
);
1564 unget_char (dtp
, c
);
1565 eat_separator (dtp
);
1566 push_char (dtp
, '\0');
1567 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1571 dtp
->u
.p
.saved_type
= BT_REAL
;
1575 l_push_char (dtp
, c
);
1578 /* Match INF and Infinity. */
1579 if (c
== 'i' || c
== 'I')
1581 c
= next_char (dtp
);
1582 l_push_char (dtp
, c
);
1583 if (c
!= 'n' && c
!= 'N')
1585 c
= next_char (dtp
);
1586 l_push_char (dtp
, c
);
1587 if (c
!= 'f' && c
!= 'F')
1589 c
= next_char (dtp
);
1590 l_push_char (dtp
, c
);
1591 if (!is_separator (c
))
1593 if (c
!= 'i' && c
!= 'I')
1595 c
= next_char (dtp
);
1596 l_push_char (dtp
, c
);
1597 if (c
!= 'n' && c
!= 'N')
1599 c
= next_char (dtp
);
1600 l_push_char (dtp
, c
);
1601 if (c
!= 'i' && c
!= 'I')
1603 c
= next_char (dtp
);
1604 l_push_char (dtp
, c
);
1605 if (c
!= 't' && c
!= 'T')
1607 c
= next_char (dtp
);
1608 l_push_char (dtp
, c
);
1609 if (c
!= 'y' && c
!= 'Y')
1611 c
= next_char (dtp
);
1612 l_push_char (dtp
, c
);
1618 c
= next_char (dtp
);
1619 l_push_char (dtp
, c
);
1620 if (c
!= 'a' && c
!= 'A')
1622 c
= next_char (dtp
);
1623 l_push_char (dtp
, c
);
1624 if (c
!= 'n' && c
!= 'N')
1626 c
= next_char (dtp
);
1627 l_push_char (dtp
, c
);
1630 if (!is_separator (c
))
1633 if (dtp
->u
.p
.namelist_mode
)
1635 if (c
== ' ' || c
=='\n' || c
== '\r')
1638 c
= next_char (dtp
);
1639 while (c
== ' ' || c
=='\n' || c
== '\r');
1641 l_push_char (dtp
, c
);
1650 push_char (dtp
, 'i');
1651 push_char (dtp
, 'n');
1652 push_char (dtp
, 'f');
1656 push_char (dtp
, 'n');
1657 push_char (dtp
, 'a');
1658 push_char (dtp
, 'n');
1665 if (dtp
->u
.p
.namelist_mode
)
1667 dtp
->u
.p
.nml_read_error
= 1;
1668 dtp
->u
.p
.line_buffer_enabled
= 1;
1669 dtp
->u
.p
.item_count
= 0;
1675 if (nml_bad_return (dtp
, c
))
1680 sprintf (message
, "Bad real number in item %d of list input",
1681 dtp
->u
.p
.item_count
);
1682 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1686 /* Check the current type against the saved type to make sure they are
1687 compatible. Returns nonzero if incompatible. */
1690 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1694 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1696 sprintf (message
, "Read type %s where %s was expected for item %d",
1697 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1698 dtp
->u
.p
.item_count
);
1700 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1704 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1707 if (dtp
->u
.p
.saved_length
!= len
)
1710 "Read kind %d %s where kind %d is required for item %d",
1711 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1712 dtp
->u
.p
.item_count
);
1713 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1721 /* Top level data transfer subroutine for list reads. Because we have
1722 to deal with repeat counts, the data item is always saved after
1723 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1724 greater than one, we copy the data item multiple times. */
1727 list_formatted_read_scalar (st_parameter_dt
*dtp
, volatile bt type
, void *p
,
1728 int kind
, size_t size
)
1735 dtp
->u
.p
.namelist_mode
= 0;
1737 dtp
->u
.p
.eof_jump
= &eof_jump
;
1738 if (setjmp (eof_jump
))
1740 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1744 if (dtp
->u
.p
.first_item
)
1746 dtp
->u
.p
.first_item
= 0;
1747 dtp
->u
.p
.input_complete
= 0;
1748 dtp
->u
.p
.repeat_count
= 1;
1749 dtp
->u
.p
.at_eol
= 0;
1751 c
= eat_spaces (dtp
);
1752 if (is_separator (c
))
1754 /* Found a null value. */
1755 eat_separator (dtp
);
1756 dtp
->u
.p
.repeat_count
= 0;
1758 /* eat_separator sets this flag if the separator was a comma. */
1759 if (dtp
->u
.p
.comma_flag
)
1762 /* eat_separator sets this flag if the separator was a \n or \r. */
1763 if (dtp
->u
.p
.at_eol
)
1764 finish_separator (dtp
);
1772 if (dtp
->u
.p
.input_complete
)
1775 if (dtp
->u
.p
.repeat_count
> 0)
1777 if (check_type (dtp
, type
, kind
))
1782 if (dtp
->u
.p
.at_eol
)
1783 finish_separator (dtp
);
1787 /* Trailing spaces prior to end of line. */
1788 if (dtp
->u
.p
.at_eol
)
1789 finish_separator (dtp
);
1792 dtp
->u
.p
.saved_type
= BT_NULL
;
1793 dtp
->u
.p
.repeat_count
= 1;
1799 read_integer (dtp
, kind
);
1802 read_logical (dtp
, kind
);
1805 read_character (dtp
, kind
);
1808 read_real (dtp
, kind
);
1811 read_complex (dtp
, kind
, size
);
1814 internal_error (&dtp
->common
, "Bad type for list read");
1817 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1818 dtp
->u
.p
.saved_length
= size
;
1820 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1824 switch (dtp
->u
.p
.saved_type
)
1830 memcpy (p
, dtp
->u
.p
.value
, size
);
1834 if (dtp
->u
.p
.saved_string
)
1836 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1837 ? (int) size
: dtp
->u
.p
.saved_used
;
1839 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1842 q
= (gfc_char4_t
*) p
;
1843 for (i
= 0; i
< m
; i
++)
1844 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1848 /* Just delimiters encountered, nothing to copy but SPACE. */
1854 memset (((char *) p
) + m
, ' ', size
- m
);
1857 q
= (gfc_char4_t
*) p
;
1858 for (i
= m
; i
< (int) size
; i
++)
1859 q
[i
] = (unsigned char) ' ';
1868 if (--dtp
->u
.p
.repeat_count
<= 0)
1872 dtp
->u
.p
.eof_jump
= NULL
;
1877 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1878 size_t size
, size_t nelems
)
1882 size_t stride
= type
== BT_CHARACTER
?
1883 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1887 /* Big loop over all the elements. */
1888 for (elem
= 0; elem
< nelems
; elem
++)
1890 dtp
->u
.p
.item_count
++;
1891 list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1896 /* Finish a list read. */
1899 finish_list_read (st_parameter_dt
*dtp
)
1905 if (dtp
->u
.p
.at_eol
)
1907 dtp
->u
.p
.at_eol
= 0;
1913 c
= next_char (dtp
);
1920 void namelist_read (st_parameter_dt *dtp)
1922 static void nml_match_name (char *name, int len)
1923 static int nml_query (st_parameter_dt *dtp)
1924 static int nml_get_obj_data (st_parameter_dt *dtp,
1925 namelist_info **prev_nl, char *, size_t)
1927 static void nml_untouch_nodes (st_parameter_dt *dtp)
1928 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1930 static int nml_parse_qualifier(descriptor_dimension * ad,
1931 array_loop_spec * ls, int rank, char *)
1932 static void nml_touch_nodes (namelist_info * nl)
1933 static int nml_read_obj (namelist_info *nl, index_type offset,
1934 namelist_info **prev_nl, char *, size_t,
1935 index_type clow, index_type chigh)
1939 /* Inputs a rank-dimensional qualifier, which can contain
1940 singlets, doublets, triplets or ':' with the standard meanings. */
1943 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1944 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1951 int is_array_section
, is_char
;
1955 is_array_section
= 0;
1956 dtp
->u
.p
.expanded_read
= 0;
1958 /* See if this is a character substring qualifier we are looking for. */
1965 /* The next character in the stream should be the '('. */
1967 c
= next_char (dtp
);
1969 /* Process the qualifier, by dimension and triplet. */
1971 for (dim
=0; dim
< rank
; dim
++ )
1973 for (indx
=0; indx
<3; indx
++)
1979 /* Process a potential sign. */
1980 c
= next_char (dtp
);
1991 unget_char (dtp
, c
);
1995 /* Process characters up to the next ':' , ',' or ')'. */
1998 c
= next_char (dtp
);
2003 is_array_section
= 1;
2007 if ((c
==',' && dim
== rank
-1)
2008 || (c
==')' && dim
< rank
-1))
2011 sprintf (parse_err_msg
, "Bad substring qualifier");
2013 sprintf (parse_err_msg
, "Bad number of index fields");
2022 case ' ': case '\t':
2024 c
= next_char (dtp
);
2029 sprintf (parse_err_msg
,
2030 "Bad character in substring qualifier");
2032 sprintf (parse_err_msg
, "Bad character in index");
2036 if ((c
== ',' || c
== ')') && indx
== 0
2037 && dtp
->u
.p
.saved_string
== 0)
2040 sprintf (parse_err_msg
, "Null substring qualifier");
2042 sprintf (parse_err_msg
, "Null index field");
2046 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2047 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2050 sprintf (parse_err_msg
, "Bad substring qualifier");
2052 sprintf (parse_err_msg
, "Bad index triplet");
2056 if (is_char
&& !is_array_section
)
2058 sprintf (parse_err_msg
,
2059 "Missing colon in substring qualifier");
2063 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2065 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2066 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2072 /* Now read the index. */
2073 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2076 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2078 sprintf (parse_err_msg
, "Bad integer in index");
2084 /* Feed the index values to the triplet arrays. */
2088 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2090 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2092 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2095 /* Singlet or doublet indices. */
2096 if (c
==',' || c
==')')
2100 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2102 /* If -std=f95/2003 or an array section is specified,
2103 do not allow excess data to be processed. */
2104 if (is_array_section
== 1
2105 || compile_options
.allow_std
< GFC_STD_GNU
)
2106 ls
[dim
].end
= ls
[dim
].start
;
2108 dtp
->u
.p
.expanded_read
= 1;
2111 /* Check for non-zero rank. */
2112 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2119 /* Check the values of the triplet indices. */
2120 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2121 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2122 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2123 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2126 sprintf (parse_err_msg
, "Substring out of range");
2128 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2132 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2133 || (ls
[dim
].step
== 0))
2135 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2139 /* Initialise the loop index counter. */
2140 ls
[dim
].idx
= ls
[dim
].start
;
2150 static namelist_info
*
2151 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2153 namelist_info
* t
= dtp
->u
.p
.ionml
;
2156 if (strcmp (var_name
, t
->var_name
) == 0)
2166 /* Visits all the components of a derived type that have
2167 not explicitly been identified in the namelist input.
2168 touched is set and the loop specification initialised
2169 to default values */
2172 nml_touch_nodes (namelist_info
* nl
)
2174 index_type len
= strlen (nl
->var_name
) + 1;
2176 char * ext_name
= (char*)get_mem (len
+ 1);
2177 memcpy (ext_name
, nl
->var_name
, len
-1);
2178 memcpy (ext_name
+ len
- 1, "%", 2);
2179 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2181 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2184 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2186 nl
->ls
[dim
].step
= 1;
2187 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2188 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2189 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2195 free_mem (ext_name
);
2199 /* Resets touched for the entire list of nml_nodes, ready for a
2203 nml_untouch_nodes (st_parameter_dt
*dtp
)
2206 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2211 /* Attempts to input name to namelist name. Returns
2212 dtp->u.p.nml_read_error = 1 on no match. */
2215 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2219 dtp
->u
.p
.nml_read_error
= 0;
2220 for (i
= 0; i
< len
; i
++)
2222 c
= next_char (dtp
);
2223 if (tolower (c
) != tolower (name
[i
]))
2225 dtp
->u
.p
.nml_read_error
= 1;
2231 /* If the namelist read is from stdin, output the current state of the
2232 namelist to stdout. This is used to implement the non-standard query
2233 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2234 the names alone are printed. */
2237 nml_query (st_parameter_dt
*dtp
, char c
)
2239 gfc_unit
* temp_unit
;
2244 static const index_type endlen
= 3;
2245 static const char endl
[] = "\r\n";
2246 static const char nmlend
[] = "&end\r\n";
2248 static const index_type endlen
= 2;
2249 static const char endl
[] = "\n";
2250 static const char nmlend
[] = "&end\n";
2253 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2256 /* Store the current unit and transfer to stdout. */
2258 temp_unit
= dtp
->u
.p
.current_unit
;
2259 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2261 if (dtp
->u
.p
.current_unit
)
2263 dtp
->u
.p
.mode
= WRITING
;
2264 next_record (dtp
, 0);
2266 /* Write the namelist in its entirety. */
2269 namelist_write (dtp
);
2271 /* Or write the list of names. */
2275 /* "&namelist_name\n" */
2277 len
= dtp
->namelist_name_len
;
2278 p
= write_block (dtp
, len
+ endlen
);
2282 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2283 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2284 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2288 len
= strlen (nl
->var_name
);
2289 p
= write_block (dtp
, len
+ endlen
);
2293 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2294 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2299 p
= write_block (dtp
, endlen
+ 3);
2301 memcpy (p
, &nmlend
, endlen
+ 3);
2304 /* Flush the stream to force immediate output. */
2306 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2307 flush (dtp
->u
.p
.current_unit
->s
);
2308 unlock_unit (dtp
->u
.p
.current_unit
);
2313 /* Restore the current unit. */
2315 dtp
->u
.p
.current_unit
= temp_unit
;
2316 dtp
->u
.p
.mode
= READING
;
2320 /* Reads and stores the input for the namelist object nl. For an array,
2321 the function loops over the ranges defined by the loop specification.
2322 This default to all the data or to the specification from a qualifier.
2323 nml_read_obj recursively calls itself to read derived types. It visits
2324 all its own components but only reads data for those that were touched
2325 when the name was parsed. If a read error is encountered, an attempt is
2326 made to return to read a new object name because the standard allows too
2327 little data to be available. On the other hand, too much data is an
2331 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2332 namelist_info
**pprev_nl
, char *nml_err_msg
,
2333 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2335 namelist_info
* cmp
;
2342 index_type obj_name_len
;
2345 /* This object not touched in name parsing. */
2350 dtp
->u
.p
.repeat_count
= 0;
2356 case GFC_DTYPE_INTEGER
:
2357 case GFC_DTYPE_LOGICAL
:
2361 case GFC_DTYPE_REAL
:
2362 dlen
= size_from_real_kind (len
);
2365 case GFC_DTYPE_COMPLEX
:
2366 dlen
= size_from_complex_kind (len
);
2369 case GFC_DTYPE_CHARACTER
:
2370 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2379 /* Update the pointer to the data, using the current index vector */
2381 pdata
= (void*)(nl
->mem_pos
+ offset
);
2382 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2383 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2384 nl
->dim
[dim
].stride
* nl
->size
);
2386 /* Reset the error flag and try to read next value, if
2387 dtp->u.p.repeat_count=0 */
2389 dtp
->u
.p
.nml_read_error
= 0;
2391 if (--dtp
->u
.p
.repeat_count
<= 0)
2393 if (dtp
->u
.p
.input_complete
)
2395 if (dtp
->u
.p
.at_eol
)
2396 finish_separator (dtp
);
2397 if (dtp
->u
.p
.input_complete
)
2400 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2401 after the switch block. */
2403 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2408 case GFC_DTYPE_INTEGER
:
2409 read_integer (dtp
, len
);
2412 case GFC_DTYPE_LOGICAL
:
2413 read_logical (dtp
, len
);
2416 case GFC_DTYPE_CHARACTER
:
2417 read_character (dtp
, len
);
2420 case GFC_DTYPE_REAL
:
2421 read_real (dtp
, len
);
2424 case GFC_DTYPE_COMPLEX
:
2425 read_complex (dtp
, len
, dlen
);
2428 case GFC_DTYPE_DERIVED
:
2429 obj_name_len
= strlen (nl
->var_name
) + 1;
2430 obj_name
= get_mem (obj_name_len
+1);
2431 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2432 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2434 /* If reading a derived type, disable the expanded read warning
2435 since a single object can have multiple reads. */
2436 dtp
->u
.p
.expanded_read
= 0;
2438 /* Now loop over the components. Update the component pointer
2439 with the return value from nml_write_obj. This loop jumps
2440 past nested derived types by testing if the potential
2441 component name contains '%'. */
2443 for (cmp
= nl
->next
;
2445 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2446 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2450 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2451 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2452 clow
, chigh
) == FAILURE
)
2454 free_mem (obj_name
);
2458 if (dtp
->u
.p
.input_complete
)
2460 free_mem (obj_name
);
2465 free_mem (obj_name
);
2469 snprintf (nml_err_msg
, nml_err_msg_size
,
2470 "Bad type for namelist object %s", nl
->var_name
);
2471 internal_error (&dtp
->common
, nml_err_msg
);
2476 /* The standard permits array data to stop short of the number of
2477 elements specified in the loop specification. In this case, we
2478 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2479 nml_get_obj_data and an attempt is made to read object name. */
2482 if (dtp
->u
.p
.nml_read_error
)
2484 dtp
->u
.p
.expanded_read
= 0;
2488 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2490 dtp
->u
.p
.expanded_read
= 0;
2494 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2495 This comes about because the read functions return BT_types. */
2497 switch (dtp
->u
.p
.saved_type
)
2504 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2508 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2509 pdata
= (void*)( pdata
+ clow
- 1 );
2510 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2512 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2519 /* Warn if a non-standard expanded read occurs. A single read of a
2520 single object is acceptable. If a second read occurs, issue a warning
2521 and set the flag to zero to prevent further warnings. */
2522 if (dtp
->u
.p
.expanded_read
== 2)
2524 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2525 dtp
->u
.p
.expanded_read
= 0;
2528 /* If the expanded read warning flag is set, increment it,
2529 indicating that a single read has occurred. */
2530 if (dtp
->u
.p
.expanded_read
>= 1)
2531 dtp
->u
.p
.expanded_read
++;
2533 /* Break out of loop if scalar. */
2537 /* Now increment the index vector. */
2542 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2544 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2546 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2548 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2550 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2554 } while (!nml_carry
);
2556 if (dtp
->u
.p
.repeat_count
> 1)
2558 snprintf (nml_err_msg
, nml_err_msg_size
,
2559 "Repeat count too large for namelist object %s", nl
->var_name
);
2569 /* Parses the object name, including array and substring qualifiers. It
2570 iterates over derived type components, touching those components and
2571 setting their loop specifications, if there is a qualifier. If the
2572 object is itself a derived type, its components and subcomponents are
2573 touched. nml_read_obj is called at the end and this reads the data in
2574 the manner specified by the object name. */
2577 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2578 char *nml_err_msg
, size_t nml_err_msg_size
)
2582 namelist_info
* first_nl
= NULL
;
2583 namelist_info
* root_nl
= NULL
;
2584 int dim
, parsed_rank
;
2586 index_type clow
, chigh
;
2587 int non_zero_rank_count
;
2589 /* Look for end of input or object name. If '?' or '=?' are encountered
2590 in stdin, print the node names or the namelist to stdout. */
2592 eat_separator (dtp
);
2593 if (dtp
->u
.p
.input_complete
)
2596 if (dtp
->u
.p
.at_eol
)
2597 finish_separator (dtp
);
2598 if (dtp
->u
.p
.input_complete
)
2601 c
= next_char (dtp
);
2605 c
= next_char (dtp
);
2608 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2611 nml_query (dtp
, '=');
2615 nml_query (dtp
, '?');
2620 nml_match_name (dtp
, "end", 3);
2621 if (dtp
->u
.p
.nml_read_error
)
2623 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2627 dtp
->u
.p
.input_complete
= 1;
2634 /* Untouch all nodes of the namelist and reset the flag that is set for
2635 derived type components. */
2637 nml_untouch_nodes (dtp
);
2639 non_zero_rank_count
= 0;
2641 /* Get the object name - should '!' and '\n' be permitted separators? */
2649 if (!is_separator (c
))
2650 push_char (dtp
, tolower(c
));
2651 c
= next_char (dtp
);
2652 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2654 unget_char (dtp
, c
);
2656 /* Check that the name is in the namelist and get pointer to object.
2657 Three error conditions exist: (i) An attempt is being made to
2658 identify a non-existent object, following a failed data read or
2659 (ii) The object name does not exist or (iii) Too many data items
2660 are present for an object. (iii) gives the same error message
2663 push_char (dtp
, '\0');
2667 size_t var_len
= strlen (root_nl
->var_name
);
2669 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2670 char ext_name
[var_len
+ saved_len
+ 1];
2672 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2673 if (dtp
->u
.p
.saved_string
)
2674 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2675 ext_name
[var_len
+ saved_len
] = '\0';
2676 nl
= find_nml_node (dtp
, ext_name
);
2679 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2683 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2684 snprintf (nml_err_msg
, nml_err_msg_size
,
2685 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2688 snprintf (nml_err_msg
, nml_err_msg_size
,
2689 "Cannot match namelist object name %s",
2690 dtp
->u
.p
.saved_string
);
2695 /* Get the length, data length, base pointer and rank of the variable.
2696 Set the default loop specification first. */
2698 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2700 nl
->ls
[dim
].step
= 1;
2701 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2702 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2703 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2706 /* Check to see if there is a qualifier: if so, parse it.*/
2708 if (c
== '(' && nl
->var_rank
)
2711 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2712 nml_err_msg
, &parsed_rank
) == FAILURE
)
2714 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2715 snprintf (nml_err_msg_end
,
2716 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2717 " for namelist variable %s", nl
->var_name
);
2721 if (parsed_rank
> 0)
2722 non_zero_rank_count
++;
2724 c
= next_char (dtp
);
2725 unget_char (dtp
, c
);
2727 else if (nl
->var_rank
> 0)
2728 non_zero_rank_count
++;
2730 /* Now parse a derived type component. The root namelist_info address
2731 is backed up, as is the previous component level. The component flag
2732 is set and the iteration is made by jumping back to get_name. */
2736 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2738 snprintf (nml_err_msg
, nml_err_msg_size
,
2739 "Attempt to get derived component for %s", nl
->var_name
);
2743 if (!component_flag
)
2748 c
= next_char (dtp
);
2752 /* Parse a character qualifier, if present. chigh = 0 is a default
2753 that signals that the string length = string_length. */
2758 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2760 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2761 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2763 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2766 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2767 snprintf (nml_err_msg_end
,
2768 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2769 " for namelist variable %s", nl
->var_name
);
2773 clow
= ind
[0].start
;
2776 if (ind
[0].step
!= 1)
2778 snprintf (nml_err_msg
, nml_err_msg_size
,
2779 "Step not allowed in substring qualifier"
2780 " for namelist object %s", nl
->var_name
);
2784 c
= next_char (dtp
);
2785 unget_char (dtp
, c
);
2788 /* If a derived type touch its components and restore the root
2789 namelist_info if we have parsed a qualified derived type
2792 if (nl
->type
== GFC_DTYPE_DERIVED
)
2793 nml_touch_nodes (nl
);
2797 /* Make sure no extraneous qualifiers are there. */
2801 snprintf (nml_err_msg
, nml_err_msg_size
,
2802 "Qualifier for a scalar or non-character namelist object %s",
2807 /* Make sure there is no more than one non-zero rank object. */
2808 if (non_zero_rank_count
> 1)
2810 snprintf (nml_err_msg
, nml_err_msg_size
,
2811 "Multiple sub-objects with non-zero rank in namelist object %s",
2813 non_zero_rank_count
= 0;
2817 /* According to the standard, an equal sign MUST follow an object name. The
2818 following is possibly lax - it allows comments, blank lines and so on to
2819 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2823 eat_separator (dtp
);
2824 if (dtp
->u
.p
.input_complete
)
2827 if (dtp
->u
.p
.at_eol
)
2828 finish_separator (dtp
);
2829 if (dtp
->u
.p
.input_complete
)
2832 c
= next_char (dtp
);
2836 snprintf (nml_err_msg
, nml_err_msg_size
,
2837 "Equal sign must follow namelist object name %s",
2842 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2843 clow
, chigh
) == FAILURE
)
2853 /* Entry point for namelist input. Goes through input until namelist name
2854 is matched. Then cycles through nml_get_obj_data until the input is
2855 completed or there is an error. */
2858 namelist_read (st_parameter_dt
*dtp
)
2862 char nml_err_msg
[200];
2863 /* Pointer to the previously read object, in case attempt is made to read
2864 new object name. Should this fail, error message can give previous
2866 namelist_info
*prev_nl
= NULL
;
2868 dtp
->u
.p
.namelist_mode
= 1;
2869 dtp
->u
.p
.input_complete
= 0;
2870 dtp
->u
.p
.expanded_read
= 0;
2872 dtp
->u
.p
.eof_jump
= &eof_jump
;
2873 if (setjmp (eof_jump
))
2875 dtp
->u
.p
.eof_jump
= NULL
;
2876 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2880 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2881 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2882 node names or namelist on stdout. */
2885 switch (c
= next_char (dtp
))
2896 c
= next_char (dtp
);
2898 nml_query (dtp
, '=');
2900 unget_char (dtp
, c
);
2904 nml_query (dtp
, '?');
2910 /* Match the name of the namelist. */
2912 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2914 if (dtp
->u
.p
.nml_read_error
)
2917 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2918 c
= next_char (dtp
);
2919 if (!is_separator(c
) && c
!= '!')
2921 unget_char (dtp
, c
);
2925 unget_char (dtp
, c
);
2926 eat_separator (dtp
);
2928 /* Ready to read namelist objects. If there is an error in input
2929 from stdin, output the error message and continue. */
2931 while (!dtp
->u
.p
.input_complete
)
2933 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2938 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2941 u
= find_unit (options
.stderr_unit
);
2942 st_printf ("%s\n", nml_err_msg
);
2952 dtp
->u
.p
.eof_jump
= NULL
;
2957 /* All namelist error calls return from here */
2961 dtp
->u
.p
.eof_jump
= NULL
;
2964 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);