1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
67 /* Save a character to a string buffer, enlarging it as necessary. */
70 push_char (st_parameter_dt *dtp, char c)
74 if (dtp->u.p.saved_string == NULL)
76 if (dtp->u.p.scratch == NULL)
77 dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
78 dtp->u.p.saved_string = dtp->u.p.scratch;
79 memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
80 dtp->u.p.saved_length = SCRATCH_SIZE;
81 dtp->u.p.saved_used = 0;
84 if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
86 dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
87 new = get_mem (2 * dtp->u.p.saved_length);
89 memset (new, 0, 2 * dtp->u.p.saved_length);
91 memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
92 if (dtp->u.p.saved_string != dtp->u.p.scratch)
93 free_mem (dtp->u.p.saved_string);
95 dtp->u.p.saved_string = new;
98 dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
102 /* Free the input buffer if necessary. */
105 free_saved (st_parameter_dt *dtp)
107 if (dtp->u.p.saved_string == NULL)
110 if (dtp->u.p.saved_string != dtp->u.p.scratch)
111 free_mem (dtp->u.p.saved_string);
113 dtp->u.p.saved_string = NULL;
114 dtp->u.p.saved_used = 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt *dtp)
123 if (dtp->u.p.line_buffer == NULL)
126 free_mem (dtp->u.p.line_buffer);
127 dtp->u.p.line_buffer = NULL;
132 next_char (st_parameter_dt *dtp)
138 if (dtp->u.p.last_char != '\0')
141 c = dtp->u.p.last_char;
142 dtp->u.p.last_char = '\0';
146 /* Read from line_buffer if enabled. */
148 if (dtp->u.p.line_buffer_enabled)
152 c = dtp->u.p.line_buffer[dtp->u.p.item_count];
153 if (c != '\0' && dtp->u.p.item_count < 64)
155 dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
156 dtp->u.p.item_count++;
160 dtp->u.p.item_count = 0;
161 dtp->u.p.line_buffer_enabled = 0;
164 /* Handle the end-of-record and end-of-file conditions for
165 internal array unit. */
166 if (is_array_io (dtp))
169 longjmp (*dtp->u.p.eof_jump, 1);
171 /* Check for "end-of-record" condition. */
172 if (dtp->u.p.current_unit->bytes_left == 0)
175 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
177 /* Check for "end-of-file" condition. */
184 record *= dtp->u.p.current_unit->recl;
185 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
186 longjmp (*dtp->u.p.eof_jump, 1);
188 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
193 /* Get the next character and handle end-of-record conditions. */
197 p = salloc_r (dtp->u.p.current_unit->s, &length);
199 if (is_stream_io (dtp))
200 dtp->u.p.current_unit->strm_pos++;
202 if (is_internal_unit (dtp))
204 if (is_array_io (dtp))
206 /* End of record is handled in the next pass through, above. The
207 check for NULL here is cautionary. */
210 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
214 dtp->u.p.current_unit->bytes_left--;
220 longjmp (*dtp->u.p.eof_jump, 1);
231 generate_error (&dtp->common, LIBERROR_OS, NULL);
236 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
237 longjmp (*dtp->u.p.eof_jump, 1);
238 dtp->u.p.current_unit->endfile = AT_ENDFILE;
245 dtp->u.p.at_eol = (c == '\n' || c == '\r');
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt *dtp, char c)
255 dtp->u.p.last_char = c;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt *dtp)
271 while (c == ' ' || c == '\t');
278 /* Skip over a separator. Technically, we don't always eat the whole
279 separator. This is because if we've processed the last input item,
280 then a separator is unnecessary. Plus the fact that operating
281 systems usually deliver console input on a line basis.
283 The upshot is that if we see a newline as part of reading a
284 separator, we stop reading. If there are more input items, we
285 continue reading the separator with finish_separator() which takes
286 care of the fact that we may or may not have seen a comma as part
290 eat_separator (st_parameter_dt *dtp)
295 dtp->u.p.comma_flag = 0;
301 dtp->u.p.comma_flag = 1;
306 dtp->u.p.input_complete = 1;
322 if (dtp->u.p.namelist_mode)
323 { /* Eat a namelist comment. */
331 /* Fall Through... */
340 /* Finish processing a separator that was interrupted by a newline.
341 If we're here, then another data item is present, so we finish what
342 we started on the previous line. */
345 finish_separator (st_parameter_dt *dtp)
356 if (dtp->u.p.comma_flag)
360 c = eat_spaces (dtp);
361 if (c == '\n' || c == '\r')
368 dtp->u.p.input_complete = 1;
369 if (!dtp->u.p.namelist_mode)
378 if (dtp->u.p.namelist_mode)
394 /* This function reads characters through to the end of the current line and
395 just ignores them. */
398 eat_line (st_parameter_dt *dtp)
401 if (!is_internal_unit (dtp))
408 /* This function is needed to catch bad conversions so that namelist can
409 attempt to see if dtp->u.p.saved_string contains a new object name rather
413 nml_bad_return (st_parameter_dt *dtp, char c)
415 if (dtp->u.p.namelist_mode)
417 dtp->u.p.nml_read_error = 1;
424 /* Convert an unsigned string to an integer. The length value is -1
425 if we are working on a repeat count. Returns nonzero if we have a
426 range problem. As a side effect, frees the dtp->u.p.saved_string. */
429 convert_integer (st_parameter_dt *dtp, int length, int negative)
431 char c, *buffer, message[100];
433 GFC_INTEGER_LARGEST v, max, max10;
435 buffer = dtp->u.p.saved_string;
438 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
463 set_integer (dtp->u.p.value, v, length);
467 dtp->u.p.repeat_count = v;
469 if (dtp->u.p.repeat_count == 0)
471 sprintf (message, "Zero repeat count in item %d of list input",
472 dtp->u.p.item_count);
474 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
484 sprintf (message, "Repeat count overflow in item %d of list input",
485 dtp->u.p.item_count);
487 sprintf (message, "Integer overflow while reading item %d",
488 dtp->u.p.item_count);
491 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
497 /* Parse a repeat count for logical and complex values which cannot
498 begin with a digit. Returns nonzero if we are done, zero if we
499 should continue on. */
502 parse_repeat (st_parameter_dt *dtp)
504 char c, message[100];
530 repeat = 10 * repeat + c - '0';
532 if (repeat > MAX_REPEAT)
535 "Repeat count overflow in item %d of list input",
536 dtp->u.p.item_count);
538 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
548 "Zero repeat count in item %d of list input",
549 dtp->u.p.item_count);
551 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
563 dtp->u.p.repeat_count = repeat;
570 sprintf (message, "Bad repeat count in item %d of list input",
571 dtp->u.p.item_count);
572 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
577 /* To read a logical we have to look ahead in the input stream to make sure
578 there is not an equal sign indicating a variable name. To do this we use
579 line_buffer to point to a temporary buffer, pushing characters there for
580 possible later reading. */
583 l_push_char (st_parameter_dt *dtp, char c)
585 if (dtp->u.p.line_buffer == NULL)
587 dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
588 memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
591 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
595 /* Read a logical character on the input. */
598 read_logical (st_parameter_dt *dtp, int length)
600 char c, message[100];
603 if (parse_repeat (dtp))
606 c = tolower (next_char (dtp));
607 l_push_char (dtp, c);
613 l_push_char (dtp, c);
615 if (!is_separator(c))
623 l_push_char (dtp, c);
625 if (!is_separator(c))
631 c = tolower (next_char (dtp));
649 return; /* Null value. */
655 dtp->u.p.saved_type = BT_LOGICAL;
656 dtp->u.p.saved_length = length;
658 /* Eat trailing garbage. */
663 while (!is_separator (c));
667 dtp->u.p.item_count = 0;
668 dtp->u.p.line_buffer_enabled = 0;
669 set_integer ((int *) dtp->u.p.value, v, length);
676 for(i = 0; i < 63; i++)
681 /* All done if this is not a namelist read. */
682 if (!dtp->u.p.namelist_mode)
695 l_push_char (dtp, c);
698 dtp->u.p.nml_read_error = 1;
699 dtp->u.p.line_buffer_enabled = 1;
700 dtp->u.p.item_count = 0;
710 if (nml_bad_return (dtp, c))
715 sprintf (message, "Bad logical value while reading item %d",
716 dtp->u.p.item_count);
717 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
722 dtp->u.p.item_count = 0;
723 dtp->u.p.line_buffer_enabled = 0;
724 dtp->u.p.saved_type = BT_LOGICAL;
725 dtp->u.p.saved_length = length;
726 set_integer ((int *) dtp->u.p.value, v, length);
732 /* Reading integers is tricky because we can actually be reading a
733 repeat count. We have to store the characters in a buffer because
734 we could be reading an integer that is larger than the default int
735 used for repeat counts. */
738 read_integer (st_parameter_dt *dtp, int length)
740 char c, message[100];
750 /* Fall through... */
756 CASE_SEPARATORS: /* Single null. */
769 /* Take care of what may be a repeat count. */
781 push_char (dtp, '\0');
784 CASE_SEPARATORS: /* Not a repeat count. */
793 if (convert_integer (dtp, -1, 0))
796 /* Get the real integer. */
811 /* Fall through... */
842 if (nml_bad_return (dtp, c))
847 sprintf (message, "Bad integer for item %d in list input",
848 dtp->u.p.item_count);
849 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
857 push_char (dtp, '\0');
858 if (convert_integer (dtp, length, negative))
865 dtp->u.p.saved_type = BT_INTEGER;
869 /* Read a character variable. */
872 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
874 char c, quote, message[100];
876 quote = ' '; /* Space means no quote character. */
886 unget_char (dtp, c); /* NULL value. */
896 if (dtp->u.p.namelist_mode)
898 if (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
899 || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE)
905 /* Check to see if we are seeing a namelist object name by using the
906 line buffer and looking ahead for an '=' or '('. */
907 l_push_char (dtp, c);
910 for(i = 0; i < 63; i++)
920 l_push_char (dtp, c);
921 dtp->u.p.item_count = 0;
922 dtp->u.p.line_buffer_enabled = 1;
927 l_push_char (dtp, c);
928 if (c == '=' || c == '(')
930 dtp->u.p.item_count = 0;
931 dtp->u.p.nml_read_error = 1;
932 dtp->u.p.line_buffer_enabled = 1;
937 /* The string is too long to be a valid object name so assume that it
938 is a string to be read in as a value. */
939 dtp->u.p.line_buffer_enabled = 1;
947 /* Deal with a possible repeat count. */
960 goto done; /* String was only digits! */
963 push_char (dtp, '\0');
968 goto get_string; /* Not a repeat count after all. */
973 if (convert_integer (dtp, -1, 0))
976 /* Now get the real string. */
982 unget_char (dtp, c); /* Repeated NULL values. */
1010 /* See if we have a doubled quote character or the end of
1013 c = next_char (dtp);
1016 push_char (dtp, quote);
1020 unget_char (dtp, c);
1026 unget_char (dtp, c);
1030 if (c != '\n' && c != '\r')
1040 /* At this point, we have to have a separator, or else the string is
1043 c = next_char (dtp);
1044 if (is_separator (c))
1046 unget_char (dtp, c);
1047 eat_separator (dtp);
1048 dtp->u.p.saved_type = BT_CHARACTER;
1054 sprintf (message, "Invalid string input in item %d",
1055 dtp->u.p.item_count);
1056 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1061 /* Parse a component of a complex constant or a real number that we
1062 are sure is already there. This is a straight real number parser. */
1065 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1067 char c, message[100];
1070 c = next_char (dtp);
1071 if (c == '-' || c == '+')
1074 c = next_char (dtp);
1077 if (!isdigit (c) && c != '.')
1082 seen_dp = (c == '.') ? 1 : 0;
1086 c = next_char (dtp);
1105 push_char (dtp, 'e');
1110 push_char (dtp, 'e');
1112 c = next_char (dtp);
1116 unget_char (dtp, c);
1125 c = next_char (dtp);
1126 if (c != '-' && c != '+')
1127 push_char (dtp, '+');
1131 c = next_char (dtp);
1141 c = next_char (dtp);
1149 unget_char (dtp, c);
1158 unget_char (dtp, c);
1159 push_char (dtp, '\0');
1161 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1168 if (nml_bad_return (dtp, c))
1173 sprintf (message, "Bad floating point number for item %d",
1174 dtp->u.p.item_count);
1175 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1181 /* Reading a complex number is straightforward because we can tell
1182 what it is right away. */
1185 read_complex (st_parameter_dt *dtp, int kind, size_t size)
1190 if (parse_repeat (dtp))
1193 c = next_char (dtp);
1200 unget_char (dtp, c);
1201 eat_separator (dtp);
1209 if (parse_real (dtp, dtp->u.p.value, kind))
1214 c = next_char (dtp);
1215 if (c == '\n' || c== '\r')
1218 unget_char (dtp, c);
1220 if (next_char (dtp) != ',')
1225 c = next_char (dtp);
1226 if (c == '\n' || c== '\r')
1229 unget_char (dtp, c);
1231 if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
1235 if (next_char (dtp) != ')')
1238 c = next_char (dtp);
1239 if (!is_separator (c))
1242 unget_char (dtp, c);
1243 eat_separator (dtp);
1246 dtp->u.p.saved_type = BT_COMPLEX;
1251 if (nml_bad_return (dtp, c))
1256 sprintf (message, "Bad complex value in item %d of list input",
1257 dtp->u.p.item_count);
1258 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1262 /* Parse a real number with a possible repeat count. */
1265 read_real (st_parameter_dt *dtp, int length)
1267 char c, message[100];
1272 c = next_char (dtp);
1289 unget_char (dtp, c); /* Single null. */
1290 eat_separator (dtp);
1297 /* Get the digit string that might be a repeat count. */
1301 c = next_char (dtp);
1324 push_char (dtp, 'e');
1326 c = next_char (dtp);
1330 push_char (dtp, '\0');
1334 if (c != '\n' && c != ',' && c != '\r')
1335 unget_char (dtp, c);
1344 if (convert_integer (dtp, -1, 0))
1347 /* Now get the number itself. */
1349 c = next_char (dtp);
1350 if (is_separator (c))
1351 { /* Repeated null value. */
1352 unget_char (dtp, c);
1353 eat_separator (dtp);
1357 if (c != '-' && c != '+')
1358 push_char (dtp, '+');
1363 c = next_char (dtp);
1366 if (!isdigit (c) && c != '.')
1382 c = next_char (dtp);
1408 push_char (dtp, 'e');
1410 c = next_char (dtp);
1419 push_char (dtp, 'e');
1421 c = next_char (dtp);
1422 if (c != '+' && c != '-')
1423 push_char (dtp, '+');
1427 c = next_char (dtp);
1437 c = next_char (dtp);
1454 unget_char (dtp, c);
1455 eat_separator (dtp);
1456 push_char (dtp, '\0');
1457 if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
1461 dtp->u.p.saved_type = BT_REAL;
1466 if (nml_bad_return (dtp, c))
1471 sprintf (message, "Bad real number in item %d of list input",
1472 dtp->u.p.item_count);
1473 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1477 /* Check the current type against the saved type to make sure they are
1478 compatible. Returns nonzero if incompatible. */
1481 check_type (st_parameter_dt *dtp, bt type, int len)
1485 if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
1487 sprintf (message, "Read type %s where %s was expected for item %d",
1488 type_name (dtp->u.p.saved_type), type_name (type),
1489 dtp->u.p.item_count);
1491 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1495 if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
1498 if (dtp->u.p.saved_length != len)
1501 "Read kind %d %s where kind %d is required for item %d",
1502 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1503 dtp->u.p.item_count);
1504 generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
1512 /* Top level data transfer subroutine for list reads. Because we have
1513 to deal with repeat counts, the data item is always saved after
1514 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1515 greater than one, we copy the data item multiple times. */
1518 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1525 dtp->u.p.namelist_mode = 0;
1527 dtp->u.p.eof_jump = &eof_jump;
1528 if (setjmp (eof_jump))
1530 generate_error (&dtp->common, LIBERROR_END, NULL);
1534 if (dtp->u.p.first_item)
1536 dtp->u.p.first_item = 0;
1537 dtp->u.p.input_complete = 0;
1538 dtp->u.p.repeat_count = 1;
1539 dtp->u.p.at_eol = 0;
1541 c = eat_spaces (dtp);
1542 if (is_separator (c))
1544 /* Found a null value. */
1545 eat_separator (dtp);
1546 dtp->u.p.repeat_count = 0;
1548 /* eat_separator sets this flag if the separator was a comma. */
1549 if (dtp->u.p.comma_flag)
1552 /* eat_separator sets this flag if the separator was a \n or \r. */
1553 if (dtp->u.p.at_eol)
1554 finish_separator (dtp);
1562 if (dtp->u.p.input_complete)
1565 if (dtp->u.p.repeat_count > 0)
1567 if (check_type (dtp, type, kind))
1572 if (dtp->u.p.at_eol)
1573 finish_separator (dtp);
1577 /* Trailing spaces prior to end of line. */
1578 if (dtp->u.p.at_eol)
1579 finish_separator (dtp);
1582 dtp->u.p.saved_type = BT_NULL;
1583 dtp->u.p.repeat_count = 1;
1589 read_integer (dtp, kind);
1592 read_logical (dtp, kind);
1595 read_character (dtp, kind);
1598 read_real (dtp, kind);
1601 read_complex (dtp, kind, size);
1604 internal_error (&dtp->common, "Bad type for list read");
1607 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1608 dtp->u.p.saved_length = size;
1610 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1614 switch (dtp->u.p.saved_type)
1620 memcpy (p, dtp->u.p.value, size);
1624 if (dtp->u.p.saved_string)
1626 m = ((int) size < dtp->u.p.saved_used)
1627 ? (int) size : dtp->u.p.saved_used;
1628 memcpy (p, dtp->u.p.saved_string, m);
1631 /* Just delimiters encountered, nothing to copy but SPACE. */
1635 memset (((char *) p) + m, ' ', size - m);
1642 if (--dtp->u.p.repeat_count <= 0)
1646 dtp->u.p.eof_jump = NULL;
1651 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1652 size_t size, size_t nelems)
1659 /* Big loop over all the elements. */
1660 for (elem = 0; elem < nelems; elem++)
1662 dtp->u.p.item_count++;
1663 list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
1668 /* Finish a list read. */
1671 finish_list_read (st_parameter_dt *dtp)
1677 if (dtp->u.p.at_eol)
1679 dtp->u.p.at_eol = 0;
1685 c = next_char (dtp);
1692 void namelist_read (st_parameter_dt *dtp)
1694 static void nml_match_name (char *name, int len)
1695 static int nml_query (st_parameter_dt *dtp)
1696 static int nml_get_obj_data (st_parameter_dt *dtp,
1697 namelist_info **prev_nl, char *)
1699 static void nml_untouch_nodes (st_parameter_dt *dtp)
1700 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1702 static int nml_parse_qualifier(descriptor_dimension * ad,
1703 array_loop_spec * ls, int rank, char *)
1704 static void nml_touch_nodes (namelist_info * nl)
1705 static int nml_read_obj (namelist_info *nl, index_type offset,
1706 namelist_info **prev_nl, char *,
1707 index_type clow, index_type chigh)
1711 /* Inputs a rank-dimensional qualifier, which can contain
1712 singlets, doublets, triplets or ':' with the standard meanings. */
1715 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1716 array_loop_spec *ls, int rank, char *parse_err_msg)
1722 int is_array_section;
1725 is_array_section = 0;
1726 dtp->u.p.expanded_read = 0;
1728 /* The next character in the stream should be the '('. */
1730 c = next_char (dtp);
1732 /* Process the qualifier, by dimension and triplet. */
1734 for (dim=0; dim < rank; dim++ )
1736 for (indx=0; indx<3; indx++)
1742 /* Process a potential sign. */
1743 c = next_char (dtp);
1754 unget_char (dtp, c);
1758 /* Process characters up to the next ':' , ',' or ')'. */
1761 c = next_char (dtp);
1766 is_array_section = 1;
1770 if ((c==',' && dim == rank -1)
1771 || (c==')' && dim < rank -1))
1773 sprintf (parse_err_msg,
1774 "Bad number of index fields");
1783 case ' ': case '\t':
1785 c = next_char (dtp);
1789 sprintf (parse_err_msg, "Bad character in index");
1793 if ((c == ',' || c == ')') && indx == 0
1794 && dtp->u.p.saved_string == 0)
1796 sprintf (parse_err_msg, "Null index field");
1800 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
1801 || (indx == 2 && dtp->u.p.saved_string == 0))
1803 sprintf(parse_err_msg, "Bad index triplet");
1807 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1809 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
1810 || (indx==1 && dtp->u.p.saved_string == 0))
1816 /* Now read the index. */
1817 if (convert_integer (dtp, sizeof(ssize_t), neg))
1819 sprintf (parse_err_msg, "Bad integer in index");
1825 /* Feed the index values to the triplet arrays. */
1829 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
1831 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
1833 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
1836 /* Singlet or doublet indices. */
1837 if (c==',' || c==')')
1841 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
1843 /* If -std=f95/2003 or an array section is specified,
1844 do not allow excess data to be processed. */
1845 if (is_array_section == 1
1846 || compile_options.allow_std < GFC_STD_GNU)
1847 ls[dim].end = ls[dim].start;
1849 dtp->u.p.expanded_read = 1;
1855 /* Check the values of the triplet indices. */
1856 if ((ls[dim].start > (ssize_t)ad[dim].ubound)
1857 || (ls[dim].start < (ssize_t)ad[dim].lbound)
1858 || (ls[dim].end > (ssize_t)ad[dim].ubound)
1859 || (ls[dim].end < (ssize_t)ad[dim].lbound))
1861 sprintf (parse_err_msg, "Index %d out of range", dim + 1);
1864 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
1865 || (ls[dim].step == 0))
1867 sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
1871 /* Initialise the loop index counter. */
1872 ls[dim].idx = ls[dim].start;
1882 static namelist_info *
1883 find_nml_node (st_parameter_dt *dtp, char * var_name)
1885 namelist_info * t = dtp->u.p.ionml;
1888 if (strcmp (var_name, t->var_name) == 0)
1898 /* Visits all the components of a derived type that have
1899 not explicitly been identified in the namelist input.
1900 touched is set and the loop specification initialised
1901 to default values */
1904 nml_touch_nodes (namelist_info * nl)
1906 index_type len = strlen (nl->var_name) + 1;
1908 char * ext_name = (char*)get_mem (len + 1);
1909 memcpy (ext_name, nl->var_name, len-1);
1910 memcpy (ext_name + len - 1, "%", 2);
1911 for (nl = nl->next; nl; nl = nl->next)
1913 if (strncmp (nl->var_name, ext_name, len) == 0)
1916 for (dim=0; dim < nl->var_rank; dim++)
1918 nl->ls[dim].step = 1;
1919 nl->ls[dim].end = nl->dim[dim].ubound;
1920 nl->ls[dim].start = nl->dim[dim].lbound;
1921 nl->ls[dim].idx = nl->ls[dim].start;
1927 free_mem (ext_name);
1931 /* Resets touched for the entire list of nml_nodes, ready for a
1935 nml_untouch_nodes (st_parameter_dt *dtp)
1938 for (t = dtp->u.p.ionml; t; t = t->next)
1943 /* Attempts to input name to namelist name. Returns
1944 dtp->u.p.nml_read_error = 1 on no match. */
1947 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
1951 dtp->u.p.nml_read_error = 0;
1952 for (i = 0; i < len; i++)
1954 c = next_char (dtp);
1955 if (tolower (c) != tolower (name[i]))
1957 dtp->u.p.nml_read_error = 1;
1963 /* If the namelist read is from stdin, output the current state of the
1964 namelist to stdout. This is used to implement the non-standard query
1965 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1966 the names alone are printed. */
1969 nml_query (st_parameter_dt *dtp, char c)
1971 gfc_unit * temp_unit;
1976 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
1979 /* Store the current unit and transfer to stdout. */
1981 temp_unit = dtp->u.p.current_unit;
1982 dtp->u.p.current_unit = find_unit (options.stdout_unit);
1984 if (dtp->u.p.current_unit)
1986 dtp->u.p.mode = WRITING;
1987 next_record (dtp, 0);
1989 /* Write the namelist in its entirety. */
1992 namelist_write (dtp);
1994 /* Or write the list of names. */
1999 /* "&namelist_name\n" */
2001 len = dtp->namelist_name_len;
2003 p = write_block (dtp, len + 3);
2005 p = write_block (dtp, len + 2);
2010 memcpy ((char*)(p + 1), dtp->namelist_name, len);
2012 memcpy ((char*)(p + len + 1), "\r\n", 2);
2014 memcpy ((char*)(p + len + 1), "\n", 1);
2016 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
2021 len = strlen (nl->var_name);
2023 p = write_block (dtp, len + 3);
2025 p = write_block (dtp, len + 2);
2030 memcpy ((char*)(p + 1), nl->var_name, len);
2032 memcpy ((char*)(p + len + 1), "\r\n", 2);
2034 memcpy ((char*)(p + len + 1), "\n", 1);
2041 p = write_block (dtp, 6);
2043 p = write_block (dtp, 5);
2048 memcpy (p, "&end\r\n", 6);
2050 memcpy (p, "&end\n", 5);
2054 /* Flush the stream to force immediate output. */
2056 flush (dtp->u.p.current_unit->s);
2057 unlock_unit (dtp->u.p.current_unit);
2062 /* Restore the current unit. */
2064 dtp->u.p.current_unit = temp_unit;
2065 dtp->u.p.mode = READING;
2069 /* Reads and stores the input for the namelist object nl. For an array,
2070 the function loops over the ranges defined by the loop specification.
2071 This default to all the data or to the specification from a qualifier.
2072 nml_read_obj recursively calls itself to read derived types. It visits
2073 all its own components but only reads data for those that were touched
2074 when the name was parsed. If a read error is encountered, an attempt is
2075 made to return to read a new object name because the standard allows too
2076 little data to be available. On the other hand, too much data is an
2080 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2081 namelist_info **pprev_nl, char *nml_err_msg,
2082 index_type clow, index_type chigh)
2085 namelist_info * cmp;
2092 index_type obj_name_len;
2095 /* This object not touched in name parsing. */
2100 dtp->u.p.repeat_count = 0;
2107 case GFC_DTYPE_INTEGER:
2108 case GFC_DTYPE_LOGICAL:
2112 case GFC_DTYPE_REAL:
2113 dlen = size_from_real_kind (len);
2116 case GFC_DTYPE_COMPLEX:
2117 dlen = size_from_complex_kind (len);
2120 case GFC_DTYPE_CHARACTER:
2121 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2131 /* Update the pointer to the data, using the current index vector */
2133 pdata = (void*)(nl->mem_pos + offset);
2134 for (dim = 0; dim < nl->var_rank; dim++)
2135 pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
2136 nl->dim[dim].stride * nl->size);
2138 /* Reset the error flag and try to read next value, if
2139 dtp->u.p.repeat_count=0 */
2141 dtp->u.p.nml_read_error = 0;
2143 if (--dtp->u.p.repeat_count <= 0)
2145 if (dtp->u.p.input_complete)
2147 if (dtp->u.p.at_eol)
2148 finish_separator (dtp);
2149 if (dtp->u.p.input_complete)
2152 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2153 after the switch block. */
2155 dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
2160 case GFC_DTYPE_INTEGER:
2161 read_integer (dtp, len);
2164 case GFC_DTYPE_LOGICAL:
2165 read_logical (dtp, len);
2168 case GFC_DTYPE_CHARACTER:
2169 read_character (dtp, len);
2172 case GFC_DTYPE_REAL:
2173 read_real (dtp, len);
2176 case GFC_DTYPE_COMPLEX:
2177 read_complex (dtp, len, dlen);
2180 case GFC_DTYPE_DERIVED:
2181 obj_name_len = strlen (nl->var_name) + 1;
2182 obj_name = get_mem (obj_name_len+1);
2183 memcpy (obj_name, nl->var_name, obj_name_len-1);
2184 memcpy (obj_name + obj_name_len - 1, "%", 2);
2186 /* If reading a derived type, disable the expanded read warning
2187 since a single object can have multiple reads. */
2188 dtp->u.p.expanded_read = 0;
2190 /* Now loop over the components. Update the component pointer
2191 with the return value from nml_write_obj. This loop jumps
2192 past nested derived types by testing if the potential
2193 component name contains '%'. */
2195 for (cmp = nl->next;
2197 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2198 !strchr (cmp->var_name + obj_name_len, '%');
2202 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2203 pprev_nl, nml_err_msg, clow, chigh)
2206 free_mem (obj_name);
2210 if (dtp->u.p.input_complete)
2212 free_mem (obj_name);
2217 free_mem (obj_name);
2221 sprintf (nml_err_msg, "Bad type for namelist object %s",
2223 internal_error (&dtp->common, nml_err_msg);
2228 /* The standard permits array data to stop short of the number of
2229 elements specified in the loop specification. In this case, we
2230 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2231 nml_get_obj_data and an attempt is made to read object name. */
2234 if (dtp->u.p.nml_read_error)
2236 dtp->u.p.expanded_read = 0;
2240 if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
2242 dtp->u.p.expanded_read = 0;
2246 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2247 This comes about because the read functions return BT_types. */
2249 switch (dtp->u.p.saved_type)
2256 memcpy (pdata, dtp->u.p.value, dlen);
2260 m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2261 pdata = (void*)( pdata + clow - 1 );
2262 memcpy (pdata, dtp->u.p.saved_string, m);
2264 memset ((void*)( pdata + m ), ' ', dlen - m);
2271 /* Warn if a non-standard expanded read occurs. A single read of a
2272 single object is acceptable. If a second read occurs, issue a warning
2273 and set the flag to zero to prevent further warnings. */
2274 if (dtp->u.p.expanded_read == 2)
2276 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
2277 dtp->u.p.expanded_read = 0;
2280 /* If the expanded read warning flag is set, increment it,
2281 indicating that a single read has occurred. */
2282 if (dtp->u.p.expanded_read >= 1)
2283 dtp->u.p.expanded_read++;
2285 /* Break out of loop if scalar. */
2289 /* Now increment the index vector. */
2294 for (dim = 0; dim < nl->var_rank; dim++)
2296 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2298 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2300 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2302 nl->ls[dim].idx = nl->ls[dim].start;
2306 } while (!nml_carry);
2308 if (dtp->u.p.repeat_count > 1)
2310 sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
2321 /* Parses the object name, including array and substring qualifiers. It
2322 iterates over derived type components, touching those components and
2323 setting their loop specifications, if there is a qualifier. If the
2324 object is itself a derived type, its components and subcomponents are
2325 touched. nml_read_obj is called at the end and this reads the data in
2326 the manner specified by the object name. */
2329 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2334 namelist_info * first_nl = NULL;
2335 namelist_info * root_nl = NULL;
2338 char parse_err_msg[30];
2339 index_type clow, chigh;
2341 /* Look for end of input or object name. If '?' or '=?' are encountered
2342 in stdin, print the node names or the namelist to stdout. */
2344 eat_separator (dtp);
2345 if (dtp->u.p.input_complete)
2348 if (dtp->u.p.at_eol)
2349 finish_separator (dtp);
2350 if (dtp->u.p.input_complete)
2353 c = next_char (dtp);
2357 c = next_char (dtp);
2360 sprintf (nml_err_msg, "namelist read: misplaced = sign");
2363 nml_query (dtp, '=');
2367 nml_query (dtp, '?');
2372 nml_match_name (dtp, "end", 3);
2373 if (dtp->u.p.nml_read_error)
2375 sprintf (nml_err_msg, "namelist not terminated with / or &end");
2379 dtp->u.p.input_complete = 1;
2386 /* Untouch all nodes of the namelist and reset the flag that is set for
2387 derived type components. */
2389 nml_untouch_nodes (dtp);
2392 /* Get the object name - should '!' and '\n' be permitted separators? */
2400 push_char (dtp, tolower(c));
2401 c = next_char (dtp);
2402 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2404 unget_char (dtp, c);
2406 /* Check that the name is in the namelist and get pointer to object.
2407 Three error conditions exist: (i) An attempt is being made to
2408 identify a non-existent object, following a failed data read or
2409 (ii) The object name does not exist or (iii) Too many data items
2410 are present for an object. (iii) gives the same error message
2413 push_char (dtp, '\0');
2417 size_t var_len = strlen (root_nl->var_name);
2419 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2420 char ext_name[var_len + saved_len + 1];
2422 memcpy (ext_name, root_nl->var_name, var_len);
2423 if (dtp->u.p.saved_string)
2424 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2425 ext_name[var_len + saved_len] = '\0';
2426 nl = find_nml_node (dtp, ext_name);
2429 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2433 if (dtp->u.p.nml_read_error && *pprev_nl)
2434 sprintf (nml_err_msg, "Bad data for namelist object %s",
2435 (*pprev_nl)->var_name);
2438 sprintf (nml_err_msg, "Cannot match namelist object name %s",
2439 dtp->u.p.saved_string);
2444 /* Get the length, data length, base pointer and rank of the variable.
2445 Set the default loop specification first. */
2447 for (dim=0; dim < nl->var_rank; dim++)
2449 nl->ls[dim].step = 1;
2450 nl->ls[dim].end = nl->dim[dim].ubound;
2451 nl->ls[dim].start = nl->dim[dim].lbound;
2452 nl->ls[dim].idx = nl->ls[dim].start;
2455 /* Check to see if there is a qualifier: if so, parse it.*/
2457 if (c == '(' && nl->var_rank)
2459 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2460 parse_err_msg) == FAILURE)
2462 sprintf (nml_err_msg, "%s for namelist variable %s",
2463 parse_err_msg, nl->var_name);
2466 c = next_char (dtp);
2467 unget_char (dtp, c);
2470 /* Now parse a derived type component. The root namelist_info address
2471 is backed up, as is the previous component level. The component flag
2472 is set and the iteration is made by jumping back to get_name. */
2477 if (nl->type != GFC_DTYPE_DERIVED)
2479 sprintf (nml_err_msg, "Attempt to get derived component for %s",
2484 if (!component_flag)
2489 c = next_char (dtp);
2494 /* Parse a character qualifier, if present. chigh = 0 is a default
2495 that signals that the string length = string_length. */
2500 if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2502 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2503 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2505 if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
2507 sprintf (nml_err_msg, "%s for namelist variable %s",
2508 parse_err_msg, nl->var_name);
2512 clow = ind[0].start;
2515 if (ind[0].step != 1)
2517 sprintf (nml_err_msg,
2518 "Bad step in substring for namelist object %s",
2523 c = next_char (dtp);
2524 unget_char (dtp, c);
2527 /* If a derived type touch its components and restore the root
2528 namelist_info if we have parsed a qualified derived type
2531 if (nl->type == GFC_DTYPE_DERIVED)
2532 nml_touch_nodes (nl);
2536 /*make sure no extraneous qualifiers are there.*/
2540 sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
2541 " namelist object %s", nl->var_name);
2545 /* According to the standard, an equal sign MUST follow an object name. The
2546 following is possibly lax - it allows comments, blank lines and so on to
2547 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2551 eat_separator (dtp);
2552 if (dtp->u.p.input_complete)
2555 if (dtp->u.p.at_eol)
2556 finish_separator (dtp);
2557 if (dtp->u.p.input_complete)
2560 c = next_char (dtp);
2564 sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
2569 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
2579 /* Entry point for namelist input. Goes through input until namelist name
2580 is matched. Then cycles through nml_get_obj_data until the input is
2581 completed or there is an error. */
2584 namelist_read (st_parameter_dt *dtp)
2588 char nml_err_msg[100];
2589 /* Pointer to the previously read object, in case attempt is made to read
2590 new object name. Should this fail, error message can give previous
2592 namelist_info *prev_nl = NULL;
2594 dtp->u.p.namelist_mode = 1;
2595 dtp->u.p.input_complete = 0;
2596 dtp->u.p.expanded_read = 0;
2598 dtp->u.p.eof_jump = &eof_jump;
2599 if (setjmp (eof_jump))
2601 dtp->u.p.eof_jump = NULL;
2602 generate_error (&dtp->common, LIBERROR_END, NULL);
2606 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2607 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2608 node names or namelist on stdout. */
2611 switch (c = next_char (dtp))
2622 c = next_char (dtp);
2624 nml_query (dtp, '=');
2626 unget_char (dtp, c);
2630 nml_query (dtp, '?');
2636 /* Match the name of the namelist. */
2638 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2640 if (dtp->u.p.nml_read_error)
2643 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2644 c = next_char (dtp);
2645 if (!is_separator(c))
2647 unget_char (dtp, c);
2651 /* Ready to read namelist objects. If there is an error in input
2652 from stdin, output the error message and continue. */
2654 while (!dtp->u.p.input_complete)
2656 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
2660 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2663 u = find_unit (options.stderr_unit);
2664 st_printf ("%s\n", nml_err_msg);
2674 dtp->u.p.eof_jump = NULL;
2679 /* All namelist error calls return from here */
2683 dtp->u.p.eof_jump = NULL;
2686 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);