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;
322 if (dtp
->u
.p
.namelist_mode
)
323 { /* Eat a namelist comment. */
331 /* Fall Through... */
340 /* Finish processing a separator that was interrupted by a newline.
341 If we're here, then another data item is present, so we finish what
342 we started on the previous line. */
345 finish_separator (st_parameter_dt
*dtp
)
356 if (dtp
->u
.p
.comma_flag
)
360 c
= eat_spaces (dtp
);
361 if (c
== '\n' || c
== '\r')
368 dtp
->u
.p
.input_complete
= 1;
369 if (!dtp
->u
.p
.namelist_mode
)
378 if (dtp
->u
.p
.namelist_mode
)
394 /* This function reads characters through to the end of the current line and
395 just ignores them. */
398 eat_line (st_parameter_dt
*dtp
)
401 if (!is_internal_unit (dtp
))
408 /* This function is needed to catch bad conversions so that namelist can
409 attempt to see if dtp->u.p.saved_string contains a new object name rather
413 nml_bad_return (st_parameter_dt
*dtp
, char c
)
415 if (dtp
->u
.p
.namelist_mode
)
417 dtp
->u
.p
.nml_read_error
= 1;
424 /* Convert an unsigned string to an integer. The length value is -1
425 if we are working on a repeat count. Returns nonzero if we have a
426 range problem. As a side effect, frees the dtp->u.p.saved_string. */
429 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
431 char c
, *buffer
, message
[100];
433 GFC_INTEGER_LARGEST v
, max
, max10
;
435 buffer
= dtp
->u
.p
.saved_string
;
438 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
463 set_integer (dtp
->u
.p
.value
, v
, length
);
467 dtp
->u
.p
.repeat_count
= v
;
469 if (dtp
->u
.p
.repeat_count
== 0)
471 sprintf (message
, "Zero repeat count in item %d of list input",
472 dtp
->u
.p
.item_count
);
474 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
484 sprintf (message
, "Repeat count overflow in item %d of list input",
485 dtp
->u
.p
.item_count
);
487 sprintf (message
, "Integer overflow while reading item %d",
488 dtp
->u
.p
.item_count
);
491 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
497 /* Parse a repeat count for logical and complex values which cannot
498 begin with a digit. Returns nonzero if we are done, zero if we
499 should continue on. */
502 parse_repeat (st_parameter_dt
*dtp
)
504 char c
, message
[100];
530 repeat
= 10 * repeat
+ c
- '0';
532 if (repeat
> MAX_REPEAT
)
535 "Repeat count overflow in item %d of list input",
536 dtp
->u
.p
.item_count
);
538 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
548 "Zero repeat count in item %d of list input",
549 dtp
->u
.p
.item_count
);
551 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
563 dtp
->u
.p
.repeat_count
= repeat
;
570 sprintf (message
, "Bad repeat count in item %d of list input",
571 dtp
->u
.p
.item_count
);
572 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
577 /* To read a logical we have to look ahead in the input stream to make sure
578 there is not an equal sign indicating a variable name. To do this we use
579 line_buffer to point to a temporary buffer, pushing characters there for
580 possible later reading. */
583 l_push_char (st_parameter_dt
*dtp
, char c
)
585 if (dtp
->u
.p
.line_buffer
== NULL
)
587 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
588 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
591 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
595 /* Read a logical character on the input. */
598 read_logical (st_parameter_dt
*dtp
, int length
)
600 char c
, message
[100];
603 if (parse_repeat (dtp
))
606 c
= tolower (next_char (dtp
));
607 l_push_char (dtp
, c
);
613 l_push_char (dtp
, c
);
615 if (!is_separator(c
))
623 l_push_char (dtp
, c
);
625 if (!is_separator(c
))
631 c
= tolower (next_char (dtp
));
649 return; /* Null value. */
655 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
656 dtp
->u
.p
.saved_length
= length
;
658 /* Eat trailing garbage. */
663 while (!is_separator (c
));
667 dtp
->u
.p
.item_count
= 0;
668 dtp
->u
.p
.line_buffer_enabled
= 0;
669 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
676 for(i
= 0; i
< 63; i
++)
681 /* All done if this is not a namelist read. */
682 if (!dtp
->u
.p
.namelist_mode
)
695 l_push_char (dtp
, c
);
698 dtp
->u
.p
.nml_read_error
= 1;
699 dtp
->u
.p
.line_buffer_enabled
= 1;
700 dtp
->u
.p
.item_count
= 0;
710 if (nml_bad_return (dtp
, c
))
715 sprintf (message
, "Bad logical value while reading item %d",
716 dtp
->u
.p
.item_count
);
717 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
722 dtp
->u
.p
.item_count
= 0;
723 dtp
->u
.p
.line_buffer_enabled
= 0;
724 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
725 dtp
->u
.p
.saved_length
= length
;
726 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
732 /* Reading integers is tricky because we can actually be reading a
733 repeat count. We have to store the characters in a buffer because
734 we could be reading an integer that is larger than the default int
735 used for repeat counts. */
738 read_integer (st_parameter_dt
*dtp
, int length
)
740 char c
, message
[100];
750 /* Fall through... */
756 CASE_SEPARATORS
: /* Single null. */
769 /* Take care of what may be a repeat count. */
781 push_char (dtp
, '\0');
784 CASE_SEPARATORS
: /* Not a repeat count. */
793 if (convert_integer (dtp
, -1, 0))
796 /* Get the real integer. */
811 /* Fall through... */
842 if (nml_bad_return (dtp
, c
))
847 sprintf (message
, "Bad integer for item %d in list input",
848 dtp
->u
.p
.item_count
);
849 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
857 push_char (dtp
, '\0');
858 if (convert_integer (dtp
, length
, negative
))
865 dtp
->u
.p
.saved_type
= BT_INTEGER
;
869 /* Read a character variable. */
872 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
874 char c
, quote
, message
[100];
876 quote
= ' '; /* Space means no quote character. */
886 unget_char (dtp
, c
); /* NULL value. */
896 if (dtp
->u
.p
.namelist_mode
)
898 if (dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_APOSTROPHE
899 || dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_QUOTE
900 || c
== '&' || c
== '$' || c
== '/')
906 /* Check to see if we are seeing a namelist object name by using the
907 line buffer and looking ahead for an '=' or '('. */
908 l_push_char (dtp
, c
);
911 for(i
= 0; i
< 63; i
++)
921 l_push_char (dtp
, c
);
922 dtp
->u
.p
.item_count
= 0;
923 dtp
->u
.p
.line_buffer_enabled
= 1;
928 l_push_char (dtp
, c
);
930 if (c
== '=' || c
== '(')
932 dtp
->u
.p
.item_count
= 0;
933 dtp
->u
.p
.nml_read_error
= 1;
934 dtp
->u
.p
.line_buffer_enabled
= 1;
939 /* The string is too long to be a valid object name so assume that it
940 is a string to be read in as a value. */
941 dtp
->u
.p
.item_count
= 0;
942 dtp
->u
.p
.line_buffer_enabled
= 1;
950 /* Deal with a possible repeat count. */
963 goto done
; /* String was only digits! */
966 push_char (dtp
, '\0');
971 goto get_string
; /* Not a repeat count after all. */
976 if (convert_integer (dtp
, -1, 0))
979 /* Now get the real string. */
985 unget_char (dtp
, c
); /* Repeated NULL values. */
1002 c
= next_char (dtp
);
1013 /* See if we have a doubled quote character or the end of
1016 c
= next_char (dtp
);
1019 push_char (dtp
, quote
);
1023 unget_char (dtp
, c
);
1029 unget_char (dtp
, c
);
1033 if (c
!= '\n' && c
!= '\r')
1043 /* At this point, we have to have a separator, or else the string is
1046 c
= next_char (dtp
);
1047 if (is_separator (c
))
1049 unget_char (dtp
, c
);
1050 eat_separator (dtp
);
1051 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1057 sprintf (message
, "Invalid string input in item %d",
1058 dtp
->u
.p
.item_count
);
1059 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1064 /* Parse a component of a complex constant or a real number that we
1065 are sure is already there. This is a straight real number parser. */
1068 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1070 char c
, message
[100];
1073 c
= next_char (dtp
);
1074 if (c
== '-' || c
== '+')
1077 c
= next_char (dtp
);
1080 if (!isdigit (c
) && c
!= '.')
1082 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1090 seen_dp
= (c
== '.') ? 1 : 0;
1094 c
= next_char (dtp
);
1113 push_char (dtp
, 'e');
1118 push_char (dtp
, 'e');
1120 c
= next_char (dtp
);
1124 unget_char (dtp
, c
);
1133 c
= next_char (dtp
);
1134 if (c
!= '-' && c
!= '+')
1135 push_char (dtp
, '+');
1139 c
= next_char (dtp
);
1145 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1155 c
= next_char (dtp
);
1163 unget_char (dtp
, c
);
1172 unget_char (dtp
, c
);
1173 push_char (dtp
, '\0');
1175 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1181 /* Match INF and Infinity. */
1182 if ((c
== 'i' || c
== 'I')
1183 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1184 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1186 c
= next_char (dtp
);
1187 if ((c
!= 'i' && c
!= 'I')
1188 || ((c
== 'i' || c
== 'I')
1189 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1190 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1191 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1192 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1193 && (c
= next_char (dtp
))))
1195 if (is_separator (c
))
1196 unget_char (dtp
, c
);
1197 push_char (dtp
, 'i');
1198 push_char (dtp
, 'n');
1199 push_char (dtp
, 'f');
1203 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1204 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1205 && (c
= next_char (dtp
)))
1207 if (is_separator (c
))
1208 unget_char (dtp
, c
);
1209 push_char (dtp
, 'n');
1210 push_char (dtp
, 'a');
1211 push_char (dtp
, 'n');
1217 if (nml_bad_return (dtp
, c
))
1222 sprintf (message
, "Bad floating point number for item %d",
1223 dtp
->u
.p
.item_count
);
1224 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1230 /* Reading a complex number is straightforward because we can tell
1231 what it is right away. */
1234 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1239 if (parse_repeat (dtp
))
1242 c
= next_char (dtp
);
1249 unget_char (dtp
, c
);
1250 eat_separator (dtp
);
1258 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1263 c
= next_char (dtp
);
1264 if (c
== '\n' || c
== '\r')
1267 unget_char (dtp
, c
);
1269 if (next_char (dtp
) != ',')
1274 c
= next_char (dtp
);
1275 if (c
== '\n' || c
== '\r')
1278 unget_char (dtp
, c
);
1280 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1284 if (next_char (dtp
) != ')')
1287 c
= next_char (dtp
);
1288 if (!is_separator (c
))
1291 unget_char (dtp
, c
);
1292 eat_separator (dtp
);
1295 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1300 if (nml_bad_return (dtp
, c
))
1305 sprintf (message
, "Bad complex value in item %d of list input",
1306 dtp
->u
.p
.item_count
);
1307 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1311 /* Parse a real number with a possible repeat count. */
1314 read_real (st_parameter_dt
*dtp
, int length
)
1316 char c
, message
[100];
1322 c
= next_char (dtp
);
1339 unget_char (dtp
, c
); /* Single null. */
1340 eat_separator (dtp
);
1353 /* Get the digit string that might be a repeat count. */
1357 c
= next_char (dtp
);
1380 push_char (dtp
, 'e');
1382 c
= next_char (dtp
);
1386 push_char (dtp
, '\0');
1390 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1391 unget_char (dtp
, c
);
1400 if (convert_integer (dtp
, -1, 0))
1403 /* Now get the number itself. */
1405 c
= next_char (dtp
);
1406 if (is_separator (c
))
1407 { /* Repeated null value. */
1408 unget_char (dtp
, c
);
1409 eat_separator (dtp
);
1413 if (c
!= '-' && c
!= '+')
1414 push_char (dtp
, '+');
1419 c
= next_char (dtp
);
1422 if (!isdigit (c
) && c
!= '.')
1424 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1443 c
= next_char (dtp
);
1469 push_char (dtp
, 'e');
1471 c
= next_char (dtp
);
1480 push_char (dtp
, 'e');
1482 c
= next_char (dtp
);
1483 if (c
!= '+' && c
!= '-')
1484 push_char (dtp
, '+');
1488 c
= next_char (dtp
);
1498 c
= next_char (dtp
);
1515 unget_char (dtp
, c
);
1516 eat_separator (dtp
);
1517 push_char (dtp
, '\0');
1518 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1522 dtp
->u
.p
.saved_type
= BT_REAL
;
1526 l_push_char (dtp
, c
);
1529 /* Match INF and Infinity. */
1530 if (c
== 'i' || c
== 'I')
1532 c
= next_char (dtp
);
1533 l_push_char (dtp
, c
);
1534 if (c
!= 'n' && c
!= 'N')
1536 c
= next_char (dtp
);
1537 l_push_char (dtp
, c
);
1538 if (c
!= 'f' && c
!= 'F')
1540 c
= next_char (dtp
);
1541 l_push_char (dtp
, c
);
1542 if (!is_separator (c
))
1544 if (c
!= 'i' && c
!= 'I')
1546 c
= next_char (dtp
);
1547 l_push_char (dtp
, c
);
1548 if (c
!= 'n' && c
!= 'N')
1550 c
= next_char (dtp
);
1551 l_push_char (dtp
, c
);
1552 if (c
!= 'i' && c
!= 'I')
1554 c
= next_char (dtp
);
1555 l_push_char (dtp
, c
);
1556 if (c
!= 't' && c
!= 'T')
1558 c
= next_char (dtp
);
1559 l_push_char (dtp
, c
);
1560 if (c
!= 'y' && c
!= 'Y')
1562 c
= next_char (dtp
);
1563 l_push_char (dtp
, c
);
1569 c
= next_char (dtp
);
1570 l_push_char (dtp
, c
);
1571 if (c
!= 'a' && c
!= 'A')
1573 c
= next_char (dtp
);
1574 l_push_char (dtp
, c
);
1575 if (c
!= 'n' && c
!= 'N')
1577 c
= next_char (dtp
);
1578 l_push_char (dtp
, c
);
1581 if (!is_separator (c
) || c
== '=')
1584 if (dtp
->u
.p
.namelist_mode
&& c
!= ',' && c
!= '/')
1585 for (i
= 0; i
< 63; i
++)
1588 c
= next_char (dtp
);
1589 l_push_char (dtp
, c
);
1593 if (c
== ',' || c
== '/' || !is_separator(c
))
1599 push_char (dtp
, 'i');
1600 push_char (dtp
, 'n');
1601 push_char (dtp
, 'f');
1605 push_char (dtp
, 'n');
1606 push_char (dtp
, 'a');
1607 push_char (dtp
, 'n');
1610 dtp
->u
.p
.item_count
= 0;
1611 dtp
->u
.p
.line_buffer_enabled
= 0;
1616 if (dtp
->u
.p
.namelist_mode
)
1618 dtp
->u
.p
.nml_read_error
= 1;
1619 dtp
->u
.p
.line_buffer_enabled
= 1;
1620 dtp
->u
.p
.item_count
= 0;
1626 if (nml_bad_return (dtp
, c
))
1631 sprintf (message
, "Bad real number in item %d of list input",
1632 dtp
->u
.p
.item_count
);
1633 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1637 /* Check the current type against the saved type to make sure they are
1638 compatible. Returns nonzero if incompatible. */
1641 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1645 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1647 sprintf (message
, "Read type %s where %s was expected for item %d",
1648 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1649 dtp
->u
.p
.item_count
);
1651 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1655 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1658 if (dtp
->u
.p
.saved_length
!= len
)
1661 "Read kind %d %s where kind %d is required for item %d",
1662 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1663 dtp
->u
.p
.item_count
);
1664 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1672 /* Top level data transfer subroutine for list reads. Because we have
1673 to deal with repeat counts, the data item is always saved after
1674 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1675 greater than one, we copy the data item multiple times. */
1678 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1685 dtp
->u
.p
.namelist_mode
= 0;
1687 dtp
->u
.p
.eof_jump
= &eof_jump
;
1688 if (setjmp (eof_jump
))
1690 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1694 if (dtp
->u
.p
.first_item
)
1696 dtp
->u
.p
.first_item
= 0;
1697 dtp
->u
.p
.input_complete
= 0;
1698 dtp
->u
.p
.repeat_count
= 1;
1699 dtp
->u
.p
.at_eol
= 0;
1701 c
= eat_spaces (dtp
);
1702 if (is_separator (c
))
1704 /* Found a null value. */
1705 eat_separator (dtp
);
1706 dtp
->u
.p
.repeat_count
= 0;
1708 /* eat_separator sets this flag if the separator was a comma. */
1709 if (dtp
->u
.p
.comma_flag
)
1712 /* eat_separator sets this flag if the separator was a \n or \r. */
1713 if (dtp
->u
.p
.at_eol
)
1714 finish_separator (dtp
);
1722 if (dtp
->u
.p
.input_complete
)
1725 if (dtp
->u
.p
.repeat_count
> 0)
1727 if (check_type (dtp
, type
, kind
))
1732 if (dtp
->u
.p
.at_eol
)
1733 finish_separator (dtp
);
1737 /* Trailing spaces prior to end of line. */
1738 if (dtp
->u
.p
.at_eol
)
1739 finish_separator (dtp
);
1742 dtp
->u
.p
.saved_type
= BT_NULL
;
1743 dtp
->u
.p
.repeat_count
= 1;
1749 read_integer (dtp
, kind
);
1752 read_logical (dtp
, kind
);
1755 read_character (dtp
, kind
);
1758 read_real (dtp
, kind
);
1761 read_complex (dtp
, kind
, size
);
1764 internal_error (&dtp
->common
, "Bad type for list read");
1767 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1768 dtp
->u
.p
.saved_length
= size
;
1770 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1774 switch (dtp
->u
.p
.saved_type
)
1780 memcpy (p
, dtp
->u
.p
.value
, size
);
1784 if (dtp
->u
.p
.saved_string
)
1786 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1787 ? (int) size
: dtp
->u
.p
.saved_used
;
1788 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1791 /* Just delimiters encountered, nothing to copy but SPACE. */
1795 memset (((char *) p
) + m
, ' ', size
- m
);
1802 if (--dtp
->u
.p
.repeat_count
<= 0)
1806 dtp
->u
.p
.eof_jump
= NULL
;
1811 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1812 size_t size
, size_t nelems
)
1819 /* Big loop over all the elements. */
1820 for (elem
= 0; elem
< nelems
; elem
++)
1822 dtp
->u
.p
.item_count
++;
1823 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1828 /* Finish a list read. */
1831 finish_list_read (st_parameter_dt
*dtp
)
1837 if (dtp
->u
.p
.at_eol
)
1839 dtp
->u
.p
.at_eol
= 0;
1845 c
= next_char (dtp
);
1852 void namelist_read (st_parameter_dt *dtp)
1854 static void nml_match_name (char *name, int len)
1855 static int nml_query (st_parameter_dt *dtp)
1856 static int nml_get_obj_data (st_parameter_dt *dtp,
1857 namelist_info **prev_nl, char *)
1859 static void nml_untouch_nodes (st_parameter_dt *dtp)
1860 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1862 static int nml_parse_qualifier(descriptor_dimension * ad,
1863 array_loop_spec * ls, int rank, char *)
1864 static void nml_touch_nodes (namelist_info * nl)
1865 static int nml_read_obj (namelist_info *nl, index_type offset,
1866 namelist_info **prev_nl, char *,
1867 index_type clow, index_type chigh)
1871 /* Inputs a rank-dimensional qualifier, which can contain
1872 singlets, doublets, triplets or ':' with the standard meanings. */
1875 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1876 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1883 int is_array_section
, is_char
;
1887 is_array_section
= 0;
1888 dtp
->u
.p
.expanded_read
= 0;
1890 /* See if this is a character substring qualifier we are looking for. */
1897 /* The next character in the stream should be the '('. */
1899 c
= next_char (dtp
);
1901 /* Process the qualifier, by dimension and triplet. */
1903 for (dim
=0; dim
< rank
; dim
++ )
1905 for (indx
=0; indx
<3; indx
++)
1911 /* Process a potential sign. */
1912 c
= next_char (dtp
);
1923 unget_char (dtp
, c
);
1927 /* Process characters up to the next ':' , ',' or ')'. */
1930 c
= next_char (dtp
);
1935 is_array_section
= 1;
1939 if ((c
==',' && dim
== rank
-1)
1940 || (c
==')' && dim
< rank
-1))
1943 sprintf (parse_err_msg
, "Bad substring qualifier");
1945 sprintf (parse_err_msg
, "Bad number of index fields");
1954 case ' ': case '\t':
1956 c
= next_char (dtp
);
1961 sprintf (parse_err_msg
,
1962 "Bad character in substring qualifier");
1964 sprintf (parse_err_msg
, "Bad character in index");
1968 if ((c
== ',' || c
== ')') && indx
== 0
1969 && dtp
->u
.p
.saved_string
== 0)
1972 sprintf (parse_err_msg
, "Null substring qualifier");
1974 sprintf (parse_err_msg
, "Null index field");
1978 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1979 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1982 sprintf (parse_err_msg
, "Bad substring qualifier");
1984 sprintf (parse_err_msg
, "Bad index triplet");
1988 if (is_char
&& !is_array_section
)
1990 sprintf (parse_err_msg
,
1991 "Missing colon in substring qualifier");
1995 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1997 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1998 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2004 /* Now read the index. */
2005 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2008 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2010 sprintf (parse_err_msg
, "Bad integer in index");
2016 /* Feed the index values to the triplet arrays. */
2020 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2022 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2024 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2027 /* Singlet or doublet indices. */
2028 if (c
==',' || c
==')')
2032 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2034 /* If -std=f95/2003 or an array section is specified,
2035 do not allow excess data to be processed. */
2036 if (is_array_section
== 1
2037 || compile_options
.allow_std
< GFC_STD_GNU
)
2038 ls
[dim
].end
= ls
[dim
].start
;
2040 dtp
->u
.p
.expanded_read
= 1;
2043 /* Check for non-zero rank. */
2044 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2051 /* Check the values of the triplet indices. */
2052 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2053 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2054 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2055 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2058 sprintf (parse_err_msg
, "Substring out of range");
2060 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2064 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2065 || (ls
[dim
].step
== 0))
2067 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2071 /* Initialise the loop index counter. */
2072 ls
[dim
].idx
= ls
[dim
].start
;
2082 static namelist_info
*
2083 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2085 namelist_info
* t
= dtp
->u
.p
.ionml
;
2088 if (strcmp (var_name
, t
->var_name
) == 0)
2098 /* Visits all the components of a derived type that have
2099 not explicitly been identified in the namelist input.
2100 touched is set and the loop specification initialised
2101 to default values */
2104 nml_touch_nodes (namelist_info
* nl
)
2106 index_type len
= strlen (nl
->var_name
) + 1;
2108 char * ext_name
= (char*)get_mem (len
+ 1);
2109 memcpy (ext_name
, nl
->var_name
, len
-1);
2110 memcpy (ext_name
+ len
- 1, "%", 2);
2111 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2113 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2116 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2118 nl
->ls
[dim
].step
= 1;
2119 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2120 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2121 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2127 free_mem (ext_name
);
2131 /* Resets touched for the entire list of nml_nodes, ready for a
2135 nml_untouch_nodes (st_parameter_dt
*dtp
)
2138 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2143 /* Attempts to input name to namelist name. Returns
2144 dtp->u.p.nml_read_error = 1 on no match. */
2147 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2151 dtp
->u
.p
.nml_read_error
= 0;
2152 for (i
= 0; i
< len
; i
++)
2154 c
= next_char (dtp
);
2155 if (tolower (c
) != tolower (name
[i
]))
2157 dtp
->u
.p
.nml_read_error
= 1;
2163 /* If the namelist read is from stdin, output the current state of the
2164 namelist to stdout. This is used to implement the non-standard query
2165 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2166 the names alone are printed. */
2169 nml_query (st_parameter_dt
*dtp
, char c
)
2171 gfc_unit
* temp_unit
;
2176 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2179 /* Store the current unit and transfer to stdout. */
2181 temp_unit
= dtp
->u
.p
.current_unit
;
2182 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2184 if (dtp
->u
.p
.current_unit
)
2186 dtp
->u
.p
.mode
= WRITING
;
2187 next_record (dtp
, 0);
2189 /* Write the namelist in its entirety. */
2192 namelist_write (dtp
);
2194 /* Or write the list of names. */
2198 /* "&namelist_name\n" */
2200 len
= dtp
->namelist_name_len
;
2202 p
= write_block (dtp
, len
+ 3);
2204 p
= write_block (dtp
, len
+ 2);
2209 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2211 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2213 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2215 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2219 len
= strlen (nl
->var_name
);
2221 p
= write_block (dtp
, len
+ 3);
2223 p
= write_block (dtp
, len
+ 2);
2228 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2230 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2232 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2239 p
= write_block (dtp
, 6);
2241 p
= write_block (dtp
, 5);
2246 memcpy (p
, "&end\r\n", 6);
2248 memcpy (p
, "&end\n", 5);
2252 /* Flush the stream to force immediate output. */
2254 flush (dtp
->u
.p
.current_unit
->s
);
2255 unlock_unit (dtp
->u
.p
.current_unit
);
2260 /* Restore the current unit. */
2262 dtp
->u
.p
.current_unit
= temp_unit
;
2263 dtp
->u
.p
.mode
= READING
;
2267 /* Reads and stores the input for the namelist object nl. For an array,
2268 the function loops over the ranges defined by the loop specification.
2269 This default to all the data or to the specification from a qualifier.
2270 nml_read_obj recursively calls itself to read derived types. It visits
2271 all its own components but only reads data for those that were touched
2272 when the name was parsed. If a read error is encountered, an attempt is
2273 made to return to read a new object name because the standard allows too
2274 little data to be available. On the other hand, too much data is an
2278 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2279 namelist_info
**pprev_nl
, char *nml_err_msg
,
2280 index_type clow
, index_type chigh
)
2282 namelist_info
* cmp
;
2289 index_type obj_name_len
;
2292 /* This object not touched in name parsing. */
2297 dtp
->u
.p
.repeat_count
= 0;
2303 case GFC_DTYPE_INTEGER
:
2304 case GFC_DTYPE_LOGICAL
:
2308 case GFC_DTYPE_REAL
:
2309 dlen
= size_from_real_kind (len
);
2312 case GFC_DTYPE_COMPLEX
:
2313 dlen
= size_from_complex_kind (len
);
2316 case GFC_DTYPE_CHARACTER
:
2317 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2326 /* Update the pointer to the data, using the current index vector */
2328 pdata
= (void*)(nl
->mem_pos
+ offset
);
2329 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2330 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2331 nl
->dim
[dim
].stride
* nl
->size
);
2333 /* Reset the error flag and try to read next value, if
2334 dtp->u.p.repeat_count=0 */
2336 dtp
->u
.p
.nml_read_error
= 0;
2338 if (--dtp
->u
.p
.repeat_count
<= 0)
2340 if (dtp
->u
.p
.input_complete
)
2342 if (dtp
->u
.p
.at_eol
)
2343 finish_separator (dtp
);
2344 if (dtp
->u
.p
.input_complete
)
2347 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2348 after the switch block. */
2350 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2355 case GFC_DTYPE_INTEGER
:
2356 read_integer (dtp
, len
);
2359 case GFC_DTYPE_LOGICAL
:
2360 read_logical (dtp
, len
);
2363 case GFC_DTYPE_CHARACTER
:
2364 read_character (dtp
, len
);
2367 case GFC_DTYPE_REAL
:
2368 read_real (dtp
, len
);
2371 case GFC_DTYPE_COMPLEX
:
2372 read_complex (dtp
, len
, dlen
);
2375 case GFC_DTYPE_DERIVED
:
2376 obj_name_len
= strlen (nl
->var_name
) + 1;
2377 obj_name
= get_mem (obj_name_len
+1);
2378 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2379 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2381 /* If reading a derived type, disable the expanded read warning
2382 since a single object can have multiple reads. */
2383 dtp
->u
.p
.expanded_read
= 0;
2385 /* Now loop over the components. Update the component pointer
2386 with the return value from nml_write_obj. This loop jumps
2387 past nested derived types by testing if the potential
2388 component name contains '%'. */
2390 for (cmp
= nl
->next
;
2392 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2393 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2397 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2398 pprev_nl
, nml_err_msg
, clow
, chigh
)
2401 free_mem (obj_name
);
2405 if (dtp
->u
.p
.input_complete
)
2407 free_mem (obj_name
);
2412 free_mem (obj_name
);
2416 sprintf (nml_err_msg
, "Bad type for namelist object %s",
2418 internal_error (&dtp
->common
, nml_err_msg
);
2423 /* The standard permits array data to stop short of the number of
2424 elements specified in the loop specification. In this case, we
2425 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2426 nml_get_obj_data and an attempt is made to read object name. */
2429 if (dtp
->u
.p
.nml_read_error
)
2431 dtp
->u
.p
.expanded_read
= 0;
2435 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2437 dtp
->u
.p
.expanded_read
= 0;
2441 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2442 This comes about because the read functions return BT_types. */
2444 switch (dtp
->u
.p
.saved_type
)
2451 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2455 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2456 pdata
= (void*)( pdata
+ clow
- 1 );
2457 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2459 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2466 /* Warn if a non-standard expanded read occurs. A single read of a
2467 single object is acceptable. If a second read occurs, issue a warning
2468 and set the flag to zero to prevent further warnings. */
2469 if (dtp
->u
.p
.expanded_read
== 2)
2471 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2472 dtp
->u
.p
.expanded_read
= 0;
2475 /* If the expanded read warning flag is set, increment it,
2476 indicating that a single read has occurred. */
2477 if (dtp
->u
.p
.expanded_read
>= 1)
2478 dtp
->u
.p
.expanded_read
++;
2480 /* Break out of loop if scalar. */
2484 /* Now increment the index vector. */
2489 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2491 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2493 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2495 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2497 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2501 } while (!nml_carry
);
2503 if (dtp
->u
.p
.repeat_count
> 1)
2505 sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2516 /* Parses the object name, including array and substring qualifiers. It
2517 iterates over derived type components, touching those components and
2518 setting their loop specifications, if there is a qualifier. If the
2519 object is itself a derived type, its components and subcomponents are
2520 touched. nml_read_obj is called at the end and this reads the data in
2521 the manner specified by the object name. */
2524 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2529 namelist_info
* first_nl
= NULL
;
2530 namelist_info
* root_nl
= NULL
;
2531 int dim
, parsed_rank
;
2533 char parse_err_msg
[30];
2534 index_type clow
, chigh
;
2535 int non_zero_rank_count
;
2537 /* Look for end of input or object name. If '?' or '=?' are encountered
2538 in stdin, print the node names or the namelist to stdout. */
2540 eat_separator (dtp
);
2541 if (dtp
->u
.p
.input_complete
)
2544 if (dtp
->u
.p
.at_eol
)
2545 finish_separator (dtp
);
2546 if (dtp
->u
.p
.input_complete
)
2549 c
= next_char (dtp
);
2553 c
= next_char (dtp
);
2556 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2559 nml_query (dtp
, '=');
2563 nml_query (dtp
, '?');
2568 nml_match_name (dtp
, "end", 3);
2569 if (dtp
->u
.p
.nml_read_error
)
2571 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2575 dtp
->u
.p
.input_complete
= 1;
2582 /* Untouch all nodes of the namelist and reset the flag that is set for
2583 derived type components. */
2585 nml_untouch_nodes (dtp
);
2587 non_zero_rank_count
= 0;
2589 /* Get the object name - should '!' and '\n' be permitted separators? */
2597 push_char (dtp
, tolower(c
));
2598 c
= next_char (dtp
);
2599 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2601 unget_char (dtp
, c
);
2603 /* Check that the name is in the namelist and get pointer to object.
2604 Three error conditions exist: (i) An attempt is being made to
2605 identify a non-existent object, following a failed data read or
2606 (ii) The object name does not exist or (iii) Too many data items
2607 are present for an object. (iii) gives the same error message
2610 push_char (dtp
, '\0');
2614 size_t var_len
= strlen (root_nl
->var_name
);
2616 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2617 char ext_name
[var_len
+ saved_len
+ 1];
2619 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2620 if (dtp
->u
.p
.saved_string
)
2621 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2622 ext_name
[var_len
+ saved_len
] = '\0';
2623 nl
= find_nml_node (dtp
, ext_name
);
2626 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2630 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2631 sprintf (nml_err_msg
, "Bad data for namelist object %s",
2632 (*pprev_nl
)->var_name
);
2635 sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2636 dtp
->u
.p
.saved_string
);
2641 /* Get the length, data length, base pointer and rank of the variable.
2642 Set the default loop specification first. */
2644 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2646 nl
->ls
[dim
].step
= 1;
2647 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2648 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2649 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2652 /* Check to see if there is a qualifier: if so, parse it.*/
2654 if (c
== '(' && nl
->var_rank
)
2657 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2658 parse_err_msg
, &parsed_rank
) == FAILURE
)
2660 sprintf (nml_err_msg
, "%s for namelist variable %s",
2661 parse_err_msg
, nl
->var_name
);
2665 if (parsed_rank
> 0)
2666 non_zero_rank_count
++;
2668 c
= next_char (dtp
);
2669 unget_char (dtp
, c
);
2671 else if (nl
->var_rank
> 0)
2672 non_zero_rank_count
++;
2674 /* Now parse a derived type component. The root namelist_info address
2675 is backed up, as is the previous component level. The component flag
2676 is set and the iteration is made by jumping back to get_name. */
2680 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2682 sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2687 if (!component_flag
)
2692 c
= next_char (dtp
);
2696 /* Parse a character qualifier, if present. chigh = 0 is a default
2697 that signals that the string length = string_length. */
2702 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2704 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2705 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2707 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, parse_err_msg
, &parsed_rank
)
2710 sprintf (nml_err_msg
, "%s for namelist variable %s",
2711 parse_err_msg
, nl
->var_name
);
2715 clow
= ind
[0].start
;
2718 if (ind
[0].step
!= 1)
2720 sprintf (nml_err_msg
,
2721 "Step not allowed in substring qualifier"
2722 " for namelist object %s", nl
->var_name
);
2726 c
= next_char (dtp
);
2727 unget_char (dtp
, c
);
2730 /* If a derived type touch its components and restore the root
2731 namelist_info if we have parsed a qualified derived type
2734 if (nl
->type
== GFC_DTYPE_DERIVED
)
2735 nml_touch_nodes (nl
);
2739 /* Make sure no extraneous qualifiers are there. */
2743 sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2744 " namelist object %s", nl
->var_name
);
2748 /* Make sure there is no more than one non-zero rank object. */
2749 if (non_zero_rank_count
> 1)
2751 sprintf (nml_err_msg
, "Multiple sub-objects with non-zero rank in"
2752 " namelist object %s", nl
->var_name
);
2753 non_zero_rank_count
= 0;
2757 /* According to the standard, an equal sign MUST follow an object name. The
2758 following is possibly lax - it allows comments, blank lines and so on to
2759 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2763 eat_separator (dtp
);
2764 if (dtp
->u
.p
.input_complete
)
2767 if (dtp
->u
.p
.at_eol
)
2768 finish_separator (dtp
);
2769 if (dtp
->u
.p
.input_complete
)
2772 c
= next_char (dtp
);
2776 sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2781 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2791 /* Entry point for namelist input. Goes through input until namelist name
2792 is matched. Then cycles through nml_get_obj_data until the input is
2793 completed or there is an error. */
2796 namelist_read (st_parameter_dt
*dtp
)
2800 char nml_err_msg
[100];
2801 /* Pointer to the previously read object, in case attempt is made to read
2802 new object name. Should this fail, error message can give previous
2804 namelist_info
*prev_nl
= NULL
;
2806 dtp
->u
.p
.namelist_mode
= 1;
2807 dtp
->u
.p
.input_complete
= 0;
2808 dtp
->u
.p
.expanded_read
= 0;
2810 dtp
->u
.p
.eof_jump
= &eof_jump
;
2811 if (setjmp (eof_jump
))
2813 dtp
->u
.p
.eof_jump
= NULL
;
2814 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2818 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2819 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2820 node names or namelist on stdout. */
2823 switch (c
= next_char (dtp
))
2834 c
= next_char (dtp
);
2836 nml_query (dtp
, '=');
2838 unget_char (dtp
, c
);
2842 nml_query (dtp
, '?');
2848 /* Match the name of the namelist. */
2850 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2852 if (dtp
->u
.p
.nml_read_error
)
2855 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2856 c
= next_char (dtp
);
2857 if (!is_separator(c
))
2859 unget_char (dtp
, c
);
2863 /* Ready to read namelist objects. If there is an error in input
2864 from stdin, output the error message and continue. */
2866 while (!dtp
->u
.p
.input_complete
)
2868 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2872 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2875 u
= find_unit (options
.stderr_unit
);
2876 st_printf ("%s\n", nml_err_msg
);
2886 dtp
->u
.p
.eof_jump
= NULL
;
2891 /* All namelist error calls return from here */
2895 dtp
->u
.p
.eof_jump
= NULL
;
2898 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);