1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
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 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/>. */
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r' || c == ';')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
68 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
71 /* Save a character to a string buffer, enlarging it as necessary. */
74 push_char (st_parameter_dt
*dtp
, char c
)
78 if (dtp
->u
.p
.saved_string
== NULL
)
80 dtp
->u
.p
.saved_string
= get_mem (SCRATCH_SIZE
);
81 // memset below should be commented out.
82 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
83 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
84 dtp
->u
.p
.saved_used
= 0;
87 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
89 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
90 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
92 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
93 dtp
->u
.p
.saved_string
= new;
95 // Also this should not be necessary.
96 memset (new + dtp
->u
.p
.saved_used
, 0,
97 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
101 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
105 /* Free the input buffer if necessary. */
108 free_saved (st_parameter_dt
*dtp
)
110 if (dtp
->u
.p
.saved_string
== NULL
)
113 free (dtp
->u
.p
.saved_string
);
115 dtp
->u
.p
.saved_string
= NULL
;
116 dtp
->u
.p
.saved_used
= 0;
120 /* Free the line buffer if necessary. */
123 free_line (st_parameter_dt
*dtp
)
125 dtp
->u
.p
.item_count
= 0;
126 dtp
->u
.p
.line_buffer_enabled
= 0;
128 if (dtp
->u
.p
.line_buffer
== NULL
)
131 free (dtp
->u
.p
.line_buffer
);
132 dtp
->u
.p
.line_buffer
= NULL
;
137 next_char (st_parameter_dt
*dtp
)
144 if (dtp
->u
.p
.last_char
!= '\0')
147 c
= dtp
->u
.p
.last_char
;
148 dtp
->u
.p
.last_char
= '\0';
152 /* Read from line_buffer if enabled. */
154 if (dtp
->u
.p
.line_buffer_enabled
)
158 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
159 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
161 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
162 dtp
->u
.p
.item_count
++;
166 dtp
->u
.p
.item_count
= 0;
167 dtp
->u
.p
.line_buffer_enabled
= 0;
170 /* Handle the end-of-record and end-of-file conditions for
171 internal array unit. */
172 if (is_array_io (dtp
))
175 longjmp (*dtp
->u
.p
.eof_jump
, 1);
177 /* Check for "end-of-record" condition. */
178 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
183 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
186 /* Check for "end-of-file" condition. */
193 record
*= dtp
->u
.p
.current_unit
->recl
;
194 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
195 longjmp (*dtp
->u
.p
.eof_jump
, 1);
197 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
202 /* Get the next character and handle end-of-record conditions. */
204 if (is_internal_unit (dtp
))
206 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, 1);
209 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
213 if (is_array_io (dtp
))
215 /* Check whether we hit EOF. */
218 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
221 dtp
->u
.p
.current_unit
->bytes_left
--;
226 longjmp (*dtp
->u
.p
.eof_jump
, 1);
236 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
240 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
241 longjmp (*dtp
->u
.p
.eof_jump
, 1);
242 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
247 if (is_stream_io (dtp
) && cc
!= EOF
)
248 dtp
->u
.p
.current_unit
->strm_pos
++;
252 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
257 /* Push a character back onto the input. */
260 unget_char (st_parameter_dt
*dtp
, char c
)
262 dtp
->u
.p
.last_char
= c
;
266 /* Skip over spaces in the input. Returns the nonspace character that
267 terminated the eating and also places it back on the input. */
270 eat_spaces (st_parameter_dt
*dtp
)
278 while (c
== ' ' || c
== '\t');
285 /* This function reads characters through to the end of the current line and
286 just ignores them. */
289 eat_line (st_parameter_dt
*dtp
)
299 /* Skip over a separator. Technically, we don't always eat the whole
300 separator. This is because if we've processed the last input item,
301 then a separator is unnecessary. Plus the fact that operating
302 systems usually deliver console input on a line basis.
304 The upshot is that if we see a newline as part of reading a
305 separator, we stop reading. If there are more input items, we
306 continue reading the separator with finish_separator() which takes
307 care of the fact that we may or may not have seen a comma as part
311 eat_separator (st_parameter_dt
*dtp
)
316 dtp
->u
.p
.comma_flag
= 0;
322 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
329 dtp
->u
.p
.comma_flag
= 1;
334 dtp
->u
.p
.input_complete
= 1;
348 if (dtp
->u
.p
.namelist_mode
)
364 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
370 if (dtp
->u
.p
.namelist_mode
)
371 { /* Eat a namelist comment. */
379 /* Fall Through... */
388 /* Finish processing a separator that was interrupted by a newline.
389 If we're here, then another data item is present, so we finish what
390 we started on the previous line. */
393 finish_separator (st_parameter_dt
*dtp
)
404 if (dtp
->u
.p
.comma_flag
)
408 c
= eat_spaces (dtp
);
409 if (c
== '\n' || c
== '\r')
416 dtp
->u
.p
.input_complete
= 1;
417 if (!dtp
->u
.p
.namelist_mode
)
426 if (dtp
->u
.p
.namelist_mode
)
442 /* This function is needed to catch bad conversions so that namelist can
443 attempt to see if dtp->u.p.saved_string contains a new object name rather
447 nml_bad_return (st_parameter_dt
*dtp
, char c
)
449 if (dtp
->u
.p
.namelist_mode
)
451 dtp
->u
.p
.nml_read_error
= 1;
458 /* Convert an unsigned string to an integer. The length value is -1
459 if we are working on a repeat count. Returns nonzero if we have a
460 range problem. As a side effect, frees the dtp->u.p.saved_string. */
463 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
465 char c
, *buffer
, message
[100];
467 GFC_INTEGER_LARGEST v
, max
, max10
;
469 buffer
= dtp
->u
.p
.saved_string
;
472 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
497 set_integer (dtp
->u
.p
.value
, v
, length
);
501 dtp
->u
.p
.repeat_count
= v
;
503 if (dtp
->u
.p
.repeat_count
== 0)
505 sprintf (message
, "Zero repeat count in item %d of list input",
506 dtp
->u
.p
.item_count
);
508 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
518 sprintf (message
, "Repeat count overflow in item %d of list input",
519 dtp
->u
.p
.item_count
);
521 sprintf (message
, "Integer overflow while reading item %d",
522 dtp
->u
.p
.item_count
);
525 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
531 /* Parse a repeat count for logical and complex values which cannot
532 begin with a digit. Returns nonzero if we are done, zero if we
533 should continue on. */
536 parse_repeat (st_parameter_dt
*dtp
)
538 char c
, message
[100];
564 repeat
= 10 * repeat
+ c
- '0';
566 if (repeat
> MAX_REPEAT
)
569 "Repeat count overflow in item %d of list input",
570 dtp
->u
.p
.item_count
);
572 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
582 "Zero repeat count in item %d of list input",
583 dtp
->u
.p
.item_count
);
585 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
597 dtp
->u
.p
.repeat_count
= repeat
;
604 sprintf (message
, "Bad repeat count in item %d of list input",
605 dtp
->u
.p
.item_count
);
606 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
611 /* To read a logical we have to look ahead in the input stream to make sure
612 there is not an equal sign indicating a variable name. To do this we use
613 line_buffer to point to a temporary buffer, pushing characters there for
614 possible later reading. */
617 l_push_char (st_parameter_dt
*dtp
, char c
)
619 if (dtp
->u
.p
.line_buffer
== NULL
)
621 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
622 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
625 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
629 /* Read a logical character on the input. */
632 read_logical (st_parameter_dt
*dtp
, int length
)
634 char c
, message
[100];
637 if (parse_repeat (dtp
))
640 c
= tolower (next_char (dtp
));
641 l_push_char (dtp
, c
);
647 l_push_char (dtp
, c
);
649 if (!is_separator(c
))
657 l_push_char (dtp
, c
);
659 if (!is_separator(c
))
666 c
= tolower (next_char (dtp
));
684 return; /* Null value. */
687 /* Save the character in case it is the beginning
688 of the next object name. */
693 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
694 dtp
->u
.p
.saved_length
= length
;
696 /* Eat trailing garbage. */
701 while (!is_separator (c
));
705 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
712 for(i
= 0; i
< 63; i
++)
717 /* All done if this is not a namelist read. */
718 if (!dtp
->u
.p
.namelist_mode
)
731 l_push_char (dtp
, c
);
734 dtp
->u
.p
.nml_read_error
= 1;
735 dtp
->u
.p
.line_buffer_enabled
= 1;
736 dtp
->u
.p
.item_count
= 0;
746 if (nml_bad_return (dtp
, c
))
751 sprintf (message
, "Bad logical value while reading item %d",
752 dtp
->u
.p
.item_count
);
753 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
758 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
759 dtp
->u
.p
.saved_length
= length
;
760 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
766 /* Reading integers is tricky because we can actually be reading a
767 repeat count. We have to store the characters in a buffer because
768 we could be reading an integer that is larger than the default int
769 used for repeat counts. */
772 read_integer (st_parameter_dt
*dtp
, int length
)
774 char c
, message
[100];
784 /* Fall through... */
790 CASE_SEPARATORS
: /* Single null. */
803 /* Take care of what may be a repeat count. */
815 push_char (dtp
, '\0');
818 CASE_SEPARATORS
: /* Not a repeat count. */
827 if (convert_integer (dtp
, -1, 0))
830 /* Get the real integer. */
845 /* Fall through... */
876 if (nml_bad_return (dtp
, c
))
881 sprintf (message
, "Bad integer for item %d in list input",
882 dtp
->u
.p
.item_count
);
883 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
891 push_char (dtp
, '\0');
892 if (convert_integer (dtp
, length
, negative
))
899 dtp
->u
.p
.saved_type
= BT_INTEGER
;
903 /* Read a character variable. */
906 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
908 char c
, quote
, message
[100];
910 quote
= ' '; /* Space means no quote character. */
920 unget_char (dtp
, c
); /* NULL value. */
930 if (dtp
->u
.p
.namelist_mode
)
940 /* Deal with a possible repeat count. */
953 goto done
; /* String was only digits! */
956 push_char (dtp
, '\0');
961 goto get_string
; /* Not a repeat count after all. */
966 if (convert_integer (dtp
, -1, 0))
969 /* Now get the real string. */
975 unget_char (dtp
, c
); /* Repeated NULL values. */
1003 /* See if we have a doubled quote character or the end of
1006 c
= next_char (dtp
);
1009 push_char (dtp
, quote
);
1013 unget_char (dtp
, c
);
1019 unget_char (dtp
, c
);
1023 if (c
!= '\n' && c
!= '\r')
1033 /* At this point, we have to have a separator, or else the string is
1036 c
= next_char (dtp
);
1037 if (is_separator (c
) || c
== '!')
1039 unget_char (dtp
, c
);
1040 eat_separator (dtp
);
1041 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1047 sprintf (message
, "Invalid string input in item %d",
1048 dtp
->u
.p
.item_count
);
1049 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1054 /* Parse a component of a complex constant or a real number that we
1055 are sure is already there. This is a straight real number parser. */
1058 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1060 char c
, message
[100];
1063 c
= next_char (dtp
);
1064 if (c
== '-' || c
== '+')
1067 c
= next_char (dtp
);
1070 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1073 if (!isdigit (c
) && c
!= '.')
1075 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1083 seen_dp
= (c
== '.') ? 1 : 0;
1087 c
= next_char (dtp
);
1088 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1108 push_char (dtp
, 'e');
1113 push_char (dtp
, 'e');
1115 c
= next_char (dtp
);
1119 unget_char (dtp
, c
);
1128 c
= next_char (dtp
);
1129 if (c
!= '-' && c
!= '+')
1130 push_char (dtp
, '+');
1134 c
= next_char (dtp
);
1145 c
= next_char (dtp
);
1153 unget_char (dtp
, c
);
1162 unget_char (dtp
, c
);
1163 push_char (dtp
, '\0');
1165 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1171 /* Match INF and Infinity. */
1172 if ((c
== 'i' || c
== 'I')
1173 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1174 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1176 c
= next_char (dtp
);
1177 if ((c
!= 'i' && c
!= 'I')
1178 || ((c
== 'i' || c
== 'I')
1179 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1180 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1181 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1182 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1183 && (c
= next_char (dtp
))))
1185 if (is_separator (c
))
1186 unget_char (dtp
, c
);
1187 push_char (dtp
, 'i');
1188 push_char (dtp
, 'n');
1189 push_char (dtp
, 'f');
1193 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1194 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1195 && (c
= next_char (dtp
)))
1197 if (is_separator (c
))
1198 unget_char (dtp
, c
);
1199 push_char (dtp
, 'n');
1200 push_char (dtp
, 'a');
1201 push_char (dtp
, 'n');
1203 /* Match "NAN(alphanum)". */
1206 for ( ; c
!= ')'; c
= next_char (dtp
))
1207 if (is_separator (c
))
1210 c
= next_char (dtp
);
1211 if (is_separator (c
))
1212 unget_char (dtp
, c
);
1219 if (nml_bad_return (dtp
, c
))
1224 sprintf (message
, "Bad floating point number for item %d",
1225 dtp
->u
.p
.item_count
);
1226 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1232 /* Reading a complex number is straightforward because we can tell
1233 what it is right away. */
1236 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1241 if (parse_repeat (dtp
))
1244 c
= next_char (dtp
);
1251 unget_char (dtp
, c
);
1252 eat_separator (dtp
);
1260 if (parse_real (dtp
, dest
, kind
))
1265 c
= next_char (dtp
);
1266 if (c
== '\n' || c
== '\r')
1269 unget_char (dtp
, c
);
1272 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1277 c
= next_char (dtp
);
1278 if (c
== '\n' || c
== '\r')
1281 unget_char (dtp
, c
);
1283 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1287 if (next_char (dtp
) != ')')
1290 c
= next_char (dtp
);
1291 if (!is_separator (c
))
1294 unget_char (dtp
, c
);
1295 eat_separator (dtp
);
1298 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1303 if (nml_bad_return (dtp
, c
))
1308 sprintf (message
, "Bad complex value in item %d of list input",
1309 dtp
->u
.p
.item_count
);
1310 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1314 /* Parse a real number with a possible repeat count. */
1317 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1319 char c
, message
[100];
1325 c
= next_char (dtp
);
1326 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1344 unget_char (dtp
, c
); /* Single null. */
1345 eat_separator (dtp
);
1358 /* Get the digit string that might be a repeat count. */
1362 c
= next_char (dtp
);
1363 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1387 push_char (dtp
, 'e');
1389 c
= next_char (dtp
);
1393 push_char (dtp
, '\0');
1397 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1398 unget_char (dtp
, c
);
1407 if (convert_integer (dtp
, -1, 0))
1410 /* Now get the number itself. */
1412 c
= next_char (dtp
);
1413 if (is_separator (c
))
1414 { /* Repeated null value. */
1415 unget_char (dtp
, c
);
1416 eat_separator (dtp
);
1420 if (c
!= '-' && c
!= '+')
1421 push_char (dtp
, '+');
1426 c
= next_char (dtp
);
1429 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1432 if (!isdigit (c
) && c
!= '.')
1434 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1453 c
= next_char (dtp
);
1454 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1481 push_char (dtp
, 'e');
1483 c
= next_char (dtp
);
1492 push_char (dtp
, 'e');
1494 c
= next_char (dtp
);
1495 if (c
!= '+' && c
!= '-')
1496 push_char (dtp
, '+');
1500 c
= next_char (dtp
);
1510 c
= next_char (dtp
);
1527 unget_char (dtp
, c
);
1528 eat_separator (dtp
);
1529 push_char (dtp
, '\0');
1530 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1534 dtp
->u
.p
.saved_type
= BT_REAL
;
1538 l_push_char (dtp
, c
);
1541 /* Match INF and Infinity. */
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
!= 'f' && c
!= 'F')
1552 c
= next_char (dtp
);
1553 l_push_char (dtp
, c
);
1554 if (!is_separator (c
))
1556 if (c
!= 'i' && c
!= 'I')
1558 c
= next_char (dtp
);
1559 l_push_char (dtp
, c
);
1560 if (c
!= 'n' && c
!= 'N')
1562 c
= next_char (dtp
);
1563 l_push_char (dtp
, c
);
1564 if (c
!= 'i' && c
!= 'I')
1566 c
= next_char (dtp
);
1567 l_push_char (dtp
, c
);
1568 if (c
!= 't' && c
!= 'T')
1570 c
= next_char (dtp
);
1571 l_push_char (dtp
, c
);
1572 if (c
!= 'y' && c
!= 'Y')
1574 c
= next_char (dtp
);
1575 l_push_char (dtp
, c
);
1581 c
= next_char (dtp
);
1582 l_push_char (dtp
, c
);
1583 if (c
!= 'a' && c
!= 'A')
1585 c
= next_char (dtp
);
1586 l_push_char (dtp
, c
);
1587 if (c
!= 'n' && c
!= 'N')
1589 c
= next_char (dtp
);
1590 l_push_char (dtp
, c
);
1592 /* Match NAN(alphanum). */
1595 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1596 if (is_separator (c
))
1599 l_push_char (dtp
, c
);
1601 l_push_char (dtp
, ')');
1602 c
= next_char (dtp
);
1603 l_push_char (dtp
, c
);
1607 if (!is_separator (c
))
1610 if (dtp
->u
.p
.namelist_mode
)
1612 if (c
== ' ' || c
=='\n' || c
== '\r')
1615 c
= next_char (dtp
);
1616 while (c
== ' ' || c
=='\n' || c
== '\r');
1618 l_push_char (dtp
, c
);
1627 push_char (dtp
, 'i');
1628 push_char (dtp
, 'n');
1629 push_char (dtp
, 'f');
1633 push_char (dtp
, 'n');
1634 push_char (dtp
, 'a');
1635 push_char (dtp
, 'n');
1642 if (dtp
->u
.p
.namelist_mode
)
1644 dtp
->u
.p
.nml_read_error
= 1;
1645 dtp
->u
.p
.line_buffer_enabled
= 1;
1646 dtp
->u
.p
.item_count
= 0;
1652 if (nml_bad_return (dtp
, c
))
1657 sprintf (message
, "Bad real number in item %d of list input",
1658 dtp
->u
.p
.item_count
);
1659 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1663 /* Check the current type against the saved type to make sure they are
1664 compatible. Returns nonzero if incompatible. */
1667 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1671 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1673 sprintf (message
, "Read type %s where %s was expected for item %d",
1674 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1675 dtp
->u
.p
.item_count
);
1677 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1681 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1684 if (dtp
->u
.p
.saved_length
!= len
)
1687 "Read kind %d %s where kind %d is required for item %d",
1688 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1689 dtp
->u
.p
.item_count
);
1690 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1698 /* Top level data transfer subroutine for list reads. Because we have
1699 to deal with repeat counts, the data item is always saved after
1700 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1701 greater than one, we copy the data item multiple times. */
1704 list_formatted_read_scalar (st_parameter_dt
*dtp
, volatile bt type
, void *p
,
1705 int kind
, size_t size
)
1712 dtp
->u
.p
.namelist_mode
= 0;
1714 dtp
->u
.p
.eof_jump
= &eof_jump
;
1715 if (setjmp (eof_jump
))
1717 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1718 if (!is_internal_unit (dtp
))
1720 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1721 dtp
->u
.p
.current_unit
->current_record
= 0;
1726 if (dtp
->u
.p
.first_item
)
1728 dtp
->u
.p
.first_item
= 0;
1729 dtp
->u
.p
.input_complete
= 0;
1730 dtp
->u
.p
.repeat_count
= 1;
1731 dtp
->u
.p
.at_eol
= 0;
1733 c
= eat_spaces (dtp
);
1734 if (is_separator (c
))
1736 /* Found a null value. */
1737 eat_separator (dtp
);
1738 dtp
->u
.p
.repeat_count
= 0;
1740 /* eat_separator sets this flag if the separator was a comma. */
1741 if (dtp
->u
.p
.comma_flag
)
1744 /* eat_separator sets this flag if the separator was a \n or \r. */
1745 if (dtp
->u
.p
.at_eol
)
1746 finish_separator (dtp
);
1754 if (dtp
->u
.p
.repeat_count
> 0)
1756 if (check_type (dtp
, type
, kind
))
1761 if (dtp
->u
.p
.input_complete
)
1764 if (dtp
->u
.p
.at_eol
)
1765 finish_separator (dtp
);
1769 /* Trailing spaces prior to end of line. */
1770 if (dtp
->u
.p
.at_eol
)
1771 finish_separator (dtp
);
1774 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1775 dtp
->u
.p
.repeat_count
= 1;
1781 read_integer (dtp
, kind
);
1784 read_logical (dtp
, kind
);
1787 read_character (dtp
, kind
);
1790 read_real (dtp
, p
, kind
);
1791 /* Copy value back to temporary if needed. */
1792 if (dtp
->u
.p
.repeat_count
> 0)
1793 memcpy (dtp
->u
.p
.value
, p
, kind
);
1796 read_complex (dtp
, p
, kind
, size
);
1797 /* Copy value back to temporary if needed. */
1798 if (dtp
->u
.p
.repeat_count
> 0)
1799 memcpy (dtp
->u
.p
.value
, p
, size
);
1802 internal_error (&dtp
->common
, "Bad type for list read");
1805 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1806 dtp
->u
.p
.saved_length
= size
;
1808 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1812 switch (dtp
->u
.p
.saved_type
)
1816 if (dtp
->u
.p
.repeat_count
> 0)
1817 memcpy (p
, dtp
->u
.p
.value
, size
);
1822 memcpy (p
, dtp
->u
.p
.value
, size
);
1826 if (dtp
->u
.p
.saved_string
)
1828 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1829 ? (int) size
: dtp
->u
.p
.saved_used
;
1831 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1834 q
= (gfc_char4_t
*) p
;
1835 for (i
= 0; i
< m
; i
++)
1836 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1840 /* Just delimiters encountered, nothing to copy but SPACE. */
1846 memset (((char *) p
) + m
, ' ', size
- m
);
1849 q
= (gfc_char4_t
*) p
;
1850 for (i
= m
; i
< (int) size
; i
++)
1851 q
[i
] = (unsigned char) ' ';
1860 internal_error (&dtp
->common
, "Bad type for list read");
1863 if (--dtp
->u
.p
.repeat_count
<= 0)
1867 dtp
->u
.p
.eof_jump
= NULL
;
1872 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1873 size_t size
, size_t nelems
)
1877 size_t stride
= type
== BT_CHARACTER
?
1878 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1882 /* Big loop over all the elements. */
1883 for (elem
= 0; elem
< nelems
; elem
++)
1885 dtp
->u
.p
.item_count
++;
1886 list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1891 /* Finish a list read. */
1894 finish_list_read (st_parameter_dt
*dtp
)
1900 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
1902 if (dtp
->u
.p
.at_eol
)
1904 dtp
->u
.p
.at_eol
= 0;
1910 c
= next_char (dtp
);
1914 if (dtp
->u
.p
.current_unit
->endfile
!= NO_ENDFILE
)
1916 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1917 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
1918 dtp
->u
.p
.current_unit
->current_record
= 0;
1924 void namelist_read (st_parameter_dt *dtp)
1926 static void nml_match_name (char *name, int len)
1927 static int nml_query (st_parameter_dt *dtp)
1928 static int nml_get_obj_data (st_parameter_dt *dtp,
1929 namelist_info **prev_nl, char *, size_t)
1931 static void nml_untouch_nodes (st_parameter_dt *dtp)
1932 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1934 static int nml_parse_qualifier(descriptor_dimension * ad,
1935 array_loop_spec * ls, int rank, char *)
1936 static void nml_touch_nodes (namelist_info * nl)
1937 static int nml_read_obj (namelist_info *nl, index_type offset,
1938 namelist_info **prev_nl, char *, size_t,
1939 index_type clow, index_type chigh)
1943 /* Inputs a rank-dimensional qualifier, which can contain
1944 singlets, doublets, triplets or ':' with the standard meanings. */
1947 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1948 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1955 int is_array_section
, is_char
;
1959 is_array_section
= 0;
1960 dtp
->u
.p
.expanded_read
= 0;
1962 /* See if this is a character substring qualifier we are looking for. */
1969 /* The next character in the stream should be the '('. */
1971 c
= next_char (dtp
);
1973 /* Process the qualifier, by dimension and triplet. */
1975 for (dim
=0; dim
< rank
; dim
++ )
1977 for (indx
=0; indx
<3; indx
++)
1983 /* Process a potential sign. */
1984 c
= next_char (dtp
);
1995 unget_char (dtp
, c
);
1999 /* Process characters up to the next ':' , ',' or ')'. */
2002 c
= next_char (dtp
);
2007 is_array_section
= 1;
2011 if ((c
==',' && dim
== rank
-1)
2012 || (c
==')' && dim
< rank
-1))
2015 sprintf (parse_err_msg
, "Bad substring qualifier");
2017 sprintf (parse_err_msg
, "Bad number of index fields");
2026 case ' ': case '\t':
2028 c
= next_char (dtp
);
2033 sprintf (parse_err_msg
,
2034 "Bad character in substring qualifier");
2036 sprintf (parse_err_msg
, "Bad character in index");
2040 if ((c
== ',' || c
== ')') && indx
== 0
2041 && dtp
->u
.p
.saved_string
== 0)
2044 sprintf (parse_err_msg
, "Null substring qualifier");
2046 sprintf (parse_err_msg
, "Null index field");
2050 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2051 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2054 sprintf (parse_err_msg
, "Bad substring qualifier");
2056 sprintf (parse_err_msg
, "Bad index triplet");
2060 if (is_char
&& !is_array_section
)
2062 sprintf (parse_err_msg
,
2063 "Missing colon in substring qualifier");
2067 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2069 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2070 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2076 /* Now read the index. */
2077 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
2080 sprintf (parse_err_msg
, "Bad integer substring qualifier");
2082 sprintf (parse_err_msg
, "Bad integer in index");
2088 /* Feed the index values to the triplet arrays. */
2092 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2094 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2096 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2099 /* Singlet or doublet indices. */
2100 if (c
==',' || c
==')')
2104 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
2106 /* If -std=f95/2003 or an array section is specified,
2107 do not allow excess data to be processed. */
2108 if (is_array_section
== 1
2109 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2110 || !dtp
->u
.p
.ionml
->touched
2111 || dtp
->u
.p
.ionml
->type
== BT_DERIVED
)
2112 ls
[dim
].end
= ls
[dim
].start
;
2114 dtp
->u
.p
.expanded_read
= 1;
2117 /* Check for non-zero rank. */
2118 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2125 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2128 dtp
->u
.p
.expanded_read
= 0;
2129 for (i
= 0; i
< dim
; i
++)
2130 ls
[i
].end
= ls
[i
].start
;
2133 /* Check the values of the triplet indices. */
2134 if ((ls
[dim
].start
> (ssize_t
) GFC_DIMENSION_UBOUND(ad
[dim
]))
2135 || (ls
[dim
].start
< (ssize_t
) GFC_DIMENSION_LBOUND(ad
[dim
]))
2136 || (ls
[dim
].end
> (ssize_t
) GFC_DIMENSION_UBOUND(ad
[dim
]))
2137 || (ls
[dim
].end
< (ssize_t
) GFC_DIMENSION_LBOUND(ad
[dim
])))
2140 sprintf (parse_err_msg
, "Substring out of range");
2142 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
2146 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2147 || (ls
[dim
].step
== 0))
2149 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
2153 /* Initialise the loop index counter. */
2154 ls
[dim
].idx
= ls
[dim
].start
;
2164 static namelist_info
*
2165 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2167 namelist_info
* t
= dtp
->u
.p
.ionml
;
2170 if (strcmp (var_name
, t
->var_name
) == 0)
2180 /* Visits all the components of a derived type that have
2181 not explicitly been identified in the namelist input.
2182 touched is set and the loop specification initialised
2183 to default values */
2186 nml_touch_nodes (namelist_info
* nl
)
2188 index_type len
= strlen (nl
->var_name
) + 1;
2190 char * ext_name
= (char*)get_mem (len
+ 1);
2191 memcpy (ext_name
, nl
->var_name
, len
-1);
2192 memcpy (ext_name
+ len
- 1, "%", 2);
2193 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2195 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2198 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2200 nl
->ls
[dim
].step
= 1;
2201 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2202 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2203 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2213 /* Resets touched for the entire list of nml_nodes, ready for a
2217 nml_untouch_nodes (st_parameter_dt
*dtp
)
2220 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2225 /* Attempts to input name to namelist name. Returns
2226 dtp->u.p.nml_read_error = 1 on no match. */
2229 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2233 dtp
->u
.p
.nml_read_error
= 0;
2234 for (i
= 0; i
< len
; i
++)
2236 c
= next_char (dtp
);
2237 if (tolower (c
) != tolower (name
[i
]))
2239 dtp
->u
.p
.nml_read_error
= 1;
2245 /* If the namelist read is from stdin, output the current state of the
2246 namelist to stdout. This is used to implement the non-standard query
2247 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2248 the names alone are printed. */
2251 nml_query (st_parameter_dt
*dtp
, char c
)
2253 gfc_unit
* temp_unit
;
2258 static const index_type endlen
= 3;
2259 static const char endl
[] = "\r\n";
2260 static const char nmlend
[] = "&end\r\n";
2262 static const index_type endlen
= 2;
2263 static const char endl
[] = "\n";
2264 static const char nmlend
[] = "&end\n";
2267 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2270 /* Store the current unit and transfer to stdout. */
2272 temp_unit
= dtp
->u
.p
.current_unit
;
2273 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2275 if (dtp
->u
.p
.current_unit
)
2277 dtp
->u
.p
.mode
= WRITING
;
2278 next_record (dtp
, 0);
2280 /* Write the namelist in its entirety. */
2283 namelist_write (dtp
);
2285 /* Or write the list of names. */
2289 /* "&namelist_name\n" */
2291 len
= dtp
->namelist_name_len
;
2292 p
= write_block (dtp
, len
+ endlen
);
2296 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2297 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2298 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2302 len
= strlen (nl
->var_name
);
2303 p
= write_block (dtp
, len
+ endlen
);
2307 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2308 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
- 1);
2313 p
= write_block (dtp
, endlen
+ 3);
2315 memcpy (p
, &nmlend
, endlen
+ 3);
2318 /* Flush the stream to force immediate output. */
2320 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2321 sflush (dtp
->u
.p
.current_unit
->s
);
2322 unlock_unit (dtp
->u
.p
.current_unit
);
2327 /* Restore the current unit. */
2329 dtp
->u
.p
.current_unit
= temp_unit
;
2330 dtp
->u
.p
.mode
= READING
;
2334 /* Reads and stores the input for the namelist object nl. For an array,
2335 the function loops over the ranges defined by the loop specification.
2336 This default to all the data or to the specification from a qualifier.
2337 nml_read_obj recursively calls itself to read derived types. It visits
2338 all its own components but only reads data for those that were touched
2339 when the name was parsed. If a read error is encountered, an attempt is
2340 made to return to read a new object name because the standard allows too
2341 little data to be available. On the other hand, too much data is an
2345 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2346 namelist_info
**pprev_nl
, char *nml_err_msg
,
2347 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2349 namelist_info
* cmp
;
2356 size_t obj_name_len
;
2359 /* This object not touched in name parsing. */
2364 dtp
->u
.p
.repeat_count
= 0;
2376 dlen
= size_from_real_kind (len
);
2380 dlen
= size_from_complex_kind (len
);
2384 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2393 /* Update the pointer to the data, using the current index vector */
2395 pdata
= (void*)(nl
->mem_pos
+ offset
);
2396 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2397 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2398 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2399 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2401 /* Reset the error flag and try to read next value, if
2402 dtp->u.p.repeat_count=0 */
2404 dtp
->u
.p
.nml_read_error
= 0;
2406 if (--dtp
->u
.p
.repeat_count
<= 0)
2408 if (dtp
->u
.p
.input_complete
)
2410 if (dtp
->u
.p
.at_eol
)
2411 finish_separator (dtp
);
2412 if (dtp
->u
.p
.input_complete
)
2415 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2421 read_integer (dtp
, len
);
2425 read_logical (dtp
, len
);
2429 read_character (dtp
, len
);
2433 /* Need to copy data back from the real location to the temp in order
2434 to handle nml reads into arrays. */
2435 read_real (dtp
, pdata
, len
);
2436 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2440 /* Same as for REAL, copy back to temp. */
2441 read_complex (dtp
, pdata
, len
, dlen
);
2442 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2446 obj_name_len
= strlen (nl
->var_name
) + 1;
2447 obj_name
= get_mem (obj_name_len
+1);
2448 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2449 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2451 /* If reading a derived type, disable the expanded read warning
2452 since a single object can have multiple reads. */
2453 dtp
->u
.p
.expanded_read
= 0;
2455 /* Now loop over the components. Update the component pointer
2456 with the return value from nml_write_obj. This loop jumps
2457 past nested derived types by testing if the potential
2458 component name contains '%'. */
2460 for (cmp
= nl
->next
;
2462 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2463 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2467 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2468 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2469 clow
, chigh
) == FAILURE
)
2475 if (dtp
->u
.p
.input_complete
)
2486 snprintf (nml_err_msg
, nml_err_msg_size
,
2487 "Bad type for namelist object %s", nl
->var_name
);
2488 internal_error (&dtp
->common
, nml_err_msg
);
2493 /* The standard permits array data to stop short of the number of
2494 elements specified in the loop specification. In this case, we
2495 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2496 nml_get_obj_data and an attempt is made to read object name. */
2499 if (dtp
->u
.p
.nml_read_error
)
2501 dtp
->u
.p
.expanded_read
= 0;
2505 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2507 dtp
->u
.p
.expanded_read
= 0;
2511 switch (dtp
->u
.p
.saved_type
)
2518 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2522 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2523 pdata
= (void*)( pdata
+ clow
- 1 );
2524 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2526 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2533 /* Warn if a non-standard expanded read occurs. A single read of a
2534 single object is acceptable. If a second read occurs, issue a warning
2535 and set the flag to zero to prevent further warnings. */
2536 if (dtp
->u
.p
.expanded_read
== 2)
2538 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2539 dtp
->u
.p
.expanded_read
= 0;
2542 /* If the expanded read warning flag is set, increment it,
2543 indicating that a single read has occurred. */
2544 if (dtp
->u
.p
.expanded_read
>= 1)
2545 dtp
->u
.p
.expanded_read
++;
2547 /* Break out of loop if scalar. */
2551 /* Now increment the index vector. */
2556 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2558 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2560 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2562 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2564 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2568 } while (!nml_carry
);
2570 if (dtp
->u
.p
.repeat_count
> 1)
2572 snprintf (nml_err_msg
, nml_err_msg_size
,
2573 "Repeat count too large for namelist object %s", nl
->var_name
);
2583 /* Parses the object name, including array and substring qualifiers. It
2584 iterates over derived type components, touching those components and
2585 setting their loop specifications, if there is a qualifier. If the
2586 object is itself a derived type, its components and subcomponents are
2587 touched. nml_read_obj is called at the end and this reads the data in
2588 the manner specified by the object name. */
2591 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2592 char *nml_err_msg
, size_t nml_err_msg_size
)
2596 namelist_info
* first_nl
= NULL
;
2597 namelist_info
* root_nl
= NULL
;
2598 int dim
, parsed_rank
;
2599 int component_flag
, qualifier_flag
;
2600 index_type clow
, chigh
;
2601 int non_zero_rank_count
;
2603 /* Look for end of input or object name. If '?' or '=?' are encountered
2604 in stdin, print the node names or the namelist to stdout. */
2606 eat_separator (dtp
);
2607 if (dtp
->u
.p
.input_complete
)
2610 if (dtp
->u
.p
.at_eol
)
2611 finish_separator (dtp
);
2612 if (dtp
->u
.p
.input_complete
)
2615 c
= next_char (dtp
);
2619 c
= next_char (dtp
);
2622 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2625 nml_query (dtp
, '=');
2629 nml_query (dtp
, '?');
2634 nml_match_name (dtp
, "end", 3);
2635 if (dtp
->u
.p
.nml_read_error
)
2637 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2641 dtp
->u
.p
.input_complete
= 1;
2648 /* Untouch all nodes of the namelist and reset the flags that are set for
2649 derived type components. */
2651 nml_untouch_nodes (dtp
);
2654 non_zero_rank_count
= 0;
2656 /* Get the object name - should '!' and '\n' be permitted separators? */
2664 if (!is_separator (c
))
2665 push_char (dtp
, tolower(c
));
2666 c
= next_char (dtp
);
2667 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2669 unget_char (dtp
, c
);
2671 /* Check that the name is in the namelist and get pointer to object.
2672 Three error conditions exist: (i) An attempt is being made to
2673 identify a non-existent object, following a failed data read or
2674 (ii) The object name does not exist or (iii) Too many data items
2675 are present for an object. (iii) gives the same error message
2678 push_char (dtp
, '\0');
2682 size_t var_len
= strlen (root_nl
->var_name
);
2684 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2685 char ext_name
[var_len
+ saved_len
+ 1];
2687 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2688 if (dtp
->u
.p
.saved_string
)
2689 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2690 ext_name
[var_len
+ saved_len
] = '\0';
2691 nl
= find_nml_node (dtp
, ext_name
);
2694 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2698 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2699 snprintf (nml_err_msg
, nml_err_msg_size
,
2700 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2703 snprintf (nml_err_msg
, nml_err_msg_size
,
2704 "Cannot match namelist object name %s",
2705 dtp
->u
.p
.saved_string
);
2710 /* Get the length, data length, base pointer and rank of the variable.
2711 Set the default loop specification first. */
2713 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2715 nl
->ls
[dim
].step
= 1;
2716 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2717 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2718 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2721 /* Check to see if there is a qualifier: if so, parse it.*/
2723 if (c
== '(' && nl
->var_rank
)
2726 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2727 nml_err_msg
, &parsed_rank
) == FAILURE
)
2729 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2730 snprintf (nml_err_msg_end
,
2731 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2732 " for namelist variable %s", nl
->var_name
);
2735 if (parsed_rank
> 0)
2736 non_zero_rank_count
++;
2740 c
= next_char (dtp
);
2741 unget_char (dtp
, c
);
2743 else if (nl
->var_rank
> 0)
2744 non_zero_rank_count
++;
2746 /* Now parse a derived type component. The root namelist_info address
2747 is backed up, as is the previous component level. The component flag
2748 is set and the iteration is made by jumping back to get_name. */
2752 if (nl
->type
!= BT_DERIVED
)
2754 snprintf (nml_err_msg
, nml_err_msg_size
,
2755 "Attempt to get derived component for %s", nl
->var_name
);
2759 if (*pprev_nl
== NULL
|| !component_flag
)
2766 c
= next_char (dtp
);
2770 /* Parse a character qualifier, if present. chigh = 0 is a default
2771 that signals that the string length = string_length. */
2776 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2778 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2779 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2781 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nml_err_msg
, &parsed_rank
)
2784 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2785 snprintf (nml_err_msg_end
,
2786 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2787 " for namelist variable %s", nl
->var_name
);
2791 clow
= ind
[0].start
;
2794 if (ind
[0].step
!= 1)
2796 snprintf (nml_err_msg
, nml_err_msg_size
,
2797 "Step not allowed in substring qualifier"
2798 " for namelist object %s", nl
->var_name
);
2802 c
= next_char (dtp
);
2803 unget_char (dtp
, c
);
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",
2850 /* If a derived type, touch its components and restore the root
2851 namelist_info if we have parsed a qualified derived type
2854 if (nl
->type
== BT_DERIVED
)
2855 nml_touch_nodes (nl
);
2859 if (first_nl
->var_rank
== 0)
2861 if (component_flag
&& qualifier_flag
)
2868 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2869 clow
, chigh
) == FAILURE
)
2879 /* Entry point for namelist input. Goes through input until namelist name
2880 is matched. Then cycles through nml_get_obj_data until the input is
2881 completed or there is an error. */
2884 namelist_read (st_parameter_dt
*dtp
)
2888 char nml_err_msg
[200];
2889 /* Pointer to the previously read object, in case attempt is made to read
2890 new object name. Should this fail, error message can give previous
2892 namelist_info
*prev_nl
= NULL
;
2894 dtp
->u
.p
.namelist_mode
= 1;
2895 dtp
->u
.p
.input_complete
= 0;
2896 dtp
->u
.p
.expanded_read
= 0;
2898 dtp
->u
.p
.eof_jump
= &eof_jump
;
2899 if (setjmp (eof_jump
))
2901 dtp
->u
.p
.eof_jump
= NULL
;
2902 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2906 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2907 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2908 node names or namelist on stdout. */
2911 switch (c
= next_char (dtp
))
2922 c
= next_char (dtp
);
2924 nml_query (dtp
, '=');
2926 unget_char (dtp
, c
);
2930 nml_query (dtp
, '?');
2936 /* Match the name of the namelist. */
2938 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2940 if (dtp
->u
.p
.nml_read_error
)
2943 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2944 c
= next_char (dtp
);
2945 if (!is_separator(c
) && c
!= '!')
2947 unget_char (dtp
, c
);
2951 unget_char (dtp
, c
);
2952 eat_separator (dtp
);
2954 /* Ready to read namelist objects. If there is an error in input
2955 from stdin, output the error message and continue. */
2957 while (!dtp
->u
.p
.input_complete
)
2959 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
2962 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2964 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
2968 dtp
->u
.p
.eof_jump
= NULL
;
2973 /* All namelist error calls return from here */
2977 dtp
->u
.p
.eof_jump
= NULL
;
2980 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);