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
);
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
248 { /* Eat a namelist comment. */
256 /* Fall Through... */
265 /* Finish processing a separator that was interrupted by a newline.
266 If we're here, then another data item is present, so we finish what
267 we started on the previous line. */
270 finish_separator (void)
294 if (!namelist_mode
) next_record (0);
317 /* This function is needed to catch bad conversions so that namelist can
318 attempt to see if saved_string contains a new object name rather than
322 nml_bad_return (char c
)
333 /* Convert an unsigned string to an integer. The length value is -1
334 if we are working on a repeat count. Returns nonzero if we have a
335 range problem. As a side effect, frees the saved_string. */
338 convert_integer (int length
, int negative
)
340 char c
, *buffer
, message
[100];
342 GFC_INTEGER_LARGEST v
, max
, max10
;
344 buffer
= saved_string
;
347 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
372 set_integer (value
, v
, length
);
378 if (repeat_count
== 0)
380 st_sprintf (message
, "Zero repeat count in item %d of list input",
383 generate_error (ERROR_READ_VALUE
, message
);
393 st_sprintf (message
, "Repeat count overflow in item %d of list input",
396 st_sprintf (message
, "Integer overflow while reading item %d",
400 generate_error (ERROR_READ_VALUE
, message
);
406 /* Parse a repeat count for logical and complex values which cannot
407 begin with a digit. Returns nonzero if we are done, zero if we
408 should continue on. */
413 char c
, message
[100];
439 repeat
= 10 * repeat
+ c
- '0';
441 if (repeat
> MAX_REPEAT
)
444 "Repeat count overflow in item %d of list input",
447 generate_error (ERROR_READ_VALUE
, message
);
457 "Zero repeat count in item %d of list input",
460 generate_error (ERROR_READ_VALUE
, message
);
472 repeat_count
= repeat
;
476 st_sprintf (message
, "Bad repeat count in item %d of list input",
479 generate_error (ERROR_READ_VALUE
, message
);
484 /* Read a logical character on the input. */
487 read_logical (int length
)
489 char c
, message
[100];
528 return; /* Null value. */
534 saved_type
= BT_LOGICAL
;
535 saved_length
= length
;
537 /* Eat trailing garbage. */
542 while (!is_separator (c
));
547 set_integer ((int *) value
, v
, length
);
553 if (nml_bad_return (c
))
556 st_sprintf (message
, "Bad logical value while reading item %d",
559 generate_error (ERROR_READ_VALUE
, message
);
563 /* Reading integers is tricky because we can actually be reading a
564 repeat count. We have to store the characters in a buffer because
565 we could be reading an integer that is larger than the default int
566 used for repeat counts. */
569 read_integer (int length
)
571 char c
, message
[100];
581 /* Fall through... */
587 CASE_SEPARATORS
: /* Single null. */
600 /* Take care of what may be a repeat count. */
615 CASE_SEPARATORS
: /* Not a repeat count. */
624 if (convert_integer (-1, 0))
627 /* Get the real integer. */
642 /* Fall through... */
673 if (nml_bad_return (c
))
678 st_sprintf (message
, "Bad integer for item %d in list input", g
.item_count
);
679 generate_error (ERROR_READ_VALUE
, message
);
688 if (convert_integer (length
, negative
))
695 saved_type
= BT_INTEGER
;
699 /* Read a character variable. */
702 read_character (int length
__attribute__ ((unused
)))
704 char c
, quote
, message
[100];
706 quote
= ' '; /* Space means no quote character. */
716 unget_char (c
); /* NULL value. */
730 /* Deal with a possible repeat count. */
743 goto done
; /* String was only digits! */
751 goto get_string
; /* Not a repeat count after all. */
756 if (convert_integer (-1, 0))
759 /* Now get the real string. */
765 unget_char (c
); /* Repeated NULL values. */
793 /* See if we have a doubled quote character or the end of
823 /* At this point, we have to have a separator, or else the string is
827 if (is_separator (c
))
831 saved_type
= BT_CHARACTER
;
836 st_sprintf (message
, "Invalid string input in item %d", g
.item_count
);
837 generate_error (ERROR_READ_VALUE
, message
);
842 /* Parse a component of a complex constant or a real number that we
843 are sure is already there. This is a straight real number parser. */
846 parse_real (void *buffer
, int length
)
848 char c
, message
[100];
852 if (c
== '-' || c
== '+')
858 if (!isdigit (c
) && c
!= '.')
863 seen_dp
= (c
== '.') ? 1 : 0;
907 if (c
!= '-' && c
!= '+')
942 m
= convert_real (buffer
, saved_string
, length
);
949 st_sprintf (message
, "Bad floating point number for item %d", g
.item_count
);
950 generate_error (ERROR_READ_VALUE
, message
);
956 /* Reading a complex number is straightforward because we can tell
957 what it is right away. */
960 read_complex (int length
)
984 if (parse_real (value
, length
))
990 if (c
== '\n' || c
== '\r')
995 if (next_char () != ',')
1001 if (c
== '\n' || c
== '\r')
1006 if (parse_real (value
+ length
, length
))
1010 if (next_char () != ')')
1014 if (!is_separator (c
))
1021 saved_type
= BT_COMPLEX
;
1026 if (nml_bad_return (c
))
1029 st_sprintf (message
, "Bad complex value in item %d of list input",
1032 generate_error (ERROR_READ_VALUE
, message
);
1036 /* Parse a real number with a possible repeat count. */
1039 read_real (int length
)
1041 char c
, message
[100];
1063 unget_char (c
); /* Single null. */
1071 /* Get the digit string that might be a repeat count. */
1108 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1118 if (convert_integer (-1, 0))
1121 /* Now get the number itself. */
1124 if (is_separator (c
))
1125 { /* Repeated null value. */
1131 if (c
!= '-' && c
!= '+')
1140 if (!isdigit (c
) && c
!= '.')
1196 if (c
!= '+' && c
!= '-')
1231 if (convert_real (value
, saved_string
, length
))
1235 saved_type
= BT_REAL
;
1240 if (nml_bad_return (c
))
1243 st_sprintf (message
, "Bad real number in item %d of list input",
1246 generate_error (ERROR_READ_VALUE
, message
);
1250 /* Check the current type against the saved type to make sure they are
1251 compatible. Returns nonzero if incompatible. */
1254 check_type (bt type
, int len
)
1258 if (saved_type
!= BT_NULL
&& saved_type
!= type
)
1260 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1261 type_name (saved_type
), type_name (type
), g
.item_count
);
1263 generate_error (ERROR_READ_VALUE
, message
);
1267 if (saved_type
== BT_NULL
|| saved_type
== BT_CHARACTER
)
1270 if (saved_length
!= len
)
1272 st_sprintf (message
,
1273 "Read kind %d %s where kind %d is required for item %d",
1274 saved_length
, type_name (saved_type
), len
, g
.item_count
);
1275 generate_error (ERROR_READ_VALUE
, message
);
1283 /* Top level data transfer subroutine for list reads. Because we have
1284 to deal with repeat counts, the data item is always saved after
1285 reading, usually in the value[] array. If a repeat count is
1286 greater than one, we copy the data item multiple times. */
1289 list_formatted_read_scalar (bt type
, void *p
, int len
)
1296 if (setjmp (g
.eof_jump
))
1298 generate_error (ERROR_END
, NULL
);
1310 if (is_separator (c
))
1311 { /* Found a null value. */
1315 finish_separator ();
1326 if (repeat_count
> 0)
1328 if (check_type (type
, len
))
1334 finish_separator ();
1338 /* trailing spaces prior to end of line */
1340 finish_separator ();
1343 saved_type
= BT_NULL
;
1356 read_character (len
);
1365 internal_error ("Bad type for list read");
1368 if (saved_type
!= BT_CHARACTER
&& saved_type
!= BT_NULL
)
1371 if (ioparm
.library_return
!= LIBRARY_OK
)
1384 memcpy (p
, value
, len
);
1390 m
= (len
< saved_used
) ? len
: saved_used
;
1391 memcpy (p
, saved_string
, m
);
1394 /* Just delimiters encountered, nothing to copy but SPACE. */
1398 memset (((char *) p
) + m
, ' ', len
- m
);
1405 if (--repeat_count
<= 0)
1411 list_formatted_read (bt type
, void *p
, int len
, size_t nelems
)
1419 if (type
== BT_COMPLEX
)
1424 /* Big loop over all the elements. */
1425 for (elem
= 0; elem
< nelems
; elem
++)
1428 list_formatted_read_scalar (type
, tmp
+ size
*elem
, len
);
1439 /* Finish a list read. */
1442 finish_list_read (void)
1463 void namelist_read (void)
1465 static void nml_match_name (char *name, int len)
1466 static int nml_query (void)
1467 static int nml_get_obj_data (void)
1469 static void nml_untouch_nodes (void)
1470 static namelist_info * find_nml_node (char * var_name)
1471 static int nml_parse_qualifier(descriptor_dimension * ad,
1472 nml_loop_spec * ls, int rank)
1473 static void nml_touch_nodes (namelist_info * nl)
1474 static int nml_read_obj (namelist_info * nl, index_type offset)
1478 /* Carries error messages from the qualifier parser. */
1479 static char parse_err_msg
[30];
1481 /* Carries error messages for error returns. */
1482 static char nml_err_msg
[100];
1484 /* Pointer to the previously read object, in case attempt is made to read
1485 new object name. Should this fail, error message can give previous
1488 static namelist_info
* prev_nl
;
1490 /* Lower index for substring qualifier. */
1492 static index_type clow
;
1494 /* Upper index for substring qualifier. */
1496 static index_type chigh
;
1498 /* Inputs a rank-dimensional qualifier, which can contain
1499 singlets, doublets, triplets or ':' with the standard meanings. */
1502 nml_parse_qualifier(descriptor_dimension
* ad
,
1503 nml_loop_spec
* ls
, int rank
)
1511 /* The next character in the stream should be the '('. */
1515 /* Process the qualifier, by dimension and triplet. */
1517 for (dim
=0; dim
< rank
; dim
++ )
1519 for (indx
=0; indx
<3; indx
++)
1525 /*process a potential sign. */
1542 /*process characters up to the next ':' , ',' or ')' */
1554 if ( (c
==',' && dim
== rank
-1)
1555 || (c
==')' && dim
< rank
-1))
1557 st_sprintf (parse_err_msg
,
1558 "Bad number of index fields");
1567 case ' ': case '\t':
1573 st_sprintf (parse_err_msg
, "Bad character in index");
1577 if (( c
==',' || c
==')') && indx
==0 && saved_string
== 0 )
1579 st_sprintf (parse_err_msg
, "Null index field");
1583 if ( ( c
==':' && indx
==1 && saved_string
== 0)
1584 || (indx
==2 && saved_string
== 0))
1586 st_sprintf(parse_err_msg
, "Bad index triplet");
1590 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1592 if ( (c
==':' && indx
==0 && saved_string
== 0)
1593 || (indx
==1 && saved_string
== 0))
1599 /* Now read the index. */
1601 if (convert_integer (sizeof(int),neg
))
1603 st_sprintf (parse_err_msg
, "Bad integer in index");
1609 /*feed the index values to the triplet arrays. */
1614 ls
[dim
].start
= *(int *)value
;
1616 ls
[dim
].end
= *(int *)value
;
1618 ls
[dim
].step
= *(int *)value
;
1621 /*singlet or doublet indices */
1623 if (c
==',' || c
==')')
1627 ls
[dim
].start
= *(int *)value
;
1628 ls
[dim
].end
= *(int *)value
;
1634 /*Check the values of the triplet indices. */
1636 if ( (ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1637 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1638 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1639 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1641 st_sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1644 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1645 || (ls
[dim
].step
== 0))
1647 st_sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1651 /* Initialise the loop index counter. */
1653 ls
[dim
].idx
= ls
[dim
].start
;
1664 static namelist_info
*
1665 find_nml_node (char * var_name
)
1667 namelist_info
* t
= ionml
;
1670 if (strcmp (var_name
,t
->var_name
) == 0)
1680 /* Visits all the components of a derived type that have
1681 not explicitly been identified in the namelist input.
1682 touched is set and the loop specification initialised
1683 to default values */
1686 nml_touch_nodes (namelist_info
* nl
)
1688 index_type len
= strlen (nl
->var_name
) + 1;
1690 char * ext_name
= (char*)get_mem (len
+ 1);
1691 strcpy (ext_name
, nl
->var_name
);
1692 strcat (ext_name
, "%");
1693 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1695 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1698 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1700 nl
->ls
[dim
].step
= 1;
1701 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1702 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1703 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1709 free_mem (ext_name
);
1713 /* Resets touched for the entire list of nml_nodes, ready for a
1717 nml_untouch_nodes (void)
1720 for (t
= ionml
; t
; t
= t
->next
)
1725 /* Attempts to input name to namelist name. Returns nml_read_error = 1
1729 nml_match_name (const char *name
, index_type len
)
1734 for (i
= 0; i
< len
; i
++)
1737 if (tolower (c
) != tolower (name
[i
]))
1745 /* If the namelist read is from stdin, output the current state of the
1746 namelist to stdout. This is used to implement the non-standard query
1747 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1748 the names alone are printed. */
1753 gfc_unit
* temp_unit
;
1758 if (current_unit
->unit_number
!= options
.stdin_unit
)
1761 /* Store the current unit and transfer to stdout. */
1763 temp_unit
= current_unit
;
1764 current_unit
= find_unit (options
.stdout_unit
);
1771 /* Write the namelist in its entirety. */
1776 /* Or write the list of names. */
1781 /* "&namelist_name\n" */
1783 len
= ioparm
.namelist_name_len
;
1784 p
= write_block (len
+ 2);
1788 memcpy ((char*)(p
+ 1), ioparm
.namelist_name
, len
);
1789 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1790 for (nl
=ionml
; nl
; nl
= nl
->next
)
1795 len
= strlen (nl
->var_name
);
1796 p
= write_block (len
+ 2);
1800 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1801 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1806 p
= write_block (5);
1809 memcpy (p
, "&end\n", 5);
1812 /* Flush the stream to force immediate output. */
1814 flush (current_unit
->s
);
1819 /* Restore the current unit. */
1821 current_unit
= temp_unit
;
1826 /* Reads and stores the input for the namelist object nl. For an array,
1827 the function loops over the ranges defined by the loop specification.
1828 This default to all the data or to the specification from a qualifier.
1829 nml_read_obj recursively calls itself to read derived types. It visits
1830 all its own components but only reads data for those that were touched
1831 when the name was parsed. If a read error is encountered, an attempt is
1832 made to return to read a new object name because the standard allows too
1833 little data to be available. On the other hand, too much data is an
1837 nml_read_obj (namelist_info
* nl
, index_type offset
)
1840 namelist_info
* cmp
;
1847 index_type obj_name_len
;
1850 /* This object not touched in name parsing. */
1862 case GFC_DTYPE_INTEGER
:
1863 case GFC_DTYPE_LOGICAL
:
1864 case GFC_DTYPE_REAL
:
1868 case GFC_DTYPE_COMPLEX
:
1872 case GFC_DTYPE_CHARACTER
:
1873 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
1883 /* Update the pointer to the data, using the current index vector */
1885 pdata
= (void*)(nl
->mem_pos
+ offset
);
1886 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
1887 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
1888 nl
->dim
[dim
].stride
* nl
->size
);
1890 /* Reset the error flag and try to read next value, if
1895 if (--repeat_count
<= 0)
1900 finish_separator ();
1904 /* GFC_TYPE_UNKNOWN through for nulls and is detected
1905 after the switch block. */
1907 saved_type
= GFC_DTYPE_UNKNOWN
;
1912 case GFC_DTYPE_INTEGER
:
1916 case GFC_DTYPE_LOGICAL
:
1920 case GFC_DTYPE_CHARACTER
:
1921 read_character (len
);
1924 case GFC_DTYPE_REAL
:
1928 case GFC_DTYPE_COMPLEX
:
1932 case GFC_DTYPE_DERIVED
:
1933 obj_name_len
= strlen (nl
->var_name
) + 1;
1934 obj_name
= get_mem (obj_name_len
+1);
1935 strcpy (obj_name
, nl
->var_name
);
1936 strcat (obj_name
, "%");
1938 /* Now loop over the components. Update the component pointer
1939 with the return value from nml_write_obj. This loop jumps
1940 past nested derived types by testing if the potential
1941 component name contains '%'. */
1943 for (cmp
= nl
->next
;
1945 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
1946 !strchr (cmp
->var_name
+ obj_name_len
, '%');
1950 if (nml_read_obj (cmp
, (index_type
)(pdata
- nl
->mem_pos
)) == FAILURE
)
1952 free_mem (obj_name
);
1958 free_mem (obj_name
);
1963 free_mem (obj_name
);
1967 st_sprintf (nml_err_msg
, "Bad type for namelist object %s",
1969 internal_error (nml_err_msg
);
1974 /* The standard permits array data to stop short of the number of
1975 elements specified in the loop specification. In this case, we
1976 should be here with nml_read_error != 0. Control returns to
1977 nml_get_obj_data and an attempt is made to read object name. */
1983 if (saved_type
== GFC_DTYPE_UNKNOWN
)
1987 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
1988 This comes about because the read functions return BT_types. */
1997 memcpy (pdata
, value
, dlen
);
2001 m
= (dlen
< saved_used
) ? dlen
: saved_used
;
2002 pdata
= (void*)( pdata
+ clow
- 1 );
2003 memcpy (pdata
, saved_string
, m
);
2005 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2012 /* Break out of loop if scalar. */
2017 /* Now increment the index vector. */
2022 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2024 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2026 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2028 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2030 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2034 } while (!nml_carry
);
2036 if (repeat_count
> 1)
2038 st_sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2049 /* Parses the object name, including array and substring qualifiers. It
2050 iterates over derived type components, touching those components and
2051 setting their loop specifications, if there is a qualifier. If the
2052 object is itself a derived type, its components and subcomponents are
2053 touched. nml_read_obj is called at the end and this reads the data in
2054 the manner specified by the object name. */
2057 nml_get_obj_data (void)
2062 namelist_info
* first_nl
= NULL
;
2063 namelist_info
* root_nl
= NULL
;
2067 /* Look for end of input or object name. If '?' or '=?' are encountered
2068 in stdin, print the node names or the namelist to stdout. */
2075 finish_separator ();
2086 st_sprintf (nml_err_msg
, "namelist read: missplaced = sign");
2098 nml_match_name ("end", 3);
2101 st_sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2112 /* Untouch all nodes of the namelist and reset the flag that is set for
2113 derived type components. */
2115 nml_untouch_nodes();
2118 /* Get the object name - should '!' and '\n' be permitted separators? */
2126 push_char(tolower(c
));
2128 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2132 /* Check that the name is in the namelist and get pointer to object.
2133 Three error conditions exist: (i) An attempt is being made to
2134 identify a non-existent object, following a failed data read or
2135 (ii) The object name does not exist or (iii) Too many data items
2136 are present for an object. (iii) gives the same error message
2143 ext_name
= (char*)get_mem (strlen (root_nl
->var_name
)
2144 + (saved_string
? strlen (saved_string
) : 0)
2146 strcpy (ext_name
, root_nl
->var_name
);
2147 strcat (ext_name
, saved_string
);
2148 nl
= find_nml_node (ext_name
);
2149 free_mem (ext_name
);
2152 nl
= find_nml_node (saved_string
);
2156 if (nml_read_error
&& prev_nl
)
2157 st_sprintf (nml_err_msg
, "Bad data for namelist object %s",
2161 st_sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2167 /* Get the length, data length, base pointer and rank of the variable.
2168 Set the default loop specification first. */
2170 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2172 nl
->ls
[dim
].step
= 1;
2173 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2174 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2175 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2178 /* Check to see if there is a qualifier: if so, parse it.*/
2180 if (c
== '(' && nl
->var_rank
)
2182 if (nml_parse_qualifier (nl
->dim
, nl
->ls
, nl
->var_rank
) == FAILURE
)
2184 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2185 parse_err_msg
, nl
->var_name
);
2192 /* Now parse a derived type component. The root namelist_info address
2193 is backed up, as is the previous component level. The component flag
2194 is set and the iteration is made by jumping back to get_name. */
2199 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2201 st_sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2206 if (!component_flag
)
2216 /* Parse a character qualifier, if present. chigh = 0 is a default
2217 that signals that the string length = string_length. */
2222 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2224 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2225 nml_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2227 if (nml_parse_qualifier (chd
, ind
, 1) == FAILURE
)
2229 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2230 parse_err_msg
, nl
->var_name
);
2234 clow
= ind
[0].start
;
2237 if (ind
[0].step
!= 1)
2239 st_sprintf (nml_err_msg
,
2240 "Bad step in substring for namelist object %s",
2249 /* If a derived type touch its components and restore the root
2250 namelist_info if we have parsed a qualified derived type
2253 if (nl
->type
== GFC_DTYPE_DERIVED
)
2254 nml_touch_nodes (nl
);
2258 /*make sure no extraneous qualifiers are there.*/
2262 st_sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2263 " namelist object %s", nl
->var_name
);
2267 /* According to the standard, an equal sign MUST follow an object name. The
2268 following is possibly lax - it allows comments, blank lines and so on to
2269 intervene. eat_spaces (); c = next_char (); would be compliant*/
2278 finish_separator ();
2286 st_sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2291 if (nml_read_obj (nl
, 0) == FAILURE
)
2301 /* Entry point for namelist input. Goes through input until namelist name
2302 is matched. Then cycles through nml_get_obj_data until the input is
2303 completed or there is an error. */
2306 namelist_read (void)
2313 if (setjmp (g
.eof_jump
))
2315 generate_error (ERROR_END
, NULL
);
2319 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2320 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2321 node names or namelist on stdout. */
2324 switch (c
= next_char ())
2345 /* Match the name of the namelist. */
2347 nml_match_name (ioparm
.namelist_name
, ioparm
.namelist_name_len
);
2352 /* Ready to read namelist objects. If there is an error in input
2353 from stdin, output the error message and continue. */
2355 while (!input_complete
)
2357 if (nml_get_obj_data () == FAILURE
)
2359 if (current_unit
->unit_number
!= options
.stdin_unit
)
2362 st_printf ("%s\n", nml_err_msg
);
2363 flush (find_unit (options
.stderr_unit
)->s
);
2370 /* All namelist error calls return from here */
2374 generate_error (ERROR_READ_VALUE
, nml_err_msg
);