1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
67 /* Save a character to a string buffer, enlarging it as necessary. */
70 push_char (st_parameter_dt
*dtp
, char c
)
74 if (dtp
->u
.p
.saved_string
== NULL
)
76 if (dtp
->u
.p
.scratch
== NULL
)
77 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
78 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
79 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
80 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
81 dtp
->u
.p
.saved_used
= 0;
84 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
86 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
87 new = get_mem (2 * dtp
->u
.p
.saved_length
);
89 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
91 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
92 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
93 free_mem (dtp
->u
.p
.saved_string
);
95 dtp
->u
.p
.saved_string
= new;
98 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
102 /* Free the input buffer if necessary. */
105 free_saved (st_parameter_dt
*dtp
)
107 if (dtp
->u
.p
.saved_string
== NULL
)
110 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
111 free_mem (dtp
->u
.p
.saved_string
);
113 dtp
->u
.p
.saved_string
= NULL
;
114 dtp
->u
.p
.saved_used
= 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt
*dtp
)
123 if (dtp
->u
.p
.line_buffer
== NULL
)
126 free_mem (dtp
->u
.p
.line_buffer
);
127 dtp
->u
.p
.line_buffer
= NULL
;
132 next_char (st_parameter_dt
*dtp
)
138 if (dtp
->u
.p
.last_char
!= '\0')
141 c
= dtp
->u
.p
.last_char
;
142 dtp
->u
.p
.last_char
= '\0';
146 /* Read from line_buffer if enabled. */
148 if (dtp
->u
.p
.line_buffer_enabled
)
152 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
153 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
155 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
156 dtp
->u
.p
.item_count
++;
160 dtp
->u
.p
.item_count
= 0;
161 dtp
->u
.p
.line_buffer_enabled
= 0;
164 /* Handle the end-of-record and end-of-file conditions for
165 internal array unit. */
166 if (is_array_io (dtp
))
169 longjmp (*dtp
->u
.p
.eof_jump
, 1);
171 /* Check for "end-of-record" condition. */
172 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
177 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
180 /* Check for "end-of-file" condition. */
187 record
*= dtp
->u
.p
.current_unit
->recl
;
188 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
189 longjmp (*dtp
->u
.p
.eof_jump
, 1);
191 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
196 /* Get the next character and handle end-of-record conditions. */
200 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
202 if (is_stream_io (dtp
))
203 dtp
->u
.p
.current_unit
->strm_pos
++;
205 if (is_internal_unit (dtp
))
207 if (is_array_io (dtp
))
209 /* End of record is handled in the next pass through, above. The
210 check for NULL here is cautionary. */
213 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
217 dtp
->u
.p
.current_unit
->bytes_left
--;
223 longjmp (*dtp
->u
.p
.eof_jump
, 1);
234 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
239 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
241 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
242 longjmp (*dtp
->u
.p
.eof_jump
, 1);
243 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
247 longjmp (*dtp
->u
.p
.eof_jump
, 1);
253 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
258 /* Push a character back onto the input. */
261 unget_char (st_parameter_dt
*dtp
, char c
)
263 dtp
->u
.p
.last_char
= c
;
267 /* Skip over spaces in the input. Returns the nonspace character that
268 terminated the eating and also places it back on the input. */
271 eat_spaces (st_parameter_dt
*dtp
)
279 while (c
== ' ' || c
== '\t');
286 /* This function reads characters through to the end of the current line and
287 just ignores them. */
290 eat_line (st_parameter_dt
*dtp
)
293 if (!is_internal_unit (dtp
))
300 /* Skip over a separator. Technically, we don't always eat the whole
301 separator. This is because if we've processed the last input item,
302 then a separator is unnecessary. Plus the fact that operating
303 systems usually deliver console input on a line basis.
305 The upshot is that if we see a newline as part of reading a
306 separator, we stop reading. If there are more input items, we
307 continue reading the separator with finish_separator() which takes
308 care of the fact that we may or may not have seen a comma as part
312 eat_separator (st_parameter_dt
*dtp
)
317 dtp
->u
.p
.comma_flag
= 0;
323 dtp
->u
.p
.comma_flag
= 1;
328 dtp
->u
.p
.input_complete
= 1;
336 if (dtp
->u
.p
.namelist_mode
)
340 while (c
== '\n' || c
== '\r' || c
== ' ');
350 if (dtp
->u
.p
.namelist_mode
)
361 while (c
== '\n' || c
== '\r' || c
== ' ');
367 if (dtp
->u
.p
.namelist_mode
)
368 { /* Eat a namelist comment. */
376 /* Fall Through... */
385 /* Finish processing a separator that was interrupted by a newline.
386 If we're here, then another data item is present, so we finish what
387 we started on the previous line. */
390 finish_separator (st_parameter_dt
*dtp
)
401 if (dtp
->u
.p
.comma_flag
)
405 c
= eat_spaces (dtp
);
406 if (c
== '\n' || c
== '\r')
413 dtp
->u
.p
.input_complete
= 1;
414 if (!dtp
->u
.p
.namelist_mode
)
423 if (dtp
->u
.p
.namelist_mode
)
439 /* This function is needed to catch bad conversions so that namelist can
440 attempt to see if dtp->u.p.saved_string contains a new object name rather
444 nml_bad_return (st_parameter_dt
*dtp
, char c
)
446 if (dtp
->u
.p
.namelist_mode
)
448 dtp
->u
.p
.nml_read_error
= 1;
455 /* Convert an unsigned string to an integer. The length value is -1
456 if we are working on a repeat count. Returns nonzero if we have a
457 range problem. As a side effect, frees the dtp->u.p.saved_string. */
460 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
462 char c
, *buffer
, message
[100];
464 GFC_INTEGER_LARGEST v
, max
, max10
;
466 buffer
= dtp
->u
.p
.saved_string
;
469 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
494 set_integer (dtp
->u
.p
.value
, v
, length
);
498 dtp
->u
.p
.repeat_count
= v
;
500 if (dtp
->u
.p
.repeat_count
== 0)
502 sprintf (message
, "Zero repeat count in item %d of list input",
503 dtp
->u
.p
.item_count
);
505 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
515 sprintf (message
, "Repeat count overflow in item %d of list input",
516 dtp
->u
.p
.item_count
);
518 sprintf (message
, "Integer overflow while reading item %d",
519 dtp
->u
.p
.item_count
);
522 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
528 /* Parse a repeat count for logical and complex values which cannot
529 begin with a digit. Returns nonzero if we are done, zero if we
530 should continue on. */
533 parse_repeat (st_parameter_dt
*dtp
)
535 char c
, message
[100];
561 repeat
= 10 * repeat
+ c
- '0';
563 if (repeat
> MAX_REPEAT
)
566 "Repeat count overflow in item %d of list input",
567 dtp
->u
.p
.item_count
);
569 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
579 "Zero repeat count in item %d of list input",
580 dtp
->u
.p
.item_count
);
582 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
594 dtp
->u
.p
.repeat_count
= repeat
;
601 sprintf (message
, "Bad repeat count in item %d of list input",
602 dtp
->u
.p
.item_count
);
603 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
608 /* To read a logical we have to look ahead in the input stream to make sure
609 there is not an equal sign indicating a variable name. To do this we use
610 line_buffer to point to a temporary buffer, pushing characters there for
611 possible later reading. */
614 l_push_char (st_parameter_dt
*dtp
, char c
)
616 if (dtp
->u
.p
.line_buffer
== NULL
)
618 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
619 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
622 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
626 /* Read a logical character on the input. */
629 read_logical (st_parameter_dt
*dtp
, int length
)
631 char c
, message
[100];
634 if (parse_repeat (dtp
))
637 c
= tolower (next_char (dtp
));
638 l_push_char (dtp
, c
);
644 l_push_char (dtp
, c
);
646 if (!is_separator(c
))
654 l_push_char (dtp
, c
);
656 if (!is_separator(c
))
662 c
= tolower (next_char (dtp
));
680 return; /* Null value. */
686 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
687 dtp
->u
.p
.saved_length
= length
;
689 /* Eat trailing garbage. */
694 while (!is_separator (c
));
698 dtp
->u
.p
.item_count
= 0;
699 dtp
->u
.p
.line_buffer_enabled
= 0;
700 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
707 for(i
= 0; i
< 63; i
++)
712 /* All done if this is not a namelist read. */
713 if (!dtp
->u
.p
.namelist_mode
)
726 l_push_char (dtp
, c
);
729 dtp
->u
.p
.nml_read_error
= 1;
730 dtp
->u
.p
.line_buffer_enabled
= 1;
731 dtp
->u
.p
.item_count
= 0;
741 if (nml_bad_return (dtp
, c
))
746 sprintf (message
, "Bad logical value while reading item %d",
747 dtp
->u
.p
.item_count
);
748 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
753 dtp
->u
.p
.item_count
= 0;
754 dtp
->u
.p
.line_buffer_enabled
= 0;
755 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
756 dtp
->u
.p
.saved_length
= length
;
757 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
763 /* Reading integers is tricky because we can actually be reading a
764 repeat count. We have to store the characters in a buffer because
765 we could be reading an integer that is larger than the default int
766 used for repeat counts. */
769 read_integer (st_parameter_dt
*dtp
, int length
)
771 char c
, message
[100];
781 /* Fall through... */
787 CASE_SEPARATORS
: /* Single null. */
800 /* Take care of what may be a repeat count. */
812 push_char (dtp
, '\0');
815 CASE_SEPARATORS
: /* Not a repeat count. */
824 if (convert_integer (dtp
, -1, 0))
827 /* Get the real integer. */
842 /* Fall through... */
873 if (nml_bad_return (dtp
, c
))
878 sprintf (message
, "Bad integer for item %d in list input",
879 dtp
->u
.p
.item_count
);
880 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
888 push_char (dtp
, '\0');
889 if (convert_integer (dtp
, length
, negative
))
896 dtp
->u
.p
.saved_type
= BT_INTEGER
;
900 /* Read a character variable. */
903 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
905 char c
, quote
, message
[100];
907 quote
= ' '; /* Space means no quote character. */
917 unget_char (dtp
, c
); /* NULL value. */
927 if (dtp
->u
.p
.namelist_mode
)
929 if (dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_APOSTROPHE
930 || dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_QUOTE
931 || c
== '&' || c
== '$' || c
== '/')
937 /* Check to see if we are seeing a namelist object name by using the
938 line buffer and looking ahead for an '=' or '('. */
939 l_push_char (dtp
, c
);
942 for(i
= 0; i
< 63; i
++)
952 l_push_char (dtp
, c
);
953 dtp
->u
.p
.item_count
= 0;
954 dtp
->u
.p
.line_buffer_enabled
= 1;
959 l_push_char (dtp
, c
);
961 if (c
== '=' || c
== '(')
963 dtp
->u
.p
.item_count
= 0;
964 dtp
->u
.p
.nml_read_error
= 1;
965 dtp
->u
.p
.line_buffer_enabled
= 1;
970 /* The string is too long to be a valid object name so assume that it
971 is a string to be read in as a value. */
972 dtp
->u
.p
.item_count
= 0;
973 dtp
->u
.p
.line_buffer_enabled
= 1;
981 /* Deal with a possible repeat count. */
994 goto done
; /* String was only digits! */
997 push_char (dtp
, '\0');
1002 goto get_string
; /* Not a repeat count after all. */
1007 if (convert_integer (dtp
, -1, 0))
1010 /* Now get the real string. */
1012 c
= next_char (dtp
);
1016 unget_char (dtp
, c
); /* Repeated NULL values. */
1017 eat_separator (dtp
);
1033 c
= next_char (dtp
);
1044 /* See if we have a doubled quote character or the end of
1047 c
= next_char (dtp
);
1050 push_char (dtp
, quote
);
1054 unget_char (dtp
, c
);
1060 unget_char (dtp
, c
);
1064 if (c
!= '\n' && c
!= '\r')
1074 /* At this point, we have to have a separator, or else the string is
1077 c
= next_char (dtp
);
1078 if (is_separator (c
))
1080 unget_char (dtp
, c
);
1081 eat_separator (dtp
);
1082 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1088 sprintf (message
, "Invalid string input in item %d",
1089 dtp
->u
.p
.item_count
);
1090 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1095 /* Parse a component of a complex constant or a real number that we
1096 are sure is already there. This is a straight real number parser. */
1099 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1101 char c
, message
[100];
1104 c
= next_char (dtp
);
1105 if (c
== '-' || c
== '+')
1108 c
= next_char (dtp
);
1111 if (!isdigit (c
) && c
!= '.')
1113 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1121 seen_dp
= (c
== '.') ? 1 : 0;
1125 c
= next_char (dtp
);
1144 push_char (dtp
, 'e');
1149 push_char (dtp
, 'e');
1151 c
= next_char (dtp
);
1155 unget_char (dtp
, c
);
1164 c
= next_char (dtp
);
1165 if (c
!= '-' && c
!= '+')
1166 push_char (dtp
, '+');
1170 c
= next_char (dtp
);
1181 c
= next_char (dtp
);
1189 unget_char (dtp
, c
);
1198 unget_char (dtp
, c
);
1199 push_char (dtp
, '\0');
1201 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1207 /* Match INF and Infinity. */
1208 if ((c
== 'i' || c
== 'I')
1209 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1210 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1212 c
= next_char (dtp
);
1213 if ((c
!= 'i' && c
!= 'I')
1214 || ((c
== 'i' || c
== 'I')
1215 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1216 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1217 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1218 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1219 && (c
= next_char (dtp
))))
1221 if (is_separator (c
))
1222 unget_char (dtp
, c
);
1223 push_char (dtp
, 'i');
1224 push_char (dtp
, 'n');
1225 push_char (dtp
, 'f');
1229 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1230 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1231 && (c
= next_char (dtp
)))
1233 if (is_separator (c
))
1234 unget_char (dtp
, c
);
1235 push_char (dtp
, 'n');
1236 push_char (dtp
, 'a');
1237 push_char (dtp
, 'n');
1243 if (nml_bad_return (dtp
, c
))
1248 sprintf (message
, "Bad floating point number for item %d",
1249 dtp
->u
.p
.item_count
);
1250 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1256 /* Reading a complex number is straightforward because we can tell
1257 what it is right away. */
1260 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1265 if (parse_repeat (dtp
))
1268 c
= next_char (dtp
);
1275 unget_char (dtp
, c
);
1276 eat_separator (dtp
);
1284 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1289 c
= next_char (dtp
);
1290 if (c
== '\n' || c
== '\r')
1293 unget_char (dtp
, c
);
1295 if (next_char (dtp
) != ',')
1300 c
= next_char (dtp
);
1301 if (c
== '\n' || c
== '\r')
1304 unget_char (dtp
, c
);
1306 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1310 if (next_char (dtp
) != ')')
1313 c
= next_char (dtp
);
1314 if (!is_separator (c
))
1317 unget_char (dtp
, c
);
1318 eat_separator (dtp
);
1321 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1326 if (nml_bad_return (dtp
, c
))
1331 sprintf (message
, "Bad complex value in item %d of list input",
1332 dtp
->u
.p
.item_count
);
1333 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1337 /* Parse a real number with a possible repeat count. */
1340 read_real (st_parameter_dt
*dtp
, int length
)
1342 char c
, message
[100];
1348 c
= next_char (dtp
);
1365 unget_char (dtp
, c
); /* Single null. */
1366 eat_separator (dtp
);
1379 /* Get the digit string that might be a repeat count. */
1383 c
= next_char (dtp
);
1406 push_char (dtp
, 'e');
1408 c
= next_char (dtp
);
1412 push_char (dtp
, '\0');
1416 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1417 unget_char (dtp
, c
);
1426 if (convert_integer (dtp
, -1, 0))
1429 /* Now get the number itself. */
1431 c
= next_char (dtp
);
1432 if (is_separator (c
))
1433 { /* Repeated null value. */
1434 unget_char (dtp
, c
);
1435 eat_separator (dtp
);
1439 if (c
!= '-' && c
!= '+')
1440 push_char (dtp
, '+');
1445 c
= next_char (dtp
);
1448 if (!isdigit (c
) && c
!= '.')
1450 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1469 c
= next_char (dtp
);
1495 push_char (dtp
, 'e');
1497 c
= next_char (dtp
);
1506 push_char (dtp
, 'e');
1508 c
= next_char (dtp
);
1509 if (c
!= '+' && c
!= '-')
1510 push_char (dtp
, '+');
1514 c
= next_char (dtp
);
1524 c
= next_char (dtp
);
1541 unget_char (dtp
, c
);
1542 eat_separator (dtp
);
1543 push_char (dtp
, '\0');
1544 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1548 dtp
->u
.p
.saved_type
= BT_REAL
;
1552 l_push_char (dtp
, c
);
1555 /* Match INF and Infinity. */
1556 if (c
== 'i' || c
== 'I')
1558 c
= next_char (dtp
);
1559 l_push_char (dtp
, c
);
1560 if (c
!= 'n' && c
!= 'N')
1562 c
= next_char (dtp
);
1563 l_push_char (dtp
, c
);
1564 if (c
!= 'f' && c
!= 'F')
1566 c
= next_char (dtp
);
1567 l_push_char (dtp
, c
);
1568 if (!is_separator (c
))
1570 if (c
!= 'i' && c
!= 'I')
1572 c
= next_char (dtp
);
1573 l_push_char (dtp
, c
);
1574 if (c
!= 'n' && c
!= 'N')
1576 c
= next_char (dtp
);
1577 l_push_char (dtp
, c
);
1578 if (c
!= 'i' && c
!= 'I')
1580 c
= next_char (dtp
);
1581 l_push_char (dtp
, c
);
1582 if (c
!= 't' && c
!= 'T')
1584 c
= next_char (dtp
);
1585 l_push_char (dtp
, c
);
1586 if (c
!= 'y' && c
!= 'Y')
1588 c
= next_char (dtp
);
1589 l_push_char (dtp
, c
);
1595 c
= next_char (dtp
);
1596 l_push_char (dtp
, c
);
1597 if (c
!= 'a' && c
!= 'A')
1599 c
= next_char (dtp
);
1600 l_push_char (dtp
, c
);
1601 if (c
!= 'n' && c
!= 'N')
1603 c
= next_char (dtp
);
1604 l_push_char (dtp
, c
);
1607 if (!is_separator (c
))
1610 if (dtp
->u
.p
.namelist_mode
)
1612 if (c
== ' ' || c
=='\n' || c
== '\r')
1615 c
= next_char (dtp
);
1616 while (c
== ' ' || c
=='\n' || c
== '\r');
1618 l_push_char (dtp
, c
);
1627 push_char (dtp
, 'i');
1628 push_char (dtp
, 'n');
1629 push_char (dtp
, 'f');
1633 push_char (dtp
, 'n');
1634 push_char (dtp
, 'a');
1635 push_char (dtp
, 'n');
1638 dtp
->u
.p
.item_count
= 0;
1639 dtp
->u
.p
.line_buffer_enabled
= 0;
1644 if (dtp
->u
.p
.namelist_mode
)
1646 dtp
->u
.p
.nml_read_error
= 1;
1647 dtp
->u
.p
.line_buffer_enabled
= 1;
1648 dtp
->u
.p
.item_count
= 0;
1654 if (nml_bad_return (dtp
, c
))
1659 sprintf (message
, "Bad real number in item %d of list input",
1660 dtp
->u
.p
.item_count
);
1661 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1665 /* Check the current type against the saved type to make sure they are
1666 compatible. Returns nonzero if incompatible. */
1669 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1673 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1675 sprintf (message
, "Read type %s where %s was expected for item %d",
1676 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1677 dtp
->u
.p
.item_count
);
1679 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1683 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1686 if (dtp
->u
.p
.saved_length
!= len
)
1689 "Read kind %d %s where kind %d is required for item %d",
1690 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1691 dtp
->u
.p
.item_count
);
1692 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1700 /* Top level data transfer subroutine for list reads. Because we have
1701 to deal with repeat counts, the data item is always saved after
1702 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1703 greater than one, we copy the data item multiple times. */
1706 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1713 dtp
->u
.p
.namelist_mode
= 0;
1715 dtp
->u
.p
.eof_jump
= &eof_jump
;
1716 if (setjmp (eof_jump
))
1718 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1722 if (dtp
->u
.p
.first_item
)
1724 dtp
->u
.p
.first_item
= 0;
1725 dtp
->u
.p
.input_complete
= 0;
1726 dtp
->u
.p
.repeat_count
= 1;
1727 dtp
->u
.p
.at_eol
= 0;
1729 c
= eat_spaces (dtp
);
1730 if (is_separator (c
))
1732 /* Found a null value. */
1733 eat_separator (dtp
);
1734 dtp
->u
.p
.repeat_count
= 0;
1736 /* eat_separator sets this flag if the separator was a comma. */
1737 if (dtp
->u
.p
.comma_flag
)
1740 /* eat_separator sets this flag if the separator was a \n or \r. */
1741 if (dtp
->u
.p
.at_eol
)
1742 finish_separator (dtp
);
1750 if (dtp
->u
.p
.input_complete
)
1753 if (dtp
->u
.p
.repeat_count
> 0)
1755 if (check_type (dtp
, type
, kind
))
1760 if (dtp
->u
.p
.at_eol
)
1761 finish_separator (dtp
);
1765 /* Trailing spaces prior to end of line. */
1766 if (dtp
->u
.p
.at_eol
)
1767 finish_separator (dtp
);
1770 dtp
->u
.p
.saved_type
= BT_NULL
;
1771 dtp
->u
.p
.repeat_count
= 1;
1777 read_integer (dtp
, kind
);
1780 read_logical (dtp
, kind
);
1783 read_character (dtp
, kind
);
1786 read_real (dtp
, kind
);
1789 read_complex (dtp
, kind
, size
);
1792 internal_error (&dtp
->common
, "Bad type for list read");
1795 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1796 dtp
->u
.p
.saved_length
= size
;
1798 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1802 switch (dtp
->u
.p
.saved_type
)
1808 memcpy (p
, dtp
->u
.p
.value
, size
);
1812 if (dtp
->u
.p
.saved_string
)
1814 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1815 ? (int) size
: dtp
->u
.p
.saved_used
;
1816 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1819 /* Just delimiters encountered, nothing to copy but SPACE. */
1823 memset (((char *) p
) + m
, ' ', size
- m
);
1830 if (--dtp
->u
.p
.repeat_count
<= 0)
1834 dtp
->u
.p
.eof_jump
= NULL
;
1839 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1840 size_t size
, size_t nelems
)
1847 /* Big loop over all the elements. */
1848 for (elem
= 0; elem
< nelems
; elem
++)
1850 dtp
->u
.p
.item_count
++;
1851 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1856 /* Finish a list read. */
1859 finish_list_read (st_parameter_dt
*dtp
)
1865 if (dtp
->u
.p
.at_eol
)
1867 dtp
->u
.p
.at_eol
= 0;
1873 c
= next_char (dtp
);
1880 void namelist_read (st_parameter_dt *dtp)
1882 static void nml_match_name (char *name, int len)
1883 static int nml_query (st_parameter_dt *dtp)
1884 static int nml_get_obj_data (st_parameter_dt *dtp,
1885 namelist_info **prev_nl, char *)
1887 static void nml_untouch_nodes (st_parameter_dt *dtp)
1888 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1890 static int nml_parse_qualifier(descriptor_dimension * ad,
1891 array_loop_spec * ls, int rank, char *)
1892 static void nml_touch_nodes (namelist_info * nl)
1893 static int nml_read_obj (namelist_info *nl, index_type offset,
1894 namelist_info **prev_nl, char *,
1895 index_type clow, index_type chigh)
1899 /* Inputs a rank-dimensional qualifier, which can contain
1900 singlets, doublets, triplets or ':' with the standard meanings. */
1903 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1904 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1911 int is_array_section
, is_char
;
1915 is_array_section
= 0;
1916 dtp
->u
.p
.expanded_read
= 0;
1918 /* See if this is a character substring qualifier we are looking for. */
1925 /* The next character in the stream should be the '('. */
1927 c
= next_char (dtp
);
1929 /* Process the qualifier, by dimension and triplet. */
1931 for (dim
=0; dim
< rank
; dim
++ )
1933 for (indx
=0; indx
<3; indx
++)
1939 /* Process a potential sign. */
1940 c
= next_char (dtp
);
1951 unget_char (dtp
, c
);
1955 /* Process characters up to the next ':' , ',' or ')'. */
1958 c
= next_char (dtp
);
1963 is_array_section
= 1;
1967 if ((c
==',' && dim
== rank
-1)
1968 || (c
==')' && dim
< rank
-1))
1971 sprintf (parse_err_msg
, "Bad substring qualifier");
1973 sprintf (parse_err_msg
, "Bad number of index fields");
1982 case ' ': case '\t':
1984 c
= next_char (dtp
);
1989 sprintf (parse_err_msg
,
1990 "Bad character in substring qualifier");
1992 sprintf (parse_err_msg
, "Bad character in index");
1996 if ((c
== ',' || c
== ')') && indx
== 0
1997 && dtp
->u
.p
.saved_string
== 0)
2000 sprintf (parse_err_msg
, "Null substring qualifier");
2002 sprintf (parse_err_msg
, "Null index field");
2006 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2007 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2010 sprintf (parse_err_msg
, "Bad substring qualifier");
2012 sprintf (parse_err_msg
, "Bad index triplet");
2016 if (is_char
&& !is_array_section
)
2018 sprintf (parse_err_msg
,
2019 "Missing colon in substring qualifier");
2023 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2025 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2026 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2032 /* Now read the index. */
2033 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2036 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2038 sprintf (parse_err_msg
, "Bad integer in index");
2044 /* Feed the index values to the triplet arrays. */
2048 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2050 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2052 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2055 /* Singlet or doublet indices. */
2056 if (c
==',' || c
==')')
2060 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2062 /* If -std=f95/2003 or an array section is specified,
2063 do not allow excess data to be processed. */
2064 if (is_array_section
== 1
2065 || compile_options
.allow_std
< GFC_STD_GNU
)
2066 ls
[dim
].end
= ls
[dim
].start
;
2068 dtp
->u
.p
.expanded_read
= 1;
2071 /* Check for non-zero rank. */
2072 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2079 /* Check the values of the triplet indices. */
2080 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2081 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2082 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2083 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2086 sprintf (parse_err_msg
, "Substring out of range");
2088 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2092 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2093 || (ls
[dim
].step
== 0))
2095 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2099 /* Initialise the loop index counter. */
2100 ls
[dim
].idx
= ls
[dim
].start
;
2110 static namelist_info
*
2111 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2113 namelist_info
* t
= dtp
->u
.p
.ionml
;
2116 if (strcmp (var_name
, t
->var_name
) == 0)
2126 /* Visits all the components of a derived type that have
2127 not explicitly been identified in the namelist input.
2128 touched is set and the loop specification initialised
2129 to default values */
2132 nml_touch_nodes (namelist_info
* nl
)
2134 index_type len
= strlen (nl
->var_name
) + 1;
2136 char * ext_name
= (char*)get_mem (len
+ 1);
2137 memcpy (ext_name
, nl
->var_name
, len
-1);
2138 memcpy (ext_name
+ len
- 1, "%", 2);
2139 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2141 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2144 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2146 nl
->ls
[dim
].step
= 1;
2147 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2148 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2149 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2155 free_mem (ext_name
);
2159 /* Resets touched for the entire list of nml_nodes, ready for a
2163 nml_untouch_nodes (st_parameter_dt
*dtp
)
2166 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2171 /* Attempts to input name to namelist name. Returns
2172 dtp->u.p.nml_read_error = 1 on no match. */
2175 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2179 dtp
->u
.p
.nml_read_error
= 0;
2180 for (i
= 0; i
< len
; i
++)
2182 c
= next_char (dtp
);
2183 if (tolower (c
) != tolower (name
[i
]))
2185 dtp
->u
.p
.nml_read_error
= 1;
2191 /* If the namelist read is from stdin, output the current state of the
2192 namelist to stdout. This is used to implement the non-standard query
2193 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2194 the names alone are printed. */
2197 nml_query (st_parameter_dt
*dtp
, char c
)
2199 gfc_unit
* temp_unit
;
2204 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2207 /* Store the current unit and transfer to stdout. */
2209 temp_unit
= dtp
->u
.p
.current_unit
;
2210 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2212 if (dtp
->u
.p
.current_unit
)
2214 dtp
->u
.p
.mode
= WRITING
;
2215 next_record (dtp
, 0);
2217 /* Write the namelist in its entirety. */
2220 namelist_write (dtp
);
2222 /* Or write the list of names. */
2226 /* "&namelist_name\n" */
2228 len
= dtp
->namelist_name_len
;
2230 p
= write_block (dtp
, len
+ 3);
2232 p
= write_block (dtp
, len
+ 2);
2237 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2239 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2241 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2243 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2247 len
= strlen (nl
->var_name
);
2249 p
= write_block (dtp
, len
+ 3);
2251 p
= write_block (dtp
, len
+ 2);
2256 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2258 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2260 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2267 p
= write_block (dtp
, 6);
2269 p
= write_block (dtp
, 5);
2274 memcpy (p
, "&end\r\n", 6);
2276 memcpy (p
, "&end\n", 5);
2280 /* Flush the stream to force immediate output. */
2282 flush (dtp
->u
.p
.current_unit
->s
);
2283 unlock_unit (dtp
->u
.p
.current_unit
);
2288 /* Restore the current unit. */
2290 dtp
->u
.p
.current_unit
= temp_unit
;
2291 dtp
->u
.p
.mode
= READING
;
2295 /* Reads and stores the input for the namelist object nl. For an array,
2296 the function loops over the ranges defined by the loop specification.
2297 This default to all the data or to the specification from a qualifier.
2298 nml_read_obj recursively calls itself to read derived types. It visits
2299 all its own components but only reads data for those that were touched
2300 when the name was parsed. If a read error is encountered, an attempt is
2301 made to return to read a new object name because the standard allows too
2302 little data to be available. On the other hand, too much data is an
2306 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2307 namelist_info
**pprev_nl
, char *nml_err_msg
,
2308 index_type clow
, index_type chigh
)
2310 namelist_info
* cmp
;
2317 index_type obj_name_len
;
2320 /* This object not touched in name parsing. */
2325 dtp
->u
.p
.repeat_count
= 0;
2331 case GFC_DTYPE_INTEGER
:
2332 case GFC_DTYPE_LOGICAL
:
2336 case GFC_DTYPE_REAL
:
2337 dlen
= size_from_real_kind (len
);
2340 case GFC_DTYPE_COMPLEX
:
2341 dlen
= size_from_complex_kind (len
);
2344 case GFC_DTYPE_CHARACTER
:
2345 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2354 /* Update the pointer to the data, using the current index vector */
2356 pdata
= (void*)(nl
->mem_pos
+ offset
);
2357 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2358 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2359 nl
->dim
[dim
].stride
* nl
->size
);
2361 /* Reset the error flag and try to read next value, if
2362 dtp->u.p.repeat_count=0 */
2364 dtp
->u
.p
.nml_read_error
= 0;
2366 if (--dtp
->u
.p
.repeat_count
<= 0)
2368 if (dtp
->u
.p
.input_complete
)
2370 if (dtp
->u
.p
.at_eol
)
2371 finish_separator (dtp
);
2372 if (dtp
->u
.p
.input_complete
)
2375 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2376 after the switch block. */
2378 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2383 case GFC_DTYPE_INTEGER
:
2384 read_integer (dtp
, len
);
2387 case GFC_DTYPE_LOGICAL
:
2388 read_logical (dtp
, len
);
2391 case GFC_DTYPE_CHARACTER
:
2392 read_character (dtp
, len
);
2395 case GFC_DTYPE_REAL
:
2396 read_real (dtp
, len
);
2399 case GFC_DTYPE_COMPLEX
:
2400 read_complex (dtp
, len
, dlen
);
2403 case GFC_DTYPE_DERIVED
:
2404 obj_name_len
= strlen (nl
->var_name
) + 1;
2405 obj_name
= get_mem (obj_name_len
+1);
2406 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2407 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2409 /* If reading a derived type, disable the expanded read warning
2410 since a single object can have multiple reads. */
2411 dtp
->u
.p
.expanded_read
= 0;
2413 /* Now loop over the components. Update the component pointer
2414 with the return value from nml_write_obj. This loop jumps
2415 past nested derived types by testing if the potential
2416 component name contains '%'. */
2418 for (cmp
= nl
->next
;
2420 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2421 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2425 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2426 pprev_nl
, nml_err_msg
, clow
, chigh
)
2429 free_mem (obj_name
);
2433 if (dtp
->u
.p
.input_complete
)
2435 free_mem (obj_name
);
2440 free_mem (obj_name
);
2444 sprintf (nml_err_msg
, "Bad type for namelist object %s",
2446 internal_error (&dtp
->common
, nml_err_msg
);
2451 /* The standard permits array data to stop short of the number of
2452 elements specified in the loop specification. In this case, we
2453 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2454 nml_get_obj_data and an attempt is made to read object name. */
2457 if (dtp
->u
.p
.nml_read_error
)
2459 dtp
->u
.p
.expanded_read
= 0;
2463 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2465 dtp
->u
.p
.expanded_read
= 0;
2469 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2470 This comes about because the read functions return BT_types. */
2472 switch (dtp
->u
.p
.saved_type
)
2479 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2483 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2484 pdata
= (void*)( pdata
+ clow
- 1 );
2485 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2487 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2494 /* Warn if a non-standard expanded read occurs. A single read of a
2495 single object is acceptable. If a second read occurs, issue a warning
2496 and set the flag to zero to prevent further warnings. */
2497 if (dtp
->u
.p
.expanded_read
== 2)
2499 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2500 dtp
->u
.p
.expanded_read
= 0;
2503 /* If the expanded read warning flag is set, increment it,
2504 indicating that a single read has occurred. */
2505 if (dtp
->u
.p
.expanded_read
>= 1)
2506 dtp
->u
.p
.expanded_read
++;
2508 /* Break out of loop if scalar. */
2512 /* Now increment the index vector. */
2517 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2519 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2521 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2523 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2525 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2529 } while (!nml_carry
);
2531 if (dtp
->u
.p
.repeat_count
> 1)
2533 sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2544 /* Parses the object name, including array and substring qualifiers. It
2545 iterates over derived type components, touching those components and
2546 setting their loop specifications, if there is a qualifier. If the
2547 object is itself a derived type, its components and subcomponents are
2548 touched. nml_read_obj is called at the end and this reads the data in
2549 the manner specified by the object name. */
2552 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2557 namelist_info
* first_nl
= NULL
;
2558 namelist_info
* root_nl
= NULL
;
2559 int dim
, parsed_rank
;
2561 char parse_err_msg
[30];
2562 index_type clow
, chigh
;
2563 int non_zero_rank_count
;
2565 /* Look for end of input or object name. If '?' or '=?' are encountered
2566 in stdin, print the node names or the namelist to stdout. */
2568 eat_separator (dtp
);
2569 if (dtp
->u
.p
.input_complete
)
2572 if (dtp
->u
.p
.at_eol
)
2573 finish_separator (dtp
);
2574 if (dtp
->u
.p
.input_complete
)
2577 c
= next_char (dtp
);
2581 c
= next_char (dtp
);
2584 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2587 nml_query (dtp
, '=');
2591 nml_query (dtp
, '?');
2596 nml_match_name (dtp
, "end", 3);
2597 if (dtp
->u
.p
.nml_read_error
)
2599 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2603 dtp
->u
.p
.input_complete
= 1;
2610 /* Untouch all nodes of the namelist and reset the flag that is set for
2611 derived type components. */
2613 nml_untouch_nodes (dtp
);
2615 non_zero_rank_count
= 0;
2617 /* Get the object name - should '!' and '\n' be permitted separators? */
2625 if (!is_separator (c
))
2626 push_char (dtp
, tolower(c
));
2627 c
= next_char (dtp
);
2628 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2630 unget_char (dtp
, c
);
2632 /* Check that the name is in the namelist and get pointer to object.
2633 Three error conditions exist: (i) An attempt is being made to
2634 identify a non-existent object, following a failed data read or
2635 (ii) The object name does not exist or (iii) Too many data items
2636 are present for an object. (iii) gives the same error message
2639 push_char (dtp
, '\0');
2643 size_t var_len
= strlen (root_nl
->var_name
);
2645 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2646 char ext_name
[var_len
+ saved_len
+ 1];
2648 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2649 if (dtp
->u
.p
.saved_string
)
2650 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2651 ext_name
[var_len
+ saved_len
] = '\0';
2652 nl
= find_nml_node (dtp
, ext_name
);
2655 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2659 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2660 sprintf (nml_err_msg
, "Bad data for namelist object %s",
2661 (*pprev_nl
)->var_name
);
2664 sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2665 dtp
->u
.p
.saved_string
);
2670 /* Get the length, data length, base pointer and rank of the variable.
2671 Set the default loop specification first. */
2673 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2675 nl
->ls
[dim
].step
= 1;
2676 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2677 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2678 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2681 /* Check to see if there is a qualifier: if so, parse it.*/
2683 if (c
== '(' && nl
->var_rank
)
2686 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2687 parse_err_msg
, &parsed_rank
) == FAILURE
)
2689 sprintf (nml_err_msg
, "%s for namelist variable %s",
2690 parse_err_msg
, nl
->var_name
);
2694 if (parsed_rank
> 0)
2695 non_zero_rank_count
++;
2697 c
= next_char (dtp
);
2698 unget_char (dtp
, c
);
2700 else if (nl
->var_rank
> 0)
2701 non_zero_rank_count
++;
2703 /* Now parse a derived type component. The root namelist_info address
2704 is backed up, as is the previous component level. The component flag
2705 is set and the iteration is made by jumping back to get_name. */
2709 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2711 sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2716 if (!component_flag
)
2721 c
= next_char (dtp
);
2725 /* Parse a character qualifier, if present. chigh = 0 is a default
2726 that signals that the string length = string_length. */
2731 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2733 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2734 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2736 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, parse_err_msg
, &parsed_rank
)
2739 sprintf (nml_err_msg
, "%s for namelist variable %s",
2740 parse_err_msg
, nl
->var_name
);
2744 clow
= ind
[0].start
;
2747 if (ind
[0].step
!= 1)
2749 sprintf (nml_err_msg
,
2750 "Step not allowed in substring qualifier"
2751 " for namelist object %s", nl
->var_name
);
2755 c
= next_char (dtp
);
2756 unget_char (dtp
, c
);
2759 /* If a derived type touch its components and restore the root
2760 namelist_info if we have parsed a qualified derived type
2763 if (nl
->type
== GFC_DTYPE_DERIVED
)
2764 nml_touch_nodes (nl
);
2768 /* Make sure no extraneous qualifiers are there. */
2772 sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2773 " namelist object %s", nl
->var_name
);
2777 /* Make sure there is no more than one non-zero rank object. */
2778 if (non_zero_rank_count
> 1)
2780 sprintf (nml_err_msg
, "Multiple sub-objects with non-zero rank in"
2781 " namelist object %s", nl
->var_name
);
2782 non_zero_rank_count
= 0;
2786 /* According to the standard, an equal sign MUST follow an object name. The
2787 following is possibly lax - it allows comments, blank lines and so on to
2788 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2792 eat_separator (dtp
);
2793 if (dtp
->u
.p
.input_complete
)
2796 if (dtp
->u
.p
.at_eol
)
2797 finish_separator (dtp
);
2798 if (dtp
->u
.p
.input_complete
)
2801 c
= next_char (dtp
);
2805 sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2810 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2820 /* Entry point for namelist input. Goes through input until namelist name
2821 is matched. Then cycles through nml_get_obj_data until the input is
2822 completed or there is an error. */
2825 namelist_read (st_parameter_dt
*dtp
)
2829 char nml_err_msg
[100];
2830 /* Pointer to the previously read object, in case attempt is made to read
2831 new object name. Should this fail, error message can give previous
2833 namelist_info
*prev_nl
= NULL
;
2835 dtp
->u
.p
.namelist_mode
= 1;
2836 dtp
->u
.p
.input_complete
= 0;
2837 dtp
->u
.p
.expanded_read
= 0;
2839 dtp
->u
.p
.eof_jump
= &eof_jump
;
2840 if (setjmp (eof_jump
))
2842 dtp
->u
.p
.eof_jump
= NULL
;
2843 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2847 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2848 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2849 node names or namelist on stdout. */
2852 switch (c
= next_char (dtp
))
2863 c
= next_char (dtp
);
2865 nml_query (dtp
, '=');
2867 unget_char (dtp
, c
);
2871 nml_query (dtp
, '?');
2877 /* Match the name of the namelist. */
2879 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2881 if (dtp
->u
.p
.nml_read_error
)
2884 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2885 c
= next_char (dtp
);
2886 if (!is_separator(c
))
2888 unget_char (dtp
, c
);
2892 /* Ready to read namelist objects. If there is an error in input
2893 from stdin, output the error message and continue. */
2895 while (!dtp
->u
.p
.input_complete
)
2897 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2901 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2904 u
= find_unit (options
.stderr_unit
);
2905 st_printf ("%s\n", nml_err_msg
);
2915 dtp
->u
.p
.eof_jump
= NULL
;
2920 /* All namelist error calls return from here */
2924 dtp
->u
.p
.eof_jump
= NULL
;
2927 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);