1 /* Copyright (C) 2002-2016 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/>. */
35 typedef unsigned char uchar
;
38 /* List directed input. Several parsing subroutines are practically
39 reimplemented from formatted input, the reason being that there are
40 all kinds of small differences between formatted and list directed
44 /* Subroutines for reading characters from the input. Because a
45 repeat count is ambiguous with an integer, we have to read the
46 whole digit string before seeing if there is a '*' which signals
47 the repeat count. Since we can have a lot of potential leading
48 zeros, we have to be able to back up by arbitrary amount. Because
49 the input might not be seekable, we have to buffer the data
52 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
53 case '5': case '6': case '7': case '8': case '9'
55 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': \
56 case '\t': case '\r': case ';'
58 /* This macro assumes that we're operating on a variable. */
60 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
61 || c == '\t' || c == '\r' || c == ';' || \
62 (dtp->u.p.namelist_mode && c == '!'))
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
72 /* Wrappers for calling the current worker functions. */
74 #define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
75 #define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c))
77 /* Worker function to save a default KIND=1 character to a string
78 buffer, enlarging it as necessary. */
81 push_char_default (st_parameter_dt
*dtp
, int c
)
85 if (dtp
->u
.p
.saved_string
== NULL
)
87 // Plain malloc should suffice here, zeroing not needed?
88 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, 1);
89 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
90 dtp
->u
.p
.saved_used
= 0;
93 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
95 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
96 dtp
->u
.p
.saved_string
=
97 xrealloc (dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_length
);
100 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = (char) c
;
104 /* Worker function to save a KIND=4 character to a string buffer,
105 enlarging the buffer as necessary. */
107 push_char4 (st_parameter_dt
*dtp
, int c
)
109 gfc_char4_t
*p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
113 dtp
->u
.p
.saved_string
= xcalloc (SCRATCH_SIZE
, sizeof (gfc_char4_t
));
114 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
115 dtp
->u
.p
.saved_used
= 0;
116 p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
119 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
121 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
122 dtp
->u
.p
.saved_string
=
123 xrealloc (dtp
->u
.p
.saved_string
,
124 dtp
->u
.p
.saved_length
* sizeof (gfc_char4_t
));
125 p
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
128 p
[dtp
->u
.p
.saved_used
++] = c
;
132 /* Free the input buffer if necessary. */
135 free_saved (st_parameter_dt
*dtp
)
137 if (dtp
->u
.p
.saved_string
== NULL
)
140 free (dtp
->u
.p
.saved_string
);
142 dtp
->u
.p
.saved_string
= NULL
;
143 dtp
->u
.p
.saved_used
= 0;
147 /* Free the line buffer if necessary. */
150 free_line (st_parameter_dt
*dtp
)
152 dtp
->u
.p
.line_buffer_pos
= 0;
153 dtp
->u
.p
.line_buffer_enabled
= 0;
155 if (dtp
->u
.p
.line_buffer
== NULL
)
158 free (dtp
->u
.p
.line_buffer
);
159 dtp
->u
.p
.line_buffer
= NULL
;
163 /* Unget saves the last character so when reading the next character,
164 we need to check to see if there is a character waiting. Similar,
165 if the line buffer is being used to read_logical, check it too. */
168 check_buffers (st_parameter_dt
*dtp
)
173 if (dtp
->u
.p
.last_char
!= EOF
- 1)
176 c
= dtp
->u
.p
.last_char
;
177 dtp
->u
.p
.last_char
= EOF
- 1;
181 /* Read from line_buffer if enabled. */
183 if (dtp
->u
.p
.line_buffer_enabled
)
187 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
];
188 if (c
!= '\0' && dtp
->u
.p
.line_buffer_pos
< 64)
190 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
] = '\0';
191 dtp
->u
.p
.line_buffer_pos
++;
195 dtp
->u
.p
.line_buffer_pos
= 0;
196 dtp
->u
.p
.line_buffer_enabled
= 0;
200 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
205 /* Worker function for default character encoded file. */
207 next_char_default (st_parameter_dt
*dtp
)
211 /* Always check the unget and line buffer first. */
212 if ((c
= check_buffers (dtp
)))
215 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
216 if (c
!= EOF
&& is_stream_io (dtp
))
217 dtp
->u
.p
.current_unit
->strm_pos
++;
219 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
224 /* Worker function for internal and array I/O units. */
226 next_char_internal (st_parameter_dt
*dtp
)
232 /* Always check the unget and line buffer first. */
233 if ((c
= check_buffers (dtp
)))
236 /* Handle the end-of-record and end-of-file conditions for
237 internal array unit. */
238 if (is_array_io (dtp
))
243 /* Check for "end-of-record" condition. */
244 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
249 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
252 /* Check for "end-of-file" condition. */
259 record
*= dtp
->u
.p
.current_unit
->recl
;
260 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
263 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
268 /* Get the next character and handle end-of-record conditions. */
270 if (dtp
->common
.unit
) /* Check for kind=4 internal unit. */
271 length
= sread (dtp
->u
.p
.current_unit
->s
, &c
, 1);
275 length
= sread (dtp
->u
.p
.current_unit
->s
, &cc
, 1);
279 if (unlikely (length
< 0))
281 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
285 if (is_array_io (dtp
))
287 /* Check whether we hit EOF. */
288 if (unlikely (length
== 0))
290 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
293 dtp
->u
.p
.current_unit
->bytes_left
--;
307 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== EOF
);
312 /* Worker function for UTF encoded files. */
314 next_char_utf8 (st_parameter_dt
*dtp
)
316 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
317 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
321 /* Always check the unget and line buffer first. */
322 if (!(c
= check_buffers (dtp
)))
323 c
= fbuf_getc (dtp
->u
.p
.current_unit
);
328 /* The number of leading 1-bits in the first byte indicates how many
330 for (nb
= 2; nb
< 7; nb
++)
331 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
336 c
= (c
& masks
[nb
-1]);
338 /* Decode the bytes read. */
339 for (i
= 1; i
< nb
; i
++)
341 gfc_char4_t n
= fbuf_getc (dtp
->u
.p
.current_unit
);
342 if ((n
& 0xC0) != 0x80)
344 c
= ((c
<< 6) + (n
& 0x3F));
347 /* Make sure the shortest possible encoding was used. */
348 if (c
<= 0x7F && nb
> 1) goto invalid
;
349 if (c
<= 0x7FF && nb
> 2) goto invalid
;
350 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
351 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
352 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
354 /* Make sure the character is valid. */
355 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
359 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== (gfc_char4_t
) EOF
);
363 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
364 return (gfc_char4_t
) '?';
367 /* Push a character back onto the input. */
370 unget_char (st_parameter_dt
*dtp
, int c
)
372 dtp
->u
.p
.last_char
= c
;
376 /* Skip over spaces in the input. Returns the nonspace character that
377 terminated the eating and also places it back on the input. */
380 eat_spaces (st_parameter_dt
*dtp
)
384 /* If internal character array IO, peak ahead and seek past spaces.
385 This is an optimization unique to character arrays with large
386 character lengths (PR38199). This code eliminates numerous calls
387 to next_character. */
388 if (is_array_io (dtp
) && (dtp
->u
.p
.last_char
== EOF
- 1))
390 gfc_offset offset
= stell (dtp
->u
.p
.current_unit
->s
);
393 if (dtp
->common
.unit
) /* kind=4 */
395 for (i
= 0; i
< dtp
->u
.p
.current_unit
->bytes_left
; i
++)
397 if (dtp
->internal_unit
[(offset
+ i
) * sizeof (gfc_char4_t
)]
404 for (i
= 0; i
< dtp
->u
.p
.current_unit
->bytes_left
; i
++)
406 if (dtp
->internal_unit
[offset
+ i
] != ' ')
413 sseek (dtp
->u
.p
.current_unit
->s
, offset
+ i
, SEEK_SET
);
414 dtp
->u
.p
.current_unit
->bytes_left
-= i
;
418 /* Now skip spaces, EOF and EOL are handled in next_char. */
421 while (c
!= EOF
&& (c
== ' ' || c
== '\t'));
428 /* This function reads characters through to the end of the current
429 line and just ignores them. Returns 0 for success and LIBERROR_END
433 eat_line (st_parameter_dt
*dtp
)
439 while (c
!= EOF
&& c
!= '\n');
446 /* Skip over a separator. Technically, we don't always eat the whole
447 separator. This is because if we've processed the last input item,
448 then a separator is unnecessary. Plus the fact that operating
449 systems usually deliver console input on a line basis.
451 The upshot is that if we see a newline as part of reading a
452 separator, we stop reading. If there are more input items, we
453 continue reading the separator with finish_separator() which takes
454 care of the fact that we may or may not have seen a comma as part
457 Returns 0 for success, and non-zero error code otherwise. */
460 eat_separator (st_parameter_dt
*dtp
)
466 dtp
->u
.p
.comma_flag
= 0;
468 if ((c
= next_char (dtp
)) == EOF
)
473 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
480 dtp
->u
.p
.comma_flag
= 1;
485 dtp
->u
.p
.input_complete
= 1;
489 if ((n
= next_char(dtp
)) == EOF
)
499 if (dtp
->u
.p
.namelist_mode
)
503 if ((c
= next_char (dtp
)) == EOF
)
507 err
= eat_line (dtp
);
513 while (c
== '\n' || c
== '\r' || c
== ' ' || c
== '\t');
519 /* Eat a namelist comment. */
520 if (dtp
->u
.p
.namelist_mode
)
522 err
= eat_line (dtp
);
529 /* Fall Through... */
539 /* Finish processing a separator that was interrupted by a newline.
540 If we're here, then another data item is present, so we finish what
541 we started on the previous line. Return 0 on success, error code
545 finish_separator (st_parameter_dt
*dtp
)
548 int err
= LIBERROR_OK
;
553 if ((c
= next_char (dtp
)) == EOF
)
558 if (dtp
->u
.p
.comma_flag
)
562 if ((c
= eat_spaces (dtp
)) == EOF
)
564 if (c
== '\n' || c
== '\r')
571 dtp
->u
.p
.input_complete
= 1;
572 if (!dtp
->u
.p
.namelist_mode
)
581 if (dtp
->u
.p
.namelist_mode
)
583 err
= eat_line (dtp
);
597 /* This function is needed to catch bad conversions so that namelist can
598 attempt to see if dtp->u.p.saved_string contains a new object name rather
602 nml_bad_return (st_parameter_dt
*dtp
, char c
)
604 if (dtp
->u
.p
.namelist_mode
)
606 dtp
->u
.p
.nml_read_error
= 1;
613 /* Convert an unsigned string to an integer. The length value is -1
614 if we are working on a repeat count. Returns nonzero if we have a
615 range problem. As a side effect, frees the dtp->u.p.saved_string. */
618 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
620 char c
, *buffer
, message
[MSGLEN
];
622 GFC_UINTEGER_LARGEST v
, max
, max10
;
623 GFC_INTEGER_LARGEST value
;
625 buffer
= dtp
->u
.p
.saved_string
;
632 max
= si_max (length
);
662 set_integer (dtp
->u
.p
.value
, value
, length
);
666 dtp
->u
.p
.repeat_count
= v
;
668 if (dtp
->u
.p
.repeat_count
== 0)
670 snprintf (message
, MSGLEN
, "Zero repeat count in item %d of list input",
671 dtp
->u
.p
.item_count
);
673 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
683 snprintf (message
, MSGLEN
, "Repeat count overflow in item %d of list input",
684 dtp
->u
.p
.item_count
);
686 snprintf (message
, MSGLEN
, "Integer overflow while reading item %d",
687 dtp
->u
.p
.item_count
);
690 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
696 /* Parse a repeat count for logical and complex values which cannot
697 begin with a digit. Returns nonzero if we are done, zero if we
698 should continue on. */
701 parse_repeat (st_parameter_dt
*dtp
)
703 char message
[MSGLEN
];
706 if ((c
= next_char (dtp
)) == EOF
)
730 repeat
= 10 * repeat
+ c
- '0';
732 if (repeat
> MAX_REPEAT
)
734 snprintf (message
, MSGLEN
,
735 "Repeat count overflow in item %d of list input",
736 dtp
->u
.p
.item_count
);
738 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
747 snprintf (message
, MSGLEN
,
748 "Zero repeat count in item %d of list input",
749 dtp
->u
.p
.item_count
);
751 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
763 dtp
->u
.p
.repeat_count
= repeat
;
777 snprintf (message
, MSGLEN
, "Bad repeat count in item %d of list input",
778 dtp
->u
.p
.item_count
);
779 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
784 /* To read a logical we have to look ahead in the input stream to make sure
785 there is not an equal sign indicating a variable name. To do this we use
786 line_buffer to point to a temporary buffer, pushing characters there for
787 possible later reading. */
790 l_push_char (st_parameter_dt
*dtp
, char c
)
792 if (dtp
->u
.p
.line_buffer
== NULL
)
793 dtp
->u
.p
.line_buffer
= xcalloc (SCRATCH_SIZE
, 1);
795 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.line_buffer_pos
++] = c
;
799 /* Read a logical character on the input. */
802 read_logical (st_parameter_dt
*dtp
, int length
)
804 char message
[MSGLEN
];
807 if (parse_repeat (dtp
))
810 c
= tolower (next_char (dtp
));
811 l_push_char (dtp
, c
);
817 l_push_char (dtp
, c
);
819 if (!is_separator(c
) && c
!= EOF
)
827 l_push_char (dtp
, c
);
829 if (!is_separator(c
) && c
!= EOF
)
836 c
= tolower (next_char (dtp
));
852 if (!dtp
->u
.p
.namelist_mode
)
859 return; /* Null value. */
862 /* Save the character in case it is the beginning
863 of the next object name. */
868 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
869 dtp
->u
.p
.saved_length
= length
;
871 /* Eat trailing garbage. */
874 while (c
!= EOF
&& !is_separator (c
));
878 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
885 for(i
= 0; i
< 63; i
++)
890 /* All done if this is not a namelist read. */
891 if (!dtp
->u
.p
.namelist_mode
)
904 l_push_char (dtp
, c
);
907 dtp
->u
.p
.nml_read_error
= 1;
908 dtp
->u
.p
.line_buffer_enabled
= 1;
909 dtp
->u
.p
.line_buffer_pos
= 0;
917 if (nml_bad_return (dtp
, c
))
933 snprintf (message
, MSGLEN
, "Bad logical value while reading item %d",
934 dtp
->u
.p
.item_count
);
936 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
941 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
942 dtp
->u
.p
.saved_length
= length
;
943 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
949 /* Reading integers is tricky because we can actually be reading a
950 repeat count. We have to store the characters in a buffer because
951 we could be reading an integer that is larger than the default int
952 used for repeat counts. */
955 read_integer (st_parameter_dt
*dtp
, int length
)
957 char message
[MSGLEN
];
967 /* Fall through... */
970 if ((c
= next_char (dtp
)) == EOF
)
975 if (!dtp
->u
.p
.namelist_mode
)
978 CASE_SEPARATORS
: /* Single null. */
991 /* Take care of what may be a repeat count. */
1003 push_char (dtp
, '\0');
1007 if (!dtp
->u
.p
.namelist_mode
)
1010 CASE_SEPARATORS
: /* Not a repeat count. */
1020 if (convert_integer (dtp
, -1, 0))
1023 /* Get the real integer. */
1025 if ((c
= next_char (dtp
)) == EOF
)
1033 if (!dtp
->u
.p
.namelist_mode
)
1037 unget_char (dtp
, c
);
1038 eat_separator (dtp
);
1043 /* Fall through... */
1046 c
= next_char (dtp
);
1057 c
= next_char (dtp
);
1065 if (!dtp
->u
.p
.namelist_mode
)
1079 if (nml_bad_return (dtp
, c
))
1092 snprintf (message
, MSGLEN
, "Bad integer for item %d in list input",
1093 dtp
->u
.p
.item_count
);
1095 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1100 unget_char (dtp
, c
);
1101 eat_separator (dtp
);
1103 push_char (dtp
, '\0');
1104 if (convert_integer (dtp
, length
, negative
))
1111 dtp
->u
.p
.saved_type
= BT_INTEGER
;
1115 /* Read a character variable. */
1118 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
1120 char quote
, message
[MSGLEN
];
1123 quote
= ' '; /* Space means no quote character. */
1125 if ((c
= next_char (dtp
)) == EOF
)
1135 unget_char (dtp
, c
); /* NULL value. */
1136 eat_separator (dtp
);
1145 if (dtp
->u
.p
.namelist_mode
)
1147 unget_char (dtp
, c
);
1154 /* Deal with a possible repeat count. */
1158 c
= next_char (dtp
);
1167 unget_char (dtp
, c
);
1168 goto done
; /* String was only digits! */
1171 push_char (dtp
, '\0');
1176 goto get_string
; /* Not a repeat count after all. */
1181 if (convert_integer (dtp
, -1, 0))
1184 /* Now get the real string. */
1186 if ((c
= next_char (dtp
)) == EOF
)
1191 unget_char (dtp
, c
); /* Repeated NULL values. */
1192 eat_separator (dtp
);
1209 if ((c
= next_char (dtp
)) == EOF
)
1221 /* See if we have a doubled quote character or the end of
1224 if ((c
= next_char (dtp
)) == EOF
)
1228 push_char (dtp
, quote
);
1232 unget_char (dtp
, c
);
1238 unget_char (dtp
, c
);
1242 if (c
!= '\n' && c
!= '\r')
1252 /* At this point, we have to have a separator, or else the string is
1255 c
= next_char (dtp
);
1257 if (is_separator (c
) || c
== EOF
)
1259 unget_char (dtp
, c
);
1260 eat_separator (dtp
);
1261 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1266 snprintf (message
, MSGLEN
, "Invalid string input in item %d",
1267 dtp
->u
.p
.item_count
);
1268 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1280 /* Parse a component of a complex constant or a real number that we
1281 are sure is already there. This is a straight real number parser. */
1284 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1286 char message
[MSGLEN
];
1289 if ((c
= next_char (dtp
)) == EOF
)
1292 if (c
== '-' || c
== '+')
1295 if ((c
= next_char (dtp
)) == EOF
)
1299 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1302 if (!isdigit (c
) && c
!= '.')
1304 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1312 seen_dp
= (c
== '.') ? 1 : 0;
1316 if ((c
= next_char (dtp
)) == EOF
)
1318 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1340 push_char (dtp
, 'e');
1345 push_char (dtp
, 'e');
1347 if ((c
= next_char (dtp
)) == EOF
)
1352 if (!dtp
->u
.p
.namelist_mode
)
1365 if ((c
= next_char (dtp
)) == EOF
)
1367 if (c
!= '-' && c
!= '+')
1368 push_char (dtp
, '+');
1372 c
= next_char (dtp
);
1383 if ((c
= next_char (dtp
)) == EOF
)
1392 if (!dtp
->u
.p
.namelist_mode
)
1397 unget_char (dtp
, c
);
1406 unget_char (dtp
, c
);
1407 push_char (dtp
, '\0');
1409 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1415 unget_char (dtp
, c
);
1416 push_char (dtp
, '\0');
1418 m
= convert_infnan (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1424 /* Match INF and Infinity. */
1425 if ((c
== 'i' || c
== 'I')
1426 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1427 && ((c
= next_char (dtp
)) == 'f' || c
== 'F'))
1429 c
= next_char (dtp
);
1430 if ((c
!= 'i' && c
!= 'I')
1431 || ((c
== 'i' || c
== 'I')
1432 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1433 && ((c
= next_char (dtp
)) == 'i' || c
== 'I')
1434 && ((c
= next_char (dtp
)) == 't' || c
== 'T')
1435 && ((c
= next_char (dtp
)) == 'y' || c
== 'Y')
1436 && (c
= next_char (dtp
))))
1438 if (is_separator (c
) || (c
== EOF
))
1439 unget_char (dtp
, c
);
1440 push_char (dtp
, 'i');
1441 push_char (dtp
, 'n');
1442 push_char (dtp
, 'f');
1446 else if (((c
= next_char (dtp
)) == 'a' || c
== 'A')
1447 && ((c
= next_char (dtp
)) == 'n' || c
== 'N')
1448 && (c
= next_char (dtp
)))
1450 if (is_separator (c
) || (c
== EOF
))
1451 unget_char (dtp
, c
);
1452 push_char (dtp
, 'n');
1453 push_char (dtp
, 'a');
1454 push_char (dtp
, 'n');
1456 /* Match "NAN(alphanum)". */
1459 for ( ; c
!= ')'; c
= next_char (dtp
))
1460 if (is_separator (c
))
1463 c
= next_char (dtp
);
1464 if (is_separator (c
) || (c
== EOF
))
1465 unget_char (dtp
, c
);
1472 if (nml_bad_return (dtp
, c
))
1485 snprintf (message
, MSGLEN
, "Bad floating point number for item %d",
1486 dtp
->u
.p
.item_count
);
1488 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1494 /* Reading a complex number is straightforward because we can tell
1495 what it is right away. */
1498 read_complex (st_parameter_dt
*dtp
, void * dest
, int kind
, size_t size
)
1500 char message
[MSGLEN
];
1503 if (parse_repeat (dtp
))
1506 c
= next_char (dtp
);
1513 if (!dtp
->u
.p
.namelist_mode
)
1518 unget_char (dtp
, c
);
1519 eat_separator (dtp
);
1528 c
= next_char (dtp
);
1529 if (c
== '\n' || c
== '\r')
1532 unget_char (dtp
, c
);
1534 if (parse_real (dtp
, dest
, kind
))
1539 c
= next_char (dtp
);
1540 if (c
== '\n' || c
== '\r')
1543 unget_char (dtp
, c
);
1546 != (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';'))
1551 c
= next_char (dtp
);
1552 if (c
== '\n' || c
== '\r')
1555 unget_char (dtp
, c
);
1557 if (parse_real (dtp
, dest
+ size
/ 2, kind
))
1562 c
= next_char (dtp
);
1563 if (c
== '\n' || c
== '\r')
1566 unget_char (dtp
, c
);
1568 if (next_char (dtp
) != ')')
1571 c
= next_char (dtp
);
1572 if (!is_separator (c
) && (c
!= EOF
))
1575 unget_char (dtp
, c
);
1576 eat_separator (dtp
);
1579 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1584 if (nml_bad_return (dtp
, c
))
1597 snprintf (message
, MSGLEN
, "Bad complex value in item %d of list input",
1598 dtp
->u
.p
.item_count
);
1600 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1604 /* Parse a real number with a possible repeat count. */
1607 read_real (st_parameter_dt
*dtp
, void * dest
, int length
)
1609 char message
[MSGLEN
];
1616 c
= next_char (dtp
);
1617 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1635 if (!dtp
->u
.p
.namelist_mode
)
1639 unget_char (dtp
, c
); /* Single null. */
1640 eat_separator (dtp
);
1653 /* Get the digit string that might be a repeat count. */
1657 c
= next_char (dtp
);
1658 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1684 push_char (dtp
, 'e');
1686 c
= next_char (dtp
);
1690 push_char (dtp
, '\0');
1694 if (!dtp
->u
.p
.namelist_mode
)
1699 if (c
!= '\n' && c
!= ',' && c
!= '\r' && c
!= ';')
1700 unget_char (dtp
, c
);
1709 if (convert_integer (dtp
, -1, 0))
1712 /* Now get the number itself. */
1714 if ((c
= next_char (dtp
)) == EOF
)
1716 if (is_separator (c
))
1717 { /* Repeated null value. */
1718 unget_char (dtp
, c
);
1719 eat_separator (dtp
);
1723 if (c
!= '-' && c
!= '+')
1724 push_char (dtp
, '+');
1729 if ((c
= next_char (dtp
)) == EOF
)
1733 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1736 if (!isdigit (c
) && c
!= '.')
1738 if (c
== 'i' || c
== 'I' || c
== 'n' || c
== 'N')
1757 c
= next_char (dtp
);
1758 if (c
== ',' && dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
)
1767 if (!dtp
->u
.p
.namelist_mode
)
1792 push_char (dtp
, 'e');
1794 c
= next_char (dtp
);
1803 push_char (dtp
, 'e');
1805 if ((c
= next_char (dtp
)) == EOF
)
1807 if (c
!= '+' && c
!= '-')
1808 push_char (dtp
, '+');
1812 c
= next_char (dtp
);
1822 c
= next_char (dtp
);
1831 if (!dtp
->u
.p
.namelist_mode
)
1844 unget_char (dtp
, c
);
1845 eat_separator (dtp
);
1846 push_char (dtp
, '\0');
1847 if (convert_real (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1854 dtp
->u
.p
.saved_type
= BT_REAL
;
1858 l_push_char (dtp
, c
);
1861 /* Match INF and Infinity. */
1862 if (c
== 'i' || c
== 'I')
1864 c
= next_char (dtp
);
1865 l_push_char (dtp
, c
);
1866 if (c
!= 'n' && c
!= 'N')
1868 c
= next_char (dtp
);
1869 l_push_char (dtp
, c
);
1870 if (c
!= 'f' && c
!= 'F')
1872 c
= next_char (dtp
);
1873 l_push_char (dtp
, c
);
1874 if (!is_separator (c
) && (c
!= EOF
))
1876 if (c
!= 'i' && c
!= 'I')
1878 c
= next_char (dtp
);
1879 l_push_char (dtp
, c
);
1880 if (c
!= 'n' && c
!= 'N')
1882 c
= next_char (dtp
);
1883 l_push_char (dtp
, c
);
1884 if (c
!= 'i' && c
!= 'I')
1886 c
= next_char (dtp
);
1887 l_push_char (dtp
, c
);
1888 if (c
!= 't' && c
!= 'T')
1890 c
= next_char (dtp
);
1891 l_push_char (dtp
, c
);
1892 if (c
!= 'y' && c
!= 'Y')
1894 c
= next_char (dtp
);
1895 l_push_char (dtp
, c
);
1901 c
= next_char (dtp
);
1902 l_push_char (dtp
, c
);
1903 if (c
!= 'a' && c
!= 'A')
1905 c
= next_char (dtp
);
1906 l_push_char (dtp
, c
);
1907 if (c
!= 'n' && c
!= 'N')
1909 c
= next_char (dtp
);
1910 l_push_char (dtp
, c
);
1912 /* Match NAN(alphanum). */
1915 for (c
= next_char (dtp
); c
!= ')'; c
= next_char (dtp
))
1916 if (is_separator (c
))
1919 l_push_char (dtp
, c
);
1921 l_push_char (dtp
, ')');
1922 c
= next_char (dtp
);
1923 l_push_char (dtp
, c
);
1927 if (!is_separator (c
) && (c
!= EOF
))
1930 if (dtp
->u
.p
.namelist_mode
)
1932 if (c
== ' ' || c
=='\n' || c
== '\r')
1936 if ((c
= next_char (dtp
)) == EOF
)
1939 while (c
== ' ' || c
=='\n' || c
== '\r');
1941 l_push_char (dtp
, c
);
1950 push_char (dtp
, 'i');
1951 push_char (dtp
, 'n');
1952 push_char (dtp
, 'f');
1956 push_char (dtp
, 'n');
1957 push_char (dtp
, 'a');
1958 push_char (dtp
, 'n');
1962 unget_char (dtp
, c
);
1963 eat_separator (dtp
);
1964 push_char (dtp
, '\0');
1965 if (convert_infnan (dtp
, dest
, dtp
->u
.p
.saved_string
, length
))
1969 dtp
->u
.p
.saved_type
= BT_REAL
;
1973 if (dtp
->u
.p
.namelist_mode
)
1975 dtp
->u
.p
.nml_read_error
= 1;
1976 dtp
->u
.p
.line_buffer_enabled
= 1;
1977 dtp
->u
.p
.line_buffer_pos
= 0;
1983 if (nml_bad_return (dtp
, c
))
1996 snprintf (message
, MSGLEN
, "Bad real number in item %d of list input",
1997 dtp
->u
.p
.item_count
);
1999 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2003 /* Check the current type against the saved type to make sure they are
2004 compatible. Returns nonzero if incompatible. */
2007 check_type (st_parameter_dt
*dtp
, bt type
, int kind
)
2009 char message
[MSGLEN
];
2011 if (dtp
->u
.p
.saved_type
!= BT_UNKNOWN
&& dtp
->u
.p
.saved_type
!= type
)
2013 snprintf (message
, MSGLEN
, "Read type %s where %s was expected for item %d",
2014 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
2015 dtp
->u
.p
.item_count
);
2017 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2021 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
2024 if ((type
!= BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
)
2025 || (type
== BT_COMPLEX
&& dtp
->u
.p
.saved_length
!= kind
*2))
2027 snprintf (message
, MSGLEN
,
2028 "Read kind %d %s where kind %d is required for item %d",
2029 type
== BT_COMPLEX
? dtp
->u
.p
.saved_length
/ 2
2030 : dtp
->u
.p
.saved_length
,
2031 type_name (dtp
->u
.p
.saved_type
), kind
,
2032 dtp
->u
.p
.item_count
);
2034 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
2042 /* Initialize the function pointers to select the correct versions of
2043 next_char and push_char depending on what we are doing. */
2046 set_workers (st_parameter_dt
*dtp
)
2048 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2050 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_utf8
;
2051 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char4
;
2053 else if (is_internal_unit (dtp
))
2055 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_internal
;
2056 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char_default
;
2060 dtp
->u
.p
.current_unit
->next_char_fn_ptr
= &next_char_default
;
2061 dtp
->u
.p
.current_unit
->push_char_fn_ptr
= &push_char_default
;
2066 /* Top level data transfer subroutine for list reads. Because we have
2067 to deal with repeat counts, the data item is always saved after
2068 reading, usually in the dtp->u.p.value[] array. If a repeat count is
2069 greater than one, we copy the data item multiple times. */
2072 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
,
2073 int kind
, size_t size
)
2079 dtp
->u
.p
.namelist_mode
= 0;
2081 /* Set the next_char and push_char worker functions. */
2084 if (dtp
->u
.p
.first_item
)
2086 dtp
->u
.p
.first_item
= 0;
2087 dtp
->u
.p
.input_complete
= 0;
2088 dtp
->u
.p
.repeat_count
= 1;
2089 dtp
->u
.p
.at_eol
= 0;
2091 if ((c
= eat_spaces (dtp
)) == EOF
)
2096 if (is_separator (c
))
2098 /* Found a null value. */
2099 dtp
->u
.p
.repeat_count
= 0;
2100 eat_separator (dtp
);
2102 /* Set end-of-line flag. */
2103 if (c
== '\n' || c
== '\r')
2105 dtp
->u
.p
.at_eol
= 1;
2106 if (finish_separator (dtp
) == LIBERROR_END
)
2118 if (dtp
->u
.p
.repeat_count
> 0)
2120 if (check_type (dtp
, type
, kind
))
2125 if (dtp
->u
.p
.input_complete
)
2128 if (dtp
->u
.p
.at_eol
)
2129 finish_separator (dtp
);
2133 /* Trailing spaces prior to end of line. */
2134 if (dtp
->u
.p
.at_eol
)
2135 finish_separator (dtp
);
2138 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2139 dtp
->u
.p
.repeat_count
= 1;
2145 read_integer (dtp
, kind
);
2148 read_logical (dtp
, kind
);
2151 read_character (dtp
, kind
);
2154 read_real (dtp
, p
, kind
);
2155 /* Copy value back to temporary if needed. */
2156 if (dtp
->u
.p
.repeat_count
> 0)
2157 memcpy (dtp
->u
.p
.value
, p
, size
);
2160 read_complex (dtp
, p
, kind
, size
);
2161 /* Copy value back to temporary if needed. */
2162 if (dtp
->u
.p
.repeat_count
> 0)
2163 memcpy (dtp
->u
.p
.value
, p
, size
);
2166 internal_error (&dtp
->common
, "Bad type for list read");
2169 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_UNKNOWN
)
2170 dtp
->u
.p
.saved_length
= size
;
2172 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2176 switch (dtp
->u
.p
.saved_type
)
2180 if (dtp
->u
.p
.repeat_count
> 0)
2181 memcpy (p
, dtp
->u
.p
.value
, size
);
2186 memcpy (p
, dtp
->u
.p
.value
, size
);
2190 if (dtp
->u
.p
.saved_string
)
2192 m
= ((int) size
< dtp
->u
.p
.saved_used
)
2193 ? (int) size
: dtp
->u
.p
.saved_used
;
2195 q
= (gfc_char4_t
*) p
;
2196 r
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
2197 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2198 for (i
= 0; i
< m
; i
++)
2203 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
2205 for (i
= 0; i
< m
; i
++)
2210 /* Just delimiters encountered, nothing to copy but SPACE. */
2216 memset (((char *) p
) + m
, ' ', size
- m
);
2219 q
= (gfc_char4_t
*) p
;
2220 for (i
= m
; i
< (int) size
; i
++)
2221 q
[i
] = (unsigned char) ' ';
2230 internal_error (&dtp
->common
, "Bad type for list read");
2233 if (--dtp
->u
.p
.repeat_count
<= 0)
2237 if (err
== LIBERROR_END
)
2242 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_READING
);
2248 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2249 size_t size
, size_t nelems
)
2253 size_t stride
= type
== BT_CHARACTER
?
2254 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2259 /* Big loop over all the elements. */
2260 for (elem
= 0; elem
< nelems
; elem
++)
2262 dtp
->u
.p
.item_count
++;
2263 err
= list_formatted_read_scalar (dtp
, type
, tmp
+ stride
*elem
,
2271 /* Finish a list read. */
2274 finish_list_read (st_parameter_dt
*dtp
)
2278 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2280 if (dtp
->u
.p
.at_eol
)
2282 dtp
->u
.p
.at_eol
= 0;
2286 if (!is_internal_unit (dtp
))
2290 /* Set the next_char and push_char worker functions. */
2293 c
= next_char (dtp
);
2310 void namelist_read (st_parameter_dt *dtp)
2312 static void nml_match_name (char *name, int len)
2313 static int nml_query (st_parameter_dt *dtp)
2314 static int nml_get_obj_data (st_parameter_dt *dtp,
2315 namelist_info **prev_nl, char *, size_t)
2317 static void nml_untouch_nodes (st_parameter_dt *dtp)
2318 static namelist_info * find_nml_node (st_parameter_dt *dtp,
2320 static int nml_parse_qualifier(descriptor_dimension * ad,
2321 array_loop_spec * ls, int rank, char *)
2322 static void nml_touch_nodes (namelist_info * nl)
2323 static int nml_read_obj (namelist_info *nl, index_type offset,
2324 namelist_info **prev_nl, char *, size_t,
2325 index_type clow, index_type chigh)
2329 /* Inputs a rank-dimensional qualifier, which can contain
2330 singlets, doublets, triplets or ':' with the standard meanings. */
2333 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
2334 array_loop_spec
*ls
, int rank
, bt nml_elem_type
,
2335 char *parse_err_msg
, size_t parse_err_msg_size
,
2342 int is_array_section
, is_char
;
2346 is_array_section
= 0;
2347 dtp
->u
.p
.expanded_read
= 0;
2349 /* See if this is a character substring qualifier we are looking for. */
2356 /* The next character in the stream should be the '('. */
2358 if ((c
= next_char (dtp
)) == EOF
)
2361 /* Process the qualifier, by dimension and triplet. */
2363 for (dim
=0; dim
< rank
; dim
++ )
2365 for (indx
=0; indx
<3; indx
++)
2371 /* Process a potential sign. */
2372 if ((c
= next_char (dtp
)) == EOF
)
2384 unget_char (dtp
, c
);
2388 /* Process characters up to the next ':' , ',' or ')'. */
2391 c
= next_char (dtp
);
2398 is_array_section
= 1;
2402 if ((c
==',' && dim
== rank
-1)
2403 || (c
==')' && dim
< rank
-1))
2406 snprintf (parse_err_msg
, parse_err_msg_size
,
2407 "Bad substring qualifier");
2409 snprintf (parse_err_msg
, parse_err_msg_size
,
2410 "Bad number of index fields");
2419 case ' ': case '\t': case '\r': case '\n':
2425 snprintf (parse_err_msg
, parse_err_msg_size
,
2426 "Bad character in substring qualifier");
2428 snprintf (parse_err_msg
, parse_err_msg_size
,
2429 "Bad character in index");
2433 if ((c
== ',' || c
== ')') && indx
== 0
2434 && dtp
->u
.p
.saved_string
== 0)
2437 snprintf (parse_err_msg
, parse_err_msg_size
,
2438 "Null substring qualifier");
2440 snprintf (parse_err_msg
, parse_err_msg_size
,
2441 "Null index field");
2445 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
2446 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
2449 snprintf (parse_err_msg
, parse_err_msg_size
,
2450 "Bad substring qualifier");
2452 snprintf (parse_err_msg
, parse_err_msg_size
,
2453 "Bad index triplet");
2457 if (is_char
&& !is_array_section
)
2459 snprintf (parse_err_msg
, parse_err_msg_size
,
2460 "Missing colon in substring qualifier");
2464 /* If '( : ? )' or '( ? : )' break and flag read failure. */
2466 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
2467 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
2473 /* Now read the index. */
2474 if (convert_integer (dtp
, sizeof(index_type
), neg
))
2477 snprintf (parse_err_msg
, parse_err_msg_size
,
2478 "Bad integer substring qualifier");
2480 snprintf (parse_err_msg
, parse_err_msg_size
,
2481 "Bad integer in index");
2487 /* Feed the index values to the triplet arrays. */
2491 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2493 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(index_type
));
2495 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(index_type
));
2498 /* Singlet or doublet indices. */
2499 if (c
==',' || c
==')')
2503 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(index_type
));
2505 /* If -std=f95/2003 or an array section is specified,
2506 do not allow excess data to be processed. */
2507 if (is_array_section
== 1
2508 || !(compile_options
.allow_std
& GFC_STD_GNU
)
2509 || nml_elem_type
== BT_DERIVED
)
2510 ls
[dim
].end
= ls
[dim
].start
;
2512 dtp
->u
.p
.expanded_read
= 1;
2515 /* Check for non-zero rank. */
2516 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
2523 if (is_array_section
== 1 && dtp
->u
.p
.expanded_read
== 1)
2526 dtp
->u
.p
.expanded_read
= 0;
2527 for (i
= 0; i
< dim
; i
++)
2528 ls
[i
].end
= ls
[i
].start
;
2531 /* Check the values of the triplet indices. */
2532 if ((ls
[dim
].start
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2533 || (ls
[dim
].start
< GFC_DIMENSION_LBOUND(ad
[dim
]))
2534 || (ls
[dim
].end
> GFC_DIMENSION_UBOUND(ad
[dim
]))
2535 || (ls
[dim
].end
< GFC_DIMENSION_LBOUND(ad
[dim
])))
2538 snprintf (parse_err_msg
, parse_err_msg_size
,
2539 "Substring out of range");
2541 snprintf (parse_err_msg
, parse_err_msg_size
,
2542 "Index %d out of range", dim
+ 1);
2546 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
2547 || (ls
[dim
].step
== 0))
2549 snprintf (parse_err_msg
, parse_err_msg_size
,
2550 "Bad range in index %d", dim
+ 1);
2554 /* Initialise the loop index counter. */
2555 ls
[dim
].idx
= ls
[dim
].start
;
2562 /* The EOF error message is issued by hit_eof. Return true so that the
2563 caller does not use parse_err_msg and parse_err_msg_size to generate
2564 an unrelated error message. */
2568 dtp
->u
.p
.input_complete
= 1;
2576 extended_look_ahead (char *p
, char *q
)
2580 /* Scan ahead to find a '%' in the p string. */
2581 for(r
= p
, s
= q
; *r
&& *s
; s
++)
2582 if ((*s
== '%' || *s
== '+') && strcmp (r
+ 1, s
+ 1) == 0)
2589 strcmp_extended_type (char *p
, char *q
)
2593 for (r
= p
, s
= q
; *r
&& *s
; r
++, s
++)
2597 if (*r
== '%' && *s
== '+' && extended_look_ahead (r
, s
))
2606 static namelist_info
*
2607 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
2609 namelist_info
* t
= dtp
->u
.p
.ionml
;
2612 if (strcmp (var_name
, t
->var_name
) == 0)
2617 if (strcmp_extended_type (var_name
, t
->var_name
))
2627 /* Visits all the components of a derived type that have
2628 not explicitly been identified in the namelist input.
2629 touched is set and the loop specification initialised
2630 to default values */
2633 nml_touch_nodes (namelist_info
* nl
)
2635 index_type len
= strlen (nl
->var_name
) + 1;
2637 char * ext_name
= xmalloc (len
+ 1);
2638 memcpy (ext_name
, nl
->var_name
, len
-1);
2639 memcpy (ext_name
+ len
- 1, "%", 2);
2640 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
2642 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
2645 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2647 nl
->ls
[dim
].step
= 1;
2648 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
2649 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
2650 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2660 /* Resets touched for the entire list of nml_nodes, ready for a
2664 nml_untouch_nodes (st_parameter_dt
*dtp
)
2667 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
2672 /* Attempts to input name to namelist name. Returns
2673 dtp->u.p.nml_read_error = 1 on no match. */
2676 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
2681 dtp
->u
.p
.nml_read_error
= 0;
2682 for (i
= 0; i
< len
; i
++)
2684 c
= next_char (dtp
);
2685 if (c
== EOF
|| (tolower (c
) != tolower (name
[i
])))
2687 dtp
->u
.p
.nml_read_error
= 1;
2693 /* If the namelist read is from stdin, output the current state of the
2694 namelist to stdout. This is used to implement the non-standard query
2695 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2696 the names alone are printed. */
2699 nml_query (st_parameter_dt
*dtp
, char c
)
2701 gfc_unit
* temp_unit
;
2706 static const index_type endlen
= 2;
2707 static const char endl
[] = "\r\n";
2708 static const char nmlend
[] = "&end\r\n";
2710 static const index_type endlen
= 1;
2711 static const char endl
[] = "\n";
2712 static const char nmlend
[] = "&end\n";
2715 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2718 /* Store the current unit and transfer to stdout. */
2720 temp_unit
= dtp
->u
.p
.current_unit
;
2721 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2723 if (dtp
->u
.p
.current_unit
)
2725 dtp
->u
.p
.mode
= WRITING
;
2726 next_record (dtp
, 0);
2728 /* Write the namelist in its entirety. */
2731 namelist_write (dtp
);
2733 /* Or write the list of names. */
2737 /* "&namelist_name\n" */
2739 len
= dtp
->namelist_name_len
;
2740 p
= write_block (dtp
, len
- 1 + endlen
);
2744 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2745 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2746 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2750 len
= strlen (nl
->var_name
);
2751 p
= write_block (dtp
, len
+ endlen
);
2755 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2756 memcpy ((char*)(p
+ len
+ 1), &endl
, endlen
);
2761 p
= write_block (dtp
, endlen
+ 4);
2764 memcpy (p
, &nmlend
, endlen
+ 4);
2767 /* Flush the stream to force immediate output. */
2769 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2770 sflush (dtp
->u
.p
.current_unit
->s
);
2771 unlock_unit (dtp
->u
.p
.current_unit
);
2776 /* Restore the current unit. */
2778 dtp
->u
.p
.current_unit
= temp_unit
;
2779 dtp
->u
.p
.mode
= READING
;
2783 /* Reads and stores the input for the namelist object nl. For an array,
2784 the function loops over the ranges defined by the loop specification.
2785 This default to all the data or to the specification from a qualifier.
2786 nml_read_obj recursively calls itself to read derived types. It visits
2787 all its own components but only reads data for those that were touched
2788 when the name was parsed. If a read error is encountered, an attempt is
2789 made to return to read a new object name because the standard allows too
2790 little data to be available. On the other hand, too much data is an
2794 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2795 namelist_info
**pprev_nl
, char *nml_err_msg
,
2796 size_t nml_err_msg_size
, index_type clow
, index_type chigh
)
2798 namelist_info
* cmp
;
2805 size_t obj_name_len
;
2808 /* If we have encountered a previous read error or this object has not been
2809 touched in name parsing, just return. */
2810 if (dtp
->u
.p
.nml_read_error
|| !nl
->touched
)
2813 dtp
->u
.p
.repeat_count
= 0;
2825 dlen
= size_from_real_kind (len
);
2829 dlen
= size_from_complex_kind (len
);
2833 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2842 /* Update the pointer to the data, using the current index vector */
2844 pdata
= (void*)(nl
->mem_pos
+ offset
);
2845 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2846 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
2847 - GFC_DESCRIPTOR_LBOUND(nl
,dim
))
2848 * GFC_DESCRIPTOR_STRIDE(nl
,dim
) * nl
->size
);
2850 /* If we are finished with the repeat count, try to read next value. */
2853 if (--dtp
->u
.p
.repeat_count
<= 0)
2855 if (dtp
->u
.p
.input_complete
)
2857 if (dtp
->u
.p
.at_eol
)
2858 finish_separator (dtp
);
2859 if (dtp
->u
.p
.input_complete
)
2862 dtp
->u
.p
.saved_type
= BT_UNKNOWN
;
2868 read_integer (dtp
, len
);
2872 read_logical (dtp
, len
);
2876 read_character (dtp
, len
);
2880 /* Need to copy data back from the real location to the temp in
2881 order to handle nml reads into arrays. */
2882 read_real (dtp
, pdata
, len
);
2883 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2887 /* Same as for REAL, copy back to temp. */
2888 read_complex (dtp
, pdata
, len
, dlen
);
2889 memcpy (dtp
->u
.p
.value
, pdata
, dlen
);
2893 obj_name_len
= strlen (nl
->var_name
) + 1;
2894 obj_name
= xmalloc (obj_name_len
+1);
2895 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2896 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2898 /* If reading a derived type, disable the expanded read warning
2899 since a single object can have multiple reads. */
2900 dtp
->u
.p
.expanded_read
= 0;
2902 /* Now loop over the components. */
2904 for (cmp
= nl
->next
;
2906 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2909 /* Jump over nested derived type by testing if the potential
2910 component name contains '%'. */
2911 if (strchr (cmp
->var_name
+ obj_name_len
, '%'))
2914 if (!nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2915 pprev_nl
, nml_err_msg
, nml_err_msg_size
,
2922 if (dtp
->u
.p
.input_complete
)
2933 snprintf (nml_err_msg
, nml_err_msg_size
,
2934 "Bad type for namelist object %s", nl
->var_name
);
2935 internal_error (&dtp
->common
, nml_err_msg
);
2940 /* The standard permits array data to stop short of the number of
2941 elements specified in the loop specification. In this case, we
2942 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2943 nml_get_obj_data and an attempt is made to read object name. */
2946 if (dtp
->u
.p
.nml_read_error
)
2948 dtp
->u
.p
.expanded_read
= 0;
2952 if (dtp
->u
.p
.saved_type
== BT_UNKNOWN
)
2954 dtp
->u
.p
.expanded_read
= 0;
2958 switch (dtp
->u
.p
.saved_type
)
2965 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2969 if (dlen
< dtp
->u
.p
.saved_used
)
2971 if (compile_options
.bounds_check
)
2973 snprintf (nml_err_msg
, nml_err_msg_size
,
2974 "Namelist object '%s' truncated on read.",
2976 generate_warning (&dtp
->common
, nml_err_msg
);
2981 m
= dtp
->u
.p
.saved_used
;
2983 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2985 gfc_char4_t
*q4
, *p4
= pdata
;
2988 q4
= (gfc_char4_t
*) dtp
->u
.p
.saved_string
;
2990 for (i
= 0; i
< m
; i
++)
2993 for (i
= 0; i
< dlen
- m
; i
++)
2994 *p4
++ = (gfc_char4_t
) ' ';
2998 pdata
= (void*)( pdata
+ clow
- 1 );
2999 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
3001 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
3009 /* Warn if a non-standard expanded read occurs. A single read of a
3010 single object is acceptable. If a second read occurs, issue a warning
3011 and set the flag to zero to prevent further warnings. */
3012 if (dtp
->u
.p
.expanded_read
== 2)
3014 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
3015 dtp
->u
.p
.expanded_read
= 0;
3018 /* If the expanded read warning flag is set, increment it,
3019 indicating that a single read has occurred. */
3020 if (dtp
->u
.p
.expanded_read
>= 1)
3021 dtp
->u
.p
.expanded_read
++;
3023 /* Break out of loop if scalar. */
3027 /* Now increment the index vector. */
3032 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
3034 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
3036 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
3038 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
3040 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
3044 } while (!nml_carry
);
3046 if (dtp
->u
.p
.repeat_count
> 1)
3048 snprintf (nml_err_msg
, nml_err_msg_size
,
3049 "Repeat count too large for namelist object %s", nl
->var_name
);
3059 /* Parses the object name, including array and substring qualifiers. It
3060 iterates over derived type components, touching those components and
3061 setting their loop specifications, if there is a qualifier. If the
3062 object is itself a derived type, its components and subcomponents are
3063 touched. nml_read_obj is called at the end and this reads the data in
3064 the manner specified by the object name. */
3067 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
3068 char *nml_err_msg
, size_t nml_err_msg_size
)
3072 namelist_info
* first_nl
= NULL
;
3073 namelist_info
* root_nl
= NULL
;
3074 int dim
, parsed_rank
;
3075 int component_flag
, qualifier_flag
;
3076 index_type clow
, chigh
;
3077 int non_zero_rank_count
;
3079 /* Look for end of input or object name. If '?' or '=?' are encountered
3080 in stdin, print the node names or the namelist to stdout. */
3082 eat_separator (dtp
);
3083 if (dtp
->u
.p
.input_complete
)
3086 if (dtp
->u
.p
.at_eol
)
3087 finish_separator (dtp
);
3088 if (dtp
->u
.p
.input_complete
)
3091 if ((c
= next_char (dtp
)) == EOF
)
3096 if ((c
= next_char (dtp
)) == EOF
)
3100 snprintf (nml_err_msg
, nml_err_msg_size
,
3101 "namelist read: misplaced = sign");
3104 nml_query (dtp
, '=');
3108 nml_query (dtp
, '?');
3113 nml_match_name (dtp
, "end", 3);
3114 if (dtp
->u
.p
.nml_read_error
)
3116 snprintf (nml_err_msg
, nml_err_msg_size
,
3117 "namelist not terminated with / or &end");
3122 dtp
->u
.p
.input_complete
= 1;
3129 /* Untouch all nodes of the namelist and reset the flags that are set for
3130 derived type components. */
3132 nml_untouch_nodes (dtp
);
3135 non_zero_rank_count
= 0;
3137 /* Get the object name - should '!' and '\n' be permitted separators? */
3145 if (!is_separator (c
))
3146 push_char_default (dtp
, tolower(c
));
3147 if ((c
= next_char (dtp
)) == EOF
)
3150 while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
3152 unget_char (dtp
, c
);
3154 /* Check that the name is in the namelist and get pointer to object.
3155 Three error conditions exist: (i) An attempt is being made to
3156 identify a non-existent object, following a failed data read or
3157 (ii) The object name does not exist or (iii) Too many data items
3158 are present for an object. (iii) gives the same error message
3161 push_char_default (dtp
, '\0');
3165 #define EXT_STACK_SZ 100
3166 char ext_stack
[EXT_STACK_SZ
];
3168 size_t var_len
= strlen (root_nl
->var_name
);
3170 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
3171 size_t ext_size
= var_len
+ saved_len
+ 1;
3173 if (ext_size
> EXT_STACK_SZ
)
3174 ext_name
= xmalloc (ext_size
);
3176 ext_name
= ext_stack
;
3178 memcpy (ext_name
, root_nl
->var_name
, var_len
);
3179 if (dtp
->u
.p
.saved_string
)
3180 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
3181 ext_name
[var_len
+ saved_len
] = '\0';
3182 nl
= find_nml_node (dtp
, ext_name
);
3184 if (ext_size
> EXT_STACK_SZ
)
3188 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
3192 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
3193 snprintf (nml_err_msg
, nml_err_msg_size
,
3194 "Bad data for namelist object %s", (*pprev_nl
)->var_name
);
3197 snprintf (nml_err_msg
, nml_err_msg_size
,
3198 "Cannot match namelist object name %s",
3199 dtp
->u
.p
.saved_string
);
3204 /* Get the length, data length, base pointer and rank of the variable.
3205 Set the default loop specification first. */
3207 for (dim
=0; dim
< nl
->var_rank
; dim
++)
3209 nl
->ls
[dim
].step
= 1;
3210 nl
->ls
[dim
].end
= GFC_DESCRIPTOR_UBOUND(nl
,dim
);
3211 nl
->ls
[dim
].start
= GFC_DESCRIPTOR_LBOUND(nl
,dim
);
3212 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
3215 /* Check to see if there is a qualifier: if so, parse it.*/
3217 if (c
== '(' && nl
->var_rank
)
3220 if (!nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
3221 nl
->type
, nml_err_msg
, nml_err_msg_size
,
3224 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
3225 snprintf (nml_err_msg_end
,
3226 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
3227 " for namelist variable %s", nl
->var_name
);
3230 if (parsed_rank
> 0)
3231 non_zero_rank_count
++;
3235 if ((c
= next_char (dtp
)) == EOF
)
3237 unget_char (dtp
, c
);
3239 else if (nl
->var_rank
> 0)
3240 non_zero_rank_count
++;
3242 /* Now parse a derived type component. The root namelist_info address
3243 is backed up, as is the previous component level. The component flag
3244 is set and the iteration is made by jumping back to get_name. */
3248 if (nl
->type
!= BT_DERIVED
)
3250 snprintf (nml_err_msg
, nml_err_msg_size
,
3251 "Attempt to get derived component for %s", nl
->var_name
);
3255 /* Don't move first_nl further in the list if a qualifier was found. */
3256 if ((*pprev_nl
== NULL
&& !qualifier_flag
) || !component_flag
)
3262 if ((c
= next_char (dtp
)) == EOF
)
3267 /* Parse a character qualifier, if present. chigh = 0 is a default
3268 that signals that the string length = string_length. */
3273 if (c
== '(' && nl
->type
== BT_CHARACTER
)
3275 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
3276 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
3278 if (!nml_parse_qualifier (dtp
, chd
, ind
, -1, nl
->type
,
3279 nml_err_msg
, nml_err_msg_size
, &parsed_rank
))
3281 char *nml_err_msg_end
= strchr (nml_err_msg
, '\0');
3282 snprintf (nml_err_msg_end
,
3283 nml_err_msg_size
- (nml_err_msg_end
- nml_err_msg
),
3284 " for namelist variable %s", nl
->var_name
);
3288 clow
= ind
[0].start
;
3291 if (ind
[0].step
!= 1)
3293 snprintf (nml_err_msg
, nml_err_msg_size
,
3294 "Step not allowed in substring qualifier"
3295 " for namelist object %s", nl
->var_name
);
3299 if ((c
= next_char (dtp
)) == EOF
)
3301 unget_char (dtp
, c
);
3304 /* Make sure no extraneous qualifiers are there. */
3308 snprintf (nml_err_msg
, nml_err_msg_size
,
3309 "Qualifier for a scalar or non-character namelist object %s",
3314 /* Make sure there is no more than one non-zero rank object. */
3315 if (non_zero_rank_count
> 1)
3317 snprintf (nml_err_msg
, nml_err_msg_size
,
3318 "Multiple sub-objects with non-zero rank in namelist object %s",
3320 non_zero_rank_count
= 0;
3324 /* According to the standard, an equal sign MUST follow an object name. The
3325 following is possibly lax - it allows comments, blank lines and so on to
3326 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
3330 eat_separator (dtp
);
3331 if (dtp
->u
.p
.input_complete
)
3334 if (dtp
->u
.p
.at_eol
)
3335 finish_separator (dtp
);
3336 if (dtp
->u
.p
.input_complete
)
3339 if ((c
= next_char (dtp
)) == EOF
)
3344 snprintf (nml_err_msg
, nml_err_msg_size
,
3345 "Equal sign must follow namelist object name %s",
3349 /* If a derived type, touch its components and restore the root
3350 namelist_info if we have parsed a qualified derived type
3353 if (nl
->type
== BT_DERIVED
)
3354 nml_touch_nodes (nl
);
3358 if (first_nl
->var_rank
== 0)
3360 if (component_flag
&& qualifier_flag
)
3367 dtp
->u
.p
.nml_read_error
= 0;
3368 if (!nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, nml_err_msg_size
,
3376 /* The EOF error message is issued by hit_eof. Return true so that the
3377 caller does not use nml_err_msg and nml_err_msg_size to generate
3378 an unrelated error message. */
3381 dtp
->u
.p
.input_complete
= 1;
3382 unget_char (dtp
, c
);
3389 /* Entry point for namelist input. Goes through input until namelist name
3390 is matched. Then cycles through nml_get_obj_data until the input is
3391 completed or there is an error. */
3394 namelist_read (st_parameter_dt
*dtp
)
3397 char nml_err_msg
[200];
3399 /* Initialize the error string buffer just in case we get an unexpected fail
3400 somewhere and end up at nml_err_ret. */
3401 strcpy (nml_err_msg
, "Internal namelist read error");
3403 /* Pointer to the previously read object, in case attempt is made to read
3404 new object name. Should this fail, error message can give previous
3406 namelist_info
*prev_nl
= NULL
;
3408 dtp
->u
.p
.namelist_mode
= 1;
3409 dtp
->u
.p
.input_complete
= 0;
3410 dtp
->u
.p
.expanded_read
= 0;
3412 /* Set the next_char and push_char worker functions. */
3415 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
3416 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
3417 node names or namelist on stdout. */
3420 c
= next_char (dtp
);
3432 c
= next_char (dtp
);
3434 nml_query (dtp
, '=');
3436 unget_char (dtp
, c
);
3440 nml_query (dtp
, '?');
3450 /* Match the name of the namelist. */
3452 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
3454 if (dtp
->u
.p
.nml_read_error
)
3457 /* A trailing space is required, we give a little latitude here, 10.9.1. */
3458 c
= next_char (dtp
);
3459 if (!is_separator(c
) && c
!= '!')
3461 unget_char (dtp
, c
);
3465 unget_char (dtp
, c
);
3466 eat_separator (dtp
);
3468 /* Ready to read namelist objects. If there is an error in input
3469 from stdin, output the error message and continue. */
3471 while (!dtp
->u
.p
.input_complete
)
3473 if (!nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
, sizeof nml_err_msg
))
3475 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
3477 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);
3480 /* Reset the previous namelist pointer if we know we are not going
3481 to be doing multiple reads within a single namelist object. */
3482 if (prev_nl
&& prev_nl
->var_rank
== 0)
3493 /* All namelist error calls return from here */
3496 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);