1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
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 95 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 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
39 /* List directed input. Several parsing subroutines are practically
40 reimplemented from formatted input, the reason being that there are
41 all kinds of small differences between formatted and list directed
45 /* Subroutines for reading characters from the input. Because a
46 repeat count is ambiguous with an integer, we have to read the
47 whole digit string before seeing if there is a '*' which signals
48 the repeat count. Since we can have a lot of potential leading
49 zeros, we have to be able to back up by arbitrary amount. Because
50 the input might not be seekable, we have to buffer the data
53 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
54 case '5': case '6': case '7': case '8': case '9'
56 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
59 /* This macro assumes that we're operating on a variable. */
61 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
62 || c == '\t' || c == '\r' || c == ';')
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
70 # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
73 /* Save a character to a string buffer, enlarging it as necessary. */
76 push_char (st_parameter_dt *dtp, char c)
80 if (dtp->u.p.saved_string == NULL)
82 if (dtp->u.p.scratch == NULL)
83 dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
84 dtp->u.p.saved_string = dtp->u.p.scratch;
85 memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
86 dtp->u.p.saved_length = SCRATCH_SIZE;
87 dtp->u.p.saved_used = 0;
90 if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
92 dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
93 new = get_mem (2 * dtp->u.p.saved_length);
95 memset (new, 0, 2 * dtp->u.p.saved_length);
97 memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
98 if (dtp->u.p.saved_string != dtp->u.p.scratch)
99 free_mem (dtp->u.p.saved_string);
101 dtp->u.p.saved_string = new;
104 dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
108 /* Free the input buffer if necessary. */
111 free_saved (st_parameter_dt *dtp)
113 if (dtp->u.p.saved_string == NULL)
116 if (dtp->u.p.saved_string != dtp->u.p.scratch)
117 free_mem (dtp->u.p.saved_string);
119 dtp->u.p.saved_string = NULL;
120 dtp->u.p.saved_used = 0;
124 /* Free the line buffer if necessary. */
127 free_line (st_parameter_dt *dtp)
129 dtp->u.p.item_count = 0;
130 dtp->u.p.line_buffer_enabled = 0;
132 if (dtp->u.p.line_buffer == NULL)
135 free_mem (dtp->u.p.line_buffer);
136 dtp->u.p.line_buffer = NULL;
141 next_char (st_parameter_dt *dtp)
147 if (dtp->u.p.last_char != '\0')
150 c = dtp->u.p.last_char;
151 dtp->u.p.last_char = '\0';
155 /* Read from line_buffer if enabled. */
157 if (dtp->u.p.line_buffer_enabled)
161 c = dtp->u.p.line_buffer[dtp->u.p.item_count];
162 if (c != '\0' && dtp->u.p.item_count < 64)
164 dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
165 dtp->u.p.item_count++;
169 dtp->u.p.item_count = 0;
170 dtp->u.p.line_buffer_enabled = 0;
173 /* Handle the end-of-record and end-of-file conditions for
174 internal array unit. */
175 if (is_array_io (dtp))
178 longjmp (*dtp->u.p.eof_jump, 1);
180 /* Check for "end-of-record" condition. */
181 if (dtp->u.p.current_unit->bytes_left == 0)
186 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
189 /* Check for "end-of-file" condition. */
196 record *= dtp->u.p.current_unit->recl;
197 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
198 longjmp (*dtp->u.p.eof_jump, 1);
200 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
205 /* Get the next character and handle end-of-record conditions. */
209 p = salloc_r (dtp->u.p.current_unit->s, &length);
211 if (is_stream_io (dtp))
212 dtp->u.p.current_unit->strm_pos++;
214 if (is_internal_unit (dtp))
216 if (is_array_io (dtp))
218 /* End of record is handled in the next pass through, above. The
219 check for NULL here is cautionary. */
222 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
226 dtp->u.p.current_unit->bytes_left--;
232 longjmp (*dtp->u.p.eof_jump, 1);
243 generate_error (&dtp->common, LIBERROR_OS, NULL);
248 if (dtp->u.p.advance_status == ADVANCE_NO)
250 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
251 longjmp (*dtp->u.p.eof_jump, 1);
252 dtp->u.p.current_unit->endfile = AT_ENDFILE;
256 longjmp (*dtp->u.p.eof_jump, 1);
262 dtp->u.p.at_eol = (c == '\n' || c == '\r');
267 /* Push a character back onto the input. */
270 unget_char (st_parameter_dt *dtp, char c)
272 dtp->u.p.last_char = c;
276 /* Skip over spaces in the input. Returns the nonspace character that
277 terminated the eating and also places it back on the input. */
280 eat_spaces (st_parameter_dt *dtp)
288 while (c == ' ' || c == '\t');
295 /* This function reads characters through to the end of the current line and
296 just ignores them. */
299 eat_line (st_parameter_dt *dtp)
302 if (!is_internal_unit (dtp))
309 /* Skip over a separator. Technically, we don't always eat the whole
310 separator. This is because if we've processed the last input item,
311 then a separator is unnecessary. Plus the fact that operating
312 systems usually deliver console input on a line basis.
314 The upshot is that if we see a newline as part of reading a
315 separator, we stop reading. If there are more input items, we
316 continue reading the separator with finish_separator() which takes
317 care of the fact that we may or may not have seen a comma as part
321 eat_separator (st_parameter_dt *dtp)
326 dtp->u.p.comma_flag = 0;
332 if (dtp->u.p.decimal_status == DECIMAL_COMMA)
339 dtp->u.p.comma_flag = 1;
344 dtp->u.p.input_complete = 1;
358 if (dtp->u.p.namelist_mode)
374 while (c == '\n' || c == '\r' || c == ' ');
380 if (dtp->u.p.namelist_mode)
381 { /* Eat a namelist comment. */
389 /* Fall Through... */
398 /* Finish processing a separator that was interrupted by a newline.
399 If we're here, then another data item is present, so we finish what
400 we started on the previous line. */
403 finish_separator (st_parameter_dt *dtp)
414 if (dtp->u.p.comma_flag)
418 c = eat_spaces (dtp);
419 if (c == '\n' || c == '\r')
426 dtp->u.p.input_complete = 1;
427 if (!dtp->u.p.namelist_mode)
436 if (dtp->u.p.namelist_mode)
452 /* This function is needed to catch bad conversions so that namelist can
453 attempt to see if dtp->u.p.saved_string contains a new object name rather
457 nml_bad_return (st_parameter_dt *dtp, char c)
459 if (dtp->u.p.namelist_mode)
461 dtp->u.p.nml_read_error = 1;
468 /* Convert an unsigned string to an integer. The length value is -1
469 if we are working on a repeat count. Returns nonzero if we have a
470 range problem. As a side effect, frees the dtp->u.p.saved_string. */
473 convert_integer (st_parameter_dt *dtp, int length, int negative)
475 char c, *buffer, message[100];
477 GFC_INTEGER_LARGEST v, max, max10;
479 buffer = dtp->u.p.saved_string;
482 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
507 set_integer (dtp->u.p.value, v, length);
511 dtp->u.p.repeat_count = v;
513 if (dtp->u.p.repeat_count == 0)
515 sprintf (message, "Zero repeat count in item %d of list input",
516 dtp->u.p.item_count);
518 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
528 sprintf (message, "Repeat count overflow in item %d of list input",
529 dtp->u.p.item_count);
531 sprintf (message, "Integer overflow while reading item %d",
532 dtp->u.p.item_count);
535 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
541 /* Parse a repeat count for logical and complex values which cannot
542 begin with a digit. Returns nonzero if we are done, zero if we
543 should continue on. */
546 parse_repeat (st_parameter_dt *dtp)
548 char c, message[100];
574 repeat = 10 * repeat + c - '0';
576 if (repeat > MAX_REPEAT)
579 "Repeat count overflow in item %d of list input",
580 dtp->u.p.item_count);
582 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
592 "Zero repeat count in item %d of list input",
593 dtp->u.p.item_count);
595 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
607 dtp->u.p.repeat_count = repeat;
614 sprintf (message, "Bad repeat count in item %d of list input",
615 dtp->u.p.item_count);
616 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
621 /* To read a logical we have to look ahead in the input stream to make sure
622 there is not an equal sign indicating a variable name. To do this we use
623 line_buffer to point to a temporary buffer, pushing characters there for
624 possible later reading. */
627 l_push_char (st_parameter_dt *dtp, char c)
629 if (dtp->u.p.line_buffer == NULL)
631 dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
632 memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
635 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
639 /* Read a logical character on the input. */
642 read_logical (st_parameter_dt *dtp, int length)
644 char c, message[100];
647 if (parse_repeat (dtp))
650 c = tolower (next_char (dtp));
651 l_push_char (dtp, c);
657 l_push_char (dtp, c);
659 if (!is_separator(c))
667 l_push_char (dtp, c);
669 if (!is_separator(c))
676 c = tolower (next_char (dtp));
694 return; /* Null value. */
697 /* Save the character in case it is the beginning
698 of the next object name. */
703 dtp->u.p.saved_type = BT_LOGICAL;
704 dtp->u.p.saved_length = length;
706 /* Eat trailing garbage. */
711 while (!is_separator (c));
715 set_integer ((int *) dtp->u.p.value, v, length);
722 for(i = 0; i < 63; i++)
727 /* All done if this is not a namelist read. */
728 if (!dtp->u.p.namelist_mode)
741 l_push_char (dtp, c);
744 dtp->u.p.nml_read_error = 1;
745 dtp->u.p.line_buffer_enabled = 1;
746 dtp->u.p.item_count = 0;
756 if (nml_bad_return (dtp, c))
761 sprintf (message, "Bad logical value while reading item %d",
762 dtp->u.p.item_count);
763 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
768 dtp->u.p.saved_type = BT_LOGICAL;
769 dtp->u.p.saved_length = length;
770 set_integer ((int *) dtp->u.p.value, v, length);
776 /* Reading integers is tricky because we can actually be reading a
777 repeat count. We have to store the characters in a buffer because
778 we could be reading an integer that is larger than the default int
779 used for repeat counts. */
782 read_integer (st_parameter_dt *dtp, int length)
784 char c, message[100];
794 /* Fall through... */
800 CASE_SEPARATORS: /* Single null. */
813 /* Take care of what may be a repeat count. */
825 push_char (dtp, '\0');
828 CASE_SEPARATORS: /* Not a repeat count. */
837 if (convert_integer (dtp, -1, 0))
840 /* Get the real integer. */
855 /* Fall through... */
886 if (nml_bad_return (dtp, c))
891 sprintf (message, "Bad integer for item %d in list input",
892 dtp->u.p.item_count);
893 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
901 push_char (dtp, '\0');
902 if (convert_integer (dtp, length, negative))
909 dtp->u.p.saved_type = BT_INTEGER;
913 /* Read a character variable. */
916 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
918 char c, quote, message[100];
920 quote = ' '; /* Space means no quote character. */
930 unget_char (dtp, c); /* NULL value. */
940 if (dtp->u.p.namelist_mode)
942 if (dtp->u.p.delim_status == DELIM_APOSTROPHE
943 || dtp->u.p.delim_status == DELIM_QUOTE
944 || c == '&' || c == '$' || c == '/')
950 /* Check to see if we are seeing a namelist object name by using the
951 line buffer and looking ahead for an '=' or '('. */
952 l_push_char (dtp, c);
955 for(i = 0; i < 63; i++)
965 l_push_char (dtp, c);
966 dtp->u.p.item_count = 0;
967 dtp->u.p.line_buffer_enabled = 1;
972 l_push_char (dtp, c);
974 if (c == '=' || c == '(')
976 dtp->u.p.item_count = 0;
977 dtp->u.p.nml_read_error = 1;
978 dtp->u.p.line_buffer_enabled = 1;
983 /* The string is too long to be a valid object name so assume that it
984 is a string to be read in as a value. */
985 dtp->u.p.item_count = 0;
986 dtp->u.p.line_buffer_enabled = 1;
994 /* Deal with a possible repeat count. */
1006 unget_char (dtp, c);
1007 goto done; /* String was only digits! */
1010 push_char (dtp, '\0');
1015 goto get_string; /* Not a repeat count after all. */
1020 if (convert_integer (dtp, -1, 0))
1023 /* Now get the real string. */
1025 c = next_char (dtp);
1029 unget_char (dtp, c); /* Repeated NULL values. */
1030 eat_separator (dtp);
1046 c = next_char (dtp);
1057 /* See if we have a doubled quote character or the end of
1060 c = next_char (dtp);
1063 push_char (dtp, quote);
1067 unget_char (dtp, c);
1073 unget_char (dtp, c);
1077 if (c != '\n' && c != '\r')
1087 /* At this point, we have to have a separator, or else the string is
1090 c = next_char (dtp);
1091 if (is_separator (c))
1093 unget_char (dtp, c);
1094 eat_separator (dtp);
1095 dtp->u.p.saved_type = BT_CHARACTER;
1101 sprintf (message, "Invalid string input in item %d",
1102 dtp->u.p.item_count);
1103 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1108 /* Parse a component of a complex constant or a real number that we
1109 are sure is already there. This is a straight real number parser. */
1112 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1114 char c, message[100];
1117 c = next_char (dtp);
1118 if (c == '-' || c == '+')
1121 c = next_char (dtp);
1124 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1127 if (!isdigit (c) && c != '.')
1129 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1137 seen_dp = (c == '.') ? 1 : 0;
1141 c = next_char (dtp);
1142 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1162 push_char (dtp, 'e');
1167 push_char (dtp, 'e');
1169 c = next_char (dtp);
1173 unget_char (dtp, c);
1182 c = next_char (dtp);
1183 if (c != '-' && c != '+')
1184 push_char (dtp, '+');
1188 c = next_char (dtp);
1199 c = next_char (dtp);
1207 unget_char (dtp, c);
1216 unget_char (dtp, c);
1217 push_char (dtp, '\0');
1219 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1225 /* Match INF and Infinity. */
1226 if ((c == 'i' || c == 'I')
1227 && ((c = next_char (dtp)) == 'n' || c == 'N')
1228 && ((c = next_char (dtp)) == 'f' || c == 'F'))
1230 c = next_char (dtp);
1231 if ((c != 'i' && c != 'I')
1232 || ((c == 'i' || c == 'I')
1233 && ((c = next_char (dtp)) == 'n' || c == 'N')
1234 && ((c = next_char (dtp)) == 'i' || c == 'I')
1235 && ((c = next_char (dtp)) == 't' || c == 'T')
1236 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1237 && (c = next_char (dtp))))
1239 if (is_separator (c))
1240 unget_char (dtp, c);
1241 push_char (dtp, 'i');
1242 push_char (dtp, 'n');
1243 push_char (dtp, 'f');
1247 else if (((c = next_char (dtp)) == 'a' || c == 'A')
1248 && ((c = next_char (dtp)) == 'n' || c == 'N')
1249 && (c = next_char (dtp)))
1251 if (is_separator (c))
1252 unget_char (dtp, c);
1253 push_char (dtp, 'n');
1254 push_char (dtp, 'a');
1255 push_char (dtp, 'n');
1261 if (nml_bad_return (dtp, c))
1266 sprintf (message, "Bad floating point number for item %d",
1267 dtp->u.p.item_count);
1268 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1274 /* Reading a complex number is straightforward because we can tell
1275 what it is right away. */
1278 read_complex (st_parameter_dt *dtp, int kind, size_t size)
1283 if (parse_repeat (dtp))
1286 c = next_char (dtp);
1293 unget_char (dtp, c);
1294 eat_separator (dtp);
1302 if (parse_real (dtp, dtp->u.p.value, kind))
1307 c = next_char (dtp);
1308 if (c == '\n' || c== '\r')
1311 unget_char (dtp, c);
1314 != (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
1319 c = next_char (dtp);
1320 if (c == '\n' || c== '\r')
1323 unget_char (dtp, c);
1325 if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
1329 if (next_char (dtp) != ')')
1332 c = next_char (dtp);
1333 if (!is_separator (c))
1336 unget_char (dtp, c);
1337 eat_separator (dtp);
1340 dtp->u.p.saved_type = BT_COMPLEX;
1345 if (nml_bad_return (dtp, c))
1350 sprintf (message, "Bad complex value in item %d of list input",
1351 dtp->u.p.item_count);
1352 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1356 /* Parse a real number with a possible repeat count. */
1359 read_real (st_parameter_dt *dtp, int length)
1361 char c, message[100];
1367 c = next_char (dtp);
1368 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1386 unget_char (dtp, c); /* Single null. */
1387 eat_separator (dtp);
1400 /* Get the digit string that might be a repeat count. */
1404 c = next_char (dtp);
1405 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1429 push_char (dtp, 'e');
1431 c = next_char (dtp);
1435 push_char (dtp, '\0');
1439 if (c != '\n' && c != ',' && c != '\r' && c != ';')
1440 unget_char (dtp, c);
1449 if (convert_integer (dtp, -1, 0))
1452 /* Now get the number itself. */
1454 c = next_char (dtp);
1455 if (is_separator (c))
1456 { /* Repeated null value. */
1457 unget_char (dtp, c);
1458 eat_separator (dtp);
1462 if (c != '-' && c != '+')
1463 push_char (dtp, '+');
1468 c = next_char (dtp);
1471 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1474 if (!isdigit (c) && c != '.')
1476 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1495 c = next_char (dtp);
1496 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1523 push_char (dtp, 'e');
1525 c = next_char (dtp);
1534 push_char (dtp, 'e');
1536 c = next_char (dtp);
1537 if (c != '+' && c != '-')
1538 push_char (dtp, '+');
1542 c = next_char (dtp);
1552 c = next_char (dtp);
1569 unget_char (dtp, c);
1570 eat_separator (dtp);
1571 push_char (dtp, '\0');
1572 if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
1576 dtp->u.p.saved_type = BT_REAL;
1580 l_push_char (dtp, c);
1583 /* Match INF and Infinity. */
1584 if (c == 'i' || c == 'I')
1586 c = next_char (dtp);
1587 l_push_char (dtp, c);
1588 if (c != 'n' && c != 'N')
1590 c = next_char (dtp);
1591 l_push_char (dtp, c);
1592 if (c != 'f' && c != 'F')
1594 c = next_char (dtp);
1595 l_push_char (dtp, c);
1596 if (!is_separator (c))
1598 if (c != 'i' && c != 'I')
1600 c = next_char (dtp);
1601 l_push_char (dtp, c);
1602 if (c != 'n' && c != 'N')
1604 c = next_char (dtp);
1605 l_push_char (dtp, c);
1606 if (c != 'i' && c != 'I')
1608 c = next_char (dtp);
1609 l_push_char (dtp, c);
1610 if (c != 't' && c != 'T')
1612 c = next_char (dtp);
1613 l_push_char (dtp, c);
1614 if (c != 'y' && c != 'Y')
1616 c = next_char (dtp);
1617 l_push_char (dtp, c);
1623 c = next_char (dtp);
1624 l_push_char (dtp, c);
1625 if (c != 'a' && c != 'A')
1627 c = next_char (dtp);
1628 l_push_char (dtp, c);
1629 if (c != 'n' && c != 'N')
1631 c = next_char (dtp);
1632 l_push_char (dtp, c);
1635 if (!is_separator (c))
1638 if (dtp->u.p.namelist_mode)
1640 if (c == ' ' || c =='\n' || c == '\r')
1643 c = next_char (dtp);
1644 while (c == ' ' || c =='\n' || c == '\r');
1646 l_push_char (dtp, c);
1655 push_char (dtp, 'i');
1656 push_char (dtp, 'n');
1657 push_char (dtp, 'f');
1661 push_char (dtp, 'n');
1662 push_char (dtp, 'a');
1663 push_char (dtp, 'n');
1670 if (dtp->u.p.namelist_mode)
1672 dtp->u.p.nml_read_error = 1;
1673 dtp->u.p.line_buffer_enabled = 1;
1674 dtp->u.p.item_count = 0;
1680 if (nml_bad_return (dtp, c))
1685 sprintf (message, "Bad real number in item %d of list input",
1686 dtp->u.p.item_count);
1687 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1691 /* Check the current type against the saved type to make sure they are
1692 compatible. Returns nonzero if incompatible. */
1695 check_type (st_parameter_dt *dtp, bt type, int len)
1699 if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
1701 sprintf (message, "Read type %s where %s was expected for item %d",
1702 type_name (dtp->u.p.saved_type), type_name (type),
1703 dtp->u.p.item_count);
1705 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1709 if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
1712 if (dtp->u.p.saved_length != len)
1715 "Read kind %d %s where kind %d is required for item %d",
1716 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1717 dtp->u.p.item_count);
1718 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1726 /* Top level data transfer subroutine for list reads. Because we have
1727 to deal with repeat counts, the data item is always saved after
1728 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1729 greater than one, we copy the data item multiple times. */
1732 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1739 dtp->u.p.namelist_mode = 0;
1741 dtp->u.p.eof_jump = &eof_jump;
1742 if (setjmp (eof_jump))
1744 generate_error (&dtp->common, LIBERROR_END, NULL);
1748 if (dtp->u.p.first_item)
1750 dtp->u.p.first_item = 0;
1751 dtp->u.p.input_complete = 0;
1752 dtp->u.p.repeat_count = 1;
1753 dtp->u.p.at_eol = 0;
1755 c = eat_spaces (dtp);
1756 if (is_separator (c))
1758 /* Found a null value. */
1759 eat_separator (dtp);
1760 dtp->u.p.repeat_count = 0;
1762 /* eat_separator sets this flag if the separator was a comma. */
1763 if (dtp->u.p.comma_flag)
1766 /* eat_separator sets this flag if the separator was a \n or \r. */
1767 if (dtp->u.p.at_eol)
1768 finish_separator (dtp);
1776 if (dtp->u.p.input_complete)
1779 if (dtp->u.p.repeat_count > 0)
1781 if (check_type (dtp, type, kind))
1786 if (dtp->u.p.at_eol)
1787 finish_separator (dtp);
1791 /* Trailing spaces prior to end of line. */
1792 if (dtp->u.p.at_eol)
1793 finish_separator (dtp);
1796 dtp->u.p.saved_type = BT_NULL;
1797 dtp->u.p.repeat_count = 1;
1803 read_integer (dtp, kind);
1806 read_logical (dtp, kind);
1809 read_character (dtp, kind);
1812 read_real (dtp, kind);
1815 read_complex (dtp, kind, size);
1818 internal_error (&dtp->common, "Bad type for list read");
1821 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1822 dtp->u.p.saved_length = size;
1824 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1828 switch (dtp->u.p.saved_type)
1834 memcpy (p, dtp->u.p.value, size);
1838 if (dtp->u.p.saved_string)
1840 m = ((int) size < dtp->u.p.saved_used)
1841 ? (int) size : dtp->u.p.saved_used;
1842 memcpy (p, dtp->u.p.saved_string, m);
1845 /* Just delimiters encountered, nothing to copy but SPACE. */
1849 memset (((char *) p) + m, ' ', size - m);
1856 if (--dtp->u.p.repeat_count <= 0)
1860 dtp->u.p.eof_jump = NULL;
1865 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1866 size_t size, size_t nelems)
1873 /* Big loop over all the elements. */
1874 for (elem = 0; elem < nelems; elem++)
1876 dtp->u.p.item_count++;
1877 list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
1882 /* Finish a list read. */
1885 finish_list_read (st_parameter_dt *dtp)
1891 if (dtp->u.p.at_eol)
1893 dtp->u.p.at_eol = 0;
1899 c = next_char (dtp);
1906 void namelist_read (st_parameter_dt *dtp)
1908 static void nml_match_name (char *name, int len)
1909 static int nml_query (st_parameter_dt *dtp)
1910 static int nml_get_obj_data (st_parameter_dt *dtp,
1911 namelist_info **prev_nl, char *, size_t)
1913 static void nml_untouch_nodes (st_parameter_dt *dtp)
1914 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1916 static int nml_parse_qualifier(descriptor_dimension * ad,
1917 array_loop_spec * ls, int rank, char *)
1918 static void nml_touch_nodes (namelist_info * nl)
1919 static int nml_read_obj (namelist_info *nl, index_type offset,
1920 namelist_info **prev_nl, char *, size_t,
1921 index_type clow, index_type chigh)
1925 /* Inputs a rank-dimensional qualifier, which can contain
1926 singlets, doublets, triplets or ':' with the standard meanings. */
1929 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1930 array_loop_spec *ls, int rank, char *parse_err_msg,
1937 int is_array_section, is_char;
1941 is_array_section = 0;
1942 dtp->u.p.expanded_read = 0;
1944 /* See if this is a character substring qualifier we are looking for. */
1951 /* The next character in the stream should be the '('. */
1953 c = next_char (dtp);
1955 /* Process the qualifier, by dimension and triplet. */
1957 for (dim=0; dim < rank; dim++ )
1959 for (indx=0; indx<3; indx++)
1965 /* Process a potential sign. */
1966 c = next_char (dtp);
1977 unget_char (dtp, c);
1981 /* Process characters up to the next ':' , ',' or ')'. */
1984 c = next_char (dtp);
1989 is_array_section = 1;
1993 if ((c==',' && dim == rank -1)
1994 || (c==')' && dim < rank -1))
1997 sprintf (parse_err_msg, "Bad substring qualifier");
1999 sprintf (parse_err_msg, "Bad number of index fields");
2008 case ' ': case '\t':
2010 c = next_char (dtp);
2015 sprintf (parse_err_msg,
2016 "Bad character in substring qualifier");
2018 sprintf (parse_err_msg, "Bad character in index");
2022 if ((c == ',' || c == ')') && indx == 0
2023 && dtp->u.p.saved_string == 0)
2026 sprintf (parse_err_msg, "Null substring qualifier");
2028 sprintf (parse_err_msg, "Null index field");
2032 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2033 || (indx == 2 && dtp->u.p.saved_string == 0))
2036 sprintf (parse_err_msg, "Bad substring qualifier");
2038 sprintf (parse_err_msg, "Bad index triplet");
2042 if (is_char && !is_array_section)
2044 sprintf (parse_err_msg,
2045 "Missing colon in substring qualifier");
2049 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2051 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2052 || (indx==1 && dtp->u.p.saved_string == 0))
2058 /* Now read the index. */
2059 if (convert_integer (dtp, sizeof(ssize_t), neg))
2062 sprintf (parse_err_msg, "Bad integer substring qualifier");
2064 sprintf (parse_err_msg, "Bad integer in index");
2070 /* Feed the index values to the triplet arrays. */
2074 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2076 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2078 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2081 /* Singlet or doublet indices. */
2082 if (c==',' || c==')')
2086 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2088 /* If -std=f95/2003 or an array section is specified,
2089 do not allow excess data to be processed. */
2090 if (is_array_section == 1
2091 || compile_options.allow_std < GFC_STD_GNU)
2092 ls[dim].end = ls[dim].start;
2094 dtp->u.p.expanded_read = 1;
2097 /* Check for non-zero rank. */
2098 if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2105 /* Check the values of the triplet indices. */
2106 if ((ls[dim].start > (ssize_t)ad[dim].ubound)
2107 || (ls[dim].start < (ssize_t)ad[dim].lbound)
2108 || (ls[dim].end > (ssize_t)ad[dim].ubound)
2109 || (ls[dim].end < (ssize_t)ad[dim].lbound))
2112 sprintf (parse_err_msg, "Substring out of range");
2114 sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2118 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2119 || (ls[dim].step == 0))
2121 sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2125 /* Initialise the loop index counter. */
2126 ls[dim].idx = ls[dim].start;
2136 static namelist_info *
2137 find_nml_node (st_parameter_dt *dtp, char * var_name)
2139 namelist_info * t = dtp->u.p.ionml;
2142 if (strcmp (var_name, t->var_name) == 0)
2152 /* Visits all the components of a derived type that have
2153 not explicitly been identified in the namelist input.
2154 touched is set and the loop specification initialised
2155 to default values */
2158 nml_touch_nodes (namelist_info * nl)
2160 index_type len = strlen (nl->var_name) + 1;
2162 char * ext_name = (char*)get_mem (len + 1);
2163 memcpy (ext_name, nl->var_name, len-1);
2164 memcpy (ext_name + len - 1, "%", 2);
2165 for (nl = nl->next; nl; nl = nl->next)
2167 if (strncmp (nl->var_name, ext_name, len) == 0)
2170 for (dim=0; dim < nl->var_rank; dim++)
2172 nl->ls[dim].step = 1;
2173 nl->ls[dim].end = nl->dim[dim].ubound;
2174 nl->ls[dim].start = nl->dim[dim].lbound;
2175 nl->ls[dim].idx = nl->ls[dim].start;
2181 free_mem (ext_name);
2185 /* Resets touched for the entire list of nml_nodes, ready for a
2189 nml_untouch_nodes (st_parameter_dt *dtp)
2192 for (t = dtp->u.p.ionml; t; t = t->next)
2197 /* Attempts to input name to namelist name. Returns
2198 dtp->u.p.nml_read_error = 1 on no match. */
2201 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2205 dtp->u.p.nml_read_error = 0;
2206 for (i = 0; i < len; i++)
2208 c = next_char (dtp);
2209 if (tolower (c) != tolower (name[i]))
2211 dtp->u.p.nml_read_error = 1;
2217 /* If the namelist read is from stdin, output the current state of the
2218 namelist to stdout. This is used to implement the non-standard query
2219 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2220 the names alone are printed. */
2223 nml_query (st_parameter_dt *dtp, char c)
2225 gfc_unit * temp_unit;
2230 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2233 /* Store the current unit and transfer to stdout. */
2235 temp_unit = dtp->u.p.current_unit;
2236 dtp->u.p.current_unit = find_unit (options.stdout_unit);
2238 if (dtp->u.p.current_unit)
2240 dtp->u.p.mode = WRITING;
2241 next_record (dtp, 0);
2243 /* Write the namelist in its entirety. */
2246 namelist_write (dtp);
2248 /* Or write the list of names. */
2252 /* "&namelist_name\n" */
2254 len = dtp->namelist_name_len;
2256 p = write_block (dtp, len + 3);
2258 p = write_block (dtp, len + 2);
2263 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2265 memcpy ((char*)(p + len + 1), "\r\n", 2);
2267 memcpy ((char*)(p + len + 1), "\n", 1);
2269 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2273 len = strlen (nl->var_name);
2275 p = write_block (dtp, len + 3);
2277 p = write_block (dtp, len + 2);
2282 memcpy ((char*)(p + 1), nl->var_name, len);
2284 memcpy ((char*)(p + len + 1), "\r\n", 2);
2286 memcpy ((char*)(p + len + 1), "\n", 1);
2293 p = write_block (dtp, 6);
2295 p = write_block (dtp, 5);
2300 memcpy (p, "&end\r\n", 6);
2302 memcpy (p, "&end\n", 5);
2306 /* Flush the stream to force immediate output. */
2308 flush (dtp->u.p.current_unit->s);
2309 unlock_unit (dtp->u.p.current_unit);
2314 /* Restore the current unit. */
2316 dtp->u.p.current_unit = temp_unit;
2317 dtp->u.p.mode = READING;
2321 /* Reads and stores the input for the namelist object nl. For an array,
2322 the function loops over the ranges defined by the loop specification.
2323 This default to all the data or to the specification from a qualifier.
2324 nml_read_obj recursively calls itself to read derived types. It visits
2325 all its own components but only reads data for those that were touched
2326 when the name was parsed. If a read error is encountered, an attempt is
2327 made to return to read a new object name because the standard allows too
2328 little data to be available. On the other hand, too much data is an
2332 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2333 namelist_info **pprev_nl, char *nml_err_msg,
2334 size_t nml_err_msg_size, index_type clow, index_type chigh)
2336 namelist_info * cmp;
2343 index_type obj_name_len;
2346 /* This object not touched in name parsing. */
2351 dtp->u.p.repeat_count = 0;
2357 case GFC_DTYPE_INTEGER:
2358 case GFC_DTYPE_LOGICAL:
2362 case GFC_DTYPE_REAL:
2363 dlen = size_from_real_kind (len);
2366 case GFC_DTYPE_COMPLEX:
2367 dlen = size_from_complex_kind (len);
2370 case GFC_DTYPE_CHARACTER:
2371 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2380 /* Update the pointer to the data, using the current index vector */
2382 pdata = (void*)(nl->mem_pos + offset);
2383 for (dim = 0; dim < nl->var_rank; dim++)
2384 pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
2385 nl->dim[dim].stride * nl->size);
2387 /* Reset the error flag and try to read next value, if
2388 dtp->u.p.repeat_count=0 */
2390 dtp->u.p.nml_read_error = 0;
2392 if (--dtp->u.p.repeat_count <= 0)
2394 if (dtp->u.p.input_complete)
2396 if (dtp->u.p.at_eol)
2397 finish_separator (dtp);
2398 if (dtp->u.p.input_complete)
2401 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2402 after the switch block. */
2404 dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
2409 case GFC_DTYPE_INTEGER:
2410 read_integer (dtp, len);
2413 case GFC_DTYPE_LOGICAL:
2414 read_logical (dtp, len);
2417 case GFC_DTYPE_CHARACTER:
2418 read_character (dtp, len);
2421 case GFC_DTYPE_REAL:
2422 read_real (dtp, len);
2425 case GFC_DTYPE_COMPLEX:
2426 read_complex (dtp, len, dlen);
2429 case GFC_DTYPE_DERIVED:
2430 obj_name_len = strlen (nl->var_name) + 1;
2431 obj_name = get_mem (obj_name_len+1);
2432 memcpy (obj_name, nl->var_name, obj_name_len-1);
2433 memcpy (obj_name + obj_name_len - 1, "%", 2);
2435 /* If reading a derived type, disable the expanded read warning
2436 since a single object can have multiple reads. */
2437 dtp->u.p.expanded_read = 0;
2439 /* Now loop over the components. Update the component pointer
2440 with the return value from nml_write_obj. This loop jumps
2441 past nested derived types by testing if the potential
2442 component name contains '%'. */
2444 for (cmp = nl->next;
2446 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2447 !strchr (cmp->var_name + obj_name_len, '%');
2451 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2452 pprev_nl, nml_err_msg, nml_err_msg_size,
2453 clow, chigh) == FAILURE)
2455 free_mem (obj_name);
2459 if (dtp->u.p.input_complete)
2461 free_mem (obj_name);
2466 free_mem (obj_name);
2470 snprintf (nml_err_msg, nml_err_msg_size,
2471 "Bad type for namelist object %s", nl->var_name);
2472 internal_error (&dtp->common, nml_err_msg);
2477 /* The standard permits array data to stop short of the number of
2478 elements specified in the loop specification. In this case, we
2479 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2480 nml_get_obj_data and an attempt is made to read object name. */
2483 if (dtp->u.p.nml_read_error)
2485 dtp->u.p.expanded_read = 0;
2489 if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
2491 dtp->u.p.expanded_read = 0;
2495 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2496 This comes about because the read functions return BT_types. */
2498 switch (dtp->u.p.saved_type)
2505 memcpy (pdata, dtp->u.p.value, dlen);
2509 m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2510 pdata = (void*)( pdata + clow - 1 );
2511 memcpy (pdata, dtp->u.p.saved_string, m);
2513 memset ((void*)( pdata + m ), ' ', dlen - m);
2520 /* Warn if a non-standard expanded read occurs. A single read of a
2521 single object is acceptable. If a second read occurs, issue a warning
2522 and set the flag to zero to prevent further warnings. */
2523 if (dtp->u.p.expanded_read == 2)
2525 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2526 dtp->u.p.expanded_read = 0;
2529 /* If the expanded read warning flag is set, increment it,
2530 indicating that a single read has occurred. */
2531 if (dtp->u.p.expanded_read >= 1)
2532 dtp->u.p.expanded_read++;
2534 /* Break out of loop if scalar. */
2538 /* Now increment the index vector. */
2543 for (dim = 0; dim < nl->var_rank; dim++)
2545 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2547 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2549 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2551 nl->ls[dim].idx = nl->ls[dim].start;
2555 } while (!nml_carry);
2557 if (dtp->u.p.repeat_count > 1)
2559 snprintf (nml_err_msg, nml_err_msg_size,
2560 "Repeat count too large for namelist object %s", nl->var_name);
2570 /* Parses the object name, including array and substring qualifiers. It
2571 iterates over derived type components, touching those components and
2572 setting their loop specifications, if there is a qualifier. If the
2573 object is itself a derived type, its components and subcomponents are
2574 touched. nml_read_obj is called at the end and this reads the data in
2575 the manner specified by the object name. */
2578 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2579 char *nml_err_msg, size_t nml_err_msg_size)
2583 namelist_info * first_nl = NULL;
2584 namelist_info * root_nl = NULL;
2585 int dim, parsed_rank;
2587 index_type clow, chigh;
2588 int non_zero_rank_count;
2590 /* Look for end of input or object name. If '?' or '=?' are encountered
2591 in stdin, print the node names or the namelist to stdout. */
2593 eat_separator (dtp);
2594 if (dtp->u.p.input_complete)
2597 if (dtp->u.p.at_eol)
2598 finish_separator (dtp);
2599 if (dtp->u.p.input_complete)
2602 c = next_char (dtp);
2606 c = next_char (dtp);
2609 sprintf (nml_err_msg, "namelist read: misplaced = sign");
2612 nml_query (dtp, '=');
2616 nml_query (dtp, '?');
2621 nml_match_name (dtp, "end", 3);
2622 if (dtp->u.p.nml_read_error)
2624 sprintf (nml_err_msg, "namelist not terminated with / or &end");
2628 dtp->u.p.input_complete = 1;
2635 /* Untouch all nodes of the namelist and reset the flag that is set for
2636 derived type components. */
2638 nml_untouch_nodes (dtp);
2640 non_zero_rank_count = 0;
2642 /* Get the object name - should '!' and '\n' be permitted separators? */
2650 if (!is_separator (c))
2651 push_char (dtp, tolower(c));
2652 c = next_char (dtp);
2653 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2655 unget_char (dtp, c);
2657 /* Check that the name is in the namelist and get pointer to object.
2658 Three error conditions exist: (i) An attempt is being made to
2659 identify a non-existent object, following a failed data read or
2660 (ii) The object name does not exist or (iii) Too many data items
2661 are present for an object. (iii) gives the same error message
2664 push_char (dtp, '\0');
2668 size_t var_len = strlen (root_nl->var_name);
2670 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2671 char ext_name[var_len + saved_len + 1];
2673 memcpy (ext_name, root_nl->var_name, var_len);
2674 if (dtp->u.p.saved_string)
2675 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2676 ext_name[var_len + saved_len] = '\0';
2677 nl = find_nml_node (dtp, ext_name);
2680 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2684 if (dtp->u.p.nml_read_error && *pprev_nl)
2685 snprintf (nml_err_msg, nml_err_msg_size,
2686 "Bad data for namelist object %s", (*pprev_nl)->var_name);
2689 snprintf (nml_err_msg, nml_err_msg_size,
2690 "Cannot match namelist object name %s",
2691 dtp->u.p.saved_string);
2696 /* Get the length, data length, base pointer and rank of the variable.
2697 Set the default loop specification first. */
2699 for (dim=0; dim < nl->var_rank; dim++)
2701 nl->ls[dim].step = 1;
2702 nl->ls[dim].end = nl->dim[dim].ubound;
2703 nl->ls[dim].start = nl->dim[dim].lbound;
2704 nl->ls[dim].idx = nl->ls[dim].start;
2707 /* Check to see if there is a qualifier: if so, parse it.*/
2709 if (c == '(' && nl->var_rank)
2712 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2713 nml_err_msg, &parsed_rank) == FAILURE)
2715 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2716 snprintf (nml_err_msg_end,
2717 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2718 " for namelist variable %s", nl->var_name);
2722 if (parsed_rank > 0)
2723 non_zero_rank_count++;
2725 c = next_char (dtp);
2726 unget_char (dtp, c);
2728 else if (nl->var_rank > 0)
2729 non_zero_rank_count++;
2731 /* Now parse a derived type component. The root namelist_info address
2732 is backed up, as is the previous component level. The component flag
2733 is set and the iteration is made by jumping back to get_name. */
2737 if (nl->type != GFC_DTYPE_DERIVED)
2739 snprintf (nml_err_msg, nml_err_msg_size,
2740 "Attempt to get derived component for %s", nl->var_name);
2744 if (!component_flag)
2749 c = next_char (dtp);
2753 /* Parse a character qualifier, if present. chigh = 0 is a default
2754 that signals that the string length = string_length. */
2759 if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2761 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2762 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2764 if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
2767 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2768 snprintf (nml_err_msg_end,
2769 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2770 " for namelist variable %s", nl->var_name);
2774 clow = ind[0].start;
2777 if (ind[0].step != 1)
2779 snprintf (nml_err_msg, nml_err_msg_size,
2780 "Step not allowed in substring qualifier"
2781 " for namelist object %s", nl->var_name);
2785 c = next_char (dtp);
2786 unget_char (dtp, c);
2789 /* If a derived type touch its components and restore the root
2790 namelist_info if we have parsed a qualified derived type
2793 if (nl->type == GFC_DTYPE_DERIVED)
2794 nml_touch_nodes (nl);
2798 /* Make sure no extraneous qualifiers are there. */
2802 snprintf (nml_err_msg, nml_err_msg_size,
2803 "Qualifier for a scalar or non-character namelist object %s",
2808 /* Make sure there is no more than one non-zero rank object. */
2809 if (non_zero_rank_count > 1)
2811 snprintf (nml_err_msg, nml_err_msg_size,
2812 "Multiple sub-objects with non-zero rank in namelist object %s",
2814 non_zero_rank_count = 0;
2818 /* According to the standard, an equal sign MUST follow an object name. The
2819 following is possibly lax - it allows comments, blank lines and so on to
2820 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2824 eat_separator (dtp);
2825 if (dtp->u.p.input_complete)
2828 if (dtp->u.p.at_eol)
2829 finish_separator (dtp);
2830 if (dtp->u.p.input_complete)
2833 c = next_char (dtp);
2837 snprintf (nml_err_msg, nml_err_msg_size,
2838 "Equal sign must follow namelist object name %s",
2843 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
2844 clow, chigh) == FAILURE)
2854 /* Entry point for namelist input. Goes through input until namelist name
2855 is matched. Then cycles through nml_get_obj_data until the input is
2856 completed or there is an error. */
2859 namelist_read (st_parameter_dt *dtp)
2863 char nml_err_msg[200];
2864 /* Pointer to the previously read object, in case attempt is made to read
2865 new object name. Should this fail, error message can give previous
2867 namelist_info *prev_nl = NULL;
2869 dtp->u.p.namelist_mode = 1;
2870 dtp->u.p.input_complete = 0;
2871 dtp->u.p.expanded_read = 0;
2873 dtp->u.p.eof_jump = &eof_jump;
2874 if (setjmp (eof_jump))
2876 dtp->u.p.eof_jump = NULL;
2877 generate_error (&dtp->common, LIBERROR_END, NULL);
2881 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2882 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2883 node names or namelist on stdout. */
2886 switch (c = next_char (dtp))
2897 c = next_char (dtp);
2899 nml_query (dtp, '=');
2901 unget_char (dtp, c);
2905 nml_query (dtp, '?');
2911 /* Match the name of the namelist. */
2913 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2915 if (dtp->u.p.nml_read_error)
2918 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2919 c = next_char (dtp);
2920 if (!is_separator(c))
2922 unget_char (dtp, c);
2926 /* Ready to read namelist objects. If there is an error in input
2927 from stdin, output the error message and continue. */
2929 while (!dtp->u.p.input_complete)
2931 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
2936 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2939 u = find_unit (options.stderr_unit);
2940 st_printf ("%s\n", nml_err_msg);
2950 dtp->u.p.eof_jump = NULL;
2955 /* All namelist error calls return from here */
2959 dtp->u.p.eof_jump = NULL;
2962 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);