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. */
40 /* List directed input. Several parsing subroutines are practically
41 reimplemented from formatted input, the reason being that there are
42 all kinds of small differences between formatted and list directed
46 /* Subroutines for reading characters from the input. Because a
47 repeat count is ambiguous with an integer, we have to read the
48 whole digit string before seeing if there is a '*' which signals
49 the repeat count. Since we can have a lot of potential leading
50 zeros, we have to be able to back up by arbitrary amount. Because
51 the input might not be seekable, we have to buffer the data
54 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
55 case '5': case '6': case '7': case '8': case '9'
57 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
60 /* This macro assumes that we're operating on a variable. */
62 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
63 || c == '\t' || c == '\r' || c == ';')
65 /* Maximum repeat count. Less than ten times the maximum signed int32. */
67 #define MAX_REPEAT 200000000
71 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
74 /* Save a character to a string buffer, enlarging it as necessary. */
77 push_char (st_parameter_dt
*dtp
, char c
)
81 if (dtp
->u
.p
.saved_string
== NULL
)
83 dtp
->u
.p
.saved_string
= get_mem (SCRATCH_SIZE
);
84 // memset below should be commented out.
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 = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
95 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
96 dtp
->u
.p
.saved_string
= new;
98 // Also this should not be necessary.
99 memset (new + dtp
->u
.p
.saved_used
, 0,
100 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
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 free_mem (dtp
->u
.p
.saved_string
);
118 dtp
->u
.p
.saved_string
= NULL
;
119 dtp
->u
.p
.saved_used
= 0;
123 /* Free the line buffer if necessary. */
126 free_line (st_parameter_dt
*dtp
)
128 dtp
->u
.p
.item_count
= 0;
129 dtp
->u
.p
.line_buffer_enabled
= 0;
131 if (dtp
->u
.p
.line_buffer
== NULL
)
134 free_mem (dtp
->u
.p
.line_buffer
);
135 dtp
->u
.p
.line_buffer
= NULL
;
140 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
, SEEK_SET
) < 0)
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. */
207 if (is_internal_unit (dtp
))
209 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, 1);
212 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
216 if (is_array_io (dtp
))
218 /* Check whether we hit EOF. */
221 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
224 dtp
->u
.p
.current_unit
->bytes_left
--;
229 longjmp (*dtp
->u
.p
.eof_jump
, 1);
239 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
243 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
244 longjmp (*dtp
->u
.p
.eof_jump
, 1);
245 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
250 if (is_stream_io (dtp
) && cc
!= EOF
)
251 dtp
->u
.p
.current_unit
->strm_pos
++;
255 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
260 /* Push a character back onto the input. */
263 unget_char (st_parameter_dt
*dtp
, char c
)
265 dtp
->u
.p
.last_char
= c
;
269 /* Skip over spaces in the input. Returns the nonspace character that
270 terminated the eating and also places it back on the input. */
273 eat_spaces (st_parameter_dt
*dtp
)
281 while (c
== ' ' || c
== '\t');
288 /* This function reads characters through to the end of the current line and
289 just ignores them. */
292 eat_line (st_parameter_dt
*dtp
)
295 if (!is_internal_unit (dtp
))
302 /* Skip over a separator. Technically, we don't always eat the whole
303 separator. This is because if we've processed the last input item,
304 then a separator is unnecessary. Plus the fact that operating
305 systems usually deliver console input on a line basis.
307 The upshot is that if we see a newline as part of reading a
308 separator, we stop reading. If there are more input items, we
309 continue reading the separator with finish_separator() which takes
310 care of the fact that we may or may not have seen a comma as part
314 eat_separator (st_parameter_dt
*dtp
)
319 dtp
->u
.p
.comma_flag
= 0;
325 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
332 dtp
->u
.p
.comma_flag
= 1;
337 dtp
->u
.p
.input_complete
= 1;
351 if (dtp
->u
.p
.namelist_mode
)
367 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
373 if (dtp
->u
.p
.namelist_mode
)
374 { /* Eat a namelist comment. */
382 /* Fall Through... */
391 /* Finish processing a separator that was interrupted by a newline.
392 If we're here, then another data item is present, so we finish what
393 we started on the previous line. */
396 finish_separator (st_parameter_dt
*dtp
)
407 if (dtp
->u
.p
.comma_flag
)
411 c
= eat_spaces (dtp
);
412 if (c
== '\n' || c
== '\r')
419 dtp
->u
.p
.input_complete
= 1;
420 if (!dtp
->u
.p
.namelist_mode
)
429 if (dtp
->u
.p
.namelist_mode
)
445 /* This function is needed to catch bad conversions so that namelist can
446 attempt to see if dtp->u.p.saved_string contains a new object name rather
450 nml_bad_return (st_parameter_dt
*dtp
, char c
)
452 if (dtp
->u
.p
.namelist_mode
)
454 dtp
->u
.p
.nml_read_error
= 1;
461 /* Convert an unsigned string to an integer. The length value is -1
462 if we are working on a repeat count. Returns nonzero if we have a
463 range problem. As a side effect, frees the dtp->u.p.saved_string. */
466 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
468 char c
, *buffer
, message
[100];
470 GFC_INTEGER_LARGEST v
, max
, max10
;
472 buffer
= dtp
->u
.p
.saved_string
;
475 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
500 set_integer (dtp
->u
.p
.value
, v
, length
);
504 dtp
->u
.p
.repeat_count
= v
;
506 if (dtp
->u
.p
.repeat_count
== 0)
508 sprintf (message
, "Zero repeat count in item %d of list input",
509 dtp
->u
.p
.item_count
);
511 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
521 sprintf (message
, "Repeat count overflow in item %d of list input",
522 dtp
->u
.p
.item_count
);
524 sprintf (message
, "Integer overflow while reading item %d",
525 dtp
->u
.p
.item_count
);
528 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
534 /* Parse a repeat count for logical and complex values which cannot
535 begin with a digit. Returns nonzero if we are done, zero if we
536 should continue on. */
539 parse_repeat (st_parameter_dt
*dtp
)
541 char c
, message
[100];
567 repeat
= 10 * repeat
+ c
- '0';
569 if (repeat
> MAX_REPEAT
)
572 "Repeat count overflow in item %d of list input",
573 dtp
->u
.p
.item_count
);
575 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
585 "Zero repeat count in item %d of list input",
586 dtp
->u
.p
.item_count
);
588 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
600 dtp
->u
.p
.repeat_count
= repeat
;
607 sprintf (message
, "Bad repeat count in item %d of list input",
608 dtp
->u
.p
.item_count
);
609 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
614 /* To read a logical we have to look ahead in the input stream to make sure
615 there is not an equal sign indicating a variable name. To do this we use
616 line_buffer to point to a temporary buffer, pushing characters there for
617 possible later reading. */
620 l_push_char (st_parameter_dt
*dtp
, char c
)
622 if (dtp
->u
.p
.line_buffer
== NULL
)
624 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
625 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
628 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
632 /* Read a logical character on the input. */
635 read_logical (st_parameter_dt
*dtp
, int length
)
637 char c
, message
[100];
640 if (parse_repeat (dtp
))
643 c
= tolower (next_char (dtp
));
644 l_push_char (dtp
, c
);
650 l_push_char (dtp
, c
);
652 if (!is_separator(c
))
660 l_push_char (dtp
, c
);
662 if (!is_separator(c
))
669 c
= tolower (next_char (dtp
));
687 return; /* Null value. */
690 /* Save the character in case it is the beginning
691 of the next object name. */
696 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
697 dtp
->u
.p
.saved_length
= length
;
699 /* Eat trailing garbage. */
704 while (!is_separator (c
));
708 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
715 for(i
= 0; i
< 63; i
++)
720 /* All done if this is not a namelist read. */
721 if (!dtp
->u
.p
.namelist_mode
)
734 l_push_char (dtp
, c
);
737 dtp
->u
.p
.nml_read_error
= 1;
738 dtp
->u
.p
.line_buffer_enabled
= 1;
739 dtp
->u
.p
.item_count
= 0;
749 if (nml_bad_return (dtp
, c
))
754 sprintf (message
, "Bad logical value while reading item %d",
755 dtp
->u
.p
.item_count
);
756 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
761 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
762 dtp
->u
.p
.saved_length
= length
;
763 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
769 /* Reading integers is tricky because we can actually be reading a
770 repeat count. We have to store the characters in a buffer because
771 we could be reading an integer that is larger than the default int
772 used for repeat counts. */
775 read_integer (st_parameter_dt
*dtp
, int length
)
777 char c
, message
[100];
787 /* Fall through... */
793 CASE_SEPARATORS
: /* Single null. */
806 /* Take care of what may be a repeat count. */
818 push_char (dtp
, '\0');
821 CASE_SEPARATORS
: /* Not a repeat count. */
830 if (convert_integer (dtp
, -1, 0))
833 /* Get the real integer. */
848 /* Fall through... */
879 if (nml_bad_return (dtp
, c
))
884 sprintf (message
, "Bad integer for item %d in list input",
885 dtp
->u
.p
.item_count
);
886 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
894 push_char (dtp
, '\0');
895 if (convert_integer (dtp
, length
, negative
))
902 dtp
->u
.p
.saved_type
= BT_INTEGER
;
906 /* Read a character variable. */
909 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
911 char c
, quote
, message
[100];
913 quote
= ' '; /* Space means no quote character. */
923 unget_char (dtp
, c
); /* NULL value. */
933 if (dtp
->u
.p
.namelist_mode
)
943 /* Deal with a possible repeat count. */
956 goto done
; /* String was only digits! */
959 push_char (dtp
, '\0');
964 goto get_string
; /* Not a repeat count after all. */
969 if (convert_integer (dtp
, -1, 0))
972 /* Now get the real string. */
978 unget_char (dtp
, c
); /* Repeated NULL values. */
1006 /* See if we have a doubled quote character or the end of
1009 c
= next_char (dtp
);
1012 push_char (dtp
, quote
);
1016 unget_char (dtp
, c
);
1022 unget_char (dtp
, c
);
1026 if (c
!= '\n' && c
!= '\r')
1036 /* At this point, we have to have a separator, or else the string is
1039 c
= next_char (dtp
);
1040 if (is_separator (c
) || c
== '!')
1042 unget_char (dtp
, c
);
1043 eat_separator (dtp
);
1044 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1050 sprintf (message
, "Invalid string input in item %d",
1051 dtp
->u
.p
.item_count
);
1052 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1057 /* Parse a component of a complex constant or a real number that we
1058 are sure is already there. This is a straight real number parser. */
1061 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1063 char c
, message
[100];
1066 c
= next_char (dtp
);
1067 if (c
== '-' || c
== '+')
1070 c
= next_char (dtp
);
1073 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1076 if (!isdigit (c
) && c
!= '.')
1078 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1086 seen_dp
= (c
== '.') ? 1 : 0;
1090 c
= next_char (dtp
);
1091 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1111 push_char (dtp
, 'e');
1116 push_char (dtp
, 'e');
1118 c
= next_char (dtp
);
1122 unget_char (dtp
, c
);
1131 c
= next_char (dtp
);
1132 if (c
!= '-' && c
!= '+')
1133 push_char (dtp
, '+');
1137 c
= next_char (dtp
);
1148 c
= next_char (dtp
);
1156 unget_char (dtp
, c
);
1165 unget_char (dtp
, c
);
1166 push_char (dtp
, '\0');
1168 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1174 /* Match INF and Infinity. */
1175 if ((c
== 'i' || c
== 'I')
1176 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1177 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1179 c
= next_char (dtp
);
1180 if ((c
!= 'i' && c
!= 'I')
1181 || ((c
== 'i' || c
== 'I')
1182 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1183 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1184 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1185 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1186 && (c
= next_char (dtp
))))
1188 if (is_separator (c
))
1189 unget_char (dtp
, c
);
1190 push_char (dtp
, 'i');
1191 push_char (dtp
, 'n');
1192 push_char (dtp
, 'f');
1196 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1197 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1198 && (c
= next_char (dtp
)))
1200 if (is_separator (c
))
1201 unget_char (dtp
, c
);
1202 push_char (dtp
, 'n');
1203 push_char (dtp
, 'a');
1204 push_char (dtp
, 'n');
1210 if (nml_bad_return (dtp
, c
))
1215 sprintf (message
, "Bad floating point number for item %d",
1216 dtp
->u
.p
.item_count
);
1217 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1223 /* Reading a complex number is straightforward because we can tell
1224 what it is right away. */
1227 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1232 if (parse_repeat (dtp
))
1235 c
= next_char (dtp
);
1242 unget_char (dtp
, c
);
1243 eat_separator (dtp
);
1251 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1256 c
= next_char (dtp
);
1257 if (c
== '\n' || c
== '\r')
1260 unget_char (dtp
, c
);
1263 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1268 c
= next_char (dtp
);
1269 if (c
== '\n' || c
== '\r')
1272 unget_char (dtp
, c
);
1274 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1278 if (next_char (dtp
) != ')')
1281 c
= next_char (dtp
);
1282 if (!is_separator (c
))
1285 unget_char (dtp
, c
);
1286 eat_separator (dtp
);
1289 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1294 if (nml_bad_return (dtp
, c
))
1299 sprintf (message
, "Bad complex value in item %d of list input",
1300 dtp
->u
.p
.item_count
);
1301 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1305 /* Parse a real number with a possible repeat count. */
1308 read_real (st_parameter_dt
*dtp
, int length
)
1310 char c
, message
[100];
1316 c
= next_char (dtp
);
1317 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1335 unget_char (dtp
, c
); /* Single null. */
1336 eat_separator (dtp
);
1349 /* Get the digit string that might be a repeat count. */
1353 c
= next_char (dtp
);
1354 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1378 push_char (dtp
, 'e');
1380 c
= next_char (dtp
);
1384 push_char (dtp
, '\0');
1388 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1389 unget_char (dtp
, c
);
1398 if (convert_integer (dtp
, -1, 0))
1401 /* Now get the number itself. */
1403 c
= next_char (dtp
);
1404 if (is_separator (c
))
1405 { /* Repeated null value. */
1406 unget_char (dtp
, c
);
1407 eat_separator (dtp
);
1411 if (c
!= '-' && c
!= '+')
1412 push_char (dtp
, '+');
1417 c
= next_char (dtp
);
1420 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1423 if (!isdigit (c
) && c
!= '.')
1425 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1444 c
= next_char (dtp
);
1445 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1472 push_char (dtp
, 'e');
1474 c
= next_char (dtp
);
1483 push_char (dtp
, 'e');
1485 c
= next_char (dtp
);
1486 if (c
!= '+' && c
!= '-')
1487 push_char (dtp
, '+');
1491 c
= next_char (dtp
);
1501 c
= next_char (dtp
);
1518 unget_char (dtp
, c
);
1519 eat_separator (dtp
);
1520 push_char (dtp
, '\0');
1521 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1525 dtp
->u
.p
.saved_type
= BT_REAL
;
1529 l_push_char (dtp
, c
);
1532 /* Match INF and Infinity. */
1533 if (c
== 'i' || c
== 'I')
1535 c
= next_char (dtp
);
1536 l_push_char (dtp
, c
);
1537 if (c
!= 'n' && c
!= 'N')
1539 c
= next_char (dtp
);
1540 l_push_char (dtp
, c
);
1541 if (c
!= 'f' && c
!= 'F')
1543 c
= next_char (dtp
);
1544 l_push_char (dtp
, c
);
1545 if (!is_separator (c
))
1547 if (c
!= 'i' && c
!= 'I')
1549 c
= next_char (dtp
);
1550 l_push_char (dtp
, c
);
1551 if (c
!= 'n' && c
!= 'N')
1553 c
= next_char (dtp
);
1554 l_push_char (dtp
, c
);
1555 if (c
!= 'i' && c
!= 'I')
1557 c
= next_char (dtp
);
1558 l_push_char (dtp
, c
);
1559 if (c
!= 't' && c
!= 'T')
1561 c
= next_char (dtp
);
1562 l_push_char (dtp
, c
);
1563 if (c
!= 'y' && c
!= 'Y')
1565 c
= next_char (dtp
);
1566 l_push_char (dtp
, c
);
1572 c
= next_char (dtp
);
1573 l_push_char (dtp
, c
);
1574 if (c
!= 'a' && c
!= 'A')
1576 c
= next_char (dtp
);
1577 l_push_char (dtp
, c
);
1578 if (c
!= 'n' && c
!= 'N')
1580 c
= next_char (dtp
);
1581 l_push_char (dtp
, c
);
1584 if (!is_separator (c
))
1587 if (dtp
->u
.p
.namelist_mode
)
1589 if (c
== ' ' || c
=='\n' || c
== '\r')
1592 c
= next_char (dtp
);
1593 while (c
== ' ' || c
=='\n' || c
== '\r');
1595 l_push_char (dtp
, c
);
1604 push_char (dtp
, 'i');
1605 push_char (dtp
, 'n');
1606 push_char (dtp
, 'f');
1610 push_char (dtp
, 'n');
1611 push_char (dtp
, 'a');
1612 push_char (dtp
, 'n');
1619 if (dtp
->u
.p
.namelist_mode
)
1621 dtp
->u
.p
.nml_read_error
= 1;
1622 dtp
->u
.p
.line_buffer_enabled
= 1;
1623 dtp
->u
.p
.item_count
= 0;
1629 if (nml_bad_return (dtp
, c
))
1634 sprintf (message
, "Bad real number in item %d of list input",
1635 dtp
->u
.p
.item_count
);
1636 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1640 /* Check the current type against the saved type to make sure they are
1641 compatible. Returns nonzero if incompatible. */
1644 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1648 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1650 sprintf (message
, "Read type %s where %s was expected for item %d",
1651 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1652 dtp
->u
.p
.item_count
);
1654 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1658 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1661 if (dtp
->u
.p
.saved_length
!= len
)
1664 "Read kind %d %s where kind %d is required for item %d",
1665 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1666 dtp
->u
.p
.item_count
);
1667 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1675 /* Top level data transfer subroutine for list reads. Because we have
1676 to deal with repeat counts, the data item is always saved after
1677 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1678 greater than one, we copy the data item multiple times. */
1681 list_formatted_read_scalar (st_parameter_dt
*dtp
, volatile bt type
, void *p
,
1682 int kind
, size_t size
)
1689 dtp
->u
.p
.namelist_mode
= 0;
1691 dtp
->u
.p
.eof_jump
= &eof_jump
;
1692 if (setjmp (eof_jump
))
1694 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1698 if (dtp
->u
.p
.first_item
)
1700 dtp
->u
.p
.first_item
= 0;
1701 dtp
->u
.p
.input_complete
= 0;
1702 dtp
->u
.p
.repeat_count
= 1;
1703 dtp
->u
.p
.at_eol
= 0;
1705 c
= eat_spaces (dtp
);
1706 if (is_separator (c
))
1708 /* Found a null value. */
1709 eat_separator (dtp
);
1710 dtp
->u
.p
.repeat_count
= 0;
1712 /* eat_separator sets this flag if the separator was a comma. */
1713 if (dtp
->u
.p
.comma_flag
)
1716 /* eat_separator sets this flag if the separator was a \n or \r. */
1717 if (dtp
->u
.p
.at_eol
)
1718 finish_separator (dtp
);
1726 if (dtp
->u
.p
.repeat_count
> 0)
1728 if (check_type (dtp
, type
, kind
))
1733 if (dtp
->u
.p
.input_complete
)
1736 if (dtp
->u
.p
.input_complete
)
1739 if (dtp
->u
.p
.at_eol
)
1740 finish_separator (dtp
);
1744 /* Trailing spaces prior to end of line. */
1745 if (dtp
->u
.p
.at_eol
)
1746 finish_separator (dtp
);
1749 dtp
->u
.p
.saved_type
= BT_NULL
;
1750 dtp
->u
.p
.repeat_count
= 1;
1756 read_integer (dtp
, kind
);
1759 read_logical (dtp
, kind
);
1762 read_character (dtp
, kind
);
1765 read_real (dtp
, kind
);
1768 read_complex (dtp
, kind
, size
);
1771 internal_error (&dtp
->common
, "Bad type for list read");
1774 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1775 dtp
->u
.p
.saved_length
= size
;
1777 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1781 switch (dtp
->u
.p
.saved_type
)
1787 memcpy (p
, dtp
->u
.p
.value
, size
);
1791 if (dtp
->u
.p
.saved_string
)
1793 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1794 ? (int) size
: dtp
->u
.p
.saved_used
;
1796 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1799 q
= (gfc_char4_t
*) p
;
1800 for (i
= 0; i
< m
; i
++)
1801 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1805 /* Just delimiters encountered, nothing to copy but SPACE. */
1811 memset (((char *) p
) + m
, ' ', size
- m
);
1814 q
= (gfc_char4_t
*) p
;
1815 for (i
= m
; i
< (int) size
; i
++)
1816 q
[i
] = (unsigned char) ' ';
1825 if (--dtp
->u
.p
.repeat_count
<= 0)
1829 dtp
->u
.p
.eof_jump
= NULL
;
1834 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1835 size_t size
, size_t nelems
)
1839 size_t stride
= type
== BT_CHARACTER
?
1840 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1844 /* Big loop over all the elements. */
1845 for (elem
= 0; elem
< nelems
; elem
++)
1847 dtp
->u
.p
.item_count
++;
1848 list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1853 /* Finish a list read. */
1856 finish_list_read (st_parameter_dt
*dtp
)
1862 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1864 if (dtp
->u
.p
.at_eol
)
1866 dtp
->u
.p
.at_eol
= 0;
1872 c
= next_char (dtp
);
1876 if (dtp
->u
.p
.current_unit
->endfile
!= NO_ENDFILE
)
1878 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1879 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1880 dtp
->u
.p
.current_unit
->current_record
= 0;
1886 void namelist_read (st_parameter_dt *dtp)
1888 static void nml_match_name (char *name, int len)
1889 static int nml_query (st_parameter_dt *dtp)
1890 static int nml_get_obj_data (st_parameter_dt *dtp,
1891 namelist_info **prev_nl, char *, size_t)
1893 static void nml_untouch_nodes (st_parameter_dt *dtp)
1894 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1896 static int nml_parse_qualifier(descriptor_dimension * ad,
1897 array_loop_spec * ls, int rank, char *)
1898 static void nml_touch_nodes (namelist_info * nl)
1899 static int nml_read_obj (namelist_info *nl, index_type offset,
1900 namelist_info **prev_nl, char *, size_t,
1901 index_type clow, index_type chigh)
1905 /* Inputs a rank-dimensional qualifier, which can contain
1906 singlets, doublets, triplets or ':' with the standard meanings. */
1909 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1910 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1917 int is_array_section
, is_char
;
1921 is_array_section
= 0;
1922 dtp
->u
.p
.expanded_read
= 0;
1924 /* See if this is a character substring qualifier we are looking for. */
1931 /* The next character in the stream should be the '('. */
1933 c
= next_char (dtp
);
1935 /* Process the qualifier, by dimension and triplet. */
1937 for (dim
=0; dim
< rank
; dim
++ )
1939 for (indx
=0; indx
<3; indx
++)
1945 /* Process a potential sign. */
1946 c
= next_char (dtp
);
1957 unget_char (dtp
, c
);
1961 /* Process characters up to the next ':' , ',' or ')'. */
1964 c
= next_char (dtp
);
1969 is_array_section
= 1;
1973 if ((c
==',' && dim
== rank
-1)
1974 || (c
==')' && dim
< rank
-1))
1977 sprintf (parse_err_msg
, "Bad substring qualifier");
1979 sprintf (parse_err_msg
, "Bad number of index fields");
1988 case ' ': case '\t':
1990 c
= next_char (dtp
);
1995 sprintf (parse_err_msg
,
1996 "Bad character in substring qualifier");
1998 sprintf (parse_err_msg
, "Bad character in index");
2002 if ((c
== ',' || c
== ')') && indx
== 0
2003 && dtp
->u
.p
.saved_string
== 0)
2006 sprintf (parse_err_msg
, "Null substring qualifier");
2008 sprintf (parse_err_msg
, "Null index field");
2012 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2013 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2016 sprintf (parse_err_msg
, "Bad substring qualifier");
2018 sprintf (parse_err_msg
, "Bad index triplet");
2022 if (is_char
&& !is_array_section
)
2024 sprintf (parse_err_msg
,
2025 "Missing colon in substring qualifier");
2029 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2031 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2032 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2038 /* Now read the index. */
2039 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2042 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2044 sprintf (parse_err_msg
, "Bad integer in index");
2050 /* Feed the index values to the triplet arrays. */
2054 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2056 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2058 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2061 /* Singlet or doublet indices. */
2062 if (c
==',' || c
==')')
2066 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2068 /* If -std=f95/2003 or an array section is specified,
2069 do not allow excess data to be processed. */
2070 if (is_array_section
== 1
2071 || compile_options
.allow_std
< GFC_STD_GNU
)
2072 ls
[dim
].end
= ls
[dim
].start
;
2074 dtp
->u
.p
.expanded_read
= 1;
2077 /* Check for non-zero rank. */
2078 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2085 /* Check the values of the triplet indices. */
2086 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2087 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2088 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2089 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2092 sprintf (parse_err_msg
, "Substring out of range");
2094 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2098 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2099 || (ls
[dim
].step
== 0))
2101 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2105 /* Initialise the loop index counter. */
2106 ls
[dim
].idx
= ls
[dim
].start
;
2116 static namelist_info
*
2117 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2119 namelist_info
* t
= dtp
->u
.p
.ionml
;
2122 if (strcmp (var_name
, t
->var_name
) == 0)
2132 /* Visits all the components of a derived type that have
2133 not explicitly been identified in the namelist input.
2134 touched is set and the loop specification initialised
2135 to default values */
2138 nml_touch_nodes (namelist_info
* nl
)
2140 index_type len
= strlen (nl
->var_name
) + 1;
2142 char * ext_name
= (char*)get_mem (len
+ 1);
2143 memcpy (ext_name
, nl
->var_name
, len
-1);
2144 memcpy (ext_name
+ len
- 1, "%", 2);
2145 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2147 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2150 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2152 nl
->ls
[dim
].step
= 1;
2153 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2154 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2155 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2161 free_mem (ext_name
);
2165 /* Resets touched for the entire list of nml_nodes, ready for a
2169 nml_untouch_nodes (st_parameter_dt
*dtp
)
2172 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2177 /* Attempts to input name to namelist name. Returns
2178 dtp->u.p.nml_read_error = 1 on no match. */
2181 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2185 dtp
->u
.p
.nml_read_error
= 0;
2186 for (i
= 0; i
< len
; i
++)
2188 c
= next_char (dtp
);
2189 if (tolower (c
) != tolower (name
[i
]))
2191 dtp
->u
.p
.nml_read_error
= 1;
2197 /* If the namelist read is from stdin, output the current state of the
2198 namelist to stdout. This is used to implement the non-standard query
2199 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2200 the names alone are printed. */
2203 nml_query (st_parameter_dt
*dtp
, char c
)
2205 gfc_unit
* temp_unit
;
2210 static const index_type endlen
= 3;
2211 static const char endl
[] = "\r\n";
2212 static const char nmlend
[] = "&end\r\n";
2214 static const index_type endlen
= 2;
2215 static const char endl
[] = "\n";
2216 static const char nmlend
[] = "&end\n";
2219 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2222 /* Store the current unit and transfer to stdout. */
2224 temp_unit
= dtp
->u
.p
.current_unit
;
2225 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2227 if (dtp
->u
.p
.current_unit
)
2229 dtp
->u
.p
.mode
= WRITING
;
2230 next_record (dtp
, 0);
2232 /* Write the namelist in its entirety. */
2235 namelist_write (dtp
);
2237 /* Or write the list of names. */
2241 /* "&namelist_name\n" */
2243 len
= dtp
->namelist_name_len
;
2244 p
= write_block (dtp
, len
+ endlen
);
2248 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2249 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2250 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2254 len
= strlen (nl
->var_name
);
2255 p
= write_block (dtp
, len
+ endlen
);
2259 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2260 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2265 p
= write_block (dtp
, endlen
+ 3);
2267 memcpy (p
, &nmlend
, endlen
+ 3);
2270 /* Flush the stream to force immediate output. */
2272 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2273 sflush (dtp
->u
.p
.current_unit
->s
);
2274 unlock_unit (dtp
->u
.p
.current_unit
);
2279 /* Restore the current unit. */
2281 dtp
->u
.p
.current_unit
= temp_unit
;
2282 dtp
->u
.p
.mode
= READING
;
2286 /* Reads and stores the input for the namelist object nl. For an array,
2287 the function loops over the ranges defined by the loop specification.
2288 This default to all the data or to the specification from a qualifier.
2289 nml_read_obj recursively calls itself to read derived types. It visits
2290 all its own components but only reads data for those that were touched
2291 when the name was parsed. If a read error is encountered, an attempt is
2292 made to return to read a new object name because the standard allows too
2293 little data to be available. On the other hand, too much data is an
2297 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2298 namelist_info
**pprev_nl
, char *nml_err_msg
,
2299 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2301 namelist_info
* cmp
;
2308 size_t obj_name_len
;
2311 /* This object not touched in name parsing. */
2316 dtp
->u
.p
.repeat_count
= 0;
2322 case GFC_DTYPE_INTEGER
:
2323 case GFC_DTYPE_LOGICAL
:
2327 case GFC_DTYPE_REAL
:
2328 dlen
= size_from_real_kind (len
);
2331 case GFC_DTYPE_COMPLEX
:
2332 dlen
= size_from_complex_kind (len
);
2335 case GFC_DTYPE_CHARACTER
:
2336 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2345 /* Update the pointer to the data, using the current index vector */
2347 pdata
= (void*)(nl
->mem_pos
+ offset
);
2348 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2349 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2350 nl
->dim
[dim
].stride
* nl
->size
);
2352 /* Reset the error flag and try to read next value, if
2353 dtp->u.p.repeat_count=0 */
2355 dtp
->u
.p
.nml_read_error
= 0;
2357 if (--dtp
->u
.p
.repeat_count
<= 0)
2359 if (dtp
->u
.p
.input_complete
)
2361 if (dtp
->u
.p
.at_eol
)
2362 finish_separator (dtp
);
2363 if (dtp
->u
.p
.input_complete
)
2366 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2367 after the switch block. */
2369 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2374 case GFC_DTYPE_INTEGER
:
2375 read_integer (dtp
, len
);
2378 case GFC_DTYPE_LOGICAL
:
2379 read_logical (dtp
, len
);
2382 case GFC_DTYPE_CHARACTER
:
2383 read_character (dtp
, len
);
2386 case GFC_DTYPE_REAL
:
2387 read_real (dtp
, len
);
2390 case GFC_DTYPE_COMPLEX
:
2391 read_complex (dtp
, len
, dlen
);
2394 case GFC_DTYPE_DERIVED
:
2395 obj_name_len
= strlen (nl
->var_name
) + 1;
2396 obj_name
= get_mem (obj_name_len
+1);
2397 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2398 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2400 /* If reading a derived type, disable the expanded read warning
2401 since a single object can have multiple reads. */
2402 dtp
->u
.p
.expanded_read
= 0;
2404 /* Now loop over the components. Update the component pointer
2405 with the return value from nml_write_obj. This loop jumps
2406 past nested derived types by testing if the potential
2407 component name contains '%'. */
2409 for (cmp
= nl
->next
;
2411 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2412 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2416 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2417 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2418 clow
, chigh
) == FAILURE
)
2420 free_mem (obj_name
);
2424 if (dtp
->u
.p
.input_complete
)
2426 free_mem (obj_name
);
2431 free_mem (obj_name
);
2435 snprintf (nml_err_msg
, nml_err_msg_size
,
2436 "Bad type for namelist object %s", nl
->var_name
);
2437 internal_error (&dtp
->common
, nml_err_msg
);
2442 /* The standard permits array data to stop short of the number of
2443 elements specified in the loop specification. In this case, we
2444 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2445 nml_get_obj_data and an attempt is made to read object name. */
2448 if (dtp
->u
.p
.nml_read_error
)
2450 dtp
->u
.p
.expanded_read
= 0;
2454 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2456 dtp
->u
.p
.expanded_read
= 0;
2460 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2461 This comes about because the read functions return BT_types. */
2463 switch (dtp
->u
.p
.saved_type
)
2470 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2474 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2475 pdata
= (void*)( pdata
+ clow
- 1 );
2476 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2478 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2485 /* Warn if a non-standard expanded read occurs. A single read of a
2486 single object is acceptable. If a second read occurs, issue a warning
2487 and set the flag to zero to prevent further warnings. */
2488 if (dtp
->u
.p
.expanded_read
== 2)
2490 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2491 dtp
->u
.p
.expanded_read
= 0;
2494 /* If the expanded read warning flag is set, increment it,
2495 indicating that a single read has occurred. */
2496 if (dtp
->u
.p
.expanded_read
>= 1)
2497 dtp
->u
.p
.expanded_read
++;
2499 /* Break out of loop if scalar. */
2503 /* Now increment the index vector. */
2508 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2510 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2512 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2514 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2516 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2520 } while (!nml_carry
);
2522 if (dtp
->u
.p
.repeat_count
> 1)
2524 snprintf (nml_err_msg
, nml_err_msg_size
,
2525 "Repeat count too large for namelist object %s", nl
->var_name
);
2535 /* Parses the object name, including array and substring qualifiers. It
2536 iterates over derived type components, touching those components and
2537 setting their loop specifications, if there is a qualifier. If the
2538 object is itself a derived type, its components and subcomponents are
2539 touched. nml_read_obj is called at the end and this reads the data in
2540 the manner specified by the object name. */
2543 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2544 char *nml_err_msg
, size_t nml_err_msg_size
)
2548 namelist_info
* first_nl
= NULL
;
2549 namelist_info
* root_nl
= NULL
;
2550 int dim
, parsed_rank
;
2552 index_type clow
, chigh
;
2553 int non_zero_rank_count
;
2555 /* Look for end of input or object name. If '?' or '=?' are encountered
2556 in stdin, print the node names or the namelist to stdout. */
2558 eat_separator (dtp
);
2559 if (dtp
->u
.p
.input_complete
)
2562 if (dtp
->u
.p
.at_eol
)
2563 finish_separator (dtp
);
2564 if (dtp
->u
.p
.input_complete
)
2567 c
= next_char (dtp
);
2571 c
= next_char (dtp
);
2574 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2577 nml_query (dtp
, '=');
2581 nml_query (dtp
, '?');
2586 nml_match_name (dtp
, "end", 3);
2587 if (dtp
->u
.p
.nml_read_error
)
2589 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2593 dtp
->u
.p
.input_complete
= 1;
2600 /* Untouch all nodes of the namelist and reset the flag that is set for
2601 derived type components. */
2603 nml_untouch_nodes (dtp
);
2605 non_zero_rank_count
= 0;
2607 /* Get the object name - should '!' and '\n' be permitted separators? */
2615 if (!is_separator (c
))
2616 push_char (dtp
, tolower(c
));
2617 c
= next_char (dtp
);
2618 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2620 unget_char (dtp
, c
);
2622 /* Check that the name is in the namelist and get pointer to object.
2623 Three error conditions exist: (i) An attempt is being made to
2624 identify a non-existent object, following a failed data read or
2625 (ii) The object name does not exist or (iii) Too many data items
2626 are present for an object. (iii) gives the same error message
2629 push_char (dtp
, '\0');
2633 size_t var_len
= strlen (root_nl
->var_name
);
2635 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2636 char ext_name
[var_len
+ saved_len
+ 1];
2638 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2639 if (dtp
->u
.p
.saved_string
)
2640 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2641 ext_name
[var_len
+ saved_len
] = '\0';
2642 nl
= find_nml_node (dtp
, ext_name
);
2645 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2649 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2650 snprintf (nml_err_msg
, nml_err_msg_size
,
2651 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2654 snprintf (nml_err_msg
, nml_err_msg_size
,
2655 "Cannot match namelist object name %s",
2656 dtp
->u
.p
.saved_string
);
2661 /* Get the length, data length, base pointer and rank of the variable.
2662 Set the default loop specification first. */
2664 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2666 nl
->ls
[dim
].step
= 1;
2667 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2668 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2669 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2672 /* Check to see if there is a qualifier: if so, parse it.*/
2674 if (c
== '(' && nl
->var_rank
)
2677 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2678 nml_err_msg
, &parsed_rank
) == FAILURE
)
2680 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2681 snprintf (nml_err_msg_end
,
2682 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2683 " for namelist variable %s", nl
->var_name
);
2687 if (parsed_rank
> 0)
2688 non_zero_rank_count
++;
2690 c
= next_char (dtp
);
2691 unget_char (dtp
, c
);
2693 else if (nl
->var_rank
> 0)
2694 non_zero_rank_count
++;
2696 /* Now parse a derived type component. The root namelist_info address
2697 is backed up, as is the previous component level. The component flag
2698 is set and the iteration is made by jumping back to get_name. */
2702 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2704 snprintf (nml_err_msg
, nml_err_msg_size
,
2705 "Attempt to get derived component for %s", nl
->var_name
);
2709 if (!component_flag
)
2714 c
= next_char (dtp
);
2718 /* Parse a character qualifier, if present. chigh = 0 is a default
2719 that signals that the string length = string_length. */
2724 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2726 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2727 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2729 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2732 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2733 snprintf (nml_err_msg_end
,
2734 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2735 " for namelist variable %s", nl
->var_name
);
2739 clow
= ind
[0].start
;
2742 if (ind
[0].step
!= 1)
2744 snprintf (nml_err_msg
, nml_err_msg_size
,
2745 "Step not allowed in substring qualifier"
2746 " for namelist object %s", nl
->var_name
);
2750 c
= next_char (dtp
);
2751 unget_char (dtp
, c
);
2754 /* If a derived type touch its components and restore the root
2755 namelist_info if we have parsed a qualified derived type
2758 if (nl
->type
== GFC_DTYPE_DERIVED
)
2759 nml_touch_nodes (nl
);
2760 if (component_flag
&& nl
->var_rank
> 0)
2763 /* Make sure no extraneous qualifiers are there. */
2767 snprintf (nml_err_msg
, nml_err_msg_size
,
2768 "Qualifier for a scalar or non-character namelist object %s",
2773 /* Make sure there is no more than one non-zero rank object. */
2774 if (non_zero_rank_count
> 1)
2776 snprintf (nml_err_msg
, nml_err_msg_size
,
2777 "Multiple sub-objects with non-zero rank in namelist object %s",
2779 non_zero_rank_count
= 0;
2783 /* According to the standard, an equal sign MUST follow an object name. The
2784 following is possibly lax - it allows comments, blank lines and so on to
2785 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2789 eat_separator (dtp
);
2790 if (dtp
->u
.p
.input_complete
)
2793 if (dtp
->u
.p
.at_eol
)
2794 finish_separator (dtp
);
2795 if (dtp
->u
.p
.input_complete
)
2798 c
= next_char (dtp
);
2802 snprintf (nml_err_msg
, nml_err_msg_size
,
2803 "Equal sign must follow namelist object name %s",
2808 if (first_nl
!= NULL
&& first_nl
->var_rank
> 0)
2811 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2812 clow
, chigh
) == FAILURE
)
2822 /* Entry point for namelist input. Goes through input until namelist name
2823 is matched. Then cycles through nml_get_obj_data until the input is
2824 completed or there is an error. */
2827 namelist_read (st_parameter_dt
*dtp
)
2831 char nml_err_msg
[200];
2832 /* Pointer to the previously read object, in case attempt is made to read
2833 new object name. Should this fail, error message can give previous
2835 namelist_info
*prev_nl
= NULL
;
2837 dtp
->u
.p
.namelist_mode
= 1;
2838 dtp
->u
.p
.input_complete
= 0;
2839 dtp
->u
.p
.expanded_read
= 0;
2841 dtp
->u
.p
.eof_jump
= &eof_jump
;
2842 if (setjmp (eof_jump
))
2844 dtp
->u
.p
.eof_jump
= NULL
;
2845 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2849 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2850 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2851 node names or namelist on stdout. */
2854 switch (c
= next_char (dtp
))
2865 c
= next_char (dtp
);
2867 nml_query (dtp
, '=');
2869 unget_char (dtp
, c
);
2873 nml_query (dtp
, '?');
2879 /* Match the name of the namelist. */
2881 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2883 if (dtp
->u
.p
.nml_read_error
)
2886 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2887 c
= next_char (dtp
);
2888 if (!is_separator(c
) && c
!= '!')
2890 unget_char (dtp
, c
);
2894 unget_char (dtp
, c
);
2895 eat_separator (dtp
);
2897 /* Ready to read namelist objects. If there is an error in input
2898 from stdin, output the error message and continue. */
2900 while (!dtp
->u
.p
.input_complete
)
2902 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2907 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2910 u
= find_unit (options
.stderr_unit
);
2911 st_printf ("%s\n", nml_err_msg
);
2921 dtp
->u
.p
.eof_jump
= NULL
;
2926 /* All namelist error calls return from here */
2930 dtp
->u
.p
.eof_jump
= NULL
;
2933 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);