1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist input contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r' || c == ';')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt *dtp, char c)
76 if (dtp->u.p.saved_string == NULL)
78 dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
79 // memset below should be commented out.
80 memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
81 dtp->u.p.saved_length = SCRATCH_SIZE;
82 dtp->u.p.saved_used = 0;
85 if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
87 dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
88 new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
90 generate_error (&dtp->common, LIBERROR_OS, NULL);
91 dtp->u.p.saved_string = new;
93 // Also this should not be necessary.
94 memset (new + dtp->u.p.saved_used, 0,
95 dtp->u.p.saved_length - dtp->u.p.saved_used);
99 dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
103 /* Free the input buffer if necessary. */
106 free_saved (st_parameter_dt *dtp)
108 if (dtp->u.p.saved_string == NULL)
111 free (dtp->u.p.saved_string);
113 dtp->u.p.saved_string = NULL;
114 dtp->u.p.saved_used = 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt *dtp)
123 dtp->u.p.item_count = 0;
124 dtp->u.p.line_buffer_enabled = 0;
126 if (dtp->u.p.line_buffer == NULL)
129 free (dtp->u.p.line_buffer);
130 dtp->u.p.line_buffer = NULL;
135 next_char (st_parameter_dt *dtp)
141 if (dtp->u.p.last_char != EOF - 1)
144 c = dtp->u.p.last_char;
145 dtp->u.p.last_char = EOF - 1;
149 /* Read from line_buffer if enabled. */
151 if (dtp->u.p.line_buffer_enabled)
155 c = dtp->u.p.line_buffer[dtp->u.p.item_count];
156 if (c != '\0' && dtp->u.p.item_count < 64)
158 dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
159 dtp->u.p.item_count++;
163 dtp->u.p.item_count = 0;
164 dtp->u.p.line_buffer_enabled = 0;
167 /* Handle the end-of-record and end-of-file conditions for
168 internal array unit. */
169 if (is_array_io (dtp))
174 /* Check for "end-of-record" condition. */
175 if (dtp->u.p.current_unit->bytes_left == 0)
180 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
183 /* Check for "end-of-file" condition. */
190 record *= dtp->u.p.current_unit->recl;
191 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
194 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
199 /* Get the next character and handle end-of-record conditions. */
201 if (is_internal_unit (dtp))
204 length = sread (dtp->u.p.current_unit->s, &cc, 1);
208 generate_error (&dtp->common, LIBERROR_OS, NULL);
212 if (is_array_io (dtp))
214 /* Check whether we hit EOF. */
217 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
220 dtp->u.p.current_unit->bytes_left--;
235 c = fbuf_getc (dtp->u.p.current_unit);
236 if (c != EOF && is_stream_io (dtp))
237 dtp->u.p.current_unit->strm_pos++;
240 dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF);
245 /* Push a character back onto the input. */
248 unget_char (st_parameter_dt *dtp, int c)
250 dtp->u.p.last_char = c;
254 /* Skip over spaces in the input. Returns the nonspace character that
255 terminated the eating and also places it back on the input. */
258 eat_spaces (st_parameter_dt *dtp)
264 while (c != EOF && (c == ' ' || c == '\t'));
271 /* This function reads characters through to the end of the current
272 line and just ignores them. Returns 0 for success and LIBERROR_END
276 eat_line (st_parameter_dt *dtp)
282 while (c != EOF && c != '\n');
289 /* Skip over a separator. Technically, we don't always eat the whole
290 separator. This is because if we've processed the last input item,
291 then a separator is unnecessary. Plus the fact that operating
292 systems usually deliver console input on a line basis.
294 The upshot is that if we see a newline as part of reading a
295 separator, we stop reading. If there are more input items, we
296 continue reading the separator with finish_separator() which takes
297 care of the fact that we may or may not have seen a comma as part
300 Returns 0 for success, and non-zero error code otherwise. */
303 eat_separator (st_parameter_dt *dtp)
309 dtp->u.p.comma_flag = 0;
311 if ((c = next_char (dtp)) == EOF)
316 if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
323 dtp->u.p.comma_flag = 1;
328 dtp->u.p.input_complete = 1;
333 if ((n = next_char(dtp)) == EOF)
343 if (dtp->u.p.namelist_mode)
347 if ((c = next_char (dtp)) == EOF)
351 err = eat_line (dtp);
354 if ((c = next_char (dtp)) == EOF)
358 err = eat_line (dtp);
361 if ((c = next_char (dtp)) == EOF)
366 while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
372 if (dtp->u.p.namelist_mode)
373 { /* Eat a namelist comment. */
374 err = eat_line (dtp);
381 /* Fall Through... */
391 /* Finish processing a separator that was interrupted by a newline.
392 If we're here, then another data item is present, so we finish what
393 we started on the previous line. Return 0 on success, error code
397 finish_separator (st_parameter_dt *dtp)
405 if ((c = next_char (dtp)) == EOF)
410 if (dtp->u.p.comma_flag)
414 if ((c = eat_spaces (dtp)) == EOF)
416 if (c == '\n' || c == '\r')
423 dtp->u.p.input_complete = 1;
424 if (!dtp->u.p.namelist_mode)
433 if (dtp->u.p.namelist_mode)
435 err = eat_line (dtp);
449 /* This function is needed to catch bad conversions so that namelist can
450 attempt to see if dtp->u.p.saved_string contains a new object name rather
454 nml_bad_return (st_parameter_dt *dtp, char c)
456 if (dtp->u.p.namelist_mode)
458 dtp->u.p.nml_read_error = 1;
465 /* Convert an unsigned string to an integer. The length value is -1
466 if we are working on a repeat count. Returns nonzero if we have a
467 range problem. As a side effect, frees the dtp->u.p.saved_string. */
470 convert_integer (st_parameter_dt *dtp, int length, int negative)
472 char c, *buffer, message[MSGLEN];
474 GFC_INTEGER_LARGEST v, max, max10;
476 buffer = dtp->u.p.saved_string;
479 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
504 set_integer (dtp->u.p.value, v, length);
508 dtp->u.p.repeat_count = v;
510 if (dtp->u.p.repeat_count == 0)
512 snprintf (message, MSGLEN, "Zero repeat count in item %d of list input",
513 dtp->u.p.item_count);
515 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
525 snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input",
526 dtp->u.p.item_count);
528 snprintf (message, MSGLEN, "Integer overflow while reading item %d",
529 dtp->u.p.item_count);
532 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
538 /* Parse a repeat count for logical and complex values which cannot
539 begin with a digit. Returns nonzero if we are done, zero if we
540 should continue on. */
543 parse_repeat (st_parameter_dt *dtp)
545 char message[MSGLEN];
548 if ((c = next_char (dtp)) == EOF)
572 repeat = 10 * repeat + c - '0';
574 if (repeat > MAX_REPEAT)
576 snprintf (message, MSGLEN,
577 "Repeat count overflow in item %d of list input",
578 dtp->u.p.item_count);
580 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
589 snprintf (message, MSGLEN,
590 "Zero repeat count in item %d of list input",
591 dtp->u.p.item_count);
593 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
605 dtp->u.p.repeat_count = repeat;
618 snprintf (message, MSGLEN, "Bad repeat count in item %d of list input",
619 dtp->u.p.item_count);
620 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
625 /* To read a logical we have to look ahead in the input stream to make sure
626 there is not an equal sign indicating a variable name. To do this we use
627 line_buffer to point to a temporary buffer, pushing characters there for
628 possible later reading. */
631 l_push_char (st_parameter_dt *dtp, char c)
633 if (dtp->u.p.line_buffer == NULL)
635 dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
636 memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
639 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
643 /* Read a logical character on the input. */
646 read_logical (st_parameter_dt *dtp, int length)
648 char message[MSGLEN];
651 if (parse_repeat (dtp))
654 c = tolower (next_char (dtp));
655 l_push_char (dtp, c);
661 l_push_char (dtp, c);
663 if (!is_separator(c) && c != EOF)
671 l_push_char (dtp, c);
673 if (!is_separator(c) && c != EOF)
680 c = tolower (next_char (dtp));
698 return; /* Null value. */
701 /* Save the character in case it is the beginning
702 of the next object name. */
707 dtp->u.p.saved_type = BT_LOGICAL;
708 dtp->u.p.saved_length = length;
710 /* Eat trailing garbage. */
713 while (c != EOF && !is_separator (c));
717 set_integer ((int *) dtp->u.p.value, v, length);
724 for(i = 0; i < 63; i++)
729 /* All done if this is not a namelist read. */
730 if (!dtp->u.p.namelist_mode)
743 l_push_char (dtp, c);
746 dtp->u.p.nml_read_error = 1;
747 dtp->u.p.line_buffer_enabled = 1;
748 dtp->u.p.item_count = 0;
758 if (nml_bad_return (dtp, c))
769 snprintf (message, MSGLEN, "Bad logical value while reading item %d",
770 dtp->u.p.item_count);
771 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
776 dtp->u.p.saved_type = BT_LOGICAL;
777 dtp->u.p.saved_length = length;
778 set_integer ((int *) dtp->u.p.value, v, length);
784 /* Reading integers is tricky because we can actually be reading a
785 repeat count. We have to store the characters in a buffer because
786 we could be reading an integer that is larger than the default int
787 used for repeat counts. */
790 read_integer (st_parameter_dt *dtp, int length)
792 char message[MSGLEN];
802 /* Fall through... */
805 if ((c = next_char (dtp)) == EOF)
809 CASE_SEPARATORS: /* Single null. */
822 /* Take care of what may be a repeat count. */
834 push_char (dtp, '\0');
837 CASE_SEPARATORS: /* Not a repeat count. */
847 if (convert_integer (dtp, -1, 0))
850 /* Get the real integer. */
852 if ((c = next_char (dtp)) == EOF)
866 /* Fall through... */
898 if (nml_bad_return (dtp, c))
909 snprintf (message, MSGLEN, "Bad integer for item %d in list input",
910 dtp->u.p.item_count);
911 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
919 push_char (dtp, '\0');
920 if (convert_integer (dtp, length, negative))
927 dtp->u.p.saved_type = BT_INTEGER;
931 /* Read a character variable. */
934 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
936 char quote, message[MSGLEN];
939 quote = ' '; /* Space means no quote character. */
941 if ((c = next_char (dtp)) == EOF)
950 unget_char (dtp, c); /* NULL value. */
960 if (dtp->u.p.namelist_mode)
970 /* Deal with a possible repeat count. */
974 if ((c = next_char (dtp)) == EOF)
984 goto done; /* String was only digits! */
987 push_char (dtp, '\0');
992 goto get_string; /* Not a repeat count after all. */
997 if (convert_integer (dtp, -1, 0))
1000 /* Now get the real string. */
1002 if ((c = next_char (dtp)) == EOF)
1007 unget_char (dtp, c); /* Repeated NULL values. */
1008 eat_separator (dtp);
1024 if ((c = next_char (dtp)) == EOF)
1036 /* See if we have a doubled quote character or the end of
1039 if ((c = next_char (dtp)) == EOF)
1043 push_char (dtp, quote);
1047 unget_char (dtp, c);
1053 unget_char (dtp, c);
1057 if (c != '\n' && c != '\r')
1067 /* At this point, we have to have a separator, or else the string is
1070 c = next_char (dtp);
1072 if (is_separator (c) || c == '!' || c == EOF)
1074 unget_char (dtp, c);
1075 eat_separator (dtp);
1076 dtp->u.p.saved_type = BT_CHARACTER;
1082 snprintf (message, MSGLEN, "Invalid string input in item %d",
1083 dtp->u.p.item_count);
1084 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1094 /* Parse a component of a complex constant or a real number that we
1095 are sure is already there. This is a straight real number parser. */
1098 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1100 char message[MSGLEN];
1103 if ((c = next_char (dtp)) == EOF)
1106 if (c == '-' || c == '+')
1109 if ((c = next_char (dtp)) == EOF)
1113 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1116 if (!isdigit (c) && c != '.')
1118 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1126 seen_dp = (c == '.') ? 1 : 0;
1130 if ((c = next_char (dtp)) == EOF)
1132 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1152 push_char (dtp, 'e');
1157 push_char (dtp, 'e');
1159 if ((c = next_char (dtp)) == EOF)
1172 if ((c = next_char (dtp)) == EOF)
1174 if (c != '-' && c != '+')
1175 push_char (dtp, '+');
1179 c = next_char (dtp);
1190 if ((c = next_char (dtp)) == EOF)
1199 unget_char (dtp, c);
1208 unget_char (dtp, c);
1209 push_char (dtp, '\0');
1211 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1217 unget_char (dtp, c);
1218 push_char (dtp, '\0');
1220 m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length);
1226 /* Match INF and Infinity. */
1227 if ((c == 'i' || c == 'I')
1228 && ((c = next_char (dtp)) == 'n' || c == 'N')
1229 && ((c = next_char (dtp)) == 'f' || c == 'F'))
1231 c = next_char (dtp);
1232 if ((c != 'i' && c != 'I')
1233 || ((c == 'i' || c == 'I')
1234 && ((c = next_char (dtp)) == 'n' || c == 'N')
1235 && ((c = next_char (dtp)) == 'i' || c == 'I')
1236 && ((c = next_char (dtp)) == 't' || c == 'T')
1237 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1238 && (c = next_char (dtp))))
1240 if (is_separator (c))
1241 unget_char (dtp, c);
1242 push_char (dtp, 'i');
1243 push_char (dtp, 'n');
1244 push_char (dtp, 'f');
1248 else if (((c = next_char (dtp)) == 'a' || c == 'A')
1249 && ((c = next_char (dtp)) == 'n' || c == 'N')
1250 && (c = next_char (dtp)))
1252 if (is_separator (c))
1253 unget_char (dtp, c);
1254 push_char (dtp, 'n');
1255 push_char (dtp, 'a');
1256 push_char (dtp, 'n');
1258 /* Match "NAN(alphanum)". */
1261 for ( ; c != ')'; c = next_char (dtp))
1262 if (is_separator (c))
1265 c = next_char (dtp);
1266 if (is_separator (c))
1267 unget_char (dtp, c);
1274 if (nml_bad_return (dtp, c))
1285 snprintf (message, MSGLEN, "Bad floating point number for item %d",
1286 dtp->u.p.item_count);
1287 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1293 /* Reading a complex number is straightforward because we can tell
1294 what it is right away. */
1297 read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
1299 char message[MSGLEN];
1302 if (parse_repeat (dtp))
1305 c = next_char (dtp);
1312 unget_char (dtp, c);
1313 eat_separator (dtp);
1322 c = next_char (dtp);
1323 if (c == '\n' || c== '\r')
1326 unget_char (dtp, c);
1328 if (parse_real (dtp, dest, kind))
1333 c = next_char (dtp);
1334 if (c == '\n' || c== '\r')
1337 unget_char (dtp, c);
1340 != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
1345 c = next_char (dtp);
1346 if (c == '\n' || c== '\r')
1349 unget_char (dtp, c);
1351 if (parse_real (dtp, dest + size / 2, kind))
1356 c = next_char (dtp);
1357 if (c == '\n' || c== '\r')
1360 unget_char (dtp, c);
1362 if (next_char (dtp) != ')')
1365 c = next_char (dtp);
1366 if (!is_separator (c))
1369 unget_char (dtp, c);
1370 eat_separator (dtp);
1373 dtp->u.p.saved_type = BT_COMPLEX;
1378 if (nml_bad_return (dtp, c))
1389 snprintf (message, MSGLEN, "Bad complex value in item %d of list input",
1390 dtp->u.p.item_count);
1391 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1395 /* Parse a real number with a possible repeat count. */
1398 read_real (st_parameter_dt *dtp, void * dest, int length)
1400 char message[MSGLEN];
1407 c = next_char (dtp);
1408 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1426 unget_char (dtp, c); /* Single null. */
1427 eat_separator (dtp);
1440 /* Get the digit string that might be a repeat count. */
1444 c = next_char (dtp);
1445 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1469 push_char (dtp, 'e');
1471 c = next_char (dtp);
1475 push_char (dtp, '\0');
1479 if (c != '\n' && c != ',' && c != '\r' && c != ';')
1480 unget_char (dtp, c);
1489 if (convert_integer (dtp, -1, 0))
1492 /* Now get the number itself. */
1494 if ((c = next_char (dtp)) == EOF)
1496 if (is_separator (c))
1497 { /* Repeated null value. */
1498 unget_char (dtp, c);
1499 eat_separator (dtp);
1503 if (c != '-' && c != '+')
1504 push_char (dtp, '+');
1509 if ((c = next_char (dtp)) == EOF)
1513 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1516 if (!isdigit (c) && c != '.')
1518 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1537 c = next_char (dtp);
1538 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1566 push_char (dtp, 'e');
1568 c = next_char (dtp);
1577 push_char (dtp, 'e');
1579 if ((c = next_char (dtp)) == EOF)
1581 if (c != '+' && c != '-')
1582 push_char (dtp, '+');
1586 c = next_char (dtp);
1596 c = next_char (dtp);
1613 unget_char (dtp, c);
1614 eat_separator (dtp);
1615 push_char (dtp, '\0');
1616 if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
1620 dtp->u.p.saved_type = BT_REAL;
1624 l_push_char (dtp, c);
1627 /* Match INF and Infinity. */
1628 if (c == 'i' || c == 'I')
1630 c = next_char (dtp);
1631 l_push_char (dtp, c);
1632 if (c != 'n' && c != 'N')
1634 c = next_char (dtp);
1635 l_push_char (dtp, c);
1636 if (c != 'f' && c != 'F')
1638 c = next_char (dtp);
1639 l_push_char (dtp, c);
1640 if (!is_separator (c))
1642 if (c != 'i' && c != 'I')
1644 c = next_char (dtp);
1645 l_push_char (dtp, c);
1646 if (c != 'n' && c != 'N')
1648 c = next_char (dtp);
1649 l_push_char (dtp, c);
1650 if (c != 'i' && c != 'I')
1652 c = next_char (dtp);
1653 l_push_char (dtp, c);
1654 if (c != 't' && c != 'T')
1656 c = next_char (dtp);
1657 l_push_char (dtp, c);
1658 if (c != 'y' && c != 'Y')
1660 c = next_char (dtp);
1661 l_push_char (dtp, c);
1667 c = next_char (dtp);
1668 l_push_char (dtp, c);
1669 if (c != 'a' && c != 'A')
1671 c = next_char (dtp);
1672 l_push_char (dtp, c);
1673 if (c != 'n' && c != 'N')
1675 c = next_char (dtp);
1676 l_push_char (dtp, c);
1678 /* Match NAN(alphanum). */
1681 for (c = next_char (dtp); c != ')'; c = next_char (dtp))
1682 if (is_separator (c))
1685 l_push_char (dtp, c);
1687 l_push_char (dtp, ')');
1688 c = next_char (dtp);
1689 l_push_char (dtp, c);
1693 if (!is_separator (c))
1696 if (dtp->u.p.namelist_mode)
1698 if (c == ' ' || c =='\n' || c == '\r')
1702 if ((c = next_char (dtp)) == EOF)
1705 while (c == ' ' || c =='\n' || c == '\r');
1707 l_push_char (dtp, c);
1716 push_char (dtp, 'i');
1717 push_char (dtp, 'n');
1718 push_char (dtp, 'f');
1722 push_char (dtp, 'n');
1723 push_char (dtp, 'a');
1724 push_char (dtp, 'n');
1728 unget_char (dtp, c);
1729 eat_separator (dtp);
1730 push_char (dtp, '\0');
1731 if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length))
1735 dtp->u.p.saved_type = BT_REAL;
1739 if (dtp->u.p.namelist_mode)
1741 dtp->u.p.nml_read_error = 1;
1742 dtp->u.p.line_buffer_enabled = 1;
1743 dtp->u.p.item_count = 0;
1749 if (nml_bad_return (dtp, c))
1761 snprintf (message, MSGLEN, "Bad real number in item %d of list input",
1762 dtp->u.p.item_count);
1763 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1767 /* Check the current type against the saved type to make sure they are
1768 compatible. Returns nonzero if incompatible. */
1771 check_type (st_parameter_dt *dtp, bt type, int len)
1773 char message[MSGLEN];
1775 if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
1777 snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d",
1778 type_name (dtp->u.p.saved_type), type_name (type),
1779 dtp->u.p.item_count);
1781 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1785 if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
1788 if (dtp->u.p.saved_length != len)
1790 snprintf (message, MSGLEN,
1791 "Read kind %d %s where kind %d is required for item %d",
1792 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1793 dtp->u.p.item_count);
1794 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1802 /* Top level data transfer subroutine for list reads. Because we have
1803 to deal with repeat counts, the data item is always saved after
1804 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1805 greater than one, we copy the data item multiple times. */
1808 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
1809 int kind, size_t size)
1815 dtp->u.p.namelist_mode = 0;
1817 if (dtp->u.p.first_item)
1819 dtp->u.p.first_item = 0;
1820 dtp->u.p.input_complete = 0;
1821 dtp->u.p.repeat_count = 1;
1822 dtp->u.p.at_eol = 0;
1824 if ((c = eat_spaces (dtp)) == EOF)
1829 if (is_separator (c))
1831 /* Found a null value. */
1832 eat_separator (dtp);
1833 dtp->u.p.repeat_count = 0;
1835 /* eat_separator sets this flag if the separator was a comma. */
1836 if (dtp->u.p.comma_flag)
1839 /* eat_separator sets this flag if the separator was a \n or \r. */
1840 if (dtp->u.p.at_eol)
1841 finish_separator (dtp);
1849 if (dtp->u.p.repeat_count > 0)
1851 if (check_type (dtp, type, kind))
1856 if (dtp->u.p.input_complete)
1859 if (dtp->u.p.at_eol)
1860 finish_separator (dtp);
1864 /* Trailing spaces prior to end of line. */
1865 if (dtp->u.p.at_eol)
1866 finish_separator (dtp);
1869 dtp->u.p.saved_type = BT_UNKNOWN;
1870 dtp->u.p.repeat_count = 1;
1876 read_integer (dtp, kind);
1879 read_logical (dtp, kind);
1882 read_character (dtp, kind);
1885 read_real (dtp, p, kind);
1886 /* Copy value back to temporary if needed. */
1887 if (dtp->u.p.repeat_count > 0)
1888 memcpy (dtp->u.p.value, p, kind);
1891 read_complex (dtp, p, kind, size);
1892 /* Copy value back to temporary if needed. */
1893 if (dtp->u.p.repeat_count > 0)
1894 memcpy (dtp->u.p.value, p, size);
1897 internal_error (&dtp->common, "Bad type for list read");
1900 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN)
1901 dtp->u.p.saved_length = size;
1903 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1907 switch (dtp->u.p.saved_type)
1911 if (dtp->u.p.repeat_count > 0)
1912 memcpy (p, dtp->u.p.value, size);
1917 memcpy (p, dtp->u.p.value, size);
1921 if (dtp->u.p.saved_string)
1923 m = ((int) size < dtp->u.p.saved_used)
1924 ? (int) size : dtp->u.p.saved_used;
1926 memcpy (p, dtp->u.p.saved_string, m);
1929 q = (gfc_char4_t *) p;
1930 for (i = 0; i < m; i++)
1931 q[i] = (unsigned char) dtp->u.p.saved_string[i];
1935 /* Just delimiters encountered, nothing to copy but SPACE. */
1941 memset (((char *) p) + m, ' ', size - m);
1944 q = (gfc_char4_t *) p;
1945 for (i = m; i < (int) size; i++)
1946 q[i] = (unsigned char) ' ';
1955 internal_error (&dtp->common, "Bad type for list read");
1958 if (--dtp->u.p.repeat_count <= 0)
1962 if (err == LIBERROR_END)
1969 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1970 size_t size, size_t nelems)
1974 size_t stride = type == BT_CHARACTER ?
1975 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1980 /* Big loop over all the elements. */
1981 for (elem = 0; elem < nelems; elem++)
1983 dtp->u.p.item_count++;
1984 err = list_formatted_read_scalar (dtp, type, tmp + stride*elem,
1992 /* Finish a list read. */
1995 finish_list_read (st_parameter_dt *dtp)
2001 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2003 if (dtp->u.p.at_eol)
2005 dtp->u.p.at_eol = 0;
2009 err = eat_line (dtp);
2010 if (err == LIBERROR_END)
2016 void namelist_read (st_parameter_dt *dtp)
2018 static void nml_match_name (char *name, int len)
2019 static int nml_query (st_parameter_dt *dtp)
2020 static int nml_get_obj_data (st_parameter_dt *dtp,
2021 namelist_info **prev_nl, char *, size_t)
2023 static void nml_untouch_nodes (st_parameter_dt *dtp)
2024 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2026 static int nml_parse_qualifier(descriptor_dimension * ad,
2027 array_loop_spec * ls, int rank, char *)
2028 static void nml_touch_nodes (namelist_info * nl)
2029 static int nml_read_obj (namelist_info *nl, index_type offset,
2030 namelist_info **prev_nl, char *, size_t,
2031 index_type clow, index_type chigh)
2035 /* Inputs a rank-dimensional qualifier, which can contain
2036 singlets, doublets, triplets or ':' with the standard meanings. */
2039 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
2040 array_loop_spec *ls, int rank, char *parse_err_msg,
2041 size_t parse_err_msg_size,
2048 int is_array_section, is_char;
2052 is_array_section = 0;
2053 dtp->u.p.expanded_read = 0;
2055 /* See if this is a character substring qualifier we are looking for. */
2062 /* The next character in the stream should be the '('. */
2064 if ((c = next_char (dtp)) == EOF)
2067 /* Process the qualifier, by dimension and triplet. */
2069 for (dim=0; dim < rank; dim++ )
2071 for (indx=0; indx<3; indx++)
2077 /* Process a potential sign. */
2078 if ((c = next_char (dtp)) == EOF)
2090 unget_char (dtp, c);
2094 /* Process characters up to the next ':' , ',' or ')'. */
2097 if ((c = next_char (dtp)) == EOF)
2103 is_array_section = 1;
2107 if ((c==',' && dim == rank -1)
2108 || (c==')' && dim < rank -1))
2111 snprintf (parse_err_msg, parse_err_msg_size,
2112 "Bad substring qualifier");
2114 snprintf (parse_err_msg, parse_err_msg_size,
2115 "Bad number of index fields");
2124 case ' ': case '\t':
2126 if ((c = next_char (dtp) == EOF))
2132 snprintf (parse_err_msg, parse_err_msg_size,
2133 "Bad character in substring qualifier");
2135 snprintf (parse_err_msg, parse_err_msg_size,
2136 "Bad character in index");
2140 if ((c == ',' || c == ')') && indx == 0
2141 && dtp->u.p.saved_string == 0)
2144 snprintf (parse_err_msg, parse_err_msg_size,
2145 "Null substring qualifier");
2147 snprintf (parse_err_msg, parse_err_msg_size,
2148 "Null index field");
2152 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2153 || (indx == 2 && dtp->u.p.saved_string == 0))
2156 snprintf (parse_err_msg, parse_err_msg_size,
2157 "Bad substring qualifier");
2159 snprintf (parse_err_msg, parse_err_msg_size,
2160 "Bad index triplet");
2164 if (is_char && !is_array_section)
2166 snprintf (parse_err_msg, parse_err_msg_size,
2167 "Missing colon in substring qualifier");
2171 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2173 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2174 || (indx==1 && dtp->u.p.saved_string == 0))
2180 /* Now read the index. */
2181 if (convert_integer (dtp, sizeof(index_type), neg))
2184 snprintf (parse_err_msg, parse_err_msg_size,
2185 "Bad integer substring qualifier");
2187 snprintf (parse_err_msg, parse_err_msg_size,
2188 "Bad integer in index");
2194 /* Feed the index values to the triplet arrays. */
2198 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2200 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type));
2202 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type));
2205 /* Singlet or doublet indices. */
2206 if (c==',' || c==')')
2210 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2212 /* If -std=f95/2003 or an array section is specified,
2213 do not allow excess data to be processed. */
2214 if (is_array_section == 1
2215 || !(compile_options.allow_std & GFC_STD_GNU)
2216 || !dtp->u.p.ionml->touched
2217 || dtp->u.p.ionml->type == BT_DERIVED)
2218 ls[dim].end = ls[dim].start;
2220 dtp->u.p.expanded_read = 1;
2223 /* Check for non-zero rank. */
2224 if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2231 if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2234 dtp->u.p.expanded_read = 0;
2235 for (i = 0; i < dim; i++)
2236 ls[i].end = ls[i].start;
2239 /* Check the values of the triplet indices. */
2240 if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim]))
2241 || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim]))
2242 || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim]))
2243 || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim])))
2246 snprintf (parse_err_msg, parse_err_msg_size,
2247 "Substring out of range");
2249 snprintf (parse_err_msg, parse_err_msg_size,
2250 "Index %d out of range", dim + 1);
2254 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2255 || (ls[dim].step == 0))
2257 snprintf (parse_err_msg, parse_err_msg_size,
2258 "Bad range in index %d", dim + 1);
2262 /* Initialise the loop index counter. */
2263 ls[dim].idx = ls[dim].start;
2273 static namelist_info *
2274 find_nml_node (st_parameter_dt *dtp, char * var_name)
2276 namelist_info * t = dtp->u.p.ionml;
2279 if (strcmp (var_name, t->var_name) == 0)
2289 /* Visits all the components of a derived type that have
2290 not explicitly been identified in the namelist input.
2291 touched is set and the loop specification initialised
2292 to default values */
2295 nml_touch_nodes (namelist_info * nl)
2297 index_type len = strlen (nl->var_name) + 1;
2299 char * ext_name = (char*)get_mem (len + 1);
2300 memcpy (ext_name, nl->var_name, len-1);
2301 memcpy (ext_name + len - 1, "%", 2);
2302 for (nl = nl->next; nl; nl = nl->next)
2304 if (strncmp (nl->var_name, ext_name, len) == 0)
2307 for (dim=0; dim < nl->var_rank; dim++)
2309 nl->ls[dim].step = 1;
2310 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2311 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2312 nl->ls[dim].idx = nl->ls[dim].start;
2322 /* Resets touched for the entire list of nml_nodes, ready for a
2326 nml_untouch_nodes (st_parameter_dt *dtp)
2329 for (t = dtp->u.p.ionml; t; t = t->next)
2334 /* Attempts to input name to namelist name. Returns
2335 dtp->u.p.nml_read_error = 1 on no match. */
2338 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2343 dtp->u.p.nml_read_error = 0;
2344 for (i = 0; i < len; i++)
2346 c = next_char (dtp);
2347 if (c == EOF || (tolower (c) != tolower (name[i])))
2349 dtp->u.p.nml_read_error = 1;
2355 /* If the namelist read is from stdin, output the current state of the
2356 namelist to stdout. This is used to implement the non-standard query
2357 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2358 the names alone are printed. */
2361 nml_query (st_parameter_dt *dtp, char c)
2363 gfc_unit * temp_unit;
2368 static const index_type endlen = 3;
2369 static const char endl[] = "\r\n";
2370 static const char nmlend[] = "&end\r\n";
2372 static const index_type endlen = 2;
2373 static const char endl[] = "\n";
2374 static const char nmlend[] = "&end\n";
2377 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2380 /* Store the current unit and transfer to stdout. */
2382 temp_unit = dtp->u.p.current_unit;
2383 dtp->u.p.current_unit = find_unit (options.stdout_unit);
2385 if (dtp->u.p.current_unit)
2387 dtp->u.p.mode = WRITING;
2388 next_record (dtp, 0);
2390 /* Write the namelist in its entirety. */
2393 namelist_write (dtp);
2395 /* Or write the list of names. */
2399 /* "&namelist_name\n" */
2401 len = dtp->namelist_name_len;
2402 p = write_block (dtp, len + endlen);
2406 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2407 memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2408 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2412 len = strlen (nl->var_name);
2413 p = write_block (dtp, len + endlen);
2417 memcpy ((char*)(p + 1), nl->var_name, len);
2418 memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2423 p = write_block (dtp, endlen + 3);
2425 memcpy (p, &nmlend, endlen + 3);
2428 /* Flush the stream to force immediate output. */
2430 fbuf_flush (dtp->u.p.current_unit, WRITING);
2431 sflush (dtp->u.p.current_unit->s);
2432 unlock_unit (dtp->u.p.current_unit);
2437 /* Restore the current unit. */
2439 dtp->u.p.current_unit = temp_unit;
2440 dtp->u.p.mode = READING;
2444 /* Reads and stores the input for the namelist object nl. For an array,
2445 the function loops over the ranges defined by the loop specification.
2446 This default to all the data or to the specification from a qualifier.
2447 nml_read_obj recursively calls itself to read derived types. It visits
2448 all its own components but only reads data for those that were touched
2449 when the name was parsed. If a read error is encountered, an attempt is
2450 made to return to read a new object name because the standard allows too
2451 little data to be available. On the other hand, too much data is an
2455 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2456 namelist_info **pprev_nl, char *nml_err_msg,
2457 size_t nml_err_msg_size, index_type clow, index_type chigh)
2459 namelist_info * cmp;
2466 size_t obj_name_len;
2469 /* This object not touched in name parsing. */
2474 dtp->u.p.repeat_count = 0;
2486 dlen = size_from_real_kind (len);
2490 dlen = size_from_complex_kind (len);
2494 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2503 /* Update the pointer to the data, using the current index vector */
2505 pdata = (void*)(nl->mem_pos + offset);
2506 for (dim = 0; dim < nl->var_rank; dim++)
2507 pdata = (void*)(pdata + (nl->ls[dim].idx
2508 - GFC_DESCRIPTOR_LBOUND(nl,dim))
2509 * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2511 /* Reset the error flag and try to read next value, if
2512 dtp->u.p.repeat_count=0 */
2514 dtp->u.p.nml_read_error = 0;
2516 if (--dtp->u.p.repeat_count <= 0)
2518 if (dtp->u.p.input_complete)
2520 if (dtp->u.p.at_eol)
2521 finish_separator (dtp);
2522 if (dtp->u.p.input_complete)
2525 dtp->u.p.saved_type = BT_UNKNOWN;
2531 read_integer (dtp, len);
2535 read_logical (dtp, len);
2539 read_character (dtp, len);
2543 /* Need to copy data back from the real location to the temp in order
2544 to handle nml reads into arrays. */
2545 read_real (dtp, pdata, len);
2546 memcpy (dtp->u.p.value, pdata, dlen);
2550 /* Same as for REAL, copy back to temp. */
2551 read_complex (dtp, pdata, len, dlen);
2552 memcpy (dtp->u.p.value, pdata, dlen);
2556 obj_name_len = strlen (nl->var_name) + 1;
2557 obj_name = get_mem (obj_name_len+1);
2558 memcpy (obj_name, nl->var_name, obj_name_len-1);
2559 memcpy (obj_name + obj_name_len - 1, "%", 2);
2561 /* If reading a derived type, disable the expanded read warning
2562 since a single object can have multiple reads. */
2563 dtp->u.p.expanded_read = 0;
2565 /* Now loop over the components. Update the component pointer
2566 with the return value from nml_write_obj. This loop jumps
2567 past nested derived types by testing if the potential
2568 component name contains '%'. */
2570 for (cmp = nl->next;
2572 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2573 !strchr (cmp->var_name + obj_name_len, '%');
2577 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2578 pprev_nl, nml_err_msg, nml_err_msg_size,
2579 clow, chigh) == FAILURE)
2585 if (dtp->u.p.input_complete)
2596 snprintf (nml_err_msg, nml_err_msg_size,
2597 "Bad type for namelist object %s", nl->var_name);
2598 internal_error (&dtp->common, nml_err_msg);
2603 /* The standard permits array data to stop short of the number of
2604 elements specified in the loop specification. In this case, we
2605 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2606 nml_get_obj_data and an attempt is made to read object name. */
2609 if (dtp->u.p.nml_read_error)
2611 dtp->u.p.expanded_read = 0;
2615 if (dtp->u.p.saved_type == BT_UNKNOWN)
2617 dtp->u.p.expanded_read = 0;
2621 switch (dtp->u.p.saved_type)
2628 memcpy (pdata, dtp->u.p.value, dlen);
2632 if (dlen < dtp->u.p.saved_used)
2634 if (compile_options.bounds_check)
2636 snprintf (nml_err_msg, nml_err_msg_size,
2637 "Namelist object '%s' truncated on read.",
2639 generate_warning (&dtp->common, nml_err_msg);
2644 m = dtp->u.p.saved_used;
2645 pdata = (void*)( pdata + clow - 1 );
2646 memcpy (pdata, dtp->u.p.saved_string, m);
2648 memset ((void*)( pdata + m ), ' ', dlen - m);
2655 /* Warn if a non-standard expanded read occurs. A single read of a
2656 single object is acceptable. If a second read occurs, issue a warning
2657 and set the flag to zero to prevent further warnings. */
2658 if (dtp->u.p.expanded_read == 2)
2660 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2661 dtp->u.p.expanded_read = 0;
2664 /* If the expanded read warning flag is set, increment it,
2665 indicating that a single read has occurred. */
2666 if (dtp->u.p.expanded_read >= 1)
2667 dtp->u.p.expanded_read++;
2669 /* Break out of loop if scalar. */
2673 /* Now increment the index vector. */
2678 for (dim = 0; dim < nl->var_rank; dim++)
2680 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2682 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2684 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2686 nl->ls[dim].idx = nl->ls[dim].start;
2690 } while (!nml_carry);
2692 if (dtp->u.p.repeat_count > 1)
2694 snprintf (nml_err_msg, nml_err_msg_size,
2695 "Repeat count too large for namelist object %s", nl->var_name);
2705 /* Parses the object name, including array and substring qualifiers. It
2706 iterates over derived type components, touching those components and
2707 setting their loop specifications, if there is a qualifier. If the
2708 object is itself a derived type, its components and subcomponents are
2709 touched. nml_read_obj is called at the end and this reads the data in
2710 the manner specified by the object name. */
2713 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2714 char *nml_err_msg, size_t nml_err_msg_size)
2718 namelist_info * first_nl = NULL;
2719 namelist_info * root_nl = NULL;
2720 int dim, parsed_rank;
2721 int component_flag, qualifier_flag;
2722 index_type clow, chigh;
2723 int non_zero_rank_count;
2725 /* Look for end of input or object name. If '?' or '=?' are encountered
2726 in stdin, print the node names or the namelist to stdout. */
2728 eat_separator (dtp);
2729 if (dtp->u.p.input_complete)
2732 if (dtp->u.p.at_eol)
2733 finish_separator (dtp);
2734 if (dtp->u.p.input_complete)
2737 if ((c = next_char (dtp)) == EOF)
2742 if ((c = next_char (dtp)) == EOF)
2746 snprintf (nml_err_msg, nml_err_msg_size,
2747 "namelist read: misplaced = sign");
2750 nml_query (dtp, '=');
2754 nml_query (dtp, '?');
2759 nml_match_name (dtp, "end", 3);
2760 if (dtp->u.p.nml_read_error)
2762 snprintf (nml_err_msg, nml_err_msg_size,
2763 "namelist not terminated with / or &end");
2767 dtp->u.p.input_complete = 1;
2774 /* Untouch all nodes of the namelist and reset the flags that are set for
2775 derived type components. */
2777 nml_untouch_nodes (dtp);
2780 non_zero_rank_count = 0;
2782 /* Get the object name - should '!' and '\n' be permitted separators? */
2790 if (!is_separator (c))
2791 push_char (dtp, tolower(c));
2792 if ((c = next_char (dtp)) == EOF)
2794 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2796 unget_char (dtp, c);
2798 /* Check that the name is in the namelist and get pointer to object.
2799 Three error conditions exist: (i) An attempt is being made to
2800 identify a non-existent object, following a failed data read or
2801 (ii) The object name does not exist or (iii) Too many data items
2802 are present for an object. (iii) gives the same error message
2805 push_char (dtp, '\0');
2809 size_t var_len = strlen (root_nl->var_name);
2811 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2812 char ext_name[var_len + saved_len + 1];
2814 memcpy (ext_name, root_nl->var_name, var_len);
2815 if (dtp->u.p.saved_string)
2816 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2817 ext_name[var_len + saved_len] = '\0';
2818 nl = find_nml_node (dtp, ext_name);
2821 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2825 if (dtp->u.p.nml_read_error && *pprev_nl)
2826 snprintf (nml_err_msg, nml_err_msg_size,
2827 "Bad data for namelist object %s", (*pprev_nl)->var_name);
2830 snprintf (nml_err_msg, nml_err_msg_size,
2831 "Cannot match namelist object name %s",
2832 dtp->u.p.saved_string);
2837 /* Get the length, data length, base pointer and rank of the variable.
2838 Set the default loop specification first. */
2840 for (dim=0; dim < nl->var_rank; dim++)
2842 nl->ls[dim].step = 1;
2843 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2844 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2845 nl->ls[dim].idx = nl->ls[dim].start;
2848 /* Check to see if there is a qualifier: if so, parse it.*/
2850 if (c == '(' && nl->var_rank)
2853 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2854 nml_err_msg, nml_err_msg_size,
2855 &parsed_rank) == FAILURE)
2857 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2858 snprintf (nml_err_msg_end,
2859 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2860 " for namelist variable %s", nl->var_name);
2863 if (parsed_rank > 0)
2864 non_zero_rank_count++;
2868 if ((c = next_char (dtp)) == EOF)
2870 unget_char (dtp, c);
2872 else if (nl->var_rank > 0)
2873 non_zero_rank_count++;
2875 /* Now parse a derived type component. The root namelist_info address
2876 is backed up, as is the previous component level. The component flag
2877 is set and the iteration is made by jumping back to get_name. */
2881 if (nl->type != BT_DERIVED)
2883 snprintf (nml_err_msg, nml_err_msg_size,
2884 "Attempt to get derived component for %s", nl->var_name);
2888 if (*pprev_nl == NULL || !component_flag)
2894 if ((c = next_char (dtp)) == EOF)
2899 /* Parse a character qualifier, if present. chigh = 0 is a default
2900 that signals that the string length = string_length. */
2905 if (c == '(' && nl->type == BT_CHARACTER)
2907 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2908 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2910 if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg,
2911 nml_err_msg_size, &parsed_rank)
2914 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2915 snprintf (nml_err_msg_end,
2916 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2917 " for namelist variable %s", nl->var_name);
2921 clow = ind[0].start;
2924 if (ind[0].step != 1)
2926 snprintf (nml_err_msg, nml_err_msg_size,
2927 "Step not allowed in substring qualifier"
2928 " for namelist object %s", nl->var_name);
2932 if ((c = next_char (dtp)) == EOF)
2934 unget_char (dtp, c);
2937 /* Make sure no extraneous qualifiers are there. */
2941 snprintf (nml_err_msg, nml_err_msg_size,
2942 "Qualifier for a scalar or non-character namelist object %s",
2947 /* Make sure there is no more than one non-zero rank object. */
2948 if (non_zero_rank_count > 1)
2950 snprintf (nml_err_msg, nml_err_msg_size,
2951 "Multiple sub-objects with non-zero rank in namelist object %s",
2953 non_zero_rank_count = 0;
2957 /* According to the standard, an equal sign MUST follow an object name. The
2958 following is possibly lax - it allows comments, blank lines and so on to
2959 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2963 eat_separator (dtp);
2964 if (dtp->u.p.input_complete)
2967 if (dtp->u.p.at_eol)
2968 finish_separator (dtp);
2969 if (dtp->u.p.input_complete)
2972 if ((c = next_char (dtp)) == EOF)
2977 snprintf (nml_err_msg, nml_err_msg_size,
2978 "Equal sign must follow namelist object name %s",
2982 /* If a derived type, touch its components and restore the root
2983 namelist_info if we have parsed a qualified derived type
2986 if (nl->type == BT_DERIVED)
2987 nml_touch_nodes (nl);
2991 if (first_nl->var_rank == 0)
2993 if (component_flag && qualifier_flag)
3000 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
3001 clow, chigh) == FAILURE)
3011 /* Entry point for namelist input. Goes through input until namelist name
3012 is matched. Then cycles through nml_get_obj_data until the input is
3013 completed or there is an error. */
3016 namelist_read (st_parameter_dt *dtp)
3019 char nml_err_msg[200];
3021 /* Initialize the error string buffer just in case we get an unexpected fail
3022 somewhere and end up at nml_err_ret. */
3023 strcpy (nml_err_msg, "Internal namelist read error");
3025 /* Pointer to the previously read object, in case attempt is made to read
3026 new object name. Should this fail, error message can give previous
3028 namelist_info *prev_nl = NULL;
3030 dtp->u.p.namelist_mode = 1;
3031 dtp->u.p.input_complete = 0;
3032 dtp->u.p.expanded_read = 0;
3034 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3035 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3036 node names or namelist on stdout. */
3039 c = next_char (dtp);
3051 c = next_char (dtp);
3053 nml_query (dtp, '=');
3055 unget_char (dtp, c);
3059 nml_query (dtp, '?');
3068 /* Match the name of the namelist. */
3070 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3072 if (dtp->u.p.nml_read_error)
3075 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
3076 c = next_char (dtp);
3077 if (!is_separator(c) && c != '!')
3079 unget_char (dtp, c);
3083 unget_char (dtp, c);
3084 eat_separator (dtp);
3086 /* Ready to read namelist objects. If there is an error in input
3087 from stdin, output the error message and continue. */
3089 while (!dtp->u.p.input_complete)
3091 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
3094 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3096 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3099 /* Reset the previous namelist pointer if we know we are not going
3100 to be doing multiple reads within a single namelist object. */
3101 if (prev_nl && prev_nl->var_rank == 0)
3112 /* All namelist error calls return from here */
3115 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);