1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
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 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
35 /* List directed input. Several parsing subroutines are practically
36 reimplemented from formatted input, the reason being that there are
37 all kinds of small differences between formatted and list directed
41 /* Subroutines for reading characters from the input. Because a
42 repeat count is ambiguous with an integer, we have to read the
43 whole digit string before seeing if there is a '*' which signals
44 the repeat count. Since we can have a lot of potential leading
45 zeros, we have to be able to back up by arbitrary amount. Because
46 the input might not be seekable, we have to buffer the data
49 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
50 case '5': case '6': case '7': case '8': case '9'
52 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
55 /* This macro assumes that we're operating on a variable. */
57 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
58 || c == '\t' || c == '\r' || c == ';')
60 /* Maximum repeat count. Less than ten times the maximum signed int32. */
62 #define MAX_REPEAT 200000000
66 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt
*dtp
, char c
)
76 if (dtp
->u
.p
.saved_string
== NULL
)
78 dtp
->u
.p
.saved_string
= get_mem (SCRATCH_SIZE
);
79 // memset below should be commented out.
80 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
81 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
82 dtp
->u
.p
.saved_used
= 0;
85 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
87 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
88 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
90 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
91 dtp
->u
.p
.saved_string
= new;
93 // Also this should not be necessary.
94 memset (new + dtp
->u
.p
.saved_used
, 0,
95 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
99 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
103 /* Free the input buffer if necessary. */
106 free_saved (st_parameter_dt
*dtp
)
108 if (dtp
->u
.p
.saved_string
== NULL
)
111 free_mem (dtp
->u
.p
.saved_string
);
113 dtp
->u
.p
.saved_string
= NULL
;
114 dtp
->u
.p
.saved_used
= 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt
*dtp
)
123 dtp
->u
.p
.item_count
= 0;
124 dtp
->u
.p
.line_buffer_enabled
= 0;
126 if (dtp
->u
.p
.line_buffer
== NULL
)
129 free_mem (dtp
->u
.p
.line_buffer
);
130 dtp
->u
.p
.line_buffer
= NULL
;
135 next_char (st_parameter_dt
*dtp
)
142 if (dtp
->u
.p
.last_char
!= '\0')
145 c
= dtp
->u
.p
.last_char
;
146 dtp
->u
.p
.last_char
= '\0';
150 /* Read from line_buffer if enabled. */
152 if (dtp
->u
.p
.line_buffer_enabled
)
156 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
157 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
159 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
160 dtp
->u
.p
.item_count
++;
164 dtp
->u
.p
.item_count
= 0;
165 dtp
->u
.p
.line_buffer_enabled
= 0;
168 /* Handle the end-of-record and end-of-file conditions for
169 internal array unit. */
170 if (is_array_io (dtp
))
173 longjmp (*dtp
->u
.p
.eof_jump
, 1);
175 /* Check for "end-of-record" condition. */
176 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
181 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
184 /* Check for "end-of-file" condition. */
191 record
*= dtp
->u
.p
.current_unit
->recl
;
192 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
193 longjmp (*dtp
->u
.p
.eof_jump
, 1);
195 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
200 /* Get the next character and handle end-of-record conditions. */
202 if (is_internal_unit (dtp
))
204 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, 1);
207 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
211 if (is_array_io (dtp
))
213 /* Check whether we hit EOF. */
216 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
219 dtp
->u
.p
.current_unit
->bytes_left
--;
224 longjmp (*dtp
->u
.p
.eof_jump
, 1);
234 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
238 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
239 longjmp (*dtp
->u
.p
.eof_jump
, 1);
240 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
245 if (is_stream_io (dtp
) && cc
!= EOF
)
246 dtp
->u
.p
.current_unit
->strm_pos
++;
250 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
255 /* Push a character back onto the input. */
258 unget_char (st_parameter_dt
*dtp
, char c
)
260 dtp
->u
.p
.last_char
= c
;
264 /* Skip over spaces in the input. Returns the nonspace character that
265 terminated the eating and also places it back on the input. */
268 eat_spaces (st_parameter_dt
*dtp
)
276 while (c
== ' ' || c
== '\t');
283 /* This function reads characters through to the end of the current line and
284 just ignores them. */
287 eat_line (st_parameter_dt
*dtp
)
290 if (!is_internal_unit (dtp
))
297 /* Skip over a separator. Technically, we don't always eat the whole
298 separator. This is because if we've processed the last input item,
299 then a separator is unnecessary. Plus the fact that operating
300 systems usually deliver console input on a line basis.
302 The upshot is that if we see a newline as part of reading a
303 separator, we stop reading. If there are more input items, we
304 continue reading the separator with finish_separator() which takes
305 care of the fact that we may or may not have seen a comma as part
309 eat_separator (st_parameter_dt
*dtp
)
314 dtp
->u
.p
.comma_flag
= 0;
320 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
327 dtp
->u
.p
.comma_flag
= 1;
332 dtp
->u
.p
.input_complete
= 1;
346 if (dtp
->u
.p
.namelist_mode
)
362 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
368 if (dtp
->u
.p
.namelist_mode
)
369 { /* Eat a namelist comment. */
377 /* Fall Through... */
386 /* Finish processing a separator that was interrupted by a newline.
387 If we're here, then another data item is present, so we finish what
388 we started on the previous line. */
391 finish_separator (st_parameter_dt
*dtp
)
402 if (dtp
->u
.p
.comma_flag
)
406 c
= eat_spaces (dtp
);
407 if (c
== '\n' || c
== '\r')
414 dtp
->u
.p
.input_complete
= 1;
415 if (!dtp
->u
.p
.namelist_mode
)
424 if (dtp
->u
.p
.namelist_mode
)
440 /* This function is needed to catch bad conversions so that namelist can
441 attempt to see if dtp->u.p.saved_string contains a new object name rather
445 nml_bad_return (st_parameter_dt
*dtp
, char c
)
447 if (dtp
->u
.p
.namelist_mode
)
449 dtp
->u
.p
.nml_read_error
= 1;
456 /* Convert an unsigned string to an integer. The length value is -1
457 if we are working on a repeat count. Returns nonzero if we have a
458 range problem. As a side effect, frees the dtp->u.p.saved_string. */
461 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
463 char c
, *buffer
, message
[100];
465 GFC_INTEGER_LARGEST v
, max
, max10
;
467 buffer
= dtp
->u
.p
.saved_string
;
470 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
495 set_integer (dtp
->u
.p
.value
, v
, length
);
499 dtp
->u
.p
.repeat_count
= v
;
501 if (dtp
->u
.p
.repeat_count
== 0)
503 sprintf (message
, "Zero repeat count in item %d of list input",
504 dtp
->u
.p
.item_count
);
506 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
516 sprintf (message
, "Repeat count overflow in item %d of list input",
517 dtp
->u
.p
.item_count
);
519 sprintf (message
, "Integer overflow while reading item %d",
520 dtp
->u
.p
.item_count
);
523 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
529 /* Parse a repeat count for logical and complex values which cannot
530 begin with a digit. Returns nonzero if we are done, zero if we
531 should continue on. */
534 parse_repeat (st_parameter_dt
*dtp
)
536 char c
, message
[100];
562 repeat
= 10 * repeat
+ c
- '0';
564 if (repeat
> MAX_REPEAT
)
567 "Repeat count overflow in item %d of list input",
568 dtp
->u
.p
.item_count
);
570 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
580 "Zero repeat count in item %d of list input",
581 dtp
->u
.p
.item_count
);
583 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
595 dtp
->u
.p
.repeat_count
= repeat
;
602 sprintf (message
, "Bad repeat count in item %d of list input",
603 dtp
->u
.p
.item_count
);
604 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
609 /* To read a logical we have to look ahead in the input stream to make sure
610 there is not an equal sign indicating a variable name. To do this we use
611 line_buffer to point to a temporary buffer, pushing characters there for
612 possible later reading. */
615 l_push_char (st_parameter_dt
*dtp
, char c
)
617 if (dtp
->u
.p
.line_buffer
== NULL
)
619 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
620 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
623 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
627 /* Read a logical character on the input. */
630 read_logical (st_parameter_dt
*dtp
, int length
)
632 char c
, message
[100];
635 if (parse_repeat (dtp
))
638 c
= tolower (next_char (dtp
));
639 l_push_char (dtp
, c
);
645 l_push_char (dtp
, c
);
647 if (!is_separator(c
))
655 l_push_char (dtp
, c
);
657 if (!is_separator(c
))
664 c
= tolower (next_char (dtp
));
682 return; /* Null value. */
685 /* Save the character in case it is the beginning
686 of the next object name. */
691 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
692 dtp
->u
.p
.saved_length
= length
;
694 /* Eat trailing garbage. */
699 while (!is_separator (c
));
703 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
710 for(i
= 0; i
< 63; i
++)
715 /* All done if this is not a namelist read. */
716 if (!dtp
->u
.p
.namelist_mode
)
729 l_push_char (dtp
, c
);
732 dtp
->u
.p
.nml_read_error
= 1;
733 dtp
->u
.p
.line_buffer_enabled
= 1;
734 dtp
->u
.p
.item_count
= 0;
744 if (nml_bad_return (dtp
, c
))
749 sprintf (message
, "Bad logical value while reading item %d",
750 dtp
->u
.p
.item_count
);
751 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
756 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
757 dtp
->u
.p
.saved_length
= length
;
758 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
764 /* Reading integers is tricky because we can actually be reading a
765 repeat count. We have to store the characters in a buffer because
766 we could be reading an integer that is larger than the default int
767 used for repeat counts. */
770 read_integer (st_parameter_dt
*dtp
, int length
)
772 char c
, message
[100];
782 /* Fall through... */
788 CASE_SEPARATORS
: /* Single null. */
801 /* Take care of what may be a repeat count. */
813 push_char (dtp
, '\0');
816 CASE_SEPARATORS
: /* Not a repeat count. */
825 if (convert_integer (dtp
, -1, 0))
828 /* Get the real integer. */
843 /* Fall through... */
874 if (nml_bad_return (dtp
, c
))
879 sprintf (message
, "Bad integer for item %d in list input",
880 dtp
->u
.p
.item_count
);
881 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
889 push_char (dtp
, '\0');
890 if (convert_integer (dtp
, length
, negative
))
897 dtp
->u
.p
.saved_type
= BT_INTEGER
;
901 /* Read a character variable. */
904 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
906 char c
, quote
, message
[100];
908 quote
= ' '; /* Space means no quote character. */
918 unget_char (dtp
, c
); /* NULL value. */
928 if (dtp
->u
.p
.namelist_mode
)
938 /* Deal with a possible repeat count. */
951 goto done
; /* String was only digits! */
954 push_char (dtp
, '\0');
959 goto get_string
; /* Not a repeat count after all. */
964 if (convert_integer (dtp
, -1, 0))
967 /* Now get the real string. */
973 unget_char (dtp
, c
); /* Repeated NULL values. */
1001 /* See if we have a doubled quote character or the end of
1004 c
= next_char (dtp
);
1007 push_char (dtp
, quote
);
1011 unget_char (dtp
, c
);
1017 unget_char (dtp
, c
);
1021 if (c
!= '\n' && c
!= '\r')
1031 /* At this point, we have to have a separator, or else the string is
1034 c
= next_char (dtp
);
1035 if (is_separator (c
) || c
== '!')
1037 unget_char (dtp
, c
);
1038 eat_separator (dtp
);
1039 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1045 sprintf (message
, "Invalid string input in item %d",
1046 dtp
->u
.p
.item_count
);
1047 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1052 /* Parse a component of a complex constant or a real number that we
1053 are sure is already there. This is a straight real number parser. */
1056 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1058 char c
, message
[100];
1061 c
= next_char (dtp
);
1062 if (c
== '-' || c
== '+')
1065 c
= next_char (dtp
);
1068 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1071 if (!isdigit (c
) && c
!= '.')
1073 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1081 seen_dp
= (c
== '.') ? 1 : 0;
1085 c
= next_char (dtp
);
1086 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1106 push_char (dtp
, 'e');
1111 push_char (dtp
, 'e');
1113 c
= next_char (dtp
);
1117 unget_char (dtp
, c
);
1126 c
= next_char (dtp
);
1127 if (c
!= '-' && c
!= '+')
1128 push_char (dtp
, '+');
1132 c
= next_char (dtp
);
1143 c
= next_char (dtp
);
1151 unget_char (dtp
, c
);
1160 unget_char (dtp
, c
);
1161 push_char (dtp
, '\0');
1163 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1169 /* Match INF and Infinity. */
1170 if ((c
== 'i' || c
== 'I')
1171 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1172 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1174 c
= next_char (dtp
);
1175 if ((c
!= 'i' && c
!= 'I')
1176 || ((c
== 'i' || c
== 'I')
1177 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1178 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1179 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1180 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1181 && (c
= next_char (dtp
))))
1183 if (is_separator (c
))
1184 unget_char (dtp
, c
);
1185 push_char (dtp
, 'i');
1186 push_char (dtp
, 'n');
1187 push_char (dtp
, 'f');
1191 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1192 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1193 && (c
= next_char (dtp
)))
1195 if (is_separator (c
))
1196 unget_char (dtp
, c
);
1197 push_char (dtp
, 'n');
1198 push_char (dtp
, 'a');
1199 push_char (dtp
, 'n');
1205 if (nml_bad_return (dtp
, c
))
1210 sprintf (message
, "Bad floating point number for item %d",
1211 dtp
->u
.p
.item_count
);
1212 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1218 /* Reading a complex number is straightforward because we can tell
1219 what it is right away. */
1222 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1227 if (parse_repeat (dtp
))
1230 c
= next_char (dtp
);
1237 unget_char (dtp
, c
);
1238 eat_separator (dtp
);
1246 if (parse_real (dtp
, dest
, kind
))
1251 c
= next_char (dtp
);
1252 if (c
== '\n' || c
== '\r')
1255 unget_char (dtp
, c
);
1258 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1263 c
= next_char (dtp
);
1264 if (c
== '\n' || c
== '\r')
1267 unget_char (dtp
, c
);
1269 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1273 if (next_char (dtp
) != ')')
1276 c
= next_char (dtp
);
1277 if (!is_separator (c
))
1280 unget_char (dtp
, c
);
1281 eat_separator (dtp
);
1284 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1289 if (nml_bad_return (dtp
, c
))
1294 sprintf (message
, "Bad complex value in item %d of list input",
1295 dtp
->u
.p
.item_count
);
1296 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1300 /* Parse a real number with a possible repeat count. */
1303 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1305 char c
, message
[100];
1311 c
= next_char (dtp
);
1312 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1330 unget_char (dtp
, c
); /* Single null. */
1331 eat_separator (dtp
);
1344 /* Get the digit string that might be a repeat count. */
1348 c
= next_char (dtp
);
1349 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1373 push_char (dtp
, 'e');
1375 c
= next_char (dtp
);
1379 push_char (dtp
, '\0');
1383 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1384 unget_char (dtp
, c
);
1393 if (convert_integer (dtp
, -1, 0))
1396 /* Now get the number itself. */
1398 c
= next_char (dtp
);
1399 if (is_separator (c
))
1400 { /* Repeated null value. */
1401 unget_char (dtp
, c
);
1402 eat_separator (dtp
);
1406 if (c
!= '-' && c
!= '+')
1407 push_char (dtp
, '+');
1412 c
= next_char (dtp
);
1415 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1418 if (!isdigit (c
) && c
!= '.')
1420 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1439 c
= next_char (dtp
);
1440 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1467 push_char (dtp
, 'e');
1469 c
= next_char (dtp
);
1478 push_char (dtp
, 'e');
1480 c
= next_char (dtp
);
1481 if (c
!= '+' && c
!= '-')
1482 push_char (dtp
, '+');
1486 c
= next_char (dtp
);
1496 c
= next_char (dtp
);
1513 unget_char (dtp
, c
);
1514 eat_separator (dtp
);
1515 push_char (dtp
, '\0');
1516 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1520 dtp
->u
.p
.saved_type
= BT_REAL
;
1524 l_push_char (dtp
, c
);
1527 /* Match INF and Infinity. */
1528 if (c
== 'i' || c
== 'I')
1530 c
= next_char (dtp
);
1531 l_push_char (dtp
, c
);
1532 if (c
!= 'n' && c
!= 'N')
1534 c
= next_char (dtp
);
1535 l_push_char (dtp
, c
);
1536 if (c
!= 'f' && c
!= 'F')
1538 c
= next_char (dtp
);
1539 l_push_char (dtp
, c
);
1540 if (!is_separator (c
))
1542 if (c
!= 'i' && c
!= 'I')
1544 c
= next_char (dtp
);
1545 l_push_char (dtp
, c
);
1546 if (c
!= 'n' && c
!= 'N')
1548 c
= next_char (dtp
);
1549 l_push_char (dtp
, c
);
1550 if (c
!= 'i' && c
!= 'I')
1552 c
= next_char (dtp
);
1553 l_push_char (dtp
, c
);
1554 if (c
!= 't' && c
!= 'T')
1556 c
= next_char (dtp
);
1557 l_push_char (dtp
, c
);
1558 if (c
!= 'y' && c
!= 'Y')
1560 c
= next_char (dtp
);
1561 l_push_char (dtp
, c
);
1567 c
= next_char (dtp
);
1568 l_push_char (dtp
, c
);
1569 if (c
!= 'a' && c
!= 'A')
1571 c
= next_char (dtp
);
1572 l_push_char (dtp
, c
);
1573 if (c
!= 'n' && c
!= 'N')
1575 c
= next_char (dtp
);
1576 l_push_char (dtp
, c
);
1579 if (!is_separator (c
))
1582 if (dtp
->u
.p
.namelist_mode
)
1584 if (c
== ' ' || c
=='\n' || c
== '\r')
1587 c
= next_char (dtp
);
1588 while (c
== ' ' || c
=='\n' || c
== '\r');
1590 l_push_char (dtp
, 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');
1614 if (dtp
->u
.p
.namelist_mode
)
1616 dtp
->u
.p
.nml_read_error
= 1;
1617 dtp
->u
.p
.line_buffer_enabled
= 1;
1618 dtp
->u
.p
.item_count
= 0;
1624 if (nml_bad_return (dtp
, c
))
1629 sprintf (message
, "Bad real number in item %d of list input",
1630 dtp
->u
.p
.item_count
);
1631 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1635 /* Check the current type against the saved type to make sure they are
1636 compatible. Returns nonzero if incompatible. */
1639 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1643 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1645 sprintf (message
, "Read type %s where %s was expected for item %d",
1646 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1647 dtp
->u
.p
.item_count
);
1649 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1653 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1656 if (dtp
->u
.p
.saved_length
!= len
)
1659 "Read kind %d %s where kind %d is required for item %d",
1660 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1661 dtp
->u
.p
.item_count
);
1662 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1670 /* Top level data transfer subroutine for list reads. Because we have
1671 to deal with repeat counts, the data item is always saved after
1672 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1673 greater than one, we copy the data item multiple times. */
1676 list_formatted_read_scalar (st_parameter_dt
*dtp
, volatile bt type
, void *p
,
1677 int kind
, size_t size
)
1684 dtp
->u
.p
.namelist_mode
= 0;
1686 dtp
->u
.p
.eof_jump
= &eof_jump
;
1687 if (setjmp (eof_jump
))
1689 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1690 if (!is_internal_unit (dtp
))
1692 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1693 dtp
->u
.p
.current_unit
->current_record
= 0;
1698 if (dtp
->u
.p
.first_item
)
1700 dtp
->u
.p
.first_item
= 0;
1701 dtp
->u
.p
.input_complete
= 0;
1702 dtp
->u
.p
.repeat_count
= 1;
1703 dtp
->u
.p
.at_eol
= 0;
1705 c
= eat_spaces (dtp
);
1706 if (is_separator (c
))
1708 /* Found a null value. */
1709 eat_separator (dtp
);
1710 dtp
->u
.p
.repeat_count
= 0;
1712 /* eat_separator sets this flag if the separator was a comma. */
1713 if (dtp
->u
.p
.comma_flag
)
1716 /* eat_separator sets this flag if the separator was a \n or \r. */
1717 if (dtp
->u
.p
.at_eol
)
1718 finish_separator (dtp
);
1726 if (dtp
->u
.p
.repeat_count
> 0)
1728 if (check_type (dtp
, type
, kind
))
1733 if (dtp
->u
.p
.input_complete
)
1736 if (dtp
->u
.p
.input_complete
)
1739 if (dtp
->u
.p
.at_eol
)
1740 finish_separator (dtp
);
1744 /* Trailing spaces prior to end of line. */
1745 if (dtp
->u
.p
.at_eol
)
1746 finish_separator (dtp
);
1749 dtp
->u
.p
.saved_type
= BT_NULL
;
1750 dtp
->u
.p
.repeat_count
= 1;
1756 read_integer (dtp
, kind
);
1759 read_logical (dtp
, kind
);
1762 read_character (dtp
, kind
);
1765 read_real (dtp
, p
, kind
);
1766 /* Copy value back to temporary if needed. */
1767 if (dtp
->u
.p
.repeat_count
> 0)
1768 memcpy (dtp
->u
.p
.value
, p
, kind
);
1771 read_complex (dtp
, p
, kind
, size
);
1772 /* Copy value back to temporary if needed. */
1773 if (dtp
->u
.p
.repeat_count
> 0)
1774 memcpy (dtp
->u
.p
.value
, p
, size
);
1777 internal_error (&dtp
->common
, "Bad type for list read");
1780 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1781 dtp
->u
.p
.saved_length
= size
;
1783 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1787 switch (dtp
->u
.p
.saved_type
)
1791 if (dtp
->u
.p
.repeat_count
> 0)
1792 memcpy (p
, dtp
->u
.p
.value
, size
);
1797 memcpy (p
, dtp
->u
.p
.value
, size
);
1801 if (dtp
->u
.p
.saved_string
)
1803 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1804 ? (int) size
: dtp
->u
.p
.saved_used
;
1806 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1809 q
= (gfc_char4_t
*) p
;
1810 for (i
= 0; i
< m
; i
++)
1811 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1815 /* Just delimiters encountered, nothing to copy but SPACE. */
1821 memset (((char *) p
) + m
, ' ', size
- m
);
1824 q
= (gfc_char4_t
*) p
;
1825 for (i
= m
; i
< (int) size
; i
++)
1826 q
[i
] = (unsigned char) ' ';
1835 if (--dtp
->u
.p
.repeat_count
<= 0)
1839 dtp
->u
.p
.eof_jump
= NULL
;
1844 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1845 size_t size
, size_t nelems
)
1849 size_t stride
= type
== BT_CHARACTER
?
1850 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1854 /* Big loop over all the elements. */
1855 for (elem
= 0; elem
< nelems
; elem
++)
1857 dtp
->u
.p
.item_count
++;
1858 list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1863 /* Finish a list read. */
1866 finish_list_read (st_parameter_dt
*dtp
)
1872 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1874 if (dtp
->u
.p
.at_eol
)
1876 dtp
->u
.p
.at_eol
= 0;
1882 c
= next_char (dtp
);
1886 if (dtp
->u
.p
.current_unit
->endfile
!= NO_ENDFILE
)
1888 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1889 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1890 dtp
->u
.p
.current_unit
->current_record
= 0;
1896 void namelist_read (st_parameter_dt *dtp)
1898 static void nml_match_name (char *name, int len)
1899 static int nml_query (st_parameter_dt *dtp)
1900 static int nml_get_obj_data (st_parameter_dt *dtp,
1901 namelist_info **prev_nl, char *, size_t)
1903 static void nml_untouch_nodes (st_parameter_dt *dtp)
1904 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1906 static int nml_parse_qualifier(descriptor_dimension * ad,
1907 array_loop_spec * ls, int rank, char *)
1908 static void nml_touch_nodes (namelist_info * nl)
1909 static int nml_read_obj (namelist_info *nl, index_type offset,
1910 namelist_info **prev_nl, char *, size_t,
1911 index_type clow, index_type chigh)
1915 /* Inputs a rank-dimensional qualifier, which can contain
1916 singlets, doublets, triplets or ':' with the standard meanings. */
1919 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1920 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1927 int is_array_section
, is_char
;
1931 is_array_section
= 0;
1932 dtp
->u
.p
.expanded_read
= 0;
1934 /* See if this is a character substring qualifier we are looking for. */
1941 /* The next character in the stream should be the '('. */
1943 c
= next_char (dtp
);
1945 /* Process the qualifier, by dimension and triplet. */
1947 for (dim
=0; dim
< rank
; dim
++ )
1949 for (indx
=0; indx
<3; indx
++)
1955 /* Process a potential sign. */
1956 c
= next_char (dtp
);
1967 unget_char (dtp
, c
);
1971 /* Process characters up to the next ':' , ',' or ')'. */
1974 c
= next_char (dtp
);
1979 is_array_section
= 1;
1983 if ((c
==',' && dim
== rank
-1)
1984 || (c
==')' && dim
< rank
-1))
1987 sprintf (parse_err_msg
, "Bad substring qualifier");
1989 sprintf (parse_err_msg
, "Bad number of index fields");
1998 case ' ': case '\t':
2000 c
= next_char (dtp
);
2005 sprintf (parse_err_msg
,
2006 "Bad character in substring qualifier");
2008 sprintf (parse_err_msg
, "Bad character in index");
2012 if ((c
== ',' || c
== ')') && indx
== 0
2013 && dtp
->u
.p
.saved_string
== 0)
2016 sprintf (parse_err_msg
, "Null substring qualifier");
2018 sprintf (parse_err_msg
, "Null index field");
2022 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2023 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2026 sprintf (parse_err_msg
, "Bad substring qualifier");
2028 sprintf (parse_err_msg
, "Bad index triplet");
2032 if (is_char
&& !is_array_section
)
2034 sprintf (parse_err_msg
,
2035 "Missing colon in substring qualifier");
2039 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2041 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2042 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2048 /* Now read the index. */
2049 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2052 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2054 sprintf (parse_err_msg
, "Bad integer in index");
2060 /* Feed the index values to the triplet arrays. */
2064 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2066 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2068 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2071 /* Singlet or doublet indices. */
2072 if (c
==',' || c
==')')
2076 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2078 /* If -std=f95/2003 or an array section is specified,
2079 do not allow excess data to be processed. */
2080 if (is_array_section
== 1
2081 || compile_options
.allow_std
< GFC_STD_GNU
)
2082 ls
[dim
].end
= ls
[dim
].start
;
2084 dtp
->u
.p
.expanded_read
= 1;
2087 /* Check for non-zero rank. */
2088 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2095 /* Check the values of the triplet indices. */
2096 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
2097 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
2098 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
2099 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
2102 sprintf (parse_err_msg
, "Substring out of range");
2104 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2108 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2109 || (ls
[dim
].step
== 0))
2111 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2115 /* Initialise the loop index counter. */
2116 ls
[dim
].idx
= ls
[dim
].start
;
2126 static namelist_info
*
2127 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2129 namelist_info
* t
= dtp
->u
.p
.ionml
;
2132 if (strcmp (var_name
, t
->var_name
) == 0)
2142 /* Visits all the components of a derived type that have
2143 not explicitly been identified in the namelist input.
2144 touched is set and the loop specification initialised
2145 to default values */
2148 nml_touch_nodes (namelist_info
* nl
)
2150 index_type len
= strlen (nl
->var_name
) + 1;
2152 char * ext_name
= (char*)get_mem (len
+ 1);
2153 memcpy (ext_name
, nl
->var_name
, len
-1);
2154 memcpy (ext_name
+ len
- 1, "%", 2);
2155 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2157 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2160 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2162 nl
->ls
[dim
].step
= 1;
2163 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2164 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2165 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2171 free_mem (ext_name
);
2175 /* Resets touched for the entire list of nml_nodes, ready for a
2179 nml_untouch_nodes (st_parameter_dt
*dtp
)
2182 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2187 /* Attempts to input name to namelist name. Returns
2188 dtp->u.p.nml_read_error = 1 on no match. */
2191 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2195 dtp
->u
.p
.nml_read_error
= 0;
2196 for (i
= 0; i
< len
; i
++)
2198 c
= next_char (dtp
);
2199 if (tolower (c
) != tolower (name
[i
]))
2201 dtp
->u
.p
.nml_read_error
= 1;
2207 /* If the namelist read is from stdin, output the current state of the
2208 namelist to stdout. This is used to implement the non-standard query
2209 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2210 the names alone are printed. */
2213 nml_query (st_parameter_dt
*dtp
, char c
)
2215 gfc_unit
* temp_unit
;
2220 static const index_type endlen
= 3;
2221 static const char endl
[] = "\r\n";
2222 static const char nmlend
[] = "&end\r\n";
2224 static const index_type endlen
= 2;
2225 static const char endl
[] = "\n";
2226 static const char nmlend
[] = "&end\n";
2229 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2232 /* Store the current unit and transfer to stdout. */
2234 temp_unit
= dtp
->u
.p
.current_unit
;
2235 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2237 if (dtp
->u
.p
.current_unit
)
2239 dtp
->u
.p
.mode
= WRITING
;
2240 next_record (dtp
, 0);
2242 /* Write the namelist in its entirety. */
2245 namelist_write (dtp
);
2247 /* Or write the list of names. */
2251 /* "&namelist_name\n" */
2253 len
= dtp
->namelist_name_len
;
2254 p
= write_block (dtp
, len
+ endlen
);
2258 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2259 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2260 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2264 len
= strlen (nl
->var_name
);
2265 p
= write_block (dtp
, len
+ endlen
);
2269 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2270 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2275 p
= write_block (dtp
, endlen
+ 3);
2277 memcpy (p
, &nmlend
, endlen
+ 3);
2280 /* Flush the stream to force immediate output. */
2282 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2283 sflush (dtp
->u
.p
.current_unit
->s
);
2284 unlock_unit (dtp
->u
.p
.current_unit
);
2289 /* Restore the current unit. */
2291 dtp
->u
.p
.current_unit
= temp_unit
;
2292 dtp
->u
.p
.mode
= READING
;
2296 /* Reads and stores the input for the namelist object nl. For an array,
2297 the function loops over the ranges defined by the loop specification.
2298 This default to all the data or to the specification from a qualifier.
2299 nml_read_obj recursively calls itself to read derived types. It visits
2300 all its own components but only reads data for those that were touched
2301 when the name was parsed. If a read error is encountered, an attempt is
2302 made to return to read a new object name because the standard allows too
2303 little data to be available. On the other hand, too much data is an
2307 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2308 namelist_info
**pprev_nl
, char *nml_err_msg
,
2309 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2311 namelist_info
* cmp
;
2318 size_t obj_name_len
;
2321 /* This object not touched in name parsing. */
2326 dtp
->u
.p
.repeat_count
= 0;
2332 case GFC_DTYPE_INTEGER
:
2333 case GFC_DTYPE_LOGICAL
:
2337 case GFC_DTYPE_REAL
:
2338 dlen
= size_from_real_kind (len
);
2341 case GFC_DTYPE_COMPLEX
:
2342 dlen
= size_from_complex_kind (len
);
2345 case GFC_DTYPE_CHARACTER
:
2346 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2355 /* Update the pointer to the data, using the current index vector */
2357 pdata
= (void*)(nl
->mem_pos
+ offset
);
2358 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2359 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2360 nl
->dim
[dim
].stride
* nl
->size
);
2362 /* Reset the error flag and try to read next value, if
2363 dtp->u.p.repeat_count=0 */
2365 dtp
->u
.p
.nml_read_error
= 0;
2367 if (--dtp
->u
.p
.repeat_count
<= 0)
2369 if (dtp
->u
.p
.input_complete
)
2371 if (dtp
->u
.p
.at_eol
)
2372 finish_separator (dtp
);
2373 if (dtp
->u
.p
.input_complete
)
2376 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2377 after the switch block. */
2379 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2384 case GFC_DTYPE_INTEGER
:
2385 read_integer (dtp
, len
);
2388 case GFC_DTYPE_LOGICAL
:
2389 read_logical (dtp
, len
);
2392 case GFC_DTYPE_CHARACTER
:
2393 read_character (dtp
, len
);
2396 case GFC_DTYPE_REAL
:
2397 /* Need to copy data back from the real location to the temp in order
2398 to handle nml reads into arrays. */
2399 read_real (dtp
, pdata
, len
);
2400 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2403 case GFC_DTYPE_COMPLEX
:
2404 /* Same as for REAL, copy back to temp. */
2405 read_complex (dtp
, pdata
, len
, dlen
);
2406 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2409 case GFC_DTYPE_DERIVED
:
2410 obj_name_len
= strlen (nl
->var_name
) + 1;
2411 obj_name
= get_mem (obj_name_len
+1);
2412 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2413 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2415 /* If reading a derived type, disable the expanded read warning
2416 since a single object can have multiple reads. */
2417 dtp
->u
.p
.expanded_read
= 0;
2419 /* Now loop over the components. Update the component pointer
2420 with the return value from nml_write_obj. This loop jumps
2421 past nested derived types by testing if the potential
2422 component name contains '%'. */
2424 for (cmp
= nl
->next
;
2426 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2427 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2431 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2432 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2433 clow
, chigh
) == FAILURE
)
2435 free_mem (obj_name
);
2439 if (dtp
->u
.p
.input_complete
)
2441 free_mem (obj_name
);
2446 free_mem (obj_name
);
2450 snprintf (nml_err_msg
, nml_err_msg_size
,
2451 "Bad type for namelist object %s", nl
->var_name
);
2452 internal_error (&dtp
->common
, nml_err_msg
);
2457 /* The standard permits array data to stop short of the number of
2458 elements specified in the loop specification. In this case, we
2459 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2460 nml_get_obj_data and an attempt is made to read object name. */
2463 if (dtp
->u
.p
.nml_read_error
)
2465 dtp
->u
.p
.expanded_read
= 0;
2469 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2471 dtp
->u
.p
.expanded_read
= 0;
2475 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2476 This comes about because the read functions return BT_types. */
2478 switch (dtp
->u
.p
.saved_type
)
2485 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2489 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2490 pdata
= (void*)( pdata
+ clow
- 1 );
2491 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2493 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2500 /* Warn if a non-standard expanded read occurs. A single read of a
2501 single object is acceptable. If a second read occurs, issue a warning
2502 and set the flag to zero to prevent further warnings. */
2503 if (dtp
->u
.p
.expanded_read
== 2)
2505 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2506 dtp
->u
.p
.expanded_read
= 0;
2509 /* If the expanded read warning flag is set, increment it,
2510 indicating that a single read has occurred. */
2511 if (dtp
->u
.p
.expanded_read
>= 1)
2512 dtp
->u
.p
.expanded_read
++;
2514 /* Break out of loop if scalar. */
2518 /* Now increment the index vector. */
2523 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2525 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2527 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2529 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2531 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2535 } while (!nml_carry
);
2537 if (dtp
->u
.p
.repeat_count
> 1)
2539 snprintf (nml_err_msg
, nml_err_msg_size
,
2540 "Repeat count too large for namelist object %s", nl
->var_name
);
2550 /* Parses the object name, including array and substring qualifiers. It
2551 iterates over derived type components, touching those components and
2552 setting their loop specifications, if there is a qualifier. If the
2553 object is itself a derived type, its components and subcomponents are
2554 touched. nml_read_obj is called at the end and this reads the data in
2555 the manner specified by the object name. */
2558 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2559 char *nml_err_msg
, size_t nml_err_msg_size
)
2563 namelist_info
* first_nl
= NULL
;
2564 namelist_info
* root_nl
= NULL
;
2565 int dim
, parsed_rank
;
2567 index_type clow
, chigh
;
2568 int non_zero_rank_count
;
2570 /* Look for end of input or object name. If '?' or '=?' are encountered
2571 in stdin, print the node names or the namelist to stdout. */
2573 eat_separator (dtp
);
2574 if (dtp
->u
.p
.input_complete
)
2577 if (dtp
->u
.p
.at_eol
)
2578 finish_separator (dtp
);
2579 if (dtp
->u
.p
.input_complete
)
2582 c
= next_char (dtp
);
2586 c
= next_char (dtp
);
2589 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2592 nml_query (dtp
, '=');
2596 nml_query (dtp
, '?');
2601 nml_match_name (dtp
, "end", 3);
2602 if (dtp
->u
.p
.nml_read_error
)
2604 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2608 dtp
->u
.p
.input_complete
= 1;
2615 /* Untouch all nodes of the namelist and reset the flag that is set for
2616 derived type components. */
2618 nml_untouch_nodes (dtp
);
2620 non_zero_rank_count
= 0;
2622 /* Get the object name - should '!' and '\n' be permitted separators? */
2630 if (!is_separator (c
))
2631 push_char (dtp
, tolower(c
));
2632 c
= next_char (dtp
);
2633 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2635 unget_char (dtp
, c
);
2637 /* Check that the name is in the namelist and get pointer to object.
2638 Three error conditions exist: (i) An attempt is being made to
2639 identify a non-existent object, following a failed data read or
2640 (ii) The object name does not exist or (iii) Too many data items
2641 are present for an object. (iii) gives the same error message
2644 push_char (dtp
, '\0');
2648 size_t var_len
= strlen (root_nl
->var_name
);
2650 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2651 char ext_name
[var_len
+ saved_len
+ 1];
2653 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2654 if (dtp
->u
.p
.saved_string
)
2655 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2656 ext_name
[var_len
+ saved_len
] = '\0';
2657 nl
= find_nml_node (dtp
, ext_name
);
2660 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2664 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2665 snprintf (nml_err_msg
, nml_err_msg_size
,
2666 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2669 snprintf (nml_err_msg
, nml_err_msg_size
,
2670 "Cannot match namelist object name %s",
2671 dtp
->u
.p
.saved_string
);
2676 /* Get the length, data length, base pointer and rank of the variable.
2677 Set the default loop specification first. */
2679 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2681 nl
->ls
[dim
].step
= 1;
2682 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2683 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2684 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2687 /* Check to see if there is a qualifier: if so, parse it.*/
2689 if (c
== '(' && nl
->var_rank
)
2692 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2693 nml_err_msg
, &parsed_rank
) == FAILURE
)
2695 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2696 snprintf (nml_err_msg_end
,
2697 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2698 " for namelist variable %s", nl
->var_name
);
2702 if (parsed_rank
> 0)
2703 non_zero_rank_count
++;
2705 c
= next_char (dtp
);
2706 unget_char (dtp
, c
);
2708 else if (nl
->var_rank
> 0)
2709 non_zero_rank_count
++;
2711 /* Now parse a derived type component. The root namelist_info address
2712 is backed up, as is the previous component level. The component flag
2713 is set and the iteration is made by jumping back to get_name. */
2717 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2719 snprintf (nml_err_msg
, nml_err_msg_size
,
2720 "Attempt to get derived component for %s", nl
->var_name
);
2724 if (!component_flag
)
2729 c
= next_char (dtp
);
2733 /* Parse a character qualifier, if present. chigh = 0 is a default
2734 that signals that the string length = string_length. */
2739 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2741 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2742 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2744 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2747 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2748 snprintf (nml_err_msg_end
,
2749 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2750 " for namelist variable %s", nl
->var_name
);
2754 clow
= ind
[0].start
;
2757 if (ind
[0].step
!= 1)
2759 snprintf (nml_err_msg
, nml_err_msg_size
,
2760 "Step not allowed in substring qualifier"
2761 " for namelist object %s", nl
->var_name
);
2765 c
= next_char (dtp
);
2766 unget_char (dtp
, c
);
2769 /* If a derived type touch its components and restore the root
2770 namelist_info if we have parsed a qualified derived type
2773 if (nl
->type
== GFC_DTYPE_DERIVED
)
2774 nml_touch_nodes (nl
);
2775 if (component_flag
&& nl
->var_rank
> 0)
2778 /* Make sure no extraneous qualifiers are there. */
2782 snprintf (nml_err_msg
, nml_err_msg_size
,
2783 "Qualifier for a scalar or non-character namelist object %s",
2788 /* Make sure there is no more than one non-zero rank object. */
2789 if (non_zero_rank_count
> 1)
2791 snprintf (nml_err_msg
, nml_err_msg_size
,
2792 "Multiple sub-objects with non-zero rank in namelist object %s",
2794 non_zero_rank_count
= 0;
2798 /* According to the standard, an equal sign MUST follow an object name. The
2799 following is possibly lax - it allows comments, blank lines and so on to
2800 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2804 eat_separator (dtp
);
2805 if (dtp
->u
.p
.input_complete
)
2808 if (dtp
->u
.p
.at_eol
)
2809 finish_separator (dtp
);
2810 if (dtp
->u
.p
.input_complete
)
2813 c
= next_char (dtp
);
2817 snprintf (nml_err_msg
, nml_err_msg_size
,
2818 "Equal sign must follow namelist object name %s",
2823 if (first_nl
!= NULL
&& first_nl
->var_rank
> 0)
2826 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2827 clow
, chigh
) == FAILURE
)
2837 /* Entry point for namelist input. Goes through input until namelist name
2838 is matched. Then cycles through nml_get_obj_data until the input is
2839 completed or there is an error. */
2842 namelist_read (st_parameter_dt
*dtp
)
2846 char nml_err_msg
[200];
2847 /* Pointer to the previously read object, in case attempt is made to read
2848 new object name. Should this fail, error message can give previous
2850 namelist_info
*prev_nl
= NULL
;
2852 dtp
->u
.p
.namelist_mode
= 1;
2853 dtp
->u
.p
.input_complete
= 0;
2854 dtp
->u
.p
.expanded_read
= 0;
2856 dtp
->u
.p
.eof_jump
= &eof_jump
;
2857 if (setjmp (eof_jump
))
2859 dtp
->u
.p
.eof_jump
= NULL
;
2860 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2864 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2865 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2866 node names or namelist on stdout. */
2869 switch (c
= next_char (dtp
))
2880 c
= next_char (dtp
);
2882 nml_query (dtp
, '=');
2884 unget_char (dtp
, c
);
2888 nml_query (dtp
, '?');
2894 /* Match the name of the namelist. */
2896 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2898 if (dtp
->u
.p
.nml_read_error
)
2901 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2902 c
= next_char (dtp
);
2903 if (!is_separator(c
) && c
!= '!')
2905 unget_char (dtp
, c
);
2909 unget_char (dtp
, c
);
2910 eat_separator (dtp
);
2912 /* Ready to read namelist objects. If there is an error in input
2913 from stdin, output the error message and continue. */
2915 while (!dtp
->u
.p
.input_complete
)
2917 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2922 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2925 u
= find_unit (options
.stderr_unit
);
2926 st_printf ("%s\n", nml_err_msg
);
2936 dtp
->u
.p
.eof_jump
= NULL
;
2941 /* All namelist error calls return from here */
2945 dtp
->u
.p
.eof_jump
= NULL
;
2948 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);