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 if (sread (dtp->u.p.current_unit->s, &c, &length) != 0)
211 generate_error (&dtp->common, LIBERROR_OS, NULL);
215 if (is_stream_io (dtp) && length == 1)
216 dtp->u.p.current_unit->strm_pos++;
218 if (is_internal_unit (dtp))
220 if (is_array_io (dtp))
222 /* Check whether we hit EOF. */
225 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
228 dtp->u.p.current_unit->bytes_left--;
233 longjmp (*dtp->u.p.eof_jump, 1);
245 if (dtp->u.p.advance_status == ADVANCE_NO)
247 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
248 longjmp (*dtp->u.p.eof_jump, 1);
249 dtp->u.p.current_unit->endfile = AT_ENDFILE;
253 longjmp (*dtp->u.p.eof_jump, 1);
257 dtp->u.p.at_eol = (c == '\n' || c == '\r');
262 /* Push a character back onto the input. */
265 unget_char (st_parameter_dt *dtp, char c)
267 dtp->u.p.last_char = c;
271 /* Skip over spaces in the input. Returns the nonspace character that
272 terminated the eating and also places it back on the input. */
275 eat_spaces (st_parameter_dt *dtp)
283 while (c == ' ' || c == '\t');
290 /* This function reads characters through to the end of the current line and
291 just ignores them. */
294 eat_line (st_parameter_dt *dtp)
297 if (!is_internal_unit (dtp))
304 /* Skip over a separator. Technically, we don't always eat the whole
305 separator. This is because if we've processed the last input item,
306 then a separator is unnecessary. Plus the fact that operating
307 systems usually deliver console input on a line basis.
309 The upshot is that if we see a newline as part of reading a
310 separator, we stop reading. If there are more input items, we
311 continue reading the separator with finish_separator() which takes
312 care of the fact that we may or may not have seen a comma as part
316 eat_separator (st_parameter_dt *dtp)
321 dtp->u.p.comma_flag = 0;
327 if (dtp->u.p.decimal_status == DECIMAL_COMMA)
334 dtp->u.p.comma_flag = 1;
339 dtp->u.p.input_complete = 1;
353 if (dtp->u.p.namelist_mode)
369 while (c == '\n' || c == '\r' || c == ' ');
375 if (dtp->u.p.namelist_mode)
376 { /* Eat a namelist comment. */
384 /* Fall Through... */
393 /* Finish processing a separator that was interrupted by a newline.
394 If we're here, then another data item is present, so we finish what
395 we started on the previous line. */
398 finish_separator (st_parameter_dt *dtp)
409 if (dtp->u.p.comma_flag)
413 c = eat_spaces (dtp);
414 if (c == '\n' || c == '\r')
421 dtp->u.p.input_complete = 1;
422 if (!dtp->u.p.namelist_mode)
431 if (dtp->u.p.namelist_mode)
447 /* This function is needed to catch bad conversions so that namelist can
448 attempt to see if dtp->u.p.saved_string contains a new object name rather
452 nml_bad_return (st_parameter_dt *dtp, char c)
454 if (dtp->u.p.namelist_mode)
456 dtp->u.p.nml_read_error = 1;
463 /* Convert an unsigned string to an integer. The length value is -1
464 if we are working on a repeat count. Returns nonzero if we have a
465 range problem. As a side effect, frees the dtp->u.p.saved_string. */
468 convert_integer (st_parameter_dt *dtp, int length, int negative)
470 char c, *buffer, message[100];
472 GFC_INTEGER_LARGEST v, max, max10;
474 buffer = dtp->u.p.saved_string;
477 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
502 set_integer (dtp->u.p.value, v, length);
506 dtp->u.p.repeat_count = v;
508 if (dtp->u.p.repeat_count == 0)
510 sprintf (message, "Zero repeat count in item %d of list input",
511 dtp->u.p.item_count);
513 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
523 sprintf (message, "Repeat count overflow in item %d of list input",
524 dtp->u.p.item_count);
526 sprintf (message, "Integer overflow while reading item %d",
527 dtp->u.p.item_count);
530 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
536 /* Parse a repeat count for logical and complex values which cannot
537 begin with a digit. Returns nonzero if we are done, zero if we
538 should continue on. */
541 parse_repeat (st_parameter_dt *dtp)
543 char c, message[100];
569 repeat = 10 * repeat + c - '0';
571 if (repeat > MAX_REPEAT)
574 "Repeat count overflow in item %d of list input",
575 dtp->u.p.item_count);
577 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
587 "Zero repeat count in item %d of list input",
588 dtp->u.p.item_count);
590 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
602 dtp->u.p.repeat_count = repeat;
609 sprintf (message, "Bad repeat count in item %d of list input",
610 dtp->u.p.item_count);
611 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
616 /* To read a logical we have to look ahead in the input stream to make sure
617 there is not an equal sign indicating a variable name. To do this we use
618 line_buffer to point to a temporary buffer, pushing characters there for
619 possible later reading. */
622 l_push_char (st_parameter_dt *dtp, char c)
624 if (dtp->u.p.line_buffer == NULL)
626 dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
627 memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
630 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
634 /* Read a logical character on the input. */
637 read_logical (st_parameter_dt *dtp, int length)
639 char c, message[100];
642 if (parse_repeat (dtp))
645 c = tolower (next_char (dtp));
646 l_push_char (dtp, c);
652 l_push_char (dtp, c);
654 if (!is_separator(c))
662 l_push_char (dtp, c);
664 if (!is_separator(c))
671 c = tolower (next_char (dtp));
689 return; /* Null value. */
692 /* Save the character in case it is the beginning
693 of the next object name. */
698 dtp->u.p.saved_type = BT_LOGICAL;
699 dtp->u.p.saved_length = length;
701 /* Eat trailing garbage. */
706 while (!is_separator (c));
710 set_integer ((int *) dtp->u.p.value, v, length);
717 for(i = 0; i < 63; i++)
722 /* All done if this is not a namelist read. */
723 if (!dtp->u.p.namelist_mode)
736 l_push_char (dtp, c);
739 dtp->u.p.nml_read_error = 1;
740 dtp->u.p.line_buffer_enabled = 1;
741 dtp->u.p.item_count = 0;
751 if (nml_bad_return (dtp, c))
756 sprintf (message, "Bad logical value while reading item %d",
757 dtp->u.p.item_count);
758 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
763 dtp->u.p.saved_type = BT_LOGICAL;
764 dtp->u.p.saved_length = length;
765 set_integer ((int *) dtp->u.p.value, v, length);
771 /* Reading integers is tricky because we can actually be reading a
772 repeat count. We have to store the characters in a buffer because
773 we could be reading an integer that is larger than the default int
774 used for repeat counts. */
777 read_integer (st_parameter_dt *dtp, int length)
779 char c, message[100];
789 /* Fall through... */
795 CASE_SEPARATORS: /* Single null. */
808 /* Take care of what may be a repeat count. */
820 push_char (dtp, '\0');
823 CASE_SEPARATORS: /* Not a repeat count. */
832 if (convert_integer (dtp, -1, 0))
835 /* Get the real integer. */
850 /* Fall through... */
881 if (nml_bad_return (dtp, c))
886 sprintf (message, "Bad integer for item %d in list input",
887 dtp->u.p.item_count);
888 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
896 push_char (dtp, '\0');
897 if (convert_integer (dtp, length, negative))
904 dtp->u.p.saved_type = BT_INTEGER;
908 /* Read a character variable. */
911 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
913 char c, quote, message[100];
915 quote = ' '; /* Space means no quote character. */
925 unget_char (dtp, c); /* NULL value. */
935 if (dtp->u.p.namelist_mode)
937 if (dtp->u.p.delim_status == DELIM_APOSTROPHE
938 || dtp->u.p.delim_status == DELIM_QUOTE
939 || c == '&' || c == '$' || c == '/')
945 /* Check to see if we are seeing a namelist object name by using the
946 line buffer and looking ahead for an '=' or '('. */
947 l_push_char (dtp, c);
950 for(i = 0; i < 63; i++)
960 l_push_char (dtp, c);
961 dtp->u.p.item_count = 0;
962 dtp->u.p.line_buffer_enabled = 1;
967 l_push_char (dtp, c);
969 if (c == '=' || c == '(')
971 dtp->u.p.item_count = 0;
972 dtp->u.p.nml_read_error = 1;
973 dtp->u.p.line_buffer_enabled = 1;
978 /* The string is too long to be a valid object name so assume that it
979 is a string to be read in as a value. */
980 dtp->u.p.item_count = 0;
981 dtp->u.p.line_buffer_enabled = 1;
989 /* Deal with a possible repeat count. */
1001 unget_char (dtp, c);
1002 goto done; /* String was only digits! */
1005 push_char (dtp, '\0');
1010 goto get_string; /* Not a repeat count after all. */
1015 if (convert_integer (dtp, -1, 0))
1018 /* Now get the real string. */
1020 c = next_char (dtp);
1024 unget_char (dtp, c); /* Repeated NULL values. */
1025 eat_separator (dtp);
1041 c = next_char (dtp);
1052 /* See if we have a doubled quote character or the end of
1055 c = next_char (dtp);
1058 push_char (dtp, quote);
1062 unget_char (dtp, c);
1068 unget_char (dtp, c);
1072 if (c != '\n' && c != '\r')
1082 /* At this point, we have to have a separator, or else the string is
1085 c = next_char (dtp);
1086 if (is_separator (c))
1088 unget_char (dtp, c);
1089 eat_separator (dtp);
1090 dtp->u.p.saved_type = BT_CHARACTER;
1096 sprintf (message, "Invalid string input in item %d",
1097 dtp->u.p.item_count);
1098 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1103 /* Parse a component of a complex constant or a real number that we
1104 are sure is already there. This is a straight real number parser. */
1107 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1109 char c, message[100];
1112 c = next_char (dtp);
1113 if (c == '-' || c == '+')
1116 c = next_char (dtp);
1119 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1122 if (!isdigit (c) && c != '.')
1124 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1132 seen_dp = (c == '.') ? 1 : 0;
1136 c = next_char (dtp);
1137 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1157 push_char (dtp, 'e');
1162 push_char (dtp, 'e');
1164 c = next_char (dtp);
1168 unget_char (dtp, c);
1177 c = next_char (dtp);
1178 if (c != '-' && c != '+')
1179 push_char (dtp, '+');
1183 c = next_char (dtp);
1194 c = next_char (dtp);
1202 unget_char (dtp, c);
1211 unget_char (dtp, c);
1212 push_char (dtp, '\0');
1214 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1220 /* Match INF and Infinity. */
1221 if ((c == 'i' || c == 'I')
1222 && ((c = next_char (dtp)) == 'n' || c == 'N')
1223 && ((c = next_char (dtp)) == 'f' || c == 'F'))
1225 c = next_char (dtp);
1226 if ((c != 'i' && c != 'I')
1227 || ((c == 'i' || c == 'I')
1228 && ((c = next_char (dtp)) == 'n' || c == 'N')
1229 && ((c = next_char (dtp)) == 'i' || c == 'I')
1230 && ((c = next_char (dtp)) == 't' || c == 'T')
1231 && ((c = next_char (dtp)) == 'y' || c == 'Y')
1232 && (c = next_char (dtp))))
1234 if (is_separator (c))
1235 unget_char (dtp, c);
1236 push_char (dtp, 'i');
1237 push_char (dtp, 'n');
1238 push_char (dtp, 'f');
1242 else if (((c = next_char (dtp)) == 'a' || c == 'A')
1243 && ((c = next_char (dtp)) == 'n' || c == 'N')
1244 && (c = next_char (dtp)))
1246 if (is_separator (c))
1247 unget_char (dtp, c);
1248 push_char (dtp, 'n');
1249 push_char (dtp, 'a');
1250 push_char (dtp, 'n');
1256 if (nml_bad_return (dtp, c))
1261 sprintf (message, "Bad floating point number for item %d",
1262 dtp->u.p.item_count);
1263 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1269 /* Reading a complex number is straightforward because we can tell
1270 what it is right away. */
1273 read_complex (st_parameter_dt *dtp, int kind, size_t size)
1278 if (parse_repeat (dtp))
1281 c = next_char (dtp);
1288 unget_char (dtp, c);
1289 eat_separator (dtp);
1297 if (parse_real (dtp, dtp->u.p.value, kind))
1302 c = next_char (dtp);
1303 if (c == '\n' || c== '\r')
1306 unget_char (dtp, c);
1309 != (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
1314 c = next_char (dtp);
1315 if (c == '\n' || c== '\r')
1318 unget_char (dtp, c);
1320 if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
1324 if (next_char (dtp) != ')')
1327 c = next_char (dtp);
1328 if (!is_separator (c))
1331 unget_char (dtp, c);
1332 eat_separator (dtp);
1335 dtp->u.p.saved_type = BT_COMPLEX;
1340 if (nml_bad_return (dtp, c))
1345 sprintf (message, "Bad complex value in item %d of list input",
1346 dtp->u.p.item_count);
1347 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1351 /* Parse a real number with a possible repeat count. */
1354 read_real (st_parameter_dt *dtp, int length)
1356 char c, message[100];
1362 c = next_char (dtp);
1363 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1381 unget_char (dtp, c); /* Single null. */
1382 eat_separator (dtp);
1395 /* Get the digit string that might be a repeat count. */
1399 c = next_char (dtp);
1400 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1424 push_char (dtp, 'e');
1426 c = next_char (dtp);
1430 push_char (dtp, '\0');
1434 if (c != '\n' && c != ',' && c != '\r' && c != ';')
1435 unget_char (dtp, c);
1444 if (convert_integer (dtp, -1, 0))
1447 /* Now get the number itself. */
1449 c = next_char (dtp);
1450 if (is_separator (c))
1451 { /* Repeated null value. */
1452 unget_char (dtp, c);
1453 eat_separator (dtp);
1457 if (c != '-' && c != '+')
1458 push_char (dtp, '+');
1463 c = next_char (dtp);
1466 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1469 if (!isdigit (c) && c != '.')
1471 if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
1490 c = next_char (dtp);
1491 if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
1518 push_char (dtp, 'e');
1520 c = next_char (dtp);
1529 push_char (dtp, 'e');
1531 c = next_char (dtp);
1532 if (c != '+' && c != '-')
1533 push_char (dtp, '+');
1537 c = next_char (dtp);
1547 c = next_char (dtp);
1564 unget_char (dtp, c);
1565 eat_separator (dtp);
1566 push_char (dtp, '\0');
1567 if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
1571 dtp->u.p.saved_type = BT_REAL;
1575 l_push_char (dtp, c);
1578 /* Match INF and Infinity. */
1579 if (c == 'i' || c == 'I')
1581 c = next_char (dtp);
1582 l_push_char (dtp, c);
1583 if (c != 'n' && c != 'N')
1585 c = next_char (dtp);
1586 l_push_char (dtp, c);
1587 if (c != 'f' && c != 'F')
1589 c = next_char (dtp);
1590 l_push_char (dtp, c);
1591 if (!is_separator (c))
1593 if (c != 'i' && c != 'I')
1595 c = next_char (dtp);
1596 l_push_char (dtp, c);
1597 if (c != 'n' && c != 'N')
1599 c = next_char (dtp);
1600 l_push_char (dtp, c);
1601 if (c != 'i' && c != 'I')
1603 c = next_char (dtp);
1604 l_push_char (dtp, c);
1605 if (c != 't' && c != 'T')
1607 c = next_char (dtp);
1608 l_push_char (dtp, c);
1609 if (c != 'y' && c != 'Y')
1611 c = next_char (dtp);
1612 l_push_char (dtp, c);
1618 c = next_char (dtp);
1619 l_push_char (dtp, c);
1620 if (c != 'a' && c != 'A')
1622 c = next_char (dtp);
1623 l_push_char (dtp, c);
1624 if (c != 'n' && c != 'N')
1626 c = next_char (dtp);
1627 l_push_char (dtp, c);
1630 if (!is_separator (c))
1633 if (dtp->u.p.namelist_mode)
1635 if (c == ' ' || c =='\n' || c == '\r')
1638 c = next_char (dtp);
1639 while (c == ' ' || c =='\n' || c == '\r');
1641 l_push_char (dtp, c);
1650 push_char (dtp, 'i');
1651 push_char (dtp, 'n');
1652 push_char (dtp, 'f');
1656 push_char (dtp, 'n');
1657 push_char (dtp, 'a');
1658 push_char (dtp, 'n');
1665 if (dtp->u.p.namelist_mode)
1667 dtp->u.p.nml_read_error = 1;
1668 dtp->u.p.line_buffer_enabled = 1;
1669 dtp->u.p.item_count = 0;
1675 if (nml_bad_return (dtp, c))
1680 sprintf (message, "Bad real number in item %d of list input",
1681 dtp->u.p.item_count);
1682 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1686 /* Check the current type against the saved type to make sure they are
1687 compatible. Returns nonzero if incompatible. */
1690 check_type (st_parameter_dt *dtp, bt type, int len)
1694 if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
1696 sprintf (message, "Read type %s where %s was expected for item %d",
1697 type_name (dtp->u.p.saved_type), type_name (type),
1698 dtp->u.p.item_count);
1700 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1704 if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
1707 if (dtp->u.p.saved_length != len)
1710 "Read kind %d %s where kind %d is required for item %d",
1711 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1712 dtp->u.p.item_count);
1713 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1721 /* Top level data transfer subroutine for list reads. Because we have
1722 to deal with repeat counts, the data item is always saved after
1723 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1724 greater than one, we copy the data item multiple times. */
1727 list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
1728 int kind, size_t size)
1734 dtp->u.p.namelist_mode = 0;
1736 dtp->u.p.eof_jump = &eof_jump;
1737 if (setjmp (eof_jump))
1739 generate_error (&dtp->common, LIBERROR_END, NULL);
1743 if (dtp->u.p.first_item)
1745 dtp->u.p.first_item = 0;
1746 dtp->u.p.input_complete = 0;
1747 dtp->u.p.repeat_count = 1;
1748 dtp->u.p.at_eol = 0;
1750 c = eat_spaces (dtp);
1751 if (is_separator (c))
1753 /* Found a null value. */
1754 eat_separator (dtp);
1755 dtp->u.p.repeat_count = 0;
1757 /* eat_separator sets this flag if the separator was a comma. */
1758 if (dtp->u.p.comma_flag)
1761 /* eat_separator sets this flag if the separator was a \n or \r. */
1762 if (dtp->u.p.at_eol)
1763 finish_separator (dtp);
1771 if (dtp->u.p.input_complete)
1774 if (dtp->u.p.repeat_count > 0)
1776 if (check_type (dtp, type, kind))
1781 if (dtp->u.p.at_eol)
1782 finish_separator (dtp);
1786 /* Trailing spaces prior to end of line. */
1787 if (dtp->u.p.at_eol)
1788 finish_separator (dtp);
1791 dtp->u.p.saved_type = BT_NULL;
1792 dtp->u.p.repeat_count = 1;
1798 read_integer (dtp, kind);
1801 read_logical (dtp, kind);
1804 read_character (dtp, kind);
1807 read_real (dtp, kind);
1810 read_complex (dtp, kind, size);
1813 internal_error (&dtp->common, "Bad type for list read");
1816 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1817 dtp->u.p.saved_length = size;
1819 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1823 switch (dtp->u.p.saved_type)
1829 memcpy (p, dtp->u.p.value, size);
1833 if (dtp->u.p.saved_string)
1835 m = ((int) size < dtp->u.p.saved_used)
1836 ? (int) size : dtp->u.p.saved_used;
1837 memcpy (p, dtp->u.p.saved_string, m);
1840 /* Just delimiters encountered, nothing to copy but SPACE. */
1844 memset (((char *) p) + m, ' ', size - m);
1851 if (--dtp->u.p.repeat_count <= 0)
1855 dtp->u.p.eof_jump = NULL;
1860 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1861 size_t size, size_t nelems)
1868 /* Big loop over all the elements. */
1869 for (elem = 0; elem < nelems; elem++)
1871 dtp->u.p.item_count++;
1872 list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
1877 /* Finish a list read. */
1880 finish_list_read (st_parameter_dt *dtp)
1886 if (dtp->u.p.at_eol)
1888 dtp->u.p.at_eol = 0;
1894 c = next_char (dtp);
1901 void namelist_read (st_parameter_dt *dtp)
1903 static void nml_match_name (char *name, int len)
1904 static int nml_query (st_parameter_dt *dtp)
1905 static int nml_get_obj_data (st_parameter_dt *dtp,
1906 namelist_info **prev_nl, char *, size_t)
1908 static void nml_untouch_nodes (st_parameter_dt *dtp)
1909 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1911 static int nml_parse_qualifier(descriptor_dimension * ad,
1912 array_loop_spec * ls, int rank, char *)
1913 static void nml_touch_nodes (namelist_info * nl)
1914 static int nml_read_obj (namelist_info *nl, index_type offset,
1915 namelist_info **prev_nl, char *, size_t,
1916 index_type clow, index_type chigh)
1920 /* Inputs a rank-dimensional qualifier, which can contain
1921 singlets, doublets, triplets or ':' with the standard meanings. */
1924 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1925 array_loop_spec *ls, int rank, char *parse_err_msg,
1932 int is_array_section, is_char;
1936 is_array_section = 0;
1937 dtp->u.p.expanded_read = 0;
1939 /* See if this is a character substring qualifier we are looking for. */
1946 /* The next character in the stream should be the '('. */
1948 c = next_char (dtp);
1950 /* Process the qualifier, by dimension and triplet. */
1952 for (dim=0; dim < rank; dim++ )
1954 for (indx=0; indx<3; indx++)
1960 /* Process a potential sign. */
1961 c = next_char (dtp);
1972 unget_char (dtp, c);
1976 /* Process characters up to the next ':' , ',' or ')'. */
1979 c = next_char (dtp);
1984 is_array_section = 1;
1988 if ((c==',' && dim == rank -1)
1989 || (c==')' && dim < rank -1))
1992 sprintf (parse_err_msg, "Bad substring qualifier");
1994 sprintf (parse_err_msg, "Bad number of index fields");
2003 case ' ': case '\t':
2005 c = next_char (dtp);
2010 sprintf (parse_err_msg,
2011 "Bad character in substring qualifier");
2013 sprintf (parse_err_msg, "Bad character in index");
2017 if ((c == ',' || c == ')') && indx == 0
2018 && dtp->u.p.saved_string == 0)
2021 sprintf (parse_err_msg, "Null substring qualifier");
2023 sprintf (parse_err_msg, "Null index field");
2027 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
2028 || (indx == 2 && dtp->u.p.saved_string == 0))
2031 sprintf (parse_err_msg, "Bad substring qualifier");
2033 sprintf (parse_err_msg, "Bad index triplet");
2037 if (is_char && !is_array_section)
2039 sprintf (parse_err_msg,
2040 "Missing colon in substring qualifier");
2044 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2046 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
2047 || (indx==1 && dtp->u.p.saved_string == 0))
2053 /* Now read the index. */
2054 if (convert_integer (dtp, sizeof(ssize_t), neg))
2057 sprintf (parse_err_msg, "Bad integer substring qualifier");
2059 sprintf (parse_err_msg, "Bad integer in index");
2065 /* Feed the index values to the triplet arrays. */
2069 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2071 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
2073 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
2076 /* Singlet or doublet indices. */
2077 if (c==',' || c==')')
2081 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
2083 /* If -std=f95/2003 or an array section is specified,
2084 do not allow excess data to be processed. */
2085 if (is_array_section == 1
2086 || compile_options.allow_std < GFC_STD_GNU)
2087 ls[dim].end = ls[dim].start;
2089 dtp->u.p.expanded_read = 1;
2092 /* Check for non-zero rank. */
2093 if (is_array_section == 1 && ls[dim].start != ls[dim].end)
2100 /* Check the values of the triplet indices. */
2101 if ((ls[dim].start > (ssize_t)ad[dim].ubound)
2102 || (ls[dim].start < (ssize_t)ad[dim].lbound)
2103 || (ls[dim].end > (ssize_t)ad[dim].ubound)
2104 || (ls[dim].end < (ssize_t)ad[dim].lbound))
2107 sprintf (parse_err_msg, "Substring out of range");
2109 sprintf (parse_err_msg, "Index %d out of range", dim + 1);
2113 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
2114 || (ls[dim].step == 0))
2116 sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
2120 /* Initialise the loop index counter. */
2121 ls[dim].idx = ls[dim].start;
2131 static namelist_info *
2132 find_nml_node (st_parameter_dt *dtp, char * var_name)
2134 namelist_info * t = dtp->u.p.ionml;
2137 if (strcmp (var_name, t->var_name) == 0)
2147 /* Visits all the components of a derived type that have
2148 not explicitly been identified in the namelist input.
2149 touched is set and the loop specification initialised
2150 to default values */
2153 nml_touch_nodes (namelist_info * nl)
2155 index_type len = strlen (nl->var_name) + 1;
2157 char * ext_name = (char*)get_mem (len + 1);
2158 memcpy (ext_name, nl->var_name, len-1);
2159 memcpy (ext_name + len - 1, "%", 2);
2160 for (nl = nl->next; nl; nl = nl->next)
2162 if (strncmp (nl->var_name, ext_name, len) == 0)
2165 for (dim=0; dim < nl->var_rank; dim++)
2167 nl->ls[dim].step = 1;
2168 nl->ls[dim].end = nl->dim[dim].ubound;
2169 nl->ls[dim].start = nl->dim[dim].lbound;
2170 nl->ls[dim].idx = nl->ls[dim].start;
2176 free_mem (ext_name);
2180 /* Resets touched for the entire list of nml_nodes, ready for a
2184 nml_untouch_nodes (st_parameter_dt *dtp)
2187 for (t = dtp->u.p.ionml; t; t = t->next)
2192 /* Attempts to input name to namelist name. Returns
2193 dtp->u.p.nml_read_error = 1 on no match. */
2196 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
2200 dtp->u.p.nml_read_error = 0;
2201 for (i = 0; i < len; i++)
2203 c = next_char (dtp);
2204 if (tolower (c) != tolower (name[i]))
2206 dtp->u.p.nml_read_error = 1;
2212 /* If the namelist read is from stdin, output the current state of the
2213 namelist to stdout. This is used to implement the non-standard query
2214 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2215 the names alone are printed. */
2218 nml_query (st_parameter_dt *dtp, char c)
2220 gfc_unit * temp_unit;
2225 static const index_type endlen = 3;
2226 static const char endl[] = "\r\n";
2227 static const char nmlend[] = "&end\r\n";
2229 static const index_type endlen = 2;
2230 static const char endl[] = "\n";
2231 static const char nmlend[] = "&end\n";
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;
2259 p = write_block (dtp, len + endlen);
2263 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2264 memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2265 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2269 len = strlen (nl->var_name);
2270 p = write_block (dtp, len + endlen);
2274 memcpy ((char*)(p + 1), nl->var_name, len);
2275 memcpy ((char*)(p + len + 1), &endl, endlen - 1);
2280 p = write_block (dtp, endlen + 3);
2282 memcpy (p, &nmlend, endlen + 3);
2285 /* Flush the stream to force immediate output. */
2287 fbuf_flush (dtp->u.p.current_unit, 1);
2288 flush (dtp->u.p.current_unit->s);
2289 unlock_unit (dtp->u.p.current_unit);
2294 /* Restore the current unit. */
2296 dtp->u.p.current_unit = temp_unit;
2297 dtp->u.p.mode = READING;
2301 /* Reads and stores the input for the namelist object nl. For an array,
2302 the function loops over the ranges defined by the loop specification.
2303 This default to all the data or to the specification from a qualifier.
2304 nml_read_obj recursively calls itself to read derived types. It visits
2305 all its own components but only reads data for those that were touched
2306 when the name was parsed. If a read error is encountered, an attempt is
2307 made to return to read a new object name because the standard allows too
2308 little data to be available. On the other hand, too much data is an
2312 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2313 namelist_info **pprev_nl, char *nml_err_msg,
2314 size_t nml_err_msg_size, index_type clow, index_type chigh)
2316 namelist_info * cmp;
2323 index_type obj_name_len;
2326 /* This object not touched in name parsing. */
2331 dtp->u.p.repeat_count = 0;
2337 case GFC_DTYPE_INTEGER:
2338 case GFC_DTYPE_LOGICAL:
2342 case GFC_DTYPE_REAL:
2343 dlen = size_from_real_kind (len);
2346 case GFC_DTYPE_COMPLEX:
2347 dlen = size_from_complex_kind (len);
2350 case GFC_DTYPE_CHARACTER:
2351 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2360 /* Update the pointer to the data, using the current index vector */
2362 pdata = (void*)(nl->mem_pos + offset);
2363 for (dim = 0; dim < nl->var_rank; dim++)
2364 pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
2365 nl->dim[dim].stride * nl->size);
2367 /* Reset the error flag and try to read next value, if
2368 dtp->u.p.repeat_count=0 */
2370 dtp->u.p.nml_read_error = 0;
2372 if (--dtp->u.p.repeat_count <= 0)
2374 if (dtp->u.p.input_complete)
2376 if (dtp->u.p.at_eol)
2377 finish_separator (dtp);
2378 if (dtp->u.p.input_complete)
2381 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2382 after the switch block. */
2384 dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
2389 case GFC_DTYPE_INTEGER:
2390 read_integer (dtp, len);
2393 case GFC_DTYPE_LOGICAL:
2394 read_logical (dtp, len);
2397 case GFC_DTYPE_CHARACTER:
2398 read_character (dtp, len);
2401 case GFC_DTYPE_REAL:
2402 read_real (dtp, len);
2405 case GFC_DTYPE_COMPLEX:
2406 read_complex (dtp, len, dlen);
2409 case GFC_DTYPE_DERIVED:
2410 obj_name_len = strlen (nl->var_name) + 1;
2411 obj_name = get_mem (obj_name_len+1);
2412 memcpy (obj_name, nl->var_name, obj_name_len-1);
2413 memcpy (obj_name + obj_name_len - 1, "%", 2);
2415 /* If reading a derived type, disable the expanded read warning
2416 since a single object can have multiple reads. */
2417 dtp->u.p.expanded_read = 0;
2419 /* Now loop over the components. Update the component pointer
2420 with the return value from nml_write_obj. This loop jumps
2421 past nested derived types by testing if the potential
2422 component name contains '%'. */
2424 for (cmp = nl->next;
2426 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2427 !strchr (cmp->var_name + obj_name_len, '%');
2431 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2432 pprev_nl, nml_err_msg, nml_err_msg_size,
2433 clow, chigh) == FAILURE)
2435 free_mem (obj_name);
2439 if (dtp->u.p.input_complete)
2441 free_mem (obj_name);
2446 free_mem (obj_name);
2450 snprintf (nml_err_msg, nml_err_msg_size,
2451 "Bad type for namelist object %s", nl->var_name);
2452 internal_error (&dtp->common, nml_err_msg);
2457 /* The standard permits array data to stop short of the number of
2458 elements specified in the loop specification. In this case, we
2459 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2460 nml_get_obj_data and an attempt is made to read object name. */
2463 if (dtp->u.p.nml_read_error)
2465 dtp->u.p.expanded_read = 0;
2469 if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
2471 dtp->u.p.expanded_read = 0;
2475 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2476 This comes about because the read functions return BT_types. */
2478 switch (dtp->u.p.saved_type)
2485 memcpy (pdata, dtp->u.p.value, dlen);
2489 m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2490 pdata = (void*)( pdata + clow - 1 );
2491 memcpy (pdata, dtp->u.p.saved_string, m);
2493 memset ((void*)( pdata + m ), ' ', dlen - m);
2500 /* Warn if a non-standard expanded read occurs. A single read of a
2501 single object is acceptable. If a second read occurs, issue a warning
2502 and set the flag to zero to prevent further warnings. */
2503 if (dtp->u.p.expanded_read == 2)
2505 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2506 dtp->u.p.expanded_read = 0;
2509 /* If the expanded read warning flag is set, increment it,
2510 indicating that a single read has occurred. */
2511 if (dtp->u.p.expanded_read >= 1)
2512 dtp->u.p.expanded_read++;
2514 /* Break out of loop if scalar. */
2518 /* Now increment the index vector. */
2523 for (dim = 0; dim < nl->var_rank; dim++)
2525 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2527 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2529 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2531 nl->ls[dim].idx = nl->ls[dim].start;
2535 } while (!nml_carry);
2537 if (dtp->u.p.repeat_count > 1)
2539 snprintf (nml_err_msg, nml_err_msg_size,
2540 "Repeat count too large for namelist object %s", nl->var_name);
2550 /* Parses the object name, including array and substring qualifiers. It
2551 iterates over derived type components, touching those components and
2552 setting their loop specifications, if there is a qualifier. If the
2553 object is itself a derived type, its components and subcomponents are
2554 touched. nml_read_obj is called at the end and this reads the data in
2555 the manner specified by the object name. */
2558 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2559 char *nml_err_msg, size_t nml_err_msg_size)
2563 namelist_info * first_nl = NULL;
2564 namelist_info * root_nl = NULL;
2565 int dim, parsed_rank;
2567 index_type clow, chigh;
2568 int non_zero_rank_count;
2570 /* Look for end of input or object name. If '?' or '=?' are encountered
2571 in stdin, print the node names or the namelist to stdout. */
2573 eat_separator (dtp);
2574 if (dtp->u.p.input_complete)
2577 if (dtp->u.p.at_eol)
2578 finish_separator (dtp);
2579 if (dtp->u.p.input_complete)
2582 c = next_char (dtp);
2586 c = next_char (dtp);
2589 sprintf (nml_err_msg, "namelist read: misplaced = sign");
2592 nml_query (dtp, '=');
2596 nml_query (dtp, '?');
2601 nml_match_name (dtp, "end", 3);
2602 if (dtp->u.p.nml_read_error)
2604 sprintf (nml_err_msg, "namelist not terminated with / or &end");
2608 dtp->u.p.input_complete = 1;
2615 /* Untouch all nodes of the namelist and reset the flag that is set for
2616 derived type components. */
2618 nml_untouch_nodes (dtp);
2620 non_zero_rank_count = 0;
2622 /* Get the object name - should '!' and '\n' be permitted separators? */
2630 if (!is_separator (c))
2631 push_char (dtp, tolower(c));
2632 c = next_char (dtp);
2633 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2635 unget_char (dtp, c);
2637 /* Check that the name is in the namelist and get pointer to object.
2638 Three error conditions exist: (i) An attempt is being made to
2639 identify a non-existent object, following a failed data read or
2640 (ii) The object name does not exist or (iii) Too many data items
2641 are present for an object. (iii) gives the same error message
2644 push_char (dtp, '\0');
2648 size_t var_len = strlen (root_nl->var_name);
2650 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2651 char ext_name[var_len + saved_len + 1];
2653 memcpy (ext_name, root_nl->var_name, var_len);
2654 if (dtp->u.p.saved_string)
2655 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2656 ext_name[var_len + saved_len] = '\0';
2657 nl = find_nml_node (dtp, ext_name);
2660 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2664 if (dtp->u.p.nml_read_error && *pprev_nl)
2665 snprintf (nml_err_msg, nml_err_msg_size,
2666 "Bad data for namelist object %s", (*pprev_nl)->var_name);
2669 snprintf (nml_err_msg, nml_err_msg_size,
2670 "Cannot match namelist object name %s",
2671 dtp->u.p.saved_string);
2676 /* Get the length, data length, base pointer and rank of the variable.
2677 Set the default loop specification first. */
2679 for (dim=0; dim < nl->var_rank; dim++)
2681 nl->ls[dim].step = 1;
2682 nl->ls[dim].end = nl->dim[dim].ubound;
2683 nl->ls[dim].start = nl->dim[dim].lbound;
2684 nl->ls[dim].idx = nl->ls[dim].start;
2687 /* Check to see if there is a qualifier: if so, parse it.*/
2689 if (c == '(' && nl->var_rank)
2692 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2693 nml_err_msg, &parsed_rank) == FAILURE)
2695 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2696 snprintf (nml_err_msg_end,
2697 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2698 " for namelist variable %s", nl->var_name);
2702 if (parsed_rank > 0)
2703 non_zero_rank_count++;
2705 c = next_char (dtp);
2706 unget_char (dtp, c);
2708 else if (nl->var_rank > 0)
2709 non_zero_rank_count++;
2711 /* Now parse a derived type component. The root namelist_info address
2712 is backed up, as is the previous component level. The component flag
2713 is set and the iteration is made by jumping back to get_name. */
2717 if (nl->type != GFC_DTYPE_DERIVED)
2719 snprintf (nml_err_msg, nml_err_msg_size,
2720 "Attempt to get derived component for %s", nl->var_name);
2724 if (!component_flag)
2729 c = next_char (dtp);
2733 /* Parse a character qualifier, if present. chigh = 0 is a default
2734 that signals that the string length = string_length. */
2739 if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2741 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2742 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2744 if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
2747 char *nml_err_msg_end = strchr (nml_err_msg, '\0');
2748 snprintf (nml_err_msg_end,
2749 nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
2750 " for namelist variable %s", nl->var_name);
2754 clow = ind[0].start;
2757 if (ind[0].step != 1)
2759 snprintf (nml_err_msg, nml_err_msg_size,
2760 "Step not allowed in substring qualifier"
2761 " for namelist object %s", nl->var_name);
2765 c = next_char (dtp);
2766 unget_char (dtp, c);
2769 /* If a derived type touch its components and restore the root
2770 namelist_info if we have parsed a qualified derived type
2773 if (nl->type == GFC_DTYPE_DERIVED)
2774 nml_touch_nodes (nl);
2778 /* Make sure no extraneous qualifiers are there. */
2782 snprintf (nml_err_msg, nml_err_msg_size,
2783 "Qualifier for a scalar or non-character namelist object %s",
2788 /* Make sure there is no more than one non-zero rank object. */
2789 if (non_zero_rank_count > 1)
2791 snprintf (nml_err_msg, nml_err_msg_size,
2792 "Multiple sub-objects with non-zero rank in namelist object %s",
2794 non_zero_rank_count = 0;
2798 /* According to the standard, an equal sign MUST follow an object name. The
2799 following is possibly lax - it allows comments, blank lines and so on to
2800 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2804 eat_separator (dtp);
2805 if (dtp->u.p.input_complete)
2808 if (dtp->u.p.at_eol)
2809 finish_separator (dtp);
2810 if (dtp->u.p.input_complete)
2813 c = next_char (dtp);
2817 snprintf (nml_err_msg, nml_err_msg_size,
2818 "Equal sign must follow namelist object name %s",
2823 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
2824 clow, chigh) == FAILURE)
2834 /* Entry point for namelist input. Goes through input until namelist name
2835 is matched. Then cycles through nml_get_obj_data until the input is
2836 completed or there is an error. */
2839 namelist_read (st_parameter_dt *dtp)
2843 char nml_err_msg[200];
2844 /* Pointer to the previously read object, in case attempt is made to read
2845 new object name. Should this fail, error message can give previous
2847 namelist_info *prev_nl = NULL;
2849 dtp->u.p.namelist_mode = 1;
2850 dtp->u.p.input_complete = 0;
2851 dtp->u.p.expanded_read = 0;
2853 dtp->u.p.eof_jump = &eof_jump;
2854 if (setjmp (eof_jump))
2856 dtp->u.p.eof_jump = NULL;
2857 generate_error (&dtp->common, LIBERROR_END, NULL);
2861 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2862 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2863 node names or namelist on stdout. */
2866 switch (c = next_char (dtp))
2877 c = next_char (dtp);
2879 nml_query (dtp, '=');
2881 unget_char (dtp, c);
2885 nml_query (dtp, '?');
2891 /* Match the name of the namelist. */
2893 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2895 if (dtp->u.p.nml_read_error)
2898 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2899 c = next_char (dtp);
2900 if (!is_separator(c))
2902 unget_char (dtp, c);
2906 /* Ready to read namelist objects. If there is an error in input
2907 from stdin, output the error message and continue. */
2909 while (!dtp->u.p.input_complete)
2911 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
2916 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2919 u = find_unit (options.stderr_unit);
2920 st_printf ("%s\n", nml_err_msg);
2930 dtp->u.p.eof_jump = NULL;
2935 /* All namelist error calls return from here */
2939 dtp->u.p.eof_jump = NULL;
2942 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);