1 /* Copyright (C) 2002-2017 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
34 typedef unsigned char uchar
;
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': \
55 case '\t': case '\r': case ';'
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' || c == ';' || \
61 (dtp->u.p.namelist_mode && c == '!'))
63 /* Maximum repeat count. Less than ten times the maximum signed int32. */
65 #define MAX_REPEAT 200000000
71 /* Wrappers for calling the current worker functions. */
73 #define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
74 #define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c))
76 /* Worker function to save a default KIND=1 character to a string
77 buffer, enlarging it as necessary. */
80 push_char_default (st_parameter_dt
*dtp
, int c
)
84 if (dtp
->u
.p
.saved_string
== NULL
)
86 /* Plain malloc should suffice here, zeroing not needed? */
87 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
88 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
89 dtp
->u
.p
.saved_used
= 0;
92 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
94 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
95 dtp
->u
.p
.saved_string
=
96 xrealloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
99 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = (char) c
;
103 /* Worker function to save a KIND=4 character to a string buffer,
104 enlarging the buffer as necessary. */
106 push_char4 (st_parameter_dt
*dtp
, int c
)
108 gfc_char4_t
*p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
112 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, sizeof (gfc_char4_t
));
113 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
114 dtp
->u
.p
.saved_used
= 0;
115 p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
118 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
120 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
121 dtp
->u
.p
.saved_string
=
122 xrealloc (dtp
->u
.p
.saved_string
,
123 dtp
->u
.p
.saved_length
* sizeof (gfc_char4_t
));
124 p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
127 p
[dtp
->u
.p
.saved_used
++] = c
;
131 /* Free the input buffer if necessary. */
134 free_saved (st_parameter_dt
*dtp
)
136 if (dtp
->u
.p
.saved_string
== NULL
)
139 free (dtp
->u
.p
.saved_string
);
141 dtp
->u
.p
.saved_string
= NULL
;
142 dtp
->u
.p
.saved_used
= 0;
146 /* Free the line buffer if necessary. */
149 free_line (st_parameter_dt
*dtp
)
151 dtp
->u
.p
.line_buffer_pos
= 0;
152 dtp
->u
.p
.line_buffer_enabled
= 0;
154 if (dtp
->u
.p
.line_buffer
== NULL
)
157 free (dtp
->u
.p
.line_buffer
);
158 dtp
->u
.p
.line_buffer
= NULL
;
162 /* Unget saves the last character so when reading the next character,
163 we need to check to see if there is a character waiting. Similar,
164 if the line buffer is being used to read_logical, check it too. */
167 check_buffers (st_parameter_dt
*dtp
)
172 if (dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1)
175 c
= dtp
->u
.p
.current_unit
->last_char
;
176 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
180 /* Read from line_buffer if enabled. */
182 if (dtp
->u
.p
.line_buffer_enabled
)
186 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
];
187 if (c
!= '\0' && dtp
->u
.p
.line_buffer_pos
< 64)
189 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
] = '\0';
190 dtp
->u
.p
.line_buffer_pos
++;
194 dtp
->u
.p
.line_buffer_pos
= 0;
195 dtp
->u
.p
.line_buffer_enabled
= 0;
199 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r' || c
== EOF
);
204 /* Worker function for default character encoded file. */
206 next_char_default (st_parameter_dt
*dtp
)
210 /* Always check the unget and line buffer first. */
211 if ((c
= check_buffers (dtp
)))
214 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
215 if (c
!= EOF
&& is_stream_io (dtp
))
216 dtp
->u
.p
.current_unit
->strm_pos
++;
218 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
223 /* Worker function for internal and array I/O units. */
225 next_char_internal (st_parameter_dt
*dtp
)
231 /* Always check the unget and line buffer first. */
232 if ((c
= check_buffers (dtp
)))
235 /* Handle the end-of-record and end-of-file conditions for
236 internal array unit. */
237 if (is_array_io (dtp
))
242 /* Check for "end-of-record" condition. */
243 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
248 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
251 /* Check for "end-of-file" condition. */
258 record
*= dtp
->u
.p
.current_unit
->recl
;
259 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
262 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
267 /* Get the next character and handle end-of-record conditions. */
269 if (is_char4_unit(dtp
)) /* Check for kind=4 internal unit. */
270 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, 1);
274 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
278 if (unlikely (length
< 0))
280 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
284 if (is_array_io (dtp
))
286 /* Check whether we hit EOF. */
287 if (unlikely (length
== 0))
289 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
292 dtp
->u
.p
.current_unit
->bytes_left
--;
306 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
311 /* Worker function for UTF encoded files. */
313 next_char_utf8 (st_parameter_dt
*dtp
)
315 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
316 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
320 /* Always check the unget and line buffer first. */
321 if (!(c
= check_buffers (dtp
)))
322 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
327 /* The number of leading 1-bits in the first byte indicates how many
329 for (nb
= 2; nb
< 7; nb
++)
330 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
335 c
= (c
& masks
[nb
-1]);
337 /* Decode the bytes read. */
338 for (i
= 1; i
< nb
; i
++)
340 gfc_char4_t n
= fbuf_getc (dtp
->u
.p
.current_unit
);
341 if ((n
& 0xC0) != 0x80)
343 c
= ((c
<< 6) + (n
& 0x3F));
346 /* Make sure the shortest possible encoding was used. */
347 if (c
<= 0x7F && nb
> 1) goto invalid
;
348 if (c
<= 0x7FF && nb
> 2) goto invalid
;
349 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
350 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
351 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
353 /* Make sure the character is valid. */
354 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
358 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== (gfc_char4_t
) EOF
);
362 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
363 return (gfc_char4_t
) '?';
366 /* Push a character back onto the input. */
369 unget_char (st_parameter_dt
*dtp
, int c
)
371 dtp
->u
.p
.current_unit
->last_char
= c
;
375 /* Skip over spaces in the input. Returns the nonspace character that
376 terminated the eating and also places it back on the input. */
379 eat_spaces (st_parameter_dt
*dtp
)
383 /* If internal character array IO, peak ahead and seek past spaces.
384 This is an optimization unique to character arrays with large
385 character lengths (PR38199). This code eliminates numerous calls
386 to next_character. */
387 if (is_array_io (dtp
) && (dtp
->u
.p
.current_unit
->last_char
== EOF
- 1))
389 gfc_offset offset
= stell (dtp
->u
.p
.current_unit
->s
);
392 if (is_char4_unit(dtp
)) /* kind=4 */
394 for (i
= 0; i
< dtp
->u
.p
.current_unit
->bytes_left
; i
++)
396 if (dtp
->internal_unit
[(offset
+ i
) * sizeof (gfc_char4_t
)]
403 for (i
= 0; i
< dtp
->u
.p
.current_unit
->bytes_left
; i
++)
405 if (dtp
->internal_unit
[offset
+ i
] != ' ')
412 sseek (dtp
->u
.p
.current_unit
->s
, offset
+ i
, SEEK_SET
);
413 dtp
->u
.p
.current_unit
->bytes_left
-= i
;
417 /* Now skip spaces, EOF and EOL are handled in next_char. */
420 while (c
!= EOF
&& (c
== ' ' || c
== '\r' || c
== '\t'));
427 /* This function reads characters through to the end of the current
428 line and just ignores them. Returns 0 for success and LIBERROR_END
432 eat_line (st_parameter_dt
*dtp
)
438 while (c
!= EOF
&& c
!= '\n');
445 /* Skip over a separator. Technically, we don't always eat the whole
446 separator. This is because if we've processed the last input item,
447 then a separator is unnecessary. Plus the fact that operating
448 systems usually deliver console input on a line basis.
450 The upshot is that if we see a newline as part of reading a
451 separator, we stop reading. If there are more input items, we
452 continue reading the separator with finish_separator() which takes
453 care of the fact that we may or may not have seen a comma as part
456 Returns 0 for success, and non-zero error code otherwise. */
459 eat_separator (st_parameter_dt
*dtp
)
465 dtp
->u
.p
.comma_flag
= 0;
467 if ((c
= next_char (dtp
)) == EOF
)
472 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
479 dtp
->u
.p
.comma_flag
= 1;
484 dtp
->u
.p
.input_complete
= 1;
488 if ((n
= next_char(dtp
)) == EOF
)
498 if (dtp
->u
.p
.namelist_mode
)
502 if ((c
= next_char (dtp
)) == EOF
)
506 err
= eat_line (dtp
);
512 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
518 /* Eat a namelist comment. */
519 if (dtp
->u
.p
.namelist_mode
)
521 err
= eat_line (dtp
);
528 /* Fall Through... */
538 /* Finish processing a separator that was interrupted by a newline.
539 If we're here, then another data item is present, so we finish what
540 we started on the previous line. Return 0 on success, error code
544 finish_separator (st_parameter_dt
*dtp
)
547 int err
= LIBERROR_OK
;
552 if ((c
= next_char (dtp
)) == EOF
)
557 if (dtp
->u
.p
.comma_flag
)
561 if ((c
= eat_spaces (dtp
)) == EOF
)
563 if (c
== '\n' || c
== '\r')
570 dtp
->u
.p
.input_complete
= 1;
571 if (!dtp
->u
.p
.namelist_mode
)
580 if (dtp
->u
.p
.namelist_mode
)
582 err
= eat_line (dtp
);
596 /* This function is needed to catch bad conversions so that namelist can
597 attempt to see if dtp->u.p.saved_string contains a new object name rather
601 nml_bad_return (st_parameter_dt
*dtp
, char c
)
603 if (dtp
->u
.p
.namelist_mode
)
605 dtp
->u
.p
.nml_read_error
= 1;
612 /* Convert an unsigned string to an integer. The length value is -1
613 if we are working on a repeat count. Returns nonzero if we have a
614 range problem. As a side effect, frees the dtp->u.p.saved_string. */
617 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
619 char c
, *buffer
, message
[MSGLEN
];
621 GFC_UINTEGER_LARGEST v
, max
, max10
;
622 GFC_INTEGER_LARGEST value
;
624 buffer
= dtp
->u
.p
.saved_string
;
631 max
= si_max (length
);
661 set_integer (dtp
->u
.p
.value
, value
, length
);
665 dtp
->u
.p
.repeat_count
= v
;
667 if (dtp
->u
.p
.repeat_count
== 0)
669 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
670 dtp
->u
.p
.item_count
);
672 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
682 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
683 dtp
->u
.p
.item_count
);
685 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
686 dtp
->u
.p
.item_count
);
689 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
695 /* Parse a repeat count for logical and complex values which cannot
696 begin with a digit. Returns nonzero if we are done, zero if we
697 should continue on. */
700 parse_repeat (st_parameter_dt
*dtp
)
702 char message
[MSGLEN
];
705 if ((c
= next_char (dtp
)) == EOF
)
729 repeat
= 10 * repeat
+ c
- '0';
731 if (repeat
> MAX_REPEAT
)
733 snprintf (message
, MSGLEN
,
734 "Repeat count overflow in item %d of list input",
735 dtp
->u
.p
.item_count
);
737 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
746 snprintf (message
, MSGLEN
,
747 "Zero repeat count in item %d of list input",
748 dtp
->u
.p
.item_count
);
750 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
762 dtp
->u
.p
.repeat_count
= repeat
;
776 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
777 dtp
->u
.p
.item_count
);
778 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
783 /* To read a logical we have to look ahead in the input stream to make sure
784 there is not an equal sign indicating a variable name. To do this we use
785 line_buffer to point to a temporary buffer, pushing characters there for
786 possible later reading. */
789 l_push_char (st_parameter_dt
*dtp
, char c
)
791 if (dtp
->u
.p
.line_buffer
== NULL
)
792 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
794 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
++] = c
;
798 /* Read a logical character on the input. */
801 read_logical (st_parameter_dt
*dtp
, int length
)
803 char message
[MSGLEN
];
806 if (parse_repeat (dtp
))
809 c
= tolower (next_char (dtp
));
810 l_push_char (dtp
, c
);
816 l_push_char (dtp
, c
);
818 if (!is_separator(c
) && c
!= EOF
)
826 l_push_char (dtp
, c
);
828 if (!is_separator(c
) && c
!= EOF
)
835 c
= tolower (next_char (dtp
));
851 if (!dtp
->u
.p
.namelist_mode
)
858 return; /* Null value. */
861 /* Save the character in case it is the beginning
862 of the next object name. */
867 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
868 dtp
->u
.p
.saved_length
= length
;
870 /* Eat trailing garbage. */
873 while (c
!= EOF
&& !is_separator (c
));
877 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
884 for(i
= 0; i
< 63; i
++)
889 /* All done if this is not a namelist read. */
890 if (!dtp
->u
.p
.namelist_mode
)
903 l_push_char (dtp
, c
);
906 dtp
->u
.p
.nml_read_error
= 1;
907 dtp
->u
.p
.line_buffer_enabled
= 1;
908 dtp
->u
.p
.line_buffer_pos
= 0;
916 if (nml_bad_return (dtp
, c
))
932 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
933 dtp
->u
.p
.item_count
);
935 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
940 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
941 dtp
->u
.p
.saved_length
= length
;
942 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
948 /* Reading integers is tricky because we can actually be reading a
949 repeat count. We have to store the characters in a buffer because
950 we could be reading an integer that is larger than the default int
951 used for repeat counts. */
954 read_integer (st_parameter_dt
*dtp
, int length
)
956 char message
[MSGLEN
];
966 /* Fall through... */
969 if ((c
= next_char (dtp
)) == EOF
)
974 if (!dtp
->u
.p
.namelist_mode
)
977 CASE_SEPARATORS
: /* Single null. */
990 /* Take care of what may be a repeat count. */
1002 push_char (dtp
, '\0');
1006 if (!dtp
->u
.p
.namelist_mode
)
1009 CASE_SEPARATORS
: /* Not a repeat count. */
1019 if (convert_integer (dtp
, -1, 0))
1022 /* Get the real integer. */
1024 if ((c
= next_char (dtp
)) == EOF
)
1032 if (!dtp
->u
.p
.namelist_mode
)
1036 unget_char (dtp
, c
);
1037 eat_separator (dtp
);
1042 /* Fall through... */
1045 c
= next_char (dtp
);
1056 c
= next_char (dtp
);
1064 if (!dtp
->u
.p
.namelist_mode
)
1078 if (nml_bad_return (dtp
, c
))
1091 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
1092 dtp
->u
.p
.item_count
);
1094 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1099 unget_char (dtp
, c
);
1100 eat_separator (dtp
);
1102 push_char (dtp
, '\0');
1103 if (convert_integer (dtp
, length
, negative
))
1110 dtp
->u
.p
.saved_type
= BT_INTEGER
;
1114 /* Read a character variable. */
1117 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
1119 char quote
, message
[MSGLEN
];
1122 quote
= ' '; /* Space means no quote character. */
1124 if ((c
= next_char (dtp
)) == EOF
)
1134 unget_char (dtp
, c
); /* NULL value. */
1135 eat_separator (dtp
);
1144 if (dtp
->u
.p
.namelist_mode
)
1146 unget_char (dtp
, c
);
1153 /* Deal with a possible repeat count. */
1157 c
= next_char (dtp
);
1166 unget_char (dtp
, c
);
1167 goto done
; /* String was only digits! */
1170 push_char (dtp
, '\0');
1175 goto get_string
; /* Not a repeat count after all. */
1180 if (convert_integer (dtp
, -1, 0))
1183 /* Now get the real string. */
1185 if ((c
= next_char (dtp
)) == EOF
)
1190 unget_char (dtp
, c
); /* Repeated NULL values. */
1191 eat_separator (dtp
);
1208 if ((c
= next_char (dtp
)) == EOF
)
1220 /* See if we have a doubled quote character or the end of
1223 if ((c
= next_char (dtp
)) == EOF
)
1227 push_char (dtp
, quote
);
1231 unget_char (dtp
, c
);
1237 unget_char (dtp
, c
);
1241 if (c
!= '\n' && c
!= '\r')
1251 /* At this point, we have to have a separator, or else the string is
1254 c
= next_char (dtp
);
1256 if (is_separator (c
) || c
== EOF
)
1258 unget_char (dtp
, c
);
1259 eat_separator (dtp
);
1260 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1265 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1266 dtp
->u
.p
.item_count
);
1267 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1279 /* Parse a component of a complex constant or a real number that we
1280 are sure is already there. This is a straight real number parser. */
1283 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1285 char message
[MSGLEN
];
1288 if ((c
= next_char (dtp
)) == EOF
)
1291 if (c
== '-' || c
== '+')
1294 if ((c
= next_char (dtp
)) == EOF
)
1298 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1301 if (!isdigit (c
) && c
!= '.')
1303 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1311 seen_dp
= (c
== '.') ? 1 : 0;
1315 if ((c
= next_char (dtp
)) == EOF
)
1317 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1339 push_char (dtp
, 'e');
1344 push_char (dtp
, 'e');
1346 if ((c
= next_char (dtp
)) == EOF
)
1351 if (!dtp
->u
.p
.namelist_mode
)
1364 if ((c
= next_char (dtp
)) == EOF
)
1366 if (c
!= '-' && c
!= '+')
1367 push_char (dtp
, '+');
1371 c
= next_char (dtp
);
1377 /* Extension: allow default exponent of 0 when omitted. */
1378 if (dtp
->common
.flags
& IOPARM_DT_DEFAULT_EXP
)
1380 push_char (dtp
, '0');
1391 if ((c
= next_char (dtp
)) == EOF
)
1400 if (!dtp
->u
.p
.namelist_mode
)
1405 unget_char (dtp
, c
);
1414 unget_char (dtp
, c
);
1415 push_char (dtp
, '\0');
1417 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1423 unget_char (dtp
, c
);
1424 push_char (dtp
, '\0');
1426 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1432 /* Match INF and Infinity. */
1433 if ((c
== 'i' || c
== 'I')
1434 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1435 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1437 c
= next_char (dtp
);
1438 if ((c
!= 'i' && c
!= 'I')
1439 || ((c
== 'i' || c
== 'I')
1440 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1441 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1442 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1443 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1444 && (c
= next_char (dtp
))))
1446 if (is_separator (c
) || (c
== EOF
))
1447 unget_char (dtp
, c
);
1448 push_char (dtp
, 'i');
1449 push_char (dtp
, 'n');
1450 push_char (dtp
, 'f');
1454 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1455 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1456 && (c
= next_char (dtp
)))
1458 if (is_separator (c
) || (c
== EOF
))
1459 unget_char (dtp
, c
);
1460 push_char (dtp
, 'n');
1461 push_char (dtp
, 'a');
1462 push_char (dtp
, 'n');
1464 /* Match "NAN(alphanum)". */
1467 for ( ; c
!= ')'; c
= next_char (dtp
))
1468 if (is_separator (c
))
1471 c
= next_char (dtp
);
1472 if (is_separator (c
) || (c
== EOF
))
1473 unget_char (dtp
, c
);
1480 if (nml_bad_return (dtp
, c
))
1495 snprintf (message
, MSGLEN
, "Bad complex floating point "
1496 "number for item %d", dtp
->u
.p
.item_count
);
1498 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1504 /* Reading a complex number is straightforward because we can tell
1505 what it is right away. */
1508 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1510 char message
[MSGLEN
];
1513 if (parse_repeat (dtp
))
1516 c
= next_char (dtp
);
1523 if (!dtp
->u
.p
.namelist_mode
)
1528 unget_char (dtp
, c
);
1529 eat_separator (dtp
);
1538 c
= next_char (dtp
);
1539 if (c
== '\n' || c
== '\r')
1542 unget_char (dtp
, c
);
1544 if (parse_real (dtp
, dest
, kind
))
1549 c
= next_char (dtp
);
1550 if (c
== '\n' || c
== '\r')
1553 unget_char (dtp
, c
);
1556 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1561 c
= next_char (dtp
);
1562 if (c
== '\n' || c
== '\r')
1565 unget_char (dtp
, c
);
1567 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1572 c
= next_char (dtp
);
1573 if (c
== '\n' || c
== '\r')
1576 unget_char (dtp
, c
);
1578 if (next_char (dtp
) != ')')
1581 c
= next_char (dtp
);
1582 if (!is_separator (c
) && (c
!= EOF
))
1585 unget_char (dtp
, c
);
1586 eat_separator (dtp
);
1589 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1594 if (nml_bad_return (dtp
, c
))
1607 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1608 dtp
->u
.p
.item_count
);
1610 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1614 /* Parse a real number with a possible repeat count. */
1617 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1619 char message
[MSGLEN
];
1626 c
= next_char (dtp
);
1627 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1645 if (!dtp
->u
.p
.namelist_mode
)
1649 unget_char (dtp
, c
); /* Single null. */
1650 eat_separator (dtp
);
1663 /* Get the digit string that might be a repeat count. */
1667 c
= next_char (dtp
);
1668 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1694 push_char (dtp
, 'e');
1696 c
= next_char (dtp
);
1700 push_char (dtp
, '\0');
1704 if (!dtp
->u
.p
.namelist_mode
)
1709 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1710 unget_char (dtp
, c
);
1719 if (convert_integer (dtp
, -1, 0))
1722 /* Now get the number itself. */
1724 if ((c
= next_char (dtp
)) == EOF
)
1726 if (is_separator (c
))
1727 { /* Repeated null value. */
1728 unget_char (dtp
, c
);
1729 eat_separator (dtp
);
1733 if (c
!= '-' && c
!= '+')
1734 push_char (dtp
, '+');
1739 if ((c
= next_char (dtp
)) == EOF
)
1743 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1746 if (!isdigit (c
) && c
!= '.')
1748 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1767 c
= next_char (dtp
);
1768 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1777 if (!dtp
->u
.p
.namelist_mode
)
1802 push_char (dtp
, 'e');
1804 c
= next_char (dtp
);
1813 push_char (dtp
, 'e');
1815 if ((c
= next_char (dtp
)) == EOF
)
1817 if (c
!= '+' && c
!= '-')
1818 push_char (dtp
, '+');
1822 c
= next_char (dtp
);
1828 /* Extension: allow default exponent of 0 when omitted. */
1829 if (dtp
->common
.flags
& IOPARM_DT_DEFAULT_EXP
)
1831 push_char (dtp
, '0');
1842 c
= next_char (dtp
);
1851 if (!dtp
->u
.p
.namelist_mode
)
1864 unget_char (dtp
, c
);
1865 eat_separator (dtp
);
1866 push_char (dtp
, '\0');
1867 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1874 dtp
->u
.p
.saved_type
= BT_REAL
;
1878 l_push_char (dtp
, c
);
1881 /* Match INF and Infinity. */
1882 if (c
== 'i' || c
== 'I')
1884 c
= next_char (dtp
);
1885 l_push_char (dtp
, c
);
1886 if (c
!= 'n' && c
!= 'N')
1888 c
= next_char (dtp
);
1889 l_push_char (dtp
, c
);
1890 if (c
!= 'f' && c
!= 'F')
1892 c
= next_char (dtp
);
1893 l_push_char (dtp
, c
);
1894 if (!is_separator (c
) && (c
!= EOF
))
1896 if (c
!= 'i' && c
!= 'I')
1898 c
= next_char (dtp
);
1899 l_push_char (dtp
, c
);
1900 if (c
!= 'n' && c
!= 'N')
1902 c
= next_char (dtp
);
1903 l_push_char (dtp
, c
);
1904 if (c
!= 'i' && c
!= 'I')
1906 c
= next_char (dtp
);
1907 l_push_char (dtp
, c
);
1908 if (c
!= 't' && c
!= 'T')
1910 c
= next_char (dtp
);
1911 l_push_char (dtp
, c
);
1912 if (c
!= 'y' && c
!= 'Y')
1914 c
= next_char (dtp
);
1915 l_push_char (dtp
, c
);
1921 c
= next_char (dtp
);
1922 l_push_char (dtp
, c
);
1923 if (c
!= 'a' && c
!= 'A')
1925 c
= next_char (dtp
);
1926 l_push_char (dtp
, c
);
1927 if (c
!= 'n' && c
!= 'N')
1929 c
= next_char (dtp
);
1930 l_push_char (dtp
, c
);
1932 /* Match NAN(alphanum). */
1935 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1936 if (is_separator (c
))
1939 l_push_char (dtp
, c
);
1941 l_push_char (dtp
, ')');
1942 c
= next_char (dtp
);
1943 l_push_char (dtp
, c
);
1947 if (!is_separator (c
) && (c
!= EOF
))
1950 if (dtp
->u
.p
.namelist_mode
)
1952 if (c
== ' ' || c
=='\n' || c
== '\r')
1956 if ((c
= next_char (dtp
)) == EOF
)
1959 while (c
== ' ' || c
=='\n' || c
== '\r');
1961 l_push_char (dtp
, c
);
1970 push_char (dtp
, 'i');
1971 push_char (dtp
, 'n');
1972 push_char (dtp
, 'f');
1976 push_char (dtp
, 'n');
1977 push_char (dtp
, 'a');
1978 push_char (dtp
, 'n');
1982 unget_char (dtp
, c
);
1983 eat_separator (dtp
);
1984 push_char (dtp
, '\0');
1985 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1989 dtp
->u
.p
.saved_type
= BT_REAL
;
1993 if (dtp
->u
.p
.namelist_mode
)
1995 dtp
->u
.p
.nml_read_error
= 1;
1996 dtp
->u
.p
.line_buffer_enabled
= 1;
1997 dtp
->u
.p
.line_buffer_pos
= 0;
2003 if (nml_bad_return (dtp
, c
))
2018 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
2019 dtp
->u
.p
.item_count
);
2021 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2025 /* Check the current type against the saved type to make sure they are
2026 compatible. Returns nonzero if incompatible. */
2029 check_type (st_parameter_dt
*dtp
, bt type
, int kind
)
2031 char message
[MSGLEN
];
2033 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
2035 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
2036 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
2037 dtp
->u
.p
.item_count
);
2039 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2043 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
2046 if ((type
!= BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
)
2047 || (type
== BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
*2))
2049 snprintf (message
, MSGLEN
,
2050 "Read kind %d %s where kind %d is required for item %d",
2051 type
== BT_COMPLEX
? dtp
->u
.p
.saved_length
/ 2
2052 : dtp
->u
.p
.saved_length
,
2053 type_name (dtp
->u
.p
.saved_type
), kind
,
2054 dtp
->u
.p
.item_count
);
2056 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2064 /* Initialize the function pointers to select the correct versions of
2065 next_char and push_char depending on what we are doing. */
2068 set_workers (st_parameter_dt
*dtp
)
2070 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2072 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_utf8
;
2073 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char4
;
2075 else if (is_internal_unit (dtp
))
2077 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_internal
;
2078 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char_default
;
2082 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_default
;
2083 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char_default
;
2088 /* Top level data transfer subroutine for list reads. Because we have
2089 to deal with repeat counts, the data item is always saved after
2090 reading, usually in the dtp->u.p.value[] array. If a repeat count is
2091 greater than one, we copy the data item multiple times. */
2094 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
2095 int kind
, size_t size
)
2101 dtp
->u
.p
.namelist_mode
= 0;
2103 /* Set the next_char and push_char worker functions. */
2106 if (dtp
->u
.p
.first_item
)
2108 dtp
->u
.p
.first_item
= 0;
2109 dtp
->u
.p
.input_complete
= 0;
2110 dtp
->u
.p
.repeat_count
= 1;
2111 dtp
->u
.p
.at_eol
= 0;
2113 if ((c
= eat_spaces (dtp
)) == EOF
)
2118 if (is_separator (c
))
2120 /* Found a null value. */
2121 dtp
->u
.p
.repeat_count
= 0;
2122 eat_separator (dtp
);
2124 /* Set end-of-line flag. */
2125 if (c
== '\n' || c
== '\r')
2127 dtp
->u
.p
.at_eol
= 1;
2128 if (finish_separator (dtp
) == LIBERROR_END
)
2140 if (dtp
->u
.p
.repeat_count
> 0)
2142 if (check_type (dtp
, type
, kind
))
2147 if (dtp
->u
.p
.input_complete
)
2150 if (dtp
->u
.p
.at_eol
)
2151 finish_separator (dtp
);
2155 /* Trailing spaces prior to end of line. */
2156 if (dtp
->u
.p
.at_eol
)
2157 finish_separator (dtp
);
2160 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2161 dtp
->u
.p
.repeat_count
= 1;
2167 read_integer (dtp
, kind
);
2170 read_logical (dtp
, kind
);
2173 read_character (dtp
, kind
);
2176 read_real (dtp
, p
, kind
);
2177 /* Copy value back to temporary if needed. */
2178 if (dtp
->u
.p
.repeat_count
> 0)
2179 memcpy (dtp
->u
.p
.value
, p
, size
);
2182 read_complex (dtp
, p
, kind
, size
);
2183 /* Copy value back to temporary if needed. */
2184 if (dtp
->u
.p
.repeat_count
> 0)
2185 memcpy (dtp
->u
.p
.value
, p
, size
);
2189 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2190 char iotype
[] = "LISTDIRECTED";
2191 gfc_charlen_type iotype_len
= 12;
2192 char tmp_iomsg
[IOMSG_LEN
] = "";
2194 gfc_charlen_type child_iomsg_len
;
2196 int *child_iostat
= NULL
;
2199 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
2200 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2202 /* Set iostat, intent(out). */
2204 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2205 dtp
->common
.iostat
: &noiostat
;
2207 /* Set iomsge, intent(inout). */
2208 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2210 child_iomsg
= dtp
->common
.iomsg
;
2211 child_iomsg_len
= dtp
->common
.iomsg_len
;
2215 child_iomsg
= tmp_iomsg
;
2216 child_iomsg_len
= IOMSG_LEN
;
2219 /* Call the user defined formatted READ procedure. */
2220 dtp
->u
.p
.current_unit
->child_dtio
++;
2221 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
2222 child_iostat
, child_iomsg
,
2223 iotype_len
, child_iomsg_len
);
2224 dtp
->u
.p
.current_unit
->child_dtio
--;
2228 internal_error (&dtp
->common
, "Bad type for list read");
2231 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
2232 dtp
->u
.p
.saved_length
= size
;
2234 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2238 switch (dtp
->u
.p
.saved_type
)
2242 if (dtp
->u
.p
.repeat_count
> 0)
2243 memcpy (p
, dtp
->u
.p
.value
, size
);
2248 memcpy (p
, dtp
->u
.p
.value
, size
);
2252 if (dtp
->u
.p
.saved_string
)
2254 m
= ((int) size
< dtp
->u
.p
.saved_used
)
2255 ? (int) size
: dtp
->u
.p
.saved_used
;
2257 q
= (gfc_char4_t
*) p
;
2258 r
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
2259 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2260 for (i
= 0; i
< m
; i
++)
2265 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
2267 for (i
= 0; i
< m
; i
++)
2272 /* Just delimiters encountered, nothing to copy but SPACE. */
2278 memset (((char *) p
) + m
, ' ', size
- m
);
2281 q
= (gfc_char4_t
*) p
;
2282 for (i
= m
; i
< (int) size
; i
++)
2283 q
[i
] = (unsigned char) ' ';
2292 internal_error (&dtp
->common
, "Bad type for list read");
2295 if (--dtp
->u
.p
.repeat_count
<= 0)
2299 if (err
== LIBERROR_END
)
2304 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_READING
);
2310 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2311 size_t size
, size_t nelems
)
2315 size_t stride
= type
== BT_CHARACTER
?
2316 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2321 /* Big loop over all the elements. */
2322 for (elem
= 0; elem
< nelems
; elem
++)
2324 dtp
->u
.p
.item_count
++;
2325 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2333 /* Finish a list read. */
2336 finish_list_read (st_parameter_dt
*dtp
)
2340 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2342 if (dtp
->u
.p
.at_eol
)
2344 dtp
->u
.p
.at_eol
= 0;
2348 if (!is_internal_unit (dtp
))
2352 /* Set the next_char and push_char worker functions. */
2355 c
= next_char (dtp
);
2372 void namelist_read (st_parameter_dt *dtp)
2374 static void nml_match_name (char *name, int len)
2375 static int nml_query (st_parameter_dt *dtp)
2376 static int nml_get_obj_data (st_parameter_dt *dtp,
2377 namelist_info **prev_nl, char *, size_t)
2379 static void nml_untouch_nodes (st_parameter_dt *dtp)
2380 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2382 static int nml_parse_qualifier(descriptor_dimension * ad,
2383 array_loop_spec * ls, int rank, char *)
2384 static void nml_touch_nodes (namelist_info * nl)
2385 static int nml_read_obj (namelist_info *nl, index_type offset,
2386 namelist_info **prev_nl, char *, size_t,
2387 index_type clow, index_type chigh)
2391 /* Inputs a rank-dimensional qualifier, which can contain
2392 singlets, doublets, triplets or ':' with the standard meanings. */
2395 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2396 array_loop_spec
*ls
, int rank
, bt nml_elem_type
,
2397 char *parse_err_msg
, size_t parse_err_msg_size
,
2404 int is_array_section
, is_char
;
2408 is_array_section
= 0;
2409 dtp
->u
.p
.expanded_read
= 0;
2411 /* See if this is a character substring qualifier we are looking for. */
2418 /* The next character in the stream should be the '('. */
2420 if ((c
= next_char (dtp
)) == EOF
)
2423 /* Process the qualifier, by dimension and triplet. */
2425 for (dim
=0; dim
< rank
; dim
++ )
2427 for (indx
=0; indx
<3; indx
++)
2433 /* Process a potential sign. */
2434 if ((c
= next_char (dtp
)) == EOF
)
2446 unget_char (dtp
, c
);
2450 /* Process characters up to the next ':' , ',' or ')'. */
2453 c
= next_char (dtp
);
2460 is_array_section
= 1;
2464 if ((c
==',' && dim
== rank
-1)
2465 || (c
==')' && dim
< rank
-1))
2468 snprintf (parse_err_msg
, parse_err_msg_size
,
2469 "Bad substring qualifier");
2471 snprintf (parse_err_msg
, parse_err_msg_size
,
2472 "Bad number of index fields");
2481 case ' ': case '\t': case '\r': case '\n':
2487 snprintf (parse_err_msg
, parse_err_msg_size
,
2488 "Bad character in substring qualifier");
2490 snprintf (parse_err_msg
, parse_err_msg_size
,
2491 "Bad character in index");
2495 if ((c
== ',' || c
== ')') && indx
== 0
2496 && dtp
->u
.p
.saved_string
== 0)
2499 snprintf (parse_err_msg
, parse_err_msg_size
,
2500 "Null substring qualifier");
2502 snprintf (parse_err_msg
, parse_err_msg_size
,
2503 "Null index field");
2507 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2508 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2511 snprintf (parse_err_msg
, parse_err_msg_size
,
2512 "Bad substring qualifier");
2514 snprintf (parse_err_msg
, parse_err_msg_size
,
2515 "Bad index triplet");
2519 if (is_char
&& !is_array_section
)
2521 snprintf (parse_err_msg
, parse_err_msg_size
,
2522 "Missing colon in substring qualifier");
2526 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2528 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2529 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2535 /* Now read the index. */
2536 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2539 snprintf (parse_err_msg
, parse_err_msg_size
,
2540 "Bad integer substring qualifier");
2542 snprintf (parse_err_msg
, parse_err_msg_size
,
2543 "Bad integer in index");
2549 /* Feed the index values to the triplet arrays. */
2553 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2555 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2557 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2560 /* Singlet or doublet indices. */
2561 if (c
==',' || c
==')')
2565 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2567 /* If -std=f95/2003 or an array section is specified,
2568 do not allow excess data to be processed. */
2569 if (is_array_section
== 1
2570 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2571 || nml_elem_type
== BT_DERIVED
)
2572 ls
[dim
].end
= ls
[dim
].start
;
2574 dtp
->u
.p
.expanded_read
= 1;
2577 /* Check for non-zero rank. */
2578 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2585 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2588 dtp
->u
.p
.expanded_read
= 0;
2589 for (i
= 0; i
< dim
; i
++)
2590 ls
[i
].end
= ls
[i
].start
;
2593 /* Check the values of the triplet indices. */
2594 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2595 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2596 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2597 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2600 snprintf (parse_err_msg
, parse_err_msg_size
,
2601 "Substring out of range");
2603 snprintf (parse_err_msg
, parse_err_msg_size
,
2604 "Index %d out of range", dim
+ 1);
2608 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2609 || (ls
[dim
].step
== 0))
2611 snprintf (parse_err_msg
, parse_err_msg_size
,
2612 "Bad range in index %d", dim
+ 1);
2616 /* Initialise the loop index counter. */
2617 ls
[dim
].idx
= ls
[dim
].start
;
2624 /* The EOF error message is issued by hit_eof. Return true so that the
2625 caller does not use parse_err_msg and parse_err_msg_size to generate
2626 an unrelated error message. */
2630 dtp
->u
.p
.input_complete
= 1;
2638 extended_look_ahead (char *p
, char *q
)
2642 /* Scan ahead to find a '%' in the p string. */
2643 for(r
= p
, s
= q
; *r
&& *s
; s
++)
2644 if ((*s
== '%' || *s
== '+') && strcmp (r
+ 1, s
+ 1) == 0)
2651 strcmp_extended_type (char *p
, char *q
)
2655 for (r
= p
, s
= q
; *r
&& *s
; r
++, s
++)
2659 if (*r
== '%' && *s
== '+' && extended_look_ahead (r
, s
))
2668 static namelist_info
*
2669 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2671 namelist_info
* t
= dtp
->u
.p
.ionml
;
2674 if (strcmp (var_name
, t
->var_name
) == 0)
2679 if (strcmp_extended_type (var_name
, t
->var_name
))
2689 /* Visits all the components of a derived type that have
2690 not explicitly been identified in the namelist input.
2691 touched is set and the loop specification initialised
2692 to default values */
2695 nml_touch_nodes (namelist_info
* nl
)
2697 index_type len
= strlen (nl
->var_name
) + 1;
2699 char * ext_name
= xmalloc (len
+ 1);
2700 memcpy (ext_name
, nl
->var_name
, len
-1);
2701 memcpy (ext_name
+ len
- 1, "%", 2);
2702 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2704 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2707 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2709 nl
->ls
[dim
].step
= 1;
2710 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2711 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2712 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2722 /* Resets touched for the entire list of nml_nodes, ready for a
2726 nml_untouch_nodes (st_parameter_dt
*dtp
)
2729 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2734 /* Attempts to input name to namelist name. Returns
2735 dtp->u.p.nml_read_error = 1 on no match. */
2738 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2743 dtp
->u
.p
.nml_read_error
= 0;
2744 for (i
= 0; i
< len
; i
++)
2746 c
= next_char (dtp
);
2747 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2749 dtp
->u
.p
.nml_read_error
= 1;
2755 /* If the namelist read is from stdin, output the current state of the
2756 namelist to stdout. This is used to implement the non-standard query
2757 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2758 the names alone are printed. */
2761 nml_query (st_parameter_dt
*dtp
, char c
)
2763 gfc_unit
* temp_unit
;
2768 static const index_type endlen
= 2;
2769 static const char endl
[] = "\r\n";
2770 static const char nmlend
[] = "&end\r\n";
2772 static const index_type endlen
= 1;
2773 static const char endl
[] = "\n";
2774 static const char nmlend
[] = "&end\n";
2777 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2780 /* Store the current unit and transfer to stdout. */
2782 temp_unit
= dtp
->u
.p
.current_unit
;
2783 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2785 if (dtp
->u
.p
.current_unit
)
2787 dtp
->u
.p
.mode
= WRITING
;
2788 next_record (dtp
, 0);
2790 /* Write the namelist in its entirety. */
2793 namelist_write (dtp
);
2795 /* Or write the list of names. */
2799 /* "&namelist_name\n" */
2801 len
= dtp
->namelist_name_len
;
2802 p
= write_block (dtp
, len
- 1 + endlen
);
2806 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2807 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2808 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2812 len
= strlen (nl
->var_name
);
2813 p
= write_block (dtp
, len
+ endlen
);
2817 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2818 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2823 p
= write_block (dtp
, endlen
+ 4);
2826 memcpy (p
, &nmlend
, endlen
+ 4);
2829 /* Flush the stream to force immediate output. */
2831 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2832 sflush (dtp
->u
.p
.current_unit
->s
);
2833 unlock_unit (dtp
->u
.p
.current_unit
);
2838 /* Restore the current unit. */
2840 dtp
->u
.p
.current_unit
= temp_unit
;
2841 dtp
->u
.p
.mode
= READING
;
2845 /* Reads and stores the input for the namelist object nl. For an array,
2846 the function loops over the ranges defined by the loop specification.
2847 This default to all the data or to the specification from a qualifier.
2848 nml_read_obj recursively calls itself to read derived types. It visits
2849 all its own components but only reads data for those that were touched
2850 when the name was parsed. If a read error is encountered, an attempt is
2851 made to return to read a new object name because the standard allows too
2852 little data to be available. On the other hand, too much data is an
2856 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2857 namelist_info
**pprev_nl
, char *nml_err_msg
,
2858 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2860 namelist_info
* cmp
;
2867 size_t obj_name_len
;
2870 /* If we have encountered a previous read error or this object has not been
2871 touched in name parsing, just return. */
2872 if (dtp
->u
.p
.nml_read_error
|| !nl
->touched
)
2875 dtp
->u
.p
.item_count
++; /* Used in error messages. */
2876 dtp
->u
.p
.repeat_count
= 0;
2888 dlen
= size_from_real_kind (len
);
2892 dlen
= size_from_complex_kind (len
);
2896 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2905 /* Update the pointer to the data, using the current index vector */
2907 pdata
= (void*)(nl
->mem_pos
+ offset
);
2908 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2909 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2910 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2911 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2913 /* If we are finished with the repeat count, try to read next value. */
2916 if (--dtp
->u
.p
.repeat_count
<= 0)
2918 if (dtp
->u
.p
.input_complete
)
2920 if (dtp
->u
.p
.at_eol
)
2921 finish_separator (dtp
);
2922 if (dtp
->u
.p
.input_complete
)
2925 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2931 read_integer (dtp
, len
);
2935 read_logical (dtp
, len
);
2939 read_character (dtp
, len
);
2943 /* Need to copy data back from the real location to the temp in
2944 order to handle nml reads into arrays. */
2945 read_real (dtp
, pdata
, len
);
2946 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2950 /* Same as for REAL, copy back to temp. */
2951 read_complex (dtp
, pdata
, len
, dlen
);
2952 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2956 obj_name_len
= strlen (nl
->var_name
) + 1;
2957 obj_name
= xmalloc (obj_name_len
+1);
2958 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2959 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2961 /* If reading a derived type, disable the expanded read warning
2962 since a single object can have multiple reads. */
2963 dtp
->u
.p
.expanded_read
= 0;
2965 /* Now loop over the components. */
2967 for (cmp
= nl
->next
;
2969 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2972 /* Jump over nested derived type by testing if the potential
2973 component name contains '%'. */
2974 if (strchr (cmp
->var_name
+ obj_name_len
, '%'))
2977 if (!nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2978 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2985 if (dtp
->u
.p
.input_complete
)
2996 snprintf (nml_err_msg
, nml_err_msg_size
,
2997 "Bad type for namelist object %s", nl
->var_name
);
2998 internal_error (&dtp
->common
, nml_err_msg
);
3003 /* The standard permits array data to stop short of the number of
3004 elements specified in the loop specification. In this case, we
3005 should be here with dtp->u.p.nml_read_error != 0. Control returns to
3006 nml_get_obj_data and an attempt is made to read object name. */
3009 if (dtp
->u
.p
.nml_read_error
)
3011 dtp
->u
.p
.expanded_read
= 0;
3015 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
3017 dtp
->u
.p
.expanded_read
= 0;
3021 switch (dtp
->u
.p
.saved_type
)
3028 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
3032 if (dlen
< dtp
->u
.p
.saved_used
)
3034 if (compile_options
.bounds_check
)
3036 snprintf (nml_err_msg
, nml_err_msg_size
,
3037 "Namelist object '%s' truncated on read.",
3039 generate_warning (&dtp
->common
, nml_err_msg
);
3044 m
= dtp
->u
.p
.saved_used
;
3046 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
3048 gfc_char4_t
*q4
, *p4
= pdata
;
3051 q4
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
3053 for (i
= 0; i
< m
; i
++)
3056 for (i
= 0; i
< dlen
- m
; i
++)
3057 *p4
++ = (gfc_char4_t
) ' ';
3061 pdata
= (void*)( pdata
+ clow
- 1 );
3062 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
3064 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
3072 /* Warn if a non-standard expanded read occurs. A single read of a
3073 single object is acceptable. If a second read occurs, issue a warning
3074 and set the flag to zero to prevent further warnings. */
3075 if (dtp
->u
.p
.expanded_read
== 2)
3077 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
3078 dtp
->u
.p
.expanded_read
= 0;
3081 /* If the expanded read warning flag is set, increment it,
3082 indicating that a single read has occurred. */
3083 if (dtp
->u
.p
.expanded_read
>= 1)
3084 dtp
->u
.p
.expanded_read
++;
3086 /* Break out of loop if scalar. */
3090 /* Now increment the index vector. */
3095 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
3097 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
3099 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
3101 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
3103 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
3107 } while (!nml_carry
);
3109 if (dtp
->u
.p
.repeat_count
> 1)
3111 snprintf (nml_err_msg
, nml_err_msg_size
,
3112 "Repeat count too large for namelist object %s", nl
->var_name
);
3122 /* Parses the object name, including array and substring qualifiers. It
3123 iterates over derived type components, touching those components and
3124 setting their loop specifications, if there is a qualifier. If the
3125 object is itself a derived type, its components and subcomponents are
3126 touched. nml_read_obj is called at the end and this reads the data in
3127 the manner specified by the object name. */
3130 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
3131 char *nml_err_msg
, size_t nml_err_msg_size
)
3135 namelist_info
* first_nl
= NULL
;
3136 namelist_info
* root_nl
= NULL
;
3137 int dim
, parsed_rank
;
3138 int component_flag
, qualifier_flag
;
3139 index_type clow
, chigh
;
3140 int non_zero_rank_count
;
3142 /* Look for end of input or object name. If '?' or '=?' are encountered
3143 in stdin, print the node names or the namelist to stdout. */
3145 eat_separator (dtp
);
3146 if (dtp
->u
.p
.input_complete
)
3149 if (dtp
->u
.p
.at_eol
)
3150 finish_separator (dtp
);
3151 if (dtp
->u
.p
.input_complete
)
3154 if ((c
= next_char (dtp
)) == EOF
)
3159 if ((c
= next_char (dtp
)) == EOF
)
3163 snprintf (nml_err_msg
, nml_err_msg_size
,
3164 "namelist read: misplaced = sign");
3167 nml_query (dtp
, '=');
3171 nml_query (dtp
, '?');
3176 nml_match_name (dtp
, "end", 3);
3177 if (dtp
->u
.p
.nml_read_error
)
3179 snprintf (nml_err_msg
, nml_err_msg_size
,
3180 "namelist not terminated with / or &end");
3185 dtp
->u
.p
.input_complete
= 1;
3192 /* Untouch all nodes of the namelist and reset the flags that are set for
3193 derived type components. */
3195 nml_untouch_nodes (dtp
);
3198 non_zero_rank_count
= 0;
3200 /* Get the object name - should '!' and '\n' be permitted separators? */
3208 if (!is_separator (c
))
3209 push_char_default (dtp
, tolower(c
));
3210 if ((c
= next_char (dtp
)) == EOF
)
3213 while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
3215 unget_char (dtp
, c
);
3217 /* Check that the name is in the namelist and get pointer to object.
3218 Three error conditions exist: (i) An attempt is being made to
3219 identify a non-existent object, following a failed data read or
3220 (ii) The object name does not exist or (iii) Too many data items
3221 are present for an object. (iii) gives the same error message
3224 push_char_default (dtp
, '\0');
3228 #define EXT_STACK_SZ 100
3229 char ext_stack
[EXT_STACK_SZ
];
3231 size_t var_len
= strlen (root_nl
->var_name
);
3233 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
3234 size_t ext_size
= var_len
+ saved_len
+ 1;
3236 if (ext_size
> EXT_STACK_SZ
)
3237 ext_name
= xmalloc (ext_size
);
3239 ext_name
= ext_stack
;
3241 memcpy (ext_name
, root_nl
->var_name
, var_len
);
3242 if (dtp
->u
.p
.saved_string
)
3243 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
3244 ext_name
[var_len
+ saved_len
] = '\0';
3245 nl
= find_nml_node (dtp
, ext_name
);
3247 if (ext_size
> EXT_STACK_SZ
)
3251 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
3255 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
3256 snprintf (nml_err_msg
, nml_err_msg_size
,
3257 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
3260 snprintf (nml_err_msg
, nml_err_msg_size
,
3261 "Cannot match namelist object name %s",
3262 dtp
->u
.p
.saved_string
);
3266 else if (nl
->dtio_sub
!= NULL
)
3268 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
3269 char iotype
[] = "NAMELIST";
3270 gfc_charlen_type iotype_len
= 8;
3271 char tmp_iomsg
[IOMSG_LEN
] = "";
3273 gfc_charlen_type child_iomsg_len
;
3275 int *child_iostat
= NULL
;
3278 formatted_dtio dtio_ptr
= (formatted_dtio
)nl
->dtio_sub
;
3280 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
3281 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
3283 list_obj
.data
= (void *)nl
->mem_pos
;
3284 list_obj
.vptr
= nl
->vtable
;
3287 /* Set iostat, intent(out). */
3289 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
3290 dtp
->common
.iostat
: &noiostat
;
3292 /* Set iomsg, intent(inout). */
3293 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
3295 child_iomsg
= dtp
->common
.iomsg
;
3296 child_iomsg_len
= dtp
->common
.iomsg_len
;
3300 child_iomsg
= tmp_iomsg
;
3301 child_iomsg_len
= IOMSG_LEN
;
3304 /* Call the user defined formatted READ procedure. */
3305 dtp
->u
.p
.current_unit
->child_dtio
++;
3306 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
3307 child_iostat
, child_iomsg
,
3308 iotype_len
, child_iomsg_len
);
3309 dtp
->u
.p
.current_unit
->child_dtio
--;
3314 /* Get the length, data length, base pointer and rank of the variable.
3315 Set the default loop specification first. */
3317 for (dim
=0; dim
< nl
->var_rank
; dim
++)
3319 nl
->ls
[dim
].step
= 1;
3320 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
3321 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
3322 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
3325 /* Check to see if there is a qualifier: if so, parse it.*/
3327 if (c
== '(' && nl
->var_rank
)
3330 if (!nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
3331 nl
->type
, nml_err_msg
, nml_err_msg_size
,
3334 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
3335 snprintf (nml_err_msg_end
,
3336 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
3337 " for namelist variable %s", nl
->var_name
);
3340 if (parsed_rank
> 0)
3341 non_zero_rank_count
++;
3345 if ((c
= next_char (dtp
)) == EOF
)
3347 unget_char (dtp
, c
);
3349 else if (nl
->var_rank
> 0)
3350 non_zero_rank_count
++;
3352 /* Now parse a derived type component. The root namelist_info address
3353 is backed up, as is the previous component level. The component flag
3354 is set and the iteration is made by jumping back to get_name. */
3358 if (nl
->type
!= BT_DERIVED
)
3360 snprintf (nml_err_msg
, nml_err_msg_size
,
3361 "Attempt to get derived component for %s", nl
->var_name
);
3365 /* Don't move first_nl further in the list if a qualifier was found. */
3366 if ((*pprev_nl
== NULL
&& !qualifier_flag
) || !component_flag
)
3372 if ((c
= next_char (dtp
)) == EOF
)
3377 /* Parse a character qualifier, if present. chigh = 0 is a default
3378 that signals that the string length = string_length. */
3383 if (c
== '(' && nl
->type
== BT_CHARACTER
)
3385 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
3386 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
3388 if (!nml_parse_qualifier (dtp
, chd
, ind
, -1, nl
->type
,
3389 nml_err_msg
, nml_err_msg_size
, &parsed_rank
))
3391 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
3392 snprintf (nml_err_msg_end
,
3393 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
3394 " for namelist variable %s", nl
->var_name
);
3398 clow
= ind
[0].start
;
3401 if (ind
[0].step
!= 1)
3403 snprintf (nml_err_msg
, nml_err_msg_size
,
3404 "Step not allowed in substring qualifier"
3405 " for namelist object %s", nl
->var_name
);
3409 if ((c
= next_char (dtp
)) == EOF
)
3411 unget_char (dtp
, c
);
3414 /* Make sure no extraneous qualifiers are there. */
3418 snprintf (nml_err_msg
, nml_err_msg_size
,
3419 "Qualifier for a scalar or non-character namelist object %s",
3424 /* Make sure there is no more than one non-zero rank object. */
3425 if (non_zero_rank_count
> 1)
3427 snprintf (nml_err_msg
, nml_err_msg_size
,
3428 "Multiple sub-objects with non-zero rank in namelist object %s",
3430 non_zero_rank_count
= 0;
3434 /* According to the standard, an equal sign MUST follow an object name. The
3435 following is possibly lax - it allows comments, blank lines and so on to
3436 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
3440 eat_separator (dtp
);
3441 if (dtp
->u
.p
.input_complete
)
3444 if (dtp
->u
.p
.at_eol
)
3445 finish_separator (dtp
);
3446 if (dtp
->u
.p
.input_complete
)
3449 if ((c
= next_char (dtp
)) == EOF
)
3454 snprintf (nml_err_msg
, nml_err_msg_size
,
3455 "Equal sign must follow namelist object name %s",
3459 /* If a derived type, touch its components and restore the root
3460 namelist_info if we have parsed a qualified derived type
3463 if (nl
->type
== BT_DERIVED
)
3464 nml_touch_nodes (nl
);
3468 if (first_nl
->var_rank
== 0)
3470 if (component_flag
&& qualifier_flag
)
3477 dtp
->u
.p
.nml_read_error
= 0;
3478 if (!nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3486 /* The EOF error message is issued by hit_eof. Return true so that the
3487 caller does not use nml_err_msg and nml_err_msg_size to generate
3488 an unrelated error message. */
3491 dtp
->u
.p
.input_complete
= 1;
3492 unget_char (dtp
, c
);
3499 /* Entry point for namelist input. Goes through input until namelist name
3500 is matched. Then cycles through nml_get_obj_data until the input is
3501 completed or there is an error. */
3504 namelist_read (st_parameter_dt
*dtp
)
3507 char nml_err_msg
[200];
3509 /* Initialize the error string buffer just in case we get an unexpected fail
3510 somewhere and end up at nml_err_ret. */
3511 strcpy (nml_err_msg
, "Internal namelist read error");
3513 /* Pointer to the previously read object, in case attempt is made to read
3514 new object name. Should this fail, error message can give previous
3516 namelist_info
*prev_nl
= NULL
;
3518 dtp
->u
.p
.namelist_mode
= 1;
3519 dtp
->u
.p
.input_complete
= 0;
3520 dtp
->u
.p
.expanded_read
= 0;
3522 /* Set the next_char and push_char worker functions. */
3525 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3526 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3527 node names or namelist on stdout. */
3530 c
= next_char (dtp
);
3542 c
= next_char (dtp
);
3544 nml_query (dtp
, '=');
3546 unget_char (dtp
, c
);
3550 nml_query (dtp
, '?');
3560 /* Match the name of the namelist. */
3562 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3564 if (dtp
->u
.p
.nml_read_error
)
3567 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3568 c
= next_char (dtp
);
3569 if (!is_separator(c
) && c
!= '!')
3571 unget_char (dtp
, c
);
3575 unget_char (dtp
, c
);
3576 eat_separator (dtp
);
3578 /* Ready to read namelist objects. If there is an error in input
3579 from stdin, output the error message and continue. */
3581 while (!dtp
->u
.p
.input_complete
)
3583 if (!nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
))
3585 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3587 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3590 /* Reset the previous namelist pointer if we know we are not going
3591 to be doing multiple reads within a single namelist object. */
3592 if (prev_nl
&& prev_nl
->var_rank
== 0)
3603 /* All namelist error calls return from here */
3606 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);