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. */
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
.input_complete
)
1729 if (dtp
->u
.p
.repeat_count
> 0)
1731 if (check_type (dtp
, type
, kind
))
1736 if (dtp
->u
.p
.at_eol
)
1737 finish_separator (dtp
);
1741 /* Trailing spaces prior to end of line. */
1742 if (dtp
->u
.p
.at_eol
)
1743 finish_separator (dtp
);
1746 dtp
->u
.p
.saved_type
= BT_NULL
;
1747 dtp
->u
.p
.repeat_count
= 1;
1753 read_integer (dtp
, kind
);
1756 read_logical (dtp
, kind
);
1759 read_character (dtp
, kind
);
1762 read_real (dtp
, kind
);
1765 read_complex (dtp
, kind
, size
);
1768 internal_error (&dtp
->common
, "Bad type for list read");
1771 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1772 dtp
->u
.p
.saved_length
= size
;
1774 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1778 switch (dtp
->u
.p
.saved_type
)
1784 memcpy (p
, dtp
->u
.p
.value
, size
);
1788 if (dtp
->u
.p
.saved_string
)
1790 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1791 ? (int) size
: dtp
->u
.p
.saved_used
;
1793 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1796 q
= (gfc_char4_t
*) p
;
1797 for (i
= 0; i
< m
; i
++)
1798 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1802 /* Just delimiters encountered, nothing to copy but SPACE. */
1808 memset (((char *) p
) + m
, ' ', size
- m
);
1811 q
= (gfc_char4_t
*) p
;
1812 for (i
= m
; i
< (int) size
; i
++)
1813 q
[i
] = (unsigned char) ' ';
1822 if (--dtp
->u
.p
.repeat_count
<= 0)
1826 dtp
->u
.p
.eof_jump
= NULL
;
1831 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1832 size_t size
, size_t nelems
)
1836 size_t stride
= type
== BT_CHARACTER
?
1837 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1841 /* Big loop over all the elements. */
1842 for (elem
= 0; elem
< nelems
; elem
++)
1844 dtp
->u
.p
.item_count
++;
1845 list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1850 /* Finish a list read. */
1853 finish_list_read (st_parameter_dt
*dtp
)
1859 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1861 if (dtp
->u
.p
.at_eol
)
1863 dtp
->u
.p
.at_eol
= 0;
1869 c
= next_char (dtp
);
1873 if (dtp
->u
.p
.current_unit
->endfile
!= NO_ENDFILE
)
1875 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1876 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1877 dtp
->u
.p
.current_unit
->current_record
= 0;
1883 void namelist_read (st_parameter_dt *dtp)
1885 static void nml_match_name (char *name, int len)
1886 static int nml_query (st_parameter_dt *dtp)
1887 static int nml_get_obj_data (st_parameter_dt *dtp,
1888 namelist_info **prev_nl, char *, size_t)
1890 static void nml_untouch_nodes (st_parameter_dt *dtp)
1891 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1893 static int nml_parse_qualifier(descriptor_dimension * ad,
1894 array_loop_spec * ls, int rank, char *)
1895 static void nml_touch_nodes (namelist_info * nl)
1896 static int nml_read_obj (namelist_info *nl, index_type offset,
1897 namelist_info **prev_nl, char *, size_t,
1898 index_type clow, index_type chigh)
1902 /* Inputs a rank-dimensional qualifier, which can contain
1903 singlets, doublets, triplets or ':' with the standard meanings. */
1906 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1907 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1914 int is_array_section
, is_char
;
1918 is_array_section
= 0;
1919 dtp
->u
.p
.expanded_read
= 0;
1921 /* See if this is a character substring qualifier we are looking for. */
1928 /* The next character in the stream should be the '('. */
1930 c
= next_char (dtp
);
1932 /* Process the qualifier, by dimension and triplet. */
1934 for (dim
=0; dim
< rank
; dim
++ )
1936 for (indx
=0; indx
<3; indx
++)
1942 /* Process a potential sign. */
1943 c
= next_char (dtp
);
1954 unget_char (dtp
, c
);
1958 /* Process characters up to the next ':' , ',' or ')'. */
1961 c
= next_char (dtp
);
1966 is_array_section
= 1;
1970 if ((c
==',' && dim
== rank
-1)
1971 || (c
==')' && dim
< rank
-1))
1974 sprintf (parse_err_msg
, "Bad substring qualifier");
1976 sprintf (parse_err_msg
, "Bad number of index fields");
1985 case ' ': case '\t':
1987 c
= next_char (dtp
);
1992 sprintf (parse_err_msg
,
1993 "Bad character in substring qualifier");
1995 sprintf (parse_err_msg
, "Bad character in index");
1999 if ((c
== ',' || c
== ')') && indx
== 0
2000 && dtp
->u
.p
.saved_string
== 0)
2003 sprintf (parse_err_msg
, "Null substring qualifier");
2005 sprintf (parse_err_msg
, "Null index field");
2009 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2010 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2013 sprintf (parse_err_msg
, "Bad substring qualifier");
2015 sprintf (parse_err_msg
, "Bad index triplet");
2019 if (is_char
&& !is_array_section
)
2021 sprintf (parse_err_msg
,
2022 "Missing colon in substring qualifier");
2026 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2028 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2029 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2035 /* Now read the index. */
2036 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2039 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2041 sprintf (parse_err_msg
, "Bad integer in index");
2047 /* Feed the index values to the triplet arrays. */
2051 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2053 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2055 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2058 /* Singlet or doublet indices. */
2059 if (c
==',' || c
==')')
2063 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2065 /* If -std=f95/2003 or an array section is specified,
2066 do not allow excess data to be processed. */
2067 if (is_array_section
== 1
2068 || compile_options
.allow_std
< GFC_STD_GNU
)
2069 ls
[dim
].end
= ls
[dim
].start
;
2071 dtp
->u
.p
.expanded_read
= 1;
2074 /* Check for non-zero rank. */
2075 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2082 /* Check the values of the triplet indices. */
2083 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2084 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2085 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2086 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2089 sprintf (parse_err_msg
, "Substring out of range");
2091 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2095 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2096 || (ls
[dim
].step
== 0))
2098 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2102 /* Initialise the loop index counter. */
2103 ls
[dim
].idx
= ls
[dim
].start
;
2113 static namelist_info
*
2114 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2116 namelist_info
* t
= dtp
->u
.p
.ionml
;
2119 if (strcmp (var_name
, t
->var_name
) == 0)
2129 /* Visits all the components of a derived type that have
2130 not explicitly been identified in the namelist input.
2131 touched is set and the loop specification initialised
2132 to default values */
2135 nml_touch_nodes (namelist_info
* nl
)
2137 index_type len
= strlen (nl
->var_name
) + 1;
2139 char * ext_name
= (char*)get_mem (len
+ 1);
2140 memcpy (ext_name
, nl
->var_name
, len
-1);
2141 memcpy (ext_name
+ len
- 1, "%", 2);
2142 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2144 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2147 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2149 nl
->ls
[dim
].step
= 1;
2150 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2151 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2152 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2158 free_mem (ext_name
);
2162 /* Resets touched for the entire list of nml_nodes, ready for a
2166 nml_untouch_nodes (st_parameter_dt
*dtp
)
2169 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2174 /* Attempts to input name to namelist name. Returns
2175 dtp->u.p.nml_read_error = 1 on no match. */
2178 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2182 dtp
->u
.p
.nml_read_error
= 0;
2183 for (i
= 0; i
< len
; i
++)
2185 c
= next_char (dtp
);
2186 if (tolower (c
) != tolower (name
[i
]))
2188 dtp
->u
.p
.nml_read_error
= 1;
2194 /* If the namelist read is from stdin, output the current state of the
2195 namelist to stdout. This is used to implement the non-standard query
2196 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2197 the names alone are printed. */
2200 nml_query (st_parameter_dt
*dtp
, char c
)
2202 gfc_unit
* temp_unit
;
2207 static const index_type endlen
= 3;
2208 static const char endl
[] = "\r\n";
2209 static const char nmlend
[] = "&end\r\n";
2211 static const index_type endlen
= 2;
2212 static const char endl
[] = "\n";
2213 static const char nmlend
[] = "&end\n";
2216 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2219 /* Store the current unit and transfer to stdout. */
2221 temp_unit
= dtp
->u
.p
.current_unit
;
2222 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2224 if (dtp
->u
.p
.current_unit
)
2226 dtp
->u
.p
.mode
= WRITING
;
2227 next_record (dtp
, 0);
2229 /* Write the namelist in its entirety. */
2232 namelist_write (dtp
);
2234 /* Or write the list of names. */
2238 /* "&namelist_name\n" */
2240 len
= dtp
->namelist_name_len
;
2241 p
= write_block (dtp
, len
+ endlen
);
2245 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2246 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2247 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2251 len
= strlen (nl
->var_name
);
2252 p
= write_block (dtp
, len
+ endlen
);
2256 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2257 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2262 p
= write_block (dtp
, endlen
+ 3);
2264 memcpy (p
, &nmlend
, endlen
+ 3);
2267 /* Flush the stream to force immediate output. */
2269 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2270 sflush (dtp
->u
.p
.current_unit
->s
);
2271 unlock_unit (dtp
->u
.p
.current_unit
);
2276 /* Restore the current unit. */
2278 dtp
->u
.p
.current_unit
= temp_unit
;
2279 dtp
->u
.p
.mode
= READING
;
2283 /* Reads and stores the input for the namelist object nl. For an array,
2284 the function loops over the ranges defined by the loop specification.
2285 This default to all the data or to the specification from a qualifier.
2286 nml_read_obj recursively calls itself to read derived types. It visits
2287 all its own components but only reads data for those that were touched
2288 when the name was parsed. If a read error is encountered, an attempt is
2289 made to return to read a new object name because the standard allows too
2290 little data to be available. On the other hand, too much data is an
2294 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2295 namelist_info
**pprev_nl
, char *nml_err_msg
,
2296 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2298 namelist_info
* cmp
;
2305 index_type obj_name_len
;
2308 /* This object not touched in name parsing. */
2313 dtp
->u
.p
.repeat_count
= 0;
2319 case GFC_DTYPE_INTEGER
:
2320 case GFC_DTYPE_LOGICAL
:
2324 case GFC_DTYPE_REAL
:
2325 dlen
= size_from_real_kind (len
);
2328 case GFC_DTYPE_COMPLEX
:
2329 dlen
= size_from_complex_kind (len
);
2332 case GFC_DTYPE_CHARACTER
:
2333 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2342 /* Update the pointer to the data, using the current index vector */
2344 pdata
= (void*)(nl
->mem_pos
+ offset
);
2345 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2346 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2347 nl
->dim
[dim
].stride
* nl
->size
);
2349 /* Reset the error flag and try to read next value, if
2350 dtp->u.p.repeat_count=0 */
2352 dtp
->u
.p
.nml_read_error
= 0;
2354 if (--dtp
->u
.p
.repeat_count
<= 0)
2356 if (dtp
->u
.p
.input_complete
)
2358 if (dtp
->u
.p
.at_eol
)
2359 finish_separator (dtp
);
2360 if (dtp
->u
.p
.input_complete
)
2363 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2364 after the switch block. */
2366 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2371 case GFC_DTYPE_INTEGER
:
2372 read_integer (dtp
, len
);
2375 case GFC_DTYPE_LOGICAL
:
2376 read_logical (dtp
, len
);
2379 case GFC_DTYPE_CHARACTER
:
2380 read_character (dtp
, len
);
2383 case GFC_DTYPE_REAL
:
2384 read_real (dtp
, len
);
2387 case GFC_DTYPE_COMPLEX
:
2388 read_complex (dtp
, len
, dlen
);
2391 case GFC_DTYPE_DERIVED
:
2392 obj_name_len
= strlen (nl
->var_name
) + 1;
2393 obj_name
= get_mem (obj_name_len
+1);
2394 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2395 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2397 /* If reading a derived type, disable the expanded read warning
2398 since a single object can have multiple reads. */
2399 dtp
->u
.p
.expanded_read
= 0;
2401 /* Now loop over the components. Update the component pointer
2402 with the return value from nml_write_obj. This loop jumps
2403 past nested derived types by testing if the potential
2404 component name contains '%'. */
2406 for (cmp
= nl
->next
;
2408 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2409 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2413 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2414 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2415 clow
, chigh
) == FAILURE
)
2417 free_mem (obj_name
);
2421 if (dtp
->u
.p
.input_complete
)
2423 free_mem (obj_name
);
2428 free_mem (obj_name
);
2432 snprintf (nml_err_msg
, nml_err_msg_size
,
2433 "Bad type for namelist object %s", nl
->var_name
);
2434 internal_error (&dtp
->common
, nml_err_msg
);
2439 /* The standard permits array data to stop short of the number of
2440 elements specified in the loop specification. In this case, we
2441 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2442 nml_get_obj_data and an attempt is made to read object name. */
2445 if (dtp
->u
.p
.nml_read_error
)
2447 dtp
->u
.p
.expanded_read
= 0;
2451 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2453 dtp
->u
.p
.expanded_read
= 0;
2457 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2458 This comes about because the read functions return BT_types. */
2460 switch (dtp
->u
.p
.saved_type
)
2467 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2471 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2472 pdata
= (void*)( pdata
+ clow
- 1 );
2473 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2475 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2482 /* Warn if a non-standard expanded read occurs. A single read of a
2483 single object is acceptable. If a second read occurs, issue a warning
2484 and set the flag to zero to prevent further warnings. */
2485 if (dtp
->u
.p
.expanded_read
== 2)
2487 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2488 dtp
->u
.p
.expanded_read
= 0;
2491 /* If the expanded read warning flag is set, increment it,
2492 indicating that a single read has occurred. */
2493 if (dtp
->u
.p
.expanded_read
>= 1)
2494 dtp
->u
.p
.expanded_read
++;
2496 /* Break out of loop if scalar. */
2500 /* Now increment the index vector. */
2505 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2507 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2509 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2511 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2513 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2517 } while (!nml_carry
);
2519 if (dtp
->u
.p
.repeat_count
> 1)
2521 snprintf (nml_err_msg
, nml_err_msg_size
,
2522 "Repeat count too large for namelist object %s", nl
->var_name
);
2532 /* Parses the object name, including array and substring qualifiers. It
2533 iterates over derived type components, touching those components and
2534 setting their loop specifications, if there is a qualifier. If the
2535 object is itself a derived type, its components and subcomponents are
2536 touched. nml_read_obj is called at the end and this reads the data in
2537 the manner specified by the object name. */
2540 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2541 char *nml_err_msg
, size_t nml_err_msg_size
)
2545 namelist_info
* first_nl
= NULL
;
2546 namelist_info
* root_nl
= NULL
;
2547 int dim
, parsed_rank
;
2549 index_type clow
, chigh
;
2550 int non_zero_rank_count
;
2552 /* Look for end of input or object name. If '?' or '=?' are encountered
2553 in stdin, print the node names or the namelist to stdout. */
2555 eat_separator (dtp
);
2556 if (dtp
->u
.p
.input_complete
)
2559 if (dtp
->u
.p
.at_eol
)
2560 finish_separator (dtp
);
2561 if (dtp
->u
.p
.input_complete
)
2564 c
= next_char (dtp
);
2568 c
= next_char (dtp
);
2571 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2574 nml_query (dtp
, '=');
2578 nml_query (dtp
, '?');
2583 nml_match_name (dtp
, "end", 3);
2584 if (dtp
->u
.p
.nml_read_error
)
2586 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2590 dtp
->u
.p
.input_complete
= 1;
2597 /* Untouch all nodes of the namelist and reset the flag that is set for
2598 derived type components. */
2600 nml_untouch_nodes (dtp
);
2602 non_zero_rank_count
= 0;
2604 /* Get the object name - should '!' and '\n' be permitted separators? */
2612 if (!is_separator (c
))
2613 push_char (dtp
, tolower(c
));
2614 c
= next_char (dtp
);
2615 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2617 unget_char (dtp
, c
);
2619 /* Check that the name is in the namelist and get pointer to object.
2620 Three error conditions exist: (i) An attempt is being made to
2621 identify a non-existent object, following a failed data read or
2622 (ii) The object name does not exist or (iii) Too many data items
2623 are present for an object. (iii) gives the same error message
2626 push_char (dtp
, '\0');
2630 size_t var_len
= strlen (root_nl
->var_name
);
2632 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2633 char ext_name
[var_len
+ saved_len
+ 1];
2635 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2636 if (dtp
->u
.p
.saved_string
)
2637 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2638 ext_name
[var_len
+ saved_len
] = '\0';
2639 nl
= find_nml_node (dtp
, ext_name
);
2642 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2646 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2647 snprintf (nml_err_msg
, nml_err_msg_size
,
2648 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2651 snprintf (nml_err_msg
, nml_err_msg_size
,
2652 "Cannot match namelist object name %s",
2653 dtp
->u
.p
.saved_string
);
2658 /* Get the length, data length, base pointer and rank of the variable.
2659 Set the default loop specification first. */
2661 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2663 nl
->ls
[dim
].step
= 1;
2664 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2665 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2666 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2669 /* Check to see if there is a qualifier: if so, parse it.*/
2671 if (c
== '(' && nl
->var_rank
)
2674 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2675 nml_err_msg
, &parsed_rank
) == FAILURE
)
2677 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2678 snprintf (nml_err_msg_end
,
2679 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2680 " for namelist variable %s", nl
->var_name
);
2684 if (parsed_rank
> 0)
2685 non_zero_rank_count
++;
2687 c
= next_char (dtp
);
2688 unget_char (dtp
, c
);
2690 else if (nl
->var_rank
> 0)
2691 non_zero_rank_count
++;
2693 /* Now parse a derived type component. The root namelist_info address
2694 is backed up, as is the previous component level. The component flag
2695 is set and the iteration is made by jumping back to get_name. */
2699 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2701 snprintf (nml_err_msg
, nml_err_msg_size
,
2702 "Attempt to get derived component for %s", nl
->var_name
);
2706 if (!component_flag
)
2711 c
= next_char (dtp
);
2715 /* Parse a character qualifier, if present. chigh = 0 is a default
2716 that signals that the string length = string_length. */
2721 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2723 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2724 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2726 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2729 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2730 snprintf (nml_err_msg_end
,
2731 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2732 " for namelist variable %s", nl
->var_name
);
2736 clow
= ind
[0].start
;
2739 if (ind
[0].step
!= 1)
2741 snprintf (nml_err_msg
, nml_err_msg_size
,
2742 "Step not allowed in substring qualifier"
2743 " for namelist object %s", nl
->var_name
);
2747 c
= next_char (dtp
);
2748 unget_char (dtp
, c
);
2751 /* If a derived type touch its components and restore the root
2752 namelist_info if we have parsed a qualified derived type
2755 if (nl
->type
== GFC_DTYPE_DERIVED
)
2756 nml_touch_nodes (nl
);
2757 if (component_flag
&& nl
->var_rank
> 0)
2760 /* Make sure no extraneous qualifiers are there. */
2764 snprintf (nml_err_msg
, nml_err_msg_size
,
2765 "Qualifier for a scalar or non-character namelist object %s",
2770 /* Make sure there is no more than one non-zero rank object. */
2771 if (non_zero_rank_count
> 1)
2773 snprintf (nml_err_msg
, nml_err_msg_size
,
2774 "Multiple sub-objects with non-zero rank in namelist object %s",
2776 non_zero_rank_count
= 0;
2780 /* According to the standard, an equal sign MUST follow an object name. The
2781 following is possibly lax - it allows comments, blank lines and so on to
2782 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2786 eat_separator (dtp
);
2787 if (dtp
->u
.p
.input_complete
)
2790 if (dtp
->u
.p
.at_eol
)
2791 finish_separator (dtp
);
2792 if (dtp
->u
.p
.input_complete
)
2795 c
= next_char (dtp
);
2799 snprintf (nml_err_msg
, nml_err_msg_size
,
2800 "Equal sign must follow namelist object name %s",
2805 if (first_nl
!= NULL
&& first_nl
->var_rank
> 0)
2808 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2809 clow
, chigh
) == FAILURE
)
2819 /* Entry point for namelist input. Goes through input until namelist name
2820 is matched. Then cycles through nml_get_obj_data until the input is
2821 completed or there is an error. */
2824 namelist_read (st_parameter_dt
*dtp
)
2828 char nml_err_msg
[200];
2829 /* Pointer to the previously read object, in case attempt is made to read
2830 new object name. Should this fail, error message can give previous
2832 namelist_info
*prev_nl
= NULL
;
2834 dtp
->u
.p
.namelist_mode
= 1;
2835 dtp
->u
.p
.input_complete
= 0;
2836 dtp
->u
.p
.expanded_read
= 0;
2838 dtp
->u
.p
.eof_jump
= &eof_jump
;
2839 if (setjmp (eof_jump
))
2841 dtp
->u
.p
.eof_jump
= NULL
;
2842 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2846 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2847 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2848 node names or namelist on stdout. */
2851 switch (c
= next_char (dtp
))
2862 c
= next_char (dtp
);
2864 nml_query (dtp
, '=');
2866 unget_char (dtp
, c
);
2870 nml_query (dtp
, '?');
2876 /* Match the name of the namelist. */
2878 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2880 if (dtp
->u
.p
.nml_read_error
)
2883 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2884 c
= next_char (dtp
);
2885 if (!is_separator(c
) && c
!= '!')
2887 unget_char (dtp
, c
);
2891 unget_char (dtp
, c
);
2892 eat_separator (dtp
);
2894 /* Ready to read namelist objects. If there is an error in input
2895 from stdin, output the error message and continue. */
2897 while (!dtp
->u
.p
.input_complete
)
2899 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2904 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2907 u
= find_unit (options
.stderr_unit
);
2908 st_printf ("%s\n", nml_err_msg
);
2918 dtp
->u
.p
.eof_jump
= NULL
;
2923 /* All namelist error calls return from here */
2927 dtp
->u
.p
.eof_jump
= NULL
;
2930 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);