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.item_count = 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.item_count];
154 if (c != '\0' && dtp->u.p.item_count < 64)
156 dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
157 dtp->u.p.item_count++;
161 dtp->u.p.item_count = 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;
624 snprintf (message, MSGLEN, "Bad repeat count in item %d of list input",
625 dtp->u.p.item_count);
626 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
631 /* To read a logical we have to look ahead in the input stream to make sure
632 there is not an equal sign indicating a variable name. To do this we use
633 line_buffer to point to a temporary buffer, pushing characters there for
634 possible later reading. */
637 l_push_char (st_parameter_dt *dtp, char c)
639 if (dtp->u.p.line_buffer == NULL)
640 dtp->u.p.line_buffer = xcalloc (SCRATCH_SIZE, 1);
642 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
646 /* Read a logical character on the input. */
649 read_logical (st_parameter_dt *dtp, int length)
651 char message[MSGLEN];
654 if (parse_repeat (dtp))
657 c = tolower (next_char (dtp));
658 l_push_char (dtp, c);
664 l_push_char (dtp, c);
666 if (!is_separator(c) && c != EOF)
674 l_push_char (dtp, c);
676 if (!is_separator(c) && c != EOF)
683 c = tolower (next_char (dtp));
702 return; /* Null value. */
705 /* Save the character in case it is the beginning
706 of the next object name. */
711 dtp->u.p.saved_type = BT_LOGICAL;
712 dtp->u.p.saved_length = length;
714 /* Eat trailing garbage. */
717 while (c != EOF && !is_separator (c));
721 set_integer ((int *) dtp->u.p.value, v, length);
728 for(i = 0; i < 63; i++)
733 /* All done if this is not a namelist read. */
734 if (!dtp->u.p.namelist_mode)
747 l_push_char (dtp, c);
750 dtp->u.p.nml_read_error = 1;
751 dtp->u.p.line_buffer_enabled = 1;
752 dtp->u.p.item_count = 0;
762 if (nml_bad_return (dtp, c))
773 snprintf (message, MSGLEN, "Bad logical value while reading item %d",
774 dtp->u.p.item_count);
775 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
780 dtp->u.p.saved_type = BT_LOGICAL;
781 dtp->u.p.saved_length = length;
782 set_integer ((int *) dtp->u.p.value, v, length);
788 /* Reading integers is tricky because we can actually be reading a
789 repeat count. We have to store the characters in a buffer because
790 we could be reading an integer that is larger than the default int
791 used for repeat counts. */
794 read_integer (st_parameter_dt *dtp, int length)
796 char message[MSGLEN];
806 /* Fall through... */
809 if ((c = next_char (dtp)) == EOF)
813 CASE_SEPARATORS: /* Single null. */
826 /* Take care of what may be a repeat count. */
838 push_char (dtp, '\0');
841 CASE_SEPARATORS: /* Not a repeat count. */
851 if (convert_integer (dtp, -1, 0))
854 /* Get the real integer. */
856 if ((c = next_char (dtp)) == EOF)
870 /* Fall through... */
902 if (nml_bad_return (dtp, c))
913 snprintf (message, MSGLEN, "Bad integer for item %d in list input",
914 dtp->u.p.item_count);
915 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
923 push_char (dtp, '\0');
924 if (convert_integer (dtp, length, negative))
931 dtp->u.p.saved_type = BT_INTEGER;
935 /* Read a character variable. */
938 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
940 char quote, message[MSGLEN];
943 quote = ' '; /* Space means no quote character. */
945 if ((c = next_char (dtp)) == EOF)
955 unget_char (dtp, c); /* NULL value. */
965 if (dtp->u.p.namelist_mode)
975 /* Deal with a possible repeat count. */
989 goto done; /* String was only digits! */
992 push_char (dtp, '\0');
997 goto get_string; /* Not a repeat count after all. */
1002 if (convert_integer (dtp, -1, 0))
1005 /* Now get the real string. */
1007 if ((c = next_char (dtp)) == EOF)
1012 unget_char (dtp, c); /* Repeated NULL values. */
1013 eat_separator (dtp);
1029 if ((c = next_char (dtp)) == EOF)
1041 /* See if we have a doubled quote character or the end of
1044 if ((c = next_char (dtp)) == EOF)
1048 push_char (dtp, quote);
1052 unget_char (dtp, c);
1058 unget_char (dtp, c);
1062 if (c != '\n' && c != '\r')
1072 /* At this point, we have to have a separator, or else the string is
1075 c = next_char (dtp);
1077 if (is_separator (c) || c == '!' || c == EOF)
1079 unget_char (dtp, c);
1080 eat_separator (dtp);
1081 dtp->u.p.saved_type = BT_CHARACTER;
1087 snprintf (message, MSGLEN, "Invalid string input in item %d",
1088 dtp->u.p.item_count);
1089 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1099 /* Parse a component of a complex constant or a real number that we
1100 are sure is already there. This is a straight real number parser. */
1103 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1105 char message[MSGLEN];
1108 if ((c = next_char (dtp)) == EOF)
1111 if (c == '-' || c == '+')
1114 if ((c = next_char (dtp)) == EOF)
1118 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1121 if (!isdigit (c) && c != '.')
1123 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1131 seen_dp = (c == '.') ? 1 : 0;
1135 if ((c = next_char (dtp)) == EOF)
1137 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1159 push_char (dtp, 'e');
1164 push_char (dtp, 'e');
1166 if ((c = next_char (dtp)) == EOF)
1180 if ((c = next_char (dtp)) == EOF)
1182 if (c != '-' && c != '+')
1183 push_char (dtp, '+');
1187 c = next_char (dtp);
1198 if ((c = next_char (dtp)) == EOF)
1208 unget_char (dtp, c);
1217 unget_char (dtp, c);
1218 push_char (dtp, '\0');
1220 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1226 unget_char (dtp, c);
1227 push_char (dtp, '\0');
1229 m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length);
1235 /* Match INF and Infinity. */
1236 if ((c == 'i' || c == 'I')
1237 && ((c = next_char (dtp)) == 'n' || c == 'N')
1238 && ((c = next_char (dtp)) == 'f' || c == 'F'))
1240 c = next_char (dtp);
1241 if ((c != 'i' && c != 'I')
1242 || ((c == 'i' || c == 'I')
1243 && ((c = next_char (dtp)) == 'n' || c == 'N')
1244 && ((c = next_char (dtp)) == 'i' || c == 'I')
1245 && ((c = next_char (dtp)) == 't' || c == 'T')
1246 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1247 && (c = next_char (dtp))))
1249 if (is_separator (c) || (c == EOF))
1250 unget_char (dtp, c);
1251 push_char (dtp, 'i');
1252 push_char (dtp, 'n');
1253 push_char (dtp, 'f');
1257 else if (((c = next_char (dtp)) == 'a' || c == 'A')
1258 && ((c = next_char (dtp)) == 'n' || c == 'N')
1259 && (c = next_char (dtp)))
1261 if (is_separator (c) || (c == EOF))
1262 unget_char (dtp, c);
1263 push_char (dtp, 'n');
1264 push_char (dtp, 'a');
1265 push_char (dtp, 'n');
1267 /* Match "NAN(alphanum)". */
1270 for ( ; c != ')'; c = next_char (dtp))
1271 if (is_separator (c))
1274 c = next_char (dtp);
1275 if (is_separator (c) || (c == EOF))
1276 unget_char (dtp, c);
1283 if (nml_bad_return (dtp, c))
1294 snprintf (message, MSGLEN, "Bad floating point number for item %d",
1295 dtp->u.p.item_count);
1296 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1302 /* Reading a complex number is straightforward because we can tell
1303 what it is right away. */
1306 read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
1308 char message[MSGLEN];
1311 if (parse_repeat (dtp))
1314 c = next_char (dtp);
1322 unget_char (dtp, c);
1323 eat_separator (dtp);
1332 c = next_char (dtp);
1333 if (c == '\n' || c== '\r')
1336 unget_char (dtp, c);
1338 if (parse_real (dtp, dest, kind))
1343 c = next_char (dtp);
1344 if (c == '\n' || c== '\r')
1347 unget_char (dtp, c);
1350 != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
1355 c = next_char (dtp);
1356 if (c == '\n' || c== '\r')
1359 unget_char (dtp, c);
1361 if (parse_real (dtp, dest + size / 2, kind))
1366 c = next_char (dtp);
1367 if (c == '\n' || c== '\r')
1370 unget_char (dtp, c);
1372 if (next_char (dtp) != ')')
1375 c = next_char (dtp);
1376 if (!is_separator (c) && (c != EOF))
1379 unget_char (dtp, c);
1380 eat_separator (dtp);
1383 dtp->u.p.saved_type = BT_COMPLEX;
1388 if (nml_bad_return (dtp, c))
1399 snprintf (message, MSGLEN, "Bad complex value in item %d of list input",
1400 dtp->u.p.item_count);
1401 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1405 /* Parse a real number with a possible repeat count. */
1408 read_real (st_parameter_dt *dtp, void * dest, int length)
1410 char message[MSGLEN];
1417 c = next_char (dtp);
1418 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1436 unget_char (dtp, c); /* Single null. */
1437 eat_separator (dtp);
1450 /* Get the digit string that might be a repeat count. */
1454 c = next_char (dtp);
1455 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1481 push_char (dtp, 'e');
1483 c = next_char (dtp);
1487 push_char (dtp, '\0');
1492 if (c != '\n' && c != ',' && c != '\r' && c != ';')
1493 unget_char (dtp, c);
1502 if (convert_integer (dtp, -1, 0))
1505 /* Now get the number itself. */
1507 if ((c = next_char (dtp)) == EOF)
1509 if (is_separator (c))
1510 { /* Repeated null value. */
1511 unget_char (dtp, c);
1512 eat_separator (dtp);
1516 if (c != '-' && c != '+')
1517 push_char (dtp, '+');
1522 if ((c = next_char (dtp)) == EOF)
1526 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1529 if (!isdigit (c) && c != '.')
1531 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1550 c = next_char (dtp);
1551 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1581 push_char (dtp, 'e');
1583 c = next_char (dtp);
1592 push_char (dtp, 'e');
1594 if ((c = next_char (dtp)) == EOF)
1596 if (c != '+' && c != '-')
1597 push_char (dtp, '+');
1601 c = next_char (dtp);
1611 c = next_char (dtp);
1629 unget_char (dtp, c);
1630 eat_separator (dtp);
1631 push_char (dtp, '\0');
1632 if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
1636 dtp->u.p.saved_type = BT_REAL;
1640 l_push_char (dtp, c);
1643 /* Match INF and Infinity. */
1644 if (c == 'i' || c == 'I')
1646 c = next_char (dtp);
1647 l_push_char (dtp, c);
1648 if (c != 'n' && c != 'N')
1650 c = next_char (dtp);
1651 l_push_char (dtp, c);
1652 if (c != 'f' && c != 'F')
1654 c = next_char (dtp);
1655 l_push_char (dtp, c);
1656 if (!is_separator (c) && (c != EOF))
1658 if (c != 'i' && c != 'I')
1660 c = next_char (dtp);
1661 l_push_char (dtp, c);
1662 if (c != 'n' && c != 'N')
1664 c = next_char (dtp);
1665 l_push_char (dtp, c);
1666 if (c != 'i' && c != 'I')
1668 c = next_char (dtp);
1669 l_push_char (dtp, c);
1670 if (c != 't' && c != 'T')
1672 c = next_char (dtp);
1673 l_push_char (dtp, c);
1674 if (c != 'y' && c != 'Y')
1676 c = next_char (dtp);
1677 l_push_char (dtp, c);
1683 c = next_char (dtp);
1684 l_push_char (dtp, c);
1685 if (c != 'a' && c != 'A')
1687 c = next_char (dtp);
1688 l_push_char (dtp, c);
1689 if (c != 'n' && c != 'N')
1691 c = next_char (dtp);
1692 l_push_char (dtp, c);
1694 /* Match NAN(alphanum). */
1697 for (c = next_char (dtp); c != ')'; c = next_char (dtp))
1698 if (is_separator (c))
1701 l_push_char (dtp, c);
1703 l_push_char (dtp, ')');
1704 c = next_char (dtp);
1705 l_push_char (dtp, c);
1709 if (!is_separator (c) && (c != EOF))
1712 if (dtp->u.p.namelist_mode)
1714 if (c == ' ' || c =='\n' || c == '\r')
1718 if ((c = next_char (dtp)) == EOF)
1721 while (c == ' ' || c =='\n' || c == '\r');
1723 l_push_char (dtp, c);
1732 push_char (dtp, 'i');
1733 push_char (dtp, 'n');
1734 push_char (dtp, 'f');
1738 push_char (dtp, 'n');
1739 push_char (dtp, 'a');
1740 push_char (dtp, 'n');
1744 unget_char (dtp, c);
1745 eat_separator (dtp);
1746 push_char (dtp, '\0');
1747 if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length))
1751 dtp->u.p.saved_type = BT_REAL;
1755 if (dtp->u.p.namelist_mode)
1757 dtp->u.p.nml_read_error = 1;
1758 dtp->u.p.line_buffer_enabled = 1;
1759 dtp->u.p.item_count = 0;
1765 if (nml_bad_return (dtp, c))
1777 snprintf (message, MSGLEN, "Bad real number in item %d of list input",
1778 dtp->u.p.item_count);
1779 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1783 /* Check the current type against the saved type to make sure they are
1784 compatible. Returns nonzero if incompatible. */
1787 check_type (st_parameter_dt *dtp, bt type, int len)
1789 char message[MSGLEN];
1791 if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
1793 snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d",
1794 type_name (dtp->u.p.saved_type), type_name (type),
1795 dtp->u.p.item_count);
1797 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1801 if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
1804 if (dtp->u.p.saved_length != len)
1806 snprintf (message, MSGLEN,
1807 "Read kind %d %s where kind %d is required for item %d",
1808 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1809 dtp->u.p.item_count);
1810 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1818 /* Top level data transfer subroutine for list reads. Because we have
1819 to deal with repeat counts, the data item is always saved after
1820 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1821 greater than one, we copy the data item multiple times. */
1824 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
1825 int kind, size_t size)
1831 dtp->u.p.namelist_mode = 0;
1833 if (dtp->u.p.first_item)
1835 dtp->u.p.first_item = 0;
1836 dtp->u.p.input_complete = 0;
1837 dtp->u.p.repeat_count = 1;
1838 dtp->u.p.at_eol = 0;
1840 if ((c = eat_spaces (dtp)) == EOF)
1845 if (is_separator (c))
1847 /* Found a null value. */
1848 eat_separator (dtp);
1849 dtp->u.p.repeat_count = 0;
1851 /* eat_separator sets this flag if the separator was a comma. */
1852 if (dtp->u.p.comma_flag)
1855 /* eat_separator sets this flag if the separator was a \n or \r. */
1856 if (dtp->u.p.at_eol)
1857 finish_separator (dtp);
1865 if (dtp->u.p.repeat_count > 0)
1867 if (check_type (dtp, type, kind))
1872 if (dtp->u.p.input_complete)
1875 if (dtp->u.p.at_eol)
1876 finish_separator (dtp);
1880 /* Trailing spaces prior to end of line. */
1881 if (dtp->u.p.at_eol)
1882 finish_separator (dtp);
1885 dtp->u.p.saved_type = BT_UNKNOWN;
1886 dtp->u.p.repeat_count = 1;
1892 read_integer (dtp, kind);
1895 read_logical (dtp, kind);
1898 read_character (dtp, kind);
1901 read_real (dtp, p, kind);
1902 /* Copy value back to temporary if needed. */
1903 if (dtp->u.p.repeat_count > 0)
1904 memcpy (dtp->u.p.value, p, size);
1907 read_complex (dtp, p, kind, size);
1908 /* Copy value back to temporary if needed. */
1909 if (dtp->u.p.repeat_count > 0)
1910 memcpy (dtp->u.p.value, p, size);
1913 internal_error (&dtp->common, "Bad type for list read");
1916 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN)
1917 dtp->u.p.saved_length = size;
1919 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1923 switch (dtp->u.p.saved_type)
1927 if (dtp->u.p.repeat_count > 0)
1928 memcpy (p, dtp->u.p.value, size);
1933 memcpy (p, dtp->u.p.value, size);
1937 if (dtp->u.p.saved_string)
1939 m = ((int) size < dtp->u.p.saved_used)
1940 ? (int) size : dtp->u.p.saved_used;
1942 memcpy (p, dtp->u.p.saved_string, m);
1945 q = (gfc_char4_t *) p;
1946 for (i = 0; i < m; i++)
1947 q[i] = (unsigned char) dtp->u.p.saved_string[i];
1951 /* Just delimiters encountered, nothing to copy but SPACE. */
1957 memset (((char *) p) + m, ' ', size - m);
1960 q = (gfc_char4_t *) p;
1961 for (i = m; i < (int) size; i++)
1962 q[i] = (unsigned char) ' ';
1971 internal_error (&dtp->common, "Bad type for list read");
1974 if (--dtp->u.p.repeat_count <= 0)
1978 if (err == LIBERROR_END)
1985 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1986 size_t size, size_t nelems)
1990 size_t stride = type == BT_CHARACTER ?
1991 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1996 /* Big loop over all the elements. */
1997 for (elem = 0; elem < nelems; elem++)
1999 dtp->u.p.item_count++;
2000 err = list_formatted_read_scalar (dtp, type, tmp + stride*elem,
2008 /* Finish a list read. */
2011 finish_list_read (st_parameter_dt *dtp)
2017 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2019 if (dtp->u.p.at_eol)
2021 dtp->u.p.at_eol = 0;
2025 err = eat_line (dtp);
2026 if (err == LIBERROR_END)
2032 void namelist_read (st_parameter_dt *dtp)
2034 static void nml_match_name (char *name, int len)
2035 static int nml_query (st_parameter_dt *dtp)
2036 static int nml_get_obj_data (st_parameter_dt *dtp,
2037 namelist_info **prev_nl, char *, size_t)
2039 static void nml_untouch_nodes (st_parameter_dt *dtp)
2040 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2042 static int nml_parse_qualifier(descriptor_dimension * ad,
2043 array_loop_spec * ls, int rank, char *)
2044 static void nml_touch_nodes (namelist_info * nl)
2045 static int nml_read_obj (namelist_info *nl, index_type offset,
2046 namelist_info **prev_nl, char *, size_t,
2047 index_type clow, index_type chigh)
2051 /* Inputs a rank-dimensional qualifier, which can contain
2052 singlets, doublets, triplets or ':' with the standard meanings. */
2055 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
2056 array_loop_spec *ls, int rank, bt nml_elem_type,
2057 char *parse_err_msg, size_t parse_err_msg_size,
2064 int is_array_section, is_char;
2068 is_array_section = 0;
2069 dtp->u.p.expanded_read = 0;
2071 /* See if this is a character substring qualifier we are looking for. */
2078 /* The next character in the stream should be the '('. */
2080 if ((c = next_char (dtp)) == EOF)
2083 /* Process the qualifier, by dimension and triplet. */
2085 for (dim=0; dim < rank; dim++ )
2087 for (indx=0; indx<3; indx++)
2093 /* Process a potential sign. */
2094 if ((c = next_char (dtp)) == EOF)
2106 unget_char (dtp, c);
2110 /* Process characters up to the next ':' , ',' or ')'. */
2113 if ((c = next_char (dtp)) == EOF)
2119 is_array_section = 1;
2123 if ((c==',' && dim == rank -1)
2124 || (c==')' && dim < rank -1))
2127 snprintf (parse_err_msg, parse_err_msg_size,
2128 "Bad substring qualifier");
2130 snprintf (parse_err_msg, parse_err_msg_size,
2131 "Bad number of index fields");
2140 case ' ': case '\t':
2142 if ((c = next_char (dtp) == EOF))
2148 snprintf (parse_err_msg, parse_err_msg_size,
2149 "Bad character in substring qualifier");
2151 snprintf (parse_err_msg, parse_err_msg_size,
2152 "Bad character in index");
2156 if ((c == ',' || c == ')') && indx == 0
2157 && dtp->u.p.saved_string == 0)
2160 snprintf (parse_err_msg, parse_err_msg_size,
2161 "Null substring qualifier");
2163 snprintf (parse_err_msg, parse_err_msg_size,
2164 "Null index field");
2168 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2169 || (indx == 2 && dtp->u.p.saved_string == 0))
2172 snprintf (parse_err_msg, parse_err_msg_size,
2173 "Bad substring qualifier");
2175 snprintf (parse_err_msg, parse_err_msg_size,
2176 "Bad index triplet");
2180 if (is_char && !is_array_section)
2182 snprintf (parse_err_msg, parse_err_msg_size,
2183 "Missing colon in substring qualifier");
2187 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2189 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2190 || (indx==1 && dtp->u.p.saved_string == 0))
2196 /* Now read the index. */
2197 if (convert_integer (dtp, sizeof(index_type), neg))
2200 snprintf (parse_err_msg, parse_err_msg_size,
2201 "Bad integer substring qualifier");
2203 snprintf (parse_err_msg, parse_err_msg_size,
2204 "Bad integer in index");
2210 /* Feed the index values to the triplet arrays. */
2214 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2216 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type));
2218 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type));
2221 /* Singlet or doublet indices. */
2222 if (c==',' || c==')')
2226 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2228 /* If -std=f95/2003 or an array section is specified,
2229 do not allow excess data to be processed. */
2230 if (is_array_section == 1
2231 || !(compile_options.allow_std & GFC_STD_GNU)
2232 || nml_elem_type == BT_DERIVED)
2233 ls[dim].end = ls[dim].start;
2235 dtp->u.p.expanded_read = 1;
2238 /* Check for non-zero rank. */
2239 if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2246 if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2249 dtp->u.p.expanded_read = 0;
2250 for (i = 0; i < dim; i++)
2251 ls[i].end = ls[i].start;
2254 /* Check the values of the triplet indices. */
2255 if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim]))
2256 || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim]))
2257 || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim]))
2258 || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim])))
2261 snprintf (parse_err_msg, parse_err_msg_size,
2262 "Substring out of range");
2264 snprintf (parse_err_msg, parse_err_msg_size,
2265 "Index %d out of range", dim + 1);
2269 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2270 || (ls[dim].step == 0))
2272 snprintf (parse_err_msg, parse_err_msg_size,
2273 "Bad range in index %d", dim + 1);
2277 /* Initialise the loop index counter. */
2278 ls[dim].idx = ls[dim].start;
2288 static namelist_info *
2289 find_nml_node (st_parameter_dt *dtp, char * var_name)
2291 namelist_info * t = dtp->u.p.ionml;
2294 if (strcmp (var_name, t->var_name) == 0)
2304 /* Visits all the components of a derived type that have
2305 not explicitly been identified in the namelist input.
2306 touched is set and the loop specification initialised
2307 to default values */
2310 nml_touch_nodes (namelist_info * nl)
2312 index_type len = strlen (nl->var_name) + 1;
2314 char * ext_name = (char*)xmalloc (len + 1);
2315 memcpy (ext_name, nl->var_name, len-1);
2316 memcpy (ext_name + len - 1, "%", 2);
2317 for (nl = nl->next; nl; nl = nl->next)
2319 if (strncmp (nl->var_name, ext_name, len) == 0)
2322 for (dim=0; dim < nl->var_rank; dim++)
2324 nl->ls[dim].step = 1;
2325 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2326 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2327 nl->ls[dim].idx = nl->ls[dim].start;
2337 /* Resets touched for the entire list of nml_nodes, ready for a
2341 nml_untouch_nodes (st_parameter_dt *dtp)
2344 for (t = dtp->u.p.ionml; t; t = t->next)
2349 /* Attempts to input name to namelist name. Returns
2350 dtp->u.p.nml_read_error = 1 on no match. */
2353 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2358 dtp->u.p.nml_read_error = 0;
2359 for (i = 0; i < len; i++)
2361 c = next_char (dtp);
2362 if (c == EOF || (tolower (c) != tolower (name[i])))
2364 dtp->u.p.nml_read_error = 1;
2370 /* If the namelist read is from stdin, output the current state of the
2371 namelist to stdout. This is used to implement the non-standard query
2372 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2373 the names alone are printed. */
2376 nml_query (st_parameter_dt *dtp, char c)
2378 gfc_unit * temp_unit;
2383 static const index_type endlen = 3;
2384 static const char endl[] = "\r\n";
2385 static const char nmlend[] = "&end\r\n";
2387 static const index_type endlen = 2;
2388 static const char endl[] = "\n";
2389 static const char nmlend[] = "&end\n";
2392 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2395 /* Store the current unit and transfer to stdout. */
2397 temp_unit = dtp->u.p.current_unit;
2398 dtp->u.p.current_unit = find_unit (options.stdout_unit);
2400 if (dtp->u.p.current_unit)
2402 dtp->u.p.mode = WRITING;
2403 next_record (dtp, 0);
2405 /* Write the namelist in its entirety. */
2408 namelist_write (dtp);
2410 /* Or write the list of names. */
2414 /* "&namelist_name\n" */
2416 len = dtp->namelist_name_len;
2417 p = write_block (dtp, len + endlen);
2421 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2422 memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2423 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2427 len = strlen (nl->var_name);
2428 p = write_block (dtp, len + endlen);
2432 memcpy ((char*)(p + 1), nl->var_name, len);
2433 memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2438 p = write_block (dtp, endlen + 3);
2440 memcpy (p, &nmlend, endlen + 3);
2443 /* Flush the stream to force immediate output. */
2445 fbuf_flush (dtp->u.p.current_unit, WRITING);
2446 sflush (dtp->u.p.current_unit->s);
2447 unlock_unit (dtp->u.p.current_unit);
2452 /* Restore the current unit. */
2454 dtp->u.p.current_unit = temp_unit;
2455 dtp->u.p.mode = READING;
2459 /* Reads and stores the input for the namelist object nl. For an array,
2460 the function loops over the ranges defined by the loop specification.
2461 This default to all the data or to the specification from a qualifier.
2462 nml_read_obj recursively calls itself to read derived types. It visits
2463 all its own components but only reads data for those that were touched
2464 when the name was parsed. If a read error is encountered, an attempt is
2465 made to return to read a new object name because the standard allows too
2466 little data to be available. On the other hand, too much data is an
2470 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2471 namelist_info **pprev_nl, char *nml_err_msg,
2472 size_t nml_err_msg_size, index_type clow, index_type chigh)
2474 namelist_info * cmp;
2481 size_t obj_name_len;
2484 /* This object not touched in name parsing. */
2489 dtp->u.p.repeat_count = 0;
2501 dlen = size_from_real_kind (len);
2505 dlen = size_from_complex_kind (len);
2509 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2518 /* Update the pointer to the data, using the current index vector */
2520 pdata = (void*)(nl->mem_pos + offset);
2521 for (dim = 0; dim < nl->var_rank; dim++)
2522 pdata = (void*)(pdata + (nl->ls[dim].idx
2523 - GFC_DESCRIPTOR_LBOUND(nl,dim))
2524 * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2526 /* Reset the error flag and try to read next value, if
2527 dtp->u.p.repeat_count=0 */
2529 dtp->u.p.nml_read_error = 0;
2531 if (--dtp->u.p.repeat_count <= 0)
2533 if (dtp->u.p.input_complete)
2535 if (dtp->u.p.at_eol)
2536 finish_separator (dtp);
2537 if (dtp->u.p.input_complete)
2540 dtp->u.p.saved_type = BT_UNKNOWN;
2546 read_integer (dtp, len);
2550 read_logical (dtp, len);
2554 read_character (dtp, len);
2558 /* Need to copy data back from the real location to the temp in order
2559 to handle nml reads into arrays. */
2560 read_real (dtp, pdata, len);
2561 memcpy (dtp->u.p.value, pdata, dlen);
2565 /* Same as for REAL, copy back to temp. */
2566 read_complex (dtp, pdata, len, dlen);
2567 memcpy (dtp->u.p.value, pdata, dlen);
2571 obj_name_len = strlen (nl->var_name) + 1;
2572 obj_name = xmalloc (obj_name_len+1);
2573 memcpy (obj_name, nl->var_name, obj_name_len-1);
2574 memcpy (obj_name + obj_name_len - 1, "%", 2);
2576 /* If reading a derived type, disable the expanded read warning
2577 since a single object can have multiple reads. */
2578 dtp->u.p.expanded_read = 0;
2580 /* Now loop over the components. */
2582 for (cmp = nl->next;
2584 !strncmp (cmp->var_name, obj_name, obj_name_len);
2587 /* Jump over nested derived type by testing if the potential
2588 component name contains '%'. */
2589 if (strchr (cmp->var_name + obj_name_len, '%'))
2592 if (!nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2593 pprev_nl, nml_err_msg, nml_err_msg_size,
2600 if (dtp->u.p.input_complete)
2611 snprintf (nml_err_msg, nml_err_msg_size,
2612 "Bad type for namelist object %s", nl->var_name);
2613 internal_error (&dtp->common, nml_err_msg);
2618 /* The standard permits array data to stop short of the number of
2619 elements specified in the loop specification. In this case, we
2620 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2621 nml_get_obj_data and an attempt is made to read object name. */
2624 if (dtp->u.p.nml_read_error)
2626 dtp->u.p.expanded_read = 0;
2630 if (dtp->u.p.saved_type == BT_UNKNOWN)
2632 dtp->u.p.expanded_read = 0;
2636 switch (dtp->u.p.saved_type)
2643 memcpy (pdata, dtp->u.p.value, dlen);
2647 if (dlen < dtp->u.p.saved_used)
2649 if (compile_options.bounds_check)
2651 snprintf (nml_err_msg, nml_err_msg_size,
2652 "Namelist object '%s' truncated on read.",
2654 generate_warning (&dtp->common, nml_err_msg);
2659 m = dtp->u.p.saved_used;
2660 pdata = (void*)( pdata + clow - 1 );
2661 memcpy (pdata, dtp->u.p.saved_string, m);
2663 memset ((void*)( pdata + m ), ' ', dlen - m);
2670 /* Warn if a non-standard expanded read occurs. A single read of a
2671 single object is acceptable. If a second read occurs, issue a warning
2672 and set the flag to zero to prevent further warnings. */
2673 if (dtp->u.p.expanded_read == 2)
2675 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2676 dtp->u.p.expanded_read = 0;
2679 /* If the expanded read warning flag is set, increment it,
2680 indicating that a single read has occurred. */
2681 if (dtp->u.p.expanded_read >= 1)
2682 dtp->u.p.expanded_read++;
2684 /* Break out of loop if scalar. */
2688 /* Now increment the index vector. */
2693 for (dim = 0; dim < nl->var_rank; dim++)
2695 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2697 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2699 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2701 nl->ls[dim].idx = nl->ls[dim].start;
2705 } while (!nml_carry);
2707 if (dtp->u.p.repeat_count > 1)
2709 snprintf (nml_err_msg, nml_err_msg_size,
2710 "Repeat count too large for namelist object %s", nl->var_name);
2720 /* Parses the object name, including array and substring qualifiers. It
2721 iterates over derived type components, touching those components and
2722 setting their loop specifications, if there is a qualifier. If the
2723 object is itself a derived type, its components and subcomponents are
2724 touched. nml_read_obj is called at the end and this reads the data in
2725 the manner specified by the object name. */
2728 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2729 char *nml_err_msg, size_t nml_err_msg_size)
2733 namelist_info * first_nl = NULL;
2734 namelist_info * root_nl = NULL;
2735 int dim, parsed_rank;
2736 int component_flag, qualifier_flag;
2737 index_type clow, chigh;
2738 int non_zero_rank_count;
2740 /* Look for end of input or object name. If '?' or '=?' are encountered
2741 in stdin, print the node names or the namelist to stdout. */
2743 eat_separator (dtp);
2744 if (dtp->u.p.input_complete)
2747 if (dtp->u.p.at_eol)
2748 finish_separator (dtp);
2749 if (dtp->u.p.input_complete)
2752 if ((c = next_char (dtp)) == EOF)
2757 if ((c = next_char (dtp)) == EOF)
2761 snprintf (nml_err_msg, nml_err_msg_size,
2762 "namelist read: misplaced = sign");
2765 nml_query (dtp, '=');
2769 nml_query (dtp, '?');
2774 nml_match_name (dtp, "end", 3);
2775 if (dtp->u.p.nml_read_error)
2777 snprintf (nml_err_msg, nml_err_msg_size,
2778 "namelist not terminated with / or &end");
2782 dtp->u.p.input_complete = 1;
2789 /* Untouch all nodes of the namelist and reset the flags that are set for
2790 derived type components. */
2792 nml_untouch_nodes (dtp);
2795 non_zero_rank_count = 0;
2797 /* Get the object name - should '!' and '\n' be permitted separators? */
2805 if (!is_separator (c))
2806 push_char (dtp, tolower(c));
2807 if ((c = next_char (dtp)) == EOF)
2809 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2811 unget_char (dtp, c);
2813 /* Check that the name is in the namelist and get pointer to object.
2814 Three error conditions exist: (i) An attempt is being made to
2815 identify a non-existent object, following a failed data read or
2816 (ii) The object name does not exist or (iii) Too many data items
2817 are present for an object. (iii) gives the same error message
2820 push_char (dtp, '\0');
2824 size_t var_len = strlen (root_nl->var_name);
2826 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2827 char ext_name[var_len + saved_len + 1];
2829 memcpy (ext_name, root_nl->var_name, var_len);
2830 if (dtp->u.p.saved_string)
2831 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2832 ext_name[var_len + saved_len] = '\0';
2833 nl = find_nml_node (dtp, ext_name);
2836 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2840 if (dtp->u.p.nml_read_error && *pprev_nl)
2841 snprintf (nml_err_msg, nml_err_msg_size,
2842 "Bad data for namelist object %s", (*pprev_nl)->var_name);
2845 snprintf (nml_err_msg, nml_err_msg_size,
2846 "Cannot match namelist object name %s",
2847 dtp->u.p.saved_string);
2852 /* Get the length, data length, base pointer and rank of the variable.
2853 Set the default loop specification first. */
2855 for (dim=0; dim < nl->var_rank; dim++)
2857 nl->ls[dim].step = 1;
2858 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2859 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2860 nl->ls[dim].idx = nl->ls[dim].start;
2863 /* Check to see if there is a qualifier: if so, parse it.*/
2865 if (c == '(' && nl->var_rank)
2868 if (!nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2869 nl->type, nml_err_msg, nml_err_msg_size,
2872 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2873 snprintf (nml_err_msg_end,
2874 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2875 " for namelist variable %s", nl->var_name);
2878 if (parsed_rank > 0)
2879 non_zero_rank_count++;
2883 if ((c = next_char (dtp)) == EOF)
2885 unget_char (dtp, c);
2887 else if (nl->var_rank > 0)
2888 non_zero_rank_count++;
2890 /* Now parse a derived type component. The root namelist_info address
2891 is backed up, as is the previous component level. The component flag
2892 is set and the iteration is made by jumping back to get_name. */
2896 if (nl->type != BT_DERIVED)
2898 snprintf (nml_err_msg, nml_err_msg_size,
2899 "Attempt to get derived component for %s", nl->var_name);
2903 /* Don't move first_nl further in the list if a qualifier was found. */
2904 if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag)
2910 if ((c = next_char (dtp)) == EOF)
2915 /* Parse a character qualifier, if present. chigh = 0 is a default
2916 that signals that the string length = string_length. */
2921 if (c == '(' && nl->type == BT_CHARACTER)
2923 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2924 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2926 if (!nml_parse_qualifier (dtp, chd, ind, -1, nl->type,
2927 nml_err_msg, nml_err_msg_size, &parsed_rank))
2929 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2930 snprintf (nml_err_msg_end,
2931 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2932 " for namelist variable %s", nl->var_name);
2936 clow = ind[0].start;
2939 if (ind[0].step != 1)
2941 snprintf (nml_err_msg, nml_err_msg_size,
2942 "Step not allowed in substring qualifier"
2943 " for namelist object %s", nl->var_name);
2947 if ((c = next_char (dtp)) == EOF)
2949 unget_char (dtp, c);
2952 /* Make sure no extraneous qualifiers are there. */
2956 snprintf (nml_err_msg, nml_err_msg_size,
2957 "Qualifier for a scalar or non-character namelist object %s",
2962 /* Make sure there is no more than one non-zero rank object. */
2963 if (non_zero_rank_count > 1)
2965 snprintf (nml_err_msg, nml_err_msg_size,
2966 "Multiple sub-objects with non-zero rank in namelist object %s",
2968 non_zero_rank_count = 0;
2972 /* According to the standard, an equal sign MUST follow an object name. The
2973 following is possibly lax - it allows comments, blank lines and so on to
2974 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2978 eat_separator (dtp);
2979 if (dtp->u.p.input_complete)
2982 if (dtp->u.p.at_eol)
2983 finish_separator (dtp);
2984 if (dtp->u.p.input_complete)
2987 if ((c = next_char (dtp)) == EOF)
2992 snprintf (nml_err_msg, nml_err_msg_size,
2993 "Equal sign must follow namelist object name %s",
2997 /* If a derived type, touch its components and restore the root
2998 namelist_info if we have parsed a qualified derived type
3001 if (nl->type == BT_DERIVED)
3002 nml_touch_nodes (nl);
3006 if (first_nl->var_rank == 0)
3008 if (component_flag && qualifier_flag)
3015 if (!nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
3026 /* Entry point for namelist input. Goes through input until namelist name
3027 is matched. Then cycles through nml_get_obj_data until the input is
3028 completed or there is an error. */
3031 namelist_read (st_parameter_dt *dtp)
3034 char nml_err_msg[200];
3036 /* Initialize the error string buffer just in case we get an unexpected fail
3037 somewhere and end up at nml_err_ret. */
3038 strcpy (nml_err_msg, "Internal namelist read error");
3040 /* Pointer to the previously read object, in case attempt is made to read
3041 new object name. Should this fail, error message can give previous
3043 namelist_info *prev_nl = NULL;
3045 dtp->u.p.namelist_mode = 1;
3046 dtp->u.p.input_complete = 0;
3047 dtp->u.p.expanded_read = 0;
3049 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3050 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3051 node names or namelist on stdout. */
3054 c = next_char (dtp);
3066 c = next_char (dtp);
3068 nml_query (dtp, '=');
3070 unget_char (dtp, c);
3074 nml_query (dtp, '?');
3083 /* Match the name of the namelist. */
3085 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3087 if (dtp->u.p.nml_read_error)
3090 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3091 c = next_char (dtp);
3092 if (!is_separator(c) && c != '!')
3094 unget_char (dtp, c);
3098 unget_char (dtp, c);
3099 eat_separator (dtp);
3101 /* Ready to read namelist objects. If there is an error in input
3102 from stdin, output the error message and continue. */
3104 while (!dtp->u.p.input_complete)
3106 if (!nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg))
3108 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3110 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3113 /* Reset the previous namelist pointer if we know we are not going
3114 to be doing multiple reads within a single namelist object. */
3115 if (prev_nl && prev_nl->var_rank == 0)
3126 /* All namelist error calls return from here */
3129 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);