1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
67 /* Save a character to a string buffer, enlarging it as necessary. */
70 push_char (st_parameter_dt
*dtp
, char c
)
74 if (dtp
->u
.p
.saved_string
== NULL
)
76 if (dtp
->u
.p
.scratch
== NULL
)
77 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
78 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
79 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
80 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
81 dtp
->u
.p
.saved_used
= 0;
84 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
86 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
87 new = get_mem (2 * dtp
->u
.p
.saved_length
);
89 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
91 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
92 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
93 free_mem (dtp
->u
.p
.saved_string
);
95 dtp
->u
.p
.saved_string
= new;
98 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
102 /* Free the input buffer if necessary. */
105 free_saved (st_parameter_dt
*dtp
)
107 if (dtp
->u
.p
.saved_string
== NULL
)
110 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
111 free_mem (dtp
->u
.p
.saved_string
);
113 dtp
->u
.p
.saved_string
= NULL
;
114 dtp
->u
.p
.saved_used
= 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt
*dtp
)
123 if (dtp
->u
.p
.line_buffer
== NULL
)
126 free_mem (dtp
->u
.p
.line_buffer
);
127 dtp
->u
.p
.line_buffer
= NULL
;
132 next_char (st_parameter_dt
*dtp
)
138 if (dtp
->u
.p
.last_char
!= '\0')
141 c
= dtp
->u
.p
.last_char
;
142 dtp
->u
.p
.last_char
= '\0';
146 /* Read from line_buffer if enabled. */
148 if (dtp
->u
.p
.line_buffer_enabled
)
152 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
153 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
155 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
156 dtp
->u
.p
.item_count
++;
160 dtp
->u
.p
.item_count
= 0;
161 dtp
->u
.p
.line_buffer_enabled
= 0;
164 /* Handle the end-of-record and end-of-file conditions for
165 internal array unit. */
166 if (is_array_io (dtp
))
169 longjmp (*dtp
->u
.p
.eof_jump
, 1);
171 /* Check for "end-of-record" condition. */
172 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
175 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
177 /* Check for "end-of-file" condition. */
184 record
*= dtp
->u
.p
.current_unit
->recl
;
185 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
186 longjmp (*dtp
->u
.p
.eof_jump
, 1);
188 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
193 /* Get the next character and handle end-of-record conditions. */
197 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
199 if (is_stream_io (dtp
))
200 dtp
->u
.p
.current_unit
->strm_pos
++;
202 if (is_internal_unit (dtp
))
204 if (is_array_io (dtp
))
206 /* End of record is handled in the next pass through, above. The
207 check for NULL here is cautionary. */
210 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
214 dtp
->u
.p
.current_unit
->bytes_left
--;
220 longjmp (*dtp
->u
.p
.eof_jump
, 1);
231 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
236 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
237 longjmp (*dtp
->u
.p
.eof_jump
, 1);
238 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
245 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt
*dtp
, char c
)
255 dtp
->u
.p
.last_char
= c
;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt
*dtp
)
271 while (c
== ' ' || c
== '\t');
278 /* Skip over a separator. Technically, we don't always eat the whole
279 separator. This is because if we've processed the last input item,
280 then a separator is unnecessary. Plus the fact that operating
281 systems usually deliver console input on a line basis.
283 The upshot is that if we see a newline as part of reading a
284 separator, we stop reading. If there are more input items, we
285 continue reading the separator with finish_separator() which takes
286 care of the fact that we may or may not have seen a comma as part
290 eat_separator (st_parameter_dt
*dtp
)
295 dtp
->u
.p
.comma_flag
= 0;
301 dtp
->u
.p
.comma_flag
= 1;
306 dtp
->u
.p
.input_complete
= 1;
322 if (dtp
->u
.p
.namelist_mode
)
323 { /* Eat a namelist comment. */
331 /* Fall Through... */
340 /* Finish processing a separator that was interrupted by a newline.
341 If we're here, then another data item is present, so we finish what
342 we started on the previous line. */
345 finish_separator (st_parameter_dt
*dtp
)
356 if (dtp
->u
.p
.comma_flag
)
360 c
= eat_spaces (dtp
);
361 if (c
== '\n' || c
== '\r')
368 dtp
->u
.p
.input_complete
= 1;
369 if (!dtp
->u
.p
.namelist_mode
)
378 if (dtp
->u
.p
.namelist_mode
)
394 /* This function reads characters through to the end of the current line and
395 just ignores them. */
398 eat_line (st_parameter_dt
*dtp
)
401 if (!is_internal_unit (dtp
))
408 /* This function is needed to catch bad conversions so that namelist can
409 attempt to see if dtp->u.p.saved_string contains a new object name rather
413 nml_bad_return (st_parameter_dt
*dtp
, char c
)
415 if (dtp
->u
.p
.namelist_mode
)
417 dtp
->u
.p
.nml_read_error
= 1;
424 /* Convert an unsigned string to an integer. The length value is -1
425 if we are working on a repeat count. Returns nonzero if we have a
426 range problem. As a side effect, frees the dtp->u.p.saved_string. */
429 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
431 char c
, *buffer
, message
[100];
433 GFC_INTEGER_LARGEST v
, max
, max10
;
435 buffer
= dtp
->u
.p
.saved_string
;
438 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
463 set_integer (dtp
->u
.p
.value
, v
, length
);
467 dtp
->u
.p
.repeat_count
= v
;
469 if (dtp
->u
.p
.repeat_count
== 0)
471 sprintf (message
, "Zero repeat count in item %d of list input",
472 dtp
->u
.p
.item_count
);
474 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
484 sprintf (message
, "Repeat count overflow in item %d of list input",
485 dtp
->u
.p
.item_count
);
487 sprintf (message
, "Integer overflow while reading item %d",
488 dtp
->u
.p
.item_count
);
491 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
497 /* Parse a repeat count for logical and complex values which cannot
498 begin with a digit. Returns nonzero if we are done, zero if we
499 should continue on. */
502 parse_repeat (st_parameter_dt
*dtp
)
504 char c
, message
[100];
530 repeat
= 10 * repeat
+ c
- '0';
532 if (repeat
> MAX_REPEAT
)
535 "Repeat count overflow in item %d of list input",
536 dtp
->u
.p
.item_count
);
538 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
548 "Zero repeat count in item %d of list input",
549 dtp
->u
.p
.item_count
);
551 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
563 dtp
->u
.p
.repeat_count
= repeat
;
570 sprintf (message
, "Bad repeat count in item %d of list input",
571 dtp
->u
.p
.item_count
);
572 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
577 /* To read a logical we have to look ahead in the input stream to make sure
578 there is not an equal sign indicating a variable name. To do this we use
579 line_buffer to point to a temporary buffer, pushing characters there for
580 possible later reading. */
583 l_push_char (st_parameter_dt
*dtp
, char c
)
585 if (dtp
->u
.p
.line_buffer
== NULL
)
587 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
588 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
591 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
595 /* Read a logical character on the input. */
598 read_logical (st_parameter_dt
*dtp
, int length
)
600 char c
, message
[100];
603 if (parse_repeat (dtp
))
606 c
= tolower (next_char (dtp
));
607 l_push_char (dtp
, c
);
613 l_push_char (dtp
, c
);
615 if (!is_separator(c
))
623 l_push_char (dtp
, c
);
625 if (!is_separator(c
))
631 c
= tolower (next_char (dtp
));
649 return; /* Null value. */
655 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
656 dtp
->u
.p
.saved_length
= length
;
658 /* Eat trailing garbage. */
663 while (!is_separator (c
));
667 dtp
->u
.p
.item_count
= 0;
668 dtp
->u
.p
.line_buffer_enabled
= 0;
669 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
676 for(i
= 0; i
< 63; i
++)
681 /* All done if this is not a namelist read. */
682 if (!dtp
->u
.p
.namelist_mode
)
695 l_push_char (dtp
, c
);
698 dtp
->u
.p
.nml_read_error
= 1;
699 dtp
->u
.p
.line_buffer_enabled
= 1;
700 dtp
->u
.p
.item_count
= 0;
710 if (nml_bad_return (dtp
, c
))
715 sprintf (message
, "Bad logical value while reading item %d",
716 dtp
->u
.p
.item_count
);
717 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
722 dtp
->u
.p
.item_count
= 0;
723 dtp
->u
.p
.line_buffer_enabled
= 0;
724 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
725 dtp
->u
.p
.saved_length
= length
;
726 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
732 /* Reading integers is tricky because we can actually be reading a
733 repeat count. We have to store the characters in a buffer because
734 we could be reading an integer that is larger than the default int
735 used for repeat counts. */
738 read_integer (st_parameter_dt
*dtp
, int length
)
740 char c
, message
[100];
750 /* Fall through... */
756 CASE_SEPARATORS
: /* Single null. */
769 /* Take care of what may be a repeat count. */
781 push_char (dtp
, '\0');
784 CASE_SEPARATORS
: /* Not a repeat count. */
793 if (convert_integer (dtp
, -1, 0))
796 /* Get the real integer. */
811 /* Fall through... */
842 if (nml_bad_return (dtp
, c
))
847 sprintf (message
, "Bad integer for item %d in list input",
848 dtp
->u
.p
.item_count
);
849 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
857 push_char (dtp
, '\0');
858 if (convert_integer (dtp
, length
, negative
))
865 dtp
->u
.p
.saved_type
= BT_INTEGER
;
869 /* Read a character variable. */
872 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
874 char c
, quote
, message
[100];
876 quote
= ' '; /* Space means no quote character. */
886 unget_char (dtp
, c
); /* NULL value. */
896 if (dtp
->u
.p
.namelist_mode
)
905 /* Deal with a possible repeat count. */
918 goto done
; /* String was only digits! */
921 push_char (dtp
, '\0');
926 goto get_string
; /* Not a repeat count after all. */
931 if (convert_integer (dtp
, -1, 0))
934 /* Now get the real string. */
940 unget_char (dtp
, c
); /* Repeated NULL values. */
968 /* See if we have a doubled quote character or the end of
974 push_char (dtp
, quote
);
988 if (c
!= '\n' && c
!= '\r')
998 /* At this point, we have to have a separator, or else the string is
1001 c
= next_char (dtp
);
1002 if (is_separator (c
))
1004 unget_char (dtp
, c
);
1005 eat_separator (dtp
);
1006 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1011 sprintf (message
, "Invalid string input in item %d",
1012 dtp
->u
.p
.item_count
);
1013 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1018 /* Parse a component of a complex constant or a real number that we
1019 are sure is already there. This is a straight real number parser. */
1022 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1024 char c
, message
[100];
1027 c
= next_char (dtp
);
1028 if (c
== '-' || c
== '+')
1031 c
= next_char (dtp
);
1034 if (!isdigit (c
) && c
!= '.')
1039 seen_dp
= (c
== '.') ? 1 : 0;
1043 c
= next_char (dtp
);
1062 push_char (dtp
, 'e');
1067 push_char (dtp
, 'e');
1069 c
= next_char (dtp
);
1073 unget_char (dtp
, c
);
1082 c
= next_char (dtp
);
1083 if (c
!= '-' && c
!= '+')
1084 push_char (dtp
, '+');
1088 c
= next_char (dtp
);
1098 c
= next_char (dtp
);
1106 unget_char (dtp
, c
);
1115 unget_char (dtp
, c
);
1116 push_char (dtp
, '\0');
1118 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1125 if (nml_bad_return (dtp
, c
))
1130 sprintf (message
, "Bad floating point number for item %d",
1131 dtp
->u
.p
.item_count
);
1132 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1138 /* Reading a complex number is straightforward because we can tell
1139 what it is right away. */
1142 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1147 if (parse_repeat (dtp
))
1150 c
= next_char (dtp
);
1157 unget_char (dtp
, c
);
1158 eat_separator (dtp
);
1166 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1171 c
= next_char (dtp
);
1172 if (c
== '\n' || c
== '\r')
1175 unget_char (dtp
, c
);
1177 if (next_char (dtp
) != ',')
1182 c
= next_char (dtp
);
1183 if (c
== '\n' || c
== '\r')
1186 unget_char (dtp
, c
);
1188 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1192 if (next_char (dtp
) != ')')
1195 c
= next_char (dtp
);
1196 if (!is_separator (c
))
1199 unget_char (dtp
, c
);
1200 eat_separator (dtp
);
1203 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1208 if (nml_bad_return (dtp
, c
))
1213 sprintf (message
, "Bad complex value in item %d of list input",
1214 dtp
->u
.p
.item_count
);
1215 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1219 /* Parse a real number with a possible repeat count. */
1222 read_real (st_parameter_dt
*dtp
, int length
)
1224 char c
, message
[100];
1229 c
= next_char (dtp
);
1246 unget_char (dtp
, c
); /* Single null. */
1247 eat_separator (dtp
);
1254 /* Get the digit string that might be a repeat count. */
1258 c
= next_char (dtp
);
1281 push_char (dtp
, 'e');
1283 c
= next_char (dtp
);
1287 push_char (dtp
, '\0');
1291 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1292 unget_char (dtp
, c
);
1301 if (convert_integer (dtp
, -1, 0))
1304 /* Now get the number itself. */
1306 c
= next_char (dtp
);
1307 if (is_separator (c
))
1308 { /* Repeated null value. */
1309 unget_char (dtp
, c
);
1310 eat_separator (dtp
);
1314 if (c
!= '-' && c
!= '+')
1315 push_char (dtp
, '+');
1320 c
= next_char (dtp
);
1323 if (!isdigit (c
) && c
!= '.')
1339 c
= next_char (dtp
);
1365 push_char (dtp
, 'e');
1367 c
= next_char (dtp
);
1376 push_char (dtp
, 'e');
1378 c
= next_char (dtp
);
1379 if (c
!= '+' && c
!= '-')
1380 push_char (dtp
, '+');
1384 c
= next_char (dtp
);
1394 c
= next_char (dtp
);
1411 unget_char (dtp
, c
);
1412 eat_separator (dtp
);
1413 push_char (dtp
, '\0');
1414 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1418 dtp
->u
.p
.saved_type
= BT_REAL
;
1423 if (nml_bad_return (dtp
, c
))
1428 sprintf (message
, "Bad real number in item %d of list input",
1429 dtp
->u
.p
.item_count
);
1430 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1434 /* Check the current type against the saved type to make sure they are
1435 compatible. Returns nonzero if incompatible. */
1438 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1442 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1444 sprintf (message
, "Read type %s where %s was expected for item %d",
1445 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1446 dtp
->u
.p
.item_count
);
1448 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1452 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1455 if (dtp
->u
.p
.saved_length
!= len
)
1458 "Read kind %d %s where kind %d is required for item %d",
1459 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1460 dtp
->u
.p
.item_count
);
1461 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1469 /* Top level data transfer subroutine for list reads. Because we have
1470 to deal with repeat counts, the data item is always saved after
1471 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1472 greater than one, we copy the data item multiple times. */
1475 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1482 dtp
->u
.p
.namelist_mode
= 0;
1484 dtp
->u
.p
.eof_jump
= &eof_jump
;
1485 if (setjmp (eof_jump
))
1487 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1491 if (dtp
->u
.p
.first_item
)
1493 dtp
->u
.p
.first_item
= 0;
1494 dtp
->u
.p
.input_complete
= 0;
1495 dtp
->u
.p
.repeat_count
= 1;
1496 dtp
->u
.p
.at_eol
= 0;
1498 c
= eat_spaces (dtp
);
1499 if (is_separator (c
))
1501 /* Found a null value. */
1502 eat_separator (dtp
);
1503 dtp
->u
.p
.repeat_count
= 0;
1505 /* eat_separator sets this flag if the separator was a comma. */
1506 if (dtp
->u
.p
.comma_flag
)
1509 /* eat_separator sets this flag if the separator was a \n or \r. */
1510 if (dtp
->u
.p
.at_eol
)
1511 finish_separator (dtp
);
1519 if (dtp
->u
.p
.input_complete
)
1522 if (dtp
->u
.p
.repeat_count
> 0)
1524 if (check_type (dtp
, type
, kind
))
1529 if (dtp
->u
.p
.at_eol
)
1530 finish_separator (dtp
);
1534 /* Trailing spaces prior to end of line. */
1535 if (dtp
->u
.p
.at_eol
)
1536 finish_separator (dtp
);
1539 dtp
->u
.p
.saved_type
= BT_NULL
;
1540 dtp
->u
.p
.repeat_count
= 1;
1546 read_integer (dtp
, kind
);
1549 read_logical (dtp
, kind
);
1552 read_character (dtp
, kind
);
1555 read_real (dtp
, kind
);
1558 read_complex (dtp
, kind
, size
);
1561 internal_error (&dtp
->common
, "Bad type for list read");
1564 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1565 dtp
->u
.p
.saved_length
= size
;
1567 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1571 switch (dtp
->u
.p
.saved_type
)
1577 memcpy (p
, dtp
->u
.p
.value
, size
);
1581 if (dtp
->u
.p
.saved_string
)
1583 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1584 ? (int) size
: dtp
->u
.p
.saved_used
;
1585 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1588 /* Just delimiters encountered, nothing to copy but SPACE. */
1592 memset (((char *) p
) + m
, ' ', size
- m
);
1599 if (--dtp
->u
.p
.repeat_count
<= 0)
1603 dtp
->u
.p
.eof_jump
= NULL
;
1608 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1609 size_t size
, size_t nelems
)
1616 /* Big loop over all the elements. */
1617 for (elem
= 0; elem
< nelems
; elem
++)
1619 dtp
->u
.p
.item_count
++;
1620 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1625 /* Finish a list read. */
1628 finish_list_read (st_parameter_dt
*dtp
)
1634 if (dtp
->u
.p
.at_eol
)
1636 dtp
->u
.p
.at_eol
= 0;
1642 c
= next_char (dtp
);
1649 void namelist_read (st_parameter_dt *dtp)
1651 static void nml_match_name (char *name, int len)
1652 static int nml_query (st_parameter_dt *dtp)
1653 static int nml_get_obj_data (st_parameter_dt *dtp,
1654 namelist_info **prev_nl, char *)
1656 static void nml_untouch_nodes (st_parameter_dt *dtp)
1657 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1659 static int nml_parse_qualifier(descriptor_dimension * ad,
1660 array_loop_spec * ls, int rank, char *)
1661 static void nml_touch_nodes (namelist_info * nl)
1662 static int nml_read_obj (namelist_info *nl, index_type offset,
1663 namelist_info **prev_nl, char *,
1664 index_type clow, index_type chigh)
1668 /* Inputs a rank-dimensional qualifier, which can contain
1669 singlets, doublets, triplets or ':' with the standard meanings. */
1672 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1673 array_loop_spec
*ls
, int rank
, char *parse_err_msg
)
1679 int is_array_section
;
1682 is_array_section
= 0;
1683 dtp
->u
.p
.expanded_read
= 0;
1685 /* The next character in the stream should be the '('. */
1687 c
= next_char (dtp
);
1689 /* Process the qualifier, by dimension and triplet. */
1691 for (dim
=0; dim
< rank
; dim
++ )
1693 for (indx
=0; indx
<3; indx
++)
1699 /* Process a potential sign. */
1700 c
= next_char (dtp
);
1711 unget_char (dtp
, c
);
1715 /* Process characters up to the next ':' , ',' or ')'. */
1718 c
= next_char (dtp
);
1723 is_array_section
= 1;
1727 if ((c
==',' && dim
== rank
-1)
1728 || (c
==')' && dim
< rank
-1))
1730 sprintf (parse_err_msg
,
1731 "Bad number of index fields");
1740 case ' ': case '\t':
1742 c
= next_char (dtp
);
1746 sprintf (parse_err_msg
, "Bad character in index");
1750 if ((c
== ',' || c
== ')') && indx
== 0
1751 && dtp
->u
.p
.saved_string
== 0)
1753 sprintf (parse_err_msg
, "Null index field");
1757 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1758 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1760 sprintf(parse_err_msg
, "Bad index triplet");
1764 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1766 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1767 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
1773 /* Now read the index. */
1774 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
1776 sprintf (parse_err_msg
, "Bad integer in index");
1782 /* Feed the index values to the triplet arrays. */
1786 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1788 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1790 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1793 /* Singlet or doublet indices. */
1794 if (c
==',' || c
==')')
1798 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1800 /* If -std=f95/2003 or an array section is specified,
1801 do not allow excess data to be processed. */
1802 if (is_array_section
== 1
1803 || compile_options
.allow_std
< GFC_STD_GNU
)
1804 ls
[dim
].end
= ls
[dim
].start
;
1806 dtp
->u
.p
.expanded_read
= 1;
1812 /* Check the values of the triplet indices. */
1813 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1814 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1815 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1816 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1818 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1821 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1822 || (ls
[dim
].step
== 0))
1824 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1828 /* Initialise the loop index counter. */
1829 ls
[dim
].idx
= ls
[dim
].start
;
1839 static namelist_info
*
1840 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
1842 namelist_info
* t
= dtp
->u
.p
.ionml
;
1845 if (strcmp (var_name
, t
->var_name
) == 0)
1855 /* Visits all the components of a derived type that have
1856 not explicitly been identified in the namelist input.
1857 touched is set and the loop specification initialised
1858 to default values */
1861 nml_touch_nodes (namelist_info
* nl
)
1863 index_type len
= strlen (nl
->var_name
) + 1;
1865 char * ext_name
= (char*)get_mem (len
+ 1);
1866 memcpy (ext_name
, nl
->var_name
, len
-1);
1867 memcpy (ext_name
+ len
- 1, "%", 2);
1868 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1870 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1873 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1875 nl
->ls
[dim
].step
= 1;
1876 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1877 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1878 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1884 free_mem (ext_name
);
1888 /* Resets touched for the entire list of nml_nodes, ready for a
1892 nml_untouch_nodes (st_parameter_dt
*dtp
)
1895 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
1900 /* Attempts to input name to namelist name. Returns
1901 dtp->u.p.nml_read_error = 1 on no match. */
1904 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
1908 dtp
->u
.p
.nml_read_error
= 0;
1909 for (i
= 0; i
< len
; i
++)
1911 c
= next_char (dtp
);
1912 if (tolower (c
) != tolower (name
[i
]))
1914 dtp
->u
.p
.nml_read_error
= 1;
1920 /* If the namelist read is from stdin, output the current state of the
1921 namelist to stdout. This is used to implement the non-standard query
1922 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1923 the names alone are printed. */
1926 nml_query (st_parameter_dt
*dtp
, char c
)
1928 gfc_unit
* temp_unit
;
1933 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
1936 /* Store the current unit and transfer to stdout. */
1938 temp_unit
= dtp
->u
.p
.current_unit
;
1939 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
1941 if (dtp
->u
.p
.current_unit
)
1943 dtp
->u
.p
.mode
= WRITING
;
1944 next_record (dtp
, 0);
1946 /* Write the namelist in its entirety. */
1949 namelist_write (dtp
);
1951 /* Or write the list of names. */
1956 /* "&namelist_name\n" */
1958 len
= dtp
->namelist_name_len
;
1960 p
= write_block (dtp
, len
+ 3);
1962 p
= write_block (dtp
, len
+ 2);
1967 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
1969 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1971 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1973 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
1978 len
= strlen (nl
->var_name
);
1980 p
= write_block (dtp
, len
+ 3);
1982 p
= write_block (dtp
, len
+ 2);
1987 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1989 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1991 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1998 p
= write_block (dtp
, 6);
2000 p
= write_block (dtp
, 5);
2005 memcpy (p
, "&end\r\n", 6);
2007 memcpy (p
, "&end\n", 5);
2011 /* Flush the stream to force immediate output. */
2013 flush (dtp
->u
.p
.current_unit
->s
);
2014 unlock_unit (dtp
->u
.p
.current_unit
);
2019 /* Restore the current unit. */
2021 dtp
->u
.p
.current_unit
= temp_unit
;
2022 dtp
->u
.p
.mode
= READING
;
2026 /* Reads and stores the input for the namelist object nl. For an array,
2027 the function loops over the ranges defined by the loop specification.
2028 This default to all the data or to the specification from a qualifier.
2029 nml_read_obj recursively calls itself to read derived types. It visits
2030 all its own components but only reads data for those that were touched
2031 when the name was parsed. If a read error is encountered, an attempt is
2032 made to return to read a new object name because the standard allows too
2033 little data to be available. On the other hand, too much data is an
2037 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2038 namelist_info
**pprev_nl
, char *nml_err_msg
,
2039 index_type clow
, index_type chigh
)
2042 namelist_info
* cmp
;
2049 index_type obj_name_len
;
2052 /* This object not touched in name parsing. */
2057 dtp
->u
.p
.repeat_count
= 0;
2064 case GFC_DTYPE_INTEGER
:
2065 case GFC_DTYPE_LOGICAL
:
2069 case GFC_DTYPE_REAL
:
2070 dlen
= size_from_real_kind (len
);
2073 case GFC_DTYPE_COMPLEX
:
2074 dlen
= size_from_complex_kind (len
);
2077 case GFC_DTYPE_CHARACTER
:
2078 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2088 /* Update the pointer to the data, using the current index vector */
2090 pdata
= (void*)(nl
->mem_pos
+ offset
);
2091 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2092 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2093 nl
->dim
[dim
].stride
* nl
->size
);
2095 /* Reset the error flag and try to read next value, if
2096 dtp->u.p.repeat_count=0 */
2098 dtp
->u
.p
.nml_read_error
= 0;
2100 if (--dtp
->u
.p
.repeat_count
<= 0)
2102 if (dtp
->u
.p
.input_complete
)
2104 if (dtp
->u
.p
.at_eol
)
2105 finish_separator (dtp
);
2106 if (dtp
->u
.p
.input_complete
)
2109 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2110 after the switch block. */
2112 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2117 case GFC_DTYPE_INTEGER
:
2118 read_integer (dtp
, len
);
2121 case GFC_DTYPE_LOGICAL
:
2122 read_logical (dtp
, len
);
2125 case GFC_DTYPE_CHARACTER
:
2126 read_character (dtp
, len
);
2129 case GFC_DTYPE_REAL
:
2130 read_real (dtp
, len
);
2133 case GFC_DTYPE_COMPLEX
:
2134 read_complex (dtp
, len
, dlen
);
2137 case GFC_DTYPE_DERIVED
:
2138 obj_name_len
= strlen (nl
->var_name
) + 1;
2139 obj_name
= get_mem (obj_name_len
+1);
2140 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2141 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2143 /* If reading a derived type, disable the expanded read warning
2144 since a single object can have multiple reads. */
2145 dtp
->u
.p
.expanded_read
= 0;
2147 /* Now loop over the components. Update the component pointer
2148 with the return value from nml_write_obj. This loop jumps
2149 past nested derived types by testing if the potential
2150 component name contains '%'. */
2152 for (cmp
= nl
->next
;
2154 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2155 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2159 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2160 pprev_nl
, nml_err_msg
, clow
, chigh
)
2163 free_mem (obj_name
);
2167 if (dtp
->u
.p
.input_complete
)
2169 free_mem (obj_name
);
2174 free_mem (obj_name
);
2178 sprintf (nml_err_msg
, "Bad type for namelist object %s",
2180 internal_error (&dtp
->common
, nml_err_msg
);
2185 /* The standard permits array data to stop short of the number of
2186 elements specified in the loop specification. In this case, we
2187 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2188 nml_get_obj_data and an attempt is made to read object name. */
2191 if (dtp
->u
.p
.nml_read_error
)
2193 dtp
->u
.p
.expanded_read
= 0;
2197 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2199 dtp
->u
.p
.expanded_read
= 0;
2203 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2204 This comes about because the read functions return BT_types. */
2206 switch (dtp
->u
.p
.saved_type
)
2213 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2217 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2218 pdata
= (void*)( pdata
+ clow
- 1 );
2219 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2221 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2228 /* Warn if a non-standard expanded read occurs. A single read of a
2229 single object is acceptable. If a second read occurs, issue a warning
2230 and set the flag to zero to prevent further warnings. */
2231 if (dtp
->u
.p
.expanded_read
== 2)
2233 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2234 dtp
->u
.p
.expanded_read
= 0;
2237 /* If the expanded read warning flag is set, increment it,
2238 indicating that a single read has occurred. */
2239 if (dtp
->u
.p
.expanded_read
>= 1)
2240 dtp
->u
.p
.expanded_read
++;
2242 /* Break out of loop if scalar. */
2246 /* Now increment the index vector. */
2251 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2253 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2255 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2257 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2259 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2263 } while (!nml_carry
);
2265 if (dtp
->u
.p
.repeat_count
> 1)
2267 sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2278 /* Parses the object name, including array and substring qualifiers. It
2279 iterates over derived type components, touching those components and
2280 setting their loop specifications, if there is a qualifier. If the
2281 object is itself a derived type, its components and subcomponents are
2282 touched. nml_read_obj is called at the end and this reads the data in
2283 the manner specified by the object name. */
2286 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2291 namelist_info
* first_nl
= NULL
;
2292 namelist_info
* root_nl
= NULL
;
2295 char parse_err_msg
[30];
2296 index_type clow
, chigh
;
2298 /* Look for end of input or object name. If '?' or '=?' are encountered
2299 in stdin, print the node names or the namelist to stdout. */
2301 eat_separator (dtp
);
2302 if (dtp
->u
.p
.input_complete
)
2305 if (dtp
->u
.p
.at_eol
)
2306 finish_separator (dtp
);
2307 if (dtp
->u
.p
.input_complete
)
2310 c
= next_char (dtp
);
2314 c
= next_char (dtp
);
2317 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2320 nml_query (dtp
, '=');
2324 nml_query (dtp
, '?');
2329 nml_match_name (dtp
, "end", 3);
2330 if (dtp
->u
.p
.nml_read_error
)
2332 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2336 dtp
->u
.p
.input_complete
= 1;
2343 /* Untouch all nodes of the namelist and reset the flag that is set for
2344 derived type components. */
2346 nml_untouch_nodes (dtp
);
2349 /* Get the object name - should '!' and '\n' be permitted separators? */
2357 push_char (dtp
, tolower(c
));
2358 c
= next_char (dtp
);
2359 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2361 unget_char (dtp
, c
);
2363 /* Check that the name is in the namelist and get pointer to object.
2364 Three error conditions exist: (i) An attempt is being made to
2365 identify a non-existent object, following a failed data read or
2366 (ii) The object name does not exist or (iii) Too many data items
2367 are present for an object. (iii) gives the same error message
2370 push_char (dtp
, '\0');
2374 size_t var_len
= strlen (root_nl
->var_name
);
2376 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2377 char ext_name
[var_len
+ saved_len
+ 1];
2379 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2380 if (dtp
->u
.p
.saved_string
)
2381 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2382 ext_name
[var_len
+ saved_len
] = '\0';
2383 nl
= find_nml_node (dtp
, ext_name
);
2386 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2390 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2391 sprintf (nml_err_msg
, "Bad data for namelist object %s",
2392 (*pprev_nl
)->var_name
);
2395 sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2396 dtp
->u
.p
.saved_string
);
2401 /* Get the length, data length, base pointer and rank of the variable.
2402 Set the default loop specification first. */
2404 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2406 nl
->ls
[dim
].step
= 1;
2407 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2408 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2409 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2412 /* Check to see if there is a qualifier: if so, parse it.*/
2414 if (c
== '(' && nl
->var_rank
)
2416 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2417 parse_err_msg
) == FAILURE
)
2419 sprintf (nml_err_msg
, "%s for namelist variable %s",
2420 parse_err_msg
, nl
->var_name
);
2423 c
= next_char (dtp
);
2424 unget_char (dtp
, c
);
2427 /* Now parse a derived type component. The root namelist_info address
2428 is backed up, as is the previous component level. The component flag
2429 is set and the iteration is made by jumping back to get_name. */
2434 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2436 sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2441 if (!component_flag
)
2446 c
= next_char (dtp
);
2451 /* Parse a character qualifier, if present. chigh = 0 is a default
2452 that signals that the string length = string_length. */
2457 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2459 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2460 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2462 if (nml_parse_qualifier (dtp
, chd
, ind
, 1, parse_err_msg
) == FAILURE
)
2464 sprintf (nml_err_msg
, "%s for namelist variable %s",
2465 parse_err_msg
, nl
->var_name
);
2469 clow
= ind
[0].start
;
2472 if (ind
[0].step
!= 1)
2474 sprintf (nml_err_msg
,
2475 "Bad step in substring for namelist object %s",
2480 c
= next_char (dtp
);
2481 unget_char (dtp
, c
);
2484 /* If a derived type touch its components and restore the root
2485 namelist_info if we have parsed a qualified derived type
2488 if (nl
->type
== GFC_DTYPE_DERIVED
)
2489 nml_touch_nodes (nl
);
2493 /*make sure no extraneous qualifiers are there.*/
2497 sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2498 " namelist object %s", nl
->var_name
);
2502 /* According to the standard, an equal sign MUST follow an object name. The
2503 following is possibly lax - it allows comments, blank lines and so on to
2504 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2508 eat_separator (dtp
);
2509 if (dtp
->u
.p
.input_complete
)
2512 if (dtp
->u
.p
.at_eol
)
2513 finish_separator (dtp
);
2514 if (dtp
->u
.p
.input_complete
)
2517 c
= next_char (dtp
);
2521 sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2526 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2536 /* Entry point for namelist input. Goes through input until namelist name
2537 is matched. Then cycles through nml_get_obj_data until the input is
2538 completed or there is an error. */
2541 namelist_read (st_parameter_dt
*dtp
)
2545 char nml_err_msg
[100];
2546 /* Pointer to the previously read object, in case attempt is made to read
2547 new object name. Should this fail, error message can give previous
2549 namelist_info
*prev_nl
= NULL
;
2551 dtp
->u
.p
.namelist_mode
= 1;
2552 dtp
->u
.p
.input_complete
= 0;
2553 dtp
->u
.p
.expanded_read
= 0;
2555 dtp
->u
.p
.eof_jump
= &eof_jump
;
2556 if (setjmp (eof_jump
))
2558 dtp
->u
.p
.eof_jump
= NULL
;
2559 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2563 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2564 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2565 node names or namelist on stdout. */
2568 switch (c
= next_char (dtp
))
2579 c
= next_char (dtp
);
2581 nml_query (dtp
, '=');
2583 unget_char (dtp
, c
);
2587 nml_query (dtp
, '?');
2593 /* Match the name of the namelist. */
2595 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2597 if (dtp
->u
.p
.nml_read_error
)
2600 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2601 c
= next_char (dtp
);
2602 if (!is_separator(c
))
2604 unget_char (dtp
, c
);
2608 /* Ready to read namelist objects. If there is an error in input
2609 from stdin, output the error message and continue. */
2611 while (!dtp
->u
.p
.input_complete
)
2613 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2617 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2620 u
= find_unit (options
.stderr_unit
);
2621 st_printf ("%s\n", nml_err_msg
);
2631 dtp
->u
.p
.eof_jump
= NULL
;
2636 /* All namelist error calls return from here */
2640 dtp
->u
.p
.eof_jump
= NULL
;
2643 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);