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
53 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
54 case '5': case '6': case '7': case '8': case '9'
56 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
59 /* This macro assumes that we're operating on a variable. */
61 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
62 || c == '\t' || c == '\r')
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt
*dtp
, char c
)
76 if (dtp
->u
.p
.saved_string
== NULL
)
78 if (dtp
->u
.p
.scratch
== NULL
)
79 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
80 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
81 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
82 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
83 dtp
->u
.p
.saved_used
= 0;
86 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
88 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
89 new = get_mem (2 * dtp
->u
.p
.saved_length
);
91 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
93 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
94 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
95 free_mem (dtp
->u
.p
.saved_string
);
97 dtp
->u
.p
.saved_string
= new;
100 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
104 /* Free the input buffer if necessary. */
107 free_saved (st_parameter_dt
*dtp
)
109 if (dtp
->u
.p
.saved_string
== NULL
)
112 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
113 free_mem (dtp
->u
.p
.saved_string
);
115 dtp
->u
.p
.saved_string
= NULL
;
116 dtp
->u
.p
.saved_used
= 0;
120 /* Free the line buffer if necessary. */
123 free_line (st_parameter_dt
*dtp
)
125 if (dtp
->u
.p
.line_buffer
== NULL
)
128 free_mem (dtp
->u
.p
.line_buffer
);
129 dtp
->u
.p
.line_buffer
= NULL
;
134 next_char (st_parameter_dt
*dtp
)
140 if (dtp
->u
.p
.last_char
!= '\0')
143 c
= dtp
->u
.p
.last_char
;
144 dtp
->u
.p
.last_char
= '\0';
148 /* Read from line_buffer if enabled. */
150 if (dtp
->u
.p
.line_buffer_enabled
)
154 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
155 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
157 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
158 dtp
->u
.p
.item_count
++;
162 dtp
->u
.p
.item_count
= 0;
163 dtp
->u
.p
.line_buffer_enabled
= 0;
166 /* Handle the end-of-record and end-of-file conditions for
167 internal array unit. */
168 if (is_array_io(dtp
))
171 longjmp (*dtp
->u
.p
.eof_jump
, 1);
173 /* Check for "end-of-record" condition. */
174 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
176 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
178 /* Check for "end-of-file" condition. */
186 record
*= dtp
->u
.p
.current_unit
->recl
;
187 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
188 longjmp (*dtp
->u
.p
.eof_jump
, 1);
190 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
194 /* Get the next character and handle end-of-record conditions. */
198 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
200 if (is_stream_io (dtp
))
201 dtp
->u
.p
.current_unit
->strm_pos
++;
203 if (is_internal_unit(dtp
))
205 if (is_array_io(dtp
))
207 /* End of record is handled in the next pass through, above. The
208 check for NULL here is cautionary. */
211 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
215 dtp
->u
.p
.current_unit
->bytes_left
--;
221 longjmp (*dtp
->u
.p
.eof_jump
, 1);
232 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
236 longjmp (*dtp
->u
.p
.eof_jump
, 1);
240 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
245 /* Push a character back onto the input. */
248 unget_char (st_parameter_dt
*dtp
, char c
)
250 dtp
->u
.p
.last_char
= c
;
254 /* Skip over spaces in the input. Returns the nonspace character that
255 terminated the eating and also places it back on the input. */
258 eat_spaces (st_parameter_dt
*dtp
)
266 while (c
== ' ' || c
== '\t');
273 /* Skip over a separator. Technically, we don't always eat the whole
274 separator. This is because if we've processed the last input item,
275 then a separator is unnecessary. Plus the fact that operating
276 systems usually deliver console input on a line basis.
278 The upshot is that if we see a newline as part of reading a
279 separator, we stop reading. If there are more input items, we
280 continue reading the separator with finish_separator() which takes
281 care of the fact that we may or may not have seen a comma as part
285 eat_separator (st_parameter_dt
*dtp
)
290 dtp
->u
.p
.comma_flag
= 0;
296 dtp
->u
.p
.comma_flag
= 1;
301 dtp
->u
.p
.input_complete
= 1;
317 if (dtp
->u
.p
.namelist_mode
)
318 { /* Eat a namelist comment. */
326 /* Fall Through... */
335 /* Finish processing a separator that was interrupted by a newline.
336 If we're here, then another data item is present, so we finish what
337 we started on the previous line. */
340 finish_separator (st_parameter_dt
*dtp
)
351 if (dtp
->u
.p
.comma_flag
)
355 c
= eat_spaces (dtp
);
356 if (c
== '\n' || c
== '\r')
363 dtp
->u
.p
.input_complete
= 1;
364 if (!dtp
->u
.p
.namelist_mode
) next_record (dtp
, 0);
372 if (dtp
->u
.p
.namelist_mode
)
388 /* This function reads characters through to the end of the current line and
389 just ignores them. */
392 eat_line (st_parameter_dt
*dtp
)
395 if (!is_internal_unit (dtp
))
402 /* This function is needed to catch bad conversions so that namelist can
403 attempt to see if dtp->u.p.saved_string contains a new object name rather
407 nml_bad_return (st_parameter_dt
*dtp
, char c
)
409 if (dtp
->u
.p
.namelist_mode
)
411 dtp
->u
.p
.nml_read_error
= 1;
418 /* Convert an unsigned string to an integer. The length value is -1
419 if we are working on a repeat count. Returns nonzero if we have a
420 range problem. As a side effect, frees the dtp->u.p.saved_string. */
423 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
425 char c
, *buffer
, message
[100];
427 GFC_INTEGER_LARGEST v
, max
, max10
;
429 buffer
= dtp
->u
.p
.saved_string
;
432 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
457 set_integer (dtp
->u
.p
.value
, v
, length
);
461 dtp
->u
.p
.repeat_count
= v
;
463 if (dtp
->u
.p
.repeat_count
== 0)
465 st_sprintf (message
, "Zero repeat count in item %d of list input",
466 dtp
->u
.p
.item_count
);
468 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
478 st_sprintf (message
, "Repeat count overflow in item %d of list input",
479 dtp
->u
.p
.item_count
);
481 st_sprintf (message
, "Integer overflow while reading item %d",
482 dtp
->u
.p
.item_count
);
485 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
491 /* Parse a repeat count for logical and complex values which cannot
492 begin with a digit. Returns nonzero if we are done, zero if we
493 should continue on. */
496 parse_repeat (st_parameter_dt
*dtp
)
498 char c
, message
[100];
524 repeat
= 10 * repeat
+ c
- '0';
526 if (repeat
> MAX_REPEAT
)
529 "Repeat count overflow in item %d of list input",
530 dtp
->u
.p
.item_count
);
532 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
542 "Zero repeat count in item %d of list input",
543 dtp
->u
.p
.item_count
);
545 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
557 dtp
->u
.p
.repeat_count
= repeat
;
564 st_sprintf (message
, "Bad repeat count in item %d of list input",
565 dtp
->u
.p
.item_count
);
566 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
571 /* To read a logical we have to look ahead in the input stream to make sure
572 there is not an equal sign indicating a variable name. To do this we use
573 line_buffer to point to a temporary buffer, pushing characters there for
574 possible later reading. */
577 l_push_char (st_parameter_dt
*dtp
, char c
)
579 if (dtp
->u
.p
.line_buffer
== NULL
)
581 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
582 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
585 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
589 /* Read a logical character on the input. */
592 read_logical (st_parameter_dt
*dtp
, int length
)
594 char c
, message
[100];
597 if (parse_repeat (dtp
))
600 c
= tolower (next_char (dtp
));
601 l_push_char (dtp
, c
);
607 l_push_char (dtp
, c
);
609 if (!is_separator(c
))
617 l_push_char (dtp
, c
);
619 if (!is_separator(c
))
625 c
= tolower (next_char (dtp
));
643 return; /* Null value. */
649 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
650 dtp
->u
.p
.saved_length
= length
;
652 /* Eat trailing garbage. */
657 while (!is_separator (c
));
661 dtp
->u
.p
.item_count
= 0;
662 dtp
->u
.p
.line_buffer_enabled
= 0;
663 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
670 for(i
= 0; i
< 63; i
++)
675 /* All done if this is not a namelist read. */
676 if (!dtp
->u
.p
.namelist_mode
)
689 l_push_char (dtp
, c
);
692 dtp
->u
.p
.nml_read_error
= 1;
693 dtp
->u
.p
.line_buffer_enabled
= 1;
694 dtp
->u
.p
.item_count
= 0;
704 if (nml_bad_return (dtp
, c
))
709 st_sprintf (message
, "Bad logical value while reading item %d",
710 dtp
->u
.p
.item_count
);
711 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
716 dtp
->u
.p
.item_count
= 0;
717 dtp
->u
.p
.line_buffer_enabled
= 0;
718 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
719 dtp
->u
.p
.saved_length
= length
;
720 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
726 /* Reading integers is tricky because we can actually be reading a
727 repeat count. We have to store the characters in a buffer because
728 we could be reading an integer that is larger than the default int
729 used for repeat counts. */
732 read_integer (st_parameter_dt
*dtp
, int length
)
734 char c
, message
[100];
744 /* Fall through... */
750 CASE_SEPARATORS
: /* Single null. */
763 /* Take care of what may be a repeat count. */
775 push_char (dtp
, '\0');
778 CASE_SEPARATORS
: /* Not a repeat count. */
787 if (convert_integer (dtp
, -1, 0))
790 /* Get the real integer. */
805 /* Fall through... */
836 if (nml_bad_return (dtp
, c
))
841 st_sprintf (message
, "Bad integer for item %d in list input",
842 dtp
->u
.p
.item_count
);
843 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
851 push_char (dtp
, '\0');
852 if (convert_integer (dtp
, length
, negative
))
859 dtp
->u
.p
.saved_type
= BT_INTEGER
;
863 /* Read a character variable. */
866 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
868 char c
, quote
, message
[100];
870 quote
= ' '; /* Space means no quote character. */
880 unget_char (dtp
, c
); /* NULL value. */
890 if (dtp
->u
.p
.namelist_mode
)
899 /* Deal with a possible repeat count. */
912 goto done
; /* String was only digits! */
915 push_char (dtp
, '\0');
920 goto get_string
; /* Not a repeat count after all. */
925 if (convert_integer (dtp
, -1, 0))
928 /* Now get the real string. */
934 unget_char (dtp
, c
); /* Repeated NULL values. */
962 /* See if we have a doubled quote character or the end of
968 push_char (dtp
, quote
);
982 if (c
!= '\n' && c
!= '\r')
992 /* At this point, we have to have a separator, or else the string is
996 if (is_separator (c
))
1000 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1005 st_sprintf (message
, "Invalid string input in item %d",
1006 dtp
->u
.p
.item_count
);
1007 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1012 /* Parse a component of a complex constant or a real number that we
1013 are sure is already there. This is a straight real number parser. */
1016 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1018 char c
, message
[100];
1021 c
= next_char (dtp
);
1022 if (c
== '-' || c
== '+')
1025 c
= next_char (dtp
);
1028 if (!isdigit (c
) && c
!= '.')
1033 seen_dp
= (c
== '.') ? 1 : 0;
1037 c
= next_char (dtp
);
1056 push_char (dtp
, 'e');
1061 push_char (dtp
, 'e');
1063 c
= next_char (dtp
);
1067 unget_char (dtp
, c
);
1076 c
= next_char (dtp
);
1077 if (c
!= '-' && c
!= '+')
1078 push_char (dtp
, '+');
1082 c
= next_char (dtp
);
1092 c
= next_char (dtp
);
1100 unget_char (dtp
, c
);
1109 unget_char (dtp
, c
);
1110 push_char (dtp
, '\0');
1112 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1119 if (nml_bad_return (dtp
, c
))
1124 st_sprintf (message
, "Bad floating point number for item %d",
1125 dtp
->u
.p
.item_count
);
1126 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1132 /* Reading a complex number is straightforward because we can tell
1133 what it is right away. */
1136 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1141 if (parse_repeat (dtp
))
1144 c
= next_char (dtp
);
1151 unget_char (dtp
, c
);
1152 eat_separator (dtp
);
1160 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1165 c
= next_char (dtp
);
1166 if (c
== '\n' || c
== '\r')
1169 unget_char (dtp
, c
);
1171 if (next_char (dtp
) != ',')
1176 c
= next_char (dtp
);
1177 if (c
== '\n' || c
== '\r')
1180 unget_char (dtp
, c
);
1182 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1186 if (next_char (dtp
) != ')')
1189 c
= next_char (dtp
);
1190 if (!is_separator (c
))
1193 unget_char (dtp
, c
);
1194 eat_separator (dtp
);
1197 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1202 if (nml_bad_return (dtp
, c
))
1207 st_sprintf (message
, "Bad complex value in item %d of list input",
1208 dtp
->u
.p
.item_count
);
1209 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1213 /* Parse a real number with a possible repeat count. */
1216 read_real (st_parameter_dt
*dtp
, int length
)
1218 char c
, message
[100];
1223 c
= next_char (dtp
);
1240 unget_char (dtp
, c
); /* Single null. */
1241 eat_separator (dtp
);
1248 /* Get the digit string that might be a repeat count. */
1252 c
= next_char (dtp
);
1275 push_char (dtp
, 'e');
1277 c
= next_char (dtp
);
1281 push_char (dtp
, '\0');
1285 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1286 unget_char (dtp
, c
);
1295 if (convert_integer (dtp
, -1, 0))
1298 /* Now get the number itself. */
1300 c
= next_char (dtp
);
1301 if (is_separator (c
))
1302 { /* Repeated null value. */
1303 unget_char (dtp
, c
);
1304 eat_separator (dtp
);
1308 if (c
!= '-' && c
!= '+')
1309 push_char (dtp
, '+');
1314 c
= next_char (dtp
);
1317 if (!isdigit (c
) && c
!= '.')
1333 c
= next_char (dtp
);
1359 push_char (dtp
, 'e');
1361 c
= next_char (dtp
);
1370 push_char (dtp
, 'e');
1372 c
= next_char (dtp
);
1373 if (c
!= '+' && c
!= '-')
1374 push_char (dtp
, '+');
1378 c
= next_char (dtp
);
1388 c
= next_char (dtp
);
1405 unget_char (dtp
, c
);
1406 eat_separator (dtp
);
1407 push_char (dtp
, '\0');
1408 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1412 dtp
->u
.p
.saved_type
= BT_REAL
;
1417 if (nml_bad_return (dtp
, c
))
1422 st_sprintf (message
, "Bad real number in item %d of list input",
1423 dtp
->u
.p
.item_count
);
1424 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1428 /* Check the current type against the saved type to make sure they are
1429 compatible. Returns nonzero if incompatible. */
1432 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1436 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1438 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1439 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1440 dtp
->u
.p
.item_count
);
1442 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1446 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1449 if (dtp
->u
.p
.saved_length
!= len
)
1451 st_sprintf (message
,
1452 "Read kind %d %s where kind %d is required for item %d",
1453 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1454 dtp
->u
.p
.item_count
);
1455 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1463 /* Top level data transfer subroutine for list reads. Because we have
1464 to deal with repeat counts, the data item is always saved after
1465 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1466 greater than one, we copy the data item multiple times. */
1469 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1476 dtp
->u
.p
.namelist_mode
= 0;
1478 dtp
->u
.p
.eof_jump
= &eof_jump
;
1479 if (setjmp (eof_jump
))
1481 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1485 if (dtp
->u
.p
.first_item
)
1487 dtp
->u
.p
.first_item
= 0;
1488 dtp
->u
.p
.input_complete
= 0;
1489 dtp
->u
.p
.repeat_count
= 1;
1490 dtp
->u
.p
.at_eol
= 0;
1492 c
= eat_spaces (dtp
);
1493 if (is_separator (c
))
1494 { /* Found a null value. */
1495 eat_separator (dtp
);
1496 dtp
->u
.p
.repeat_count
= 0;
1498 /* eat_separator sets this flag if the separator was a comma */
1499 if (dtp
->u
.p
.comma_flag
)
1502 /* eat_separator sets this flag if the separator was a \n or \r */
1503 if (dtp
->u
.p
.at_eol
)
1504 finish_separator (dtp
);
1512 if (dtp
->u
.p
.input_complete
)
1515 if (dtp
->u
.p
.repeat_count
> 0)
1517 if (check_type (dtp
, type
, kind
))
1522 if (dtp
->u
.p
.at_eol
)
1523 finish_separator (dtp
);
1527 /* trailing spaces prior to end of line */
1528 if (dtp
->u
.p
.at_eol
)
1529 finish_separator (dtp
);
1532 dtp
->u
.p
.saved_type
= BT_NULL
;
1533 dtp
->u
.p
.repeat_count
= 1;
1539 read_integer (dtp
, kind
);
1542 read_logical (dtp
, kind
);
1545 read_character (dtp
, kind
);
1548 read_real (dtp
, kind
);
1551 read_complex (dtp
, kind
, size
);
1554 internal_error (&dtp
->common
, "Bad type for list read");
1557 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1558 dtp
->u
.p
.saved_length
= size
;
1560 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1564 switch (dtp
->u
.p
.saved_type
)
1570 memcpy (p
, dtp
->u
.p
.value
, size
);
1574 if (dtp
->u
.p
.saved_string
)
1576 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1577 ? (int) size
: dtp
->u
.p
.saved_used
;
1578 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1581 /* Just delimiters encountered, nothing to copy but SPACE. */
1585 memset (((char *) p
) + m
, ' ', size
- m
);
1592 if (--dtp
->u
.p
.repeat_count
<= 0)
1596 dtp
->u
.p
.eof_jump
= NULL
;
1601 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1602 size_t size
, size_t nelems
)
1609 /* Big loop over all the elements. */
1610 for (elem
= 0; elem
< nelems
; elem
++)
1612 dtp
->u
.p
.item_count
++;
1613 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1618 /* Finish a list read. */
1621 finish_list_read (st_parameter_dt
*dtp
)
1627 if (dtp
->u
.p
.at_eol
)
1629 dtp
->u
.p
.at_eol
= 0;
1635 c
= next_char (dtp
);
1642 void namelist_read (st_parameter_dt *dtp)
1644 static void nml_match_name (char *name, int len)
1645 static int nml_query (st_parameter_dt *dtp)
1646 static int nml_get_obj_data (st_parameter_dt *dtp,
1647 namelist_info **prev_nl, char *)
1649 static void nml_untouch_nodes (st_parameter_dt *dtp)
1650 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1652 static int nml_parse_qualifier(descriptor_dimension * ad,
1653 array_loop_spec * ls, int rank, char *)
1654 static void nml_touch_nodes (namelist_info * nl)
1655 static int nml_read_obj (namelist_info *nl, index_type offset,
1656 namelist_info **prev_nl, char *,
1657 index_type clow, index_type chigh)
1661 /* Inputs a rank-dimensional qualifier, which can contain
1662 singlets, doublets, triplets or ':' with the standard meanings. */
1665 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1666 array_loop_spec
*ls
, int rank
, char *parse_err_msg
)
1672 int is_array_section
;
1675 is_array_section
= 0;
1676 dtp
->u
.p
.expanded_read
= 0;
1678 /* The next character in the stream should be the '('. */
1680 c
= next_char (dtp
);
1682 /* Process the qualifier, by dimension and triplet. */
1684 for (dim
=0; dim
< rank
; dim
++ )
1686 for (indx
=0; indx
<3; indx
++)
1692 /* Process a potential sign. */
1693 c
= next_char (dtp
);
1704 unget_char (dtp
, c
);
1708 /* Process characters up to the next ':' , ',' or ')'. */
1711 c
= next_char (dtp
);
1716 is_array_section
= 1;
1720 if ((c
==',' && dim
== rank
-1)
1721 || (c
==')' && dim
< rank
-1))
1723 st_sprintf (parse_err_msg
,
1724 "Bad number of index fields");
1733 case ' ': case '\t':
1735 c
= next_char (dtp
);
1739 st_sprintf (parse_err_msg
, "Bad character in index");
1743 if ((c
== ',' || c
== ')') && indx
== 0
1744 && dtp
->u
.p
.saved_string
== 0)
1746 st_sprintf (parse_err_msg
, "Null index field");
1750 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1751 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1753 st_sprintf(parse_err_msg
, "Bad index triplet");
1757 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1759 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1760 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
1766 /* Now read the index. */
1767 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
1769 st_sprintf (parse_err_msg
, "Bad integer in index");
1775 /* Feed the index values to the triplet arrays. */
1779 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1781 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1783 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1786 /* Singlet or doublet indices. */
1787 if (c
==',' || c
==')')
1791 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1793 /* If -std=f95/2003 or an array section is specified,
1794 do not allow excess data to be processed. */
1795 if (is_array_section
== 1
1796 || compile_options
.allow_std
< GFC_STD_GNU
)
1797 ls
[dim
].end
= ls
[dim
].start
;
1799 dtp
->u
.p
.expanded_read
= 1;
1805 /* Check the values of the triplet indices. */
1806 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1807 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1808 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1809 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1811 st_sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1814 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1815 || (ls
[dim
].step
== 0))
1817 st_sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1821 /* Initialise the loop index counter. */
1822 ls
[dim
].idx
= ls
[dim
].start
;
1832 static namelist_info
*
1833 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
1835 namelist_info
* t
= dtp
->u
.p
.ionml
;
1838 if (strcmp (var_name
, t
->var_name
) == 0)
1848 /* Visits all the components of a derived type that have
1849 not explicitly been identified in the namelist input.
1850 touched is set and the loop specification initialised
1851 to default values */
1854 nml_touch_nodes (namelist_info
* nl
)
1856 index_type len
= strlen (nl
->var_name
) + 1;
1858 char * ext_name
= (char*)get_mem (len
+ 1);
1859 strcpy (ext_name
, nl
->var_name
);
1860 strcat (ext_name
, "%");
1861 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1863 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1866 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1868 nl
->ls
[dim
].step
= 1;
1869 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1870 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1871 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1877 free_mem (ext_name
);
1881 /* Resets touched for the entire list of nml_nodes, ready for a
1885 nml_untouch_nodes (st_parameter_dt
*dtp
)
1888 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
1893 /* Attempts to input name to namelist name. Returns
1894 dtp->u.p.nml_read_error = 1 on no match. */
1897 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
1901 dtp
->u
.p
.nml_read_error
= 0;
1902 for (i
= 0; i
< len
; i
++)
1904 c
= next_char (dtp
);
1905 if (tolower (c
) != tolower (name
[i
]))
1907 dtp
->u
.p
.nml_read_error
= 1;
1913 /* If the namelist read is from stdin, output the current state of the
1914 namelist to stdout. This is used to implement the non-standard query
1915 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1916 the names alone are printed. */
1919 nml_query (st_parameter_dt
*dtp
, char c
)
1921 gfc_unit
* temp_unit
;
1926 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
1929 /* Store the current unit and transfer to stdout. */
1931 temp_unit
= dtp
->u
.p
.current_unit
;
1932 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
1934 if (dtp
->u
.p
.current_unit
)
1936 dtp
->u
.p
.mode
= WRITING
;
1937 next_record (dtp
, 0);
1939 /* Write the namelist in its entirety. */
1942 namelist_write (dtp
);
1944 /* Or write the list of names. */
1949 /* "&namelist_name\n" */
1951 len
= dtp
->namelist_name_len
;
1953 p
= write_block (dtp
, len
+ 3);
1955 p
= write_block (dtp
, len
+ 2);
1960 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
1962 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1964 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1966 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
1971 len
= strlen (nl
->var_name
);
1973 p
= write_block (dtp
, len
+ 3);
1975 p
= write_block (dtp
, len
+ 2);
1980 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1982 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1984 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1991 p
= write_block (dtp
, 6);
1993 p
= write_block (dtp
, 5);
1998 memcpy (p
, "&end\r\n", 6);
2000 memcpy (p
, "&end\n", 5);
2004 /* Flush the stream to force immediate output. */
2006 flush (dtp
->u
.p
.current_unit
->s
);
2007 unlock_unit (dtp
->u
.p
.current_unit
);
2012 /* Restore the current unit. */
2014 dtp
->u
.p
.current_unit
= temp_unit
;
2015 dtp
->u
.p
.mode
= READING
;
2019 /* Reads and stores the input for the namelist object nl. For an array,
2020 the function loops over the ranges defined by the loop specification.
2021 This default to all the data or to the specification from a qualifier.
2022 nml_read_obj recursively calls itself to read derived types. It visits
2023 all its own components but only reads data for those that were touched
2024 when the name was parsed. If a read error is encountered, an attempt is
2025 made to return to read a new object name because the standard allows too
2026 little data to be available. On the other hand, too much data is an
2030 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2031 namelist_info
**pprev_nl
, char *nml_err_msg
,
2032 index_type clow
, index_type chigh
)
2035 namelist_info
* cmp
;
2042 index_type obj_name_len
;
2045 /* This object not touched in name parsing. */
2050 dtp
->u
.p
.repeat_count
= 0;
2057 case GFC_DTYPE_INTEGER
:
2058 case GFC_DTYPE_LOGICAL
:
2062 case GFC_DTYPE_REAL
:
2063 dlen
= size_from_real_kind (len
);
2066 case GFC_DTYPE_COMPLEX
:
2067 dlen
= size_from_complex_kind (len
);
2070 case GFC_DTYPE_CHARACTER
:
2071 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2081 /* Update the pointer to the data, using the current index vector */
2083 pdata
= (void*)(nl
->mem_pos
+ offset
);
2084 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2085 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2086 nl
->dim
[dim
].stride
* nl
->size
);
2088 /* Reset the error flag and try to read next value, if
2089 dtp->u.p.repeat_count=0 */
2091 dtp
->u
.p
.nml_read_error
= 0;
2093 if (--dtp
->u
.p
.repeat_count
<= 0)
2095 if (dtp
->u
.p
.input_complete
)
2097 if (dtp
->u
.p
.at_eol
)
2098 finish_separator (dtp
);
2099 if (dtp
->u
.p
.input_complete
)
2102 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2103 after the switch block. */
2105 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2110 case GFC_DTYPE_INTEGER
:
2111 read_integer (dtp
, len
);
2114 case GFC_DTYPE_LOGICAL
:
2115 read_logical (dtp
, len
);
2118 case GFC_DTYPE_CHARACTER
:
2119 read_character (dtp
, len
);
2122 case GFC_DTYPE_REAL
:
2123 read_real (dtp
, len
);
2126 case GFC_DTYPE_COMPLEX
:
2127 read_complex (dtp
, len
, dlen
);
2130 case GFC_DTYPE_DERIVED
:
2131 obj_name_len
= strlen (nl
->var_name
) + 1;
2132 obj_name
= get_mem (obj_name_len
+1);
2133 strcpy (obj_name
, nl
->var_name
);
2134 strcat (obj_name
, "%");
2136 /* If reading a derived type, disable the expanded read warning
2137 since a single object can have multiple reads. */
2138 dtp
->u
.p
.expanded_read
= 0;
2140 /* Now loop over the components. Update the component pointer
2141 with the return value from nml_write_obj. This loop jumps
2142 past nested derived types by testing if the potential
2143 component name contains '%'. */
2145 for (cmp
= nl
->next
;
2147 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2148 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2152 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2153 pprev_nl
, nml_err_msg
, clow
, chigh
)
2156 free_mem (obj_name
);
2160 if (dtp
->u
.p
.input_complete
)
2162 free_mem (obj_name
);
2167 free_mem (obj_name
);
2171 st_sprintf (nml_err_msg
, "Bad type for namelist object %s",
2173 internal_error (&dtp
->common
, nml_err_msg
);
2178 /* The standard permits array data to stop short of the number of
2179 elements specified in the loop specification. In this case, we
2180 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2181 nml_get_obj_data and an attempt is made to read object name. */
2184 if (dtp
->u
.p
.nml_read_error
)
2186 dtp
->u
.p
.expanded_read
= 0;
2190 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2192 dtp
->u
.p
.expanded_read
= 0;
2196 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2197 This comes about because the read functions return BT_types. */
2199 switch (dtp
->u
.p
.saved_type
)
2206 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2210 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2211 pdata
= (void*)( pdata
+ clow
- 1 );
2212 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2214 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2221 /* Warn if a non-standard expanded read occurs. A single read of a
2222 single object is acceptable. If a second read occurs, issue a warning
2223 and set the flag to zero to prevent further warnings. */
2224 if (dtp
->u
.p
.expanded_read
== 2)
2226 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2227 dtp
->u
.p
.expanded_read
= 0;
2230 /* If the expanded read warning flag is set, increment it,
2231 indicating that a single read has occurred. */
2232 if (dtp
->u
.p
.expanded_read
>= 1)
2233 dtp
->u
.p
.expanded_read
++;
2235 /* Break out of loop if scalar. */
2239 /* Now increment the index vector. */
2244 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2246 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2248 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2250 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2252 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2256 } while (!nml_carry
);
2258 if (dtp
->u
.p
.repeat_count
> 1)
2260 st_sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2271 /* Parses the object name, including array and substring qualifiers. It
2272 iterates over derived type components, touching those components and
2273 setting their loop specifications, if there is a qualifier. If the
2274 object is itself a derived type, its components and subcomponents are
2275 touched. nml_read_obj is called at the end and this reads the data in
2276 the manner specified by the object name. */
2279 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2284 namelist_info
* first_nl
= NULL
;
2285 namelist_info
* root_nl
= NULL
;
2288 char parse_err_msg
[30];
2289 index_type clow
, chigh
;
2291 /* Look for end of input or object name. If '?' or '=?' are encountered
2292 in stdin, print the node names or the namelist to stdout. */
2294 eat_separator (dtp
);
2295 if (dtp
->u
.p
.input_complete
)
2298 if (dtp
->u
.p
.at_eol
)
2299 finish_separator (dtp
);
2300 if (dtp
->u
.p
.input_complete
)
2303 c
= next_char (dtp
);
2307 c
= next_char (dtp
);
2310 st_sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2313 nml_query (dtp
, '=');
2317 nml_query (dtp
, '?');
2322 nml_match_name (dtp
, "end", 3);
2323 if (dtp
->u
.p
.nml_read_error
)
2325 st_sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2329 dtp
->u
.p
.input_complete
= 1;
2336 /* Untouch all nodes of the namelist and reset the flag that is set for
2337 derived type components. */
2339 nml_untouch_nodes (dtp
);
2342 /* Get the object name - should '!' and '\n' be permitted separators? */
2350 push_char (dtp
, tolower(c
));
2351 c
= next_char (dtp
);
2352 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2354 unget_char (dtp
, c
);
2356 /* Check that the name is in the namelist and get pointer to object.
2357 Three error conditions exist: (i) An attempt is being made to
2358 identify a non-existent object, following a failed data read or
2359 (ii) The object name does not exist or (iii) Too many data items
2360 are present for an object. (iii) gives the same error message
2363 push_char (dtp
, '\0');
2367 size_t var_len
= strlen (root_nl
->var_name
);
2369 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2370 char ext_name
[var_len
+ saved_len
+ 1];
2372 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2373 if (dtp
->u
.p
.saved_string
)
2374 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2375 ext_name
[var_len
+ saved_len
] = '\0';
2376 nl
= find_nml_node (dtp
, ext_name
);
2379 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2383 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2384 st_sprintf (nml_err_msg
, "Bad data for namelist object %s",
2385 (*pprev_nl
)->var_name
);
2388 st_sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2389 dtp
->u
.p
.saved_string
);
2394 /* Get the length, data length, base pointer and rank of the variable.
2395 Set the default loop specification first. */
2397 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2399 nl
->ls
[dim
].step
= 1;
2400 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2401 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2402 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2405 /* Check to see if there is a qualifier: if so, parse it.*/
2407 if (c
== '(' && nl
->var_rank
)
2409 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2410 parse_err_msg
) == FAILURE
)
2412 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2413 parse_err_msg
, nl
->var_name
);
2416 c
= next_char (dtp
);
2417 unget_char (dtp
, c
);
2420 /* Now parse a derived type component. The root namelist_info address
2421 is backed up, as is the previous component level. The component flag
2422 is set and the iteration is made by jumping back to get_name. */
2427 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2429 st_sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2434 if (!component_flag
)
2439 c
= next_char (dtp
);
2444 /* Parse a character qualifier, if present. chigh = 0 is a default
2445 that signals that the string length = string_length. */
2450 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2452 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2453 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2455 if (nml_parse_qualifier (dtp
, chd
, ind
, 1, parse_err_msg
) == FAILURE
)
2457 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2458 parse_err_msg
, nl
->var_name
);
2462 clow
= ind
[0].start
;
2465 if (ind
[0].step
!= 1)
2467 st_sprintf (nml_err_msg
,
2468 "Bad step in substring for namelist object %s",
2473 c
= next_char (dtp
);
2474 unget_char (dtp
, c
);
2477 /* If a derived type touch its components and restore the root
2478 namelist_info if we have parsed a qualified derived type
2481 if (nl
->type
== GFC_DTYPE_DERIVED
)
2482 nml_touch_nodes (nl
);
2486 /*make sure no extraneous qualifiers are there.*/
2490 st_sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2491 " namelist object %s", nl
->var_name
);
2495 /* According to the standard, an equal sign MUST follow an object name. The
2496 following is possibly lax - it allows comments, blank lines and so on to
2497 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2501 eat_separator (dtp
);
2502 if (dtp
->u
.p
.input_complete
)
2505 if (dtp
->u
.p
.at_eol
)
2506 finish_separator (dtp
);
2507 if (dtp
->u
.p
.input_complete
)
2510 c
= next_char (dtp
);
2514 st_sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2519 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2529 /* Entry point for namelist input. Goes through input until namelist name
2530 is matched. Then cycles through nml_get_obj_data until the input is
2531 completed or there is an error. */
2534 namelist_read (st_parameter_dt
*dtp
)
2538 char nml_err_msg
[100];
2539 /* Pointer to the previously read object, in case attempt is made to read
2540 new object name. Should this fail, error message can give previous
2542 namelist_info
*prev_nl
= NULL
;
2544 dtp
->u
.p
.namelist_mode
= 1;
2545 dtp
->u
.p
.input_complete
= 0;
2546 dtp
->u
.p
.expanded_read
= 0;
2548 dtp
->u
.p
.eof_jump
= &eof_jump
;
2549 if (setjmp (eof_jump
))
2551 dtp
->u
.p
.eof_jump
= NULL
;
2552 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2556 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2557 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2558 node names or namelist on stdout. */
2561 switch (c
= next_char (dtp
))
2568 c
= next_char (dtp
);
2570 nml_query (dtp
, '=');
2572 unget_char (dtp
, c
);
2576 nml_query (dtp
, '?');
2582 /* Match the name of the namelist. */
2584 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2586 if (dtp
->u
.p
.nml_read_error
)
2589 /* Ready to read namelist objects. If there is an error in input
2590 from stdin, output the error message and continue. */
2592 while (!dtp
->u
.p
.input_complete
)
2594 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2598 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2601 u
= find_unit (options
.stderr_unit
);
2602 st_printf ("%s\n", nml_err_msg
);
2612 dtp
->u
.p
.eof_jump
= NULL
;
2617 /* All namelist error calls return from here */
2621 dtp
->u
.p
.eof_jump
= NULL
;
2624 generate_error (&dtp
->common
, ERROR_READ_VALUE
, nml_err_msg
);