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)
175 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
177 /* Check for "end-of-file" condition. */
184 record
*= dtp
->u
.p
.current_unit
->recl
;
185 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
186 longjmp (*dtp
->u
.p
.eof_jump
, 1);
188 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
193 /* Get the next character and handle end-of-record conditions. */
197 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
199 if (is_stream_io (dtp
))
200 dtp
->u
.p
.current_unit
->strm_pos
++;
202 if (is_internal_unit (dtp
))
204 if (is_array_io (dtp
))
206 /* End of record is handled in the next pass through, above. The
207 check for NULL here is cautionary. */
210 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
214 dtp
->u
.p
.current_unit
->bytes_left
--;
220 longjmp (*dtp
->u
.p
.eof_jump
, 1);
231 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
236 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
237 longjmp (*dtp
->u
.p
.eof_jump
, 1);
238 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
245 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt
*dtp
, char c
)
255 dtp
->u
.p
.last_char
= c
;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt
*dtp
)
271 while (c
== ' ' || c
== '\t');
278 /* Skip over a separator. Technically, we don't always eat the whole
279 separator. This is because if we've processed the last input item,
280 then a separator is unnecessary. Plus the fact that operating
281 systems usually deliver console input on a line basis.
283 The upshot is that if we see a newline as part of reading a
284 separator, we stop reading. If there are more input items, we
285 continue reading the separator with finish_separator() which takes
286 care of the fact that we may or may not have seen a comma as part
290 eat_separator (st_parameter_dt
*dtp
)
295 dtp
->u
.p
.comma_flag
= 0;
301 dtp
->u
.p
.comma_flag
= 1;
306 dtp
->u
.p
.input_complete
= 1;
314 if (dtp
->u
.p
.namelist_mode
)
318 while (c
== '\n' || c
== '\r' || c
== ' ');
328 if (dtp
->u
.p
.namelist_mode
)
332 while (c
== '\n' || c
== '\r' || c
== ' ');
338 if (dtp
->u
.p
.namelist_mode
)
339 { /* Eat a namelist comment. */
347 /* Fall Through... */
356 /* Finish processing a separator that was interrupted by a newline.
357 If we're here, then another data item is present, so we finish what
358 we started on the previous line. */
361 finish_separator (st_parameter_dt
*dtp
)
372 if (dtp
->u
.p
.comma_flag
)
376 c
= eat_spaces (dtp
);
377 if (c
== '\n' || c
== '\r')
384 dtp
->u
.p
.input_complete
= 1;
385 if (!dtp
->u
.p
.namelist_mode
)
394 if (dtp
->u
.p
.namelist_mode
)
410 /* This function reads characters through to the end of the current line and
411 just ignores them. */
414 eat_line (st_parameter_dt
*dtp
)
417 if (!is_internal_unit (dtp
))
424 /* This function is needed to catch bad conversions so that namelist can
425 attempt to see if dtp->u.p.saved_string contains a new object name rather
429 nml_bad_return (st_parameter_dt
*dtp
, char c
)
431 if (dtp
->u
.p
.namelist_mode
)
433 dtp
->u
.p
.nml_read_error
= 1;
440 /* Convert an unsigned string to an integer. The length value is -1
441 if we are working on a repeat count. Returns nonzero if we have a
442 range problem. As a side effect, frees the dtp->u.p.saved_string. */
445 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
447 char c
, *buffer
, message
[100];
449 GFC_INTEGER_LARGEST v
, max
, max10
;
451 buffer
= dtp
->u
.p
.saved_string
;
454 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
479 set_integer (dtp
->u
.p
.value
, v
, length
);
483 dtp
->u
.p
.repeat_count
= v
;
485 if (dtp
->u
.p
.repeat_count
== 0)
487 sprintf (message
, "Zero repeat count in item %d of list input",
488 dtp
->u
.p
.item_count
);
490 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
500 sprintf (message
, "Repeat count overflow in item %d of list input",
501 dtp
->u
.p
.item_count
);
503 sprintf (message
, "Integer overflow while reading item %d",
504 dtp
->u
.p
.item_count
);
507 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
513 /* Parse a repeat count for logical and complex values which cannot
514 begin with a digit. Returns nonzero if we are done, zero if we
515 should continue on. */
518 parse_repeat (st_parameter_dt
*dtp
)
520 char c
, message
[100];
546 repeat
= 10 * repeat
+ c
- '0';
548 if (repeat
> MAX_REPEAT
)
551 "Repeat count overflow in item %d of list input",
552 dtp
->u
.p
.item_count
);
554 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
564 "Zero repeat count in item %d of list input",
565 dtp
->u
.p
.item_count
);
567 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
579 dtp
->u
.p
.repeat_count
= repeat
;
586 sprintf (message
, "Bad repeat count in item %d of list input",
587 dtp
->u
.p
.item_count
);
588 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
593 /* To read a logical we have to look ahead in the input stream to make sure
594 there is not an equal sign indicating a variable name. To do this we use
595 line_buffer to point to a temporary buffer, pushing characters there for
596 possible later reading. */
599 l_push_char (st_parameter_dt
*dtp
, char c
)
601 if (dtp
->u
.p
.line_buffer
== NULL
)
603 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
604 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
607 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
611 /* Read a logical character on the input. */
614 read_logical (st_parameter_dt
*dtp
, int length
)
616 char c
, message
[100];
619 if (parse_repeat (dtp
))
622 c
= tolower (next_char (dtp
));
623 l_push_char (dtp
, c
);
629 l_push_char (dtp
, c
);
631 if (!is_separator(c
))
639 l_push_char (dtp
, c
);
641 if (!is_separator(c
))
647 c
= tolower (next_char (dtp
));
665 return; /* Null value. */
671 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
672 dtp
->u
.p
.saved_length
= length
;
674 /* Eat trailing garbage. */
679 while (!is_separator (c
));
683 dtp
->u
.p
.item_count
= 0;
684 dtp
->u
.p
.line_buffer_enabled
= 0;
685 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
692 for(i
= 0; i
< 63; i
++)
697 /* All done if this is not a namelist read. */
698 if (!dtp
->u
.p
.namelist_mode
)
711 l_push_char (dtp
, c
);
714 dtp
->u
.p
.nml_read_error
= 1;
715 dtp
->u
.p
.line_buffer_enabled
= 1;
716 dtp
->u
.p
.item_count
= 0;
726 if (nml_bad_return (dtp
, c
))
731 sprintf (message
, "Bad logical value while reading item %d",
732 dtp
->u
.p
.item_count
);
733 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
738 dtp
->u
.p
.item_count
= 0;
739 dtp
->u
.p
.line_buffer_enabled
= 0;
740 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
741 dtp
->u
.p
.saved_length
= length
;
742 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
748 /* Reading integers is tricky because we can actually be reading a
749 repeat count. We have to store the characters in a buffer because
750 we could be reading an integer that is larger than the default int
751 used for repeat counts. */
754 read_integer (st_parameter_dt
*dtp
, int length
)
756 char c
, message
[100];
766 /* Fall through... */
772 CASE_SEPARATORS
: /* Single null. */
785 /* Take care of what may be a repeat count. */
797 push_char (dtp
, '\0');
800 CASE_SEPARATORS
: /* Not a repeat count. */
809 if (convert_integer (dtp
, -1, 0))
812 /* Get the real integer. */
827 /* Fall through... */
858 if (nml_bad_return (dtp
, c
))
863 sprintf (message
, "Bad integer for item %d in list input",
864 dtp
->u
.p
.item_count
);
865 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
873 push_char (dtp
, '\0');
874 if (convert_integer (dtp
, length
, negative
))
881 dtp
->u
.p
.saved_type
= BT_INTEGER
;
885 /* Read a character variable. */
888 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
890 char c
, quote
, message
[100];
892 quote
= ' '; /* Space means no quote character. */
902 unget_char (dtp
, c
); /* NULL value. */
912 if (dtp
->u
.p
.namelist_mode
)
914 if (dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_APOSTROPHE
915 || dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_QUOTE
916 || c
== '&' || c
== '$' || c
== '/')
922 /* Check to see if we are seeing a namelist object name by using the
923 line buffer and looking ahead for an '=' or '('. */
924 l_push_char (dtp
, c
);
927 for(i
= 0; i
< 63; i
++)
937 l_push_char (dtp
, c
);
938 dtp
->u
.p
.item_count
= 0;
939 dtp
->u
.p
.line_buffer_enabled
= 1;
944 l_push_char (dtp
, c
);
946 if (c
== '=' || c
== '(')
948 dtp
->u
.p
.item_count
= 0;
949 dtp
->u
.p
.nml_read_error
= 1;
950 dtp
->u
.p
.line_buffer_enabled
= 1;
955 /* The string is too long to be a valid object name so assume that it
956 is a string to be read in as a value. */
957 dtp
->u
.p
.item_count
= 0;
958 dtp
->u
.p
.line_buffer_enabled
= 1;
966 /* Deal with a possible repeat count. */
979 goto done
; /* String was only digits! */
982 push_char (dtp
, '\0');
987 goto get_string
; /* Not a repeat count after all. */
992 if (convert_integer (dtp
, -1, 0))
995 /* Now get the real string. */
1001 unget_char (dtp
, c
); /* Repeated NULL values. */
1002 eat_separator (dtp
);
1018 c
= next_char (dtp
);
1029 /* See if we have a doubled quote character or the end of
1032 c
= next_char (dtp
);
1035 push_char (dtp
, quote
);
1039 unget_char (dtp
, c
);
1045 unget_char (dtp
, c
);
1049 if (c
!= '\n' && c
!= '\r')
1059 /* At this point, we have to have a separator, or else the string is
1062 c
= next_char (dtp
);
1063 if (is_separator (c
))
1065 unget_char (dtp
, c
);
1066 eat_separator (dtp
);
1067 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1073 sprintf (message
, "Invalid string input in item %d",
1074 dtp
->u
.p
.item_count
);
1075 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1080 /* Parse a component of a complex constant or a real number that we
1081 are sure is already there. This is a straight real number parser. */
1084 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1086 char c
, message
[100];
1089 c
= next_char (dtp
);
1090 if (c
== '-' || c
== '+')
1093 c
= next_char (dtp
);
1096 if (!isdigit (c
) && c
!= '.')
1098 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1106 seen_dp
= (c
== '.') ? 1 : 0;
1110 c
= next_char (dtp
);
1129 push_char (dtp
, 'e');
1134 push_char (dtp
, 'e');
1136 c
= next_char (dtp
);
1140 unget_char (dtp
, c
);
1149 c
= next_char (dtp
);
1150 if (c
!= '-' && c
!= '+')
1151 push_char (dtp
, '+');
1155 c
= next_char (dtp
);
1166 c
= next_char (dtp
);
1174 unget_char (dtp
, c
);
1183 unget_char (dtp
, c
);
1184 push_char (dtp
, '\0');
1186 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1192 /* Match INF and Infinity. */
1193 if ((c
== 'i' || c
== 'I')
1194 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1195 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1197 c
= next_char (dtp
);
1198 if ((c
!= 'i' && c
!= 'I')
1199 || ((c
== 'i' || c
== 'I')
1200 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1201 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1202 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1203 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1204 && (c
= next_char (dtp
))))
1206 if (is_separator (c
))
1207 unget_char (dtp
, c
);
1208 push_char (dtp
, 'i');
1209 push_char (dtp
, 'n');
1210 push_char (dtp
, 'f');
1214 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1215 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1216 && (c
= next_char (dtp
)))
1218 if (is_separator (c
))
1219 unget_char (dtp
, c
);
1220 push_char (dtp
, 'n');
1221 push_char (dtp
, 'a');
1222 push_char (dtp
, 'n');
1228 if (nml_bad_return (dtp
, c
))
1233 sprintf (message
, "Bad floating point number for item %d",
1234 dtp
->u
.p
.item_count
);
1235 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1241 /* Reading a complex number is straightforward because we can tell
1242 what it is right away. */
1245 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1250 if (parse_repeat (dtp
))
1253 c
= next_char (dtp
);
1260 unget_char (dtp
, c
);
1261 eat_separator (dtp
);
1269 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1274 c
= next_char (dtp
);
1275 if (c
== '\n' || c
== '\r')
1278 unget_char (dtp
, c
);
1280 if (next_char (dtp
) != ',')
1285 c
= next_char (dtp
);
1286 if (c
== '\n' || c
== '\r')
1289 unget_char (dtp
, c
);
1291 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1295 if (next_char (dtp
) != ')')
1298 c
= next_char (dtp
);
1299 if (!is_separator (c
))
1302 unget_char (dtp
, c
);
1303 eat_separator (dtp
);
1306 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1311 if (nml_bad_return (dtp
, c
))
1316 sprintf (message
, "Bad complex value in item %d of list input",
1317 dtp
->u
.p
.item_count
);
1318 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1322 /* Parse a real number with a possible repeat count. */
1325 read_real (st_parameter_dt
*dtp
, int length
)
1327 char c
, message
[100];
1333 c
= next_char (dtp
);
1350 unget_char (dtp
, c
); /* Single null. */
1351 eat_separator (dtp
);
1364 /* Get the digit string that might be a repeat count. */
1368 c
= next_char (dtp
);
1391 push_char (dtp
, 'e');
1393 c
= next_char (dtp
);
1397 push_char (dtp
, '\0');
1401 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1402 unget_char (dtp
, c
);
1411 if (convert_integer (dtp
, -1, 0))
1414 /* Now get the number itself. */
1416 c
= next_char (dtp
);
1417 if (is_separator (c
))
1418 { /* Repeated null value. */
1419 unget_char (dtp
, c
);
1420 eat_separator (dtp
);
1424 if (c
!= '-' && c
!= '+')
1425 push_char (dtp
, '+');
1430 c
= next_char (dtp
);
1433 if (!isdigit (c
) && c
!= '.')
1435 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1454 c
= next_char (dtp
);
1480 push_char (dtp
, 'e');
1482 c
= next_char (dtp
);
1491 push_char (dtp
, 'e');
1493 c
= next_char (dtp
);
1494 if (c
!= '+' && c
!= '-')
1495 push_char (dtp
, '+');
1499 c
= next_char (dtp
);
1509 c
= next_char (dtp
);
1526 unget_char (dtp
, c
);
1527 eat_separator (dtp
);
1528 push_char (dtp
, '\0');
1529 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1533 dtp
->u
.p
.saved_type
= BT_REAL
;
1537 l_push_char (dtp
, c
);
1540 /* Match INF and Infinity. */
1541 if (c
== 'i' || c
== 'I')
1543 c
= next_char (dtp
);
1544 l_push_char (dtp
, c
);
1545 if (c
!= 'n' && c
!= 'N')
1547 c
= next_char (dtp
);
1548 l_push_char (dtp
, c
);
1549 if (c
!= 'f' && c
!= 'F')
1551 c
= next_char (dtp
);
1552 l_push_char (dtp
, c
);
1553 if (!is_separator (c
))
1555 if (c
!= 'i' && c
!= 'I')
1557 c
= next_char (dtp
);
1558 l_push_char (dtp
, c
);
1559 if (c
!= 'n' && c
!= 'N')
1561 c
= next_char (dtp
);
1562 l_push_char (dtp
, c
);
1563 if (c
!= 'i' && c
!= 'I')
1565 c
= next_char (dtp
);
1566 l_push_char (dtp
, c
);
1567 if (c
!= 't' && c
!= 'T')
1569 c
= next_char (dtp
);
1570 l_push_char (dtp
, c
);
1571 if (c
!= 'y' && c
!= 'Y')
1573 c
= next_char (dtp
);
1574 l_push_char (dtp
, c
);
1580 c
= next_char (dtp
);
1581 l_push_char (dtp
, c
);
1582 if (c
!= 'a' && c
!= 'A')
1584 c
= next_char (dtp
);
1585 l_push_char (dtp
, c
);
1586 if (c
!= 'n' && c
!= 'N')
1588 c
= next_char (dtp
);
1589 l_push_char (dtp
, c
);
1592 if (!is_separator (c
))
1595 if (dtp
->u
.p
.namelist_mode
)
1597 if (c
== ' ' || c
=='\n' || c
== '\r')
1600 c
= next_char (dtp
);
1601 while (c
== ' ' || c
=='\n' || c
== '\r');
1603 l_push_char (dtp
, c
);
1612 push_char (dtp
, 'i');
1613 push_char (dtp
, 'n');
1614 push_char (dtp
, 'f');
1618 push_char (dtp
, 'n');
1619 push_char (dtp
, 'a');
1620 push_char (dtp
, 'n');
1623 dtp
->u
.p
.item_count
= 0;
1624 dtp
->u
.p
.line_buffer_enabled
= 0;
1629 if (dtp
->u
.p
.namelist_mode
)
1631 dtp
->u
.p
.nml_read_error
= 1;
1632 dtp
->u
.p
.line_buffer_enabled
= 1;
1633 dtp
->u
.p
.item_count
= 0;
1639 if (nml_bad_return (dtp
, c
))
1644 sprintf (message
, "Bad real number in item %d of list input",
1645 dtp
->u
.p
.item_count
);
1646 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1650 /* Check the current type against the saved type to make sure they are
1651 compatible. Returns nonzero if incompatible. */
1654 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1658 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1660 sprintf (message
, "Read type %s where %s was expected for item %d",
1661 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1662 dtp
->u
.p
.item_count
);
1664 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1668 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1671 if (dtp
->u
.p
.saved_length
!= len
)
1674 "Read kind %d %s where kind %d is required for item %d",
1675 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1676 dtp
->u
.p
.item_count
);
1677 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1685 /* Top level data transfer subroutine for list reads. Because we have
1686 to deal with repeat counts, the data item is always saved after
1687 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1688 greater than one, we copy the data item multiple times. */
1691 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1698 dtp
->u
.p
.namelist_mode
= 0;
1700 dtp
->u
.p
.eof_jump
= &eof_jump
;
1701 if (setjmp (eof_jump
))
1703 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1707 if (dtp
->u
.p
.first_item
)
1709 dtp
->u
.p
.first_item
= 0;
1710 dtp
->u
.p
.input_complete
= 0;
1711 dtp
->u
.p
.repeat_count
= 1;
1712 dtp
->u
.p
.at_eol
= 0;
1714 c
= eat_spaces (dtp
);
1715 if (is_separator (c
))
1717 /* Found a null value. */
1718 eat_separator (dtp
);
1719 dtp
->u
.p
.repeat_count
= 0;
1721 /* eat_separator sets this flag if the separator was a comma. */
1722 if (dtp
->u
.p
.comma_flag
)
1725 /* eat_separator sets this flag if the separator was a \n or \r. */
1726 if (dtp
->u
.p
.at_eol
)
1727 finish_separator (dtp
);
1735 if (dtp
->u
.p
.input_complete
)
1738 if (dtp
->u
.p
.repeat_count
> 0)
1740 if (check_type (dtp
, type
, kind
))
1745 if (dtp
->u
.p
.at_eol
)
1746 finish_separator (dtp
);
1750 /* Trailing spaces prior to end of line. */
1751 if (dtp
->u
.p
.at_eol
)
1752 finish_separator (dtp
);
1755 dtp
->u
.p
.saved_type
= BT_NULL
;
1756 dtp
->u
.p
.repeat_count
= 1;
1762 read_integer (dtp
, kind
);
1765 read_logical (dtp
, kind
);
1768 read_character (dtp
, kind
);
1771 read_real (dtp
, kind
);
1774 read_complex (dtp
, kind
, size
);
1777 internal_error (&dtp
->common
, "Bad type for list read");
1780 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1781 dtp
->u
.p
.saved_length
= size
;
1783 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1787 switch (dtp
->u
.p
.saved_type
)
1793 memcpy (p
, dtp
->u
.p
.value
, size
);
1797 if (dtp
->u
.p
.saved_string
)
1799 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1800 ? (int) size
: dtp
->u
.p
.saved_used
;
1801 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1804 /* Just delimiters encountered, nothing to copy but SPACE. */
1808 memset (((char *) p
) + m
, ' ', size
- m
);
1815 if (--dtp
->u
.p
.repeat_count
<= 0)
1819 dtp
->u
.p
.eof_jump
= NULL
;
1824 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1825 size_t size
, size_t nelems
)
1832 /* Big loop over all the elements. */
1833 for (elem
= 0; elem
< nelems
; elem
++)
1835 dtp
->u
.p
.item_count
++;
1836 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1841 /* Finish a list read. */
1844 finish_list_read (st_parameter_dt
*dtp
)
1850 if (dtp
->u
.p
.at_eol
)
1852 dtp
->u
.p
.at_eol
= 0;
1858 c
= next_char (dtp
);
1865 void namelist_read (st_parameter_dt *dtp)
1867 static void nml_match_name (char *name, int len)
1868 static int nml_query (st_parameter_dt *dtp)
1869 static int nml_get_obj_data (st_parameter_dt *dtp,
1870 namelist_info **prev_nl, char *)
1872 static void nml_untouch_nodes (st_parameter_dt *dtp)
1873 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1875 static int nml_parse_qualifier(descriptor_dimension * ad,
1876 array_loop_spec * ls, int rank, char *)
1877 static void nml_touch_nodes (namelist_info * nl)
1878 static int nml_read_obj (namelist_info *nl, index_type offset,
1879 namelist_info **prev_nl, char *,
1880 index_type clow, index_type chigh)
1884 /* Inputs a rank-dimensional qualifier, which can contain
1885 singlets, doublets, triplets or ':' with the standard meanings. */
1888 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1889 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1896 int is_array_section
, is_char
;
1900 is_array_section
= 0;
1901 dtp
->u
.p
.expanded_read
= 0;
1903 /* See if this is a character substring qualifier we are looking for. */
1910 /* The next character in the stream should be the '('. */
1912 c
= next_char (dtp
);
1914 /* Process the qualifier, by dimension and triplet. */
1916 for (dim
=0; dim
< rank
; dim
++ )
1918 for (indx
=0; indx
<3; indx
++)
1924 /* Process a potential sign. */
1925 c
= next_char (dtp
);
1936 unget_char (dtp
, c
);
1940 /* Process characters up to the next ':' , ',' or ')'. */
1943 c
= next_char (dtp
);
1948 is_array_section
= 1;
1952 if ((c
==',' && dim
== rank
-1)
1953 || (c
==')' && dim
< rank
-1))
1956 sprintf (parse_err_msg
, "Bad substring qualifier");
1958 sprintf (parse_err_msg
, "Bad number of index fields");
1967 case ' ': case '\t':
1969 c
= next_char (dtp
);
1974 sprintf (parse_err_msg
,
1975 "Bad character in substring qualifier");
1977 sprintf (parse_err_msg
, "Bad character in index");
1981 if ((c
== ',' || c
== ')') && indx
== 0
1982 && dtp
->u
.p
.saved_string
== 0)
1985 sprintf (parse_err_msg
, "Null substring qualifier");
1987 sprintf (parse_err_msg
, "Null index field");
1991 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1992 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1995 sprintf (parse_err_msg
, "Bad substring qualifier");
1997 sprintf (parse_err_msg
, "Bad index triplet");
2001 if (is_char
&& !is_array_section
)
2003 sprintf (parse_err_msg
,
2004 "Missing colon in substring qualifier");
2008 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2010 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2011 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2017 /* Now read the index. */
2018 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2021 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2023 sprintf (parse_err_msg
, "Bad integer in index");
2029 /* Feed the index values to the triplet arrays. */
2033 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2035 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2037 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2040 /* Singlet or doublet indices. */
2041 if (c
==',' || c
==')')
2045 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2047 /* If -std=f95/2003 or an array section is specified,
2048 do not allow excess data to be processed. */
2049 if (is_array_section
== 1
2050 || compile_options
.allow_std
< GFC_STD_GNU
)
2051 ls
[dim
].end
= ls
[dim
].start
;
2053 dtp
->u
.p
.expanded_read
= 1;
2056 /* Check for non-zero rank. */
2057 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2064 /* Check the values of the triplet indices. */
2065 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2066 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2067 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2068 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2071 sprintf (parse_err_msg
, "Substring out of range");
2073 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2077 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2078 || (ls
[dim
].step
== 0))
2080 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2084 /* Initialise the loop index counter. */
2085 ls
[dim
].idx
= ls
[dim
].start
;
2095 static namelist_info
*
2096 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2098 namelist_info
* t
= dtp
->u
.p
.ionml
;
2101 if (strcmp (var_name
, t
->var_name
) == 0)
2111 /* Visits all the components of a derived type that have
2112 not explicitly been identified in the namelist input.
2113 touched is set and the loop specification initialised
2114 to default values */
2117 nml_touch_nodes (namelist_info
* nl
)
2119 index_type len
= strlen (nl
->var_name
) + 1;
2121 char * ext_name
= (char*)get_mem (len
+ 1);
2122 memcpy (ext_name
, nl
->var_name
, len
-1);
2123 memcpy (ext_name
+ len
- 1, "%", 2);
2124 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2126 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2129 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2131 nl
->ls
[dim
].step
= 1;
2132 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2133 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2134 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2140 free_mem (ext_name
);
2144 /* Resets touched for the entire list of nml_nodes, ready for a
2148 nml_untouch_nodes (st_parameter_dt
*dtp
)
2151 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2156 /* Attempts to input name to namelist name. Returns
2157 dtp->u.p.nml_read_error = 1 on no match. */
2160 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2164 dtp
->u
.p
.nml_read_error
= 0;
2165 for (i
= 0; i
< len
; i
++)
2167 c
= next_char (dtp
);
2168 if (tolower (c
) != tolower (name
[i
]))
2170 dtp
->u
.p
.nml_read_error
= 1;
2176 /* If the namelist read is from stdin, output the current state of the
2177 namelist to stdout. This is used to implement the non-standard query
2178 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2179 the names alone are printed. */
2182 nml_query (st_parameter_dt
*dtp
, char c
)
2184 gfc_unit
* temp_unit
;
2189 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2192 /* Store the current unit and transfer to stdout. */
2194 temp_unit
= dtp
->u
.p
.current_unit
;
2195 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2197 if (dtp
->u
.p
.current_unit
)
2199 dtp
->u
.p
.mode
= WRITING
;
2200 next_record (dtp
, 0);
2202 /* Write the namelist in its entirety. */
2205 namelist_write (dtp
);
2207 /* Or write the list of names. */
2211 /* "&namelist_name\n" */
2213 len
= dtp
->namelist_name_len
;
2215 p
= write_block (dtp
, len
+ 3);
2217 p
= write_block (dtp
, len
+ 2);
2222 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2224 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2226 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2228 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2232 len
= strlen (nl
->var_name
);
2234 p
= write_block (dtp
, len
+ 3);
2236 p
= write_block (dtp
, len
+ 2);
2241 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2243 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2245 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2252 p
= write_block (dtp
, 6);
2254 p
= write_block (dtp
, 5);
2259 memcpy (p
, "&end\r\n", 6);
2261 memcpy (p
, "&end\n", 5);
2265 /* Flush the stream to force immediate output. */
2267 flush (dtp
->u
.p
.current_unit
->s
);
2268 unlock_unit (dtp
->u
.p
.current_unit
);
2273 /* Restore the current unit. */
2275 dtp
->u
.p
.current_unit
= temp_unit
;
2276 dtp
->u
.p
.mode
= READING
;
2280 /* Reads and stores the input for the namelist object nl. For an array,
2281 the function loops over the ranges defined by the loop specification.
2282 This default to all the data or to the specification from a qualifier.
2283 nml_read_obj recursively calls itself to read derived types. It visits
2284 all its own components but only reads data for those that were touched
2285 when the name was parsed. If a read error is encountered, an attempt is
2286 made to return to read a new object name because the standard allows too
2287 little data to be available. On the other hand, too much data is an
2291 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2292 namelist_info
**pprev_nl
, char *nml_err_msg
,
2293 index_type clow
, index_type chigh
)
2295 namelist_info
* cmp
;
2302 index_type obj_name_len
;
2305 /* This object not touched in name parsing. */
2310 dtp
->u
.p
.repeat_count
= 0;
2316 case GFC_DTYPE_INTEGER
:
2317 case GFC_DTYPE_LOGICAL
:
2321 case GFC_DTYPE_REAL
:
2322 dlen
= size_from_real_kind (len
);
2325 case GFC_DTYPE_COMPLEX
:
2326 dlen
= size_from_complex_kind (len
);
2329 case GFC_DTYPE_CHARACTER
:
2330 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2339 /* Update the pointer to the data, using the current index vector */
2341 pdata
= (void*)(nl
->mem_pos
+ offset
);
2342 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2343 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2344 nl
->dim
[dim
].stride
* nl
->size
);
2346 /* Reset the error flag and try to read next value, if
2347 dtp->u.p.repeat_count=0 */
2349 dtp
->u
.p
.nml_read_error
= 0;
2351 if (--dtp
->u
.p
.repeat_count
<= 0)
2353 if (dtp
->u
.p
.input_complete
)
2355 if (dtp
->u
.p
.at_eol
)
2356 finish_separator (dtp
);
2357 if (dtp
->u
.p
.input_complete
)
2360 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2361 after the switch block. */
2363 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2368 case GFC_DTYPE_INTEGER
:
2369 read_integer (dtp
, len
);
2372 case GFC_DTYPE_LOGICAL
:
2373 read_logical (dtp
, len
);
2376 case GFC_DTYPE_CHARACTER
:
2377 read_character (dtp
, len
);
2380 case GFC_DTYPE_REAL
:
2381 read_real (dtp
, len
);
2384 case GFC_DTYPE_COMPLEX
:
2385 read_complex (dtp
, len
, dlen
);
2388 case GFC_DTYPE_DERIVED
:
2389 obj_name_len
= strlen (nl
->var_name
) + 1;
2390 obj_name
= get_mem (obj_name_len
+1);
2391 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2392 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2394 /* If reading a derived type, disable the expanded read warning
2395 since a single object can have multiple reads. */
2396 dtp
->u
.p
.expanded_read
= 0;
2398 /* Now loop over the components. Update the component pointer
2399 with the return value from nml_write_obj. This loop jumps
2400 past nested derived types by testing if the potential
2401 component name contains '%'. */
2403 for (cmp
= nl
->next
;
2405 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2406 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2410 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2411 pprev_nl
, nml_err_msg
, clow
, chigh
)
2414 free_mem (obj_name
);
2418 if (dtp
->u
.p
.input_complete
)
2420 free_mem (obj_name
);
2425 free_mem (obj_name
);
2429 sprintf (nml_err_msg
, "Bad type for namelist object %s",
2431 internal_error (&dtp
->common
, nml_err_msg
);
2436 /* The standard permits array data to stop short of the number of
2437 elements specified in the loop specification. In this case, we
2438 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2439 nml_get_obj_data and an attempt is made to read object name. */
2442 if (dtp
->u
.p
.nml_read_error
)
2444 dtp
->u
.p
.expanded_read
= 0;
2448 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2450 dtp
->u
.p
.expanded_read
= 0;
2454 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2455 This comes about because the read functions return BT_types. */
2457 switch (dtp
->u
.p
.saved_type
)
2464 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2468 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2469 pdata
= (void*)( pdata
+ clow
- 1 );
2470 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2472 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2479 /* Warn if a non-standard expanded read occurs. A single read of a
2480 single object is acceptable. If a second read occurs, issue a warning
2481 and set the flag to zero to prevent further warnings. */
2482 if (dtp
->u
.p
.expanded_read
== 2)
2484 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2485 dtp
->u
.p
.expanded_read
= 0;
2488 /* If the expanded read warning flag is set, increment it,
2489 indicating that a single read has occurred. */
2490 if (dtp
->u
.p
.expanded_read
>= 1)
2491 dtp
->u
.p
.expanded_read
++;
2493 /* Break out of loop if scalar. */
2497 /* Now increment the index vector. */
2502 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2504 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2506 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2508 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2510 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2514 } while (!nml_carry
);
2516 if (dtp
->u
.p
.repeat_count
> 1)
2518 sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2529 /* Parses the object name, including array and substring qualifiers. It
2530 iterates over derived type components, touching those components and
2531 setting their loop specifications, if there is a qualifier. If the
2532 object is itself a derived type, its components and subcomponents are
2533 touched. nml_read_obj is called at the end and this reads the data in
2534 the manner specified by the object name. */
2537 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2542 namelist_info
* first_nl
= NULL
;
2543 namelist_info
* root_nl
= NULL
;
2544 int dim
, parsed_rank
;
2546 char parse_err_msg
[30];
2547 index_type clow
, chigh
;
2548 int non_zero_rank_count
;
2550 /* Look for end of input or object name. If '?' or '=?' are encountered
2551 in stdin, print the node names or the namelist to stdout. */
2553 eat_separator (dtp
);
2554 if (dtp
->u
.p
.input_complete
)
2557 if (dtp
->u
.p
.at_eol
)
2558 finish_separator (dtp
);
2559 if (dtp
->u
.p
.input_complete
)
2562 c
= next_char (dtp
);
2566 c
= next_char (dtp
);
2569 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2572 nml_query (dtp
, '=');
2576 nml_query (dtp
, '?');
2581 nml_match_name (dtp
, "end", 3);
2582 if (dtp
->u
.p
.nml_read_error
)
2584 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2588 dtp
->u
.p
.input_complete
= 1;
2595 /* Untouch all nodes of the namelist and reset the flag that is set for
2596 derived type components. */
2598 nml_untouch_nodes (dtp
);
2600 non_zero_rank_count
= 0;
2602 /* Get the object name - should '!' and '\n' be permitted separators? */
2610 if (!is_separator (c
))
2611 push_char (dtp
, tolower(c
));
2612 c
= next_char (dtp
);
2613 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2615 unget_char (dtp
, c
);
2617 /* Check that the name is in the namelist and get pointer to object.
2618 Three error conditions exist: (i) An attempt is being made to
2619 identify a non-existent object, following a failed data read or
2620 (ii) The object name does not exist or (iii) Too many data items
2621 are present for an object. (iii) gives the same error message
2624 push_char (dtp
, '\0');
2628 size_t var_len
= strlen (root_nl
->var_name
);
2630 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2631 char ext_name
[var_len
+ saved_len
+ 1];
2633 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2634 if (dtp
->u
.p
.saved_string
)
2635 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2636 ext_name
[var_len
+ saved_len
] = '\0';
2637 nl
= find_nml_node (dtp
, ext_name
);
2640 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2644 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2645 sprintf (nml_err_msg
, "Bad data for namelist object %s",
2646 (*pprev_nl
)->var_name
);
2649 sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2650 dtp
->u
.p
.saved_string
);
2655 /* Get the length, data length, base pointer and rank of the variable.
2656 Set the default loop specification first. */
2658 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2660 nl
->ls
[dim
].step
= 1;
2661 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2662 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2663 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2666 /* Check to see if there is a qualifier: if so, parse it.*/
2668 if (c
== '(' && nl
->var_rank
)
2671 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2672 parse_err_msg
, &parsed_rank
) == FAILURE
)
2674 sprintf (nml_err_msg
, "%s for namelist variable %s",
2675 parse_err_msg
, nl
->var_name
);
2679 if (parsed_rank
> 0)
2680 non_zero_rank_count
++;
2682 c
= next_char (dtp
);
2683 unget_char (dtp
, c
);
2685 else if (nl
->var_rank
> 0)
2686 non_zero_rank_count
++;
2688 /* Now parse a derived type component. The root namelist_info address
2689 is backed up, as is the previous component level. The component flag
2690 is set and the iteration is made by jumping back to get_name. */
2694 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2696 sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2701 if (!component_flag
)
2706 c
= next_char (dtp
);
2710 /* Parse a character qualifier, if present. chigh = 0 is a default
2711 that signals that the string length = string_length. */
2716 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2718 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2719 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2721 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, parse_err_msg
, &parsed_rank
)
2724 sprintf (nml_err_msg
, "%s for namelist variable %s",
2725 parse_err_msg
, nl
->var_name
);
2729 clow
= ind
[0].start
;
2732 if (ind
[0].step
!= 1)
2734 sprintf (nml_err_msg
,
2735 "Step not allowed in substring qualifier"
2736 " for namelist object %s", nl
->var_name
);
2740 c
= next_char (dtp
);
2741 unget_char (dtp
, c
);
2744 /* If a derived type touch its components and restore the root
2745 namelist_info if we have parsed a qualified derived type
2748 if (nl
->type
== GFC_DTYPE_DERIVED
)
2749 nml_touch_nodes (nl
);
2753 /* Make sure no extraneous qualifiers are there. */
2757 sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2758 " namelist object %s", nl
->var_name
);
2762 /* Make sure there is no more than one non-zero rank object. */
2763 if (non_zero_rank_count
> 1)
2765 sprintf (nml_err_msg
, "Multiple sub-objects with non-zero rank in"
2766 " namelist object %s", nl
->var_name
);
2767 non_zero_rank_count
= 0;
2771 /* According to the standard, an equal sign MUST follow an object name. The
2772 following is possibly lax - it allows comments, blank lines and so on to
2773 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2777 eat_separator (dtp
);
2778 if (dtp
->u
.p
.input_complete
)
2781 if (dtp
->u
.p
.at_eol
)
2782 finish_separator (dtp
);
2783 if (dtp
->u
.p
.input_complete
)
2786 c
= next_char (dtp
);
2790 sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2795 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2805 /* Entry point for namelist input. Goes through input until namelist name
2806 is matched. Then cycles through nml_get_obj_data until the input is
2807 completed or there is an error. */
2810 namelist_read (st_parameter_dt
*dtp
)
2814 char nml_err_msg
[100];
2815 /* Pointer to the previously read object, in case attempt is made to read
2816 new object name. Should this fail, error message can give previous
2818 namelist_info
*prev_nl
= NULL
;
2820 dtp
->u
.p
.namelist_mode
= 1;
2821 dtp
->u
.p
.input_complete
= 0;
2822 dtp
->u
.p
.expanded_read
= 0;
2824 dtp
->u
.p
.eof_jump
= &eof_jump
;
2825 if (setjmp (eof_jump
))
2827 dtp
->u
.p
.eof_jump
= NULL
;
2828 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2832 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2833 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2834 node names or namelist on stdout. */
2837 switch (c
= next_char (dtp
))
2848 c
= next_char (dtp
);
2850 nml_query (dtp
, '=');
2852 unget_char (dtp
, c
);
2856 nml_query (dtp
, '?');
2862 /* Match the name of the namelist. */
2864 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2866 if (dtp
->u
.p
.nml_read_error
)
2869 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2870 c
= next_char (dtp
);
2871 if (!is_separator(c
))
2873 unget_char (dtp
, c
);
2877 /* Ready to read namelist objects. If there is an error in input
2878 from stdin, output the error message and continue. */
2880 while (!dtp
->u
.p
.input_complete
)
2882 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2886 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2889 u
= find_unit (options
.stderr_unit
);
2890 st_printf ("%s\n", nml_err_msg
);
2900 dtp
->u
.p
.eof_jump
= NULL
;
2905 /* All namelist error calls return from here */
2909 dtp
->u
.p
.eof_jump
= NULL
;
2912 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);