1 /* Copyright (C) 2002-2013 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
36 /* List directed input. Several parsing subroutines are practically
37 reimplemented from formatted input, the reason being that there are
38 all kinds of small differences between formatted and list directed
42 /* Subroutines for reading characters from the input. Because a
43 repeat count is ambiguous with an integer, we have to read the
44 whole digit string before seeing if there is a '*' which signals
45 the repeat count. Since we can have a lot of potential leading
46 zeros, we have to be able to back up by arbitrary amount. Because
47 the input might not be seekable, we have to buffer the data
50 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
51 case '5': case '6': case '7': case '8': case '9'
53 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
56 /* This macro assumes that we're operating on a variable. */
58 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
59 || c == '\t' || c == '\r' || c == ';')
61 /* Maximum repeat count. Less than ten times the maximum signed int32. */
63 #define MAX_REPEAT 200000000
68 /* Save a character to a string buffer, enlarging it as necessary. */
71 push_char (st_parameter_dt
*dtp
, char c
)
75 if (dtp
->u
.p
.saved_string
== NULL
)
77 // Plain malloc should suffice here, zeroing not needed?
78 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
79 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
80 dtp
->u
.p
.saved_used
= 0;
83 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
85 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
86 new = realloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
88 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
89 dtp
->u
.p
.saved_string
= new;
91 // Also this should not be necessary.
92 memset (new + dtp
->u
.p
.saved_used
, 0,
93 dtp
->u
.p
.saved_length
- dtp
->u
.p
.saved_used
);
97 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
101 /* Free the input buffer if necessary. */
104 free_saved (st_parameter_dt
*dtp
)
106 if (dtp
->u
.p
.saved_string
== NULL
)
109 free (dtp
->u
.p
.saved_string
);
111 dtp
->u
.p
.saved_string
= NULL
;
112 dtp
->u
.p
.saved_used
= 0;
116 /* Free the line buffer if necessary. */
119 free_line (st_parameter_dt
*dtp
)
121 dtp
->u
.p
.line_buffer_pos
= 0;
122 dtp
->u
.p
.line_buffer_enabled
= 0;
124 if (dtp
->u
.p
.line_buffer
== NULL
)
127 free (dtp
->u
.p
.line_buffer
);
128 dtp
->u
.p
.line_buffer
= NULL
;
133 next_char (st_parameter_dt
*dtp
)
139 if (dtp
->u
.p
.last_char
!= EOF
- 1)
142 c
= dtp
->u
.p
.last_char
;
143 dtp
->u
.p
.last_char
= EOF
- 1;
147 /* Read from line_buffer if enabled. */
149 if (dtp
->u
.p
.line_buffer_enabled
)
153 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
];
154 if (c
!= '\0' && dtp
->u
.p
.line_buffer_pos
< 64)
156 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
] = '\0';
157 dtp
->u
.p
.line_buffer_pos
++;
161 dtp
->u
.p
.line_buffer_pos
= 0;
162 dtp
->u
.p
.line_buffer_enabled
= 0;
165 /* Handle the end-of-record and end-of-file conditions for
166 internal array unit. */
167 if (is_array_io (dtp
))
172 /* Check for "end-of-record" condition. */
173 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
178 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
181 /* Check for "end-of-file" condition. */
188 record
*= dtp
->u
.p
.current_unit
->recl
;
189 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
192 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
197 /* Get the next character and handle end-of-record conditions. */
199 if (is_internal_unit (dtp
))
201 /* Check for kind=4 internal unit. */
202 if (dtp
->common
.unit
)
203 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, sizeof (gfc_char4_t
));
207 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
213 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
217 if (is_array_io (dtp
))
219 /* Check whether we hit EOF. */
222 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
225 dtp
->u
.p
.current_unit
->bytes_left
--;
240 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
241 if (c
!= EOF
&& is_stream_io (dtp
))
242 dtp
->u
.p
.current_unit
->strm_pos
++;
245 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt
*dtp
, int c
)
255 dtp
->u
.p
.last_char
= c
;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt
*dtp
)
269 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
276 /* This function reads characters through to the end of the current
277 line and just ignores them. Returns 0 for success and LIBERROR_END
281 eat_line (st_parameter_dt
*dtp
)
287 while (c
!= EOF
&& c
!= '\n');
294 /* Skip over a separator. Technically, we don't always eat the whole
295 separator. This is because if we've processed the last input item,
296 then a separator is unnecessary. Plus the fact that operating
297 systems usually deliver console input on a line basis.
299 The upshot is that if we see a newline as part of reading a
300 separator, we stop reading. If there are more input items, we
301 continue reading the separator with finish_separator() which takes
302 care of the fact that we may or may not have seen a comma as part
305 Returns 0 for success, and non-zero error code otherwise. */
308 eat_separator (st_parameter_dt
*dtp
)
314 dtp
->u
.p
.comma_flag
= 0;
316 if ((c
= next_char (dtp
)) == EOF
)
321 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
328 dtp
->u
.p
.comma_flag
= 1;
333 dtp
->u
.p
.input_complete
= 1;
338 if ((n
= next_char(dtp
)) == EOF
)
348 if (dtp
->u
.p
.namelist_mode
)
352 if ((c
= next_char (dtp
)) == EOF
)
356 err
= eat_line (dtp
);
362 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
368 if (dtp
->u
.p
.namelist_mode
)
369 { /* Eat a namelist comment. */
370 err
= eat_line (dtp
);
377 /* Fall Through... */
387 /* Finish processing a separator that was interrupted by a newline.
388 If we're here, then another data item is present, so we finish what
389 we started on the previous line. Return 0 on success, error code
393 finish_separator (st_parameter_dt
*dtp
)
401 if ((c
= next_char (dtp
)) == EOF
)
406 if (dtp
->u
.p
.comma_flag
)
410 if ((c
= eat_spaces (dtp
)) == EOF
)
412 if (c
== '\n' || c
== '\r')
419 dtp
->u
.p
.input_complete
= 1;
420 if (!dtp
->u
.p
.namelist_mode
)
429 if (dtp
->u
.p
.namelist_mode
)
431 err
= eat_line (dtp
);
445 /* This function is needed to catch bad conversions so that namelist can
446 attempt to see if dtp->u.p.saved_string contains a new object name rather
450 nml_bad_return (st_parameter_dt
*dtp
, char c
)
452 if (dtp
->u
.p
.namelist_mode
)
454 dtp
->u
.p
.nml_read_error
= 1;
461 /* Convert an unsigned string to an integer. The length value is -1
462 if we are working on a repeat count. Returns nonzero if we have a
463 range problem. As a side effect, frees the dtp->u.p.saved_string. */
466 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
468 char c
, *buffer
, message
[MSGLEN
];
470 GFC_UINTEGER_LARGEST v
, max
, max10
;
471 GFC_INTEGER_LARGEST value
;
473 buffer
= dtp
->u
.p
.saved_string
;
480 max
= si_max (length
);
510 set_integer (dtp
->u
.p
.value
, value
, length
);
514 dtp
->u
.p
.repeat_count
= v
;
516 if (dtp
->u
.p
.repeat_count
== 0)
518 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
519 dtp
->u
.p
.item_count
);
521 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
531 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
532 dtp
->u
.p
.item_count
);
534 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
535 dtp
->u
.p
.item_count
);
538 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
544 /* Parse a repeat count for logical and complex values which cannot
545 begin with a digit. Returns nonzero if we are done, zero if we
546 should continue on. */
549 parse_repeat (st_parameter_dt
*dtp
)
551 char message
[MSGLEN
];
554 if ((c
= next_char (dtp
)) == EOF
)
578 repeat
= 10 * repeat
+ c
- '0';
580 if (repeat
> MAX_REPEAT
)
582 snprintf (message
, MSGLEN
,
583 "Repeat count overflow in item %d of list input",
584 dtp
->u
.p
.item_count
);
586 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
595 snprintf (message
, MSGLEN
,
596 "Zero repeat count in item %d of list input",
597 dtp
->u
.p
.item_count
);
599 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
611 dtp
->u
.p
.repeat_count
= repeat
;
625 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
626 dtp
->u
.p
.item_count
);
627 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
632 /* To read a logical we have to look ahead in the input stream to make sure
633 there is not an equal sign indicating a variable name. To do this we use
634 line_buffer to point to a temporary buffer, pushing characters there for
635 possible later reading. */
638 l_push_char (st_parameter_dt
*dtp
, char c
)
640 if (dtp
->u
.p
.line_buffer
== NULL
)
641 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
643 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
++] = c
;
647 /* Read a logical character on the input. */
650 read_logical (st_parameter_dt
*dtp
, int length
)
652 char message
[MSGLEN
];
655 if (parse_repeat (dtp
))
658 c
= tolower (next_char (dtp
));
659 l_push_char (dtp
, c
);
665 l_push_char (dtp
, c
);
667 if (!is_separator(c
) && c
!= EOF
)
675 l_push_char (dtp
, c
);
677 if (!is_separator(c
) && c
!= EOF
)
684 c
= tolower (next_char (dtp
));
703 return; /* Null value. */
706 /* Save the character in case it is the beginning
707 of the next object name. */
712 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
713 dtp
->u
.p
.saved_length
= length
;
715 /* Eat trailing garbage. */
718 while (c
!= EOF
&& !is_separator (c
));
722 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
729 for(i
= 0; i
< 63; i
++)
734 /* All done if this is not a namelist read. */
735 if (!dtp
->u
.p
.namelist_mode
)
748 l_push_char (dtp
, c
);
751 dtp
->u
.p
.nml_read_error
= 1;
752 dtp
->u
.p
.line_buffer_enabled
= 1;
753 dtp
->u
.p
.line_buffer_pos
= 0;
761 if (nml_bad_return (dtp
, c
))
777 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
778 dtp
->u
.p
.item_count
);
780 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
785 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
786 dtp
->u
.p
.saved_length
= length
;
787 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
793 /* Reading integers is tricky because we can actually be reading a
794 repeat count. We have to store the characters in a buffer because
795 we could be reading an integer that is larger than the default int
796 used for repeat counts. */
799 read_integer (st_parameter_dt
*dtp
, int length
)
801 char message
[MSGLEN
];
811 /* Fall through... */
814 if ((c
= next_char (dtp
)) == EOF
)
818 CASE_SEPARATORS
: /* Single null. */
831 /* Take care of what may be a repeat count. */
843 push_char (dtp
, '\0');
846 CASE_SEPARATORS
: /* Not a repeat count. */
856 if (convert_integer (dtp
, -1, 0))
859 /* Get the real integer. */
861 if ((c
= next_char (dtp
)) == EOF
)
875 /* Fall through... */
907 if (nml_bad_return (dtp
, c
))
920 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
921 dtp
->u
.p
.item_count
);
923 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
931 push_char (dtp
, '\0');
932 if (convert_integer (dtp
, length
, negative
))
939 dtp
->u
.p
.saved_type
= BT_INTEGER
;
943 /* Read a character variable. */
946 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
948 char quote
, message
[MSGLEN
];
951 quote
= ' '; /* Space means no quote character. */
953 if ((c
= next_char (dtp
)) == EOF
)
963 unget_char (dtp
, c
); /* NULL value. */
973 if (dtp
->u
.p
.namelist_mode
)
983 /* Deal with a possible repeat count. */
997 goto done
; /* String was only digits! */
1000 push_char (dtp
, '\0');
1005 goto get_string
; /* Not a repeat count after all. */
1010 if (convert_integer (dtp
, -1, 0))
1013 /* Now get the real string. */
1015 if ((c
= next_char (dtp
)) == EOF
)
1020 unget_char (dtp
, c
); /* Repeated NULL values. */
1021 eat_separator (dtp
);
1037 if ((c
= next_char (dtp
)) == EOF
)
1049 /* See if we have a doubled quote character or the end of
1052 if ((c
= next_char (dtp
)) == EOF
)
1056 push_char (dtp
, quote
);
1060 unget_char (dtp
, c
);
1066 unget_char (dtp
, c
);
1070 if (c
!= '\n' && c
!= '\r')
1080 /* At this point, we have to have a separator, or else the string is
1083 c
= next_char (dtp
);
1085 if (is_separator (c
) || c
== '!' || c
== EOF
)
1087 unget_char (dtp
, c
);
1088 eat_separator (dtp
);
1089 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1094 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1095 dtp
->u
.p
.item_count
);
1096 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1108 /* Parse a component of a complex constant or a real number that we
1109 are sure is already there. This is a straight real number parser. */
1112 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1114 char message
[MSGLEN
];
1117 if ((c
= next_char (dtp
)) == EOF
)
1120 if (c
== '-' || c
== '+')
1123 if ((c
= next_char (dtp
)) == EOF
)
1127 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1130 if (!isdigit (c
) && c
!= '.')
1132 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1140 seen_dp
= (c
== '.') ? 1 : 0;
1144 if ((c
= next_char (dtp
)) == EOF
)
1146 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1168 push_char (dtp
, 'e');
1173 push_char (dtp
, 'e');
1175 if ((c
= next_char (dtp
)) == EOF
)
1189 if ((c
= next_char (dtp
)) == EOF
)
1191 if (c
!= '-' && c
!= '+')
1192 push_char (dtp
, '+');
1196 c
= next_char (dtp
);
1207 if ((c
= next_char (dtp
)) == EOF
)
1217 unget_char (dtp
, c
);
1226 unget_char (dtp
, c
);
1227 push_char (dtp
, '\0');
1229 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1235 unget_char (dtp
, c
);
1236 push_char (dtp
, '\0');
1238 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1244 /* Match INF and Infinity. */
1245 if ((c
== 'i' || c
== 'I')
1246 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1247 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1249 c
= next_char (dtp
);
1250 if ((c
!= 'i' && c
!= 'I')
1251 || ((c
== 'i' || c
== 'I')
1252 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1253 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1254 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1255 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1256 && (c
= next_char (dtp
))))
1258 if (is_separator (c
) || (c
== EOF
))
1259 unget_char (dtp
, c
);
1260 push_char (dtp
, 'i');
1261 push_char (dtp
, 'n');
1262 push_char (dtp
, 'f');
1266 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1267 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1268 && (c
= next_char (dtp
)))
1270 if (is_separator (c
) || (c
== EOF
))
1271 unget_char (dtp
, c
);
1272 push_char (dtp
, 'n');
1273 push_char (dtp
, 'a');
1274 push_char (dtp
, 'n');
1276 /* Match "NAN(alphanum)". */
1279 for ( ; c
!= ')'; c
= next_char (dtp
))
1280 if (is_separator (c
))
1283 c
= next_char (dtp
);
1284 if (is_separator (c
) || (c
== EOF
))
1285 unget_char (dtp
, c
);
1292 if (nml_bad_return (dtp
, c
))
1305 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1306 dtp
->u
.p
.item_count
);
1308 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1314 /* Reading a complex number is straightforward because we can tell
1315 what it is right away. */
1318 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1320 char message
[MSGLEN
];
1323 if (parse_repeat (dtp
))
1326 c
= next_char (dtp
);
1334 unget_char (dtp
, c
);
1335 eat_separator (dtp
);
1344 c
= next_char (dtp
);
1345 if (c
== '\n' || c
== '\r')
1348 unget_char (dtp
, c
);
1350 if (parse_real (dtp
, dest
, kind
))
1355 c
= next_char (dtp
);
1356 if (c
== '\n' || c
== '\r')
1359 unget_char (dtp
, c
);
1362 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1367 c
= next_char (dtp
);
1368 if (c
== '\n' || c
== '\r')
1371 unget_char (dtp
, c
);
1373 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1378 c
= next_char (dtp
);
1379 if (c
== '\n' || c
== '\r')
1382 unget_char (dtp
, c
);
1384 if (next_char (dtp
) != ')')
1387 c
= next_char (dtp
);
1388 if (!is_separator (c
) && (c
!= EOF
))
1391 unget_char (dtp
, c
);
1392 eat_separator (dtp
);
1395 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1400 if (nml_bad_return (dtp
, c
))
1413 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1414 dtp
->u
.p
.item_count
);
1416 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1420 /* Parse a real number with a possible repeat count. */
1423 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1425 char message
[MSGLEN
];
1432 c
= next_char (dtp
);
1433 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1451 unget_char (dtp
, c
); /* Single null. */
1452 eat_separator (dtp
);
1465 /* Get the digit string that might be a repeat count. */
1469 c
= next_char (dtp
);
1470 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1496 push_char (dtp
, 'e');
1498 c
= next_char (dtp
);
1502 push_char (dtp
, '\0');
1507 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1508 unget_char (dtp
, c
);
1517 if (convert_integer (dtp
, -1, 0))
1520 /* Now get the number itself. */
1522 if ((c
= next_char (dtp
)) == EOF
)
1524 if (is_separator (c
))
1525 { /* Repeated null value. */
1526 unget_char (dtp
, c
);
1527 eat_separator (dtp
);
1531 if (c
!= '-' && c
!= '+')
1532 push_char (dtp
, '+');
1537 if ((c
= next_char (dtp
)) == EOF
)
1541 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1544 if (!isdigit (c
) && c
!= '.')
1546 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1565 c
= next_char (dtp
);
1566 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1596 push_char (dtp
, 'e');
1598 c
= next_char (dtp
);
1607 push_char (dtp
, 'e');
1609 if ((c
= next_char (dtp
)) == EOF
)
1611 if (c
!= '+' && c
!= '-')
1612 push_char (dtp
, '+');
1616 c
= next_char (dtp
);
1626 c
= next_char (dtp
);
1644 unget_char (dtp
, c
);
1645 eat_separator (dtp
);
1646 push_char (dtp
, '\0');
1647 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1654 dtp
->u
.p
.saved_type
= BT_REAL
;
1658 l_push_char (dtp
, c
);
1661 /* Match INF and Infinity. */
1662 if (c
== 'i' || c
== 'I')
1664 c
= next_char (dtp
);
1665 l_push_char (dtp
, c
);
1666 if (c
!= 'n' && c
!= 'N')
1668 c
= next_char (dtp
);
1669 l_push_char (dtp
, c
);
1670 if (c
!= 'f' && c
!= 'F')
1672 c
= next_char (dtp
);
1673 l_push_char (dtp
, c
);
1674 if (!is_separator (c
) && (c
!= EOF
))
1676 if (c
!= 'i' && c
!= 'I')
1678 c
= next_char (dtp
);
1679 l_push_char (dtp
, c
);
1680 if (c
!= 'n' && c
!= 'N')
1682 c
= next_char (dtp
);
1683 l_push_char (dtp
, c
);
1684 if (c
!= 'i' && c
!= 'I')
1686 c
= next_char (dtp
);
1687 l_push_char (dtp
, c
);
1688 if (c
!= 't' && c
!= 'T')
1690 c
= next_char (dtp
);
1691 l_push_char (dtp
, c
);
1692 if (c
!= 'y' && c
!= 'Y')
1694 c
= next_char (dtp
);
1695 l_push_char (dtp
, c
);
1701 c
= next_char (dtp
);
1702 l_push_char (dtp
, c
);
1703 if (c
!= 'a' && c
!= 'A')
1705 c
= next_char (dtp
);
1706 l_push_char (dtp
, c
);
1707 if (c
!= 'n' && c
!= 'N')
1709 c
= next_char (dtp
);
1710 l_push_char (dtp
, c
);
1712 /* Match NAN(alphanum). */
1715 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1716 if (is_separator (c
))
1719 l_push_char (dtp
, c
);
1721 l_push_char (dtp
, ')');
1722 c
= next_char (dtp
);
1723 l_push_char (dtp
, c
);
1727 if (!is_separator (c
) && (c
!= EOF
))
1730 if (dtp
->u
.p
.namelist_mode
)
1732 if (c
== ' ' || c
=='\n' || c
== '\r')
1736 if ((c
= next_char (dtp
)) == EOF
)
1739 while (c
== ' ' || c
=='\n' || c
== '\r');
1741 l_push_char (dtp
, c
);
1750 push_char (dtp
, 'i');
1751 push_char (dtp
, 'n');
1752 push_char (dtp
, 'f');
1756 push_char (dtp
, 'n');
1757 push_char (dtp
, 'a');
1758 push_char (dtp
, 'n');
1762 unget_char (dtp
, c
);
1763 eat_separator (dtp
);
1764 push_char (dtp
, '\0');
1765 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1769 dtp
->u
.p
.saved_type
= BT_REAL
;
1773 if (dtp
->u
.p
.namelist_mode
)
1775 dtp
->u
.p
.nml_read_error
= 1;
1776 dtp
->u
.p
.line_buffer_enabled
= 1;
1777 dtp
->u
.p
.line_buffer_pos
= 0;
1783 if (nml_bad_return (dtp
, c
))
1796 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1797 dtp
->u
.p
.item_count
);
1799 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1803 /* Check the current type against the saved type to make sure they are
1804 compatible. Returns nonzero if incompatible. */
1807 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1809 char message
[MSGLEN
];
1811 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
1813 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
1814 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1815 dtp
->u
.p
.item_count
);
1817 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1821 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1824 if (dtp
->u
.p
.saved_length
!= len
)
1826 snprintf (message
, MSGLEN
,
1827 "Read kind %d %s where kind %d is required for item %d",
1828 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1829 dtp
->u
.p
.item_count
);
1830 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1839 /* Top level data transfer subroutine for list reads. Because we have
1840 to deal with repeat counts, the data item is always saved after
1841 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1842 greater than one, we copy the data item multiple times. */
1845 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
1846 int kind
, size_t size
)
1852 dtp
->u
.p
.namelist_mode
= 0;
1854 if (dtp
->u
.p
.first_item
)
1856 dtp
->u
.p
.first_item
= 0;
1857 dtp
->u
.p
.input_complete
= 0;
1858 dtp
->u
.p
.repeat_count
= 1;
1859 dtp
->u
.p
.at_eol
= 0;
1861 if ((c
= eat_spaces (dtp
)) == EOF
)
1866 if (is_separator (c
))
1868 /* Found a null value. */
1869 eat_separator (dtp
);
1870 dtp
->u
.p
.repeat_count
= 0;
1872 /* eat_separator sets this flag if the separator was a comma. */
1873 if (dtp
->u
.p
.comma_flag
)
1876 /* eat_separator sets this flag if the separator was a \n or \r. */
1877 if (dtp
->u
.p
.at_eol
)
1878 finish_separator (dtp
);
1886 if (dtp
->u
.p
.repeat_count
> 0)
1888 if (check_type (dtp
, type
, kind
))
1893 if (dtp
->u
.p
.input_complete
)
1896 if (dtp
->u
.p
.at_eol
)
1897 finish_separator (dtp
);
1901 /* Trailing spaces prior to end of line. */
1902 if (dtp
->u
.p
.at_eol
)
1903 finish_separator (dtp
);
1906 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
1907 dtp
->u
.p
.repeat_count
= 1;
1913 read_integer (dtp
, kind
);
1916 read_logical (dtp
, kind
);
1919 read_character (dtp
, kind
);
1922 read_real (dtp
, p
, kind
);
1923 /* Copy value back to temporary if needed. */
1924 if (dtp
->u
.p
.repeat_count
> 0)
1925 memcpy (dtp
->u
.p
.value
, p
, size
);
1928 read_complex (dtp
, p
, kind
, size
);
1929 /* Copy value back to temporary if needed. */
1930 if (dtp
->u
.p
.repeat_count
> 0)
1931 memcpy (dtp
->u
.p
.value
, p
, size
);
1934 internal_error (&dtp
->common
, "Bad type for list read");
1937 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
1938 dtp
->u
.p
.saved_length
= size
;
1940 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1944 switch (dtp
->u
.p
.saved_type
)
1948 if (dtp
->u
.p
.repeat_count
> 0)
1949 memcpy (p
, dtp
->u
.p
.value
, size
);
1954 memcpy (p
, dtp
->u
.p
.value
, size
);
1958 if (dtp
->u
.p
.saved_string
)
1960 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1961 ? (int) size
: dtp
->u
.p
.saved_used
;
1963 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1966 q
= (gfc_char4_t
*) p
;
1967 for (i
= 0; i
< m
; i
++)
1968 q
[i
] = (unsigned char) dtp
->u
.p
.saved_string
[i
];
1972 /* Just delimiters encountered, nothing to copy but SPACE. */
1978 memset (((char *) p
) + m
, ' ', size
- m
);
1981 q
= (gfc_char4_t
*) p
;
1982 for (i
= m
; i
< (int) size
; i
++)
1983 q
[i
] = (unsigned char) ' ';
1992 internal_error (&dtp
->common
, "Bad type for list read");
1995 if (--dtp
->u
.p
.repeat_count
<= 0)
1999 if (err
== LIBERROR_END
)
2009 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2010 size_t size
, size_t nelems
)
2014 size_t stride
= type
== BT_CHARACTER
?
2015 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2020 /* Big loop over all the elements. */
2021 for (elem
= 0; elem
< nelems
; elem
++)
2023 dtp
->u
.p
.item_count
++;
2024 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2032 /* Finish a list read. */
2035 finish_list_read (st_parameter_dt
*dtp
)
2039 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2041 if (dtp
->u
.p
.at_eol
)
2043 dtp
->u
.p
.at_eol
= 0;
2047 if (!is_internal_unit (dtp
))
2050 c
= next_char (dtp
);
2067 void namelist_read (st_parameter_dt *dtp)
2069 static void nml_match_name (char *name, int len)
2070 static int nml_query (st_parameter_dt *dtp)
2071 static int nml_get_obj_data (st_parameter_dt *dtp,
2072 namelist_info **prev_nl, char *, size_t)
2074 static void nml_untouch_nodes (st_parameter_dt *dtp)
2075 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2077 static int nml_parse_qualifier(descriptor_dimension * ad,
2078 array_loop_spec * ls, int rank, char *)
2079 static void nml_touch_nodes (namelist_info * nl)
2080 static int nml_read_obj (namelist_info *nl, index_type offset,
2081 namelist_info **prev_nl, char *, size_t,
2082 index_type clow, index_type chigh)
2086 /* Inputs a rank-dimensional qualifier, which can contain
2087 singlets, doublets, triplets or ':' with the standard meanings. */
2090 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2091 array_loop_spec
*ls
, int rank
, bt nml_elem_type
,
2092 char *parse_err_msg
, size_t parse_err_msg_size
,
2099 int is_array_section
, is_char
;
2103 is_array_section
= 0;
2104 dtp
->u
.p
.expanded_read
= 0;
2106 /* See if this is a character substring qualifier we are looking for. */
2113 /* The next character in the stream should be the '('. */
2115 if ((c
= next_char (dtp
)) == EOF
)
2118 /* Process the qualifier, by dimension and triplet. */
2120 for (dim
=0; dim
< rank
; dim
++ )
2122 for (indx
=0; indx
<3; indx
++)
2128 /* Process a potential sign. */
2129 if ((c
= next_char (dtp
)) == EOF
)
2141 unget_char (dtp
, c
);
2145 /* Process characters up to the next ':' , ',' or ')'. */
2148 c
= next_char (dtp
);
2155 is_array_section
= 1;
2159 if ((c
==',' && dim
== rank
-1)
2160 || (c
==')' && dim
< rank
-1))
2163 snprintf (parse_err_msg
, parse_err_msg_size
,
2164 "Bad substring qualifier");
2166 snprintf (parse_err_msg
, parse_err_msg_size
,
2167 "Bad number of index fields");
2176 case ' ': case '\t': case '\r': case '\n':
2182 snprintf (parse_err_msg
, parse_err_msg_size
,
2183 "Bad character in substring qualifier");
2185 snprintf (parse_err_msg
, parse_err_msg_size
,
2186 "Bad character in index");
2190 if ((c
== ',' || c
== ')') && indx
== 0
2191 && dtp
->u
.p
.saved_string
== 0)
2194 snprintf (parse_err_msg
, parse_err_msg_size
,
2195 "Null substring qualifier");
2197 snprintf (parse_err_msg
, parse_err_msg_size
,
2198 "Null index field");
2202 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2203 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2206 snprintf (parse_err_msg
, parse_err_msg_size
,
2207 "Bad substring qualifier");
2209 snprintf (parse_err_msg
, parse_err_msg_size
,
2210 "Bad index triplet");
2214 if (is_char
&& !is_array_section
)
2216 snprintf (parse_err_msg
, parse_err_msg_size
,
2217 "Missing colon in substring qualifier");
2221 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2223 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2224 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2230 /* Now read the index. */
2231 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2234 snprintf (parse_err_msg
, parse_err_msg_size
,
2235 "Bad integer substring qualifier");
2237 snprintf (parse_err_msg
, parse_err_msg_size
,
2238 "Bad integer in index");
2244 /* Feed the index values to the triplet arrays. */
2248 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2250 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2252 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2255 /* Singlet or doublet indices. */
2256 if (c
==',' || c
==')')
2260 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2262 /* If -std=f95/2003 or an array section is specified,
2263 do not allow excess data to be processed. */
2264 if (is_array_section
== 1
2265 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2266 || nml_elem_type
== BT_DERIVED
)
2267 ls
[dim
].end
= ls
[dim
].start
;
2269 dtp
->u
.p
.expanded_read
= 1;
2272 /* Check for non-zero rank. */
2273 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2280 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2283 dtp
->u
.p
.expanded_read
= 0;
2284 for (i
= 0; i
< dim
; i
++)
2285 ls
[i
].end
= ls
[i
].start
;
2288 /* Check the values of the triplet indices. */
2289 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2290 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2291 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2292 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2295 snprintf (parse_err_msg
, parse_err_msg_size
,
2296 "Substring out of range");
2298 snprintf (parse_err_msg
, parse_err_msg_size
,
2299 "Index %d out of range", dim
+ 1);
2303 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2304 || (ls
[dim
].step
== 0))
2306 snprintf (parse_err_msg
, parse_err_msg_size
,
2307 "Bad range in index %d", dim
+ 1);
2311 /* Initialise the loop index counter. */
2312 ls
[dim
].idx
= ls
[dim
].start
;
2319 /* The EOF error message is issued by hit_eof. Return true so that the
2320 caller does not use parse_err_msg and parse_err_msg_size to generate
2321 an unrelated error message. */
2325 dtp
->u
.p
.input_complete
= 1;
2331 static namelist_info
*
2332 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2334 namelist_info
* t
= dtp
->u
.p
.ionml
;
2337 if (strcmp (var_name
, t
->var_name
) == 0)
2347 /* Visits all the components of a derived type that have
2348 not explicitly been identified in the namelist input.
2349 touched is set and the loop specification initialised
2350 to default values */
2353 nml_touch_nodes (namelist_info
* nl
)
2355 index_type len
= strlen (nl
->var_name
) + 1;
2357 char * ext_name
= (char*)xmalloc (len
+ 1);
2358 memcpy (ext_name
, nl
->var_name
, len
-1);
2359 memcpy (ext_name
+ len
- 1, "%", 2);
2360 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2362 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2365 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2367 nl
->ls
[dim
].step
= 1;
2368 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2369 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2370 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2380 /* Resets touched for the entire list of nml_nodes, ready for a
2384 nml_untouch_nodes (st_parameter_dt
*dtp
)
2387 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2392 /* Attempts to input name to namelist name. Returns
2393 dtp->u.p.nml_read_error = 1 on no match. */
2396 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2401 dtp
->u
.p
.nml_read_error
= 0;
2402 for (i
= 0; i
< len
; i
++)
2404 c
= next_char (dtp
);
2405 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2407 dtp
->u
.p
.nml_read_error
= 1;
2413 /* If the namelist read is from stdin, output the current state of the
2414 namelist to stdout. This is used to implement the non-standard query
2415 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2416 the names alone are printed. */
2419 nml_query (st_parameter_dt
*dtp
, char c
)
2421 gfc_unit
* temp_unit
;
2426 static const index_type endlen
= 2;
2427 static const char endl
[] = "\r\n";
2428 static const char nmlend
[] = "&end\r\n";
2430 static const index_type endlen
= 1;
2431 static const char endl
[] = "\n";
2432 static const char nmlend
[] = "&end\n";
2435 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2438 /* Store the current unit and transfer to stdout. */
2440 temp_unit
= dtp
->u
.p
.current_unit
;
2441 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2443 if (dtp
->u
.p
.current_unit
)
2445 dtp
->u
.p
.mode
= WRITING
;
2446 next_record (dtp
, 0);
2448 /* Write the namelist in its entirety. */
2451 namelist_write (dtp
);
2453 /* Or write the list of names. */
2457 /* "&namelist_name\n" */
2459 len
= dtp
->namelist_name_len
;
2460 p
= write_block (dtp
, len
- 1 + endlen
);
2464 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2465 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2466 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2470 len
= strlen (nl
->var_name
);
2471 p
= write_block (dtp
, len
+ endlen
);
2475 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2476 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2481 p
= write_block (dtp
, endlen
+ 4);
2484 memcpy (p
, &nmlend
, endlen
+ 4);
2487 /* Flush the stream to force immediate output. */
2489 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2490 sflush (dtp
->u
.p
.current_unit
->s
);
2491 unlock_unit (dtp
->u
.p
.current_unit
);
2496 /* Restore the current unit. */
2498 dtp
->u
.p
.current_unit
= temp_unit
;
2499 dtp
->u
.p
.mode
= READING
;
2503 /* Reads and stores the input for the namelist object nl. For an array,
2504 the function loops over the ranges defined by the loop specification.
2505 This default to all the data or to the specification from a qualifier.
2506 nml_read_obj recursively calls itself to read derived types. It visits
2507 all its own components but only reads data for those that were touched
2508 when the name was parsed. If a read error is encountered, an attempt is
2509 made to return to read a new object name because the standard allows too
2510 little data to be available. On the other hand, too much data is an
2514 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2515 namelist_info
**pprev_nl
, char *nml_err_msg
,
2516 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2518 namelist_info
* cmp
;
2525 size_t obj_name_len
;
2528 /* This object not touched in name parsing. */
2533 dtp
->u
.p
.repeat_count
= 0;
2545 dlen
= size_from_real_kind (len
);
2549 dlen
= size_from_complex_kind (len
);
2553 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2562 /* Update the pointer to the data, using the current index vector */
2564 pdata
= (void*)(nl
->mem_pos
+ offset
);
2565 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2566 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2567 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2568 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2570 /* Reset the error flag and try to read next value, if
2571 dtp->u.p.repeat_count=0 */
2573 dtp
->u
.p
.nml_read_error
= 0;
2575 if (--dtp
->u
.p
.repeat_count
<= 0)
2577 if (dtp
->u
.p
.input_complete
)
2579 if (dtp
->u
.p
.at_eol
)
2580 finish_separator (dtp
);
2581 if (dtp
->u
.p
.input_complete
)
2584 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2590 read_integer (dtp
, len
);
2594 read_logical (dtp
, len
);
2598 read_character (dtp
, len
);
2602 /* Need to copy data back from the real location to the temp in order
2603 to handle nml reads into arrays. */
2604 read_real (dtp
, pdata
, len
);
2605 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2609 /* Same as for REAL, copy back to temp. */
2610 read_complex (dtp
, pdata
, len
, dlen
);
2611 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2615 obj_name_len
= strlen (nl
->var_name
) + 1;
2616 obj_name
= xmalloc (obj_name_len
+1);
2617 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2618 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2620 /* If reading a derived type, disable the expanded read warning
2621 since a single object can have multiple reads. */
2622 dtp
->u
.p
.expanded_read
= 0;
2624 /* Now loop over the components. */
2626 for (cmp
= nl
->next
;
2628 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2631 /* Jump over nested derived type by testing if the potential
2632 component name contains '%'. */
2633 if (strchr (cmp
->var_name
+ obj_name_len
, '%'))
2636 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2637 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2638 clow
, chigh
) == FAILURE
)
2644 if (dtp
->u
.p
.input_complete
)
2655 snprintf (nml_err_msg
, nml_err_msg_size
,
2656 "Bad type for namelist object %s", nl
->var_name
);
2657 internal_error (&dtp
->common
, nml_err_msg
);
2662 /* The standard permits array data to stop short of the number of
2663 elements specified in the loop specification. In this case, we
2664 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2665 nml_get_obj_data and an attempt is made to read object name. */
2668 if (dtp
->u
.p
.nml_read_error
)
2670 dtp
->u
.p
.expanded_read
= 0;
2674 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2676 dtp
->u
.p
.expanded_read
= 0;
2680 switch (dtp
->u
.p
.saved_type
)
2687 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2691 if (dlen
< dtp
->u
.p
.saved_used
)
2693 if (compile_options
.bounds_check
)
2695 snprintf (nml_err_msg
, nml_err_msg_size
,
2696 "Namelist object '%s' truncated on read.",
2698 generate_warning (&dtp
->common
, nml_err_msg
);
2703 m
= dtp
->u
.p
.saved_used
;
2704 pdata
= (void*)( pdata
+ clow
- 1 );
2705 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2707 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2714 /* Warn if a non-standard expanded read occurs. A single read of a
2715 single object is acceptable. If a second read occurs, issue a warning
2716 and set the flag to zero to prevent further warnings. */
2717 if (dtp
->u
.p
.expanded_read
== 2)
2719 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2720 dtp
->u
.p
.expanded_read
= 0;
2723 /* If the expanded read warning flag is set, increment it,
2724 indicating that a single read has occurred. */
2725 if (dtp
->u
.p
.expanded_read
>= 1)
2726 dtp
->u
.p
.expanded_read
++;
2728 /* Break out of loop if scalar. */
2732 /* Now increment the index vector. */
2737 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2739 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2741 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2743 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2745 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2749 } while (!nml_carry
);
2751 if (dtp
->u
.p
.repeat_count
> 1)
2753 snprintf (nml_err_msg
, nml_err_msg_size
,
2754 "Repeat count too large for namelist object %s", nl
->var_name
);
2764 /* Parses the object name, including array and substring qualifiers. It
2765 iterates over derived type components, touching those components and
2766 setting their loop specifications, if there is a qualifier. If the
2767 object is itself a derived type, its components and subcomponents are
2768 touched. nml_read_obj is called at the end and this reads the data in
2769 the manner specified by the object name. */
2772 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2773 char *nml_err_msg
, size_t nml_err_msg_size
)
2777 namelist_info
* first_nl
= NULL
;
2778 namelist_info
* root_nl
= NULL
;
2779 int dim
, parsed_rank
;
2780 int component_flag
, qualifier_flag
;
2781 index_type clow
, chigh
;
2782 int non_zero_rank_count
;
2784 /* Look for end of input or object name. If '?' or '=?' are encountered
2785 in stdin, print the node names or the namelist to stdout. */
2787 eat_separator (dtp
);
2788 if (dtp
->u
.p
.input_complete
)
2791 if (dtp
->u
.p
.at_eol
)
2792 finish_separator (dtp
);
2793 if (dtp
->u
.p
.input_complete
)
2796 if ((c
= next_char (dtp
)) == EOF
)
2801 if ((c
= next_char (dtp
)) == EOF
)
2805 snprintf (nml_err_msg
, nml_err_msg_size
,
2806 "namelist read: misplaced = sign");
2809 nml_query (dtp
, '=');
2813 nml_query (dtp
, '?');
2818 nml_match_name (dtp
, "end", 3);
2819 if (dtp
->u
.p
.nml_read_error
)
2821 snprintf (nml_err_msg
, nml_err_msg_size
,
2822 "namelist not terminated with / or &end");
2826 dtp
->u
.p
.input_complete
= 1;
2833 /* Untouch all nodes of the namelist and reset the flags that are set for
2834 derived type components. */
2836 nml_untouch_nodes (dtp
);
2839 non_zero_rank_count
= 0;
2841 /* Get the object name - should '!' and '\n' be permitted separators? */
2849 if (!is_separator (c
))
2850 push_char (dtp
, tolower(c
));
2851 if ((c
= next_char (dtp
)) == EOF
)
2854 while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2856 unget_char (dtp
, c
);
2858 /* Check that the name is in the namelist and get pointer to object.
2859 Three error conditions exist: (i) An attempt is being made to
2860 identify a non-existent object, following a failed data read or
2861 (ii) The object name does not exist or (iii) Too many data items
2862 are present for an object. (iii) gives the same error message
2865 push_char (dtp
, '\0');
2869 size_t var_len
= strlen (root_nl
->var_name
);
2871 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2872 char ext_name
[var_len
+ saved_len
+ 1];
2874 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2875 if (dtp
->u
.p
.saved_string
)
2876 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2877 ext_name
[var_len
+ saved_len
] = '\0';
2878 nl
= find_nml_node (dtp
, ext_name
);
2881 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2885 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2886 snprintf (nml_err_msg
, nml_err_msg_size
,
2887 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
2890 snprintf (nml_err_msg
, nml_err_msg_size
,
2891 "Cannot match namelist object name %s",
2892 dtp
->u
.p
.saved_string
);
2897 /* Get the length, data length, base pointer and rank of the variable.
2898 Set the default loop specification first. */
2900 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2902 nl
->ls
[dim
].step
= 1;
2903 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2904 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2905 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2908 /* Check to see if there is a qualifier: if so, parse it.*/
2910 if (c
== '(' && nl
->var_rank
)
2913 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2914 nl
->type
, nml_err_msg
, nml_err_msg_size
,
2915 &parsed_rank
) == FAILURE
)
2917 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2918 snprintf (nml_err_msg_end
,
2919 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2920 " for namelist variable %s", nl
->var_name
);
2923 if (parsed_rank
> 0)
2924 non_zero_rank_count
++;
2928 if ((c
= next_char (dtp
)) == EOF
)
2930 unget_char (dtp
, c
);
2932 else if (nl
->var_rank
> 0)
2933 non_zero_rank_count
++;
2935 /* Now parse a derived type component. The root namelist_info address
2936 is backed up, as is the previous component level. The component flag
2937 is set and the iteration is made by jumping back to get_name. */
2941 if (nl
->type
!= BT_DERIVED
)
2943 snprintf (nml_err_msg
, nml_err_msg_size
,
2944 "Attempt to get derived component for %s", nl
->var_name
);
2948 /* Don't move first_nl further in the list if a qualifier was found. */
2949 if ((*pprev_nl
== NULL
&& !qualifier_flag
) || !component_flag
)
2955 if ((c
= next_char (dtp
)) == EOF
)
2960 /* Parse a character qualifier, if present. chigh = 0 is a default
2961 that signals that the string length = string_length. */
2966 if (c
== '(' && nl
->type
== BT_CHARACTER
)
2968 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2969 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2971 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, nl
->type
,
2972 nml_err_msg
, nml_err_msg_size
, &parsed_rank
)
2975 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
2976 snprintf (nml_err_msg_end
,
2977 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
2978 " for namelist variable %s", nl
->var_name
);
2982 clow
= ind
[0].start
;
2985 if (ind
[0].step
!= 1)
2987 snprintf (nml_err_msg
, nml_err_msg_size
,
2988 "Step not allowed in substring qualifier"
2989 " for namelist object %s", nl
->var_name
);
2993 if ((c
= next_char (dtp
)) == EOF
)
2995 unget_char (dtp
, c
);
2998 /* Make sure no extraneous qualifiers are there. */
3002 snprintf (nml_err_msg
, nml_err_msg_size
,
3003 "Qualifier for a scalar or non-character namelist object %s",
3008 /* Make sure there is no more than one non-zero rank object. */
3009 if (non_zero_rank_count
> 1)
3011 snprintf (nml_err_msg
, nml_err_msg_size
,
3012 "Multiple sub-objects with non-zero rank in namelist object %s",
3014 non_zero_rank_count
= 0;
3018 /* According to the standard, an equal sign MUST follow an object name. The
3019 following is possibly lax - it allows comments, blank lines and so on to
3020 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
3024 eat_separator (dtp
);
3025 if (dtp
->u
.p
.input_complete
)
3028 if (dtp
->u
.p
.at_eol
)
3029 finish_separator (dtp
);
3030 if (dtp
->u
.p
.input_complete
)
3033 if ((c
= next_char (dtp
)) == EOF
)
3038 snprintf (nml_err_msg
, nml_err_msg_size
,
3039 "Equal sign must follow namelist object name %s",
3043 /* If a derived type, touch its components and restore the root
3044 namelist_info if we have parsed a qualified derived type
3047 if (nl
->type
== BT_DERIVED
)
3048 nml_touch_nodes (nl
);
3052 if (first_nl
->var_rank
== 0)
3054 if (component_flag
&& qualifier_flag
)
3061 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3062 clow
, chigh
) == FAILURE
)
3069 /* The EOF error message is issued by hit_eof. Return true so that the
3070 caller does not use nml_err_msg and nml_err_msg_size to generate
3071 an unrelated error message. */
3074 dtp
->u
.p
.input_complete
= 1;
3075 unget_char (dtp
, c
);
3083 /* Entry point for namelist input. Goes through input until namelist name
3084 is matched. Then cycles through nml_get_obj_data until the input is
3085 completed or there is an error. */
3088 namelist_read (st_parameter_dt
*dtp
)
3091 char nml_err_msg
[200];
3093 /* Initialize the error string buffer just in case we get an unexpected fail
3094 somewhere and end up at nml_err_ret. */
3095 strcpy (nml_err_msg
, "Internal namelist read error");
3097 /* Pointer to the previously read object, in case attempt is made to read
3098 new object name. Should this fail, error message can give previous
3100 namelist_info
*prev_nl
= NULL
;
3102 dtp
->u
.p
.namelist_mode
= 1;
3103 dtp
->u
.p
.input_complete
= 0;
3104 dtp
->u
.p
.expanded_read
= 0;
3106 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3107 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3108 node names or namelist on stdout. */
3111 c
= next_char (dtp
);
3123 c
= next_char (dtp
);
3125 nml_query (dtp
, '=');
3127 unget_char (dtp
, c
);
3131 nml_query (dtp
, '?');
3141 /* Match the name of the namelist. */
3143 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3145 if (dtp
->u
.p
.nml_read_error
)
3148 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3149 c
= next_char (dtp
);
3150 if (!is_separator(c
) && c
!= '!')
3152 unget_char (dtp
, c
);
3156 unget_char (dtp
, c
);
3157 eat_separator (dtp
);
3159 /* Ready to read namelist objects. If there is an error in input
3160 from stdin, output the error message and continue. */
3162 while (!dtp
->u
.p
.input_complete
)
3164 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
)
3167 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3169 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3172 /* Reset the previous namelist pointer if we know we are not going
3173 to be doing multiple reads within a single namelist object. */
3174 if (prev_nl
&& prev_nl
->var_rank
== 0)
3185 /* All namelist error calls return from here */
3188 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);