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, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, 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
[32];
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
);
147 if (last_char
!= '\0')
157 p
= salloc_r (current_unit
->s
, &length
);
160 generate_error (ERROR_OS
, NULL
);
166 /* For internal files return a newline instead of signalling EOF. */
167 /* ??? This isn't quite right, but we don't handle internal files
168 with multiple records. */
169 if (is_internal_unit ())
172 longjmp (g
.eof_jump
, 1);
178 at_eol
= (c
== '\n' || c
== '\r');
183 /* Push a character back onto the input. */
192 /* Skip over spaces in the input. Returns the nonspace character that
193 terminated the eating and also places it back on the input. */
204 while (c
== ' ' || c
== '\t');
211 /* Skip over a separator. Technically, we don't always eat the whole
212 separator. This is because if we've processed the last input item,
213 then a separator is unnecessary. Plus the fact that operating
214 systems usually deliver console input on a line basis.
216 The upshot is that if we see a newline as part of reading a
217 separator, we stop reading. If there are more input items, we
218 continue reading the separator with finish_separator() which takes
219 care of the fact that we may or may not have seen a comma as part
249 { /* Eat a namelist comment. */
257 /* Fall Through... */
266 /* Finish processing a separator that was interrupted by a newline.
267 If we're here, then another data item is present, so we finish what
268 we started on the previous line. */
271 finish_separator (void)
295 if (!namelist_mode
) next_record (0);
318 /* This function is needed to catch bad conversions so that namelist can
319 attempt to see if saved_string contains a new object name rather than
323 nml_bad_return (char c
)
334 /* Convert an unsigned string to an integer. The length value is -1
335 if we are working on a repeat count. Returns nonzero if we have a
336 range problem. As a side effect, frees the saved_string. */
339 convert_integer (int length
, int negative
)
341 char c
, *buffer
, message
[100];
343 GFC_INTEGER_LARGEST v
, max
, max10
;
345 buffer
= saved_string
;
348 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
373 set_integer (value
, v
, length
);
379 if (repeat_count
== 0)
381 st_sprintf (message
, "Zero repeat count in item %d of list input",
384 generate_error (ERROR_READ_VALUE
, message
);
394 st_sprintf (message
, "Repeat count overflow in item %d of list input",
397 st_sprintf (message
, "Integer overflow while reading item %d",
401 generate_error (ERROR_READ_VALUE
, message
);
407 /* Parse a repeat count for logical and complex values which cannot
408 begin with a digit. Returns nonzero if we are done, zero if we
409 should continue on. */
414 char c
, message
[100];
440 repeat
= 10 * repeat
+ c
- '0';
442 if (repeat
> MAX_REPEAT
)
445 "Repeat count overflow in item %d of list input",
448 generate_error (ERROR_READ_VALUE
, message
);
458 "Zero repeat count in item %d of list input",
461 generate_error (ERROR_READ_VALUE
, message
);
473 repeat_count
= repeat
;
477 st_sprintf (message
, "Bad repeat count in item %d of list input",
480 generate_error (ERROR_READ_VALUE
, message
);
485 /* Read a logical character on the input. */
488 read_logical (int length
)
490 char c
, message
[100];
529 return; /* Null value. */
535 saved_type
= BT_LOGICAL
;
536 saved_length
= length
;
538 /* Eat trailing garbage. */
543 while (!is_separator (c
));
548 set_integer ((int *) value
, v
, length
);
554 if (nml_bad_return (c
))
557 st_sprintf (message
, "Bad logical value while reading item %d",
560 generate_error (ERROR_READ_VALUE
, message
);
564 /* Reading integers is tricky because we can actually be reading a
565 repeat count. We have to store the characters in a buffer because
566 we could be reading an integer that is larger than the default int
567 used for repeat counts. */
570 read_integer (int length
)
572 char c
, message
[100];
582 /* Fall through... */
588 CASE_SEPARATORS
: /* Single null. */
601 /* Take care of what may be a repeat count. */
616 CASE_SEPARATORS
: /* Not a repeat count. */
625 if (convert_integer (-1, 0))
628 /* Get the real integer. */
643 /* Fall through... */
674 if (nml_bad_return (c
))
679 st_sprintf (message
, "Bad integer for item %d in list input", g
.item_count
);
680 generate_error (ERROR_READ_VALUE
, message
);
689 if (convert_integer (length
, negative
))
696 saved_type
= BT_INTEGER
;
700 /* Read a character variable. */
703 read_character (int length
__attribute__ ((unused
)))
705 char c
, quote
, message
[100];
707 quote
= ' '; /* Space means no quote character. */
717 unget_char (c
); /* NULL value. */
731 /* Deal with a possible repeat count. */
744 goto done
; /* String was only digits! */
752 goto get_string
; /* Not a repeat count after all. */
757 if (convert_integer (-1, 0))
760 /* Now get the real string. */
766 unget_char (c
); /* Repeated NULL values. */
794 /* See if we have a doubled quote character or the end of
824 /* At this point, we have to have a separator, or else the string is
828 if (is_separator (c
))
832 saved_type
= BT_CHARACTER
;
837 st_sprintf (message
, "Invalid string input in item %d", g
.item_count
);
838 generate_error (ERROR_READ_VALUE
, message
);
843 /* Parse a component of a complex constant or a real number that we
844 are sure is already there. This is a straight real number parser. */
847 parse_real (void *buffer
, int length
)
849 char c
, message
[100];
853 if (c
== '-' || c
== '+')
859 if (!isdigit (c
) && c
!= '.')
864 seen_dp
= (c
== '.') ? 1 : 0;
908 if (c
!= '-' && c
!= '+')
943 m
= convert_real (buffer
, saved_string
, length
);
950 st_sprintf (message
, "Bad floating point number for item %d", g
.item_count
);
951 generate_error (ERROR_READ_VALUE
, message
);
957 /* Reading a complex number is straightforward because we can tell
958 what it is right away. */
961 read_complex (int kind
, size_t size
)
985 if (parse_real (value
, kind
))
991 if (c
== '\n' || c
== '\r')
996 if (next_char () != ',')
1002 if (c
== '\n' || c
== '\r')
1007 if (parse_real (value
+ size
/ 2, kind
))
1011 if (next_char () != ')')
1015 if (!is_separator (c
))
1022 saved_type
= BT_COMPLEX
;
1027 if (nml_bad_return (c
))
1030 st_sprintf (message
, "Bad complex value in item %d of list input",
1033 generate_error (ERROR_READ_VALUE
, message
);
1037 /* Parse a real number with a possible repeat count. */
1040 read_real (int length
)
1042 char c
, message
[100];
1064 unget_char (c
); /* Single null. */
1072 /* Get the digit string that might be a repeat count. */
1109 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1119 if (convert_integer (-1, 0))
1122 /* Now get the number itself. */
1125 if (is_separator (c
))
1126 { /* Repeated null value. */
1132 if (c
!= '-' && c
!= '+')
1141 if (!isdigit (c
) && c
!= '.')
1197 if (c
!= '+' && c
!= '-')
1232 if (convert_real (value
, saved_string
, length
))
1236 saved_type
= BT_REAL
;
1241 if (nml_bad_return (c
))
1244 st_sprintf (message
, "Bad real number in item %d of list input",
1247 generate_error (ERROR_READ_VALUE
, message
);
1251 /* Check the current type against the saved type to make sure they are
1252 compatible. Returns nonzero if incompatible. */
1255 check_type (bt type
, int len
)
1259 if (saved_type
!= BT_NULL
&& saved_type
!= type
)
1261 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1262 type_name (saved_type
), type_name (type
), g
.item_count
);
1264 generate_error (ERROR_READ_VALUE
, message
);
1268 if (saved_type
== BT_NULL
|| saved_type
== BT_CHARACTER
)
1271 if (saved_length
!= len
)
1273 st_sprintf (message
,
1274 "Read kind %d %s where kind %d is required for item %d",
1275 saved_length
, type_name (saved_type
), len
, g
.item_count
);
1276 generate_error (ERROR_READ_VALUE
, message
);
1284 /* Top level data transfer subroutine for list reads. Because we have
1285 to deal with repeat counts, the data item is always saved after
1286 reading, usually in the value[] array. If a repeat count is
1287 greater than one, we copy the data item multiple times. */
1290 list_formatted_read_scalar (bt type
, void *p
, int kind
, size_t size
)
1297 if (setjmp (g
.eof_jump
))
1299 generate_error (ERROR_END
, NULL
);
1311 if (is_separator (c
))
1312 { /* Found a null value. */
1316 finish_separator ();
1327 if (repeat_count
> 0)
1329 if (check_type (type
, kind
))
1335 finish_separator ();
1339 /* trailing spaces prior to end of line */
1341 finish_separator ();
1344 saved_type
= BT_NULL
;
1351 read_integer (kind
);
1354 read_logical (kind
);
1357 read_character (kind
);
1363 read_complex (kind
, size
);
1366 internal_error ("Bad type for list read");
1369 if (saved_type
!= BT_CHARACTER
&& saved_type
!= BT_NULL
)
1370 saved_length
= size
;
1372 if (ioparm
.library_return
!= LIBRARY_OK
)
1382 memcpy (p
, value
, size
);
1388 m
= ((int) size
< saved_used
) ? (int) size
: saved_used
;
1389 memcpy (p
, saved_string
, m
);
1392 /* Just delimiters encountered, nothing to copy but SPACE. */
1396 memset (((char *) p
) + m
, ' ', size
- m
);
1403 if (--repeat_count
<= 0)
1409 list_formatted_read (bt type
, void *p
, int kind
, size_t size
, size_t nelems
)
1416 /* Big loop over all the elements. */
1417 for (elem
= 0; elem
< nelems
; elem
++)
1420 list_formatted_read_scalar (type
, tmp
+ size
*elem
, kind
, size
);
1431 /* Finish a list read. */
1434 finish_list_read (void)
1455 void namelist_read (void)
1457 static void nml_match_name (char *name, int len)
1458 static int nml_query (void)
1459 static int nml_get_obj_data (void)
1461 static void nml_untouch_nodes (void)
1462 static namelist_info * find_nml_node (char * var_name)
1463 static int nml_parse_qualifier(descriptor_dimension * ad,
1464 array_loop_spec * ls, int rank)
1465 static void nml_touch_nodes (namelist_info * nl)
1466 static int nml_read_obj (namelist_info * nl, index_type offset)
1470 /* Carries error messages from the qualifier parser. */
1471 static char parse_err_msg
[30];
1473 /* Carries error messages for error returns. */
1474 static char nml_err_msg
[100];
1476 /* Pointer to the previously read object, in case attempt is made to read
1477 new object name. Should this fail, error message can give previous
1480 static namelist_info
* prev_nl
;
1482 /* Lower index for substring qualifier. */
1484 static index_type clow
;
1486 /* Upper index for substring qualifier. */
1488 static index_type chigh
;
1490 /* Inputs a rank-dimensional qualifier, which can contain
1491 singlets, doublets, triplets or ':' with the standard meanings. */
1494 nml_parse_qualifier(descriptor_dimension
* ad
,
1495 array_loop_spec
* ls
, int rank
)
1503 /* The next character in the stream should be the '('. */
1507 /* Process the qualifier, by dimension and triplet. */
1509 for (dim
=0; dim
< rank
; dim
++ )
1511 for (indx
=0; indx
<3; indx
++)
1517 /*process a potential sign. */
1534 /*process characters up to the next ':' , ',' or ')' */
1546 if ( (c
==',' && dim
== rank
-1)
1547 || (c
==')' && dim
< rank
-1))
1549 st_sprintf (parse_err_msg
,
1550 "Bad number of index fields");
1559 case ' ': case '\t':
1565 st_sprintf (parse_err_msg
, "Bad character in index");
1569 if (( c
==',' || c
==')') && indx
==0 && saved_string
== 0 )
1571 st_sprintf (parse_err_msg
, "Null index field");
1575 if ( ( c
==':' && indx
==1 && saved_string
== 0)
1576 || (indx
==2 && saved_string
== 0))
1578 st_sprintf(parse_err_msg
, "Bad index triplet");
1582 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1584 if ( (c
==':' && indx
==0 && saved_string
== 0)
1585 || (indx
==1 && saved_string
== 0))
1591 /* Now read the index. */
1593 if (convert_integer (sizeof(int),neg
))
1595 st_sprintf (parse_err_msg
, "Bad integer in index");
1601 /*feed the index values to the triplet arrays. */
1606 ls
[dim
].start
= *(int *)value
;
1608 ls
[dim
].end
= *(int *)value
;
1610 ls
[dim
].step
= *(int *)value
;
1613 /*singlet or doublet indices */
1615 if (c
==',' || c
==')')
1619 ls
[dim
].start
= *(int *)value
;
1620 ls
[dim
].end
= *(int *)value
;
1626 /*Check the values of the triplet indices. */
1628 if ( (ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1629 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1630 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1631 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1633 st_sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1636 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1637 || (ls
[dim
].step
== 0))
1639 st_sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1643 /* Initialise the loop index counter. */
1645 ls
[dim
].idx
= ls
[dim
].start
;
1656 static namelist_info
*
1657 find_nml_node (char * var_name
)
1659 namelist_info
* t
= ionml
;
1662 if (strcmp (var_name
,t
->var_name
) == 0)
1672 /* Visits all the components of a derived type that have
1673 not explicitly been identified in the namelist input.
1674 touched is set and the loop specification initialised
1675 to default values */
1678 nml_touch_nodes (namelist_info
* nl
)
1680 index_type len
= strlen (nl
->var_name
) + 1;
1682 char * ext_name
= (char*)get_mem (len
+ 1);
1683 strcpy (ext_name
, nl
->var_name
);
1684 strcat (ext_name
, "%");
1685 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1687 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1690 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1692 nl
->ls
[dim
].step
= 1;
1693 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1694 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1695 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1701 free_mem (ext_name
);
1705 /* Resets touched for the entire list of nml_nodes, ready for a
1709 nml_untouch_nodes (void)
1712 for (t
= ionml
; t
; t
= t
->next
)
1717 /* Attempts to input name to namelist name. Returns nml_read_error = 1
1721 nml_match_name (const char *name
, index_type len
)
1726 for (i
= 0; i
< len
; i
++)
1729 if (tolower (c
) != tolower (name
[i
]))
1737 /* If the namelist read is from stdin, output the current state of the
1738 namelist to stdout. This is used to implement the non-standard query
1739 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1740 the names alone are printed. */
1745 gfc_unit
* temp_unit
;
1750 if (current_unit
->unit_number
!= options
.stdin_unit
)
1753 /* Store the current unit and transfer to stdout. */
1755 temp_unit
= current_unit
;
1756 current_unit
= find_unit (options
.stdout_unit
);
1763 /* Write the namelist in its entirety. */
1768 /* Or write the list of names. */
1773 /* "&namelist_name\n" */
1775 len
= ioparm
.namelist_name_len
;
1776 p
= write_block (len
+ 2);
1780 memcpy ((char*)(p
+ 1), ioparm
.namelist_name
, len
);
1781 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1782 for (nl
=ionml
; nl
; nl
= nl
->next
)
1787 len
= strlen (nl
->var_name
);
1788 p
= write_block (len
+ 2);
1792 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1793 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1798 p
= write_block (5);
1801 memcpy (p
, "&end\n", 5);
1804 /* Flush the stream to force immediate output. */
1806 flush (current_unit
->s
);
1811 /* Restore the current unit. */
1813 current_unit
= temp_unit
;
1818 /* Reads and stores the input for the namelist object nl. For an array,
1819 the function loops over the ranges defined by the loop specification.
1820 This default to all the data or to the specification from a qualifier.
1821 nml_read_obj recursively calls itself to read derived types. It visits
1822 all its own components but only reads data for those that were touched
1823 when the name was parsed. If a read error is encountered, an attempt is
1824 made to return to read a new object name because the standard allows too
1825 little data to be available. On the other hand, too much data is an
1829 nml_read_obj (namelist_info
* nl
, index_type offset
)
1832 namelist_info
* cmp
;
1839 index_type obj_name_len
;
1842 /* This object not touched in name parsing. */
1854 case GFC_DTYPE_INTEGER
:
1855 case GFC_DTYPE_LOGICAL
:
1859 case GFC_DTYPE_REAL
:
1860 dlen
= size_from_real_kind (len
);
1863 case GFC_DTYPE_COMPLEX
:
1864 dlen
= size_from_complex_kind (len
);
1867 case GFC_DTYPE_CHARACTER
:
1868 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
1878 /* Update the pointer to the data, using the current index vector */
1880 pdata
= (void*)(nl
->mem_pos
+ offset
);
1881 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
1882 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
1883 nl
->dim
[dim
].stride
* nl
->size
);
1885 /* Reset the error flag and try to read next value, if
1890 if (--repeat_count
<= 0)
1895 finish_separator ();
1899 /* GFC_TYPE_UNKNOWN through for nulls and is detected
1900 after the switch block. */
1902 saved_type
= GFC_DTYPE_UNKNOWN
;
1907 case GFC_DTYPE_INTEGER
:
1911 case GFC_DTYPE_LOGICAL
:
1915 case GFC_DTYPE_CHARACTER
:
1916 read_character (len
);
1919 case GFC_DTYPE_REAL
:
1923 case GFC_DTYPE_COMPLEX
:
1924 read_complex (len
, dlen
);
1927 case GFC_DTYPE_DERIVED
:
1928 obj_name_len
= strlen (nl
->var_name
) + 1;
1929 obj_name
= get_mem (obj_name_len
+1);
1930 strcpy (obj_name
, nl
->var_name
);
1931 strcat (obj_name
, "%");
1933 /* Now loop over the components. Update the component pointer
1934 with the return value from nml_write_obj. This loop jumps
1935 past nested derived types by testing if the potential
1936 component name contains '%'. */
1938 for (cmp
= nl
->next
;
1940 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
1941 !strchr (cmp
->var_name
+ obj_name_len
, '%');
1945 if (nml_read_obj (cmp
, (index_type
)(pdata
- nl
->mem_pos
)) == FAILURE
)
1947 free_mem (obj_name
);
1953 free_mem (obj_name
);
1958 free_mem (obj_name
);
1962 st_sprintf (nml_err_msg
, "Bad type for namelist object %s",
1964 internal_error (nml_err_msg
);
1969 /* The standard permits array data to stop short of the number of
1970 elements specified in the loop specification. In this case, we
1971 should be here with nml_read_error != 0. Control returns to
1972 nml_get_obj_data and an attempt is made to read object name. */
1978 if (saved_type
== GFC_DTYPE_UNKNOWN
)
1982 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
1983 This comes about because the read functions return BT_types. */
1992 memcpy (pdata
, value
, dlen
);
1996 m
= (dlen
< saved_used
) ? dlen
: saved_used
;
1997 pdata
= (void*)( pdata
+ clow
- 1 );
1998 memcpy (pdata
, saved_string
, m
);
2000 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2007 /* Break out of loop if scalar. */
2012 /* Now increment the index vector. */
2017 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2019 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2021 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2023 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2025 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2029 } while (!nml_carry
);
2031 if (repeat_count
> 1)
2033 st_sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2044 /* Parses the object name, including array and substring qualifiers. It
2045 iterates over derived type components, touching those components and
2046 setting their loop specifications, if there is a qualifier. If the
2047 object is itself a derived type, its components and subcomponents are
2048 touched. nml_read_obj is called at the end and this reads the data in
2049 the manner specified by the object name. */
2052 nml_get_obj_data (void)
2057 namelist_info
* first_nl
= NULL
;
2058 namelist_info
* root_nl
= NULL
;
2062 /* Look for end of input or object name. If '?' or '=?' are encountered
2063 in stdin, print the node names or the namelist to stdout. */
2070 finish_separator ();
2081 st_sprintf (nml_err_msg
, "namelist read: missplaced = sign");
2093 nml_match_name ("end", 3);
2096 st_sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2107 /* Untouch all nodes of the namelist and reset the flag that is set for
2108 derived type components. */
2110 nml_untouch_nodes();
2113 /* Get the object name - should '!' and '\n' be permitted separators? */
2121 push_char(tolower(c
));
2123 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2127 /* Check that the name is in the namelist and get pointer to object.
2128 Three error conditions exist: (i) An attempt is being made to
2129 identify a non-existent object, following a failed data read or
2130 (ii) The object name does not exist or (iii) Too many data items
2131 are present for an object. (iii) gives the same error message
2138 ext_name
= (char*)get_mem (strlen (root_nl
->var_name
)
2139 + (saved_string
? strlen (saved_string
) : 0)
2141 strcpy (ext_name
, root_nl
->var_name
);
2142 strcat (ext_name
, saved_string
);
2143 nl
= find_nml_node (ext_name
);
2144 free_mem (ext_name
);
2147 nl
= find_nml_node (saved_string
);
2151 if (nml_read_error
&& prev_nl
)
2152 st_sprintf (nml_err_msg
, "Bad data for namelist object %s",
2156 st_sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2162 /* Get the length, data length, base pointer and rank of the variable.
2163 Set the default loop specification first. */
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
;
2173 /* Check to see if there is a qualifier: if so, parse it.*/
2175 if (c
== '(' && nl
->var_rank
)
2177 if (nml_parse_qualifier (nl
->dim
, nl
->ls
, nl
->var_rank
) == FAILURE
)
2179 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2180 parse_err_msg
, nl
->var_name
);
2187 /* Now parse a derived type component. The root namelist_info address
2188 is backed up, as is the previous component level. The component flag
2189 is set and the iteration is made by jumping back to get_name. */
2194 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2196 st_sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2201 if (!component_flag
)
2211 /* Parse a character qualifier, if present. chigh = 0 is a default
2212 that signals that the string length = string_length. */
2217 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2219 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2220 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2222 if (nml_parse_qualifier (chd
, ind
, 1) == FAILURE
)
2224 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2225 parse_err_msg
, nl
->var_name
);
2229 clow
= ind
[0].start
;
2232 if (ind
[0].step
!= 1)
2234 st_sprintf (nml_err_msg
,
2235 "Bad step in substring for namelist object %s",
2244 /* If a derived type touch its components and restore the root
2245 namelist_info if we have parsed a qualified derived type
2248 if (nl
->type
== GFC_DTYPE_DERIVED
)
2249 nml_touch_nodes (nl
);
2253 /*make sure no extraneous qualifiers are there.*/
2257 st_sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2258 " namelist object %s", nl
->var_name
);
2262 /* According to the standard, an equal sign MUST follow an object name. The
2263 following is possibly lax - it allows comments, blank lines and so on to
2264 intervene. eat_spaces (); c = next_char (); would be compliant*/
2273 finish_separator ();
2281 st_sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2286 if (nml_read_obj (nl
, 0) == FAILURE
)
2296 /* Entry point for namelist input. Goes through input until namelist name
2297 is matched. Then cycles through nml_get_obj_data until the input is
2298 completed or there is an error. */
2301 namelist_read (void)
2308 if (setjmp (g
.eof_jump
))
2310 generate_error (ERROR_END
, NULL
);
2314 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2315 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2316 node names or namelist on stdout. */
2319 switch (c
= next_char ())
2340 /* Match the name of the namelist. */
2342 nml_match_name (ioparm
.namelist_name
, ioparm
.namelist_name_len
);
2347 /* Ready to read namelist objects. If there is an error in input
2348 from stdin, output the error message and continue. */
2350 while (!input_complete
)
2352 if (nml_get_obj_data () == FAILURE
)
2354 if (current_unit
->unit_number
!= options
.stdin_unit
)
2357 st_printf ("%s\n", nml_err_msg
);
2358 flush (find_unit (options
.stderr_unit
)->s
);
2365 /* All namelist error calls return from here */
2370 generate_error (ERROR_READ_VALUE
, nml_err_msg
);