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 dtp
->u
.p
.item_count
= 0;
124 dtp
->u
.p
.line_buffer_enabled
= 0;
126 if (dtp
->u
.p
.line_buffer
== NULL
)
129 free_mem (dtp
->u
.p
.line_buffer
);
130 dtp
->u
.p
.line_buffer
= NULL
;
135 next_char (st_parameter_dt
*dtp
)
141 if (dtp
->u
.p
.last_char
!= '\0')
144 c
= dtp
->u
.p
.last_char
;
145 dtp
->u
.p
.last_char
= '\0';
149 /* Read from line_buffer if enabled. */
151 if (dtp
->u
.p
.line_buffer_enabled
)
155 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
156 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
158 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
159 dtp
->u
.p
.item_count
++;
163 dtp
->u
.p
.item_count
= 0;
164 dtp
->u
.p
.line_buffer_enabled
= 0;
167 /* Handle the end-of-record and end-of-file conditions for
168 internal array unit. */
169 if (is_array_io (dtp
))
172 longjmp (*dtp
->u
.p
.eof_jump
, 1);
174 /* Check for "end-of-record" condition. */
175 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
180 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
183 /* Check for "end-of-file" condition. */
190 record
*= dtp
->u
.p
.current_unit
->recl
;
191 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
192 longjmp (*dtp
->u
.p
.eof_jump
, 1);
194 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
199 /* Get the next character and handle end-of-record conditions. */
203 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
205 if (is_stream_io (dtp
))
206 dtp
->u
.p
.current_unit
->strm_pos
++;
208 if (is_internal_unit (dtp
))
210 if (is_array_io (dtp
))
212 /* End of record is handled in the next pass through, above. The
213 check for NULL here is cautionary. */
216 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
220 dtp
->u
.p
.current_unit
->bytes_left
--;
226 longjmp (*dtp
->u
.p
.eof_jump
, 1);
237 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
242 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
244 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
245 longjmp (*dtp
->u
.p
.eof_jump
, 1);
246 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
250 longjmp (*dtp
->u
.p
.eof_jump
, 1);
256 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
261 /* Push a character back onto the input. */
264 unget_char (st_parameter_dt
*dtp
, char c
)
266 dtp
->u
.p
.last_char
= c
;
270 /* Skip over spaces in the input. Returns the nonspace character that
271 terminated the eating and also places it back on the input. */
274 eat_spaces (st_parameter_dt
*dtp
)
282 while (c
== ' ' || c
== '\t');
289 /* This function reads characters through to the end of the current line and
290 just ignores them. */
293 eat_line (st_parameter_dt
*dtp
)
296 if (!is_internal_unit (dtp
))
303 /* Skip over a separator. Technically, we don't always eat the whole
304 separator. This is because if we've processed the last input item,
305 then a separator is unnecessary. Plus the fact that operating
306 systems usually deliver console input on a line basis.
308 The upshot is that if we see a newline as part of reading a
309 separator, we stop reading. If there are more input items, we
310 continue reading the separator with finish_separator() which takes
311 care of the fact that we may or may not have seen a comma as part
315 eat_separator (st_parameter_dt
*dtp
)
320 dtp
->u
.p
.comma_flag
= 0;
326 dtp
->u
.p
.comma_flag
= 1;
331 dtp
->u
.p
.input_complete
= 1;
339 if (dtp
->u
.p
.namelist_mode
)
343 while (c
== '\n' || c
== '\r' || c
== ' ');
353 if (dtp
->u
.p
.namelist_mode
)
369 while (c
== '\n' || c
== '\r' || c
== ' ');
375 if (dtp
->u
.p
.namelist_mode
)
376 { /* Eat a namelist comment. */
384 /* Fall Through... */
393 /* Finish processing a separator that was interrupted by a newline.
394 If we're here, then another data item is present, so we finish what
395 we started on the previous line. */
398 finish_separator (st_parameter_dt
*dtp
)
409 if (dtp
->u
.p
.comma_flag
)
413 c
= eat_spaces (dtp
);
414 if (c
== '\n' || c
== '\r')
421 dtp
->u
.p
.input_complete
= 1;
422 if (!dtp
->u
.p
.namelist_mode
)
431 if (dtp
->u
.p
.namelist_mode
)
447 /* This function is needed to catch bad conversions so that namelist can
448 attempt to see if dtp->u.p.saved_string contains a new object name rather
452 nml_bad_return (st_parameter_dt
*dtp
, char c
)
454 if (dtp
->u
.p
.namelist_mode
)
456 dtp
->u
.p
.nml_read_error
= 1;
463 /* Convert an unsigned string to an integer. The length value is -1
464 if we are working on a repeat count. Returns nonzero if we have a
465 range problem. As a side effect, frees the dtp->u.p.saved_string. */
468 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
470 char c
, *buffer
, message
[100];
472 GFC_INTEGER_LARGEST v
, max
, max10
;
474 buffer
= dtp
->u
.p
.saved_string
;
477 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
502 set_integer (dtp
->u
.p
.value
, v
, length
);
506 dtp
->u
.p
.repeat_count
= v
;
508 if (dtp
->u
.p
.repeat_count
== 0)
510 sprintf (message
, "Zero repeat count in item %d of list input",
511 dtp
->u
.p
.item_count
);
513 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
523 sprintf (message
, "Repeat count overflow in item %d of list input",
524 dtp
->u
.p
.item_count
);
526 sprintf (message
, "Integer overflow while reading item %d",
527 dtp
->u
.p
.item_count
);
530 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
536 /* Parse a repeat count for logical and complex values which cannot
537 begin with a digit. Returns nonzero if we are done, zero if we
538 should continue on. */
541 parse_repeat (st_parameter_dt
*dtp
)
543 char c
, message
[100];
569 repeat
= 10 * repeat
+ c
- '0';
571 if (repeat
> MAX_REPEAT
)
574 "Repeat count overflow in item %d of list input",
575 dtp
->u
.p
.item_count
);
577 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
587 "Zero repeat count in item %d of list input",
588 dtp
->u
.p
.item_count
);
590 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
602 dtp
->u
.p
.repeat_count
= repeat
;
609 sprintf (message
, "Bad repeat count in item %d of list input",
610 dtp
->u
.p
.item_count
);
611 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
616 /* To read a logical we have to look ahead in the input stream to make sure
617 there is not an equal sign indicating a variable name. To do this we use
618 line_buffer to point to a temporary buffer, pushing characters there for
619 possible later reading. */
622 l_push_char (st_parameter_dt
*dtp
, char c
)
624 if (dtp
->u
.p
.line_buffer
== NULL
)
626 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
627 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
630 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
634 /* Read a logical character on the input. */
637 read_logical (st_parameter_dt
*dtp
, int length
)
639 char c
, message
[100];
642 if (parse_repeat (dtp
))
645 c
= tolower (next_char (dtp
));
646 l_push_char (dtp
, c
);
652 l_push_char (dtp
, c
);
654 if (!is_separator(c
))
662 l_push_char (dtp
, c
);
664 if (!is_separator(c
))
670 c
= tolower (next_char (dtp
));
688 return; /* Null value. */
691 /* Save the character in case it is the beginning
692 of the next object name. */
697 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
698 dtp
->u
.p
.saved_length
= length
;
700 /* Eat trailing garbage. */
705 while (!is_separator (c
));
709 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
716 for(i
= 0; i
< 63; i
++)
721 /* All done if this is not a namelist read. */
722 if (!dtp
->u
.p
.namelist_mode
)
735 l_push_char (dtp
, c
);
738 dtp
->u
.p
.nml_read_error
= 1;
739 dtp
->u
.p
.line_buffer_enabled
= 1;
740 dtp
->u
.p
.item_count
= 0;
750 if (nml_bad_return (dtp
, c
))
755 sprintf (message
, "Bad logical value while reading item %d",
756 dtp
->u
.p
.item_count
);
757 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
762 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
763 dtp
->u
.p
.saved_length
= length
;
764 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
770 /* Reading integers is tricky because we can actually be reading a
771 repeat count. We have to store the characters in a buffer because
772 we could be reading an integer that is larger than the default int
773 used for repeat counts. */
776 read_integer (st_parameter_dt
*dtp
, int length
)
778 char c
, message
[100];
788 /* Fall through... */
794 CASE_SEPARATORS
: /* Single null. */
807 /* Take care of what may be a repeat count. */
819 push_char (dtp
, '\0');
822 CASE_SEPARATORS
: /* Not a repeat count. */
831 if (convert_integer (dtp
, -1, 0))
834 /* Get the real integer. */
849 /* Fall through... */
880 if (nml_bad_return (dtp
, c
))
885 sprintf (message
, "Bad integer for item %d in list input",
886 dtp
->u
.p
.item_count
);
887 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
895 push_char (dtp
, '\0');
896 if (convert_integer (dtp
, length
, negative
))
903 dtp
->u
.p
.saved_type
= BT_INTEGER
;
907 /* Read a character variable. */
910 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
912 char c
, quote
, message
[100];
914 quote
= ' '; /* Space means no quote character. */
924 unget_char (dtp
, c
); /* NULL value. */
934 if (dtp
->u
.p
.namelist_mode
)
936 if (dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_APOSTROPHE
937 || dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_QUOTE
938 || c
== '&' || c
== '$' || c
== '/')
944 /* Check to see if we are seeing a namelist object name by using the
945 line buffer and looking ahead for an '=' or '('. */
946 l_push_char (dtp
, c
);
949 for(i
= 0; i
< 63; i
++)
959 l_push_char (dtp
, c
);
960 dtp
->u
.p
.item_count
= 0;
961 dtp
->u
.p
.line_buffer_enabled
= 1;
966 l_push_char (dtp
, c
);
968 if (c
== '=' || c
== '(')
970 dtp
->u
.p
.item_count
= 0;
971 dtp
->u
.p
.nml_read_error
= 1;
972 dtp
->u
.p
.line_buffer_enabled
= 1;
977 /* The string is too long to be a valid object name so assume that it
978 is a string to be read in as a value. */
979 dtp
->u
.p
.item_count
= 0;
980 dtp
->u
.p
.line_buffer_enabled
= 1;
988 /* Deal with a possible repeat count. */
1000 unget_char (dtp
, c
);
1001 goto done
; /* String was only digits! */
1004 push_char (dtp
, '\0');
1009 goto get_string
; /* Not a repeat count after all. */
1014 if (convert_integer (dtp
, -1, 0))
1017 /* Now get the real string. */
1019 c
= next_char (dtp
);
1023 unget_char (dtp
, c
); /* Repeated NULL values. */
1024 eat_separator (dtp
);
1040 c
= next_char (dtp
);
1051 /* See if we have a doubled quote character or the end of
1054 c
= next_char (dtp
);
1057 push_char (dtp
, quote
);
1061 unget_char (dtp
, c
);
1067 unget_char (dtp
, c
);
1071 if (c
!= '\n' && c
!= '\r')
1081 /* At this point, we have to have a separator, or else the string is
1084 c
= next_char (dtp
);
1085 if (is_separator (c
))
1087 unget_char (dtp
, c
);
1088 eat_separator (dtp
);
1089 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1095 sprintf (message
, "Invalid string input in item %d",
1096 dtp
->u
.p
.item_count
);
1097 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1102 /* Parse a component of a complex constant or a real number that we
1103 are sure is already there. This is a straight real number parser. */
1106 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1108 char c
, message
[100];
1111 c
= next_char (dtp
);
1112 if (c
== '-' || c
== '+')
1115 c
= next_char (dtp
);
1118 if (!isdigit (c
) && c
!= '.')
1120 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1128 seen_dp
= (c
== '.') ? 1 : 0;
1132 c
= next_char (dtp
);
1151 push_char (dtp
, 'e');
1156 push_char (dtp
, 'e');
1158 c
= next_char (dtp
);
1162 unget_char (dtp
, c
);
1171 c
= next_char (dtp
);
1172 if (c
!= '-' && c
!= '+')
1173 push_char (dtp
, '+');
1177 c
= next_char (dtp
);
1188 c
= next_char (dtp
);
1196 unget_char (dtp
, c
);
1205 unget_char (dtp
, c
);
1206 push_char (dtp
, '\0');
1208 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1214 /* Match INF and Infinity. */
1215 if ((c
== 'i' || c
== 'I')
1216 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1217 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1219 c
= next_char (dtp
);
1220 if ((c
!= 'i' && c
!= 'I')
1221 || ((c
== 'i' || c
== 'I')
1222 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1223 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1224 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1225 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1226 && (c
= next_char (dtp
))))
1228 if (is_separator (c
))
1229 unget_char (dtp
, c
);
1230 push_char (dtp
, 'i');
1231 push_char (dtp
, 'n');
1232 push_char (dtp
, 'f');
1236 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1237 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1238 && (c
= next_char (dtp
)))
1240 if (is_separator (c
))
1241 unget_char (dtp
, c
);
1242 push_char (dtp
, 'n');
1243 push_char (dtp
, 'a');
1244 push_char (dtp
, 'n');
1250 if (nml_bad_return (dtp
, c
))
1255 sprintf (message
, "Bad floating point number for item %d",
1256 dtp
->u
.p
.item_count
);
1257 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1263 /* Reading a complex number is straightforward because we can tell
1264 what it is right away. */
1267 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1272 if (parse_repeat (dtp
))
1275 c
= next_char (dtp
);
1282 unget_char (dtp
, c
);
1283 eat_separator (dtp
);
1291 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1296 c
= next_char (dtp
);
1297 if (c
== '\n' || c
== '\r')
1300 unget_char (dtp
, c
);
1302 if (next_char (dtp
) != ',')
1307 c
= next_char (dtp
);
1308 if (c
== '\n' || c
== '\r')
1311 unget_char (dtp
, c
);
1313 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1317 if (next_char (dtp
) != ')')
1320 c
= next_char (dtp
);
1321 if (!is_separator (c
))
1324 unget_char (dtp
, c
);
1325 eat_separator (dtp
);
1328 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1333 if (nml_bad_return (dtp
, c
))
1338 sprintf (message
, "Bad complex value in item %d of list input",
1339 dtp
->u
.p
.item_count
);
1340 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1344 /* Parse a real number with a possible repeat count. */
1347 read_real (st_parameter_dt
*dtp
, int length
)
1349 char c
, message
[100];
1355 c
= next_char (dtp
);
1372 unget_char (dtp
, c
); /* Single null. */
1373 eat_separator (dtp
);
1386 /* Get the digit string that might be a repeat count. */
1390 c
= next_char (dtp
);
1413 push_char (dtp
, 'e');
1415 c
= next_char (dtp
);
1419 push_char (dtp
, '\0');
1423 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1424 unget_char (dtp
, c
);
1433 if (convert_integer (dtp
, -1, 0))
1436 /* Now get the number itself. */
1438 c
= next_char (dtp
);
1439 if (is_separator (c
))
1440 { /* Repeated null value. */
1441 unget_char (dtp
, c
);
1442 eat_separator (dtp
);
1446 if (c
!= '-' && c
!= '+')
1447 push_char (dtp
, '+');
1452 c
= next_char (dtp
);
1455 if (!isdigit (c
) && c
!= '.')
1457 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1476 c
= next_char (dtp
);
1502 push_char (dtp
, 'e');
1504 c
= next_char (dtp
);
1513 push_char (dtp
, 'e');
1515 c
= next_char (dtp
);
1516 if (c
!= '+' && c
!= '-')
1517 push_char (dtp
, '+');
1521 c
= next_char (dtp
);
1531 c
= next_char (dtp
);
1548 unget_char (dtp
, c
);
1549 eat_separator (dtp
);
1550 push_char (dtp
, '\0');
1551 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1555 dtp
->u
.p
.saved_type
= BT_REAL
;
1559 l_push_char (dtp
, c
);
1562 /* Match INF and Infinity. */
1563 if (c
== 'i' || c
== 'I')
1565 c
= next_char (dtp
);
1566 l_push_char (dtp
, c
);
1567 if (c
!= 'n' && c
!= 'N')
1569 c
= next_char (dtp
);
1570 l_push_char (dtp
, c
);
1571 if (c
!= 'f' && c
!= 'F')
1573 c
= next_char (dtp
);
1574 l_push_char (dtp
, c
);
1575 if (!is_separator (c
))
1577 if (c
!= 'i' && c
!= 'I')
1579 c
= next_char (dtp
);
1580 l_push_char (dtp
, c
);
1581 if (c
!= 'n' && c
!= 'N')
1583 c
= next_char (dtp
);
1584 l_push_char (dtp
, c
);
1585 if (c
!= 'i' && c
!= 'I')
1587 c
= next_char (dtp
);
1588 l_push_char (dtp
, c
);
1589 if (c
!= 't' && c
!= 'T')
1591 c
= next_char (dtp
);
1592 l_push_char (dtp
, c
);
1593 if (c
!= 'y' && c
!= 'Y')
1595 c
= next_char (dtp
);
1596 l_push_char (dtp
, c
);
1602 c
= next_char (dtp
);
1603 l_push_char (dtp
, c
);
1604 if (c
!= 'a' && c
!= 'A')
1606 c
= next_char (dtp
);
1607 l_push_char (dtp
, c
);
1608 if (c
!= 'n' && c
!= 'N')
1610 c
= next_char (dtp
);
1611 l_push_char (dtp
, c
);
1614 if (!is_separator (c
))
1617 if (dtp
->u
.p
.namelist_mode
)
1619 if (c
== ' ' || c
=='\n' || c
== '\r')
1622 c
= next_char (dtp
);
1623 while (c
== ' ' || c
=='\n' || c
== '\r');
1625 l_push_char (dtp
, c
);
1634 push_char (dtp
, 'i');
1635 push_char (dtp
, 'n');
1636 push_char (dtp
, 'f');
1640 push_char (dtp
, 'n');
1641 push_char (dtp
, 'a');
1642 push_char (dtp
, 'n');
1649 if (dtp
->u
.p
.namelist_mode
)
1651 dtp
->u
.p
.nml_read_error
= 1;
1652 dtp
->u
.p
.line_buffer_enabled
= 1;
1653 dtp
->u
.p
.item_count
= 0;
1659 if (nml_bad_return (dtp
, c
))
1664 sprintf (message
, "Bad real number in item %d of list input",
1665 dtp
->u
.p
.item_count
);
1666 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1670 /* Check the current type against the saved type to make sure they are
1671 compatible. Returns nonzero if incompatible. */
1674 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1678 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1680 sprintf (message
, "Read type %s where %s was expected for item %d",
1681 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1682 dtp
->u
.p
.item_count
);
1684 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1688 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1691 if (dtp
->u
.p
.saved_length
!= len
)
1694 "Read kind %d %s where kind %d is required for item %d",
1695 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1696 dtp
->u
.p
.item_count
);
1697 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1705 /* Top level data transfer subroutine for list reads. Because we have
1706 to deal with repeat counts, the data item is always saved after
1707 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1708 greater than one, we copy the data item multiple times. */
1711 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1718 dtp
->u
.p
.namelist_mode
= 0;
1720 dtp
->u
.p
.eof_jump
= &eof_jump
;
1721 if (setjmp (eof_jump
))
1723 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1727 if (dtp
->u
.p
.first_item
)
1729 dtp
->u
.p
.first_item
= 0;
1730 dtp
->u
.p
.input_complete
= 0;
1731 dtp
->u
.p
.repeat_count
= 1;
1732 dtp
->u
.p
.at_eol
= 0;
1734 c
= eat_spaces (dtp
);
1735 if (is_separator (c
))
1737 /* Found a null value. */
1738 eat_separator (dtp
);
1739 dtp
->u
.p
.repeat_count
= 0;
1741 /* eat_separator sets this flag if the separator was a comma. */
1742 if (dtp
->u
.p
.comma_flag
)
1745 /* eat_separator sets this flag if the separator was a \n or \r. */
1746 if (dtp
->u
.p
.at_eol
)
1747 finish_separator (dtp
);
1755 if (dtp
->u
.p
.input_complete
)
1758 if (dtp
->u
.p
.repeat_count
> 0)
1760 if (check_type (dtp
, type
, kind
))
1765 if (dtp
->u
.p
.at_eol
)
1766 finish_separator (dtp
);
1770 /* Trailing spaces prior to end of line. */
1771 if (dtp
->u
.p
.at_eol
)
1772 finish_separator (dtp
);
1775 dtp
->u
.p
.saved_type
= BT_NULL
;
1776 dtp
->u
.p
.repeat_count
= 1;
1782 read_integer (dtp
, kind
);
1785 read_logical (dtp
, kind
);
1788 read_character (dtp
, kind
);
1791 read_real (dtp
, kind
);
1794 read_complex (dtp
, kind
, size
);
1797 internal_error (&dtp
->common
, "Bad type for list read");
1800 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1801 dtp
->u
.p
.saved_length
= size
;
1803 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1807 switch (dtp
->u
.p
.saved_type
)
1813 memcpy (p
, dtp
->u
.p
.value
, size
);
1817 if (dtp
->u
.p
.saved_string
)
1819 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1820 ? (int) size
: dtp
->u
.p
.saved_used
;
1821 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1824 /* Just delimiters encountered, nothing to copy but SPACE. */
1828 memset (((char *) p
) + m
, ' ', size
- m
);
1835 if (--dtp
->u
.p
.repeat_count
<= 0)
1839 dtp
->u
.p
.eof_jump
= NULL
;
1844 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1845 size_t size
, size_t nelems
)
1852 /* Big loop over all the elements. */
1853 for (elem
= 0; elem
< nelems
; elem
++)
1855 dtp
->u
.p
.item_count
++;
1856 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1861 /* Finish a list read. */
1864 finish_list_read (st_parameter_dt
*dtp
)
1870 if (dtp
->u
.p
.at_eol
)
1872 dtp
->u
.p
.at_eol
= 0;
1878 c
= next_char (dtp
);
1885 void namelist_read (st_parameter_dt *dtp)
1887 static void nml_match_name (char *name, int len)
1888 static int nml_query (st_parameter_dt *dtp)
1889 static int nml_get_obj_data (st_parameter_dt *dtp,
1890 namelist_info **prev_nl, char *)
1892 static void nml_untouch_nodes (st_parameter_dt *dtp)
1893 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1895 static int nml_parse_qualifier(descriptor_dimension * ad,
1896 array_loop_spec * ls, int rank, char *)
1897 static void nml_touch_nodes (namelist_info * nl)
1898 static int nml_read_obj (namelist_info *nl, index_type offset,
1899 namelist_info **prev_nl, char *,
1900 index_type clow, index_type chigh)
1904 /* Inputs a rank-dimensional qualifier, which can contain
1905 singlets, doublets, triplets or ':' with the standard meanings. */
1908 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1909 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1916 int is_array_section
, is_char
;
1920 is_array_section
= 0;
1921 dtp
->u
.p
.expanded_read
= 0;
1923 /* See if this is a character substring qualifier we are looking for. */
1930 /* The next character in the stream should be the '('. */
1932 c
= next_char (dtp
);
1934 /* Process the qualifier, by dimension and triplet. */
1936 for (dim
=0; dim
< rank
; dim
++ )
1938 for (indx
=0; indx
<3; indx
++)
1944 /* Process a potential sign. */
1945 c
= next_char (dtp
);
1956 unget_char (dtp
, c
);
1960 /* Process characters up to the next ':' , ',' or ')'. */
1963 c
= next_char (dtp
);
1968 is_array_section
= 1;
1972 if ((c
==',' && dim
== rank
-1)
1973 || (c
==')' && dim
< rank
-1))
1976 sprintf (parse_err_msg
, "Bad substring qualifier");
1978 sprintf (parse_err_msg
, "Bad number of index fields");
1987 case ' ': case '\t':
1989 c
= next_char (dtp
);
1994 sprintf (parse_err_msg
,
1995 "Bad character in substring qualifier");
1997 sprintf (parse_err_msg
, "Bad character in index");
2001 if ((c
== ',' || c
== ')') && indx
== 0
2002 && dtp
->u
.p
.saved_string
== 0)
2005 sprintf (parse_err_msg
, "Null substring qualifier");
2007 sprintf (parse_err_msg
, "Null index field");
2011 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2012 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2015 sprintf (parse_err_msg
, "Bad substring qualifier");
2017 sprintf (parse_err_msg
, "Bad index triplet");
2021 if (is_char
&& !is_array_section
)
2023 sprintf (parse_err_msg
,
2024 "Missing colon in substring qualifier");
2028 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2030 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2031 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2037 /* Now read the index. */
2038 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2041 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2043 sprintf (parse_err_msg
, "Bad integer in index");
2049 /* Feed the index values to the triplet arrays. */
2053 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2055 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2057 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2060 /* Singlet or doublet indices. */
2061 if (c
==',' || c
==')')
2065 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2067 /* If -std=f95/2003 or an array section is specified,
2068 do not allow excess data to be processed. */
2069 if (is_array_section
== 1
2070 || compile_options
.allow_std
< GFC_STD_GNU
)
2071 ls
[dim
].end
= ls
[dim
].start
;
2073 dtp
->u
.p
.expanded_read
= 1;
2076 /* Check for non-zero rank. */
2077 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2084 /* Check the values of the triplet indices. */
2085 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2086 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2087 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2088 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2091 sprintf (parse_err_msg
, "Substring out of range");
2093 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2097 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2098 || (ls
[dim
].step
== 0))
2100 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2104 /* Initialise the loop index counter. */
2105 ls
[dim
].idx
= ls
[dim
].start
;
2115 static namelist_info
*
2116 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2118 namelist_info
* t
= dtp
->u
.p
.ionml
;
2121 if (strcmp (var_name
, t
->var_name
) == 0)
2131 /* Visits all the components of a derived type that have
2132 not explicitly been identified in the namelist input.
2133 touched is set and the loop specification initialised
2134 to default values */
2137 nml_touch_nodes (namelist_info
* nl
)
2139 index_type len
= strlen (nl
->var_name
) + 1;
2141 char * ext_name
= (char*)get_mem (len
+ 1);
2142 memcpy (ext_name
, nl
->var_name
, len
-1);
2143 memcpy (ext_name
+ len
- 1, "%", 2);
2144 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2146 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2149 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2151 nl
->ls
[dim
].step
= 1;
2152 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2153 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2154 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2160 free_mem (ext_name
);
2164 /* Resets touched for the entire list of nml_nodes, ready for a
2168 nml_untouch_nodes (st_parameter_dt
*dtp
)
2171 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2176 /* Attempts to input name to namelist name. Returns
2177 dtp->u.p.nml_read_error = 1 on no match. */
2180 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2184 dtp
->u
.p
.nml_read_error
= 0;
2185 for (i
= 0; i
< len
; i
++)
2187 c
= next_char (dtp
);
2188 if (tolower (c
) != tolower (name
[i
]))
2190 dtp
->u
.p
.nml_read_error
= 1;
2196 /* If the namelist read is from stdin, output the current state of the
2197 namelist to stdout. This is used to implement the non-standard query
2198 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2199 the names alone are printed. */
2202 nml_query (st_parameter_dt
*dtp
, char c
)
2204 gfc_unit
* temp_unit
;
2209 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2212 /* Store the current unit and transfer to stdout. */
2214 temp_unit
= dtp
->u
.p
.current_unit
;
2215 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2217 if (dtp
->u
.p
.current_unit
)
2219 dtp
->u
.p
.mode
= WRITING
;
2220 next_record (dtp
, 0);
2222 /* Write the namelist in its entirety. */
2225 namelist_write (dtp
);
2227 /* Or write the list of names. */
2231 /* "&namelist_name\n" */
2233 len
= dtp
->namelist_name_len
;
2235 p
= write_block (dtp
, len
+ 3);
2237 p
= write_block (dtp
, len
+ 2);
2242 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2244 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2246 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2248 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2252 len
= strlen (nl
->var_name
);
2254 p
= write_block (dtp
, len
+ 3);
2256 p
= write_block (dtp
, len
+ 2);
2261 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2263 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2265 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2272 p
= write_block (dtp
, 6);
2274 p
= write_block (dtp
, 5);
2279 memcpy (p
, "&end\r\n", 6);
2281 memcpy (p
, "&end\n", 5);
2285 /* Flush the stream to force immediate output. */
2287 flush (dtp
->u
.p
.current_unit
->s
);
2288 unlock_unit (dtp
->u
.p
.current_unit
);
2293 /* Restore the current unit. */
2295 dtp
->u
.p
.current_unit
= temp_unit
;
2296 dtp
->u
.p
.mode
= READING
;
2300 /* Reads and stores the input for the namelist object nl. For an array,
2301 the function loops over the ranges defined by the loop specification.
2302 This default to all the data or to the specification from a qualifier.
2303 nml_read_obj recursively calls itself to read derived types. It visits
2304 all its own components but only reads data for those that were touched
2305 when the name was parsed. If a read error is encountered, an attempt is
2306 made to return to read a new object name because the standard allows too
2307 little data to be available. On the other hand, too much data is an
2311 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2312 namelist_info
**pprev_nl
, char *nml_err_msg
,
2313 index_type clow
, index_type chigh
)
2315 namelist_info
* cmp
;
2322 index_type obj_name_len
;
2325 /* This object not touched in name parsing. */
2330 dtp
->u
.p
.repeat_count
= 0;
2336 case GFC_DTYPE_INTEGER
:
2337 case GFC_DTYPE_LOGICAL
:
2341 case GFC_DTYPE_REAL
:
2342 dlen
= size_from_real_kind (len
);
2345 case GFC_DTYPE_COMPLEX
:
2346 dlen
= size_from_complex_kind (len
);
2349 case GFC_DTYPE_CHARACTER
:
2350 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2359 /* Update the pointer to the data, using the current index vector */
2361 pdata
= (void*)(nl
->mem_pos
+ offset
);
2362 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2363 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2364 nl
->dim
[dim
].stride
* nl
->size
);
2366 /* Reset the error flag and try to read next value, if
2367 dtp->u.p.repeat_count=0 */
2369 dtp
->u
.p
.nml_read_error
= 0;
2371 if (--dtp
->u
.p
.repeat_count
<= 0)
2373 if (dtp
->u
.p
.input_complete
)
2375 if (dtp
->u
.p
.at_eol
)
2376 finish_separator (dtp
);
2377 if (dtp
->u
.p
.input_complete
)
2380 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2381 after the switch block. */
2383 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2388 case GFC_DTYPE_INTEGER
:
2389 read_integer (dtp
, len
);
2392 case GFC_DTYPE_LOGICAL
:
2393 read_logical (dtp
, len
);
2396 case GFC_DTYPE_CHARACTER
:
2397 read_character (dtp
, len
);
2400 case GFC_DTYPE_REAL
:
2401 read_real (dtp
, len
);
2404 case GFC_DTYPE_COMPLEX
:
2405 read_complex (dtp
, len
, dlen
);
2408 case GFC_DTYPE_DERIVED
:
2409 obj_name_len
= strlen (nl
->var_name
) + 1;
2410 obj_name
= get_mem (obj_name_len
+1);
2411 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2412 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2414 /* If reading a derived type, disable the expanded read warning
2415 since a single object can have multiple reads. */
2416 dtp
->u
.p
.expanded_read
= 0;
2418 /* Now loop over the components. Update the component pointer
2419 with the return value from nml_write_obj. This loop jumps
2420 past nested derived types by testing if the potential
2421 component name contains '%'. */
2423 for (cmp
= nl
->next
;
2425 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2426 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2430 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2431 pprev_nl
, nml_err_msg
, clow
, chigh
)
2434 free_mem (obj_name
);
2438 if (dtp
->u
.p
.input_complete
)
2440 free_mem (obj_name
);
2445 free_mem (obj_name
);
2449 sprintf (nml_err_msg
, "Bad type for namelist object %s",
2451 internal_error (&dtp
->common
, nml_err_msg
);
2456 /* The standard permits array data to stop short of the number of
2457 elements specified in the loop specification. In this case, we
2458 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2459 nml_get_obj_data and an attempt is made to read object name. */
2462 if (dtp
->u
.p
.nml_read_error
)
2464 dtp
->u
.p
.expanded_read
= 0;
2468 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2470 dtp
->u
.p
.expanded_read
= 0;
2474 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2475 This comes about because the read functions return BT_types. */
2477 switch (dtp
->u
.p
.saved_type
)
2484 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2488 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2489 pdata
= (void*)( pdata
+ clow
- 1 );
2490 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2492 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2499 /* Warn if a non-standard expanded read occurs. A single read of a
2500 single object is acceptable. If a second read occurs, issue a warning
2501 and set the flag to zero to prevent further warnings. */
2502 if (dtp
->u
.p
.expanded_read
== 2)
2504 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2505 dtp
->u
.p
.expanded_read
= 0;
2508 /* If the expanded read warning flag is set, increment it,
2509 indicating that a single read has occurred. */
2510 if (dtp
->u
.p
.expanded_read
>= 1)
2511 dtp
->u
.p
.expanded_read
++;
2513 /* Break out of loop if scalar. */
2517 /* Now increment the index vector. */
2522 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2524 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2526 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2528 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2530 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2534 } while (!nml_carry
);
2536 if (dtp
->u
.p
.repeat_count
> 1)
2538 sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2549 /* Parses the object name, including array and substring qualifiers. It
2550 iterates over derived type components, touching those components and
2551 setting their loop specifications, if there is a qualifier. If the
2552 object is itself a derived type, its components and subcomponents are
2553 touched. nml_read_obj is called at the end and this reads the data in
2554 the manner specified by the object name. */
2557 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2562 namelist_info
* first_nl
= NULL
;
2563 namelist_info
* root_nl
= NULL
;
2564 int dim
, parsed_rank
;
2566 char parse_err_msg
[30];
2567 index_type clow
, chigh
;
2568 int non_zero_rank_count
;
2570 /* Look for end of input or object name. If '?' or '=?' are encountered
2571 in stdin, print the node names or the namelist to stdout. */
2573 eat_separator (dtp
);
2574 if (dtp
->u
.p
.input_complete
)
2577 if (dtp
->u
.p
.at_eol
)
2578 finish_separator (dtp
);
2579 if (dtp
->u
.p
.input_complete
)
2582 c
= next_char (dtp
);
2586 c
= next_char (dtp
);
2589 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2592 nml_query (dtp
, '=');
2596 nml_query (dtp
, '?');
2601 nml_match_name (dtp
, "end", 3);
2602 if (dtp
->u
.p
.nml_read_error
)
2604 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2608 dtp
->u
.p
.input_complete
= 1;
2615 /* Untouch all nodes of the namelist and reset the flag that is set for
2616 derived type components. */
2618 nml_untouch_nodes (dtp
);
2620 non_zero_rank_count
= 0;
2622 /* Get the object name - should '!' and '\n' be permitted separators? */
2630 if (!is_separator (c
))
2631 push_char (dtp
, tolower(c
));
2632 c
= next_char (dtp
);
2633 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2635 unget_char (dtp
, c
);
2637 /* Check that the name is in the namelist and get pointer to object.
2638 Three error conditions exist: (i) An attempt is being made to
2639 identify a non-existent object, following a failed data read or
2640 (ii) The object name does not exist or (iii) Too many data items
2641 are present for an object. (iii) gives the same error message
2644 push_char (dtp
, '\0');
2648 size_t var_len
= strlen (root_nl
->var_name
);
2650 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2651 char ext_name
[var_len
+ saved_len
+ 1];
2653 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2654 if (dtp
->u
.p
.saved_string
)
2655 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2656 ext_name
[var_len
+ saved_len
] = '\0';
2657 nl
= find_nml_node (dtp
, ext_name
);
2660 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2664 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2665 sprintf (nml_err_msg
, "Bad data for namelist object %s",
2666 (*pprev_nl
)->var_name
);
2669 sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2670 dtp
->u
.p
.saved_string
);
2675 /* Get the length, data length, base pointer and rank of the variable.
2676 Set the default loop specification first. */
2678 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2680 nl
->ls
[dim
].step
= 1;
2681 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2682 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2683 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2686 /* Check to see if there is a qualifier: if so, parse it.*/
2688 if (c
== '(' && nl
->var_rank
)
2691 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2692 parse_err_msg
, &parsed_rank
) == FAILURE
)
2694 sprintf (nml_err_msg
, "%s for namelist variable %s",
2695 parse_err_msg
, nl
->var_name
);
2699 if (parsed_rank
> 0)
2700 non_zero_rank_count
++;
2702 c
= next_char (dtp
);
2703 unget_char (dtp
, c
);
2705 else if (nl
->var_rank
> 0)
2706 non_zero_rank_count
++;
2708 /* Now parse a derived type component. The root namelist_info address
2709 is backed up, as is the previous component level. The component flag
2710 is set and the iteration is made by jumping back to get_name. */
2714 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2716 sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2721 if (!component_flag
)
2726 c
= next_char (dtp
);
2730 /* Parse a character qualifier, if present. chigh = 0 is a default
2731 that signals that the string length = string_length. */
2736 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2738 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2739 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2741 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, parse_err_msg
, &parsed_rank
)
2744 sprintf (nml_err_msg
, "%s for namelist variable %s",
2745 parse_err_msg
, nl
->var_name
);
2749 clow
= ind
[0].start
;
2752 if (ind
[0].step
!= 1)
2754 sprintf (nml_err_msg
,
2755 "Step not allowed in substring qualifier"
2756 " for namelist object %s", nl
->var_name
);
2760 c
= next_char (dtp
);
2761 unget_char (dtp
, c
);
2764 /* If a derived type touch its components and restore the root
2765 namelist_info if we have parsed a qualified derived type
2768 if (nl
->type
== GFC_DTYPE_DERIVED
)
2769 nml_touch_nodes (nl
);
2773 /* Make sure no extraneous qualifiers are there. */
2777 sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2778 " namelist object %s", nl
->var_name
);
2782 /* Make sure there is no more than one non-zero rank object. */
2783 if (non_zero_rank_count
> 1)
2785 sprintf (nml_err_msg
, "Multiple sub-objects with non-zero rank in"
2786 " namelist object %s", nl
->var_name
);
2787 non_zero_rank_count
= 0;
2791 /* According to the standard, an equal sign MUST follow an object name. The
2792 following is possibly lax - it allows comments, blank lines and so on to
2793 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2797 eat_separator (dtp
);
2798 if (dtp
->u
.p
.input_complete
)
2801 if (dtp
->u
.p
.at_eol
)
2802 finish_separator (dtp
);
2803 if (dtp
->u
.p
.input_complete
)
2806 c
= next_char (dtp
);
2810 sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2815 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2825 /* Entry point for namelist input. Goes through input until namelist name
2826 is matched. Then cycles through nml_get_obj_data until the input is
2827 completed or there is an error. */
2830 namelist_read (st_parameter_dt
*dtp
)
2834 char nml_err_msg
[100];
2835 /* Pointer to the previously read object, in case attempt is made to read
2836 new object name. Should this fail, error message can give previous
2838 namelist_info
*prev_nl
= NULL
;
2840 dtp
->u
.p
.namelist_mode
= 1;
2841 dtp
->u
.p
.input_complete
= 0;
2842 dtp
->u
.p
.expanded_read
= 0;
2844 dtp
->u
.p
.eof_jump
= &eof_jump
;
2845 if (setjmp (eof_jump
))
2847 dtp
->u
.p
.eof_jump
= NULL
;
2848 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2852 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2853 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2854 node names or namelist on stdout. */
2857 switch (c
= next_char (dtp
))
2868 c
= next_char (dtp
);
2870 nml_query (dtp
, '=');
2872 unget_char (dtp
, c
);
2876 nml_query (dtp
, '?');
2882 /* Match the name of the namelist. */
2884 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2886 if (dtp
->u
.p
.nml_read_error
)
2889 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2890 c
= next_char (dtp
);
2891 if (!is_separator(c
))
2893 unget_char (dtp
, c
);
2897 /* Ready to read namelist objects. If there is an error in input
2898 from stdin, output the error message and continue. */
2900 while (!dtp
->u
.p
.input_complete
)
2902 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2906 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2909 u
= find_unit (options
.stderr_unit
);
2910 st_printf ("%s\n", nml_err_msg
);
2920 dtp
->u
.p
.eof_jump
= NULL
;
2925 /* All namelist error calls return from here */
2929 dtp
->u
.p
.eof_jump
= NULL
;
2932 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);