1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist input contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran 95 runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
39 /* List directed input. Several parsing subroutines are practically
40 reimplemented from formatted input, the reason being that there are
41 all kinds of small differences between formatted and list directed
45 /* Subroutines for reading characters from the input. Because a
46 repeat count is ambiguous with an integer, we have to read the
47 whole digit string before seeing if there is a '*' which signals
48 the repeat count. Since we can have a lot of potential leading
49 zeros, we have to be able to back up by arbitrary amount. Because
50 the input might not be seekable, we have to buffer the data
53 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
54 case '5': case '6': case '7': case '8': case '9'
56 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
59 /* This macro assumes that we're operating on a variable. */
61 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
62 || c == '\t' || c == '\r' || c == ';')
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
70 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
73 /* Save a character to a string buffer, enlarging it as necessary. */
76 push_char (st_parameter_dt
*dtp
, char c
)
80 if (dtp
->u
.p
.saved_string
== NULL
)
82 if (dtp
->u
.p
.scratch
== NULL
)
83 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
84 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
85 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
86 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
87 dtp
->u
.p
.saved_used
= 0;
90 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
92 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
93 new = get_mem (2 * dtp
->u
.p
.saved_length
);
95 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
97 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
98 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
99 free_mem (dtp
->u
.p
.saved_string
);
101 dtp
->u
.p
.saved_string
= new;
104 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
108 /* Free the input buffer if necessary. */
111 free_saved (st_parameter_dt
*dtp
)
113 if (dtp
->u
.p
.saved_string
== NULL
)
116 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
117 free_mem (dtp
->u
.p
.saved_string
);
119 dtp
->u
.p
.saved_string
= NULL
;
120 dtp
->u
.p
.saved_used
= 0;
124 /* Free the line buffer if necessary. */
127 free_line (st_parameter_dt
*dtp
)
129 dtp
->u
.p
.item_count
= 0;
130 dtp
->u
.p
.line_buffer_enabled
= 0;
132 if (dtp
->u
.p
.line_buffer
== NULL
)
135 free_mem (dtp
->u
.p
.line_buffer
);
136 dtp
->u
.p
.line_buffer
= NULL
;
141 next_char (st_parameter_dt
*dtp
)
147 if (dtp
->u
.p
.last_char
!= '\0')
150 c
= dtp
->u
.p
.last_char
;
151 dtp
->u
.p
.last_char
= '\0';
155 /* Read from line_buffer if enabled. */
157 if (dtp
->u
.p
.line_buffer_enabled
)
161 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
162 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
164 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
165 dtp
->u
.p
.item_count
++;
169 dtp
->u
.p
.item_count
= 0;
170 dtp
->u
.p
.line_buffer_enabled
= 0;
173 /* Handle the end-of-record and end-of-file conditions for
174 internal array unit. */
175 if (is_array_io (dtp
))
178 longjmp (*dtp
->u
.p
.eof_jump
, 1);
180 /* Check for "end-of-record" condition. */
181 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
186 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
189 /* Check for "end-of-file" condition. */
196 record
*= dtp
->u
.p
.current_unit
->recl
;
197 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
198 longjmp (*dtp
->u
.p
.eof_jump
, 1);
200 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
205 /* Get the next character and handle end-of-record conditions. */
209 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
211 if (is_stream_io (dtp
))
212 dtp
->u
.p
.current_unit
->strm_pos
++;
214 if (is_internal_unit (dtp
))
216 if (is_array_io (dtp
))
218 /* End of record is handled in the next pass through, above. The
219 check for NULL here is cautionary. */
222 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
226 dtp
->u
.p
.current_unit
->bytes_left
--;
232 longjmp (*dtp
->u
.p
.eof_jump
, 1);
243 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
248 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
250 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
251 longjmp (*dtp
->u
.p
.eof_jump
, 1);
252 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
256 longjmp (*dtp
->u
.p
.eof_jump
, 1);
262 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
267 /* Push a character back onto the input. */
270 unget_char (st_parameter_dt
*dtp
, char c
)
272 dtp
->u
.p
.last_char
= c
;
276 /* Skip over spaces in the input. Returns the nonspace character that
277 terminated the eating and also places it back on the input. */
280 eat_spaces (st_parameter_dt
*dtp
)
288 while (c
== ' ' || c
== '\t');
295 /* This function reads characters through to the end of the current line and
296 just ignores them. */
299 eat_line (st_parameter_dt
*dtp
)
302 if (!is_internal_unit (dtp
))
309 /* Skip over a separator. Technically, we don't always eat the whole
310 separator. This is because if we've processed the last input item,
311 then a separator is unnecessary. Plus the fact that operating
312 systems usually deliver console input on a line basis.
314 The upshot is that if we see a newline as part of reading a
315 separator, we stop reading. If there are more input items, we
316 continue reading the separator with finish_separator() which takes
317 care of the fact that we may or may not have seen a comma as part
321 eat_separator (st_parameter_dt
*dtp
)
326 dtp
->u
.p
.comma_flag
= 0;
332 if (dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
339 dtp
->u
.p
.comma_flag
= 1;
344 dtp
->u
.p
.input_complete
= 1;
352 if (dtp
->u
.p
.namelist_mode
)
356 while (c
== '\n' || c
== '\r' || c
== ' ');
366 if (dtp
->u
.p
.namelist_mode
)
382 while (c
== '\n' || c
== '\r' || c
== ' ');
388 if (dtp
->u
.p
.namelist_mode
)
389 { /* Eat a namelist comment. */
397 /* Fall Through... */
406 /* Finish processing a separator that was interrupted by a newline.
407 If we're here, then another data item is present, so we finish what
408 we started on the previous line. */
411 finish_separator (st_parameter_dt
*dtp
)
422 if (dtp
->u
.p
.comma_flag
)
426 c
= eat_spaces (dtp
);
427 if (c
== '\n' || c
== '\r')
434 dtp
->u
.p
.input_complete
= 1;
435 if (!dtp
->u
.p
.namelist_mode
)
444 if (dtp
->u
.p
.namelist_mode
)
460 /* This function is needed to catch bad conversions so that namelist can
461 attempt to see if dtp->u.p.saved_string contains a new object name rather
465 nml_bad_return (st_parameter_dt
*dtp
, char c
)
467 if (dtp
->u
.p
.namelist_mode
)
469 dtp
->u
.p
.nml_read_error
= 1;
476 /* Convert an unsigned string to an integer. The length value is -1
477 if we are working on a repeat count. Returns nonzero if we have a
478 range problem. As a side effect, frees the dtp->u.p.saved_string. */
481 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
483 char c
, *buffer
, message
[100];
485 GFC_INTEGER_LARGEST v
, max
, max10
;
487 buffer
= dtp
->u
.p
.saved_string
;
490 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
515 set_integer (dtp
->u
.p
.value
, v
, length
);
519 dtp
->u
.p
.repeat_count
= v
;
521 if (dtp
->u
.p
.repeat_count
== 0)
523 sprintf (message
, "Zero repeat count in item %d of list input",
524 dtp
->u
.p
.item_count
);
526 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
536 sprintf (message
, "Repeat count overflow in item %d of list input",
537 dtp
->u
.p
.item_count
);
539 sprintf (message
, "Integer overflow while reading item %d",
540 dtp
->u
.p
.item_count
);
543 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
549 /* Parse a repeat count for logical and complex values which cannot
550 begin with a digit. Returns nonzero if we are done, zero if we
551 should continue on. */
554 parse_repeat (st_parameter_dt
*dtp
)
556 char c
, message
[100];
582 repeat
= 10 * repeat
+ c
- '0';
584 if (repeat
> MAX_REPEAT
)
587 "Repeat count overflow in item %d of list input",
588 dtp
->u
.p
.item_count
);
590 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
600 "Zero repeat count in item %d of list input",
601 dtp
->u
.p
.item_count
);
603 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
615 dtp
->u
.p
.repeat_count
= repeat
;
622 sprintf (message
, "Bad repeat count in item %d of list input",
623 dtp
->u
.p
.item_count
);
624 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
629 /* To read a logical we have to look ahead in the input stream to make sure
630 there is not an equal sign indicating a variable name. To do this we use
631 line_buffer to point to a temporary buffer, pushing characters there for
632 possible later reading. */
635 l_push_char (st_parameter_dt
*dtp
, char c
)
637 if (dtp
->u
.p
.line_buffer
== NULL
)
639 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
640 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
643 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
647 /* Read a logical character on the input. */
650 read_logical (st_parameter_dt
*dtp
, int length
)
652 char c
, message
[100];
655 if (parse_repeat (dtp
))
658 c
= tolower (next_char (dtp
));
659 l_push_char (dtp
, c
);
665 l_push_char (dtp
, c
);
667 if (!is_separator(c
))
675 l_push_char (dtp
, c
);
677 if (!is_separator(c
))
684 c
= tolower (next_char (dtp
));
702 return; /* Null value. */
705 /* Save the character in case it is the beginning
706 of the next object name. */
711 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
712 dtp
->u
.p
.saved_length
= length
;
714 /* Eat trailing garbage. */
719 while (!is_separator (c
));
723 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
730 for(i
= 0; i
< 63; i
++)
735 /* All done if this is not a namelist read. */
736 if (!dtp
->u
.p
.namelist_mode
)
749 l_push_char (dtp
, c
);
752 dtp
->u
.p
.nml_read_error
= 1;
753 dtp
->u
.p
.line_buffer_enabled
= 1;
754 dtp
->u
.p
.item_count
= 0;
764 if (nml_bad_return (dtp
, c
))
769 sprintf (message
, "Bad logical value while reading item %d",
770 dtp
->u
.p
.item_count
);
771 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
776 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
777 dtp
->u
.p
.saved_length
= length
;
778 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
784 /* Reading integers is tricky because we can actually be reading a
785 repeat count. We have to store the characters in a buffer because
786 we could be reading an integer that is larger than the default int
787 used for repeat counts. */
790 read_integer (st_parameter_dt
*dtp
, int length
)
792 char c
, message
[100];
802 /* Fall through... */
808 CASE_SEPARATORS
: /* Single null. */
821 /* Take care of what may be a repeat count. */
833 push_char (dtp
, '\0');
836 CASE_SEPARATORS
: /* Not a repeat count. */
845 if (convert_integer (dtp
, -1, 0))
848 /* Get the real integer. */
863 /* Fall through... */
894 if (nml_bad_return (dtp
, c
))
899 sprintf (message
, "Bad integer for item %d in list input",
900 dtp
->u
.p
.item_count
);
901 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
909 push_char (dtp
, '\0');
910 if (convert_integer (dtp
, length
, negative
))
917 dtp
->u
.p
.saved_type
= BT_INTEGER
;
921 /* Read a character variable. */
924 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
926 char c
, quote
, message
[100];
928 quote
= ' '; /* Space means no quote character. */
938 unget_char (dtp
, c
); /* NULL value. */
948 if (dtp
->u
.p
.namelist_mode
)
950 if (dtp
->u
.p
.delim_status
== DELIM_APOSTROPHE
951 || dtp
->u
.p
.delim_status
== DELIM_QUOTE
952 || c
== '&' || c
== '$' || c
== '/')
958 /* Check to see if we are seeing a namelist object name by using the
959 line buffer and looking ahead for an '=' or '('. */
960 l_push_char (dtp
, c
);
963 for(i
= 0; i
< 63; i
++)
973 l_push_char (dtp
, c
);
974 dtp
->u
.p
.item_count
= 0;
975 dtp
->u
.p
.line_buffer_enabled
= 1;
980 l_push_char (dtp
, c
);
982 if (c
== '=' || c
== '(')
984 dtp
->u
.p
.item_count
= 0;
985 dtp
->u
.p
.nml_read_error
= 1;
986 dtp
->u
.p
.line_buffer_enabled
= 1;
991 /* The string is too long to be a valid object name so assume that it
992 is a string to be read in as a value. */
993 dtp
->u
.p
.item_count
= 0;
994 dtp
->u
.p
.line_buffer_enabled
= 1;
1002 /* Deal with a possible repeat count. */
1006 c
= next_char (dtp
);
1014 unget_char (dtp
, c
);
1015 goto done
; /* String was only digits! */
1018 push_char (dtp
, '\0');
1023 goto get_string
; /* Not a repeat count after all. */
1028 if (convert_integer (dtp
, -1, 0))
1031 /* Now get the real string. */
1033 c
= next_char (dtp
);
1037 unget_char (dtp
, c
); /* Repeated NULL values. */
1038 eat_separator (dtp
);
1054 c
= next_char (dtp
);
1065 /* See if we have a doubled quote character or the end of
1068 c
= next_char (dtp
);
1071 push_char (dtp
, quote
);
1075 unget_char (dtp
, c
);
1081 unget_char (dtp
, c
);
1085 if (c
!= '\n' && c
!= '\r')
1095 /* At this point, we have to have a separator, or else the string is
1098 c
= next_char (dtp
);
1099 if (is_separator (c
))
1101 unget_char (dtp
, c
);
1102 eat_separator (dtp
);
1103 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1109 sprintf (message
, "Invalid string input in item %d",
1110 dtp
->u
.p
.item_count
);
1111 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1116 /* Parse a component of a complex constant or a real number that we
1117 are sure is already there. This is a straight real number parser. */
1120 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1122 char c
, message
[100];
1125 c
= next_char (dtp
);
1126 if (c
== '-' || c
== '+')
1129 c
= next_char (dtp
);
1132 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1135 if (!isdigit (c
) && c
!= '.')
1137 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1145 seen_dp
= (c
== '.') ? 1 : 0;
1149 c
= next_char (dtp
);
1150 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1170 push_char (dtp
, 'e');
1175 push_char (dtp
, 'e');
1177 c
= next_char (dtp
);
1181 unget_char (dtp
, c
);
1190 c
= next_char (dtp
);
1191 if (c
!= '-' && c
!= '+')
1192 push_char (dtp
, '+');
1196 c
= next_char (dtp
);
1207 c
= next_char (dtp
);
1215 unget_char (dtp
, c
);
1224 unget_char (dtp
, c
);
1225 push_char (dtp
, '\0');
1227 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1233 /* Match INF and Infinity. */
1234 if ((c
== 'i' || c
== 'I')
1235 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1236 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1238 c
= next_char (dtp
);
1239 if ((c
!= 'i' && c
!= 'I')
1240 || ((c
== 'i' || c
== 'I')
1241 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1242 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1243 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1244 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1245 && (c
= next_char (dtp
))))
1247 if (is_separator (c
))
1248 unget_char (dtp
, c
);
1249 push_char (dtp
, 'i');
1250 push_char (dtp
, 'n');
1251 push_char (dtp
, 'f');
1255 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1256 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1257 && (c
= next_char (dtp
)))
1259 if (is_separator (c
))
1260 unget_char (dtp
, c
);
1261 push_char (dtp
, 'n');
1262 push_char (dtp
, 'a');
1263 push_char (dtp
, 'n');
1269 if (nml_bad_return (dtp
, c
))
1274 sprintf (message
, "Bad floating point number for item %d",
1275 dtp
->u
.p
.item_count
);
1276 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1282 /* Reading a complex number is straightforward because we can tell
1283 what it is right away. */
1286 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1291 if (parse_repeat (dtp
))
1294 c
= next_char (dtp
);
1301 unget_char (dtp
, c
);
1302 eat_separator (dtp
);
1310 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1315 c
= next_char (dtp
);
1316 if (c
== '\n' || c
== '\r')
1319 unget_char (dtp
, c
);
1322 != (dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';'))
1327 c
= next_char (dtp
);
1328 if (c
== '\n' || c
== '\r')
1331 unget_char (dtp
, c
);
1333 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1337 if (next_char (dtp
) != ')')
1340 c
= next_char (dtp
);
1341 if (!is_separator (c
))
1344 unget_char (dtp
, c
);
1345 eat_separator (dtp
);
1348 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1353 if (nml_bad_return (dtp
, c
))
1358 sprintf (message
, "Bad complex value in item %d of list input",
1359 dtp
->u
.p
.item_count
);
1360 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1364 /* Parse a real number with a possible repeat count. */
1367 read_real (st_parameter_dt
*dtp
, int length
)
1369 char c
, message
[100];
1375 c
= next_char (dtp
);
1376 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1394 unget_char (dtp
, c
); /* Single null. */
1395 eat_separator (dtp
);
1408 /* Get the digit string that might be a repeat count. */
1412 c
= next_char (dtp
);
1413 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1437 push_char (dtp
, 'e');
1439 c
= next_char (dtp
);
1443 push_char (dtp
, '\0');
1447 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1448 unget_char (dtp
, c
);
1457 if (convert_integer (dtp
, -1, 0))
1460 /* Now get the number itself. */
1462 c
= next_char (dtp
);
1463 if (is_separator (c
))
1464 { /* Repeated null value. */
1465 unget_char (dtp
, c
);
1466 eat_separator (dtp
);
1470 if (c
!= '-' && c
!= '+')
1471 push_char (dtp
, '+');
1476 c
= next_char (dtp
);
1479 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1482 if (!isdigit (c
) && c
!= '.')
1484 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1503 c
= next_char (dtp
);
1504 if (c
== ',' && dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
)
1531 push_char (dtp
, 'e');
1533 c
= next_char (dtp
);
1542 push_char (dtp
, 'e');
1544 c
= next_char (dtp
);
1545 if (c
!= '+' && c
!= '-')
1546 push_char (dtp
, '+');
1550 c
= next_char (dtp
);
1560 c
= next_char (dtp
);
1577 unget_char (dtp
, c
);
1578 eat_separator (dtp
);
1579 push_char (dtp
, '\0');
1580 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1584 dtp
->u
.p
.saved_type
= BT_REAL
;
1588 l_push_char (dtp
, c
);
1591 /* Match INF and Infinity. */
1592 if (c
== 'i' || c
== 'I')
1594 c
= next_char (dtp
);
1595 l_push_char (dtp
, c
);
1596 if (c
!= 'n' && c
!= 'N')
1598 c
= next_char (dtp
);
1599 l_push_char (dtp
, c
);
1600 if (c
!= 'f' && c
!= 'F')
1602 c
= next_char (dtp
);
1603 l_push_char (dtp
, c
);
1604 if (!is_separator (c
))
1606 if (c
!= 'i' && c
!= 'I')
1608 c
= next_char (dtp
);
1609 l_push_char (dtp
, c
);
1610 if (c
!= 'n' && c
!= 'N')
1612 c
= next_char (dtp
);
1613 l_push_char (dtp
, c
);
1614 if (c
!= 'i' && c
!= 'I')
1616 c
= next_char (dtp
);
1617 l_push_char (dtp
, c
);
1618 if (c
!= 't' && c
!= 'T')
1620 c
= next_char (dtp
);
1621 l_push_char (dtp
, c
);
1622 if (c
!= 'y' && c
!= 'Y')
1624 c
= next_char (dtp
);
1625 l_push_char (dtp
, c
);
1631 c
= next_char (dtp
);
1632 l_push_char (dtp
, c
);
1633 if (c
!= 'a' && c
!= 'A')
1635 c
= next_char (dtp
);
1636 l_push_char (dtp
, c
);
1637 if (c
!= 'n' && c
!= 'N')
1639 c
= next_char (dtp
);
1640 l_push_char (dtp
, c
);
1643 if (!is_separator (c
))
1646 if (dtp
->u
.p
.namelist_mode
)
1648 if (c
== ' ' || c
=='\n' || c
== '\r')
1651 c
= next_char (dtp
);
1652 while (c
== ' ' || c
=='\n' || c
== '\r');
1654 l_push_char (dtp
, c
);
1663 push_char (dtp
, 'i');
1664 push_char (dtp
, 'n');
1665 push_char (dtp
, 'f');
1669 push_char (dtp
, 'n');
1670 push_char (dtp
, 'a');
1671 push_char (dtp
, 'n');
1678 if (dtp
->u
.p
.namelist_mode
)
1680 dtp
->u
.p
.nml_read_error
= 1;
1681 dtp
->u
.p
.line_buffer_enabled
= 1;
1682 dtp
->u
.p
.item_count
= 0;
1688 if (nml_bad_return (dtp
, c
))
1693 sprintf (message
, "Bad real number in item %d of list input",
1694 dtp
->u
.p
.item_count
);
1695 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1699 /* Check the current type against the saved type to make sure they are
1700 compatible. Returns nonzero if incompatible. */
1703 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1707 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1709 sprintf (message
, "Read type %s where %s was expected for item %d",
1710 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1711 dtp
->u
.p
.item_count
);
1713 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1717 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1720 if (dtp
->u
.p
.saved_length
!= len
)
1723 "Read kind %d %s where kind %d is required for item %d",
1724 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1725 dtp
->u
.p
.item_count
);
1726 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1734 /* Top level data transfer subroutine for list reads. Because we have
1735 to deal with repeat counts, the data item is always saved after
1736 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1737 greater than one, we copy the data item multiple times. */
1740 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1747 dtp
->u
.p
.namelist_mode
= 0;
1749 dtp
->u
.p
.eof_jump
= &eof_jump
;
1750 if (setjmp (eof_jump
))
1752 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1756 if (dtp
->u
.p
.first_item
)
1758 dtp
->u
.p
.first_item
= 0;
1759 dtp
->u
.p
.input_complete
= 0;
1760 dtp
->u
.p
.repeat_count
= 1;
1761 dtp
->u
.p
.at_eol
= 0;
1763 c
= eat_spaces (dtp
);
1764 if (is_separator (c
))
1766 /* Found a null value. */
1767 eat_separator (dtp
);
1768 dtp
->u
.p
.repeat_count
= 0;
1770 /* eat_separator sets this flag if the separator was a comma. */
1771 if (dtp
->u
.p
.comma_flag
)
1774 /* eat_separator sets this flag if the separator was a \n or \r. */
1775 if (dtp
->u
.p
.at_eol
)
1776 finish_separator (dtp
);
1784 if (dtp
->u
.p
.input_complete
)
1787 if (dtp
->u
.p
.repeat_count
> 0)
1789 if (check_type (dtp
, type
, kind
))
1794 if (dtp
->u
.p
.at_eol
)
1795 finish_separator (dtp
);
1799 /* Trailing spaces prior to end of line. */
1800 if (dtp
->u
.p
.at_eol
)
1801 finish_separator (dtp
);
1804 dtp
->u
.p
.saved_type
= BT_NULL
;
1805 dtp
->u
.p
.repeat_count
= 1;
1811 read_integer (dtp
, kind
);
1814 read_logical (dtp
, kind
);
1817 read_character (dtp
, kind
);
1820 read_real (dtp
, kind
);
1823 read_complex (dtp
, kind
, size
);
1826 internal_error (&dtp
->common
, "Bad type for list read");
1829 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1830 dtp
->u
.p
.saved_length
= size
;
1832 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1836 switch (dtp
->u
.p
.saved_type
)
1842 memcpy (p
, dtp
->u
.p
.value
, size
);
1846 if (dtp
->u
.p
.saved_string
)
1848 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1849 ? (int) size
: dtp
->u
.p
.saved_used
;
1850 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1853 /* Just delimiters encountered, nothing to copy but SPACE. */
1857 memset (((char *) p
) + m
, ' ', size
- m
);
1864 if (--dtp
->u
.p
.repeat_count
<= 0)
1868 dtp
->u
.p
.eof_jump
= NULL
;
1873 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1874 size_t size
, size_t nelems
)
1881 /* Big loop over all the elements. */
1882 for (elem
= 0; elem
< nelems
; elem
++)
1884 dtp
->u
.p
.item_count
++;
1885 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1890 /* Finish a list read. */
1893 finish_list_read (st_parameter_dt
*dtp
)
1899 if (dtp
->u
.p
.at_eol
)
1901 dtp
->u
.p
.at_eol
= 0;
1907 c
= next_char (dtp
);
1914 void namelist_read (st_parameter_dt *dtp)
1916 static void nml_match_name (char *name, int len)
1917 static int nml_query (st_parameter_dt *dtp)
1918 static int nml_get_obj_data (st_parameter_dt *dtp,
1919 namelist_info **prev_nl, char *, size_t)
1921 static void nml_untouch_nodes (st_parameter_dt *dtp)
1922 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1924 static int nml_parse_qualifier(descriptor_dimension * ad,
1925 array_loop_spec * ls, int rank, char *)
1926 static void nml_touch_nodes (namelist_info * nl)
1927 static int nml_read_obj (namelist_info *nl, index_type offset,
1928 namelist_info **prev_nl, char *, size_t,
1929 index_type clow, index_type chigh)
1933 /* Inputs a rank-dimensional qualifier, which can contain
1934 singlets, doublets, triplets or ':' with the standard meanings. */
1937 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1938 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1945 int is_array_section
, is_char
;
1949 is_array_section
= 0;
1950 dtp
->u
.p
.expanded_read
= 0;
1952 /* See if this is a character substring qualifier we are looking for. */
1959 /* The next character in the stream should be the '('. */
1961 c
= next_char (dtp
);
1963 /* Process the qualifier, by dimension and triplet. */
1965 for (dim
=0; dim
< rank
; dim
++ )
1967 for (indx
=0; indx
<3; indx
++)
1973 /* Process a potential sign. */
1974 c
= next_char (dtp
);
1985 unget_char (dtp
, c
);
1989 /* Process characters up to the next ':' , ',' or ')'. */
1992 c
= next_char (dtp
);
1997 is_array_section
= 1;
2001 if ((c
==',' && dim
== rank
-1)
2002 || (c
==')' && dim
< rank
-1))
2005 sprintf (parse_err_msg
, "Bad substring qualifier");
2007 sprintf (parse_err_msg
, "Bad number of index fields");
2016 case ' ': case '\t':
2018 c
= next_char (dtp
);
2023 sprintf (parse_err_msg
,
2024 "Bad character in substring qualifier");
2026 sprintf (parse_err_msg
, "Bad character in index");
2030 if ((c
== ',' || c
== ')') && indx
== 0
2031 && dtp
->u
.p
.saved_string
== 0)
2034 sprintf (parse_err_msg
, "Null substring qualifier");
2036 sprintf (parse_err_msg
, "Null index field");
2040 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2041 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2044 sprintf (parse_err_msg
, "Bad substring qualifier");
2046 sprintf (parse_err_msg
, "Bad index triplet");
2050 if (is_char
&& !is_array_section
)
2052 sprintf (parse_err_msg
,
2053 "Missing colon in substring qualifier");
2057 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2059 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2060 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2066 /* Now read the index. */
2067 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2070 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2072 sprintf (parse_err_msg
, "Bad integer in index");
2078 /* Feed the index values to the triplet arrays. */
2082 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2084 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2086 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2089 /* Singlet or doublet indices. */
2090 if (c
==',' || c
==')')
2094 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2096 /* If -std=f95/2003 or an array section is specified,
2097 do not allow excess data to be processed. */
2098 if (is_array_section
== 1
2099 || compile_options
.allow_std
< GFC_STD_GNU
)
2100 ls
[dim
].end
= ls
[dim
].start
;
2102 dtp
->u
.p
.expanded_read
= 1;
2105 /* Check for non-zero rank. */
2106 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2113 /* Check the values of the triplet indices. */
2114 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2115 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2116 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2117 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2120 sprintf (parse_err_msg
, "Substring out of range");
2122 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2126 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2127 || (ls
[dim
].step
== 0))
2129 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2133 /* Initialise the loop index counter. */
2134 ls
[dim
].idx
= ls
[dim
].start
;
2144 static namelist_info
*
2145 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2147 namelist_info
* t
= dtp
->u
.p
.ionml
;
2150 if (strcmp (var_name
, t
->var_name
) == 0)
2160 /* Visits all the components of a derived type that have
2161 not explicitly been identified in the namelist input.
2162 touched is set and the loop specification initialised
2163 to default values */
2166 nml_touch_nodes (namelist_info
* nl
)
2168 index_type len
= strlen (nl
->var_name
) + 1;
2170 char * ext_name
= (char*)get_mem (len
+ 1);
2171 memcpy (ext_name
, nl
->var_name
, len
-1);
2172 memcpy (ext_name
+ len
- 1, "%", 2);
2173 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2175 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2178 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2180 nl
->ls
[dim
].step
= 1;
2181 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2182 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2183 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2189 free_mem (ext_name
);
2193 /* Resets touched for the entire list of nml_nodes, ready for a
2197 nml_untouch_nodes (st_parameter_dt
*dtp
)
2200 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2205 /* Attempts to input name to namelist name. Returns
2206 dtp->u.p.nml_read_error = 1 on no match. */
2209 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2213 dtp
->u
.p
.nml_read_error
= 0;
2214 for (i
= 0; i
< len
; i
++)
2216 c
= next_char (dtp
);
2217 if (tolower (c
) != tolower (name
[i
]))
2219 dtp
->u
.p
.nml_read_error
= 1;
2225 /* If the namelist read is from stdin, output the current state of the
2226 namelist to stdout. This is used to implement the non-standard query
2227 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2228 the names alone are printed. */
2231 nml_query (st_parameter_dt
*dtp
, char c
)
2233 gfc_unit
* temp_unit
;
2238 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2241 /* Store the current unit and transfer to stdout. */
2243 temp_unit
= dtp
->u
.p
.current_unit
;
2244 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2246 if (dtp
->u
.p
.current_unit
)
2248 dtp
->u
.p
.mode
= WRITING
;
2249 next_record (dtp
, 0);
2251 /* Write the namelist in its entirety. */
2254 namelist_write (dtp
);
2256 /* Or write the list of names. */
2260 /* "&namelist_name\n" */
2262 len
= dtp
->namelist_name_len
;
2264 p
= write_block (dtp
, len
+ 3);
2266 p
= write_block (dtp
, len
+ 2);
2271 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2273 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2275 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2277 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2281 len
= strlen (nl
->var_name
);
2283 p
= write_block (dtp
, len
+ 3);
2285 p
= write_block (dtp
, len
+ 2);
2290 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2292 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2294 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2301 p
= write_block (dtp
, 6);
2303 p
= write_block (dtp
, 5);
2308 memcpy (p
, "&end\r\n", 6);
2310 memcpy (p
, "&end\n", 5);
2314 /* Flush the stream to force immediate output. */
2316 flush (dtp
->u
.p
.current_unit
->s
);
2317 unlock_unit (dtp
->u
.p
.current_unit
);
2322 /* Restore the current unit. */
2324 dtp
->u
.p
.current_unit
= temp_unit
;
2325 dtp
->u
.p
.mode
= READING
;
2329 /* Reads and stores the input for the namelist object nl. For an array,
2330 the function loops over the ranges defined by the loop specification.
2331 This default to all the data or to the specification from a qualifier.
2332 nml_read_obj recursively calls itself to read derived types. It visits
2333 all its own components but only reads data for those that were touched
2334 when the name was parsed. If a read error is encountered, an attempt is
2335 made to return to read a new object name because the standard allows too
2336 little data to be available. On the other hand, too much data is an
2340 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2341 namelist_info
**pprev_nl
, char *nml_err_msg
,
2342 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2344 namelist_info
* cmp
;
2351 index_type obj_name_len
;
2354 /* This object not touched in name parsing. */
2359 dtp
->u
.p
.repeat_count
= 0;
2365 case GFC_DTYPE_INTEGER
:
2366 case GFC_DTYPE_LOGICAL
:
2370 case GFC_DTYPE_REAL
:
2371 dlen
= size_from_real_kind (len
);
2374 case GFC_DTYPE_COMPLEX
:
2375 dlen
= size_from_complex_kind (len
);
2378 case GFC_DTYPE_CHARACTER
:
2379 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2388 /* Update the pointer to the data, using the current index vector */
2390 pdata
= (void*)(nl
->mem_pos
+ offset
);
2391 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2392 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2393 nl
->dim
[dim
].stride
* nl
->size
);
2395 /* Reset the error flag and try to read next value, if
2396 dtp->u.p.repeat_count=0 */
2398 dtp
->u
.p
.nml_read_error
= 0;
2400 if (--dtp
->u
.p
.repeat_count
<= 0)
2402 if (dtp
->u
.p
.input_complete
)
2404 if (dtp
->u
.p
.at_eol
)
2405 finish_separator (dtp
);
2406 if (dtp
->u
.p
.input_complete
)
2409 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2410 after the switch block. */
2412 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2417 case GFC_DTYPE_INTEGER
:
2418 read_integer (dtp
, len
);
2421 case GFC_DTYPE_LOGICAL
:
2422 read_logical (dtp
, len
);
2425 case GFC_DTYPE_CHARACTER
:
2426 read_character (dtp
, len
);
2429 case GFC_DTYPE_REAL
:
2430 read_real (dtp
, len
);
2433 case GFC_DTYPE_COMPLEX
:
2434 read_complex (dtp
, len
, dlen
);
2437 case GFC_DTYPE_DERIVED
:
2438 obj_name_len
= strlen (nl
->var_name
) + 1;
2439 obj_name
= get_mem (obj_name_len
+1);
2440 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2441 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2443 /* If reading a derived type, disable the expanded read warning
2444 since a single object can have multiple reads. */
2445 dtp
->u
.p
.expanded_read
= 0;
2447 /* Now loop over the components. Update the component pointer
2448 with the return value from nml_write_obj. This loop jumps
2449 past nested derived types by testing if the potential
2450 component name contains '%'. */
2452 for (cmp
= nl
->next
;
2454 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2455 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2459 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2460 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2461 clow
, chigh
) == FAILURE
)
2463 free_mem (obj_name
);
2467 if (dtp
->u
.p
.input_complete
)
2469 free_mem (obj_name
);
2474 free_mem (obj_name
);
2478 snprintf (nml_err_msg
, nml_err_msg_size
,
2479 "Bad type for namelist object %s", nl
->var_name
);
2480 internal_error (&dtp
->common
, nml_err_msg
);
2485 /* The standard permits array data to stop short of the number of
2486 elements specified in the loop specification. In this case, we
2487 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2488 nml_get_obj_data and an attempt is made to read object name. */
2491 if (dtp
->u
.p
.nml_read_error
)
2493 dtp
->u
.p
.expanded_read
= 0;
2497 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2499 dtp
->u
.p
.expanded_read
= 0;
2503 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2504 This comes about because the read functions return BT_types. */
2506 switch (dtp
->u
.p
.saved_type
)
2513 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2517 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2518 pdata
= (void*)( pdata
+ clow
- 1 );
2519 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2521 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2528 /* Warn if a non-standard expanded read occurs. A single read of a
2529 single object is acceptable. If a second read occurs, issue a warning
2530 and set the flag to zero to prevent further warnings. */
2531 if (dtp
->u
.p
.expanded_read
== 2)
2533 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2534 dtp
->u
.p
.expanded_read
= 0;
2537 /* If the expanded read warning flag is set, increment it,
2538 indicating that a single read has occurred. */
2539 if (dtp
->u
.p
.expanded_read
>= 1)
2540 dtp
->u
.p
.expanded_read
++;
2542 /* Break out of loop if scalar. */
2546 /* Now increment the index vector. */
2551 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2553 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2555 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2557 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2559 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2563 } while (!nml_carry
);
2565 if (dtp
->u
.p
.repeat_count
> 1)
2567 snprintf (nml_err_msg
, nml_err_msg_size
,
2568 "Repeat count too large for namelist object %s", nl
->var_name
);
2578 /* Parses the object name, including array and substring qualifiers. It
2579 iterates over derived type components, touching those components and
2580 setting their loop specifications, if there is a qualifier. If the
2581 object is itself a derived type, its components and subcomponents are
2582 touched. nml_read_obj is called at the end and this reads the data in
2583 the manner specified by the object name. */
2586 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2587 char *nml_err_msg
, size_t nml_err_msg_size
)
2591 namelist_info
* first_nl
= NULL
;
2592 namelist_info
* root_nl
= NULL
;
2593 int dim
, parsed_rank
;
2595 index_type clow
, chigh
;
2596 int non_zero_rank_count
;
2598 /* Look for end of input or object name. If '?' or '=?' are encountered
2599 in stdin, print the node names or the namelist to stdout. */
2601 eat_separator (dtp
);
2602 if (dtp
->u
.p
.input_complete
)
2605 if (dtp
->u
.p
.at_eol
)
2606 finish_separator (dtp
);
2607 if (dtp
->u
.p
.input_complete
)
2610 c
= next_char (dtp
);
2614 c
= next_char (dtp
);
2617 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2620 nml_query (dtp
, '=');
2624 nml_query (dtp
, '?');
2629 nml_match_name (dtp
, "end", 3);
2630 if (dtp
->u
.p
.nml_read_error
)
2632 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2636 dtp
->u
.p
.input_complete
= 1;
2643 /* Untouch all nodes of the namelist and reset the flag that is set for
2644 derived type components. */
2646 nml_untouch_nodes (dtp
);
2648 non_zero_rank_count
= 0;
2650 /* Get the object name - should '!' and '\n' be permitted separators? */
2658 if (!is_separator (c
))
2659 push_char (dtp
, tolower(c
));
2660 c
= next_char (dtp
);
2661 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2663 unget_char (dtp
, c
);
2665 /* Check that the name is in the namelist and get pointer to object.
2666 Three error conditions exist: (i) An attempt is being made to
2667 identify a non-existent object, following a failed data read or
2668 (ii) The object name does not exist or (iii) Too many data items
2669 are present for an object. (iii) gives the same error message
2672 push_char (dtp
, '\0');
2676 size_t var_len
= strlen (root_nl
->var_name
);
2678 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2679 char ext_name
[var_len
+ saved_len
+ 1];
2681 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2682 if (dtp
->u
.p
.saved_string
)
2683 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2684 ext_name
[var_len
+ saved_len
] = '\0';
2685 nl
= find_nml_node (dtp
, ext_name
);
2688 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2692 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2693 snprintf (nml_err_msg
, nml_err_msg_size
,
2694 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2697 snprintf (nml_err_msg
, nml_err_msg_size
,
2698 "Cannot match namelist object name %s",
2699 dtp
->u
.p
.saved_string
);
2704 /* Get the length, data length, base pointer and rank of the variable.
2705 Set the default loop specification first. */
2707 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2709 nl
->ls
[dim
].step
= 1;
2710 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2711 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2712 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2715 /* Check to see if there is a qualifier: if so, parse it.*/
2717 if (c
== '(' && nl
->var_rank
)
2720 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2721 nml_err_msg
, &parsed_rank
) == FAILURE
)
2723 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2724 snprintf (nml_err_msg_end
,
2725 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2726 " for namelist variable %s", nl
->var_name
);
2730 if (parsed_rank
> 0)
2731 non_zero_rank_count
++;
2733 c
= next_char (dtp
);
2734 unget_char (dtp
, c
);
2736 else if (nl
->var_rank
> 0)
2737 non_zero_rank_count
++;
2739 /* Now parse a derived type component. The root namelist_info address
2740 is backed up, as is the previous component level. The component flag
2741 is set and the iteration is made by jumping back to get_name. */
2745 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2747 snprintf (nml_err_msg
, nml_err_msg_size
,
2748 "Attempt to get derived component for %s", nl
->var_name
);
2752 if (!component_flag
)
2757 c
= next_char (dtp
);
2761 /* Parse a character qualifier, if present. chigh = 0 is a default
2762 that signals that the string length = string_length. */
2767 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2769 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2770 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2772 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2775 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2776 snprintf (nml_err_msg_end
,
2777 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2778 " for namelist variable %s", nl
->var_name
);
2782 clow
= ind
[0].start
;
2785 if (ind
[0].step
!= 1)
2787 snprintf (nml_err_msg
, nml_err_msg_size
,
2788 "Step not allowed in substring qualifier"
2789 " for namelist object %s", nl
->var_name
);
2793 c
= next_char (dtp
);
2794 unget_char (dtp
, c
);
2797 /* If a derived type touch its components and restore the root
2798 namelist_info if we have parsed a qualified derived type
2801 if (nl
->type
== GFC_DTYPE_DERIVED
)
2802 nml_touch_nodes (nl
);
2806 /* Make sure no extraneous qualifiers are there. */
2810 snprintf (nml_err_msg
, nml_err_msg_size
,
2811 "Qualifier for a scalar or non-character namelist object %s",
2816 /* Make sure there is no more than one non-zero rank object. */
2817 if (non_zero_rank_count
> 1)
2819 snprintf (nml_err_msg
, nml_err_msg_size
,
2820 "Multiple sub-objects with non-zero rank in namelist object %s",
2822 non_zero_rank_count
= 0;
2826 /* According to the standard, an equal sign MUST follow an object name. The
2827 following is possibly lax - it allows comments, blank lines and so on to
2828 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2832 eat_separator (dtp
);
2833 if (dtp
->u
.p
.input_complete
)
2836 if (dtp
->u
.p
.at_eol
)
2837 finish_separator (dtp
);
2838 if (dtp
->u
.p
.input_complete
)
2841 c
= next_char (dtp
);
2845 snprintf (nml_err_msg
, nml_err_msg_size
,
2846 "Equal sign must follow namelist object name %s",
2851 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2852 clow
, chigh
) == FAILURE
)
2862 /* Entry point for namelist input. Goes through input until namelist name
2863 is matched. Then cycles through nml_get_obj_data until the input is
2864 completed or there is an error. */
2867 namelist_read (st_parameter_dt
*dtp
)
2871 char nml_err_msg
[200];
2872 /* Pointer to the previously read object, in case attempt is made to read
2873 new object name. Should this fail, error message can give previous
2875 namelist_info
*prev_nl
= NULL
;
2877 dtp
->u
.p
.namelist_mode
= 1;
2878 dtp
->u
.p
.input_complete
= 0;
2879 dtp
->u
.p
.expanded_read
= 0;
2881 dtp
->u
.p
.eof_jump
= &eof_jump
;
2882 if (setjmp (eof_jump
))
2884 dtp
->u
.p
.eof_jump
= NULL
;
2885 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2889 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2890 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2891 node names or namelist on stdout. */
2894 switch (c
= next_char (dtp
))
2905 c
= next_char (dtp
);
2907 nml_query (dtp
, '=');
2909 unget_char (dtp
, c
);
2913 nml_query (dtp
, '?');
2919 /* Match the name of the namelist. */
2921 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2923 if (dtp
->u
.p
.nml_read_error
)
2926 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2927 c
= next_char (dtp
);
2928 if (!is_separator(c
))
2930 unget_char (dtp
, c
);
2934 /* Ready to read namelist objects. If there is an error in input
2935 from stdin, output the error message and continue. */
2937 while (!dtp
->u
.p
.input_complete
)
2939 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2944 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2947 u
= find_unit (options
.stderr_unit
);
2948 st_printf ("%s\n", nml_err_msg
);
2958 dtp
->u
.p
.eof_jump
= NULL
;
2963 /* All namelist error calls return from here */
2967 dtp
->u
.p
.eof_jump
= NULL
;
2970 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);