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;
625 snprintf (message, MSGLEN, "Bad repeat count in item %d of list input",
626 dtp->u.p.item_count);
627 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
632 /* To read a logical we have to look ahead in the input stream to make sure
633 there is not an equal sign indicating a variable name. To do this we use
634 line_buffer to point to a temporary buffer, pushing characters there for
635 possible later reading. */
638 l_push_char (st_parameter_dt *dtp, char c)
640 if (dtp->u.p.line_buffer == NULL)
641 dtp->u.p.line_buffer = xcalloc (SCRATCH_SIZE, 1);
643 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
647 /* Read a logical character on the input. */
650 read_logical (st_parameter_dt *dtp, int length)
652 char message[MSGLEN];
655 if (parse_repeat (dtp))
658 c = tolower (next_char (dtp));
659 l_push_char (dtp, c);
665 l_push_char (dtp, c);
667 if (!is_separator(c) && c != EOF)
675 l_push_char (dtp, c);
677 if (!is_separator(c) && c != EOF)
684 c = tolower (next_char (dtp));
703 return; /* Null value. */
706 /* Save the character in case it is the beginning
707 of the next object name. */
712 dtp->u.p.saved_type = BT_LOGICAL;
713 dtp->u.p.saved_length = length;
715 /* Eat trailing garbage. */
718 while (c != EOF && !is_separator (c));
722 set_integer ((int *) dtp->u.p.value, v, length);
729 for(i = 0; i < 63; i++)
734 /* All done if this is not a namelist read. */
735 if (!dtp->u.p.namelist_mode)
748 l_push_char (dtp, c);
751 dtp->u.p.nml_read_error = 1;
752 dtp->u.p.line_buffer_enabled = 1;
753 dtp->u.p.item_count = 0;
763 if (nml_bad_return (dtp, c))
774 snprintf (message, MSGLEN, "Bad logical value while reading item %d",
775 dtp->u.p.item_count);
776 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
781 dtp->u.p.saved_type = BT_LOGICAL;
782 dtp->u.p.saved_length = length;
783 set_integer ((int *) dtp->u.p.value, v, length);
789 /* Reading integers is tricky because we can actually be reading a
790 repeat count. We have to store the characters in a buffer because
791 we could be reading an integer that is larger than the default int
792 used for repeat counts. */
795 read_integer (st_parameter_dt *dtp, int length)
797 char message[MSGLEN];
807 /* Fall through... */
810 if ((c = next_char (dtp)) == EOF)
814 CASE_SEPARATORS: /* Single null. */
827 /* Take care of what may be a repeat count. */
839 push_char (dtp, '\0');
842 CASE_SEPARATORS: /* Not a repeat count. */
852 if (convert_integer (dtp, -1, 0))
855 /* Get the real integer. */
857 if ((c = next_char (dtp)) == EOF)
871 /* Fall through... */
903 if (nml_bad_return (dtp, c))
917 snprintf (message, MSGLEN, "Bad integer for item %d in list input",
918 dtp->u.p.item_count);
919 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
927 push_char (dtp, '\0');
928 if (convert_integer (dtp, length, negative))
935 dtp->u.p.saved_type = BT_INTEGER;
939 /* Read a character variable. */
942 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
944 char quote, message[MSGLEN];
947 quote = ' '; /* Space means no quote character. */
949 if ((c = next_char (dtp)) == EOF)
959 unget_char (dtp, c); /* NULL value. */
969 if (dtp->u.p.namelist_mode)
979 /* Deal with a possible repeat count. */
993 goto done; /* String was only digits! */
996 push_char (dtp, '\0');
1001 goto get_string; /* Not a repeat count after all. */
1006 if (convert_integer (dtp, -1, 0))
1009 /* Now get the real string. */
1011 if ((c = next_char (dtp)) == EOF)
1016 unget_char (dtp, c); /* Repeated NULL values. */
1017 eat_separator (dtp);
1033 if ((c = next_char (dtp)) == EOF)
1045 /* See if we have a doubled quote character or the end of
1048 if ((c = next_char (dtp)) == EOF)
1052 push_char (dtp, quote);
1056 unget_char (dtp, c);
1062 unget_char (dtp, c);
1066 if (c != '\n' && c != '\r')
1076 /* At this point, we have to have a separator, or else the string is
1079 c = next_char (dtp);
1081 if (is_separator (c) || c == '!' || c == EOF)
1083 unget_char (dtp, c);
1084 eat_separator (dtp);
1085 dtp->u.p.saved_type = BT_CHARACTER;
1090 snprintf (message, MSGLEN, "Invalid string input in item %d",
1091 dtp->u.p.item_count);
1092 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1104 /* Parse a component of a complex constant or a real number that we
1105 are sure is already there. This is a straight real number parser. */
1108 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1110 char message[MSGLEN];
1113 if ((c = next_char (dtp)) == EOF)
1116 if (c == '-' || c == '+')
1119 if ((c = next_char (dtp)) == EOF)
1123 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1126 if (!isdigit (c) && c != '.')
1128 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1136 seen_dp = (c == '.') ? 1 : 0;
1140 if ((c = next_char (dtp)) == EOF)
1142 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1164 push_char (dtp, 'e');
1169 push_char (dtp, 'e');
1171 if ((c = next_char (dtp)) == EOF)
1185 if ((c = next_char (dtp)) == EOF)
1187 if (c != '-' && c != '+')
1188 push_char (dtp, '+');
1192 c = next_char (dtp);
1203 if ((c = next_char (dtp)) == EOF)
1213 unget_char (dtp, c);
1222 unget_char (dtp, c);
1223 push_char (dtp, '\0');
1225 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1231 unget_char (dtp, c);
1232 push_char (dtp, '\0');
1234 m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length);
1240 /* Match INF and Infinity. */
1241 if ((c == 'i' || c == 'I')
1242 && ((c = next_char (dtp)) == 'n' || c == 'N')
1243 && ((c = next_char (dtp)) == 'f' || c == 'F'))
1245 c = next_char (dtp);
1246 if ((c != 'i' && c != 'I')
1247 || ((c == 'i' || c == 'I')
1248 && ((c = next_char (dtp)) == 'n' || c == 'N')
1249 && ((c = next_char (dtp)) == 'i' || c == 'I')
1250 && ((c = next_char (dtp)) == 't' || c == 'T')
1251 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1252 && (c = next_char (dtp))))
1254 if (is_separator (c) || (c == EOF))
1255 unget_char (dtp, c);
1256 push_char (dtp, 'i');
1257 push_char (dtp, 'n');
1258 push_char (dtp, 'f');
1262 else if (((c = next_char (dtp)) == 'a' || c == 'A')
1263 && ((c = next_char (dtp)) == 'n' || c == 'N')
1264 && (c = next_char (dtp)))
1266 if (is_separator (c) || (c == EOF))
1267 unget_char (dtp, c);
1268 push_char (dtp, 'n');
1269 push_char (dtp, 'a');
1270 push_char (dtp, 'n');
1272 /* Match "NAN(alphanum)". */
1275 for ( ; c != ')'; c = next_char (dtp))
1276 if (is_separator (c))
1279 c = next_char (dtp);
1280 if (is_separator (c) || (c == EOF))
1281 unget_char (dtp, c);
1288 if (nml_bad_return (dtp, c))
1302 snprintf (message, MSGLEN, "Bad floating point number for item %d",
1303 dtp->u.p.item_count);
1304 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1310 /* Reading a complex number is straightforward because we can tell
1311 what it is right away. */
1314 read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
1316 char message[MSGLEN];
1319 if (parse_repeat (dtp))
1322 c = next_char (dtp);
1330 unget_char (dtp, c);
1331 eat_separator (dtp);
1340 c = next_char (dtp);
1341 if (c == '\n' || c== '\r')
1344 unget_char (dtp, c);
1346 if (parse_real (dtp, dest, kind))
1351 c = next_char (dtp);
1352 if (c == '\n' || c== '\r')
1355 unget_char (dtp, c);
1358 != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
1363 c = next_char (dtp);
1364 if (c == '\n' || c== '\r')
1367 unget_char (dtp, c);
1369 if (parse_real (dtp, dest + size / 2, kind))
1374 c = next_char (dtp);
1375 if (c == '\n' || c== '\r')
1378 unget_char (dtp, c);
1380 if (next_char (dtp) != ')')
1383 c = next_char (dtp);
1384 if (!is_separator (c) && (c != EOF))
1387 unget_char (dtp, c);
1388 eat_separator (dtp);
1391 dtp->u.p.saved_type = BT_COMPLEX;
1396 if (nml_bad_return (dtp, c))
1410 snprintf (message, MSGLEN, "Bad complex value in item %d of list input",
1411 dtp->u.p.item_count);
1412 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1416 /* Parse a real number with a possible repeat count. */
1419 read_real (st_parameter_dt *dtp, void * dest, int length)
1421 char message[MSGLEN];
1428 c = next_char (dtp);
1429 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1447 unget_char (dtp, c); /* Single null. */
1448 eat_separator (dtp);
1461 /* Get the digit string that might be a repeat count. */
1465 c = next_char (dtp);
1466 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1492 push_char (dtp, 'e');
1494 c = next_char (dtp);
1498 push_char (dtp, '\0');
1503 if (c != '\n' && c != ',' && c != '\r' && c != ';')
1504 unget_char (dtp, c);
1513 if (convert_integer (dtp, -1, 0))
1516 /* Now get the number itself. */
1518 if ((c = next_char (dtp)) == EOF)
1520 if (is_separator (c))
1521 { /* Repeated null value. */
1522 unget_char (dtp, c);
1523 eat_separator (dtp);
1527 if (c != '-' && c != '+')
1528 push_char (dtp, '+');
1533 if ((c = next_char (dtp)) == EOF)
1537 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1540 if (!isdigit (c) && c != '.')
1542 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1561 c = next_char (dtp);
1562 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
1592 push_char (dtp, 'e');
1594 c = next_char (dtp);
1603 push_char (dtp, 'e');
1605 if ((c = next_char (dtp)) == EOF)
1607 if (c != '+' && c != '-')
1608 push_char (dtp, '+');
1612 c = next_char (dtp);
1622 c = next_char (dtp);
1640 unget_char (dtp, c);
1641 eat_separator (dtp);
1642 push_char (dtp, '\0');
1643 if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
1650 dtp->u.p.saved_type = BT_REAL;
1654 l_push_char (dtp, c);
1657 /* Match INF and Infinity. */
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 != 'f' && c != 'F')
1668 c = next_char (dtp);
1669 l_push_char (dtp, c);
1670 if (!is_separator (c) && (c != EOF))
1672 if (c != 'i' && c != 'I')
1674 c = next_char (dtp);
1675 l_push_char (dtp, c);
1676 if (c != 'n' && c != 'N')
1678 c = next_char (dtp);
1679 l_push_char (dtp, c);
1680 if (c != 'i' && c != 'I')
1682 c = next_char (dtp);
1683 l_push_char (dtp, c);
1684 if (c != 't' && c != 'T')
1686 c = next_char (dtp);
1687 l_push_char (dtp, c);
1688 if (c != 'y' && c != 'Y')
1690 c = next_char (dtp);
1691 l_push_char (dtp, c);
1697 c = next_char (dtp);
1698 l_push_char (dtp, c);
1699 if (c != 'a' && c != 'A')
1701 c = next_char (dtp);
1702 l_push_char (dtp, c);
1703 if (c != 'n' && c != 'N')
1705 c = next_char (dtp);
1706 l_push_char (dtp, c);
1708 /* Match NAN(alphanum). */
1711 for (c = next_char (dtp); c != ')'; c = next_char (dtp))
1712 if (is_separator (c))
1715 l_push_char (dtp, c);
1717 l_push_char (dtp, ')');
1718 c = next_char (dtp);
1719 l_push_char (dtp, c);
1723 if (!is_separator (c) && (c != EOF))
1726 if (dtp->u.p.namelist_mode)
1728 if (c == ' ' || c =='\n' || c == '\r')
1732 if ((c = next_char (dtp)) == EOF)
1735 while (c == ' ' || c =='\n' || c == '\r');
1737 l_push_char (dtp, c);
1746 push_char (dtp, 'i');
1747 push_char (dtp, 'n');
1748 push_char (dtp, 'f');
1752 push_char (dtp, 'n');
1753 push_char (dtp, 'a');
1754 push_char (dtp, 'n');
1758 unget_char (dtp, c);
1759 eat_separator (dtp);
1760 push_char (dtp, '\0');
1761 if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length))
1765 dtp->u.p.saved_type = BT_REAL;
1769 if (dtp->u.p.namelist_mode)
1771 dtp->u.p.nml_read_error = 1;
1772 dtp->u.p.line_buffer_enabled = 1;
1773 dtp->u.p.item_count = 0;
1779 if (nml_bad_return (dtp, c))
1793 snprintf (message, MSGLEN, "Bad real number in item %d of list input",
1794 dtp->u.p.item_count);
1795 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1799 /* Check the current type against the saved type to make sure they are
1800 compatible. Returns nonzero if incompatible. */
1803 check_type (st_parameter_dt *dtp, bt type, int len)
1805 char message[MSGLEN];
1807 if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
1810 snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d",
1811 type_name (dtp->u.p.saved_type), type_name (type),
1812 dtp->u.p.item_count);
1814 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1818 if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
1821 if (dtp->u.p.saved_length != len)
1824 snprintf (message, MSGLEN,
1825 "Read kind %d %s where kind %d is required for item %d",
1826 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1827 dtp->u.p.item_count);
1828 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1836 /* Top level data transfer subroutine for list reads. Because we have
1837 to deal with repeat counts, the data item is always saved after
1838 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1839 greater than one, we copy the data item multiple times. */
1842 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
1843 int kind, size_t size)
1849 dtp->u.p.namelist_mode = 0;
1851 if (dtp->u.p.first_item)
1853 dtp->u.p.first_item = 0;
1854 dtp->u.p.input_complete = 0;
1855 dtp->u.p.repeat_count = 1;
1856 dtp->u.p.at_eol = 0;
1858 if ((c = eat_spaces (dtp)) == EOF)
1863 if (is_separator (c))
1865 /* Found a null value. */
1866 eat_separator (dtp);
1867 dtp->u.p.repeat_count = 0;
1869 /* eat_separator sets this flag if the separator was a comma. */
1870 if (dtp->u.p.comma_flag)
1873 /* eat_separator sets this flag if the separator was a \n or \r. */
1874 if (dtp->u.p.at_eol)
1875 finish_separator (dtp);
1883 if (dtp->u.p.repeat_count > 0)
1885 if (check_type (dtp, type, kind))
1890 if (dtp->u.p.input_complete)
1893 if (dtp->u.p.at_eol)
1894 finish_separator (dtp);
1898 /* Trailing spaces prior to end of line. */
1899 if (dtp->u.p.at_eol)
1900 finish_separator (dtp);
1903 dtp->u.p.saved_type = BT_UNKNOWN;
1904 dtp->u.p.repeat_count = 1;
1910 read_integer (dtp, kind);
1913 read_logical (dtp, kind);
1916 read_character (dtp, kind);
1919 read_real (dtp, p, kind);
1920 /* Copy value back to temporary if needed. */
1921 if (dtp->u.p.repeat_count > 0)
1922 memcpy (dtp->u.p.value, p, size);
1925 read_complex (dtp, p, kind, size);
1926 /* Copy value back to temporary if needed. */
1927 if (dtp->u.p.repeat_count > 0)
1928 memcpy (dtp->u.p.value, p, size);
1931 internal_error (&dtp->common, "Bad type for list read");
1934 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN)
1935 dtp->u.p.saved_length = size;
1937 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1941 switch (dtp->u.p.saved_type)
1945 if (dtp->u.p.repeat_count > 0)
1946 memcpy (p, dtp->u.p.value, size);
1951 memcpy (p, dtp->u.p.value, size);
1955 if (dtp->u.p.saved_string)
1957 m = ((int) size < dtp->u.p.saved_used)
1958 ? (int) size : dtp->u.p.saved_used;
1960 memcpy (p, dtp->u.p.saved_string, m);
1963 q = (gfc_char4_t *) p;
1964 for (i = 0; i < m; i++)
1965 q[i] = (unsigned char) dtp->u.p.saved_string[i];
1969 /* Just delimiters encountered, nothing to copy but SPACE. */
1975 memset (((char *) p) + m, ' ', size - m);
1978 q = (gfc_char4_t *) p;
1979 for (i = m; i < (int) size; i++)
1980 q[i] = (unsigned char) ' ';
1989 internal_error (&dtp->common, "Bad type for list read");
1992 if (--dtp->u.p.repeat_count <= 0)
1996 if (err == LIBERROR_END)
2006 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
2007 size_t size, size_t nelems)
2011 size_t stride = type == BT_CHARACTER ?
2012 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
2017 /* Big loop over all the elements. */
2018 for (elem = 0; elem < nelems; elem++)
2020 dtp->u.p.item_count++;
2021 err = list_formatted_read_scalar (dtp, type, tmp + stride*elem,
2029 /* Finish a list read. */
2032 finish_list_read (st_parameter_dt *dtp)
2038 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2040 if (dtp->u.p.at_eol)
2042 dtp->u.p.at_eol = 0;
2046 err = eat_line (dtp);
2047 if (err == LIBERROR_END)
2056 void namelist_read (st_parameter_dt *dtp)
2058 static void nml_match_name (char *name, int len)
2059 static int nml_query (st_parameter_dt *dtp)
2060 static int nml_get_obj_data (st_parameter_dt *dtp,
2061 namelist_info **prev_nl, char *, size_t)
2063 static void nml_untouch_nodes (st_parameter_dt *dtp)
2064 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2066 static int nml_parse_qualifier(descriptor_dimension * ad,
2067 array_loop_spec * ls, int rank, char *)
2068 static void nml_touch_nodes (namelist_info * nl)
2069 static int nml_read_obj (namelist_info *nl, index_type offset,
2070 namelist_info **prev_nl, char *, size_t,
2071 index_type clow, index_type chigh)
2075 /* Inputs a rank-dimensional qualifier, which can contain
2076 singlets, doublets, triplets or ':' with the standard meanings. */
2079 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
2080 array_loop_spec *ls, int rank, bt nml_elem_type,
2081 char *parse_err_msg, size_t parse_err_msg_size,
2088 int is_array_section, is_char;
2092 is_array_section = 0;
2093 dtp->u.p.expanded_read = 0;
2095 /* See if this is a character substring qualifier we are looking for. */
2102 /* The next character in the stream should be the '('. */
2104 if ((c = next_char (dtp)) == EOF)
2107 /* Process the qualifier, by dimension and triplet. */
2109 for (dim=0; dim < rank; dim++ )
2111 for (indx=0; indx<3; indx++)
2117 /* Process a potential sign. */
2118 if ((c = next_char (dtp)) == EOF)
2130 unget_char (dtp, c);
2134 /* Process characters up to the next ':' , ',' or ')'. */
2137 c = next_char (dtp);
2144 is_array_section = 1;
2148 if ((c==',' && dim == rank -1)
2149 || (c==')' && dim < rank -1))
2152 snprintf (parse_err_msg, parse_err_msg_size,
2153 "Bad substring qualifier");
2155 snprintf (parse_err_msg, parse_err_msg_size,
2156 "Bad number of index fields");
2165 case ' ': case '\t': case '\r': case '\n':
2171 snprintf (parse_err_msg, parse_err_msg_size,
2172 "Bad character in substring qualifier");
2174 snprintf (parse_err_msg, parse_err_msg_size,
2175 "Bad character in index");
2179 if ((c == ',' || c == ')') && indx == 0
2180 && dtp->u.p.saved_string == 0)
2183 snprintf (parse_err_msg, parse_err_msg_size,
2184 "Null substring qualifier");
2186 snprintf (parse_err_msg, parse_err_msg_size,
2187 "Null index field");
2191 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2192 || (indx == 2 && dtp->u.p.saved_string == 0))
2195 snprintf (parse_err_msg, parse_err_msg_size,
2196 "Bad substring qualifier");
2198 snprintf (parse_err_msg, parse_err_msg_size,
2199 "Bad index triplet");
2203 if (is_char && !is_array_section)
2205 snprintf (parse_err_msg, parse_err_msg_size,
2206 "Missing colon in substring qualifier");
2210 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2212 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2213 || (indx==1 && dtp->u.p.saved_string == 0))
2219 /* Now read the index. */
2220 if (convert_integer (dtp, sizeof(index_type), neg))
2223 snprintf (parse_err_msg, parse_err_msg_size,
2224 "Bad integer substring qualifier");
2226 snprintf (parse_err_msg, parse_err_msg_size,
2227 "Bad integer in index");
2233 /* Feed the index values to the triplet arrays. */
2237 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2239 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type));
2241 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type));
2244 /* Singlet or doublet indices. */
2245 if (c==',' || c==')')
2249 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
2251 /* If -std=f95/2003 or an array section is specified,
2252 do not allow excess data to be processed. */
2253 if (is_array_section == 1
2254 || !(compile_options.allow_std & GFC_STD_GNU)
2255 || nml_elem_type == BT_DERIVED)
2256 ls[dim].end = ls[dim].start;
2258 dtp->u.p.expanded_read = 1;
2261 /* Check for non-zero rank. */
2262 if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2269 if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
2272 dtp->u.p.expanded_read = 0;
2273 for (i = 0; i < dim; i++)
2274 ls[i].end = ls[i].start;
2277 /* Check the values of the triplet indices. */
2278 if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim]))
2279 || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim]))
2280 || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim]))
2281 || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim])))
2284 snprintf (parse_err_msg, parse_err_msg_size,
2285 "Substring out of range");
2287 snprintf (parse_err_msg, parse_err_msg_size,
2288 "Index %d out of range", dim + 1);
2292 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2293 || (ls[dim].step == 0))
2295 snprintf (parse_err_msg, parse_err_msg_size,
2296 "Bad range in index %d", dim + 1);
2300 /* Initialise the loop index counter. */
2301 ls[dim].idx = ls[dim].start;
2308 /* The EOF error message is issued by hit_eof. Return true so that the
2309 caller does not use parse_err_msg and parse_err_msg_size to generate
2310 an unrelated error message. */
2314 dtp->u.p.input_complete = 1;
2320 static namelist_info *
2321 find_nml_node (st_parameter_dt *dtp, char * var_name)
2323 namelist_info * t = dtp->u.p.ionml;
2326 if (strcmp (var_name, t->var_name) == 0)
2336 /* Visits all the components of a derived type that have
2337 not explicitly been identified in the namelist input.
2338 touched is set and the loop specification initialised
2339 to default values */
2342 nml_touch_nodes (namelist_info * nl)
2344 index_type len = strlen (nl->var_name) + 1;
2346 char * ext_name = (char*)xmalloc (len + 1);
2347 memcpy (ext_name, nl->var_name, len-1);
2348 memcpy (ext_name + len - 1, "%", 2);
2349 for (nl = nl->next; nl; nl = nl->next)
2351 if (strncmp (nl->var_name, ext_name, len) == 0)
2354 for (dim=0; dim < nl->var_rank; dim++)
2356 nl->ls[dim].step = 1;
2357 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2358 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2359 nl->ls[dim].idx = nl->ls[dim].start;
2369 /* Resets touched for the entire list of nml_nodes, ready for a
2373 nml_untouch_nodes (st_parameter_dt *dtp)
2376 for (t = dtp->u.p.ionml; t; t = t->next)
2381 /* Attempts to input name to namelist name. Returns
2382 dtp->u.p.nml_read_error = 1 on no match. */
2385 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2390 dtp->u.p.nml_read_error = 0;
2391 for (i = 0; i < len; i++)
2393 c = next_char (dtp);
2394 if (c == EOF || (tolower (c) != tolower (name[i])))
2396 dtp->u.p.nml_read_error = 1;
2402 /* If the namelist read is from stdin, output the current state of the
2403 namelist to stdout. This is used to implement the non-standard query
2404 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2405 the names alone are printed. */
2408 nml_query (st_parameter_dt *dtp, char c)
2410 gfc_unit * temp_unit;
2415 static const index_type endlen = 2;
2416 static const char endl[] = "\r\n";
2417 static const char nmlend[] = "&end\r\n";
2419 static const index_type endlen = 1;
2420 static const char endl[] = "\n";
2421 static const char nmlend[] = "&end\n";
2424 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2427 /* Store the current unit and transfer to stdout. */
2429 temp_unit = dtp->u.p.current_unit;
2430 dtp->u.p.current_unit = find_unit (options.stdout_unit);
2432 if (dtp->u.p.current_unit)
2434 dtp->u.p.mode = WRITING;
2435 next_record (dtp, 0);
2437 /* Write the namelist in its entirety. */
2440 namelist_write (dtp);
2442 /* Or write the list of names. */
2446 /* "&namelist_name\n" */
2448 len = dtp->namelist_name_len;
2449 p = write_block (dtp, len - 1 + endlen);
2453 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2454 memcpy ((char*)(p + len + 1), &endl, endlen);
2455 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2459 len = strlen (nl->var_name);
2460 p = write_block (dtp, len + endlen);
2464 memcpy ((char*)(p + 1), nl->var_name, len);
2465 memcpy ((char*)(p + len + 1), &endl, endlen);
2470 p = write_block (dtp, endlen + 4);
2473 memcpy (p, &nmlend, endlen + 4);
2476 /* Flush the stream to force immediate output. */
2478 fbuf_flush (dtp->u.p.current_unit, WRITING);
2479 sflush (dtp->u.p.current_unit->s);
2480 unlock_unit (dtp->u.p.current_unit);
2485 /* Restore the current unit. */
2487 dtp->u.p.current_unit = temp_unit;
2488 dtp->u.p.mode = READING;
2492 /* Reads and stores the input for the namelist object nl. For an array,
2493 the function loops over the ranges defined by the loop specification.
2494 This default to all the data or to the specification from a qualifier.
2495 nml_read_obj recursively calls itself to read derived types. It visits
2496 all its own components but only reads data for those that were touched
2497 when the name was parsed. If a read error is encountered, an attempt is
2498 made to return to read a new object name because the standard allows too
2499 little data to be available. On the other hand, too much data is an
2503 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2504 namelist_info **pprev_nl, char *nml_err_msg,
2505 size_t nml_err_msg_size, index_type clow, index_type chigh)
2507 namelist_info * cmp;
2514 size_t obj_name_len;
2517 /* This object not touched in name parsing. */
2522 dtp->u.p.repeat_count = 0;
2534 dlen = size_from_real_kind (len);
2538 dlen = size_from_complex_kind (len);
2542 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2551 /* Update the pointer to the data, using the current index vector */
2553 pdata = (void*)(nl->mem_pos + offset);
2554 for (dim = 0; dim < nl->var_rank; dim++)
2555 pdata = (void*)(pdata + (nl->ls[dim].idx
2556 - GFC_DESCRIPTOR_LBOUND(nl,dim))
2557 * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
2559 /* Reset the error flag and try to read next value, if
2560 dtp->u.p.repeat_count=0 */
2562 dtp->u.p.nml_read_error = 0;
2564 if (--dtp->u.p.repeat_count <= 0)
2566 if (dtp->u.p.input_complete)
2568 if (dtp->u.p.at_eol)
2569 finish_separator (dtp);
2570 if (dtp->u.p.input_complete)
2573 dtp->u.p.saved_type = BT_UNKNOWN;
2579 read_integer (dtp, len);
2583 read_logical (dtp, len);
2587 read_character (dtp, len);
2591 /* Need to copy data back from the real location to the temp in order
2592 to handle nml reads into arrays. */
2593 read_real (dtp, pdata, len);
2594 memcpy (dtp->u.p.value, pdata, dlen);
2598 /* Same as for REAL, copy back to temp. */
2599 read_complex (dtp, pdata, len, dlen);
2600 memcpy (dtp->u.p.value, pdata, dlen);
2604 obj_name_len = strlen (nl->var_name) + 1;
2605 obj_name = xmalloc (obj_name_len+1);
2606 memcpy (obj_name, nl->var_name, obj_name_len-1);
2607 memcpy (obj_name + obj_name_len - 1, "%", 2);
2609 /* If reading a derived type, disable the expanded read warning
2610 since a single object can have multiple reads. */
2611 dtp->u.p.expanded_read = 0;
2613 /* Now loop over the components. */
2615 for (cmp = nl->next;
2617 !strncmp (cmp->var_name, obj_name, obj_name_len);
2620 /* Jump over nested derived type by testing if the potential
2621 component name contains '%'. */
2622 if (strchr (cmp->var_name + obj_name_len, '%'))
2625 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2626 pprev_nl, nml_err_msg, nml_err_msg_size,
2627 clow, chigh) == FAILURE)
2633 if (dtp->u.p.input_complete)
2644 snprintf (nml_err_msg, nml_err_msg_size,
2645 "Bad type for namelist object %s", nl->var_name);
2646 internal_error (&dtp->common, nml_err_msg);
2651 /* The standard permits array data to stop short of the number of
2652 elements specified in the loop specification. In this case, we
2653 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2654 nml_get_obj_data and an attempt is made to read object name. */
2657 if (dtp->u.p.nml_read_error)
2659 dtp->u.p.expanded_read = 0;
2663 if (dtp->u.p.saved_type == BT_UNKNOWN)
2665 dtp->u.p.expanded_read = 0;
2669 switch (dtp->u.p.saved_type)
2676 memcpy (pdata, dtp->u.p.value, dlen);
2680 if (dlen < dtp->u.p.saved_used)
2682 if (compile_options.bounds_check)
2684 snprintf (nml_err_msg, nml_err_msg_size,
2685 "Namelist object '%s' truncated on read.",
2687 generate_warning (&dtp->common, nml_err_msg);
2692 m = dtp->u.p.saved_used;
2693 pdata = (void*)( pdata + clow - 1 );
2694 memcpy (pdata, dtp->u.p.saved_string, m);
2696 memset ((void*)( pdata + m ), ' ', dlen - m);
2703 /* Warn if a non-standard expanded read occurs. A single read of a
2704 single object is acceptable. If a second read occurs, issue a warning
2705 and set the flag to zero to prevent further warnings. */
2706 if (dtp->u.p.expanded_read == 2)
2708 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2709 dtp->u.p.expanded_read = 0;
2712 /* If the expanded read warning flag is set, increment it,
2713 indicating that a single read has occurred. */
2714 if (dtp->u.p.expanded_read >= 1)
2715 dtp->u.p.expanded_read++;
2717 /* Break out of loop if scalar. */
2721 /* Now increment the index vector. */
2726 for (dim = 0; dim < nl->var_rank; dim++)
2728 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2730 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2732 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2734 nl->ls[dim].idx = nl->ls[dim].start;
2738 } while (!nml_carry);
2740 if (dtp->u.p.repeat_count > 1)
2742 snprintf (nml_err_msg, nml_err_msg_size,
2743 "Repeat count too large for namelist object %s", nl->var_name);
2753 /* Parses the object name, including array and substring qualifiers. It
2754 iterates over derived type components, touching those components and
2755 setting their loop specifications, if there is a qualifier. If the
2756 object is itself a derived type, its components and subcomponents are
2757 touched. nml_read_obj is called at the end and this reads the data in
2758 the manner specified by the object name. */
2761 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2762 char *nml_err_msg, size_t nml_err_msg_size)
2766 namelist_info * first_nl = NULL;
2767 namelist_info * root_nl = NULL;
2768 int dim, parsed_rank;
2769 int component_flag, qualifier_flag;
2770 index_type clow, chigh;
2771 int non_zero_rank_count;
2773 /* Look for end of input or object name. If '?' or '=?' are encountered
2774 in stdin, print the node names or the namelist to stdout. */
2776 eat_separator (dtp);
2777 if (dtp->u.p.input_complete)
2780 if (dtp->u.p.at_eol)
2781 finish_separator (dtp);
2782 if (dtp->u.p.input_complete)
2785 if ((c = next_char (dtp)) == EOF)
2790 if ((c = next_char (dtp)) == EOF)
2794 snprintf (nml_err_msg, nml_err_msg_size,
2795 "namelist read: misplaced = sign");
2798 nml_query (dtp, '=');
2802 nml_query (dtp, '?');
2807 nml_match_name (dtp, "end", 3);
2808 if (dtp->u.p.nml_read_error)
2810 snprintf (nml_err_msg, nml_err_msg_size,
2811 "namelist not terminated with / or &end");
2815 dtp->u.p.input_complete = 1;
2822 /* Untouch all nodes of the namelist and reset the flags that are set for
2823 derived type components. */
2825 nml_untouch_nodes (dtp);
2828 non_zero_rank_count = 0;
2830 /* Get the object name - should '!' and '\n' be permitted separators? */
2838 if (!is_separator (c))
2839 push_char (dtp, tolower(c));
2840 if ((c = next_char (dtp)) == EOF)
2843 while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2845 unget_char (dtp, c);
2847 /* Check that the name is in the namelist and get pointer to object.
2848 Three error conditions exist: (i) An attempt is being made to
2849 identify a non-existent object, following a failed data read or
2850 (ii) The object name does not exist or (iii) Too many data items
2851 are present for an object. (iii) gives the same error message
2854 push_char (dtp, '\0');
2858 size_t var_len = strlen (root_nl->var_name);
2860 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2861 char ext_name[var_len + saved_len + 1];
2863 memcpy (ext_name, root_nl->var_name, var_len);
2864 if (dtp->u.p.saved_string)
2865 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2866 ext_name[var_len + saved_len] = '\0';
2867 nl = find_nml_node (dtp, ext_name);
2870 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2874 if (dtp->u.p.nml_read_error && *pprev_nl)
2875 snprintf (nml_err_msg, nml_err_msg_size,
2876 "Bad data for namelist object %s", (*pprev_nl)->var_name);
2879 snprintf (nml_err_msg, nml_err_msg_size,
2880 "Cannot match namelist object name %s",
2881 dtp->u.p.saved_string);
2886 /* Get the length, data length, base pointer and rank of the variable.
2887 Set the default loop specification first. */
2889 for (dim=0; dim < nl->var_rank; dim++)
2891 nl->ls[dim].step = 1;
2892 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
2893 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
2894 nl->ls[dim].idx = nl->ls[dim].start;
2897 /* Check to see if there is a qualifier: if so, parse it.*/
2899 if (c == '(' && nl->var_rank)
2902 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2903 nl->type, nml_err_msg, nml_err_msg_size,
2904 &parsed_rank) == FAILURE)
2906 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2907 snprintf (nml_err_msg_end,
2908 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2909 " for namelist variable %s", nl->var_name);
2912 if (parsed_rank > 0)
2913 non_zero_rank_count++;
2917 if ((c = next_char (dtp)) == EOF)
2919 unget_char (dtp, c);
2921 else if (nl->var_rank > 0)
2922 non_zero_rank_count++;
2924 /* Now parse a derived type component. The root namelist_info address
2925 is backed up, as is the previous component level. The component flag
2926 is set and the iteration is made by jumping back to get_name. */
2930 if (nl->type != BT_DERIVED)
2932 snprintf (nml_err_msg, nml_err_msg_size,
2933 "Attempt to get derived component for %s", nl->var_name);
2937 /* Don't move first_nl further in the list if a qualifier was found. */
2938 if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag)
2944 if ((c = next_char (dtp)) == EOF)
2949 /* Parse a character qualifier, if present. chigh = 0 is a default
2950 that signals that the string length = string_length. */
2955 if (c == '(' && nl->type == BT_CHARACTER)
2957 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2958 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2960 if (nml_parse_qualifier (dtp, chd, ind, -1, nl->type,
2961 nml_err_msg, nml_err_msg_size, &parsed_rank)
2964 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2965 snprintf (nml_err_msg_end,
2966 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2967 " for namelist variable %s", nl->var_name);
2971 clow = ind[0].start;
2974 if (ind[0].step != 1)
2976 snprintf (nml_err_msg, nml_err_msg_size,
2977 "Step not allowed in substring qualifier"
2978 " for namelist object %s", nl->var_name);
2982 if ((c = next_char (dtp)) == EOF)
2984 unget_char (dtp, c);
2987 /* Make sure no extraneous qualifiers are there. */
2991 snprintf (nml_err_msg, nml_err_msg_size,
2992 "Qualifier for a scalar or non-character namelist object %s",
2997 /* Make sure there is no more than one non-zero rank object. */
2998 if (non_zero_rank_count > 1)
3000 snprintf (nml_err_msg, nml_err_msg_size,
3001 "Multiple sub-objects with non-zero rank in namelist object %s",
3003 non_zero_rank_count = 0;
3007 /* According to the standard, an equal sign MUST follow an object name. The
3008 following is possibly lax - it allows comments, blank lines and so on to
3009 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
3013 eat_separator (dtp);
3014 if (dtp->u.p.input_complete)
3017 if (dtp->u.p.at_eol)
3018 finish_separator (dtp);
3019 if (dtp->u.p.input_complete)
3022 if ((c = next_char (dtp)) == EOF)
3027 snprintf (nml_err_msg, nml_err_msg_size,
3028 "Equal sign must follow namelist object name %s",
3032 /* If a derived type, touch its components and restore the root
3033 namelist_info if we have parsed a qualified derived type
3036 if (nl->type == BT_DERIVED)
3037 nml_touch_nodes (nl);
3041 if (first_nl->var_rank == 0)
3043 if (component_flag && qualifier_flag)
3050 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
3051 clow, chigh) == FAILURE)
3058 /* The EOF error message is issued by hit_eof. Return true so that the
3059 caller does not use nml_err_msg and nml_err_msg_size to generate
3060 an unrelated error message. */
3063 dtp->u.p.input_complete = 1;
3064 unget_char (dtp, c);
3072 /* Entry point for namelist input. Goes through input until namelist name
3073 is matched. Then cycles through nml_get_obj_data until the input is
3074 completed or there is an error. */
3077 namelist_read (st_parameter_dt *dtp)
3080 char nml_err_msg[200];
3082 /* Initialize the error string buffer just in case we get an unexpected fail
3083 somewhere and end up at nml_err_ret. */
3084 strcpy (nml_err_msg, "Internal namelist read error");
3086 /* Pointer to the previously read object, in case attempt is made to read
3087 new object name. Should this fail, error message can give previous
3089 namelist_info *prev_nl = NULL;
3091 dtp->u.p.namelist_mode = 1;
3092 dtp->u.p.input_complete = 0;
3093 dtp->u.p.expanded_read = 0;
3095 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3096 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3097 node names or namelist on stdout. */
3100 c = next_char (dtp);
3112 c = next_char (dtp);
3114 nml_query (dtp, '=');
3116 unget_char (dtp, c);
3120 nml_query (dtp, '?');
3130 /* Match the name of the namelist. */
3132 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
3134 if (dtp->u.p.nml_read_error)
3137 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3138 c = next_char (dtp);
3139 if (!is_separator(c) && c != '!')
3141 unget_char (dtp, c);
3145 unget_char (dtp, c);
3146 eat_separator (dtp);
3148 /* Ready to read namelist objects. If there is an error in input
3149 from stdin, output the error message and continue. */
3151 while (!dtp->u.p.input_complete)
3153 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
3156 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
3158 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
3161 /* Reset the previous namelist pointer if we know we are not going
3162 to be doing multiple reads within a single namelist object. */
3163 if (prev_nl && prev_nl->var_rank == 0)
3174 /* All namelist error calls return from here */
3177 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);