1 /* Copyright (C) 2002, 2003, 2004, 2005 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, 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA. */
35 #include "libgfortran.h"
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
51 ourselves. Data is buffered in scratch[] until it becomes too
52 large, after which we start allocating memory on the heap. */
54 static int repeat_count, saved_length, saved_used;
55 static int input_complete, at_eol, comma_flag;
56 static char last_char, *saved_string;
59 /* A namelist specific flag used in the list directed library
60 to flag that calls are being made from namelist read (eg. to ignore
61 comments or to treat '/' as a terminator) */
63 static int namelist_mode;
65 /* A namelist specific flag used in the list directed library to flag
66 read errors and return, so that an attempt can be made to read a
69 static int nml_read_error;
71 /* Storage area for values except for strings. Must be large enough
72 to hold a complex value (two reals) of the largest kind. */
74 static char value[20];
76 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
77 case '5': case '6': case '7': case '8': case '9'
79 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
82 /* This macro assumes that we're operating on a variable. */
84 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
85 || c == '\t' || c == '\r')
87 /* Maximum repeat count. Less than ten times the maximum signed int32. */
89 #define MAX_REPEAT 200000000
92 /* Save a character to a string buffer, enlarging it as necessary. */
99 if (saved_string == NULL)
101 saved_string = scratch;
102 memset (saved_string,0,SCRATCH_SIZE);
103 saved_length = SCRATCH_SIZE;
107 if (saved_used >= saved_length)
109 saved_length = 2 * saved_length;
110 new = get_mem (2 * saved_length);
112 memset (new,0,2 * saved_length);
114 memcpy (new, saved_string, saved_used);
115 if (saved_string != scratch)
116 free_mem (saved_string);
121 saved_string[saved_used++] = c;
125 /* Free the input buffer if necessary. */
130 if (saved_string == NULL)
133 if (saved_string != scratch)
134 free_mem (saved_string);
146 if (last_char != '\0')
156 p = salloc_r (current_unit->s, &length);
159 generate_error (ERROR_OS, NULL);
165 /* For internal files return a newline instead of signalling EOF. */
166 /* ??? This isn't quite right, but we don't handle internal files
167 with multiple records. */
168 if (is_internal_unit ())
171 longjmp (g.eof_jump, 1);
177 at_eol = (c == '\n' || c == '\r');
182 /* Push a character back onto the input. */
191 /* Skip over spaces in the input. Returns the nonspace character that
192 terminated the eating and also places it back on the input. */
203 while (c == ' ' || c == '\t');
210 /* Skip over a separator. Technically, we don't always eat the whole
211 separator. This is because if we've processed the last input item,
212 then a separator is unnecessary. Plus the fact that operating
213 systems usually deliver console input on a line basis.
215 The upshot is that if we see a newline as part of reading a
216 separator, we stop reading. If there are more input items, we
217 continue reading the separator with finish_separator() which takes
218 care of the fact that we may or may not have seen a comma as part
253 { /* Eat a namelist comment. */
261 /* Fall Through... */
270 /* Finish processing a separator that was interrupted by a newline.
271 If we're here, then another data item is present, so we finish what
272 we started on the previous line. */
275 finish_separator (void)
299 if (!namelist_mode) next_record (0);
322 /* This function is needed to catch bad conversions so that namelist can
323 attempt to see if saved_string contains a new object name rather than
327 nml_bad_return (char c)
338 /* Convert an unsigned string to an integer. The length value is -1
339 if we are working on a repeat count. Returns nonzero if we have a
340 range problem. As a side effect, frees the saved_string. */
343 convert_integer (int length, int negative)
345 char c, *buffer, message[100];
347 int64_t v, max, max10;
349 buffer = saved_string;
352 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
377 set_integer (value, v, length);
383 if (repeat_count == 0)
385 st_sprintf (message, "Zero repeat count in item %d of list input",
388 generate_error (ERROR_READ_VALUE, message);
398 st_sprintf (message, "Repeat count overflow in item %d of list input",
401 st_sprintf (message, "Integer overflow while reading item %d",
405 generate_error (ERROR_READ_VALUE, message);
411 /* Parse a repeat count for logical and complex values which cannot
412 begin with a digit. Returns nonzero if we are done, zero if we
413 should continue on. */
418 char c, message[100];
444 repeat = 10 * repeat + c - '0';
446 if (repeat > MAX_REPEAT)
449 "Repeat count overflow in item %d of list input",
452 generate_error (ERROR_READ_VALUE, message);
462 "Zero repeat count in item %d of list input",
465 generate_error (ERROR_READ_VALUE, message);
477 repeat_count = repeat;
481 st_sprintf (message, "Bad repeat count in item %d of list input",
484 generate_error (ERROR_READ_VALUE, message);
489 /* Read a logical character on the input. */
492 read_logical (int length)
494 char c, message[100];
533 return; /* Null value. */
539 saved_type = BT_LOGICAL;
540 saved_length = length;
542 /* Eat trailing garbage. */
547 while (!is_separator (c));
552 set_integer ((int *) value, v, length);
558 if (nml_bad_return (c))
561 st_sprintf (message, "Bad logical value while reading item %d",
564 generate_error (ERROR_READ_VALUE, message);
568 /* Reading integers is tricky because we can actually be reading a
569 repeat count. We have to store the characters in a buffer because
570 we could be reading an integer that is larger than the default int
571 used for repeat counts. */
574 read_integer (int length)
576 char c, message[100];
586 /* Fall through... */
592 CASE_SEPARATORS: /* Single null. */
605 /* Take care of what may be a repeat count. */
620 CASE_SEPARATORS: /* Not a repeat count. */
629 if (convert_integer (-1, 0))
632 /* Get the real integer. */
647 /* Fall through... */
678 if (nml_bad_return (c))
683 st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
684 generate_error (ERROR_READ_VALUE, message);
693 if (convert_integer (length, negative))
700 saved_type = BT_INTEGER;
704 /* Read a character variable. */
707 read_character (int length)
709 char c, quote, message[100];
711 quote = ' '; /* Space means no quote character. */
721 unget_char (c); /* NULL value. */
735 /* Deal with a possible repeat count. */
748 goto done; /* String was only digits! */
756 goto get_string; /* Not a repeat count after all. */
761 if (convert_integer (-1, 0))
764 /* Now get the real string. */
770 unget_char (c); /* Repeated NULL values. */
798 /* See if we have a doubled quote character or the end of
828 /* At this point, we have to have a separator, or else the string is
832 if (is_separator (c))
836 saved_type = BT_CHARACTER;
841 st_sprintf (message, "Invalid string input in item %d", g.item_count);
842 generate_error (ERROR_READ_VALUE, message);
847 /* Parse a component of a complex constant or a real number that we
848 are sure is already there. This is a straight real number parser. */
851 parse_real (void *buffer, int length)
853 char c, message[100];
857 if (c == '-' || c == '+')
863 if (!isdigit (c) && c != '.')
868 seen_dp = (c == '.') ? 1 : 0;
912 if (c != '-' && c != '+')
947 m = convert_real (buffer, saved_string, length);
954 st_sprintf (message, "Bad floating point number for item %d", g.item_count);
955 generate_error (ERROR_READ_VALUE, message);
961 /* Reading a complex number is straightforward because we can tell
962 what it is right away. */
965 read_complex (int length)
989 if (parse_real (value, length))
993 if (next_char () != ',')
997 if (parse_real (value + length, length))
1001 if (next_char () != ')')
1005 if (!is_separator (c))
1012 saved_type = BT_COMPLEX;
1017 if (nml_bad_return (c))
1020 st_sprintf (message, "Bad complex value in item %d of list input",
1023 generate_error (ERROR_READ_VALUE, message);
1027 /* Parse a real number with a possible repeat count. */
1030 read_real (int length)
1032 char c, message[100];
1054 unget_char (c); /* Single null. */
1062 /* Get the digit string that might be a repeat count. */
1099 if (c != '\n' && c != ',' && c != '\r')
1109 if (convert_integer (-1, 0))
1112 /* Now get the number itself. */
1115 if (is_separator (c))
1116 { /* Repeated null value. */
1122 if (c != '-' && c != '+')
1131 if (!isdigit (c) && c != '.')
1187 if (c != '+' && c != '-')
1222 if (convert_real (value, saved_string, length))
1226 saved_type = BT_REAL;
1231 if (nml_bad_return (c))
1234 st_sprintf (message, "Bad real number in item %d of list input",
1237 generate_error (ERROR_READ_VALUE, message);
1241 /* Check the current type against the saved type to make sure they are
1242 compatible. Returns nonzero if incompatible. */
1245 check_type (bt type, int len)
1249 if (saved_type != BT_NULL && saved_type != type)
1251 st_sprintf (message, "Read type %s where %s was expected for item %d",
1252 type_name (saved_type), type_name (type), g.item_count);
1254 generate_error (ERROR_READ_VALUE, message);
1258 if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
1261 if (saved_length != len)
1263 st_sprintf (message,
1264 "Read kind %d %s where kind %d is required for item %d",
1265 saved_length, type_name (saved_type), len, g.item_count);
1266 generate_error (ERROR_READ_VALUE, message);
1274 /* Top level data transfer subroutine for list reads. Because we have
1275 to deal with repeat counts, the data item is always saved after
1276 reading, usually in the value[] array. If a repeat count is
1277 greater than one, we copy the data item multiple times. */
1280 list_formatted_read (bt type, void *p, int len)
1287 if (setjmp (g.eof_jump))
1289 generate_error (ERROR_END, NULL);
1301 if (is_separator (c))
1302 { /* Found a null value. */
1306 finish_separator ();
1317 if (repeat_count > 0)
1319 if (check_type (type, len))
1325 finish_separator ();
1329 /* trailing spaces prior to end of line */
1331 finish_separator ();
1334 saved_type = BT_NULL;
1347 read_character (len);
1356 internal_error ("Bad type for list read");
1359 if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
1362 if (ioparm.library_return != LIBRARY_OK)
1375 memcpy (p, value, len);
1381 m = (len < saved_used) ? len : saved_used;
1382 memcpy (p, saved_string, m);
1385 /* Just delimiters encountered, nothing to copy but SPACE. */
1389 memset (((char *) p) + m, ' ', len - m);
1396 if (--repeat_count <= 0)
1406 /* Finish a list read. */
1409 finish_list_read (void)
1430 void namelist_read (void)
1432 static void nml_match_name (char *name, int len)
1433 static int nml_query (void)
1434 static int nml_get_obj_data (void)
1436 static void nml_untouch_nodes (void)
1437 static namelist_info * find_nml_node (char * var_name)
1438 static int nml_parse_qualifier(descriptor_dimension * ad,
1439 nml_loop_spec * ls, int rank)
1440 static void nml_touch_nodes (namelist_info * nl)
1441 static int nml_read_obj (namelist_info * nl, index_type offset)
1445 /* Carries error messages from the qualifier parser. */
1446 static char parse_err_msg[30];
1448 /* Carries error messages for error returns. */
1449 static char nml_err_msg[100];
1451 /* Pointer to the previously read object, in case attempt is made to read
1452 new object name. Should this fail, error message can give previous
1455 static namelist_info * prev_nl;
1457 /* Lower index for substring qualifier. */
1459 static index_type clow;
1461 /* Upper index for substring qualifier. */
1463 static index_type chigh;
1465 /* Inputs a rank-dimensional qualifier, which can contain
1466 singlets, doublets, triplets or ':' with the standard meanings. */
1469 nml_parse_qualifier(descriptor_dimension * ad,
1470 nml_loop_spec * ls, int rank)
1478 /* The next character in the stream should be the '('. */
1482 /* Process the qualifier, by dimension and triplet. */
1484 for (dim=0; dim < rank; dim++ )
1486 for (indx=0; indx<3; indx++)
1492 /*process a potential sign. */
1509 /*process characters up to the next ':' , ',' or ')' */
1521 if ( (c==',' && dim == rank -1)
1522 || (c==')' && dim < rank -1))
1524 st_sprintf (parse_err_msg,
1525 "Bad number of index fields");
1534 case ' ': case '\t':
1540 st_sprintf (parse_err_msg, "Bad character in index");
1544 if (( c==',' || c==')') && indx==0 && saved_string == 0 )
1546 st_sprintf (parse_err_msg, "Null index field");
1550 if ( ( c==':' && indx==1 && saved_string == 0)
1551 || (indx==2 && saved_string == 0))
1553 st_sprintf(parse_err_msg, "Bad index triplet");
1557 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1559 if ( (c==':' && indx==0 && saved_string == 0)
1560 || (indx==1 && saved_string == 0))
1566 /* Now read the index. */
1568 if (convert_integer (sizeof(int),neg))
1570 st_sprintf (parse_err_msg, "Bad integer in index");
1576 /*feed the index values to the triplet arrays. */
1581 ls[dim].start = *(int *)value;
1583 ls[dim].end = *(int *)value;
1585 ls[dim].step = *(int *)value;
1588 /*singlet or doublet indices */
1590 if (c==',' || c==')')
1594 ls[dim].start = *(int *)value;
1595 ls[dim].end = *(int *)value;
1601 /*Check the values of the triplet indices. */
1603 if ( (ls[dim].start > (ssize_t)ad[dim].ubound)
1604 || (ls[dim].start < (ssize_t)ad[dim].lbound)
1605 || (ls[dim].end > (ssize_t)ad[dim].ubound)
1606 || (ls[dim].end < (ssize_t)ad[dim].lbound))
1608 st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
1611 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
1612 || (ls[dim].step == 0))
1614 st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
1618 /* Initialise the loop index counter. */
1620 ls[dim].idx = ls[dim].start;
1631 static namelist_info *
1632 find_nml_node (char * var_name)
1634 namelist_info * t = ionml;
1637 if (strcmp (var_name,t->var_name) == 0)
1647 /* Visits all the components of a derived type that have
1648 not explicitly been identified in the namelist input.
1649 touched is set and the loop specification initialised
1650 to default values */
1653 nml_touch_nodes (namelist_info * nl)
1655 index_type len = strlen (nl->var_name) + 1;
1657 char * ext_name = (char*)get_mem (len + 1);
1658 strcpy (ext_name, nl->var_name);
1659 strcat (ext_name, "%");
1660 for (nl = nl->next; nl; nl = nl->next)
1662 if (strncmp (nl->var_name, ext_name, len) == 0)
1665 for (dim=0; dim < nl->var_rank; dim++)
1667 nl->ls[dim].step = 1;
1668 nl->ls[dim].end = nl->dim[dim].ubound;
1669 nl->ls[dim].start = nl->dim[dim].lbound;
1670 nl->ls[dim].idx = nl->ls[dim].start;
1676 free_mem (ext_name);
1680 /* Resets touched for the entire list of nml_nodes, ready for a
1684 nml_untouch_nodes (void)
1687 for (t = ionml; t; t = t->next)
1692 /* Attempts to input name to namelist name. Returns nml_read_error = 1
1696 nml_match_name (char *name, index_type len)
1701 for (i = 0; i < len; i++)
1704 if (tolower (c) != tolower (name[i]))
1712 /* If the namelist read is from stdin, output the current state of the
1713 namelist to stdout. This is used to implement the non-standard query
1714 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1715 the names alone are printed. */
1720 gfc_unit * temp_unit;
1725 if (current_unit->unit_number != options.stdin_unit)
1728 /* Store the current unit and transfer to stdout. */
1730 temp_unit = current_unit;
1731 current_unit = find_unit (options.stdout_unit);
1738 /* Write the namelist in its entirety. */
1743 /* Or write the list of names. */
1748 /* "&namelist_name\n" */
1750 len = ioparm.namelist_name_len;
1751 p = write_block (len + 2);
1755 memcpy ((char*)(p + 1), ioparm.namelist_name, len);
1756 memcpy ((char*)(p + len + 1), "\n", 1);
1757 for (nl =ionml; nl; nl = nl->next)
1762 len = strlen (nl->var_name);
1763 p = write_block (len + 2);
1767 memcpy ((char*)(p + 1), nl->var_name, len);
1768 memcpy ((char*)(p + len + 1), "\n", 1);
1773 p = write_block (5);
1776 memcpy (p, "&end\n", 5);
1779 /* Flush the stream to force immediate output. */
1781 flush (current_unit->s);
1786 /* Restore the current unit. */
1788 current_unit = temp_unit;
1793 /* Reads and stores the input for the namelist object nl. For an array,
1794 the function loops over the ranges defined by the loop specification.
1795 This default to all the data or to the specification from a qualifier.
1796 nml_read_obj recursively calls itself to read derived types. It visits
1797 all its own components but only reads data for those that were touched
1798 when the name was parsed. If a read error is encountered, an attempt is
1799 made to return to read a new object name because the standard allows too
1800 little data to be available. On the other hand, too much data is an
1804 nml_read_obj (namelist_info * nl, index_type offset)
1807 namelist_info * cmp;
1814 index_type obj_name_len;
1817 /* This object not touched in name parsing. */
1829 case GFC_DTYPE_INTEGER:
1830 case GFC_DTYPE_LOGICAL:
1831 case GFC_DTYPE_REAL:
1835 case GFC_DTYPE_COMPLEX:
1839 case GFC_DTYPE_CHARACTER:
1840 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
1850 /* Update the pointer to the data, using the current index vector */
1852 pdata = (void*)(nl->mem_pos + offset);
1853 for (dim = 0; dim < nl->var_rank; dim++)
1854 pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
1855 nl->dim[dim].stride * nl->size);
1857 /* Reset the error flag and try to read next value, if
1862 if (--repeat_count <= 0)
1867 finish_separator ();
1871 /* GFC_TYPE_UNKNOWN through for nulls and is detected
1872 after the switch block. */
1874 saved_type = GFC_DTYPE_UNKNOWN;
1879 case GFC_DTYPE_INTEGER:
1883 case GFC_DTYPE_LOGICAL:
1887 case GFC_DTYPE_CHARACTER:
1888 read_character (len);
1891 case GFC_DTYPE_REAL:
1895 case GFC_DTYPE_COMPLEX:
1899 case GFC_DTYPE_DERIVED:
1900 obj_name_len = strlen (nl->var_name) + 1;
1901 obj_name = get_mem (obj_name_len+1);
1902 strcpy (obj_name, nl->var_name);
1903 strcat (obj_name, "%");
1905 /* Now loop over the components. Update the component pointer
1906 with the return value from nml_write_obj. This loop jumps
1907 past nested derived types by testing if the potential
1908 component name contains '%'. */
1910 for (cmp = nl->next;
1912 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
1913 !strchr (cmp->var_name + obj_name_len, '%');
1917 if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
1919 free_mem (obj_name);
1925 free_mem (obj_name);
1930 free_mem (obj_name);
1934 st_sprintf (nml_err_msg, "Bad type for namelist object %s",
1936 internal_error (nml_err_msg);
1941 /* The standard permits array data to stop short of the number of
1942 elements specified in the loop specification. In this case, we
1943 should be here with nml_read_error != 0. Control returns to
1944 nml_get_obj_data and an attempt is made to read object name. */
1950 if (saved_type == GFC_DTYPE_UNKNOWN)
1954 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
1955 This comes about because the read functions return BT_types. */
1964 memcpy (pdata, value, dlen);
1968 m = (dlen < saved_used) ? dlen : saved_used;
1969 pdata = (void*)( pdata + clow - 1 );
1970 memcpy (pdata, saved_string, m);
1972 memset ((void*)( pdata + m ), ' ', dlen - m);
1979 /* Break out of loop if scalar. */
1984 /* Now increment the index vector. */
1989 for (dim = 0; dim < nl->var_rank; dim++)
1991 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
1993 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
1995 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
1997 nl->ls[dim].idx = nl->ls[dim].start;
2001 } while (!nml_carry);
2003 if (repeat_count > 1)
2005 st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
2016 /* Parses the object name, including array and substring qualifiers. It
2017 iterates over derived type components, touching those components and
2018 setting their loop specifications, if there is a qualifier. If the
2019 object is itself a derived type, its components and subcomponents are
2020 touched. nml_read_obj is called at the end and this reads the data in
2021 the manner specified by the object name. */
2024 nml_get_obj_data (void)
2029 namelist_info * first_nl = NULL;
2030 namelist_info * root_nl = NULL;
2034 /* Look for end of input or object name. If '?' or '=?' are encountered
2035 in stdin, print the node names or the namelist to stdout. */
2042 finish_separator ();
2053 st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
2065 nml_match_name ("end", 3);
2068 st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
2079 /* Untouch all nodes of the namelist and reset the flag that is set for
2080 derived type components. */
2082 nml_untouch_nodes();
2085 /* Get the object name - should '!' and '\n' be permitted separators? */
2093 push_char(tolower(c));
2095 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2099 /* Check that the name is in the namelist and get pointer to object.
2100 Three error conditions exist: (i) An attempt is being made to
2101 identify a non-existent object, following a failed data read or
2102 (ii) The object name does not exist or (iii) Too many data items
2103 are present for an object. (iii) gives the same error message
2110 ext_name = (char*)get_mem (strlen (root_nl->var_name)
2111 + (saved_string ? strlen (saved_string) : 0)
2113 strcpy (ext_name, root_nl->var_name);
2114 strcat (ext_name, saved_string);
2115 nl = find_nml_node (ext_name);
2116 free_mem (ext_name);
2119 nl = find_nml_node (saved_string);
2123 if (nml_read_error && prev_nl)
2124 st_sprintf (nml_err_msg, "Bad data for namelist object %s",
2128 st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
2134 /* Get the length, data length, base pointer and rank of the variable.
2135 Set the default loop specification first. */
2137 for (dim=0; dim < nl->var_rank; dim++)
2139 nl->ls[dim].step = 1;
2140 nl->ls[dim].end = nl->dim[dim].ubound;
2141 nl->ls[dim].start = nl->dim[dim].lbound;
2142 nl->ls[dim].idx = nl->ls[dim].start;
2145 /* Check to see if there is a qualifier: if so, parse it.*/
2147 if (c == '(' && nl->var_rank)
2149 if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
2151 st_sprintf (nml_err_msg, "%s for namelist variable %s",
2152 parse_err_msg, nl->var_name);
2159 /* Now parse a derived type component. The root namelist_info address
2160 is backed up, as is the previous component level. The component flag
2161 is set and the iteration is made by jumping back to get_name. */
2166 if (nl->type != GFC_DTYPE_DERIVED)
2168 st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
2173 if (!component_flag)
2183 /* Parse a character qualifier, if present. chigh = 0 is a default
2184 that signals that the string length = string_length. */
2189 if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2191 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2192 nml_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2194 if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
2196 st_sprintf (nml_err_msg, "%s for namelist variable %s",
2197 parse_err_msg, nl->var_name);
2201 clow = ind[0].start;
2204 if (ind[0].step != 1)
2206 st_sprintf (nml_err_msg,
2207 "Bad step in substring for namelist object %s",
2216 /* If a derived type touch its components and restore the root
2217 namelist_info if we have parsed a qualified derived type
2220 if (nl->type == GFC_DTYPE_DERIVED)
2221 nml_touch_nodes (nl);
2225 /*make sure no extraneous qualifiers are there.*/
2229 st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
2230 " namelist object %s", nl->var_name);
2234 /* According to the standard, an equal sign MUST follow an object name. The
2235 following is possibly lax - it allows comments, blank lines and so on to
2236 intervene. eat_spaces (); c = next_char (); would be compliant*/
2245 finish_separator ();
2253 st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
2258 if (nml_read_obj (nl, 0) == FAILURE)
2268 /* Entry point for namelist input. Goes through input until namelist name
2269 is matched. Then cycles through nml_get_obj_data until the input is
2270 completed or there is an error. */
2273 namelist_read (void)
2280 if (setjmp (g.eof_jump))
2282 generate_error (ERROR_END, NULL);
2286 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2287 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2288 node names or namelist on stdout. */
2291 switch (c = next_char ())
2312 /* Match the name of the namelist. */
2314 nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
2319 /* Ready to read namelist objects. If there is an error in input
2320 from stdin, output the error message and continue. */
2322 while (!input_complete)
2324 if (nml_get_obj_data () == FAILURE)
2326 if (current_unit->unit_number != options.stdin_unit)
2329 st_printf ("%s\n", nml_err_msg);
2330 flush (find_unit (options.stderr_unit)->s);
2337 /* All namelist error calls return from here */
2341 generate_error (ERROR_READ_VALUE , nml_err_msg);