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
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt *dtp, char c)
76 if (dtp->u.p.saved_string == NULL)
78 if (dtp->u.p.scratch == NULL)
79 dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
80 dtp->u.p.saved_string = dtp->u.p.scratch;
81 memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
82 dtp->u.p.saved_length = SCRATCH_SIZE;
83 dtp->u.p.saved_used = 0;
86 if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
88 dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
89 new = get_mem (2 * dtp->u.p.saved_length);
91 memset (new, 0, 2 * dtp->u.p.saved_length);
93 memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
94 if (dtp->u.p.saved_string != dtp->u.p.scratch)
95 free_mem (dtp->u.p.saved_string);
97 dtp->u.p.saved_string = new;
100 dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
104 /* Free the input buffer if necessary. */
107 free_saved (st_parameter_dt *dtp)
109 if (dtp->u.p.saved_string == NULL)
112 if (dtp->u.p.saved_string != dtp->u.p.scratch)
113 free_mem (dtp->u.p.saved_string);
115 dtp->u.p.saved_string = NULL;
116 dtp->u.p.saved_used = 0;
120 /* Free the line buffer if necessary. */
123 free_line (st_parameter_dt *dtp)
125 dtp->u.p.item_count = 0;
126 dtp->u.p.line_buffer_enabled = 0;
128 if (dtp->u.p.line_buffer == NULL)
131 free_mem (dtp->u.p.line_buffer);
132 dtp->u.p.line_buffer = NULL;
137 next_char (st_parameter_dt *dtp)
143 if (dtp->u.p.last_char != '\0')
146 c = dtp->u.p.last_char;
147 dtp->u.p.last_char = '\0';
151 /* Read from line_buffer if enabled. */
153 if (dtp->u.p.line_buffer_enabled)
157 c = dtp->u.p.line_buffer[dtp->u.p.item_count];
158 if (c != '\0' && dtp->u.p.item_count < 64)
160 dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
161 dtp->u.p.item_count++;
165 dtp->u.p.item_count = 0;
166 dtp->u.p.line_buffer_enabled = 0;
169 /* Handle the end-of-record and end-of-file conditions for
170 internal array unit. */
171 if (is_array_io (dtp))
174 longjmp (*dtp->u.p.eof_jump, 1);
176 /* Check for "end-of-record" condition. */
177 if (dtp->u.p.current_unit->bytes_left == 0)
182 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
185 /* Check for "end-of-file" condition. */
192 record *= dtp->u.p.current_unit->recl;
193 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
194 longjmp (*dtp->u.p.eof_jump, 1);
196 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
201 /* Get the next character and handle end-of-record conditions. */
205 p = salloc_r (dtp->u.p.current_unit->s, &length);
207 if (is_stream_io (dtp))
208 dtp->u.p.current_unit->strm_pos++;
210 if (is_internal_unit (dtp))
212 if (is_array_io (dtp))
214 /* End of record is handled in the next pass through, above. The
215 check for NULL here is cautionary. */
218 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
222 dtp->u.p.current_unit->bytes_left--;
228 longjmp (*dtp->u.p.eof_jump, 1);
239 generate_error (&dtp->common, LIBERROR_OS, NULL);
244 if (dtp->u.p.advance_status == ADVANCE_NO)
246 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
247 longjmp (*dtp->u.p.eof_jump, 1);
248 dtp->u.p.current_unit->endfile = AT_ENDFILE;
252 longjmp (*dtp->u.p.eof_jump, 1);
258 dtp->u.p.at_eol = (c == '\n' || c == '\r');
263 /* Push a character back onto the input. */
266 unget_char (st_parameter_dt *dtp, char c)
268 dtp->u.p.last_char = c;
272 /* Skip over spaces in the input. Returns the nonspace character that
273 terminated the eating and also places it back on the input. */
276 eat_spaces (st_parameter_dt *dtp)
284 while (c == ' ' || c == '\t');
291 /* This function reads characters through to the end of the current line and
292 just ignores them. */
295 eat_line (st_parameter_dt *dtp)
298 if (!is_internal_unit (dtp))
305 /* Skip over a separator. Technically, we don't always eat the whole
306 separator. This is because if we've processed the last input item,
307 then a separator is unnecessary. Plus the fact that operating
308 systems usually deliver console input on a line basis.
310 The upshot is that if we see a newline as part of reading a
311 separator, we stop reading. If there are more input items, we
312 continue reading the separator with finish_separator() which takes
313 care of the fact that we may or may not have seen a comma as part
317 eat_separator (st_parameter_dt *dtp)
322 dtp->u.p.comma_flag = 0;
328 if (dtp->u.p.decimal_status == DECIMAL_COMMA)
335 dtp->u.p.comma_flag = 1;
340 dtp->u.p.input_complete = 1;
348 if (dtp->u.p.namelist_mode)
352 while (c == '\n' || c == '\r' || c == ' ');
362 if (dtp->u.p.namelist_mode)
378 while (c == '\n' || c == '\r' || c == ' ');
384 if (dtp->u.p.namelist_mode)
385 { /* Eat a namelist comment. */
393 /* Fall Through... */
402 /* Finish processing a separator that was interrupted by a newline.
403 If we're here, then another data item is present, so we finish what
404 we started on the previous line. */
407 finish_separator (st_parameter_dt *dtp)
418 if (dtp->u.p.comma_flag)
422 c = eat_spaces (dtp);
423 if (c == '\n' || c == '\r')
430 dtp->u.p.input_complete = 1;
431 if (!dtp->u.p.namelist_mode)
440 if (dtp->u.p.namelist_mode)
456 /* This function is needed to catch bad conversions so that namelist can
457 attempt to see if dtp->u.p.saved_string contains a new object name rather
461 nml_bad_return (st_parameter_dt *dtp, char c)
463 if (dtp->u.p.namelist_mode)
465 dtp->u.p.nml_read_error = 1;
472 /* Convert an unsigned string to an integer. The length value is -1
473 if we are working on a repeat count. Returns nonzero if we have a
474 range problem. As a side effect, frees the dtp->u.p.saved_string. */
477 convert_integer (st_parameter_dt *dtp, int length, int negative)
479 char c, *buffer, message[100];
481 GFC_INTEGER_LARGEST v, max, max10;
483 buffer = dtp->u.p.saved_string;
486 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
511 set_integer (dtp->u.p.value, v, length);
515 dtp->u.p.repeat_count = v;
517 if (dtp->u.p.repeat_count == 0)
519 sprintf (message, "Zero repeat count in item %d of list input",
520 dtp->u.p.item_count);
522 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
532 sprintf (message, "Repeat count overflow in item %d of list input",
533 dtp->u.p.item_count);
535 sprintf (message, "Integer overflow while reading item %d",
536 dtp->u.p.item_count);
539 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
545 /* Parse a repeat count for logical and complex values which cannot
546 begin with a digit. Returns nonzero if we are done, zero if we
547 should continue on. */
550 parse_repeat (st_parameter_dt *dtp)
552 char c, message[100];
578 repeat = 10 * repeat + c - '0';
580 if (repeat > MAX_REPEAT)
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);
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;
618 sprintf (message, "Bad repeat count in item %d of list input",
619 dtp->u.p.item_count);
620 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
625 /* To read a logical we have to look ahead in the input stream to make sure
626 there is not an equal sign indicating a variable name. To do this we use
627 line_buffer to point to a temporary buffer, pushing characters there for
628 possible later reading. */
631 l_push_char (st_parameter_dt *dtp, char c)
633 if (dtp->u.p.line_buffer == NULL)
635 dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
636 memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
639 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
643 /* Read a logical character on the input. */
646 read_logical (st_parameter_dt *dtp, int length)
648 char c, message[100];
651 if (parse_repeat (dtp))
654 c = tolower (next_char (dtp));
655 l_push_char (dtp, c);
661 l_push_char (dtp, c);
663 if (!is_separator(c))
671 l_push_char (dtp, c);
673 if (!is_separator(c))
680 c = tolower (next_char (dtp));
698 return; /* Null value. */
701 /* Save the character in case it is the beginning
702 of the next object name. */
707 dtp->u.p.saved_type = BT_LOGICAL;
708 dtp->u.p.saved_length = length;
710 /* Eat trailing garbage. */
715 while (!is_separator (c));
719 set_integer ((int *) dtp->u.p.value, v, length);
726 for(i = 0; i < 63; i++)
731 /* All done if this is not a namelist read. */
732 if (!dtp->u.p.namelist_mode)
745 l_push_char (dtp, c);
748 dtp->u.p.nml_read_error = 1;
749 dtp->u.p.line_buffer_enabled = 1;
750 dtp->u.p.item_count = 0;
760 if (nml_bad_return (dtp, c))
765 sprintf (message, "Bad logical value while reading item %d",
766 dtp->u.p.item_count);
767 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
772 dtp->u.p.saved_type = BT_LOGICAL;
773 dtp->u.p.saved_length = length;
774 set_integer ((int *) dtp->u.p.value, v, length);
780 /* Reading integers is tricky because we can actually be reading a
781 repeat count. We have to store the characters in a buffer because
782 we could be reading an integer that is larger than the default int
783 used for repeat counts. */
786 read_integer (st_parameter_dt *dtp, int length)
788 char c, message[100];
798 /* Fall through... */
804 CASE_SEPARATORS: /* Single null. */
817 /* Take care of what may be a repeat count. */
829 push_char (dtp, '\0');
832 CASE_SEPARATORS: /* Not a repeat count. */
841 if (convert_integer (dtp, -1, 0))
844 /* Get the real integer. */
859 /* Fall through... */
890 if (nml_bad_return (dtp, c))
895 sprintf (message, "Bad integer for item %d in list input",
896 dtp->u.p.item_count);
897 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
905 push_char (dtp, '\0');
906 if (convert_integer (dtp, length, negative))
913 dtp->u.p.saved_type = BT_INTEGER;
917 /* Read a character variable. */
920 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
922 char c, quote, message[100];
924 quote = ' '; /* Space means no quote character. */
934 unget_char (dtp, c); /* NULL value. */
944 if (dtp->u.p.namelist_mode)
946 if (dtp->u.p.delim_status == DELIM_APOSTROPHE
947 || dtp->u.p.delim_status == DELIM_QUOTE
948 || c == '&' || c == '$' || c == '/')
954 /* Check to see if we are seeing a namelist object name by using the
955 line buffer and looking ahead for an '=' or '('. */
956 l_push_char (dtp, c);
959 for(i = 0; i < 63; i++)
969 l_push_char (dtp, c);
970 dtp->u.p.item_count = 0;
971 dtp->u.p.line_buffer_enabled = 1;
976 l_push_char (dtp, c);
978 if (c == '=' || c == '(')
980 dtp->u.p.item_count = 0;
981 dtp->u.p.nml_read_error = 1;
982 dtp->u.p.line_buffer_enabled = 1;
987 /* The string is too long to be a valid object name so assume that it
988 is a string to be read in as a value. */
989 dtp->u.p.item_count = 0;
990 dtp->u.p.line_buffer_enabled = 1;
998 /* Deal with a possible repeat count. */
1002 c = next_char (dtp);
1010 unget_char (dtp, c);
1011 goto done; /* String was only digits! */
1014 push_char (dtp, '\0');
1019 goto get_string; /* Not a repeat count after all. */
1024 if (convert_integer (dtp, -1, 0))
1027 /* Now get the real string. */
1029 c = next_char (dtp);
1033 unget_char (dtp, c); /* Repeated NULL values. */
1034 eat_separator (dtp);
1050 c = next_char (dtp);
1061 /* See if we have a doubled quote character or the end of
1064 c = next_char (dtp);
1067 push_char (dtp, quote);
1071 unget_char (dtp, c);
1077 unget_char (dtp, c);
1081 if (c != '\n' && c != '\r')
1091 /* At this point, we have to have a separator, or else the string is
1094 c = next_char (dtp);
1095 if (is_separator (c))
1097 unget_char (dtp, c);
1098 eat_separator (dtp);
1099 dtp->u.p.saved_type = BT_CHARACTER;
1105 sprintf (message, "Invalid string input in item %d",
1106 dtp->u.p.item_count);
1107 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1112 /* Parse a component of a complex constant or a real number that we
1113 are sure is already there. This is a straight real number parser. */
1116 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1118 char c, message[100];
1121 c = next_char (dtp);
1122 if (c == '-' || c == '+')
1125 c = next_char (dtp);
1128 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1131 if (!isdigit (c) && c != '.')
1133 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1141 seen_dp = (c == '.') ? 1 : 0;
1145 c = next_char (dtp);
1146 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1166 push_char (dtp, 'e');
1171 push_char (dtp, 'e');
1173 c = next_char (dtp);
1177 unget_char (dtp, c);
1186 c = next_char (dtp);
1187 if (c != '-' && c != '+')
1188 push_char (dtp, '+');
1192 c = next_char (dtp);
1203 c = next_char (dtp);
1211 unget_char (dtp, c);
1220 unget_char (dtp, c);
1221 push_char (dtp, '\0');
1223 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1229 /* Match INF and Infinity. */
1230 if ((c == 'i' || c == 'I')
1231 && ((c = next_char (dtp)) == 'n' || c == 'N')
1232 && ((c = next_char (dtp)) == 'f' || c == 'F'))
1234 c = next_char (dtp);
1235 if ((c != 'i' && c != 'I')
1236 || ((c == 'i' || c == 'I')
1237 && ((c = next_char (dtp)) == 'n' || c == 'N')
1238 && ((c = next_char (dtp)) == 'i' || c == 'I')
1239 && ((c = next_char (dtp)) == 't' || c == 'T')
1240 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1241 && (c = next_char (dtp))))
1243 if (is_separator (c))
1244 unget_char (dtp, c);
1245 push_char (dtp, 'i');
1246 push_char (dtp, 'n');
1247 push_char (dtp, 'f');
1251 else if (((c = next_char (dtp)) == 'a' || c == 'A')
1252 && ((c = next_char (dtp)) == 'n' || c == 'N')
1253 && (c = next_char (dtp)))
1255 if (is_separator (c))
1256 unget_char (dtp, c);
1257 push_char (dtp, 'n');
1258 push_char (dtp, 'a');
1259 push_char (dtp, 'n');
1265 if (nml_bad_return (dtp, c))
1270 sprintf (message, "Bad floating point number for item %d",
1271 dtp->u.p.item_count);
1272 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1278 /* Reading a complex number is straightforward because we can tell
1279 what it is right away. */
1282 read_complex (st_parameter_dt *dtp, int kind, size_t size)
1287 if (parse_repeat (dtp))
1290 c = next_char (dtp);
1297 unget_char (dtp, c);
1298 eat_separator (dtp);
1306 if (parse_real (dtp, dtp->u.p.value, kind))
1311 c = next_char (dtp);
1312 if (c == '\n' || c== '\r')
1315 unget_char (dtp, c);
1318 != (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
1323 c = next_char (dtp);
1324 if (c == '\n' || c== '\r')
1327 unget_char (dtp, c);
1329 if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
1333 if (next_char (dtp) != ')')
1336 c = next_char (dtp);
1337 if (!is_separator (c))
1340 unget_char (dtp, c);
1341 eat_separator (dtp);
1344 dtp->u.p.saved_type = BT_COMPLEX;
1349 if (nml_bad_return (dtp, c))
1354 sprintf (message, "Bad complex value in item %d of list input",
1355 dtp->u.p.item_count);
1356 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1360 /* Parse a real number with a possible repeat count. */
1363 read_real (st_parameter_dt *dtp, int length)
1365 char c, message[100];
1371 c = next_char (dtp);
1372 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1390 unget_char (dtp, c); /* Single null. */
1391 eat_separator (dtp);
1404 /* Get the digit string that might be a repeat count. */
1408 c = next_char (dtp);
1409 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1433 push_char (dtp, 'e');
1435 c = next_char (dtp);
1439 push_char (dtp, '\0');
1443 if (c != '\n' && c != ',' && c != '\r' && c != ';')
1444 unget_char (dtp, c);
1453 if (convert_integer (dtp, -1, 0))
1456 /* Now get the number itself. */
1458 c = next_char (dtp);
1459 if (is_separator (c))
1460 { /* Repeated null value. */
1461 unget_char (dtp, c);
1462 eat_separator (dtp);
1466 if (c != '-' && c != '+')
1467 push_char (dtp, '+');
1472 c = next_char (dtp);
1475 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1478 if (!isdigit (c) && c != '.')
1480 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1499 c = next_char (dtp);
1500 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1527 push_char (dtp, 'e');
1529 c = next_char (dtp);
1538 push_char (dtp, 'e');
1540 c = next_char (dtp);
1541 if (c != '+' && c != '-')
1542 push_char (dtp, '+');
1546 c = next_char (dtp);
1556 c = next_char (dtp);
1573 unget_char (dtp, c);
1574 eat_separator (dtp);
1575 push_char (dtp, '\0');
1576 if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
1580 dtp->u.p.saved_type = BT_REAL;
1584 l_push_char (dtp, c);
1587 /* Match INF and Infinity. */
1588 if (c == 'i' || c == 'I')
1590 c = next_char (dtp);
1591 l_push_char (dtp, c);
1592 if (c != 'n' && c != 'N')
1594 c = next_char (dtp);
1595 l_push_char (dtp, c);
1596 if (c != 'f' && c != 'F')
1598 c = next_char (dtp);
1599 l_push_char (dtp, c);
1600 if (!is_separator (c))
1602 if (c != 'i' && c != 'I')
1604 c = next_char (dtp);
1605 l_push_char (dtp, c);
1606 if (c != 'n' && c != 'N')
1608 c = next_char (dtp);
1609 l_push_char (dtp, c);
1610 if (c != 'i' && c != 'I')
1612 c = next_char (dtp);
1613 l_push_char (dtp, c);
1614 if (c != 't' && c != 'T')
1616 c = next_char (dtp);
1617 l_push_char (dtp, c);
1618 if (c != 'y' && c != 'Y')
1620 c = next_char (dtp);
1621 l_push_char (dtp, c);
1627 c = next_char (dtp);
1628 l_push_char (dtp, c);
1629 if (c != 'a' && c != 'A')
1631 c = next_char (dtp);
1632 l_push_char (dtp, c);
1633 if (c != 'n' && c != 'N')
1635 c = next_char (dtp);
1636 l_push_char (dtp, c);
1639 if (!is_separator (c))
1642 if (dtp->u.p.namelist_mode)
1644 if (c == ' ' || c =='\n' || c == '\r')
1647 c = next_char (dtp);
1648 while (c == ' ' || c =='\n' || c == '\r');
1650 l_push_char (dtp, c);
1659 push_char (dtp, 'i');
1660 push_char (dtp, 'n');
1661 push_char (dtp, 'f');
1665 push_char (dtp, 'n');
1666 push_char (dtp, 'a');
1667 push_char (dtp, 'n');
1674 if (dtp->u.p.namelist_mode)
1676 dtp->u.p.nml_read_error = 1;
1677 dtp->u.p.line_buffer_enabled = 1;
1678 dtp->u.p.item_count = 0;
1684 if (nml_bad_return (dtp, c))
1689 sprintf (message, "Bad real number in item %d of list input",
1690 dtp->u.p.item_count);
1691 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1695 /* Check the current type against the saved type to make sure they are
1696 compatible. Returns nonzero if incompatible. */
1699 check_type (st_parameter_dt *dtp, bt type, int len)
1703 if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
1705 sprintf (message, "Read type %s where %s was expected for item %d",
1706 type_name (dtp->u.p.saved_type), type_name (type),
1707 dtp->u.p.item_count);
1709 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1713 if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
1716 if (dtp->u.p.saved_length != len)
1719 "Read kind %d %s where kind %d is required for item %d",
1720 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1721 dtp->u.p.item_count);
1722 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1730 /* Top level data transfer subroutine for list reads. Because we have
1731 to deal with repeat counts, the data item is always saved after
1732 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1733 greater than one, we copy the data item multiple times. */
1736 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1743 dtp->u.p.namelist_mode = 0;
1745 dtp->u.p.eof_jump = &eof_jump;
1746 if (setjmp (eof_jump))
1748 generate_error (&dtp->common, LIBERROR_END, NULL);
1752 if (dtp->u.p.first_item)
1754 dtp->u.p.first_item = 0;
1755 dtp->u.p.input_complete = 0;
1756 dtp->u.p.repeat_count = 1;
1757 dtp->u.p.at_eol = 0;
1759 c = eat_spaces (dtp);
1760 if (is_separator (c))
1762 /* Found a null value. */
1763 eat_separator (dtp);
1764 dtp->u.p.repeat_count = 0;
1766 /* eat_separator sets this flag if the separator was a comma. */
1767 if (dtp->u.p.comma_flag)
1770 /* eat_separator sets this flag if the separator was a \n or \r. */
1771 if (dtp->u.p.at_eol)
1772 finish_separator (dtp);
1780 if (dtp->u.p.input_complete)
1783 if (dtp->u.p.repeat_count > 0)
1785 if (check_type (dtp, type, kind))
1790 if (dtp->u.p.at_eol)
1791 finish_separator (dtp);
1795 /* Trailing spaces prior to end of line. */
1796 if (dtp->u.p.at_eol)
1797 finish_separator (dtp);
1800 dtp->u.p.saved_type = BT_NULL;
1801 dtp->u.p.repeat_count = 1;
1807 read_integer (dtp, kind);
1810 read_logical (dtp, kind);
1813 read_character (dtp, kind);
1816 read_real (dtp, kind);
1819 read_complex (dtp, kind, size);
1822 internal_error (&dtp->common, "Bad type for list read");
1825 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1826 dtp->u.p.saved_length = size;
1828 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1832 switch (dtp->u.p.saved_type)
1838 memcpy (p, dtp->u.p.value, size);
1842 if (dtp->u.p.saved_string)
1844 m = ((int) size < dtp->u.p.saved_used)
1845 ? (int) size : dtp->u.p.saved_used;
1846 memcpy (p, dtp->u.p.saved_string, m);
1849 /* Just delimiters encountered, nothing to copy but SPACE. */
1853 memset (((char *) p) + m, ' ', size - m);
1860 if (--dtp->u.p.repeat_count <= 0)
1864 dtp->u.p.eof_jump = NULL;
1869 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1870 size_t size, size_t nelems)
1877 /* Big loop over all the elements. */
1878 for (elem = 0; elem < nelems; elem++)
1880 dtp->u.p.item_count++;
1881 list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
1886 /* Finish a list read. */
1889 finish_list_read (st_parameter_dt *dtp)
1895 if (dtp->u.p.at_eol)
1897 dtp->u.p.at_eol = 0;
1903 c = next_char (dtp);
1910 void namelist_read (st_parameter_dt *dtp)
1912 static void nml_match_name (char *name, int len)
1913 static int nml_query (st_parameter_dt *dtp)
1914 static int nml_get_obj_data (st_parameter_dt *dtp,
1915 namelist_info **prev_nl, char *)
1917 static void nml_untouch_nodes (st_parameter_dt *dtp)
1918 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1920 static int nml_parse_qualifier(descriptor_dimension * ad,
1921 array_loop_spec * ls, int rank, char *)
1922 static void nml_touch_nodes (namelist_info * nl)
1923 static int nml_read_obj (namelist_info *nl, index_type offset,
1924 namelist_info **prev_nl, char *,
1925 index_type clow, index_type chigh)
1929 /* Inputs a rank-dimensional qualifier, which can contain
1930 singlets, doublets, triplets or ':' with the standard meanings. */
1933 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1934 array_loop_spec *ls, int rank, char *parse_err_msg,
1941 int is_array_section, is_char;
1945 is_array_section = 0;
1946 dtp->u.p.expanded_read = 0;
1948 /* See if this is a character substring qualifier we are looking for. */
1955 /* The next character in the stream should be the '('. */
1957 c = next_char (dtp);
1959 /* Process the qualifier, by dimension and triplet. */
1961 for (dim=0; dim < rank; dim++ )
1963 for (indx=0; indx<3; indx++)
1969 /* Process a potential sign. */
1970 c = next_char (dtp);
1981 unget_char (dtp, c);
1985 /* Process characters up to the next ':' , ',' or ')'. */
1988 c = next_char (dtp);
1993 is_array_section = 1;
1997 if ((c==',' && dim == rank -1)
1998 || (c==')' && dim < rank -1))
2001 sprintf (parse_err_msg, "Bad substring qualifier");
2003 sprintf (parse_err_msg, "Bad number of index fields");
2012 case ' ': case '\t':
2014 c = next_char (dtp);
2019 sprintf (parse_err_msg,
2020 "Bad character in substring qualifier");
2022 sprintf (parse_err_msg, "Bad character in index");
2026 if ((c == ',' || c == ')') && indx == 0
2027 && dtp->u.p.saved_string == 0)
2030 sprintf (parse_err_msg, "Null substring qualifier");
2032 sprintf (parse_err_msg, "Null index field");
2036 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2037 || (indx == 2 && dtp->u.p.saved_string == 0))
2040 sprintf (parse_err_msg, "Bad substring qualifier");
2042 sprintf (parse_err_msg, "Bad index triplet");
2046 if (is_char && !is_array_section)
2048 sprintf (parse_err_msg,
2049 "Missing colon in substring qualifier");
2053 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2055 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2056 || (indx==1 && dtp->u.p.saved_string == 0))
2062 /* Now read the index. */
2063 if (convert_integer (dtp, sizeof(ssize_t), neg))
2066 sprintf (parse_err_msg, "Bad integer substring qualifier");
2068 sprintf (parse_err_msg, "Bad integer in index");
2074 /* Feed the index values to the triplet arrays. */
2078 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2080 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2082 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2085 /* Singlet or doublet indices. */
2086 if (c==',' || c==')')
2090 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2092 /* If -std=f95/2003 or an array section is specified,
2093 do not allow excess data to be processed. */
2094 if (is_array_section == 1
2095 || compile_options.allow_std < GFC_STD_GNU)
2096 ls[dim].end = ls[dim].start;
2098 dtp->u.p.expanded_read = 1;
2101 /* Check for non-zero rank. */
2102 if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2109 /* Check the values of the triplet indices. */
2110 if ((ls[dim].start > (ssize_t)ad[dim].ubound)
2111 || (ls[dim].start < (ssize_t)ad[dim].lbound)
2112 || (ls[dim].end > (ssize_t)ad[dim].ubound)
2113 || (ls[dim].end < (ssize_t)ad[dim].lbound))
2116 sprintf (parse_err_msg, "Substring out of range");
2118 sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2122 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2123 || (ls[dim].step == 0))
2125 sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2129 /* Initialise the loop index counter. */
2130 ls[dim].idx = ls[dim].start;
2140 static namelist_info *
2141 find_nml_node (st_parameter_dt *dtp, char * var_name)
2143 namelist_info * t = dtp->u.p.ionml;
2146 if (strcmp (var_name, t->var_name) == 0)
2156 /* Visits all the components of a derived type that have
2157 not explicitly been identified in the namelist input.
2158 touched is set and the loop specification initialised
2159 to default values */
2162 nml_touch_nodes (namelist_info * nl)
2164 index_type len = strlen (nl->var_name) + 1;
2166 char * ext_name = (char*)get_mem (len + 1);
2167 memcpy (ext_name, nl->var_name, len-1);
2168 memcpy (ext_name + len - 1, "%", 2);
2169 for (nl = nl->next; nl; nl = nl->next)
2171 if (strncmp (nl->var_name, ext_name, len) == 0)
2174 for (dim=0; dim < nl->var_rank; dim++)
2176 nl->ls[dim].step = 1;
2177 nl->ls[dim].end = nl->dim[dim].ubound;
2178 nl->ls[dim].start = nl->dim[dim].lbound;
2179 nl->ls[dim].idx = nl->ls[dim].start;
2185 free_mem (ext_name);
2189 /* Resets touched for the entire list of nml_nodes, ready for a
2193 nml_untouch_nodes (st_parameter_dt *dtp)
2196 for (t = dtp->u.p.ionml; t; t = t->next)
2201 /* Attempts to input name to namelist name. Returns
2202 dtp->u.p.nml_read_error = 1 on no match. */
2205 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2209 dtp->u.p.nml_read_error = 0;
2210 for (i = 0; i < len; i++)
2212 c = next_char (dtp);
2213 if (tolower (c) != tolower (name[i]))
2215 dtp->u.p.nml_read_error = 1;
2221 /* If the namelist read is from stdin, output the current state of the
2222 namelist to stdout. This is used to implement the non-standard query
2223 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2224 the names alone are printed. */
2227 nml_query (st_parameter_dt *dtp, char c)
2229 gfc_unit * temp_unit;
2234 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2237 /* Store the current unit and transfer to stdout. */
2239 temp_unit = dtp->u.p.current_unit;
2240 dtp->u.p.current_unit = find_unit (options.stdout_unit);
2242 if (dtp->u.p.current_unit)
2244 dtp->u.p.mode = WRITING;
2245 next_record (dtp, 0);
2247 /* Write the namelist in its entirety. */
2250 namelist_write (dtp);
2252 /* Or write the list of names. */
2256 /* "&namelist_name\n" */
2258 len = dtp->namelist_name_len;
2260 p = write_block (dtp, len + 3);
2262 p = write_block (dtp, len + 2);
2267 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2269 memcpy ((char*)(p + len + 1), "\r\n", 2);
2271 memcpy ((char*)(p + len + 1), "\n", 1);
2273 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2277 len = strlen (nl->var_name);
2279 p = write_block (dtp, len + 3);
2281 p = write_block (dtp, len + 2);
2286 memcpy ((char*)(p + 1), nl->var_name, len);
2288 memcpy ((char*)(p + len + 1), "\r\n", 2);
2290 memcpy ((char*)(p + len + 1), "\n", 1);
2297 p = write_block (dtp, 6);
2299 p = write_block (dtp, 5);
2304 memcpy (p, "&end\r\n", 6);
2306 memcpy (p, "&end\n", 5);
2310 /* Flush the stream to force immediate output. */
2312 flush (dtp->u.p.current_unit->s);
2313 unlock_unit (dtp->u.p.current_unit);
2318 /* Restore the current unit. */
2320 dtp->u.p.current_unit = temp_unit;
2321 dtp->u.p.mode = READING;
2325 /* Reads and stores the input for the namelist object nl. For an array,
2326 the function loops over the ranges defined by the loop specification.
2327 This default to all the data or to the specification from a qualifier.
2328 nml_read_obj recursively calls itself to read derived types. It visits
2329 all its own components but only reads data for those that were touched
2330 when the name was parsed. If a read error is encountered, an attempt is
2331 made to return to read a new object name because the standard allows too
2332 little data to be available. On the other hand, too much data is an
2336 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2337 namelist_info **pprev_nl, char *nml_err_msg,
2338 index_type clow, index_type chigh)
2340 namelist_info * cmp;
2347 index_type obj_name_len;
2350 /* This object not touched in name parsing. */
2355 dtp->u.p.repeat_count = 0;
2361 case GFC_DTYPE_INTEGER:
2362 case GFC_DTYPE_LOGICAL:
2366 case GFC_DTYPE_REAL:
2367 dlen = size_from_real_kind (len);
2370 case GFC_DTYPE_COMPLEX:
2371 dlen = size_from_complex_kind (len);
2374 case GFC_DTYPE_CHARACTER:
2375 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2384 /* Update the pointer to the data, using the current index vector */
2386 pdata = (void*)(nl->mem_pos + offset);
2387 for (dim = 0; dim < nl->var_rank; dim++)
2388 pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
2389 nl->dim[dim].stride * nl->size);
2391 /* Reset the error flag and try to read next value, if
2392 dtp->u.p.repeat_count=0 */
2394 dtp->u.p.nml_read_error = 0;
2396 if (--dtp->u.p.repeat_count <= 0)
2398 if (dtp->u.p.input_complete)
2400 if (dtp->u.p.at_eol)
2401 finish_separator (dtp);
2402 if (dtp->u.p.input_complete)
2405 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2406 after the switch block. */
2408 dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
2413 case GFC_DTYPE_INTEGER:
2414 read_integer (dtp, len);
2417 case GFC_DTYPE_LOGICAL:
2418 read_logical (dtp, len);
2421 case GFC_DTYPE_CHARACTER:
2422 read_character (dtp, len);
2425 case GFC_DTYPE_REAL:
2426 read_real (dtp, len);
2429 case GFC_DTYPE_COMPLEX:
2430 read_complex (dtp, len, dlen);
2433 case GFC_DTYPE_DERIVED:
2434 obj_name_len = strlen (nl->var_name) + 1;
2435 obj_name = get_mem (obj_name_len+1);
2436 memcpy (obj_name, nl->var_name, obj_name_len-1);
2437 memcpy (obj_name + obj_name_len - 1, "%", 2);
2439 /* If reading a derived type, disable the expanded read warning
2440 since a single object can have multiple reads. */
2441 dtp->u.p.expanded_read = 0;
2443 /* Now loop over the components. Update the component pointer
2444 with the return value from nml_write_obj. This loop jumps
2445 past nested derived types by testing if the potential
2446 component name contains '%'. */
2448 for (cmp = nl->next;
2450 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2451 !strchr (cmp->var_name + obj_name_len, '%');
2455 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2456 pprev_nl, nml_err_msg, clow, chigh)
2459 free_mem (obj_name);
2463 if (dtp->u.p.input_complete)
2465 free_mem (obj_name);
2470 free_mem (obj_name);
2474 sprintf (nml_err_msg, "Bad type for namelist object %s",
2476 internal_error (&dtp->common, nml_err_msg);
2481 /* The standard permits array data to stop short of the number of
2482 elements specified in the loop specification. In this case, we
2483 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2484 nml_get_obj_data and an attempt is made to read object name. */
2487 if (dtp->u.p.nml_read_error)
2489 dtp->u.p.expanded_read = 0;
2493 if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
2495 dtp->u.p.expanded_read = 0;
2499 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2500 This comes about because the read functions return BT_types. */
2502 switch (dtp->u.p.saved_type)
2509 memcpy (pdata, dtp->u.p.value, dlen);
2513 m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2514 pdata = (void*)( pdata + clow - 1 );
2515 memcpy (pdata, dtp->u.p.saved_string, m);
2517 memset ((void*)( pdata + m ), ' ', dlen - m);
2524 /* Warn if a non-standard expanded read occurs. A single read of a
2525 single object is acceptable. If a second read occurs, issue a warning
2526 and set the flag to zero to prevent further warnings. */
2527 if (dtp->u.p.expanded_read == 2)
2529 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2530 dtp->u.p.expanded_read = 0;
2533 /* If the expanded read warning flag is set, increment it,
2534 indicating that a single read has occurred. */
2535 if (dtp->u.p.expanded_read >= 1)
2536 dtp->u.p.expanded_read++;
2538 /* Break out of loop if scalar. */
2542 /* Now increment the index vector. */
2547 for (dim = 0; dim < nl->var_rank; dim++)
2549 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2551 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2553 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2555 nl->ls[dim].idx = nl->ls[dim].start;
2559 } while (!nml_carry);
2561 if (dtp->u.p.repeat_count > 1)
2563 sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
2574 /* Parses the object name, including array and substring qualifiers. It
2575 iterates over derived type components, touching those components and
2576 setting their loop specifications, if there is a qualifier. If the
2577 object is itself a derived type, its components and subcomponents are
2578 touched. nml_read_obj is called at the end and this reads the data in
2579 the manner specified by the object name. */
2582 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2587 namelist_info * first_nl = NULL;
2588 namelist_info * root_nl = NULL;
2589 int dim, parsed_rank;
2591 char parse_err_msg[30];
2592 index_type clow, chigh;
2593 int non_zero_rank_count;
2595 /* Look for end of input or object name. If '?' or '=?' are encountered
2596 in stdin, print the node names or the namelist to stdout. */
2598 eat_separator (dtp);
2599 if (dtp->u.p.input_complete)
2602 if (dtp->u.p.at_eol)
2603 finish_separator (dtp);
2604 if (dtp->u.p.input_complete)
2607 c = next_char (dtp);
2611 c = next_char (dtp);
2614 sprintf (nml_err_msg, "namelist read: misplaced = sign");
2617 nml_query (dtp, '=');
2621 nml_query (dtp, '?');
2626 nml_match_name (dtp, "end", 3);
2627 if (dtp->u.p.nml_read_error)
2629 sprintf (nml_err_msg, "namelist not terminated with / or &end");
2633 dtp->u.p.input_complete = 1;
2640 /* Untouch all nodes of the namelist and reset the flag that is set for
2641 derived type components. */
2643 nml_untouch_nodes (dtp);
2645 non_zero_rank_count = 0;
2647 /* Get the object name - should '!' and '\n' be permitted separators? */
2655 if (!is_separator (c))
2656 push_char (dtp, tolower(c));
2657 c = next_char (dtp);
2658 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2660 unget_char (dtp, c);
2662 /* Check that the name is in the namelist and get pointer to object.
2663 Three error conditions exist: (i) An attempt is being made to
2664 identify a non-existent object, following a failed data read or
2665 (ii) The object name does not exist or (iii) Too many data items
2666 are present for an object. (iii) gives the same error message
2669 push_char (dtp, '\0');
2673 size_t var_len = strlen (root_nl->var_name);
2675 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2676 char ext_name[var_len + saved_len + 1];
2678 memcpy (ext_name, root_nl->var_name, var_len);
2679 if (dtp->u.p.saved_string)
2680 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2681 ext_name[var_len + saved_len] = '\0';
2682 nl = find_nml_node (dtp, ext_name);
2685 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2689 if (dtp->u.p.nml_read_error && *pprev_nl)
2690 sprintf (nml_err_msg, "Bad data for namelist object %s",
2691 (*pprev_nl)->var_name);
2694 sprintf (nml_err_msg, "Cannot match namelist object name %s",
2695 dtp->u.p.saved_string);
2700 /* Get the length, data length, base pointer and rank of the variable.
2701 Set the default loop specification first. */
2703 for (dim=0; dim < nl->var_rank; dim++)
2705 nl->ls[dim].step = 1;
2706 nl->ls[dim].end = nl->dim[dim].ubound;
2707 nl->ls[dim].start = nl->dim[dim].lbound;
2708 nl->ls[dim].idx = nl->ls[dim].start;
2711 /* Check to see if there is a qualifier: if so, parse it.*/
2713 if (c == '(' && nl->var_rank)
2716 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2717 parse_err_msg, &parsed_rank) == FAILURE)
2719 sprintf (nml_err_msg, "%s for namelist variable %s",
2720 parse_err_msg, nl->var_name);
2724 if (parsed_rank > 0)
2725 non_zero_rank_count++;
2727 c = next_char (dtp);
2728 unget_char (dtp, c);
2730 else if (nl->var_rank > 0)
2731 non_zero_rank_count++;
2733 /* Now parse a derived type component. The root namelist_info address
2734 is backed up, as is the previous component level. The component flag
2735 is set and the iteration is made by jumping back to get_name. */
2739 if (nl->type != GFC_DTYPE_DERIVED)
2741 sprintf (nml_err_msg, "Attempt to get derived component for %s",
2746 if (!component_flag)
2751 c = next_char (dtp);
2755 /* Parse a character qualifier, if present. chigh = 0 is a default
2756 that signals that the string length = string_length. */
2761 if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2763 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2764 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2766 if (nml_parse_qualifier (dtp, chd, ind, -1, parse_err_msg, &parsed_rank)
2769 sprintf (nml_err_msg, "%s for namelist variable %s",
2770 parse_err_msg, nl->var_name);
2774 clow = ind[0].start;
2777 if (ind[0].step != 1)
2779 sprintf (nml_err_msg,
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 sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
2803 " namelist object %s", nl->var_name);
2807 /* Make sure there is no more than one non-zero rank object. */
2808 if (non_zero_rank_count > 1)
2810 sprintf (nml_err_msg, "Multiple sub-objects with non-zero rank in"
2811 " namelist object %s", nl->var_name);
2812 non_zero_rank_count = 0;
2816 /* According to the standard, an equal sign MUST follow an object name. The
2817 following is possibly lax - it allows comments, blank lines and so on to
2818 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2822 eat_separator (dtp);
2823 if (dtp->u.p.input_complete)
2826 if (dtp->u.p.at_eol)
2827 finish_separator (dtp);
2828 if (dtp->u.p.input_complete)
2831 c = next_char (dtp);
2835 sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
2840 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
2850 /* Entry point for namelist input. Goes through input until namelist name
2851 is matched. Then cycles through nml_get_obj_data until the input is
2852 completed or there is an error. */
2855 namelist_read (st_parameter_dt *dtp)
2859 char nml_err_msg[100];
2860 /* Pointer to the previously read object, in case attempt is made to read
2861 new object name. Should this fail, error message can give previous
2863 namelist_info *prev_nl = NULL;
2865 dtp->u.p.namelist_mode = 1;
2866 dtp->u.p.input_complete = 0;
2867 dtp->u.p.expanded_read = 0;
2869 dtp->u.p.eof_jump = &eof_jump;
2870 if (setjmp (eof_jump))
2872 dtp->u.p.eof_jump = NULL;
2873 generate_error (&dtp->common, LIBERROR_END, NULL);
2877 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2878 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2879 node names or namelist on stdout. */
2882 switch (c = next_char (dtp))
2893 c = next_char (dtp);
2895 nml_query (dtp, '=');
2897 unget_char (dtp, c);
2901 nml_query (dtp, '?');
2907 /* Match the name of the namelist. */
2909 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2911 if (dtp->u.p.nml_read_error)
2914 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2915 c = next_char (dtp);
2916 if (!is_separator(c))
2918 unget_char (dtp, c);
2922 /* Ready to read namelist objects. If there is an error in input
2923 from stdin, output the error message and continue. */
2925 while (!dtp->u.p.input_complete)
2927 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
2931 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2934 u = find_unit (options.stderr_unit);
2935 st_printf ("%s\n", nml_err_msg);
2945 dtp->u.p.eof_jump = NULL;
2950 /* All namelist error calls return from here */
2954 dtp->u.p.eof_jump = NULL;
2957 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);