]>
Commit | Line | Data |
---|---|---|
7adcbafe | 1 | /* Copyright (C) 2002-2022 Free Software Foundation, Inc. |
6de9cd9a | 2 | Contributed by Andy Vaught |
29dc5138 | 3 | Namelist input contributed by Paul Thomas |
10256cbe | 4 | F2003 I/O support contributed by Jerry DeLisle |
6de9cd9a | 5 | |
bb408e87 | 6 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a DN |
7 | |
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 | |
748086b7 | 10 | the Free Software Foundation; either version 3, or (at your option) |
6de9cd9a DN |
11 | any later version. |
12 | ||
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. | |
17 | ||
748086b7 JJ |
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. | |
21 | ||
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/>. */ | |
6de9cd9a DN |
26 | |
27 | ||
36ae8a61 | 28 | #include "io.h" |
92cbdb68 JB |
29 | #include "fbuf.h" |
30 | #include "unix.h" | |
6de9cd9a | 31 | #include <string.h> |
6de9cd9a | 32 | |
42c1e008 JD |
33 | typedef unsigned char uchar; |
34 | ||
6de9cd9a DN |
35 | |
36 | /* List directed input. Several parsing subroutines are practically | |
7fcb1804 TS |
37 | reimplemented from formatted input, the reason being that there are |
38 | all kinds of small differences between formatted and list directed | |
39 | parsing. */ | |
6de9cd9a DN |
40 | |
41 | ||
42 | /* Subroutines for reading characters from the input. Because a | |
7fcb1804 TS |
43 | repeat count is ambiguous with an integer, we have to read the |
44 | whole digit string before seeing if there is a '*' which signals | |
45 | the repeat count. Since we can have a lot of potential leading | |
46 | zeros, we have to be able to back up by arbitrary amount. Because | |
47 | the input might not be seekable, we have to buffer the data | |
5e805e44 | 48 | ourselves. */ |
6de9cd9a DN |
49 | |
50 | #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ | |
51 | case '5': case '6': case '7': case '8': case '9' | |
52 | ||
b6749273 DH |
53 | #define CASE_SEPARATORS /* Fall through. */ \ |
54 | case ' ': case ',': case '/': case '\n': \ | |
fc12098d | 55 | case '\t': case '\r': case ';' |
6de9cd9a | 56 | |
7fcb1804 | 57 | /* This macro assumes that we're operating on a variable. */ |
6de9cd9a DN |
58 | |
59 | #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \ | |
fc12098d JD |
60 | || c == '\t' || c == '\r' || c == ';' || \ |
61 | (dtp->u.p.namelist_mode && c == '!')) | |
6de9cd9a | 62 | |
7fcb1804 | 63 | /* Maximum repeat count. Less than ten times the maximum signed int32. */ |
6de9cd9a DN |
64 | |
65 | #define MAX_REPEAT 200000000 | |
66 | ||
d30fe1c5 JB |
67 | |
68 | #define MSGLEN 100 | |
6de9cd9a | 69 | |
6de9cd9a | 70 | |
d428be77 JD |
71 | /* Wrappers for calling the current worker functions. */ |
72 | ||
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)) | |
75 | ||
76 | /* Worker function to save a default KIND=1 character to a string | |
77 | buffer, enlarging it as necessary. */ | |
fc12098d | 78 | |
6de9cd9a | 79 | static void |
d428be77 | 80 | push_char_default (st_parameter_dt *dtp, int c) |
6de9cd9a | 81 | { |
d74fd3c7 | 82 | |
6de9cd9a | 83 | |
5e805e44 | 84 | if (dtp->u.p.saved_string == NULL) |
6de9cd9a | 85 | { |
e73d3ca6 | 86 | /* Plain malloc should suffice here, zeroing not needed? */ |
f4471acb | 87 | dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1); |
5e805e44 JJ |
88 | dtp->u.p.saved_length = SCRATCH_SIZE; |
89 | dtp->u.p.saved_used = 0; | |
6de9cd9a DN |
90 | } |
91 | ||
5e805e44 | 92 | if (dtp->u.p.saved_used >= dtp->u.p.saved_length) |
6de9cd9a | 93 | { |
5e805e44 | 94 | dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; |
fc12098d | 95 | dtp->u.p.saved_string = |
d74fd3c7 | 96 | xrealloc (dtp->u.p.saved_string, dtp->u.p.saved_length); |
6de9cd9a DN |
97 | } |
98 | ||
d428be77 | 99 | dtp->u.p.saved_string[dtp->u.p.saved_used++] = (char) c; |
6de9cd9a DN |
100 | } |
101 | ||
42c1e008 | 102 | |
d428be77 JD |
103 | /* Worker function to save a KIND=4 character to a string buffer, |
104 | enlarging the buffer as necessary. */ | |
42c1e008 | 105 | static void |
d428be77 | 106 | push_char4 (st_parameter_dt *dtp, int c) |
42c1e008 | 107 | { |
fc12098d | 108 | gfc_char4_t *p = (gfc_char4_t *) dtp->u.p.saved_string; |
42c1e008 JD |
109 | |
110 | if (p == NULL) | |
111 | { | |
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; | |
116 | } | |
117 | ||
118 | if (dtp->u.p.saved_used >= dtp->u.p.saved_length) | |
119 | { | |
120 | dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; | |
efea09f2 JD |
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; | |
42c1e008 JD |
125 | } |
126 | ||
127 | p[dtp->u.p.saved_used++] = c; | |
128 | } | |
129 | ||
6de9cd9a | 130 | |
7fcb1804 | 131 | /* Free the input buffer if necessary. */ |
6de9cd9a DN |
132 | |
133 | static void | |
5e805e44 | 134 | free_saved (st_parameter_dt *dtp) |
6de9cd9a | 135 | { |
5e805e44 | 136 | if (dtp->u.p.saved_string == NULL) |
6de9cd9a DN |
137 | return; |
138 | ||
bb408e87 | 139 | free (dtp->u.p.saved_string); |
6de9cd9a | 140 | |
5e805e44 JJ |
141 | dtp->u.p.saved_string = NULL; |
142 | dtp->u.p.saved_used = 0; | |
6de9cd9a DN |
143 | } |
144 | ||
145 | ||
c9f15d9c JD |
146 | /* Free the line buffer if necessary. */ |
147 | ||
148 | static void | |
149 | free_line (st_parameter_dt *dtp) | |
150 | { | |
2558e2e8 | 151 | dtp->u.p.line_buffer_pos = 0; |
17f46ec3 JD |
152 | dtp->u.p.line_buffer_enabled = 0; |
153 | ||
c9f15d9c JD |
154 | if (dtp->u.p.line_buffer == NULL) |
155 | return; | |
156 | ||
bb408e87 | 157 | free (dtp->u.p.line_buffer); |
c9f15d9c JD |
158 | dtp->u.p.line_buffer = NULL; |
159 | } | |
160 | ||
161 | ||
d428be77 JD |
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. */ | |
fc12098d | 165 | |
c86af7f3 | 166 | static int |
d428be77 | 167 | check_buffers (st_parameter_dt *dtp) |
6de9cd9a | 168 | { |
c86af7f3 | 169 | int c; |
6de9cd9a | 170 | |
d428be77 | 171 | c = '\0'; |
e73d3ca6 | 172 | if (dtp->u.p.current_unit->last_char != EOF - 1) |
6de9cd9a | 173 | { |
5e805e44 | 174 | dtp->u.p.at_eol = 0; |
e73d3ca6 PT |
175 | c = dtp->u.p.current_unit->last_char; |
176 | dtp->u.p.current_unit->last_char = EOF - 1; | |
6de9cd9a DN |
177 | goto done; |
178 | } | |
179 | ||
c9f15d9c JD |
180 | /* Read from line_buffer if enabled. */ |
181 | ||
182 | if (dtp->u.p.line_buffer_enabled) | |
183 | { | |
184 | dtp->u.p.at_eol = 0; | |
185 | ||
2558e2e8 JD |
186 | c = dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos]; |
187 | if (c != '\0' && dtp->u.p.line_buffer_pos < 64) | |
c9f15d9c | 188 | { |
2558e2e8 JD |
189 | dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos] = '\0'; |
190 | dtp->u.p.line_buffer_pos++; | |
c9f15d9c JD |
191 | goto done; |
192 | } | |
193 | ||
2558e2e8 | 194 | dtp->u.p.line_buffer_pos = 0; |
17f46ec3 | 195 | dtp->u.p.line_buffer_enabled = 0; |
c8869272 | 196 | } |
fc12098d | 197 | |
d428be77 | 198 | done: |
90eeab20 | 199 | dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF); |
d428be77 JD |
200 | return c; |
201 | } | |
202 | ||
203 | ||
204 | /* Worker function for default character encoded file. */ | |
205 | static int | |
206 | next_char_default (st_parameter_dt *dtp) | |
207 | { | |
208 | int c; | |
209 | ||
210 | /* Always check the unget and line buffer first. */ | |
211 | if ((c = check_buffers (dtp))) | |
212 | return c; | |
213 | ||
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++; | |
217 | ||
218 | dtp->u.p.at_eol = (c == '\n' || c == EOF); | |
219 | return c; | |
220 | } | |
221 | ||
222 | ||
223 | /* Worker function for internal and array I/O units. */ | |
224 | static int | |
225 | next_char_internal (st_parameter_dt *dtp) | |
226 | { | |
227 | ssize_t length; | |
228 | gfc_offset record; | |
229 | int c; | |
230 | ||
231 | /* Always check the unget and line buffer first. */ | |
232 | if ((c = check_buffers (dtp))) | |
233 | return c; | |
6de9cd9a | 234 | |
807fb853 JD |
235 | /* Handle the end-of-record and end-of-file conditions for |
236 | internal array unit. */ | |
d10fb73e | 237 | if (is_array_io (dtp)) |
6de9cd9a | 238 | { |
807fb853 | 239 | if (dtp->u.p.at_eof) |
c86af7f3 | 240 | return EOF; |
8ad4c895 | 241 | |
807fb853 JD |
242 | /* Check for "end-of-record" condition. */ |
243 | if (dtp->u.p.current_unit->bytes_left == 0) | |
244 | { | |
9370b3c0 TK |
245 | int finished; |
246 | ||
bbd6c8aa | 247 | c = '\n'; |
9370b3c0 TK |
248 | record = next_array_record (dtp, dtp->u.p.current_unit->ls, |
249 | &finished); | |
8ad4c895 | 250 | |
fc12098d | 251 | /* Check for "end-of-file" condition. */ |
9370b3c0 | 252 | if (finished) |
807fb853 JD |
253 | { |
254 | dtp->u.p.at_eof = 1; | |
807fb853 JD |
255 | goto done; |
256 | } | |
257 | ||
258 | record *= dtp->u.p.current_unit->recl; | |
7812c78c | 259 | if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) |
c86af7f3 | 260 | return EOF; |
807fb853 JD |
261 | |
262 | dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
bbd6c8aa | 263 | goto done; |
807fb853 | 264 | } |
6de9cd9a DN |
265 | } |
266 | ||
807fb853 | 267 | /* Get the next character and handle end-of-record conditions. */ |
1eaa31d8 JD |
268 | if (likely (dtp->u.p.current_unit->bytes_left > 0)) |
269 | { | |
270 | if (unlikely (is_char4_unit(dtp))) /* Check for kind=4 internal unit. */ | |
271 | length = sread (dtp->u.p.current_unit->s, &c, 1); | |
272 | else | |
273 | { | |
274 | char cc; | |
275 | length = sread (dtp->u.p.current_unit->s, &cc, 1); | |
276 | c = cc; | |
277 | } | |
278 | } | |
d428be77 | 279 | else |
1eaa31d8 | 280 | length = 0; |
d428be77 JD |
281 | |
282 | if (unlikely (length < 0)) | |
f3ed1d02 | 283 | { |
d428be77 JD |
284 | generate_error (&dtp->common, LIBERROR_OS, NULL); |
285 | return '\0'; | |
286 | } | |
7c0de753 | 287 | |
d428be77 JD |
288 | if (is_array_io (dtp)) |
289 | { | |
fc12098d | 290 | /* Check whether we hit EOF. */ |
d428be77 | 291 | if (unlikely (length == 0)) |
7812c78c | 292 | { |
d428be77 | 293 | generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); |
7812c78c | 294 | return '\0'; |
fc12098d | 295 | } |
334ff453 PB |
296 | } |
297 | else | |
8ad4c895 | 298 | { |
fc12098d | 299 | if (dtp->u.p.at_eof) |
d428be77 JD |
300 | return EOF; |
301 | if (length == 0) | |
302 | { | |
303 | c = '\n'; | |
304 | dtp->u.p.at_eof = 1; | |
305 | } | |
8ad4c895 | 306 | } |
1eaa31d8 | 307 | dtp->u.p.current_unit->bytes_left--; |
d428be77 | 308 | |
6de9cd9a | 309 | done: |
937424c1 | 310 | dtp->u.p.at_eol = (c == '\n' || c == EOF); |
6de9cd9a DN |
311 | return c; |
312 | } | |
313 | ||
314 | ||
d428be77 JD |
315 | /* Worker function for UTF encoded files. */ |
316 | static int | |
fc12098d | 317 | next_char_utf8 (st_parameter_dt *dtp) |
42c1e008 JD |
318 | { |
319 | static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 }; | |
320 | static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; | |
321 | int i, nb; | |
322 | gfc_char4_t c; | |
323 | ||
d428be77 JD |
324 | /* Always check the unget and line buffer first. */ |
325 | if (!(c = check_buffers (dtp))) | |
326 | c = fbuf_getc (dtp->u.p.current_unit); | |
327 | ||
42c1e008 | 328 | if (c < 0x80) |
d428be77 | 329 | goto utf_done; |
42c1e008 JD |
330 | |
331 | /* The number of leading 1-bits in the first byte indicates how many | |
332 | bytes follow. */ | |
333 | for (nb = 2; nb < 7; nb++) | |
334 | if ((c & ~masks[nb-1]) == patns[nb-1]) | |
335 | goto found; | |
336 | goto invalid; | |
fc12098d | 337 | |
42c1e008 JD |
338 | found: |
339 | c = (c & masks[nb-1]); | |
340 | ||
341 | /* Decode the bytes read. */ | |
342 | for (i = 1; i < nb; i++) | |
343 | { | |
d428be77 | 344 | gfc_char4_t n = fbuf_getc (dtp->u.p.current_unit); |
42c1e008 JD |
345 | if ((n & 0xC0) != 0x80) |
346 | goto invalid; | |
42c1e008 JD |
347 | c = ((c << 6) + (n & 0x3F)); |
348 | } | |
349 | ||
350 | /* Make sure the shortest possible encoding was used. */ | |
351 | if (c <= 0x7F && nb > 1) goto invalid; | |
352 | if (c <= 0x7FF && nb > 2) goto invalid; | |
353 | if (c <= 0xFFFF && nb > 3) goto invalid; | |
354 | if (c <= 0x1FFFFF && nb > 4) goto invalid; | |
355 | if (c <= 0x3FFFFFF && nb > 5) goto invalid; | |
356 | ||
357 | /* Make sure the character is valid. */ | |
358 | if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF)) | |
359 | goto invalid; | |
360 | ||
d428be77 JD |
361 | utf_done: |
362 | dtp->u.p.at_eol = (c == '\n' || c == (gfc_char4_t) EOF); | |
363 | return (int) c; | |
fc12098d | 364 | |
42c1e008 JD |
365 | invalid: |
366 | generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding"); | |
367 | return (gfc_char4_t) '?'; | |
368 | } | |
369 | ||
7fcb1804 | 370 | /* Push a character back onto the input. */ |
6de9cd9a DN |
371 | |
372 | static void | |
c86af7f3 | 373 | unget_char (st_parameter_dt *dtp, int c) |
6de9cd9a | 374 | { |
e73d3ca6 | 375 | dtp->u.p.current_unit->last_char = c; |
6de9cd9a DN |
376 | } |
377 | ||
378 | ||
7fcb1804 TS |
379 | /* Skip over spaces in the input. Returns the nonspace character that |
380 | terminated the eating and also places it back on the input. */ | |
6de9cd9a | 381 | |
c86af7f3 | 382 | static int |
5e805e44 | 383 | eat_spaces (st_parameter_dt *dtp) |
6de9cd9a | 384 | { |
c86af7f3 | 385 | int c; |
6de9cd9a | 386 | |
c8869272 | 387 | /* If internal character array IO, peak ahead and seek past spaces. |
b896e674 JD |
388 | This is an optimization unique to character arrays with large |
389 | character lengths (PR38199). This code eliminates numerous calls | |
390 | to next_character. */ | |
e73d3ca6 | 391 | if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1)) |
c8869272 JD |
392 | { |
393 | gfc_offset offset = stell (dtp->u.p.current_unit->s); | |
b896e674 | 394 | gfc_offset i; |
c8869272 | 395 | |
4a8d4422 | 396 | if (is_char4_unit(dtp)) /* kind=4 */ |
c8869272 | 397 | { |
b896e674 | 398 | for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++) |
c8869272 | 399 | { |
93896498 | 400 | if (dtp->internal_unit[(offset + i) * sizeof (gfc_char4_t)] |
b896e674 JD |
401 | != (gfc_char4_t)' ') |
402 | break; | |
c8869272 | 403 | } |
c8869272 JD |
404 | } |
405 | else | |
406 | { | |
b896e674 | 407 | for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++) |
c8869272 | 408 | { |
b896e674 JD |
409 | if (dtp->internal_unit[offset + i] != ' ') |
410 | break; | |
c8869272 | 411 | } |
b896e674 | 412 | } |
03c0f195 | 413 | |
b896e674 JD |
414 | if (i != 0) |
415 | { | |
416 | sseek (dtp->u.p.current_unit->s, offset + i, SEEK_SET); | |
417 | dtp->u.p.current_unit->bytes_left -= i; | |
c8869272 JD |
418 | } |
419 | } | |
b896e674 | 420 | |
c8869272 | 421 | /* Now skip spaces, EOF and EOL are handled in next_char. */ |
6de9cd9a | 422 | do |
c86af7f3 | 423 | c = next_char (dtp); |
e3f36534 | 424 | while (c != EOF && (c == ' ' || c == '\r' || c == '\t')); |
6de9cd9a | 425 | |
5e805e44 | 426 | unget_char (dtp, c); |
6de9cd9a DN |
427 | return c; |
428 | } | |
429 | ||
430 | ||
c86af7f3 JB |
431 | /* This function reads characters through to the end of the current |
432 | line and just ignores them. Returns 0 for success and LIBERROR_END | |
433 | if it hit EOF. */ | |
667e2045 | 434 | |
c86af7f3 | 435 | static int |
667e2045 TB |
436 | eat_line (st_parameter_dt *dtp) |
437 | { | |
c86af7f3 | 438 | int c; |
951b8fbe JD |
439 | |
440 | do | |
441 | c = next_char (dtp); | |
c86af7f3 JB |
442 | while (c != EOF && c != '\n'); |
443 | if (c == EOF) | |
444 | return LIBERROR_END; | |
445 | return 0; | |
667e2045 TB |
446 | } |
447 | ||
448 | ||
7fcb1804 TS |
449 | /* Skip over a separator. Technically, we don't always eat the whole |
450 | separator. This is because if we've processed the last input item, | |
451 | then a separator is unnecessary. Plus the fact that operating | |
452 | systems usually deliver console input on a line basis. | |
453 | ||
454 | The upshot is that if we see a newline as part of reading a | |
455 | separator, we stop reading. If there are more input items, we | |
456 | continue reading the separator with finish_separator() which takes | |
457 | care of the fact that we may or may not have seen a comma as part | |
fc12098d | 458 | of the separator. |
6de9cd9a | 459 | |
c86af7f3 JB |
460 | Returns 0 for success, and non-zero error code otherwise. */ |
461 | ||
462 | static int | |
5e805e44 | 463 | eat_separator (st_parameter_dt *dtp) |
6de9cd9a | 464 | { |
c86af7f3 JB |
465 | int c, n; |
466 | int err = 0; | |
6de9cd9a | 467 | |
5e805e44 JJ |
468 | eat_spaces (dtp); |
469 | dtp->u.p.comma_flag = 0; | |
6de9cd9a | 470 | |
c86af7f3 JB |
471 | if ((c = next_char (dtp)) == EOF) |
472 | return LIBERROR_END; | |
6de9cd9a DN |
473 | switch (c) |
474 | { | |
475 | case ',': | |
105b7136 | 476 | if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe JD |
477 | { |
478 | unget_char (dtp, c); | |
479 | break; | |
480 | } | |
481 | /* Fall through. */ | |
482 | case ';': | |
5e805e44 JJ |
483 | dtp->u.p.comma_flag = 1; |
484 | eat_spaces (dtp); | |
6de9cd9a DN |
485 | break; |
486 | ||
487 | case '/': | |
5e805e44 | 488 | dtp->u.p.input_complete = 1; |
6de9cd9a DN |
489 | break; |
490 | ||
94887ef4 | 491 | case '\r': |
c86af7f3 JB |
492 | if ((n = next_char(dtp)) == EOF) |
493 | return LIBERROR_END; | |
36afed5a | 494 | if (n != '\n') |
78a15b1f | 495 | { |
36afed5a JD |
496 | unget_char (dtp, n); |
497 | break; | |
78a15b1f | 498 | } |
36afed5a | 499 | /* Fall through. */ |
8824fd4c | 500 | case '\n': |
5e805e44 | 501 | dtp->u.p.at_eol = 1; |
78a15b1f JD |
502 | if (dtp->u.p.namelist_mode) |
503 | { | |
504 | do | |
667e2045 | 505 | { |
c86af7f3 JB |
506 | if ((c = next_char (dtp)) == EOF) |
507 | return LIBERROR_END; | |
667e2045 TB |
508 | if (c == '!') |
509 | { | |
c86af7f3 JB |
510 | err = eat_line (dtp); |
511 | if (err) | |
512 | return err; | |
a2f3eae2 | 513 | c = '\n'; |
667e2045 TB |
514 | } |
515 | } | |
fb669c2b | 516 | while (c == '\n' || c == '\r' || c == ' ' || c == '\t'); |
78a15b1f JD |
517 | unget_char (dtp, c); |
518 | } | |
6de9cd9a DN |
519 | break; |
520 | ||
521 | case '!': | |
fc12098d | 522 | /* Eat a namelist comment. */ |
5e805e44 | 523 | if (dtp->u.p.namelist_mode) |
fc12098d | 524 | { |
c86af7f3 JB |
525 | err = eat_line (dtp); |
526 | if (err) | |
527 | return err; | |
6de9cd9a DN |
528 | |
529 | break; | |
530 | } | |
531 | ||
7fcb1804 | 532 | /* Fall Through... */ |
6de9cd9a DN |
533 | |
534 | default: | |
5e805e44 | 535 | unget_char (dtp, c); |
6de9cd9a DN |
536 | break; |
537 | } | |
c86af7f3 | 538 | return err; |
6de9cd9a DN |
539 | } |
540 | ||
541 | ||
7fcb1804 TS |
542 | /* Finish processing a separator that was interrupted by a newline. |
543 | If we're here, then another data item is present, so we finish what | |
c86af7f3 JB |
544 | we started on the previous line. Return 0 on success, error code |
545 | on failure. */ | |
6de9cd9a | 546 | |
c86af7f3 | 547 | static int |
5e805e44 | 548 | finish_separator (st_parameter_dt *dtp) |
6de9cd9a | 549 | { |
c86af7f3 | 550 | int c; |
95bd9622 | 551 | int err = LIBERROR_OK; |
6de9cd9a | 552 | |
f21edfd6 | 553 | restart: |
5e805e44 | 554 | eat_spaces (dtp); |
6de9cd9a | 555 | |
c86af7f3 JB |
556 | if ((c = next_char (dtp)) == EOF) |
557 | return LIBERROR_END; | |
6de9cd9a DN |
558 | switch (c) |
559 | { | |
560 | case ',': | |
5e805e44 JJ |
561 | if (dtp->u.p.comma_flag) |
562 | unget_char (dtp, c); | |
6de9cd9a DN |
563 | else |
564 | { | |
c86af7f3 JB |
565 | if ((c = eat_spaces (dtp)) == EOF) |
566 | return LIBERROR_END; | |
8824fd4c | 567 | if (c == '\n' || c == '\r') |
6de9cd9a DN |
568 | goto restart; |
569 | } | |
570 | ||
571 | break; | |
572 | ||
573 | case '/': | |
5e805e44 | 574 | dtp->u.p.input_complete = 1; |
b8df885f | 575 | if (!dtp->u.p.namelist_mode) |
c86af7f3 | 576 | return err; |
6de9cd9a DN |
577 | break; |
578 | ||
579 | case '\n': | |
94887ef4 | 580 | case '\r': |
6de9cd9a DN |
581 | goto restart; |
582 | ||
583 | case '!': | |
5e805e44 | 584 | if (dtp->u.p.namelist_mode) |
6de9cd9a | 585 | { |
c86af7f3 JB |
586 | err = eat_line (dtp); |
587 | if (err) | |
588 | return err; | |
6de9cd9a DN |
589 | goto restart; |
590 | } | |
95bd9622 | 591 | /* Fall through. */ |
6de9cd9a | 592 | default: |
5e805e44 | 593 | unget_char (dtp, c); |
6de9cd9a DN |
594 | break; |
595 | } | |
c86af7f3 | 596 | return err; |
6de9cd9a DN |
597 | } |
598 | ||
9855448d | 599 | |
29dc5138 | 600 | /* This function is needed to catch bad conversions so that namelist can |
5e805e44 JJ |
601 | attempt to see if dtp->u.p.saved_string contains a new object name rather |
602 | than a bad value. */ | |
29dc5138 PT |
603 | |
604 | static int | |
5e805e44 | 605 | nml_bad_return (st_parameter_dt *dtp, char c) |
29dc5138 | 606 | { |
5e805e44 | 607 | if (dtp->u.p.namelist_mode) |
29dc5138 | 608 | { |
5e805e44 JJ |
609 | dtp->u.p.nml_read_error = 1; |
610 | unget_char (dtp, c); | |
29dc5138 PT |
611 | return 1; |
612 | } | |
613 | return 0; | |
614 | } | |
6de9cd9a | 615 | |
7fcb1804 TS |
616 | /* Convert an unsigned string to an integer. The length value is -1 |
617 | if we are working on a repeat count. Returns nonzero if we have a | |
5e805e44 | 618 | range problem. As a side effect, frees the dtp->u.p.saved_string. */ |
6de9cd9a DN |
619 | |
620 | static int | |
5e805e44 | 621 | convert_integer (st_parameter_dt *dtp, int length, int negative) |
6de9cd9a | 622 | { |
d30fe1c5 | 623 | char c, *buffer, message[MSGLEN]; |
6de9cd9a | 624 | int m; |
80b91c0b JB |
625 | GFC_UINTEGER_LARGEST v, max, max10; |
626 | GFC_INTEGER_LARGEST value; | |
6de9cd9a | 627 | |
5e805e44 | 628 | buffer = dtp->u.p.saved_string; |
6de9cd9a DN |
629 | v = 0; |
630 | ||
80b91c0b JB |
631 | if (length == -1) |
632 | max = MAX_REPEAT; | |
633 | else | |
634 | { | |
635 | max = si_max (length); | |
636 | if (negative) | |
637 | max++; | |
638 | } | |
6de9cd9a DN |
639 | max10 = max / 10; |
640 | ||
641 | for (;;) | |
642 | { | |
643 | c = *buffer++; | |
644 | if (c == '\0') | |
645 | break; | |
646 | c -= '0'; | |
647 | ||
648 | if (v > max10) | |
649 | goto overflow; | |
650 | v = 10 * v; | |
651 | ||
652 | if (v > max - c) | |
653 | goto overflow; | |
654 | v += c; | |
655 | } | |
656 | ||
657 | m = 0; | |
658 | ||
659 | if (length != -1) | |
660 | { | |
661 | if (negative) | |
80b91c0b JB |
662 | value = -v; |
663 | else | |
664 | value = v; | |
665 | set_integer (dtp->u.p.value, value, length); | |
6de9cd9a DN |
666 | } |
667 | else | |
668 | { | |
5e805e44 | 669 | dtp->u.p.repeat_count = v; |
6de9cd9a | 670 | |
5e805e44 | 671 | if (dtp->u.p.repeat_count == 0) |
6de9cd9a | 672 | { |
d30fe1c5 | 673 | snprintf (message, MSGLEN, "Zero repeat count in item %d of list input", |
d8163f5c | 674 | dtp->u.p.item_count); |
6de9cd9a | 675 | |
d74b97cc | 676 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
677 | m = 1; |
678 | } | |
679 | } | |
680 | ||
5e805e44 | 681 | free_saved (dtp); |
6de9cd9a DN |
682 | return m; |
683 | ||
f21edfd6 | 684 | overflow: |
6de9cd9a | 685 | if (length == -1) |
d30fe1c5 | 686 | snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input", |
d8163f5c | 687 | dtp->u.p.item_count); |
6de9cd9a | 688 | else |
d30fe1c5 | 689 | snprintf (message, MSGLEN, "Integer overflow while reading item %d", |
d8163f5c | 690 | dtp->u.p.item_count); |
6de9cd9a | 691 | |
5e805e44 | 692 | free_saved (dtp); |
d74b97cc | 693 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
694 | |
695 | return 1; | |
696 | } | |
697 | ||
698 | ||
7fcb1804 TS |
699 | /* Parse a repeat count for logical and complex values which cannot |
700 | begin with a digit. Returns nonzero if we are done, zero if we | |
701 | should continue on. */ | |
6de9cd9a DN |
702 | |
703 | static int | |
5e805e44 | 704 | parse_repeat (st_parameter_dt *dtp) |
6de9cd9a | 705 | { |
d30fe1c5 | 706 | char message[MSGLEN]; |
c86af7f3 | 707 | int c, repeat; |
6de9cd9a | 708 | |
c86af7f3 JB |
709 | if ((c = next_char (dtp)) == EOF) |
710 | goto bad_repeat; | |
6de9cd9a DN |
711 | switch (c) |
712 | { | |
713 | CASE_DIGITS: | |
714 | repeat = c - '0'; | |
715 | break; | |
716 | ||
717 | CASE_SEPARATORS: | |
5e805e44 JJ |
718 | unget_char (dtp, c); |
719 | eat_separator (dtp); | |
6de9cd9a DN |
720 | return 1; |
721 | ||
722 | default: | |
5e805e44 | 723 | unget_char (dtp, c); |
6de9cd9a DN |
724 | return 0; |
725 | } | |
726 | ||
727 | for (;;) | |
728 | { | |
5e805e44 | 729 | c = next_char (dtp); |
6de9cd9a DN |
730 | switch (c) |
731 | { | |
732 | CASE_DIGITS: | |
733 | repeat = 10 * repeat + c - '0'; | |
734 | ||
735 | if (repeat > MAX_REPEAT) | |
736 | { | |
d30fe1c5 | 737 | snprintf (message, MSGLEN, |
d8163f5c TK |
738 | "Repeat count overflow in item %d of list input", |
739 | dtp->u.p.item_count); | |
6de9cd9a | 740 | |
d74b97cc | 741 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
742 | return 1; |
743 | } | |
744 | ||
745 | break; | |
746 | ||
747 | case '*': | |
748 | if (repeat == 0) | |
749 | { | |
d30fe1c5 | 750 | snprintf (message, MSGLEN, |
d8163f5c TK |
751 | "Zero repeat count in item %d of list input", |
752 | dtp->u.p.item_count); | |
6de9cd9a | 753 | |
d74b97cc | 754 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
755 | return 1; |
756 | } | |
757 | ||
758 | goto done; | |
759 | ||
760 | default: | |
761 | goto bad_repeat; | |
762 | } | |
763 | } | |
764 | ||
f21edfd6 | 765 | done: |
5e805e44 | 766 | dtp->u.p.repeat_count = repeat; |
6de9cd9a DN |
767 | return 0; |
768 | ||
f21edfd6 | 769 | bad_repeat: |
9855448d | 770 | |
9855448d | 771 | free_saved (dtp); |
c86af7f3 JB |
772 | if (c == EOF) |
773 | { | |
79029289 | 774 | free_line (dtp); |
c86af7f3 JB |
775 | hit_eof (dtp); |
776 | return 1; | |
777 | } | |
778 | else | |
779 | eat_line (dtp); | |
d30fe1c5 | 780 | snprintf (message, MSGLEN, "Bad repeat count in item %d of list input", |
d8163f5c | 781 | dtp->u.p.item_count); |
d74b97cc | 782 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
783 | return 1; |
784 | } | |
785 | ||
786 | ||
c9f15d9c | 787 | /* To read a logical we have to look ahead in the input stream to make sure |
fc12098d | 788 | there is not an equal sign indicating a variable name. To do this we use |
c9f15d9c JD |
789 | line_buffer to point to a temporary buffer, pushing characters there for |
790 | possible later reading. */ | |
791 | ||
792 | static void | |
793 | l_push_char (st_parameter_dt *dtp, char c) | |
794 | { | |
c9f15d9c | 795 | if (dtp->u.p.line_buffer == NULL) |
f4471acb | 796 | dtp->u.p.line_buffer = xcalloc (SCRATCH_SIZE, 1); |
c9f15d9c | 797 | |
2558e2e8 | 798 | dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos++] = c; |
c9f15d9c JD |
799 | } |
800 | ||
801 | ||
7fcb1804 | 802 | /* Read a logical character on the input. */ |
6de9cd9a DN |
803 | |
804 | static void | |
5e805e44 | 805 | read_logical (st_parameter_dt *dtp, int length) |
6de9cd9a | 806 | { |
d30fe1c5 | 807 | char message[MSGLEN]; |
c86af7f3 | 808 | int c, i, v; |
6de9cd9a | 809 | |
5e805e44 | 810 | if (parse_repeat (dtp)) |
6de9cd9a DN |
811 | return; |
812 | ||
21423a1d | 813 | c = safe_tolower (next_char (dtp)); |
c9f15d9c | 814 | l_push_char (dtp, c); |
6de9cd9a DN |
815 | switch (c) |
816 | { | |
817 | case 't': | |
6de9cd9a | 818 | v = 1; |
5f547104 | 819 | c = next_char (dtp); |
c9f15d9c JD |
820 | l_push_char (dtp, c); |
821 | ||
5f547104 | 822 | if (!is_separator(c) && c != EOF) |
c9f15d9c JD |
823 | goto possible_name; |
824 | ||
825 | unget_char (dtp, c); | |
6de9cd9a DN |
826 | break; |
827 | case 'f': | |
6de9cd9a | 828 | v = 0; |
5f547104 | 829 | c = next_char (dtp); |
c9f15d9c | 830 | l_push_char (dtp, c); |
6de9cd9a | 831 | |
5f547104 | 832 | if (!is_separator(c) && c != EOF) |
c9f15d9c JD |
833 | goto possible_name; |
834 | ||
835 | unget_char (dtp, c); | |
836 | break; | |
10256cbe | 837 | |
6de9cd9a | 838 | case '.': |
21423a1d | 839 | c = safe_tolower (next_char (dtp)); |
6de9cd9a DN |
840 | switch (c) |
841 | { | |
c9f15d9c JD |
842 | case 't': |
843 | v = 1; | |
844 | break; | |
845 | case 'f': | |
846 | v = 0; | |
847 | break; | |
848 | default: | |
849 | goto bad_logical; | |
6de9cd9a DN |
850 | } |
851 | ||
852 | break; | |
853 | ||
fc12098d JD |
854 | case '!': |
855 | if (!dtp->u.p.namelist_mode) | |
856 | goto bad_logical; | |
857 | ||
6de9cd9a | 858 | CASE_SEPARATORS: |
cc186345 | 859 | case EOF: |
5e805e44 JJ |
860 | unget_char (dtp, c); |
861 | eat_separator (dtp); | |
7fcb1804 | 862 | return; /* Null value. */ |
6de9cd9a DN |
863 | |
864 | default: | |
17f46ec3 JD |
865 | /* Save the character in case it is the beginning |
866 | of the next object name. */ | |
867 | unget_char (dtp, c); | |
6de9cd9a DN |
868 | goto bad_logical; |
869 | } | |
870 | ||
5e805e44 JJ |
871 | dtp->u.p.saved_type = BT_LOGICAL; |
872 | dtp->u.p.saved_length = length; | |
6de9cd9a | 873 | |
7fcb1804 | 874 | /* Eat trailing garbage. */ |
6de9cd9a | 875 | do |
c86af7f3 JB |
876 | c = next_char (dtp); |
877 | while (c != EOF && !is_separator (c)); | |
6de9cd9a | 878 | |
5e805e44 JJ |
879 | unget_char (dtp, c); |
880 | eat_separator (dtp); | |
5e805e44 | 881 | set_integer ((int *) dtp->u.p.value, v, length); |
4e72e1c5 | 882 | free_line (dtp); |
6de9cd9a DN |
883 | |
884 | return; | |
885 | ||
c9f15d9c JD |
886 | possible_name: |
887 | ||
888 | for(i = 0; i < 63; i++) | |
889 | { | |
890 | c = next_char (dtp); | |
891 | if (is_separator(c)) | |
892 | { | |
03e957f8 JD |
893 | /* All done if this is not a namelist read. */ |
894 | if (!dtp->u.p.namelist_mode) | |
895 | goto logical_done; | |
896 | ||
c9f15d9c JD |
897 | unget_char (dtp, c); |
898 | eat_separator (dtp); | |
899 | c = next_char (dtp); | |
900 | if (c != '=') | |
901 | { | |
902 | unget_char (dtp, c); | |
03e957f8 | 903 | goto logical_done; |
c9f15d9c JD |
904 | } |
905 | } | |
fc12098d | 906 | |
c9f15d9c JD |
907 | l_push_char (dtp, c); |
908 | if (c == '=') | |
909 | { | |
910 | dtp->u.p.nml_read_error = 1; | |
911 | dtp->u.p.line_buffer_enabled = 1; | |
2558e2e8 | 912 | dtp->u.p.line_buffer_pos = 0; |
c9f15d9c JD |
913 | return; |
914 | } | |
fc12098d | 915 | |
03e957f8 | 916 | } |
c9f15d9c | 917 | |
f21edfd6 | 918 | bad_logical: |
29dc5138 | 919 | |
5e805e44 | 920 | if (nml_bad_return (dtp, c)) |
2558e2e8 JD |
921 | { |
922 | free_line (dtp); | |
923 | return; | |
924 | } | |
925 | ||
29dc5138 | 926 | |
9855448d | 927 | free_saved (dtp); |
c86af7f3 JB |
928 | if (c == EOF) |
929 | { | |
2558e2e8 | 930 | free_line (dtp); |
c86af7f3 JB |
931 | hit_eof (dtp); |
932 | return; | |
933 | } | |
fc2c5998 | 934 | else if (c != '\n') |
c86af7f3 | 935 | eat_line (dtp); |
d30fe1c5 | 936 | snprintf (message, MSGLEN, "Bad logical value while reading item %d", |
5e805e44 | 937 | dtp->u.p.item_count); |
2558e2e8 | 938 | free_line (dtp); |
d74b97cc | 939 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
03e957f8 JD |
940 | return; |
941 | ||
942 | logical_done: | |
4e72e1c5 | 943 | |
03e957f8 JD |
944 | dtp->u.p.saved_type = BT_LOGICAL; |
945 | dtp->u.p.saved_length = length; | |
946 | set_integer ((int *) dtp->u.p.value, v, length); | |
4e72e1c5 JD |
947 | free_saved (dtp); |
948 | free_line (dtp); | |
6de9cd9a DN |
949 | } |
950 | ||
951 | ||
7fcb1804 TS |
952 | /* Reading integers is tricky because we can actually be reading a |
953 | repeat count. We have to store the characters in a buffer because | |
954 | we could be reading an integer that is larger than the default int | |
955 | used for repeat counts. */ | |
6de9cd9a DN |
956 | |
957 | static void | |
5e805e44 | 958 | read_integer (st_parameter_dt *dtp, int length) |
6de9cd9a | 959 | { |
d30fe1c5 | 960 | char message[MSGLEN]; |
c86af7f3 | 961 | int c, negative; |
6de9cd9a DN |
962 | |
963 | negative = 0; | |
964 | ||
5e805e44 | 965 | c = next_char (dtp); |
6de9cd9a DN |
966 | switch (c) |
967 | { | |
968 | case '-': | |
969 | negative = 1; | |
7fcb1804 | 970 | /* Fall through... */ |
6de9cd9a DN |
971 | |
972 | case '+': | |
c86af7f3 JB |
973 | if ((c = next_char (dtp)) == EOF) |
974 | goto bad_integer; | |
6de9cd9a DN |
975 | goto get_integer; |
976 | ||
fc12098d JD |
977 | case '!': |
978 | if (!dtp->u.p.namelist_mode) | |
979 | goto bad_integer; | |
980 | ||
7fcb1804 | 981 | CASE_SEPARATORS: /* Single null. */ |
5e805e44 JJ |
982 | unget_char (dtp, c); |
983 | eat_separator (dtp); | |
6de9cd9a DN |
984 | return; |
985 | ||
986 | CASE_DIGITS: | |
5e805e44 | 987 | push_char (dtp, c); |
6de9cd9a DN |
988 | break; |
989 | ||
990 | default: | |
991 | goto bad_integer; | |
992 | } | |
993 | ||
7fcb1804 | 994 | /* Take care of what may be a repeat count. */ |
6de9cd9a DN |
995 | |
996 | for (;;) | |
997 | { | |
5e805e44 | 998 | c = next_char (dtp); |
6de9cd9a DN |
999 | switch (c) |
1000 | { | |
1001 | CASE_DIGITS: | |
5e805e44 | 1002 | push_char (dtp, c); |
6de9cd9a DN |
1003 | break; |
1004 | ||
1005 | case '*': | |
5e805e44 | 1006 | push_char (dtp, '\0'); |
6de9cd9a DN |
1007 | goto repeat; |
1008 | ||
fc12098d JD |
1009 | case '!': |
1010 | if (!dtp->u.p.namelist_mode) | |
1011 | goto bad_integer; | |
1012 | ||
7fcb1804 | 1013 | CASE_SEPARATORS: /* Not a repeat count. */ |
5f547104 | 1014 | case EOF: |
6de9cd9a DN |
1015 | goto done; |
1016 | ||
1017 | default: | |
1018 | goto bad_integer; | |
1019 | } | |
1020 | } | |
1021 | ||
f21edfd6 | 1022 | repeat: |
5e805e44 | 1023 | if (convert_integer (dtp, -1, 0)) |
6de9cd9a DN |
1024 | return; |
1025 | ||
7fcb1804 | 1026 | /* Get the real integer. */ |
6de9cd9a | 1027 | |
c86af7f3 JB |
1028 | if ((c = next_char (dtp)) == EOF) |
1029 | goto bad_integer; | |
6de9cd9a DN |
1030 | switch (c) |
1031 | { | |
1032 | CASE_DIGITS: | |
1033 | break; | |
1034 | ||
fc12098d JD |
1035 | case '!': |
1036 | if (!dtp->u.p.namelist_mode) | |
1037 | goto bad_integer; | |
1038 | ||
6de9cd9a | 1039 | CASE_SEPARATORS: |
5e805e44 JJ |
1040 | unget_char (dtp, c); |
1041 | eat_separator (dtp); | |
6de9cd9a DN |
1042 | return; |
1043 | ||
1044 | case '-': | |
1045 | negative = 1; | |
7fcb1804 | 1046 | /* Fall through... */ |
6de9cd9a DN |
1047 | |
1048 | case '+': | |
5e805e44 | 1049 | c = next_char (dtp); |
6de9cd9a DN |
1050 | break; |
1051 | } | |
1052 | ||
f21edfd6 | 1053 | get_integer: |
21423a1d | 1054 | if (!safe_isdigit (c)) |
6de9cd9a | 1055 | goto bad_integer; |
5e805e44 | 1056 | push_char (dtp, c); |
6de9cd9a DN |
1057 | |
1058 | for (;;) | |
1059 | { | |
5e805e44 | 1060 | c = next_char (dtp); |
6de9cd9a DN |
1061 | switch (c) |
1062 | { | |
1063 | CASE_DIGITS: | |
5e805e44 | 1064 | push_char (dtp, c); |
6de9cd9a DN |
1065 | break; |
1066 | ||
fc12098d JD |
1067 | case '!': |
1068 | if (!dtp->u.p.namelist_mode) | |
1069 | goto bad_integer; | |
1070 | ||
6de9cd9a | 1071 | CASE_SEPARATORS: |
5f547104 | 1072 | case EOF: |
6de9cd9a DN |
1073 | goto done; |
1074 | ||
1075 | default: | |
1076 | goto bad_integer; | |
1077 | } | |
1078 | } | |
1079 | ||
f21edfd6 | 1080 | bad_integer: |
29dc5138 | 1081 | |
5e805e44 | 1082 | if (nml_bad_return (dtp, c)) |
29dc5138 | 1083 | return; |
c86af7f3 | 1084 | |
fc12098d | 1085 | free_saved (dtp); |
c86af7f3 JB |
1086 | if (c == EOF) |
1087 | { | |
79029289 | 1088 | free_line (dtp); |
c86af7f3 JB |
1089 | hit_eof (dtp); |
1090 | return; | |
1091 | } | |
fc2c5998 | 1092 | else if (c != '\n') |
c86af7f3 | 1093 | eat_line (dtp); |
79029289 | 1094 | |
d30fe1c5 | 1095 | snprintf (message, MSGLEN, "Bad integer for item %d in list input", |
5e805e44 | 1096 | dtp->u.p.item_count); |
2558e2e8 | 1097 | free_line (dtp); |
d74b97cc | 1098 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1099 | |
1100 | return; | |
1101 | ||
f21edfd6 | 1102 | done: |
5e805e44 JJ |
1103 | unget_char (dtp, c); |
1104 | eat_separator (dtp); | |
6de9cd9a | 1105 | |
5e805e44 JJ |
1106 | push_char (dtp, '\0'); |
1107 | if (convert_integer (dtp, length, negative)) | |
6de9cd9a | 1108 | { |
5e805e44 | 1109 | free_saved (dtp); |
6de9cd9a DN |
1110 | return; |
1111 | } | |
1112 | ||
5e805e44 JJ |
1113 | free_saved (dtp); |
1114 | dtp->u.p.saved_type = BT_INTEGER; | |
6de9cd9a DN |
1115 | } |
1116 | ||
1117 | ||
7fcb1804 | 1118 | /* Read a character variable. */ |
6de9cd9a DN |
1119 | |
1120 | static void | |
5e805e44 | 1121 | read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) |
6de9cd9a | 1122 | { |
d30fe1c5 | 1123 | char quote, message[MSGLEN]; |
c86af7f3 | 1124 | int c; |
6de9cd9a | 1125 | |
7fcb1804 | 1126 | quote = ' '; /* Space means no quote character. */ |
6de9cd9a | 1127 | |
c86af7f3 JB |
1128 | if ((c = next_char (dtp)) == EOF) |
1129 | goto eof; | |
6de9cd9a DN |
1130 | switch (c) |
1131 | { | |
1132 | CASE_DIGITS: | |
5e805e44 | 1133 | push_char (dtp, c); |
6de9cd9a DN |
1134 | break; |
1135 | ||
1136 | CASE_SEPARATORS: | |
cc186345 | 1137 | case EOF: |
5e805e44 JJ |
1138 | unget_char (dtp, c); /* NULL value. */ |
1139 | eat_separator (dtp); | |
6de9cd9a DN |
1140 | return; |
1141 | ||
1142 | case '"': | |
1143 | case '\'': | |
1144 | quote = c; | |
1145 | goto get_string; | |
1146 | ||
1147 | default: | |
808a2225 | 1148 | if (dtp->u.p.namelist_mode) |
c4a108fd | 1149 | { |
a7f5d054 JD |
1150 | unget_char (dtp, c); |
1151 | return; | |
c4a108fd | 1152 | } |
5e805e44 | 1153 | push_char (dtp, c); |
6de9cd9a DN |
1154 | goto get_string; |
1155 | } | |
1156 | ||
7fcb1804 | 1157 | /* Deal with a possible repeat count. */ |
6de9cd9a DN |
1158 | |
1159 | for (;;) | |
1160 | { | |
cc186345 | 1161 | c = next_char (dtp); |
6de9cd9a DN |
1162 | switch (c) |
1163 | { | |
1164 | CASE_DIGITS: | |
5e805e44 | 1165 | push_char (dtp, c); |
6de9cd9a DN |
1166 | break; |
1167 | ||
1168 | CASE_SEPARATORS: | |
cc186345 | 1169 | case EOF: |
5e805e44 | 1170 | unget_char (dtp, c); |
7fcb1804 | 1171 | goto done; /* String was only digits! */ |
6de9cd9a DN |
1172 | |
1173 | case '*': | |
5e805e44 | 1174 | push_char (dtp, '\0'); |
6de9cd9a DN |
1175 | goto got_repeat; |
1176 | ||
1177 | default: | |
5e805e44 | 1178 | push_char (dtp, c); |
7fcb1804 | 1179 | goto get_string; /* Not a repeat count after all. */ |
6de9cd9a DN |
1180 | } |
1181 | } | |
1182 | ||
f21edfd6 | 1183 | got_repeat: |
5e805e44 | 1184 | if (convert_integer (dtp, -1, 0)) |
6de9cd9a DN |
1185 | return; |
1186 | ||
7fcb1804 | 1187 | /* Now get the real string. */ |
6de9cd9a | 1188 | |
c86af7f3 JB |
1189 | if ((c = next_char (dtp)) == EOF) |
1190 | goto eof; | |
6de9cd9a DN |
1191 | switch (c) |
1192 | { | |
1193 | CASE_SEPARATORS: | |
5e805e44 JJ |
1194 | unget_char (dtp, c); /* Repeated NULL values. */ |
1195 | eat_separator (dtp); | |
6de9cd9a DN |
1196 | return; |
1197 | ||
1198 | case '"': | |
1199 | case '\'': | |
1200 | quote = c; | |
1201 | break; | |
1202 | ||
1203 | default: | |
5e805e44 | 1204 | push_char (dtp, c); |
6de9cd9a DN |
1205 | break; |
1206 | } | |
1207 | ||
f21edfd6 | 1208 | get_string: |
6de9cd9a | 1209 | |
d428be77 JD |
1210 | for (;;) |
1211 | { | |
1212 | if ((c = next_char (dtp)) == EOF) | |
1213 | goto done_eof; | |
1214 | switch (c) | |
1215 | { | |
1216 | case '"': | |
1217 | case '\'': | |
1218 | if (c != quote) | |
1219 | { | |
1220 | push_char (dtp, c); | |
1221 | break; | |
1222 | } | |
fc12098d | 1223 | |
d428be77 JD |
1224 | /* See if we have a doubled quote character or the end of |
1225 | the string. */ | |
fc12098d | 1226 | |
d428be77 JD |
1227 | if ((c = next_char (dtp)) == EOF) |
1228 | goto done_eof; | |
1229 | if (c == quote) | |
1230 | { | |
1231 | push_char (dtp, quote); | |
1232 | break; | |
1233 | } | |
fc12098d | 1234 | |
d428be77 JD |
1235 | unget_char (dtp, c); |
1236 | goto done; | |
fc12098d | 1237 | |
d428be77 JD |
1238 | CASE_SEPARATORS: |
1239 | if (quote == ' ') | |
1240 | { | |
1241 | unget_char (dtp, c); | |
1242 | goto done; | |
1243 | } | |
fc12098d | 1244 | |
d428be77 | 1245 | if (c != '\n' && c != '\r') |
5e805e44 | 1246 | push_char (dtp, c); |
d428be77 | 1247 | break; |
fc12098d | 1248 | |
d428be77 JD |
1249 | default: |
1250 | push_char (dtp, c); | |
1251 | break; | |
1252 | } | |
1253 | } | |
6de9cd9a | 1254 | |
f21edfd6 RH |
1255 | /* At this point, we have to have a separator, or else the string is |
1256 | invalid. */ | |
1257 | done: | |
5e805e44 | 1258 | c = next_char (dtp); |
d3ff9ee4 | 1259 | done_eof: |
fc12098d | 1260 | if (is_separator (c) || c == EOF) |
6de9cd9a | 1261 | { |
5e805e44 JJ |
1262 | unget_char (dtp, c); |
1263 | eat_separator (dtp); | |
1264 | dtp->u.p.saved_type = BT_CHARACTER; | |
6de9cd9a | 1265 | } |
fc12098d | 1266 | else |
6de9cd9a | 1267 | { |
5e805e44 | 1268 | free_saved (dtp); |
d30fe1c5 | 1269 | snprintf (message, MSGLEN, "Invalid string input in item %d", |
5e805e44 | 1270 | dtp->u.p.item_count); |
d74b97cc | 1271 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a | 1272 | } |
79029289 | 1273 | free_line (dtp); |
d3ff9ee4 JB |
1274 | return; |
1275 | ||
1276 | eof: | |
1277 | free_saved (dtp); | |
79029289 | 1278 | free_line (dtp); |
d3ff9ee4 | 1279 | hit_eof (dtp); |
6de9cd9a DN |
1280 | } |
1281 | ||
1282 | ||
7fcb1804 TS |
1283 | /* Parse a component of a complex constant or a real number that we |
1284 | are sure is already there. This is a straight real number parser. */ | |
6de9cd9a DN |
1285 | |
1286 | static int | |
5e805e44 | 1287 | parse_real (st_parameter_dt *dtp, void *buffer, int length) |
6de9cd9a | 1288 | { |
d30fe1c5 | 1289 | char message[MSGLEN]; |
c86af7f3 | 1290 | int c, m, seen_dp; |
6de9cd9a | 1291 | |
c86af7f3 JB |
1292 | if ((c = next_char (dtp)) == EOF) |
1293 | goto bad; | |
fc12098d | 1294 | |
6de9cd9a DN |
1295 | if (c == '-' || c == '+') |
1296 | { | |
5e805e44 | 1297 | push_char (dtp, c); |
c86af7f3 JB |
1298 | if ((c = next_char (dtp)) == EOF) |
1299 | goto bad; | |
6de9cd9a DN |
1300 | } |
1301 | ||
105b7136 | 1302 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1303 | c = '.'; |
fc12098d | 1304 | |
21423a1d | 1305 | if (!safe_isdigit (c) && c != '.') |
c9f7e825 TB |
1306 | { |
1307 | if (c == 'i' || c == 'I' || c == 'n' || c == 'N') | |
1308 | goto inf_nan; | |
1309 | else | |
1310 | goto bad; | |
1311 | } | |
6de9cd9a | 1312 | |
5e805e44 | 1313 | push_char (dtp, c); |
6de9cd9a DN |
1314 | |
1315 | seen_dp = (c == '.') ? 1 : 0; | |
1316 | ||
1317 | for (;;) | |
1318 | { | |
c86af7f3 JB |
1319 | if ((c = next_char (dtp)) == EOF) |
1320 | goto bad; | |
105b7136 | 1321 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1322 | c = '.'; |
6de9cd9a DN |
1323 | switch (c) |
1324 | { | |
1325 | CASE_DIGITS: | |
5e805e44 | 1326 | push_char (dtp, c); |
6de9cd9a DN |
1327 | break; |
1328 | ||
1329 | case '.': | |
1330 | if (seen_dp) | |
1331 | goto bad; | |
1332 | ||
1333 | seen_dp = 1; | |
5e805e44 | 1334 | push_char (dtp, c); |
6de9cd9a DN |
1335 | break; |
1336 | ||
1337 | case 'e': | |
1338 | case 'E': | |
1339 | case 'd': | |
1340 | case 'D': | |
96b3ee1c TB |
1341 | case 'q': |
1342 | case 'Q': | |
5e805e44 | 1343 | push_char (dtp, 'e'); |
6de9cd9a DN |
1344 | goto exp1; |
1345 | ||
1346 | case '-': | |
1347 | case '+': | |
5e805e44 JJ |
1348 | push_char (dtp, 'e'); |
1349 | push_char (dtp, c); | |
c86af7f3 JB |
1350 | if ((c = next_char (dtp)) == EOF) |
1351 | goto bad; | |
6de9cd9a DN |
1352 | goto exp2; |
1353 | ||
fc12098d JD |
1354 | case '!': |
1355 | if (!dtp->u.p.namelist_mode) | |
1356 | goto bad; | |
1357 | ||
6de9cd9a | 1358 | CASE_SEPARATORS: |
cc186345 | 1359 | case EOF: |
6de9cd9a DN |
1360 | goto done; |
1361 | ||
1362 | default: | |
1363 | goto done; | |
1364 | } | |
1365 | } | |
1366 | ||
f21edfd6 | 1367 | exp1: |
c86af7f3 JB |
1368 | if ((c = next_char (dtp)) == EOF) |
1369 | goto bad; | |
6de9cd9a | 1370 | if (c != '-' && c != '+') |
5e805e44 | 1371 | push_char (dtp, '+'); |
6de9cd9a DN |
1372 | else |
1373 | { | |
5e805e44 JJ |
1374 | push_char (dtp, c); |
1375 | c = next_char (dtp); | |
6de9cd9a DN |
1376 | } |
1377 | ||
f21edfd6 | 1378 | exp2: |
21423a1d | 1379 | if (!safe_isdigit (c)) |
6869e9c6 FR |
1380 | { |
1381 | /* Extension: allow default exponent of 0 when omitted. */ | |
7ee4f6f3 | 1382 | if (dtp->common.flags & IOPARM_DT_DEC_EXT) |
6869e9c6 FR |
1383 | { |
1384 | push_char (dtp, '0'); | |
1385 | goto done; | |
1386 | } | |
1387 | else | |
1388 | goto bad_exponent; | |
1389 | } | |
c9f7e825 | 1390 | |
5e805e44 | 1391 | push_char (dtp, c); |
6de9cd9a DN |
1392 | |
1393 | for (;;) | |
1394 | { | |
c86af7f3 JB |
1395 | if ((c = next_char (dtp)) == EOF) |
1396 | goto bad; | |
6de9cd9a DN |
1397 | switch (c) |
1398 | { | |
1399 | CASE_DIGITS: | |
5e805e44 | 1400 | push_char (dtp, c); |
6de9cd9a DN |
1401 | break; |
1402 | ||
fc12098d JD |
1403 | case '!': |
1404 | if (!dtp->u.p.namelist_mode) | |
1405 | goto bad; | |
1406 | ||
6de9cd9a | 1407 | CASE_SEPARATORS: |
cc186345 | 1408 | case EOF: |
5e805e44 | 1409 | unget_char (dtp, c); |
6de9cd9a DN |
1410 | goto done; |
1411 | ||
1412 | default: | |
1413 | goto done; | |
1414 | } | |
1415 | } | |
1416 | ||
f21edfd6 | 1417 | done: |
5e805e44 JJ |
1418 | unget_char (dtp, c); |
1419 | push_char (dtp, '\0'); | |
6de9cd9a | 1420 | |
5e805e44 JJ |
1421 | m = convert_real (dtp, buffer, dtp->u.p.saved_string, length); |
1422 | free_saved (dtp); | |
6de9cd9a DN |
1423 | |
1424 | return m; | |
1425 | ||
458653cc JDA |
1426 | done_infnan: |
1427 | unget_char (dtp, c); | |
1428 | push_char (dtp, '\0'); | |
1429 | ||
1430 | m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length); | |
1431 | free_saved (dtp); | |
1432 | ||
1433 | return m; | |
1434 | ||
c9f7e825 TB |
1435 | inf_nan: |
1436 | /* Match INF and Infinity. */ | |
1437 | if ((c == 'i' || c == 'I') | |
1438 | && ((c = next_char (dtp)) == 'n' || c == 'N') | |
1439 | && ((c = next_char (dtp)) == 'f' || c == 'F')) | |
1440 | { | |
1441 | c = next_char (dtp); | |
1442 | if ((c != 'i' && c != 'I') | |
1443 | || ((c == 'i' || c == 'I') | |
1444 | && ((c = next_char (dtp)) == 'n' || c == 'N') | |
1445 | && ((c = next_char (dtp)) == 'i' || c == 'I') | |
1446 | && ((c = next_char (dtp)) == 't' || c == 'T') | |
1447 | && ((c = next_char (dtp)) == 'y' || c == 'Y') | |
1448 | && (c = next_char (dtp)))) | |
1449 | { | |
cc186345 | 1450 | if (is_separator (c) || (c == EOF)) |
c9f7e825 TB |
1451 | unget_char (dtp, c); |
1452 | push_char (dtp, 'i'); | |
1453 | push_char (dtp, 'n'); | |
1454 | push_char (dtp, 'f'); | |
458653cc | 1455 | goto done_infnan; |
c9f7e825 TB |
1456 | } |
1457 | } /* Match NaN. */ | |
1458 | else if (((c = next_char (dtp)) == 'a' || c == 'A') | |
1459 | && ((c = next_char (dtp)) == 'n' || c == 'N') | |
1460 | && (c = next_char (dtp))) | |
1461 | { | |
cc186345 | 1462 | if (is_separator (c) || (c == EOF)) |
c9f7e825 TB |
1463 | unget_char (dtp, c); |
1464 | push_char (dtp, 'n'); | |
1465 | push_char (dtp, 'a'); | |
1466 | push_char (dtp, 'n'); | |
fc12098d | 1467 | |
83377c6a TB |
1468 | /* Match "NAN(alphanum)". */ |
1469 | if (c == '(') | |
1470 | { | |
1471 | for ( ; c != ')'; c = next_char (dtp)) | |
1472 | if (is_separator (c)) | |
1473 | goto bad; | |
83377c6a | 1474 | |
83377c6a | 1475 | c = next_char (dtp); |
cc186345 | 1476 | if (is_separator (c) || (c == EOF)) |
83377c6a TB |
1477 | unget_char (dtp, c); |
1478 | } | |
458653cc | 1479 | goto done_infnan; |
c9f7e825 TB |
1480 | } |
1481 | ||
f21edfd6 | 1482 | bad: |
9855448d JD |
1483 | |
1484 | if (nml_bad_return (dtp, c)) | |
1485 | return 0; | |
1486 | ||
64a454d9 JD |
1487 | bad_exponent: |
1488 | ||
5e805e44 | 1489 | free_saved (dtp); |
c86af7f3 JB |
1490 | if (c == EOF) |
1491 | { | |
79029289 | 1492 | free_line (dtp); |
c86af7f3 JB |
1493 | hit_eof (dtp); |
1494 | return 1; | |
1495 | } | |
fc2c5998 | 1496 | else if (c != '\n') |
c86af7f3 | 1497 | eat_line (dtp); |
79029289 | 1498 | |
64a454d9 JD |
1499 | snprintf (message, MSGLEN, "Bad complex floating point " |
1500 | "number for item %d", dtp->u.p.item_count); | |
2558e2e8 | 1501 | free_line (dtp); |
d74b97cc | 1502 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1503 | |
1504 | return 1; | |
1505 | } | |
1506 | ||
1507 | ||
7fcb1804 TS |
1508 | /* Reading a complex number is straightforward because we can tell |
1509 | what it is right away. */ | |
6de9cd9a DN |
1510 | |
1511 | static void | |
f29876bb | 1512 | read_complex (st_parameter_dt *dtp, void *dest, int kind, size_t size) |
6de9cd9a | 1513 | { |
d30fe1c5 | 1514 | char message[MSGLEN]; |
c86af7f3 | 1515 | int c; |
6de9cd9a | 1516 | |
5e805e44 | 1517 | if (parse_repeat (dtp)) |
6de9cd9a DN |
1518 | return; |
1519 | ||
5e805e44 | 1520 | c = next_char (dtp); |
6de9cd9a DN |
1521 | switch (c) |
1522 | { | |
1523 | case '(': | |
1524 | break; | |
1525 | ||
fc12098d JD |
1526 | case '!': |
1527 | if (!dtp->u.p.namelist_mode) | |
1528 | goto bad_complex; | |
1529 | ||
6de9cd9a | 1530 | CASE_SEPARATORS: |
cc186345 | 1531 | case EOF: |
5e805e44 JJ |
1532 | unget_char (dtp, c); |
1533 | eat_separator (dtp); | |
6de9cd9a DN |
1534 | return; |
1535 | ||
1536 | default: | |
1537 | goto bad_complex; | |
1538 | } | |
1539 | ||
fc2c5998 | 1540 | eol_1: |
5e805e44 | 1541 | eat_spaces (dtp); |
fc2c5998 JD |
1542 | c = next_char (dtp); |
1543 | if (c == '\n' || c== '\r') | |
1544 | goto eol_1; | |
1545 | else | |
1546 | unget_char (dtp, c); | |
1547 | ||
6b680210 | 1548 | if (parse_real (dtp, dest, kind)) |
6de9cd9a DN |
1549 | return; |
1550 | ||
fc2c5998 | 1551 | eol_2: |
5e805e44 JJ |
1552 | eat_spaces (dtp); |
1553 | c = next_char (dtp); | |
b125b4cf | 1554 | if (c == '\n' || c== '\r') |
fc2c5998 | 1555 | goto eol_2; |
b125b4cf | 1556 | else |
5e805e44 | 1557 | unget_char (dtp, c); |
b125b4cf | 1558 | |
105b7136 JD |
1559 | if (next_char (dtp) |
1560 | != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';')) | |
1561 | goto bad_complex; | |
6de9cd9a | 1562 | |
fc2c5998 | 1563 | eol_3: |
5e805e44 JJ |
1564 | eat_spaces (dtp); |
1565 | c = next_char (dtp); | |
b125b4cf | 1566 | if (c == '\n' || c== '\r') |
fc2c5998 | 1567 | goto eol_3; |
b125b4cf | 1568 | else |
5e805e44 | 1569 | unget_char (dtp, c); |
b125b4cf | 1570 | |
6b680210 | 1571 | if (parse_real (dtp, dest + size / 2, kind)) |
6de9cd9a | 1572 | return; |
fc12098d | 1573 | |
fc2c5998 | 1574 | eol_4: |
5e805e44 | 1575 | eat_spaces (dtp); |
fc2c5998 JD |
1576 | c = next_char (dtp); |
1577 | if (c == '\n' || c== '\r') | |
1578 | goto eol_4; | |
1579 | else | |
1580 | unget_char (dtp, c); | |
1581 | ||
5e805e44 | 1582 | if (next_char (dtp) != ')') |
6de9cd9a DN |
1583 | goto bad_complex; |
1584 | ||
5e805e44 | 1585 | c = next_char (dtp); |
cc186345 | 1586 | if (!is_separator (c) && (c != EOF)) |
6de9cd9a DN |
1587 | goto bad_complex; |
1588 | ||
5e805e44 JJ |
1589 | unget_char (dtp, c); |
1590 | eat_separator (dtp); | |
6de9cd9a | 1591 | |
5e805e44 JJ |
1592 | free_saved (dtp); |
1593 | dtp->u.p.saved_type = BT_COMPLEX; | |
6de9cd9a DN |
1594 | return; |
1595 | ||
f21edfd6 | 1596 | bad_complex: |
29dc5138 | 1597 | |
5e805e44 | 1598 | if (nml_bad_return (dtp, c)) |
29dc5138 PT |
1599 | return; |
1600 | ||
9855448d | 1601 | free_saved (dtp); |
c86af7f3 JB |
1602 | if (c == EOF) |
1603 | { | |
79029289 | 1604 | free_line (dtp); |
c86af7f3 JB |
1605 | hit_eof (dtp); |
1606 | return; | |
1607 | } | |
fc12098d | 1608 | else if (c != '\n') |
c86af7f3 | 1609 | eat_line (dtp); |
79029289 | 1610 | |
d30fe1c5 | 1611 | snprintf (message, MSGLEN, "Bad complex value in item %d of list input", |
5e805e44 | 1612 | dtp->u.p.item_count); |
2558e2e8 | 1613 | free_line (dtp); |
d74b97cc | 1614 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1615 | } |
1616 | ||
1617 | ||
7fcb1804 | 1618 | /* Parse a real number with a possible repeat count. */ |
6de9cd9a DN |
1619 | |
1620 | static void | |
f29876bb | 1621 | read_real (st_parameter_dt *dtp, void *dest, int length) |
6de9cd9a | 1622 | { |
d30fe1c5 | 1623 | char message[MSGLEN]; |
c86af7f3 | 1624 | int c; |
6de9cd9a | 1625 | int seen_dp; |
78a15b1f | 1626 | int is_inf; |
6de9cd9a DN |
1627 | |
1628 | seen_dp = 0; | |
1629 | ||
5e805e44 | 1630 | c = next_char (dtp); |
105b7136 | 1631 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1632 | c = '.'; |
6de9cd9a DN |
1633 | switch (c) |
1634 | { | |
1635 | CASE_DIGITS: | |
5e805e44 | 1636 | push_char (dtp, c); |
6de9cd9a DN |
1637 | break; |
1638 | ||
1639 | case '.': | |
5e805e44 | 1640 | push_char (dtp, c); |
6de9cd9a DN |
1641 | seen_dp = 1; |
1642 | break; | |
1643 | ||
1644 | case '+': | |
1645 | case '-': | |
1646 | goto got_sign; | |
1647 | ||
fc12098d JD |
1648 | case '!': |
1649 | if (!dtp->u.p.namelist_mode) | |
1650 | goto bad_real; | |
1651 | ||
6de9cd9a | 1652 | CASE_SEPARATORS: |
5e805e44 JJ |
1653 | unget_char (dtp, c); /* Single null. */ |
1654 | eat_separator (dtp); | |
6de9cd9a DN |
1655 | return; |
1656 | ||
c9f7e825 TB |
1657 | case 'i': |
1658 | case 'I': | |
1659 | case 'n': | |
1660 | case 'N': | |
1661 | goto inf_nan; | |
1662 | ||
6de9cd9a DN |
1663 | default: |
1664 | goto bad_real; | |
1665 | } | |
1666 | ||
7fcb1804 | 1667 | /* Get the digit string that might be a repeat count. */ |
6de9cd9a DN |
1668 | |
1669 | for (;;) | |
1670 | { | |
5e805e44 | 1671 | c = next_char (dtp); |
105b7136 | 1672 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1673 | c = '.'; |
6de9cd9a DN |
1674 | switch (c) |
1675 | { | |
1676 | CASE_DIGITS: | |
5e805e44 | 1677 | push_char (dtp, c); |
6de9cd9a DN |
1678 | break; |
1679 | ||
1680 | case '.': | |
10256cbe JD |
1681 | if (seen_dp) |
1682 | goto bad_real; | |
6de9cd9a DN |
1683 | |
1684 | seen_dp = 1; | |
5e805e44 | 1685 | push_char (dtp, c); |
6de9cd9a DN |
1686 | goto real_loop; |
1687 | ||
1688 | case 'E': | |
1689 | case 'e': | |
1690 | case 'D': | |
1691 | case 'd': | |
96b3ee1c TB |
1692 | case 'Q': |
1693 | case 'q': | |
6de9cd9a DN |
1694 | goto exp1; |
1695 | ||
1696 | case '+': | |
1697 | case '-': | |
5e805e44 JJ |
1698 | push_char (dtp, 'e'); |
1699 | push_char (dtp, c); | |
1700 | c = next_char (dtp); | |
6de9cd9a DN |
1701 | goto exp2; |
1702 | ||
1703 | case '*': | |
5e805e44 | 1704 | push_char (dtp, '\0'); |
6de9cd9a DN |
1705 | goto got_repeat; |
1706 | ||
fc12098d JD |
1707 | case '!': |
1708 | if (!dtp->u.p.namelist_mode) | |
1709 | goto bad_real; | |
1710 | ||
6de9cd9a | 1711 | CASE_SEPARATORS: |
cc186345 | 1712 | case EOF: |
10256cbe | 1713 | if (c != '\n' && c != ',' && c != '\r' && c != ';') |
5e805e44 | 1714 | unget_char (dtp, c); |
6de9cd9a DN |
1715 | goto done; |
1716 | ||
1717 | default: | |
1718 | goto bad_real; | |
1719 | } | |
1720 | } | |
1721 | ||
f21edfd6 | 1722 | got_repeat: |
5e805e44 | 1723 | if (convert_integer (dtp, -1, 0)) |
6de9cd9a DN |
1724 | return; |
1725 | ||
7fcb1804 | 1726 | /* Now get the number itself. */ |
6de9cd9a | 1727 | |
c86af7f3 JB |
1728 | if ((c = next_char (dtp)) == EOF) |
1729 | goto bad_real; | |
6de9cd9a | 1730 | if (is_separator (c)) |
7fcb1804 | 1731 | { /* Repeated null value. */ |
5e805e44 JJ |
1732 | unget_char (dtp, c); |
1733 | eat_separator (dtp); | |
6de9cd9a DN |
1734 | return; |
1735 | } | |
1736 | ||
1737 | if (c != '-' && c != '+') | |
5e805e44 | 1738 | push_char (dtp, '+'); |
6de9cd9a DN |
1739 | else |
1740 | { | |
1741 | got_sign: | |
5e805e44 | 1742 | push_char (dtp, c); |
c86af7f3 JB |
1743 | if ((c = next_char (dtp)) == EOF) |
1744 | goto bad_real; | |
6de9cd9a DN |
1745 | } |
1746 | ||
105b7136 | 1747 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe JD |
1748 | c = '.'; |
1749 | ||
21423a1d | 1750 | if (!safe_isdigit (c) && c != '.') |
c9f7e825 TB |
1751 | { |
1752 | if (c == 'i' || c == 'I' || c == 'n' || c == 'N') | |
1753 | goto inf_nan; | |
1754 | else | |
1755 | goto bad_real; | |
1756 | } | |
6de9cd9a DN |
1757 | |
1758 | if (c == '.') | |
1759 | { | |
1760 | if (seen_dp) | |
1761 | goto bad_real; | |
1762 | else | |
1763 | seen_dp = 1; | |
1764 | } | |
1765 | ||
5e805e44 | 1766 | push_char (dtp, c); |
6de9cd9a | 1767 | |
f21edfd6 | 1768 | real_loop: |
6de9cd9a DN |
1769 | for (;;) |
1770 | { | |
5e805e44 | 1771 | c = next_char (dtp); |
105b7136 | 1772 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1773 | c = '.'; |
6de9cd9a DN |
1774 | switch (c) |
1775 | { | |
1776 | CASE_DIGITS: | |
5e805e44 | 1777 | push_char (dtp, c); |
6de9cd9a DN |
1778 | break; |
1779 | ||
fc12098d JD |
1780 | case '!': |
1781 | if (!dtp->u.p.namelist_mode) | |
1782 | goto bad_real; | |
1783 | ||
6de9cd9a | 1784 | CASE_SEPARATORS: |
c86af7f3 | 1785 | case EOF: |
6de9cd9a DN |
1786 | goto done; |
1787 | ||
1788 | case '.': | |
1789 | if (seen_dp) | |
1790 | goto bad_real; | |
1791 | ||
1792 | seen_dp = 1; | |
5e805e44 | 1793 | push_char (dtp, c); |
6de9cd9a DN |
1794 | break; |
1795 | ||
1796 | case 'E': | |
1797 | case 'e': | |
1798 | case 'D': | |
1799 | case 'd': | |
96b3ee1c TB |
1800 | case 'Q': |
1801 | case 'q': | |
6de9cd9a DN |
1802 | goto exp1; |
1803 | ||
1804 | case '+': | |
1805 | case '-': | |
5e805e44 JJ |
1806 | push_char (dtp, 'e'); |
1807 | push_char (dtp, c); | |
1808 | c = next_char (dtp); | |
6de9cd9a DN |
1809 | goto exp2; |
1810 | ||
1811 | default: | |
1812 | goto bad_real; | |
1813 | } | |
1814 | } | |
1815 | ||
f21edfd6 | 1816 | exp1: |
5e805e44 | 1817 | push_char (dtp, 'e'); |
6de9cd9a | 1818 | |
c86af7f3 JB |
1819 | if ((c = next_char (dtp)) == EOF) |
1820 | goto bad_real; | |
6de9cd9a | 1821 | if (c != '+' && c != '-') |
5e805e44 | 1822 | push_char (dtp, '+'); |
6de9cd9a DN |
1823 | else |
1824 | { | |
5e805e44 JJ |
1825 | push_char (dtp, c); |
1826 | c = next_char (dtp); | |
6de9cd9a DN |
1827 | } |
1828 | ||
f21edfd6 | 1829 | exp2: |
21423a1d | 1830 | if (!safe_isdigit (c)) |
6869e9c6 FR |
1831 | { |
1832 | /* Extension: allow default exponent of 0 when omitted. */ | |
7ee4f6f3 | 1833 | if (dtp->common.flags & IOPARM_DT_DEC_EXT) |
6869e9c6 FR |
1834 | { |
1835 | push_char (dtp, '0'); | |
1836 | goto done; | |
1837 | } | |
1838 | else | |
1839 | goto bad_exponent; | |
1840 | } | |
64a454d9 | 1841 | |
5e805e44 | 1842 | push_char (dtp, c); |
6de9cd9a DN |
1843 | |
1844 | for (;;) | |
1845 | { | |
5e805e44 | 1846 | c = next_char (dtp); |
6de9cd9a DN |
1847 | |
1848 | switch (c) | |
1849 | { | |
1850 | CASE_DIGITS: | |
5e805e44 | 1851 | push_char (dtp, c); |
6de9cd9a DN |
1852 | break; |
1853 | ||
fc12098d JD |
1854 | case '!': |
1855 | if (!dtp->u.p.namelist_mode) | |
1856 | goto bad_real; | |
1857 | ||
6de9cd9a | 1858 | CASE_SEPARATORS: |
cc186345 | 1859 | case EOF: |
6de9cd9a DN |
1860 | goto done; |
1861 | ||
1862 | default: | |
1863 | goto bad_real; | |
1864 | } | |
1865 | } | |
1866 | ||
f21edfd6 | 1867 | done: |
5e805e44 JJ |
1868 | unget_char (dtp, c); |
1869 | eat_separator (dtp); | |
1870 | push_char (dtp, '\0'); | |
6b680210 | 1871 | if (convert_real (dtp, dest, dtp->u.p.saved_string, length)) |
79029289 TB |
1872 | { |
1873 | free_saved (dtp); | |
1874 | return; | |
1875 | } | |
6de9cd9a | 1876 | |
5e805e44 JJ |
1877 | free_saved (dtp); |
1878 | dtp->u.p.saved_type = BT_REAL; | |
6de9cd9a DN |
1879 | return; |
1880 | ||
c9f7e825 | 1881 | inf_nan: |
b446725a TB |
1882 | l_push_char (dtp, c); |
1883 | is_inf = 0; | |
1884 | ||
c9f7e825 | 1885 | /* Match INF and Infinity. */ |
b446725a | 1886 | if (c == 'i' || c == 'I') |
c9f7e825 | 1887 | { |
b446725a TB |
1888 | c = next_char (dtp); |
1889 | l_push_char (dtp, c); | |
1890 | if (c != 'n' && c != 'N') | |
1891 | goto unwind; | |
1892 | c = next_char (dtp); | |
1893 | l_push_char (dtp, c); | |
1894 | if (c != 'f' && c != 'F') | |
1895 | goto unwind; | |
1896 | c = next_char (dtp); | |
1897 | l_push_char (dtp, c); | |
cc186345 | 1898 | if (!is_separator (c) && (c != EOF)) |
b446725a TB |
1899 | { |
1900 | if (c != 'i' && c != 'I') | |
1901 | goto unwind; | |
1902 | c = next_char (dtp); | |
1903 | l_push_char (dtp, c); | |
1904 | if (c != 'n' && c != 'N') | |
1905 | goto unwind; | |
1906 | c = next_char (dtp); | |
1907 | l_push_char (dtp, c); | |
1908 | if (c != 'i' && c != 'I') | |
1909 | goto unwind; | |
1910 | c = next_char (dtp); | |
1911 | l_push_char (dtp, c); | |
1912 | if (c != 't' && c != 'T') | |
1913 | goto unwind; | |
1914 | c = next_char (dtp); | |
1915 | l_push_char (dtp, c); | |
1916 | if (c != 'y' && c != 'Y') | |
1917 | goto unwind; | |
1918 | c = next_char (dtp); | |
1919 | l_push_char (dtp, c); | |
1920 | } | |
1921 | is_inf = 1; | |
c9f7e825 | 1922 | } /* Match NaN. */ |
b446725a TB |
1923 | else |
1924 | { | |
1925 | c = next_char (dtp); | |
1926 | l_push_char (dtp, c); | |
1927 | if (c != 'a' && c != 'A') | |
1928 | goto unwind; | |
1929 | c = next_char (dtp); | |
1930 | l_push_char (dtp, c); | |
1931 | if (c != 'n' && c != 'N') | |
1932 | goto unwind; | |
1933 | c = next_char (dtp); | |
1934 | l_push_char (dtp, c); | |
83377c6a TB |
1935 | |
1936 | /* Match NAN(alphanum). */ | |
1937 | if (c == '(') | |
1938 | { | |
1939 | for (c = next_char (dtp); c != ')'; c = next_char (dtp)) | |
1940 | if (is_separator (c)) | |
1941 | goto unwind; | |
1942 | else | |
1943 | l_push_char (dtp, c); | |
1944 | ||
1945 | l_push_char (dtp, ')'); | |
1946 | c = next_char (dtp); | |
1947 | l_push_char (dtp, c); | |
1948 | } | |
b446725a TB |
1949 | } |
1950 | ||
cc186345 | 1951 | if (!is_separator (c) && (c != EOF)) |
b446725a TB |
1952 | goto unwind; |
1953 | ||
78a15b1f | 1954 | if (dtp->u.p.namelist_mode) |
fc12098d | 1955 | { |
78a15b1f JD |
1956 | if (c == ' ' || c =='\n' || c == '\r') |
1957 | { | |
1958 | do | |
c86af7f3 JB |
1959 | { |
1960 | if ((c = next_char (dtp)) == EOF) | |
1961 | goto bad_real; | |
1962 | } | |
78a15b1f | 1963 | while (c == ' ' || c =='\n' || c == '\r'); |
b446725a | 1964 | |
78a15b1f JD |
1965 | l_push_char (dtp, c); |
1966 | ||
1967 | if (c == '=') | |
1968 | goto unwind; | |
1969 | } | |
b446725a TB |
1970 | } |
1971 | ||
1972 | if (is_inf) | |
1973 | { | |
1974 | push_char (dtp, 'i'); | |
1975 | push_char (dtp, 'n'); | |
1976 | push_char (dtp, 'f'); | |
1977 | } | |
1978 | else | |
c9f7e825 TB |
1979 | { |
1980 | push_char (dtp, 'n'); | |
1981 | push_char (dtp, 'a'); | |
1982 | push_char (dtp, 'n'); | |
b446725a TB |
1983 | } |
1984 | ||
b446725a | 1985 | free_line (dtp); |
458653cc JDA |
1986 | unget_char (dtp, c); |
1987 | eat_separator (dtp); | |
1988 | push_char (dtp, '\0'); | |
1989 | if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length)) | |
1990 | return; | |
1991 | ||
1992 | free_saved (dtp); | |
1993 | dtp->u.p.saved_type = BT_REAL; | |
1994 | return; | |
b446725a TB |
1995 | |
1996 | unwind: | |
1997 | if (dtp->u.p.namelist_mode) | |
1998 | { | |
1999 | dtp->u.p.nml_read_error = 1; | |
2000 | dtp->u.p.line_buffer_enabled = 1; | |
2558e2e8 | 2001 | dtp->u.p.line_buffer_pos = 0; |
b446725a | 2002 | return; |
c9f7e825 TB |
2003 | } |
2004 | ||
f21edfd6 | 2005 | bad_real: |
29dc5138 | 2006 | |
5e805e44 | 2007 | if (nml_bad_return (dtp, c)) |
29dc5138 PT |
2008 | return; |
2009 | ||
64a454d9 JD |
2010 | bad_exponent: |
2011 | ||
9855448d | 2012 | free_saved (dtp); |
c86af7f3 JB |
2013 | if (c == EOF) |
2014 | { | |
79029289 | 2015 | free_line (dtp); |
c86af7f3 JB |
2016 | hit_eof (dtp); |
2017 | return; | |
2018 | } | |
fc2c5998 | 2019 | else if (c != '\n') |
c86af7f3 | 2020 | eat_line (dtp); |
fc2c5998 | 2021 | |
d30fe1c5 | 2022 | snprintf (message, MSGLEN, "Bad real number in item %d of list input", |
5e805e44 | 2023 | dtp->u.p.item_count); |
2558e2e8 | 2024 | free_line (dtp); |
d74b97cc | 2025 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
2026 | } |
2027 | ||
2028 | ||
7fcb1804 TS |
2029 | /* Check the current type against the saved type to make sure they are |
2030 | compatible. Returns nonzero if incompatible. */ | |
6de9cd9a DN |
2031 | |
2032 | static int | |
71879a86 | 2033 | check_type (st_parameter_dt *dtp, bt type, int kind) |
6de9cd9a | 2034 | { |
d30fe1c5 | 2035 | char message[MSGLEN]; |
6de9cd9a | 2036 | |
a11930ba | 2037 | if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) |
6de9cd9a | 2038 | { |
d30fe1c5 | 2039 | snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d", |
5e805e44 JJ |
2040 | type_name (dtp->u.p.saved_type), type_name (type), |
2041 | dtp->u.p.item_count); | |
2558e2e8 | 2042 | free_line (dtp); |
d74b97cc | 2043 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
2044 | return 1; |
2045 | } | |
2046 | ||
a11930ba | 2047 | if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER) |
6de9cd9a DN |
2048 | return 0; |
2049 | ||
71879a86 TB |
2050 | if ((type != BT_COMPLEX && dtp->u.p.saved_length != kind) |
2051 | || (type == BT_COMPLEX && dtp->u.p.saved_length != kind*2)) | |
6de9cd9a | 2052 | { |
d30fe1c5 | 2053 | snprintf (message, MSGLEN, |
6de9cd9a | 2054 | "Read kind %d %s where kind %d is required for item %d", |
71879a86 TB |
2055 | type == BT_COMPLEX ? dtp->u.p.saved_length / 2 |
2056 | : dtp->u.p.saved_length, | |
2057 | type_name (dtp->u.p.saved_type), kind, | |
5e805e44 | 2058 | dtp->u.p.item_count); |
2558e2e8 | 2059 | free_line (dtp); |
d74b97cc | 2060 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
2061 | return 1; |
2062 | } | |
2063 | ||
2064 | return 0; | |
2065 | } | |
2066 | ||
2067 | ||
d428be77 JD |
2068 | /* Initialize the function pointers to select the correct versions of |
2069 | next_char and push_char depending on what we are doing. */ | |
2070 | ||
2071 | static void | |
2072 | set_workers (st_parameter_dt *dtp) | |
2073 | { | |
2074 | if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) | |
2075 | { | |
2076 | dtp->u.p.current_unit->next_char_fn_ptr = &next_char_utf8; | |
2077 | dtp->u.p.current_unit->push_char_fn_ptr = &push_char4; | |
2078 | } | |
2079 | else if (is_internal_unit (dtp)) | |
2080 | { | |
2081 | dtp->u.p.current_unit->next_char_fn_ptr = &next_char_internal; | |
2082 | dtp->u.p.current_unit->push_char_fn_ptr = &push_char_default; | |
2083 | } | |
2084 | else | |
2085 | { | |
2086 | dtp->u.p.current_unit->next_char_fn_ptr = &next_char_default; | |
2087 | dtp->u.p.current_unit->push_char_fn_ptr = &push_char_default; | |
2088 | } | |
2089 | ||
2090 | } | |
2091 | ||
7fcb1804 TS |
2092 | /* Top level data transfer subroutine for list reads. Because we have |
2093 | to deal with repeat counts, the data item is always saved after | |
5e805e44 | 2094 | reading, usually in the dtp->u.p.value[] array. If a repeat count is |
7fcb1804 | 2095 | greater than one, we copy the data item multiple times. */ |
6de9cd9a | 2096 | |
c86af7f3 JB |
2097 | static int |
2098 | list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, | |
51407486 | 2099 | int kind, size_t size) |
6de9cd9a | 2100 | { |
42c1e008 | 2101 | gfc_char4_t *q, *r; |
ea99ec5b JB |
2102 | size_t m; |
2103 | int c; | |
c86af7f3 | 2104 | int err = 0; |
6de9cd9a | 2105 | |
d428be77 JD |
2106 | /* Set the next_char and push_char worker functions. */ |
2107 | set_workers (dtp); | |
2108 | ||
5e805e44 | 2109 | if (dtp->u.p.first_item) |
6de9cd9a | 2110 | { |
5e805e44 JJ |
2111 | dtp->u.p.first_item = 0; |
2112 | dtp->u.p.input_complete = 0; | |
2113 | dtp->u.p.repeat_count = 1; | |
2114 | dtp->u.p.at_eol = 0; | |
fc12098d | 2115 | |
c86af7f3 JB |
2116 | if ((c = eat_spaces (dtp)) == EOF) |
2117 | { | |
2118 | err = LIBERROR_END; | |
2119 | goto cleanup; | |
2120 | } | |
6de9cd9a | 2121 | if (is_separator (c)) |
b8df885f | 2122 | { |
02227563 | 2123 | /* Found a null value. */ |
5e805e44 | 2124 | dtp->u.p.repeat_count = 0; |
02227563 | 2125 | eat_separator (dtp); |
a7c633ea | 2126 | |
e34994fc JD |
2127 | /* Set end-of-line flag. */ |
2128 | if (c == '\n' || c == '\r') | |
2129 | { | |
2130 | dtp->u.p.at_eol = 1; | |
2131 | if (finish_separator (dtp) == LIBERROR_END) | |
2132 | { | |
2133 | err = LIBERROR_END; | |
2134 | goto cleanup; | |
2135 | } | |
2136 | } | |
a7c633ea JD |
2137 | else |
2138 | goto cleanup; | |
6de9cd9a | 2139 | } |
6de9cd9a DN |
2140 | } |
2141 | else | |
2142 | { | |
5e805e44 | 2143 | if (dtp->u.p.repeat_count > 0) |
6de9cd9a | 2144 | { |
5e805e44 | 2145 | if (check_type (dtp, type, kind)) |
c86af7f3 | 2146 | return err; |
6de9cd9a DN |
2147 | goto set_value; |
2148 | } | |
fc12098d | 2149 | |
7812c78c JD |
2150 | if (dtp->u.p.input_complete) |
2151 | goto cleanup; | |
6de9cd9a | 2152 | |
5e805e44 JJ |
2153 | if (dtp->u.p.at_eol) |
2154 | finish_separator (dtp); | |
6de9cd9a | 2155 | else |
c72477d6 | 2156 | { |
5e805e44 | 2157 | eat_spaces (dtp); |
b8df885f | 2158 | /* Trailing spaces prior to end of line. */ |
5e805e44 JJ |
2159 | if (dtp->u.p.at_eol) |
2160 | finish_separator (dtp); | |
c72477d6 | 2161 | } |
6de9cd9a | 2162 | |
a11930ba | 2163 | dtp->u.p.saved_type = BT_UNKNOWN; |
5e805e44 | 2164 | dtp->u.p.repeat_count = 1; |
6de9cd9a DN |
2165 | } |
2166 | ||
6de9cd9a DN |
2167 | switch (type) |
2168 | { | |
2169 | case BT_INTEGER: | |
5e805e44 | 2170 | read_integer (dtp, kind); |
6de9cd9a DN |
2171 | break; |
2172 | case BT_LOGICAL: | |
5e805e44 | 2173 | read_logical (dtp, kind); |
6de9cd9a DN |
2174 | break; |
2175 | case BT_CHARACTER: | |
5e805e44 | 2176 | read_character (dtp, kind); |
6de9cd9a DN |
2177 | break; |
2178 | case BT_REAL: | |
6b680210 JB |
2179 | read_real (dtp, p, kind); |
2180 | /* Copy value back to temporary if needed. */ | |
2181 | if (dtp->u.p.repeat_count > 0) | |
a35c9bef | 2182 | memcpy (dtp->u.p.value, p, size); |
6de9cd9a DN |
2183 | break; |
2184 | case BT_COMPLEX: | |
6b680210 JB |
2185 | read_complex (dtp, p, kind, size); |
2186 | /* Copy value back to temporary if needed. */ | |
2187 | if (dtp->u.p.repeat_count > 0) | |
2188 | memcpy (dtp->u.p.value, p, size); | |
6de9cd9a | 2189 | break; |
e73d3ca6 PT |
2190 | case BT_CLASS: |
2191 | { | |
2192 | int unit = dtp->u.p.current_unit->unit_number; | |
2193 | char iotype[] = "LISTDIRECTED"; | |
2194 | gfc_charlen_type iotype_len = 12; | |
2195 | char tmp_iomsg[IOMSG_LEN] = ""; | |
2196 | char *child_iomsg; | |
2197 | gfc_charlen_type child_iomsg_len; | |
2198 | int noiostat; | |
2199 | int *child_iostat = NULL; | |
e9bfdf18 | 2200 | gfc_full_array_i4 vlist; |
e73d3ca6 PT |
2201 | |
2202 | GFC_DESCRIPTOR_DATA(&vlist) = NULL; | |
2203 | GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); | |
2204 | ||
2205 | /* Set iostat, intent(out). */ | |
2206 | noiostat = 0; | |
2207 | child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? | |
2208 | dtp->common.iostat : &noiostat; | |
2209 | ||
2210 | /* Set iomsge, intent(inout). */ | |
2211 | if (dtp->common.flags & IOPARM_HAS_IOMSG) | |
2212 | { | |
2213 | child_iomsg = dtp->common.iomsg; | |
2214 | child_iomsg_len = dtp->common.iomsg_len; | |
2215 | } | |
2216 | else | |
2217 | { | |
2218 | child_iomsg = tmp_iomsg; | |
2219 | child_iomsg_len = IOMSG_LEN; | |
2220 | } | |
2221 | ||
2222 | /* Call the user defined formatted READ procedure. */ | |
2223 | dtp->u.p.current_unit->child_dtio++; | |
2224 | dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist, | |
2225 | child_iostat, child_iomsg, | |
2226 | iotype_len, child_iomsg_len); | |
1f10d710 | 2227 | dtp->u.p.child_saved_iostat = *child_iostat; |
e73d3ca6 PT |
2228 | dtp->u.p.current_unit->child_dtio--; |
2229 | } | |
2230 | break; | |
6de9cd9a | 2231 | default: |
5e805e44 | 2232 | internal_error (&dtp->common, "Bad type for list read"); |
6de9cd9a DN |
2233 | } |
2234 | ||
a11930ba | 2235 | if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN) |
5e805e44 | 2236 | dtp->u.p.saved_length = size; |
6de9cd9a | 2237 | |
5e805e44 JJ |
2238 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
2239 | goto cleanup; | |
6de9cd9a | 2240 | |
f21edfd6 | 2241 | set_value: |
5e805e44 | 2242 | switch (dtp->u.p.saved_type) |
6de9cd9a DN |
2243 | { |
2244 | case BT_COMPLEX: | |
6de9cd9a | 2245 | case BT_REAL: |
6b680210 JB |
2246 | if (dtp->u.p.repeat_count > 0) |
2247 | memcpy (p, dtp->u.p.value, size); | |
2248 | break; | |
2249 | ||
2250 | case BT_INTEGER: | |
6de9cd9a | 2251 | case BT_LOGICAL: |
5e805e44 | 2252 | memcpy (p, dtp->u.p.value, size); |
6de9cd9a DN |
2253 | break; |
2254 | ||
2255 | case BT_CHARACTER: | |
5e805e44 | 2256 | if (dtp->u.p.saved_string) |
cea93abb | 2257 | { |
ea99ec5b JB |
2258 | m = (size < (size_t) dtp->u.p.saved_used) |
2259 | ? size : (size_t) dtp->u.p.saved_used; | |
42c1e008 JD |
2260 | |
2261 | q = (gfc_char4_t *) p; | |
2262 | r = (gfc_char4_t *) dtp->u.p.saved_string; | |
2263 | if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) | |
ea99ec5b | 2264 | for (size_t i = 0; i < m; i++) |
42c1e008 | 2265 | *q++ = *r++; |
cea93abb JD |
2266 | else |
2267 | { | |
42c1e008 JD |
2268 | if (kind == 1) |
2269 | memcpy (p, dtp->u.p.saved_string, m); | |
2270 | else | |
ea99ec5b | 2271 | for (size_t i = 0; i < m; i++) |
d428be77 | 2272 | *q++ = *r++; |
cea93abb JD |
2273 | } |
2274 | } | |
420aa7b8 | 2275 | else |
7fcb1804 | 2276 | /* Just delimiters encountered, nothing to copy but SPACE. */ |
04b0faec | 2277 | m = 0; |
6de9cd9a | 2278 | |
ea99ec5b | 2279 | if (m < size) |
cea93abb JD |
2280 | { |
2281 | if (kind == 1) | |
2282 | memset (((char *) p) + m, ' ', size - m); | |
2283 | else | |
2284 | { | |
2285 | q = (gfc_char4_t *) p; | |
ea99ec5b | 2286 | for (size_t i = m; i < size; i++) |
cea93abb JD |
2287 | q[i] = (unsigned char) ' '; |
2288 | } | |
2289 | } | |
6de9cd9a DN |
2290 | break; |
2291 | ||
a11930ba | 2292 | case BT_UNKNOWN: |
6de9cd9a | 2293 | break; |
a11930ba JD |
2294 | |
2295 | default: | |
2296 | internal_error (&dtp->common, "Bad type for list read"); | |
6de9cd9a DN |
2297 | } |
2298 | ||
5e805e44 JJ |
2299 | if (--dtp->u.p.repeat_count <= 0) |
2300 | free_saved (dtp); | |
2301 | ||
2302 | cleanup: | |
fd262197 JD |
2303 | /* err may have been set above from finish_separator, so if it is set |
2304 | trigger the hit_eof. The hit_eof will set bits in common.flags. */ | |
c86af7f3 | 2305 | if (err == LIBERROR_END) |
79029289 TB |
2306 | { |
2307 | free_line (dtp); | |
2308 | hit_eof (dtp); | |
2309 | } | |
fd262197 JD |
2310 | /* Now we check common.flags for any errors that could have occurred in |
2311 | a READ elsewhere such as in read_integer. */ | |
2312 | err = dtp->common.flags & IOPARM_LIBRETURN_MASK; | |
1060d940 | 2313 | fbuf_flush_list (dtp->u.p.current_unit, LIST_READING); |
c86af7f3 | 2314 | return err; |
6de9cd9a DN |
2315 | } |
2316 | ||
18623fae JB |
2317 | |
2318 | void | |
5e805e44 JJ |
2319 | list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind, |
2320 | size_t size, size_t nelems) | |
18623fae JB |
2321 | { |
2322 | size_t elem; | |
18623fae | 2323 | char *tmp; |
cea93abb JD |
2324 | size_t stride = type == BT_CHARACTER ? |
2325 | size * GFC_SIZE_OF_CHAR_KIND(kind) : size; | |
c86af7f3 | 2326 | int err; |
18623fae JB |
2327 | |
2328 | tmp = (char *) p; | |
2329 | ||
18623fae JB |
2330 | /* Big loop over all the elements. */ |
2331 | for (elem = 0; elem < nelems; elem++) | |
2332 | { | |
5e805e44 | 2333 | dtp->u.p.item_count++; |
fc12098d | 2334 | err = list_formatted_read_scalar (dtp, type, tmp + stride*elem, |
c86af7f3 JB |
2335 | kind, size); |
2336 | if (err) | |
2337 | break; | |
18623fae JB |
2338 | } |
2339 | } | |
2340 | ||
2341 | ||
7fcb1804 | 2342 | /* Finish a list read. */ |
6de9cd9a DN |
2343 | |
2344 | void | |
5e805e44 | 2345 | finish_list_read (st_parameter_dt *dtp) |
6de9cd9a | 2346 | { |
5e805e44 | 2347 | free_saved (dtp); |
6de9cd9a | 2348 | |
7812c78c JD |
2349 | fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); |
2350 | ||
5e805e44 | 2351 | if (dtp->u.p.at_eol) |
6de9cd9a | 2352 | { |
5e805e44 | 2353 | dtp->u.p.at_eol = 0; |
6de9cd9a DN |
2354 | return; |
2355 | } | |
2356 | ||
3b63b663 | 2357 | if (!is_internal_unit (dtp)) |
79029289 | 2358 | { |
e9471044 | 2359 | int c; |
d428be77 JD |
2360 | |
2361 | /* Set the next_char and push_char worker functions. */ | |
2362 | set_workers (dtp); | |
2363 | ||
1f10d710 | 2364 | if (likely (dtp->u.p.child_saved_iostat == LIBERROR_OK)) |
3b63b663 | 2365 | { |
1f10d710 JD |
2366 | c = next_char (dtp); |
2367 | if (c == EOF) | |
2368 | { | |
2369 | free_line (dtp); | |
2370 | hit_eof (dtp); | |
2371 | return; | |
2372 | } | |
2373 | if (c != '\n') | |
2374 | eat_line (dtp); | |
3b63b663 | 2375 | } |
79029289 | 2376 | } |
e9471044 JD |
2377 | |
2378 | free_line (dtp); | |
2379 | ||
6de9cd9a DN |
2380 | } |
2381 | ||
29dc5138 PT |
2382 | /* NAMELIST INPUT |
2383 | ||
5e805e44 | 2384 | void namelist_read (st_parameter_dt *dtp) |
29dc5138 PT |
2385 | calls: |
2386 | static void nml_match_name (char *name, int len) | |
5e805e44 JJ |
2387 | static int nml_query (st_parameter_dt *dtp) |
2388 | static int nml_get_obj_data (st_parameter_dt *dtp, | |
24722ea9 | 2389 | namelist_info **prev_nl, char *, size_t) |
29dc5138 | 2390 | calls: |
5e805e44 | 2391 | static void nml_untouch_nodes (st_parameter_dt *dtp) |
f29876bb JD |
2392 | static namelist_info *find_nml_node (st_parameter_dt *dtp, |
2393 | char *var_name) | |
2394 | static int nml_parse_qualifier(descriptor_dimension *ad, | |
2395 | array_loop_spec *ls, int rank, char *) | |
2396 | static void nml_touch_nodes (namelist_info *nl) | |
5e805e44 | 2397 | static int nml_read_obj (namelist_info *nl, index_type offset, |
24722ea9 | 2398 | namelist_info **prev_nl, char *, size_t, |
5e805e44 | 2399 | index_type clow, index_type chigh) |
29dc5138 PT |
2400 | calls: |
2401 | -itself- */ | |
2402 | ||
29dc5138 PT |
2403 | /* Inputs a rank-dimensional qualifier, which can contain |
2404 | singlets, doublets, triplets or ':' with the standard meanings. */ | |
2405 | ||
f5e3ed2d | 2406 | static bool |
5e805e44 | 2407 | nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, |
6f6fafc9 TS |
2408 | array_loop_spec *ls, int rank, bt nml_elem_type, |
2409 | char *parse_err_msg, size_t parse_err_msg_size, | |
45dfbe77 | 2410 | int *parsed_rank) |
29dc5138 PT |
2411 | { |
2412 | int dim; | |
2413 | int indx; | |
2414 | int neg; | |
2415 | int null_flag; | |
45dfbe77 | 2416 | int is_array_section, is_char; |
c86af7f3 | 2417 | int c; |
29dc5138 | 2418 | |
45dfbe77 | 2419 | is_char = 0; |
25292a1b JD |
2420 | is_array_section = 0; |
2421 | dtp->u.p.expanded_read = 0; | |
2422 | ||
45dfbe77 JD |
2423 | /* See if this is a character substring qualifier we are looking for. */ |
2424 | if (rank == -1) | |
2425 | { | |
2426 | rank = 1; | |
2427 | is_char = 1; | |
2428 | } | |
2429 | ||
29dc5138 PT |
2430 | /* The next character in the stream should be the '('. */ |
2431 | ||
c86af7f3 | 2432 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 2433 | goto err_ret; |
29dc5138 PT |
2434 | |
2435 | /* Process the qualifier, by dimension and triplet. */ | |
2436 | ||
2437 | for (dim=0; dim < rank; dim++ ) | |
2438 | { | |
2439 | for (indx=0; indx<3; indx++) | |
2440 | { | |
5e805e44 JJ |
2441 | free_saved (dtp); |
2442 | eat_spaces (dtp); | |
29dc5138 PT |
2443 | neg = 0; |
2444 | ||
b90ba157 | 2445 | /* Process a potential sign. */ |
c86af7f3 | 2446 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 2447 | goto err_ret; |
29dc5138 PT |
2448 | switch (c) |
2449 | { | |
2450 | case '-': | |
2451 | neg = 1; | |
2452 | break; | |
2453 | ||
2454 | case '+': | |
2455 | break; | |
2456 | ||
2457 | default: | |
5e805e44 | 2458 | unget_char (dtp, c); |
29dc5138 PT |
2459 | break; |
2460 | } | |
2461 | ||
b90ba157 | 2462 | /* Process characters up to the next ':' , ',' or ')'. */ |
29dc5138 PT |
2463 | for (;;) |
2464 | { | |
83437e67 | 2465 | c = next_char (dtp); |
29dc5138 PT |
2466 | switch (c) |
2467 | { | |
83437e67 JD |
2468 | case EOF: |
2469 | goto err_ret; | |
2470 | ||
29dc5138 | 2471 | case ':': |
25292a1b | 2472 | is_array_section = 1; |
29dc5138 PT |
2473 | break; |
2474 | ||
2475 | case ',': case ')': | |
b90ba157 RH |
2476 | if ((c==',' && dim == rank -1) |
2477 | || (c==')' && dim < rank -1)) | |
29dc5138 | 2478 | { |
45dfbe77 | 2479 | if (is_char) |
fc12098d | 2480 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2481 | "Bad substring qualifier"); |
45dfbe77 | 2482 | else |
fc12098d | 2483 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2484 | "Bad number of index fields"); |
29dc5138 PT |
2485 | goto err_ret; |
2486 | } | |
2487 | break; | |
2488 | ||
2489 | CASE_DIGITS: | |
5e805e44 | 2490 | push_char (dtp, c); |
29dc5138 PT |
2491 | continue; |
2492 | ||
83437e67 | 2493 | case ' ': case '\t': case '\r': case '\n': |
5e805e44 | 2494 | eat_spaces (dtp); |
29dc5138 PT |
2495 | break; |
2496 | ||
2497 | default: | |
45dfbe77 | 2498 | if (is_char) |
d30fe1c5 | 2499 | snprintf (parse_err_msg, parse_err_msg_size, |
45dfbe77 JD |
2500 | "Bad character in substring qualifier"); |
2501 | else | |
fc12098d | 2502 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2503 | "Bad character in index"); |
29dc5138 PT |
2504 | goto err_ret; |
2505 | } | |
2506 | ||
5e805e44 JJ |
2507 | if ((c == ',' || c == ')') && indx == 0 |
2508 | && dtp->u.p.saved_string == 0) | |
29dc5138 | 2509 | { |
45dfbe77 | 2510 | if (is_char) |
fc12098d | 2511 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2512 | "Null substring qualifier"); |
45dfbe77 | 2513 | else |
fc12098d | 2514 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2515 | "Null index field"); |
29dc5138 PT |
2516 | goto err_ret; |
2517 | } | |
2518 | ||
5e805e44 | 2519 | if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0) |
b90ba157 | 2520 | || (indx == 2 && dtp->u.p.saved_string == 0)) |
29dc5138 | 2521 | { |
45dfbe77 | 2522 | if (is_char) |
fc12098d | 2523 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2524 | "Bad substring qualifier"); |
45dfbe77 | 2525 | else |
d30fe1c5 JB |
2526 | snprintf (parse_err_msg, parse_err_msg_size, |
2527 | "Bad index triplet"); | |
45dfbe77 JD |
2528 | goto err_ret; |
2529 | } | |
2530 | ||
2531 | if (is_char && !is_array_section) | |
2532 | { | |
d30fe1c5 | 2533 | snprintf (parse_err_msg, parse_err_msg_size, |
45dfbe77 | 2534 | "Missing colon in substring qualifier"); |
29dc5138 PT |
2535 | goto err_ret; |
2536 | } | |
2537 | ||
2538 | /* If '( : ? )' or '( ? : )' break and flag read failure. */ | |
2539 | null_flag = 0; | |
5e805e44 | 2540 | if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0) |
b90ba157 | 2541 | || (indx==1 && dtp->u.p.saved_string == 0)) |
29dc5138 PT |
2542 | { |
2543 | null_flag = 1; | |
2544 | break; | |
2545 | } | |
2546 | ||
2547 | /* Now read the index. */ | |
44720bef | 2548 | if (convert_integer (dtp, sizeof(index_type), neg)) |
29dc5138 | 2549 | { |
45dfbe77 | 2550 | if (is_char) |
d30fe1c5 JB |
2551 | snprintf (parse_err_msg, parse_err_msg_size, |
2552 | "Bad integer substring qualifier"); | |
45dfbe77 | 2553 | else |
d30fe1c5 JB |
2554 | snprintf (parse_err_msg, parse_err_msg_size, |
2555 | "Bad integer in index"); | |
29dc5138 PT |
2556 | goto err_ret; |
2557 | } | |
2558 | break; | |
2559 | } | |
2560 | ||
b90ba157 | 2561 | /* Feed the index values to the triplet arrays. */ |
29dc5138 PT |
2562 | if (!null_flag) |
2563 | { | |
2564 | if (indx == 0) | |
44720bef | 2565 | memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type)); |
29dc5138 | 2566 | if (indx == 1) |
44720bef | 2567 | memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type)); |
29dc5138 | 2568 | if (indx == 2) |
44720bef | 2569 | memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type)); |
29dc5138 PT |
2570 | } |
2571 | ||
b90ba157 | 2572 | /* Singlet or doublet indices. */ |
29dc5138 PT |
2573 | if (c==',' || c==')') |
2574 | { | |
2575 | if (indx == 0) | |
2576 | { | |
44720bef | 2577 | memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type)); |
25292a1b JD |
2578 | |
2579 | /* If -std=f95/2003 or an array section is specified, | |
2580 | do not allow excess data to be processed. */ | |
5609699a JD |
2581 | if (is_array_section == 1 |
2582 | || !(compile_options.allow_std & GFC_STD_GNU) | |
6f6fafc9 | 2583 | || nml_elem_type == BT_DERIVED) |
25292a1b JD |
2584 | ls[dim].end = ls[dim].start; |
2585 | else | |
2586 | dtp->u.p.expanded_read = 1; | |
29dc5138 | 2587 | } |
45dfbe77 JD |
2588 | |
2589 | /* Check for non-zero rank. */ | |
2590 | if (is_array_section == 1 && ls[dim].start != ls[dim].end) | |
2591 | *parsed_rank = 1; | |
2592 | ||
29dc5138 PT |
2593 | break; |
2594 | } | |
2595 | } | |
2596 | ||
2f4d643d | 2597 | if (is_array_section == 1 && dtp->u.p.expanded_read == 1) |
5609699a | 2598 | { |
2f4d643d TB |
2599 | int i; |
2600 | dtp->u.p.expanded_read = 0; | |
2601 | for (i = 0; i < dim; i++) | |
2602 | ls[i].end = ls[i].start; | |
5609699a | 2603 | } |
2f4d643d | 2604 | |
b90ba157 | 2605 | /* Check the values of the triplet indices. */ |
44720bef JB |
2606 | if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim])) |
2607 | || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim])) | |
2608 | || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim])) | |
2609 | || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim]))) | |
29dc5138 | 2610 | { |
45dfbe77 | 2611 | if (is_char) |
fc12098d | 2612 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2613 | "Substring out of range"); |
45dfbe77 | 2614 | else |
fc12098d | 2615 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2616 | "Index %d out of range", dim + 1); |
29dc5138 PT |
2617 | goto err_ret; |
2618 | } | |
45dfbe77 | 2619 | |
29dc5138 | 2620 | if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) |
b90ba157 | 2621 | || (ls[dim].step == 0)) |
29dc5138 | 2622 | { |
fc12098d | 2623 | snprintf (parse_err_msg, parse_err_msg_size, |
d30fe1c5 | 2624 | "Bad range in index %d", dim + 1); |
29dc5138 PT |
2625 | goto err_ret; |
2626 | } | |
2627 | ||
2628 | /* Initialise the loop index counter. */ | |
29dc5138 | 2629 | ls[dim].idx = ls[dim].start; |
29dc5138 | 2630 | } |
5e805e44 | 2631 | eat_spaces (dtp); |
f5e3ed2d | 2632 | return true; |
29dc5138 PT |
2633 | |
2634 | err_ret: | |
2635 | ||
83437e67 JD |
2636 | /* The EOF error message is issued by hit_eof. Return true so that the |
2637 | caller does not use parse_err_msg and parse_err_msg_size to generate | |
2638 | an unrelated error message. */ | |
2639 | if (c == EOF) | |
2640 | { | |
2641 | hit_eof (dtp); | |
2642 | dtp->u.p.input_complete = 1; | |
2643 | return true; | |
2644 | } | |
f5e3ed2d | 2645 | return false; |
29dc5138 PT |
2646 | } |
2647 | ||
3b111bd7 JD |
2648 | |
2649 | static bool | |
2650 | extended_look_ahead (char *p, char *q) | |
2651 | { | |
2652 | char *r, *s; | |
2653 | ||
2654 | /* Scan ahead to find a '%' in the p string. */ | |
2655 | for(r = p, s = q; *r && *s; s++) | |
2656 | if ((*s == '%' || *s == '+') && strcmp (r + 1, s + 1) == 0) | |
2657 | return true; | |
2658 | return false; | |
2659 | } | |
2660 | ||
2661 | ||
2662 | static bool | |
2663 | strcmp_extended_type (char *p, char *q) | |
2664 | { | |
2665 | char *r, *s; | |
fc12098d | 2666 | |
3b111bd7 JD |
2667 | for (r = p, s = q; *r && *s; r++, s++) |
2668 | { | |
2669 | if (*r != *s) | |
2670 | { | |
2671 | if (*r == '%' && *s == '+' && extended_look_ahead (r, s)) | |
2672 | return true; | |
2673 | break; | |
2674 | } | |
2675 | } | |
2676 | return false; | |
2677 | } | |
2678 | ||
2679 | ||
6de9cd9a | 2680 | static namelist_info * |
f29876bb | 2681 | find_nml_node (st_parameter_dt *dtp, char *var_name) |
6de9cd9a | 2682 | { |
f29876bb | 2683 | namelist_info *t = dtp->u.p.ionml; |
29dc5138 PT |
2684 | while (t != NULL) |
2685 | { | |
5e805e44 | 2686 | if (strcmp (var_name, t->var_name) == 0) |
29dc5138 PT |
2687 | { |
2688 | t->touched = 1; | |
2689 | return t; | |
2690 | } | |
3b111bd7 JD |
2691 | if (strcmp_extended_type (var_name, t->var_name)) |
2692 | { | |
2693 | t->touched = 1; | |
2694 | return t; | |
2695 | } | |
29dc5138 PT |
2696 | t = t->next; |
2697 | } | |
6de9cd9a DN |
2698 | return NULL; |
2699 | } | |
2700 | ||
29dc5138 PT |
2701 | /* Visits all the components of a derived type that have |
2702 | not explicitly been identified in the namelist input. | |
420aa7b8 | 2703 | touched is set and the loop specification initialised |
29dc5138 PT |
2704 | to default values */ |
2705 | ||
6de9cd9a | 2706 | static void |
f29876bb | 2707 | nml_touch_nodes (namelist_info *nl) |
6de9cd9a | 2708 | { |
29dc5138 PT |
2709 | index_type len = strlen (nl->var_name) + 1; |
2710 | int dim; | |
f29876bb | 2711 | char *ext_name = xmalloc (len + 1); |
88fdfd5a JB |
2712 | memcpy (ext_name, nl->var_name, len-1); |
2713 | memcpy (ext_name + len - 1, "%", 2); | |
29dc5138 | 2714 | for (nl = nl->next; nl; nl = nl->next) |
6de9cd9a | 2715 | { |
29dc5138 PT |
2716 | if (strncmp (nl->var_name, ext_name, len) == 0) |
2717 | { | |
2718 | nl->touched = 1; | |
2719 | for (dim=0; dim < nl->var_rank; dim++) | |
2720 | { | |
2721 | nl->ls[dim].step = 1; | |
dfb55fdc TK |
2722 | nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); |
2723 | nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); | |
29dc5138 PT |
2724 | nl->ls[dim].idx = nl->ls[dim].start; |
2725 | } | |
2726 | } | |
2727 | else | |
2728 | break; | |
6de9cd9a | 2729 | } |
bb408e87 | 2730 | free (ext_name); |
29dc5138 PT |
2731 | return; |
2732 | } | |
2733 | ||
2734 | /* Resets touched for the entire list of nml_nodes, ready for a | |
2735 | new object. */ | |
2736 | ||
2737 | static void | |
5e805e44 | 2738 | nml_untouch_nodes (st_parameter_dt *dtp) |
29dc5138 | 2739 | { |
f29876bb | 2740 | namelist_info *t; |
5e805e44 | 2741 | for (t = dtp->u.p.ionml; t; t = t->next) |
29dc5138 PT |
2742 | t->touched = 0; |
2743 | return; | |
2744 | } | |
2745 | ||
5e805e44 JJ |
2746 | /* Attempts to input name to namelist name. Returns |
2747 | dtp->u.p.nml_read_error = 1 on no match. */ | |
6de9cd9a | 2748 | |
29dc5138 | 2749 | static void |
5e805e44 | 2750 | nml_match_name (st_parameter_dt *dtp, const char *name, index_type len) |
29dc5138 PT |
2751 | { |
2752 | index_type i; | |
c86af7f3 JB |
2753 | int c; |
2754 | ||
5e805e44 | 2755 | dtp->u.p.nml_read_error = 0; |
29dc5138 | 2756 | for (i = 0; i < len; i++) |
6de9cd9a | 2757 | { |
5e805e44 | 2758 | c = next_char (dtp); |
21423a1d | 2759 | if (c == EOF || (safe_tolower (c) != safe_tolower (name[i]))) |
29dc5138 | 2760 | { |
5e805e44 | 2761 | dtp->u.p.nml_read_error = 1; |
29dc5138 PT |
2762 | break; |
2763 | } | |
6de9cd9a DN |
2764 | } |
2765 | } | |
2766 | ||
29dc5138 PT |
2767 | /* If the namelist read is from stdin, output the current state of the |
2768 | namelist to stdout. This is used to implement the non-standard query | |
2769 | features, ? and =?. If c == '=' the full namelist is printed. Otherwise | |
2770 | the names alone are printed. */ | |
6de9cd9a | 2771 | |
29dc5138 | 2772 | static void |
5e805e44 | 2773 | nml_query (st_parameter_dt *dtp, char c) |
6de9cd9a | 2774 | { |
f29876bb JD |
2775 | gfc_unit *temp_unit; |
2776 | namelist_info *nl; | |
29dc5138 | 2777 | index_type len; |
f29876bb | 2778 | char *p; |
15877a88 | 2779 | #ifdef HAVE_CRLF |
a0b012be | 2780 | static const index_type endlen = 2; |
15877a88 JB |
2781 | static const char endl[] = "\r\n"; |
2782 | static const char nmlend[] = "&end\r\n"; | |
2783 | #else | |
a0b012be | 2784 | static const index_type endlen = 1; |
15877a88 JB |
2785 | static const char endl[] = "\n"; |
2786 | static const char nmlend[] = "&end\n"; | |
2787 | #endif | |
6de9cd9a | 2788 | |
5e805e44 | 2789 | if (dtp->u.p.current_unit->unit_number != options.stdin_unit) |
29dc5138 | 2790 | return; |
6de9cd9a | 2791 | |
29dc5138 PT |
2792 | /* Store the current unit and transfer to stdout. */ |
2793 | ||
5e805e44 JJ |
2794 | temp_unit = dtp->u.p.current_unit; |
2795 | dtp->u.p.current_unit = find_unit (options.stdout_unit); | |
29dc5138 | 2796 | |
5e805e44 | 2797 | if (dtp->u.p.current_unit) |
6de9cd9a | 2798 | { |
5e805e44 JJ |
2799 | dtp->u.p.mode = WRITING; |
2800 | next_record (dtp, 0); | |
29dc5138 PT |
2801 | |
2802 | /* Write the namelist in its entirety. */ | |
2803 | ||
2804 | if (c == '=') | |
5e805e44 | 2805 | namelist_write (dtp); |
29dc5138 PT |
2806 | |
2807 | /* Or write the list of names. */ | |
2808 | ||
2809 | else | |
2810 | { | |
29dc5138 PT |
2811 | /* "&namelist_name\n" */ |
2812 | ||
5e805e44 | 2813 | len = dtp->namelist_name_len; |
a0b012be | 2814 | p = write_block (dtp, len - 1 + endlen); |
15877a88 JB |
2815 | if (!p) |
2816 | goto query_return; | |
29dc5138 | 2817 | memcpy (p, "&", 1); |
5e805e44 | 2818 | memcpy ((char*)(p + 1), dtp->namelist_name, len); |
a0b012be | 2819 | memcpy ((char*)(p + len + 1), &endl, endlen); |
5e805e44 | 2820 | for (nl = dtp->u.p.ionml; nl; nl = nl->next) |
29dc5138 | 2821 | { |
29dc5138 PT |
2822 | /* " var_name\n" */ |
2823 | ||
2824 | len = strlen (nl->var_name); | |
15877a88 | 2825 | p = write_block (dtp, len + endlen); |
29dc5138 PT |
2826 | if (!p) |
2827 | goto query_return; | |
2828 | memcpy (p, " ", 1); | |
2829 | memcpy ((char*)(p + 1), nl->var_name, len); | |
a0b012be | 2830 | memcpy ((char*)(p + len + 1), &endl, endlen); |
29dc5138 PT |
2831 | } |
2832 | ||
2833 | /* "&end\n" */ | |
2834 | ||
a0b012be TB |
2835 | p = write_block (dtp, endlen + 4); |
2836 | if (!p) | |
29dc5138 | 2837 | goto query_return; |
a0b012be | 2838 | memcpy (p, &nmlend, endlen + 4); |
29dc5138 PT |
2839 | } |
2840 | ||
2841 | /* Flush the stream to force immediate output. */ | |
2842 | ||
7812c78c JD |
2843 | fbuf_flush (dtp->u.p.current_unit, WRITING); |
2844 | sflush (dtp->u.p.current_unit->s); | |
5e805e44 | 2845 | unlock_unit (dtp->u.p.current_unit); |
6de9cd9a DN |
2846 | } |
2847 | ||
29dc5138 | 2848 | query_return: |
6de9cd9a | 2849 | |
29dc5138 | 2850 | /* Restore the current unit. */ |
6de9cd9a | 2851 | |
5e805e44 JJ |
2852 | dtp->u.p.current_unit = temp_unit; |
2853 | dtp->u.p.mode = READING; | |
29dc5138 PT |
2854 | return; |
2855 | } | |
2856 | ||
2857 | /* Reads and stores the input for the namelist object nl. For an array, | |
2858 | the function loops over the ranges defined by the loop specification. | |
2859 | This default to all the data or to the specification from a qualifier. | |
2860 | nml_read_obj recursively calls itself to read derived types. It visits | |
2861 | all its own components but only reads data for those that were touched | |
2862 | when the name was parsed. If a read error is encountered, an attempt is | |
2863 | made to return to read a new object name because the standard allows too | |
2864 | little data to be available. On the other hand, too much data is an | |
2865 | error. */ | |
2866 | ||
f5e3ed2d | 2867 | static bool |
f29876bb | 2868 | nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset, |
5e805e44 | 2869 | namelist_info **pprev_nl, char *nml_err_msg, |
24722ea9 | 2870 | size_t nml_err_msg_size, index_type clow, index_type chigh) |
29dc5138 | 2871 | { |
f29876bb JD |
2872 | namelist_info *cmp; |
2873 | char *obj_name; | |
29dc5138 PT |
2874 | int nml_carry; |
2875 | int len; | |
2876 | int dim; | |
2877 | index_type dlen; | |
2878 | index_type m; | |
f9bfed22 | 2879 | size_t obj_name_len; |
f29876bb | 2880 | void *pdata; |
51cd6b78 | 2881 | gfc_class list_obj; |
29dc5138 | 2882 | |
ba829325 JD |
2883 | /* If we have encountered a previous read error or this object has not been |
2884 | touched in name parsing, just return. */ | |
2885 | if (dtp->u.p.nml_read_error || !nl->touched) | |
f5e3ed2d | 2886 | return true; |
29dc5138 | 2887 | |
64a454d9 | 2888 | dtp->u.p.item_count++; /* Used in error messages. */ |
5e805e44 JJ |
2889 | dtp->u.p.repeat_count = 0; |
2890 | eat_spaces (dtp); | |
29dc5138 PT |
2891 | |
2892 | len = nl->len; | |
2893 | switch (nl->type) | |
2894 | { | |
a11930ba JD |
2895 | case BT_INTEGER: |
2896 | case BT_LOGICAL: | |
29dc5138 PT |
2897 | dlen = len; |
2898 | break; | |
2899 | ||
a11930ba | 2900 | case BT_REAL: |
e5ef4b3b JB |
2901 | dlen = size_from_real_kind (len); |
2902 | break; | |
2903 | ||
a11930ba | 2904 | case BT_COMPLEX: |
e5ef4b3b | 2905 | dlen = size_from_complex_kind (len); |
29dc5138 PT |
2906 | break; |
2907 | ||
a11930ba | 2908 | case BT_CHARACTER: |
29dc5138 | 2909 | dlen = chigh ? (chigh - clow + 1) : nl->string_length; |
6de9cd9a DN |
2910 | break; |
2911 | ||
2912 | default: | |
29dc5138 | 2913 | dlen = 0; |
6de9cd9a DN |
2914 | } |
2915 | ||
29dc5138 | 2916 | do |
6de9cd9a | 2917 | { |
29dc5138 | 2918 | /* Update the pointer to the data, using the current index vector */ |
6de9cd9a | 2919 | |
51cd6b78 JD |
2920 | if ((nl->type == BT_DERIVED || nl->type == BT_CLASS) |
2921 | && nl->dtio_sub != NULL) | |
2922 | { | |
2923 | pdata = NULL; /* Not used under these conidtions. */ | |
2924 | if (nl->type == BT_CLASS) | |
2925 | list_obj.data = ((gfc_class*)nl->mem_pos)->data; | |
2926 | else | |
2927 | list_obj.data = (void *)nl->mem_pos; | |
2928 | ||
2929 | for (dim = 0; dim < nl->var_rank; dim++) | |
2930 | list_obj.data = list_obj.data + (nl->ls[dim].idx | |
2931 | - GFC_DESCRIPTOR_LBOUND(nl,dim)) | |
2932 | * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size; | |
2933 | } | |
2934 | else | |
2935 | { | |
2936 | pdata = (void*)(nl->mem_pos + offset); | |
2937 | for (dim = 0; dim < nl->var_rank; dim++) | |
2938 | pdata = (void*)(pdata + (nl->ls[dim].idx | |
2939 | - GFC_DESCRIPTOR_LBOUND(nl,dim)) | |
2940 | * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size); | |
2941 | } | |
77747e5f | 2942 | |
ba829325 | 2943 | /* If we are finished with the repeat count, try to read next value. */ |
29dc5138 | 2944 | |
29dc5138 | 2945 | nml_carry = 0; |
5e805e44 | 2946 | if (--dtp->u.p.repeat_count <= 0) |
29dc5138 | 2947 | { |
5e805e44 | 2948 | if (dtp->u.p.input_complete) |
f5e3ed2d | 2949 | return true; |
5e805e44 JJ |
2950 | if (dtp->u.p.at_eol) |
2951 | finish_separator (dtp); | |
2952 | if (dtp->u.p.input_complete) | |
f5e3ed2d | 2953 | return true; |
29dc5138 | 2954 | |
a11930ba | 2955 | dtp->u.p.saved_type = BT_UNKNOWN; |
5e805e44 | 2956 | free_saved (dtp); |
420aa7b8 | 2957 | |
6de9cd9a | 2958 | switch (nl->type) |
29dc5138 | 2959 | { |
a11930ba | 2960 | case BT_INTEGER: |
cc186345 JD |
2961 | read_integer (dtp, len); |
2962 | break; | |
29dc5138 | 2963 | |
a11930ba | 2964 | case BT_LOGICAL: |
cc186345 JD |
2965 | read_logical (dtp, len); |
2966 | break; | |
29dc5138 | 2967 | |
a11930ba | 2968 | case BT_CHARACTER: |
cc186345 JD |
2969 | read_character (dtp, len); |
2970 | break; | |
29dc5138 | 2971 | |
a11930ba | 2972 | case BT_REAL: |
ba829325 JD |
2973 | /* Need to copy data back from the real location to the temp in |
2974 | order to handle nml reads into arrays. */ | |
6b680210 JB |
2975 | read_real (dtp, pdata, len); |
2976 | memcpy (dtp->u.p.value, pdata, dlen); | |
2977 | break; | |
29dc5138 | 2978 | |
a11930ba | 2979 | case BT_COMPLEX: |
6b680210 JB |
2980 | /* Same as for REAL, copy back to temp. */ |
2981 | read_complex (dtp, pdata, len, dlen); | |
2982 | memcpy (dtp->u.p.value, pdata, dlen); | |
2983 | break; | |
6de9cd9a | 2984 | |
a11930ba | 2985 | case BT_DERIVED: |
51cd6b78 | 2986 | case BT_CLASS: |
fdc54f39 JD |
2987 | /* If this object has a User Defined procedure, call it. */ |
2988 | if (nl->dtio_sub != NULL) | |
2989 | { | |
2990 | int unit = dtp->u.p.current_unit->unit_number; | |
2991 | char iotype[] = "NAMELIST"; | |
2992 | gfc_charlen_type iotype_len = 8; | |
2993 | char tmp_iomsg[IOMSG_LEN] = ""; | |
2994 | char *child_iomsg; | |
2995 | gfc_charlen_type child_iomsg_len; | |
2996 | int noiostat; | |
2997 | int *child_iostat = NULL; | |
e9bfdf18 | 2998 | gfc_full_array_i4 vlist; |
fdc54f39 JD |
2999 | formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub; |
3000 | ||
3001 | GFC_DESCRIPTOR_DATA(&vlist) = NULL; | |
3002 | GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); | |
51cd6b78 | 3003 | |
fdc54f39 JD |
3004 | list_obj.vptr = nl->vtable; |
3005 | list_obj.len = 0; | |
3006 | ||
3007 | /* Set iostat, intent(out). */ | |
3008 | noiostat = 0; | |
3009 | child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? | |
3010 | dtp->common.iostat : &noiostat; | |
3011 | ||
3012 | /* Set iomsg, intent(inout). */ | |
3013 | if (dtp->common.flags & IOPARM_HAS_IOMSG) | |
3014 | { | |
3015 | child_iomsg = dtp->common.iomsg; | |
3016 | child_iomsg_len = dtp->common.iomsg_len; | |
3017 | } | |
3018 | else | |
3019 | { | |
3020 | child_iomsg = tmp_iomsg; | |
3021 | child_iomsg_len = IOMSG_LEN; | |
3022 | } | |
3023 | ||
fdc54f39 JD |
3024 | /* Call the user defined formatted READ procedure. */ |
3025 | dtp->u.p.current_unit->child_dtio++; | |
3026 | dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist, | |
3027 | child_iostat, child_iomsg, | |
3028 | iotype_len, child_iomsg_len); | |
3029 | dtp->u.p.child_saved_iostat = *child_iostat; | |
3030 | dtp->u.p.current_unit->child_dtio--; | |
3031 | goto incr_idx; | |
3032 | } | |
3033 | ||
3034 | /* Must be default derived type namelist read. */ | |
29dc5138 | 3035 | obj_name_len = strlen (nl->var_name) + 1; |
1a0fd3d3 | 3036 | obj_name = xmalloc (obj_name_len+1); |
88fdfd5a JB |
3037 | memcpy (obj_name, nl->var_name, obj_name_len-1); |
3038 | memcpy (obj_name + obj_name_len - 1, "%", 2); | |
29dc5138 | 3039 | |
25292a1b JD |
3040 | /* If reading a derived type, disable the expanded read warning |
3041 | since a single object can have multiple reads. */ | |
3042 | dtp->u.p.expanded_read = 0; | |
3043 | ||
a0b67fe2 | 3044 | /* Now loop over the components. */ |
29dc5138 PT |
3045 | |
3046 | for (cmp = nl->next; | |
3047 | cmp && | |
a0b67fe2 | 3048 | !strncmp (cmp->var_name, obj_name, obj_name_len); |
29dc5138 PT |
3049 | cmp = cmp->next) |
3050 | { | |
a0b67fe2 TS |
3051 | /* Jump over nested derived type by testing if the potential |
3052 | component name contains '%'. */ | |
3053 | if (strchr (cmp->var_name + obj_name_len, '%')) | |
3054 | continue; | |
29dc5138 | 3055 | |
f5e3ed2d | 3056 | if (!nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos), |
24722ea9 | 3057 | pprev_nl, nml_err_msg, nml_err_msg_size, |
f5e3ed2d | 3058 | clow, chigh)) |
883dd429 | 3059 | { |
bb408e87 | 3060 | free (obj_name); |
f5e3ed2d | 3061 | return false; |
883dd429 | 3062 | } |
29dc5138 | 3063 | |
5e805e44 | 3064 | if (dtp->u.p.input_complete) |
883dd429 | 3065 | { |
bb408e87 | 3066 | free (obj_name); |
f5e3ed2d | 3067 | return true; |
883dd429 | 3068 | } |
29dc5138 PT |
3069 | } |
3070 | ||
bb408e87 | 3071 | free (obj_name); |
29dc5138 PT |
3072 | goto incr_idx; |
3073 | ||
3074 | default: | |
24722ea9 JJ |
3075 | snprintf (nml_err_msg, nml_err_msg_size, |
3076 | "Bad type for namelist object %s", nl->var_name); | |
5e805e44 | 3077 | internal_error (&dtp->common, nml_err_msg); |
29dc5138 PT |
3078 | goto nml_err_ret; |
3079 | } | |
3080 | } | |
6de9cd9a | 3081 | |
29dc5138 PT |
3082 | /* The standard permits array data to stop short of the number of |
3083 | elements specified in the loop specification. In this case, we | |
5e805e44 | 3084 | should be here with dtp->u.p.nml_read_error != 0. Control returns to |
29dc5138 | 3085 | nml_get_obj_data and an attempt is made to read object name. */ |
6de9cd9a | 3086 | |
5e805e44 JJ |
3087 | *pprev_nl = nl; |
3088 | if (dtp->u.p.nml_read_error) | |
25292a1b JD |
3089 | { |
3090 | dtp->u.p.expanded_read = 0; | |
f5e3ed2d | 3091 | return true; |
25292a1b | 3092 | } |
6de9cd9a | 3093 | |
a11930ba | 3094 | if (dtp->u.p.saved_type == BT_UNKNOWN) |
25292a1b JD |
3095 | { |
3096 | dtp->u.p.expanded_read = 0; | |
3097 | goto incr_idx; | |
3098 | } | |
29dc5138 | 3099 | |
5e805e44 | 3100 | switch (dtp->u.p.saved_type) |
29dc5138 PT |
3101 | { |
3102 | ||
3103 | case BT_COMPLEX: | |
3104 | case BT_REAL: | |
3105 | case BT_INTEGER: | |
3106 | case BT_LOGICAL: | |
5e805e44 | 3107 | memcpy (pdata, dtp->u.p.value, dlen); |
29dc5138 PT |
3108 | break; |
3109 | ||
3110 | case BT_CHARACTER: | |
fc5f5bb7 JD |
3111 | if (dlen < dtp->u.p.saved_used) |
3112 | { | |
3113 | if (compile_options.bounds_check) | |
3114 | { | |
3115 | snprintf (nml_err_msg, nml_err_msg_size, | |
3116 | "Namelist object '%s' truncated on read.", | |
3117 | nl->var_name); | |
3118 | generate_warning (&dtp->common, nml_err_msg); | |
3119 | } | |
3120 | m = dlen; | |
3121 | } | |
3122 | else | |
3123 | m = dtp->u.p.saved_used; | |
42c1e008 JD |
3124 | |
3125 | if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) | |
3126 | { | |
3127 | gfc_char4_t *q4, *p4 = pdata; | |
3128 | int i; | |
3129 | ||
3130 | q4 = (gfc_char4_t *) dtp->u.p.saved_string; | |
3131 | p4 += clow -1; | |
3132 | for (i = 0; i < m; i++) | |
3133 | *p4++ = *q4++; | |
3134 | if (m < dlen) | |
3135 | for (i = 0; i < dlen - m; i++) | |
3136 | *p4++ = (gfc_char4_t) ' '; | |
3137 | } | |
3138 | else | |
3139 | { | |
3140 | pdata = (void*)( pdata + clow - 1 ); | |
3141 | memcpy (pdata, dtp->u.p.saved_string, m); | |
3142 | if (m < dlen) | |
3143 | memset ((void*)( pdata + m ), ' ', dlen - m); | |
3144 | } | |
25292a1b | 3145 | break; |
29dc5138 PT |
3146 | |
3147 | default: | |
3148 | break; | |
3149 | } | |
3150 | ||
25292a1b JD |
3151 | /* Warn if a non-standard expanded read occurs. A single read of a |
3152 | single object is acceptable. If a second read occurs, issue a warning | |
3153 | and set the flag to zero to prevent further warnings. */ | |
3154 | if (dtp->u.p.expanded_read == 2) | |
3155 | { | |
2e444427 | 3156 | notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read."); |
25292a1b JD |
3157 | dtp->u.p.expanded_read = 0; |
3158 | } | |
3159 | ||
3160 | /* If the expanded read warning flag is set, increment it, | |
8b6dba81 | 3161 | indicating that a single read has occurred. */ |
25292a1b JD |
3162 | if (dtp->u.p.expanded_read >= 1) |
3163 | dtp->u.p.expanded_read++; | |
29dc5138 | 3164 | |
25292a1b | 3165 | /* Break out of loop if scalar. */ |
29dc5138 PT |
3166 | if (!nl->var_rank) |
3167 | break; | |
3168 | ||
3169 | /* Now increment the index vector. */ | |
3170 | ||
3171 | incr_idx: | |
3172 | ||
3173 | nml_carry = 1; | |
3174 | for (dim = 0; dim < nl->var_rank; dim++) | |
3175 | { | |
3176 | nl->ls[dim].idx += nml_carry * nl->ls[dim].step; | |
3177 | nml_carry = 0; | |
3178 | if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end)) | |
3179 | || | |
3180 | ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end))) | |
3181 | { | |
3182 | nl->ls[dim].idx = nl->ls[dim].start; | |
3183 | nml_carry = 1; | |
3184 | } | |
3185 | } | |
3186 | } while (!nml_carry); | |
3187 | ||
5e805e44 | 3188 | if (dtp->u.p.repeat_count > 1) |
29dc5138 | 3189 | { |
24722ea9 JJ |
3190 | snprintf (nml_err_msg, nml_err_msg_size, |
3191 | "Repeat count too large for namelist object %s", nl->var_name); | |
3192 | goto nml_err_ret; | |
29dc5138 | 3193 | } |
f5e3ed2d | 3194 | return true; |
29dc5138 PT |
3195 | |
3196 | nml_err_ret: | |
3197 | ||
f5e3ed2d | 3198 | return false; |
29dc5138 PT |
3199 | } |
3200 | ||
3201 | /* Parses the object name, including array and substring qualifiers. It | |
3202 | iterates over derived type components, touching those components and | |
3203 | setting their loop specifications, if there is a qualifier. If the | |
3204 | object is itself a derived type, its components and subcomponents are | |
3205 | touched. nml_read_obj is called at the end and this reads the data in | |
3206 | the manner specified by the object name. */ | |
3207 | ||
f5e3ed2d | 3208 | static bool |
5e805e44 | 3209 | nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, |
24722ea9 | 3210 | char *nml_err_msg, size_t nml_err_msg_size) |
29dc5138 | 3211 | { |
c86af7f3 | 3212 | int c; |
f29876bb JD |
3213 | namelist_info *nl; |
3214 | namelist_info *first_nl = NULL; | |
3215 | namelist_info *root_nl = NULL; | |
45dfbe77 | 3216 | int dim, parsed_rank; |
e3e2cdd1 | 3217 | int component_flag, qualifier_flag; |
5e805e44 | 3218 | index_type clow, chigh; |
45dfbe77 | 3219 | int non_zero_rank_count; |
29dc5138 PT |
3220 | |
3221 | /* Look for end of input or object name. If '?' or '=?' are encountered | |
3222 | in stdin, print the node names or the namelist to stdout. */ | |
3223 | ||
5e805e44 JJ |
3224 | eat_separator (dtp); |
3225 | if (dtp->u.p.input_complete) | |
f5e3ed2d | 3226 | return true; |
29dc5138 | 3227 | |
5e805e44 JJ |
3228 | if (dtp->u.p.at_eol) |
3229 | finish_separator (dtp); | |
3230 | if (dtp->u.p.input_complete) | |
f5e3ed2d | 3231 | return true; |
29dc5138 | 3232 | |
c86af7f3 | 3233 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 3234 | goto nml_err_ret; |
29dc5138 PT |
3235 | switch (c) |
3236 | { | |
3237 | case '=': | |
c86af7f3 | 3238 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 3239 | goto nml_err_ret; |
29dc5138 PT |
3240 | if (c != '?') |
3241 | { | |
fc12098d | 3242 | snprintf (nml_err_msg, nml_err_msg_size, |
d30fe1c5 | 3243 | "namelist read: misplaced = sign"); |
29dc5138 PT |
3244 | goto nml_err_ret; |
3245 | } | |
5e805e44 | 3246 | nml_query (dtp, '='); |
f5e3ed2d | 3247 | return true; |
29dc5138 PT |
3248 | |
3249 | case '?': | |
5e805e44 | 3250 | nml_query (dtp, '?'); |
f5e3ed2d | 3251 | return true; |
29dc5138 PT |
3252 | |
3253 | case '$': | |
3254 | case '&': | |
5e805e44 JJ |
3255 | nml_match_name (dtp, "end", 3); |
3256 | if (dtp->u.p.nml_read_error) | |
29dc5138 | 3257 | { |
fc12098d | 3258 | snprintf (nml_err_msg, nml_err_msg_size, |
d30fe1c5 | 3259 | "namelist not terminated with / or &end"); |
29dc5138 PT |
3260 | goto nml_err_ret; |
3261 | } | |
95bd9622 | 3262 | /* Fall through. */ |
29dc5138 | 3263 | case '/': |
5e805e44 | 3264 | dtp->u.p.input_complete = 1; |
f5e3ed2d | 3265 | return true; |
29dc5138 PT |
3266 | |
3267 | default : | |
3268 | break; | |
3269 | } | |
3270 | ||
e3e2cdd1 | 3271 | /* Untouch all nodes of the namelist and reset the flags that are set for |
29dc5138 PT |
3272 | derived type components. */ |
3273 | ||
5e805e44 | 3274 | nml_untouch_nodes (dtp); |
29dc5138 | 3275 | component_flag = 0; |
e3e2cdd1 | 3276 | qualifier_flag = 0; |
45dfbe77 | 3277 | non_zero_rank_count = 0; |
29dc5138 PT |
3278 | |
3279 | /* Get the object name - should '!' and '\n' be permitted separators? */ | |
3280 | ||
3281 | get_name: | |
3282 | ||
5e805e44 | 3283 | free_saved (dtp); |
29dc5138 PT |
3284 | |
3285 | do | |
3286 | { | |
78a15b1f | 3287 | if (!is_separator (c)) |
21423a1d | 3288 | push_char_default (dtp, safe_tolower(c)); |
c86af7f3 | 3289 | if ((c = next_char (dtp)) == EOF) |
83437e67 JD |
3290 | goto nml_err_ret; |
3291 | } | |
3292 | while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' )); | |
29dc5138 | 3293 | |
5e805e44 | 3294 | unget_char (dtp, c); |
29dc5138 PT |
3295 | |
3296 | /* Check that the name is in the namelist and get pointer to object. | |
3297 | Three error conditions exist: (i) An attempt is being made to | |
3298 | identify a non-existent object, following a failed data read or | |
3299 | (ii) The object name does not exist or (iii) Too many data items | |
3300 | are present for an object. (iii) gives the same error message | |
3301 | as (i) */ | |
3302 | ||
d428be77 | 3303 | push_char_default (dtp, '\0'); |
29dc5138 PT |
3304 | |
3305 | if (component_flag) | |
3306 | { | |
581d2326 JB |
3307 | #define EXT_STACK_SZ 100 |
3308 | char ext_stack[EXT_STACK_SZ]; | |
3309 | char *ext_name; | |
5e805e44 JJ |
3310 | size_t var_len = strlen (root_nl->var_name); |
3311 | size_t saved_len | |
3312 | = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0; | |
581d2326 JB |
3313 | size_t ext_size = var_len + saved_len + 1; |
3314 | ||
3315 | if (ext_size > EXT_STACK_SZ) | |
3316 | ext_name = xmalloc (ext_size); | |
3317 | else | |
3318 | ext_name = ext_stack; | |
5e805e44 JJ |
3319 | |
3320 | memcpy (ext_name, root_nl->var_name, var_len); | |
3321 | if (dtp->u.p.saved_string) | |
3322 | memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len); | |
3323 | ext_name[var_len + saved_len] = '\0'; | |
3324 | nl = find_nml_node (dtp, ext_name); | |
581d2326 JB |
3325 | |
3326 | if (ext_size > EXT_STACK_SZ) | |
3327 | free (ext_name); | |
29dc5138 PT |
3328 | } |
3329 | else | |
5e805e44 | 3330 | nl = find_nml_node (dtp, dtp->u.p.saved_string); |
29dc5138 PT |
3331 | |
3332 | if (nl == NULL) | |
3333 | { | |
5e805e44 | 3334 | if (dtp->u.p.nml_read_error && *pprev_nl) |
24722ea9 JJ |
3335 | snprintf (nml_err_msg, nml_err_msg_size, |
3336 | "Bad data for namelist object %s", (*pprev_nl)->var_name); | |
29dc5138 PT |
3337 | |
3338 | else | |
24722ea9 JJ |
3339 | snprintf (nml_err_msg, nml_err_msg_size, |
3340 | "Cannot match namelist object name %s", | |
3341 | dtp->u.p.saved_string); | |
29dc5138 PT |
3342 | |
3343 | goto nml_err_ret; | |
3344 | } | |
3345 | ||
3346 | /* Get the length, data length, base pointer and rank of the variable. | |
3347 | Set the default loop specification first. */ | |
3348 | ||
3349 | for (dim=0; dim < nl->var_rank; dim++) | |
3350 | { | |
3351 | nl->ls[dim].step = 1; | |
dfb55fdc TK |
3352 | nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); |
3353 | nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); | |
29dc5138 PT |
3354 | nl->ls[dim].idx = nl->ls[dim].start; |
3355 | } | |
3356 | ||
3357 | /* Check to see if there is a qualifier: if so, parse it.*/ | |
3358 | ||
3359 | if (c == '(' && nl->var_rank) | |
3360 | { | |
45dfbe77 | 3361 | parsed_rank = 0; |
f5e3ed2d | 3362 | if (!nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, |
6f6fafc9 | 3363 | nl->type, nml_err_msg, nml_err_msg_size, |
f5e3ed2d | 3364 | &parsed_rank)) |
29dc5138 | 3365 | { |
24722ea9 JJ |
3366 | char *nml_err_msg_end = strchr (nml_err_msg, '\0'); |
3367 | snprintf (nml_err_msg_end, | |
3368 | nml_err_msg_size - (nml_err_msg_end - nml_err_msg), | |
3369 | " for namelist variable %s", nl->var_name); | |
29dc5138 PT |
3370 | goto nml_err_ret; |
3371 | } | |
45dfbe77 JD |
3372 | if (parsed_rank > 0) |
3373 | non_zero_rank_count++; | |
3374 | ||
e3e2cdd1 JD |
3375 | qualifier_flag = 1; |
3376 | ||
c86af7f3 | 3377 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 3378 | goto nml_err_ret; |
5e805e44 | 3379 | unget_char (dtp, c); |
29dc5138 | 3380 | } |
45dfbe77 JD |
3381 | else if (nl->var_rank > 0) |
3382 | non_zero_rank_count++; | |
29dc5138 PT |
3383 | |
3384 | /* Now parse a derived type component. The root namelist_info address | |
3385 | is backed up, as is the previous component level. The component flag | |
3386 | is set and the iteration is made by jumping back to get_name. */ | |
3387 | ||
3388 | if (c == '%') | |
3389 | { | |
a11930ba | 3390 | if (nl->type != BT_DERIVED) |
29dc5138 | 3391 | { |
24722ea9 JJ |
3392 | snprintf (nml_err_msg, nml_err_msg_size, |
3393 | "Attempt to get derived component for %s", nl->var_name); | |
29dc5138 PT |
3394 | goto nml_err_ret; |
3395 | } | |
3396 | ||
a0b67fe2 TS |
3397 | /* Don't move first_nl further in the list if a qualifier was found. */ |
3398 | if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag) | |
29dc5138 PT |
3399 | first_nl = nl; |
3400 | ||
3401 | root_nl = nl; | |
3423894f | 3402 | |
29dc5138 | 3403 | component_flag = 1; |
c86af7f3 | 3404 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 3405 | goto nml_err_ret; |
29dc5138 | 3406 | goto get_name; |
29dc5138 PT |
3407 | } |
3408 | ||
3409 | /* Parse a character qualifier, if present. chigh = 0 is a default | |
3410 | that signals that the string length = string_length. */ | |
3411 | ||
3412 | clow = 1; | |
3413 | chigh = 0; | |
3414 | ||
a11930ba | 3415 | if (c == '(' && nl->type == BT_CHARACTER) |
29dc5138 | 3416 | { |
4b6903ec | 3417 | descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; |
965eec16 | 3418 | array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; |
29dc5138 | 3419 | |
6f6fafc9 TS |
3420 | if (!nml_parse_qualifier (dtp, chd, ind, -1, nl->type, |
3421 | nml_err_msg, nml_err_msg_size, &parsed_rank)) | |
29dc5138 | 3422 | { |
24722ea9 JJ |
3423 | char *nml_err_msg_end = strchr (nml_err_msg, '\0'); |
3424 | snprintf (nml_err_msg_end, | |
3425 | nml_err_msg_size - (nml_err_msg_end - nml_err_msg), | |
3426 | " for namelist variable %s", nl->var_name); | |
29dc5138 PT |
3427 | goto nml_err_ret; |
3428 | } | |
3429 | ||
3430 | clow = ind[0].start; | |
3431 | chigh = ind[0].end; | |
3432 | ||
3433 | if (ind[0].step != 1) | |
3434 | { | |
24722ea9 JJ |
3435 | snprintf (nml_err_msg, nml_err_msg_size, |
3436 | "Step not allowed in substring qualifier" | |
3437 | " for namelist object %s", nl->var_name); | |
29dc5138 PT |
3438 | goto nml_err_ret; |
3439 | } | |
3440 | ||
c86af7f3 | 3441 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 3442 | goto nml_err_ret; |
5e805e44 | 3443 | unget_char (dtp, c); |
29dc5138 PT |
3444 | } |
3445 | ||
45dfbe77 | 3446 | /* Make sure no extraneous qualifiers are there. */ |
29dc5138 PT |
3447 | |
3448 | if (c == '(') | |
3449 | { | |
24722ea9 JJ |
3450 | snprintf (nml_err_msg, nml_err_msg_size, |
3451 | "Qualifier for a scalar or non-character namelist object %s", | |
3452 | nl->var_name); | |
29dc5138 PT |
3453 | goto nml_err_ret; |
3454 | } | |
3455 | ||
45dfbe77 JD |
3456 | /* Make sure there is no more than one non-zero rank object. */ |
3457 | if (non_zero_rank_count > 1) | |
3458 | { | |
24722ea9 JJ |
3459 | snprintf (nml_err_msg, nml_err_msg_size, |
3460 | "Multiple sub-objects with non-zero rank in namelist object %s", | |
3461 | nl->var_name); | |
45dfbe77 JD |
3462 | non_zero_rank_count = 0; |
3463 | goto nml_err_ret; | |
3464 | } | |
3465 | ||
29dc5138 PT |
3466 | /* According to the standard, an equal sign MUST follow an object name. The |
3467 | following is possibly lax - it allows comments, blank lines and so on to | |
5e805e44 | 3468 | intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/ |
29dc5138 | 3469 | |
5e805e44 | 3470 | free_saved (dtp); |
29dc5138 | 3471 | |
5e805e44 JJ |
3472 | eat_separator (dtp); |
3473 | if (dtp->u.p.input_complete) | |
f5e3ed2d | 3474 | return true; |
29dc5138 | 3475 | |
5e805e44 JJ |
3476 | if (dtp->u.p.at_eol) |
3477 | finish_separator (dtp); | |
3478 | if (dtp->u.p.input_complete) | |
f5e3ed2d | 3479 | return true; |
29dc5138 | 3480 | |
c86af7f3 | 3481 | if ((c = next_char (dtp)) == EOF) |
83437e67 | 3482 | goto nml_err_ret; |
29dc5138 PT |
3483 | |
3484 | if (c != '=') | |
3485 | { | |
24722ea9 JJ |
3486 | snprintf (nml_err_msg, nml_err_msg_size, |
3487 | "Equal sign must follow namelist object name %s", | |
3488 | nl->var_name); | |
29dc5138 PT |
3489 | goto nml_err_ret; |
3490 | } | |
fdc54f39 | 3491 | |
e3e2cdd1 JD |
3492 | /* If a derived type, touch its components and restore the root |
3493 | namelist_info if we have parsed a qualified derived type | |
3494 | component. */ | |
3495 | ||
fdc54f39 | 3496 | if (nl->type == BT_DERIVED && nl->dtio_sub == NULL) |
e3e2cdd1 JD |
3497 | nml_touch_nodes (nl); |
3498 | ||
3499 | if (first_nl) | |
3500 | { | |
3501 | if (first_nl->var_rank == 0) | |
3502 | { | |
3503 | if (component_flag && qualifier_flag) | |
3504 | nl = first_nl; | |
3505 | } | |
3506 | else | |
3507 | nl = first_nl; | |
3508 | } | |
6de9cd9a | 3509 | |
ba829325 | 3510 | dtp->u.p.nml_read_error = 0; |
f5e3ed2d JB |
3511 | if (!nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size, |
3512 | clow, chigh)) | |
29dc5138 PT |
3513 | goto nml_err_ret; |
3514 | ||
f5e3ed2d | 3515 | return true; |
29dc5138 PT |
3516 | |
3517 | nml_err_ret: | |
3518 | ||
83437e67 JD |
3519 | /* The EOF error message is issued by hit_eof. Return true so that the |
3520 | caller does not use nml_err_msg and nml_err_msg_size to generate | |
3521 | an unrelated error message. */ | |
3522 | if (c == EOF) | |
3523 | { | |
3524 | dtp->u.p.input_complete = 1; | |
3525 | unget_char (dtp, c); | |
3526 | hit_eof (dtp); | |
3527 | return true; | |
3528 | } | |
f5e3ed2d | 3529 | return false; |
29dc5138 PT |
3530 | } |
3531 | ||
3532 | /* Entry point for namelist input. Goes through input until namelist name | |
3533 | is matched. Then cycles through nml_get_obj_data until the input is | |
3534 | completed or there is an error. */ | |
3535 | ||
3536 | void | |
5e805e44 | 3537 | namelist_read (st_parameter_dt *dtp) |
29dc5138 | 3538 | { |
c86af7f3 | 3539 | int c; |
24722ea9 | 3540 | char nml_err_msg[200]; |
353255cd JD |
3541 | |
3542 | /* Initialize the error string buffer just in case we get an unexpected fail | |
3543 | somewhere and end up at nml_err_ret. */ | |
3544 | strcpy (nml_err_msg, "Internal namelist read error"); | |
3545 | ||
5e805e44 JJ |
3546 | /* Pointer to the previously read object, in case attempt is made to read |
3547 | new object name. Should this fail, error message can give previous | |
3548 | name. */ | |
3549 | namelist_info *prev_nl = NULL; | |
29dc5138 | 3550 | |
5e805e44 | 3551 | dtp->u.p.input_complete = 0; |
25292a1b | 3552 | dtp->u.p.expanded_read = 0; |
fc12098d | 3553 | |
d428be77 JD |
3554 | /* Set the next_char and push_char worker functions. */ |
3555 | set_workers (dtp); | |
29dc5138 | 3556 | |
29dc5138 PT |
3557 | /* Look for &namelist_name . Skip all characters, testing for $nmlname. |
3558 | Exit on success or EOF. If '?' or '=?' encountered in stdin, print | |
3559 | node names or namelist on stdout. */ | |
3560 | ||
3561 | find_nml_name: | |
43e0224a | 3562 | c = next_char (dtp); |
c86af7f3 | 3563 | switch (c) |
29dc5138 PT |
3564 | { |
3565 | case '$': | |
3566 | case '&': | |
6de9cd9a | 3567 | break; |
29dc5138 | 3568 | |
4f8d744e | 3569 | case '!': |
43e0224a | 3570 | eat_line (dtp); |
4f8d744e JD |
3571 | goto find_nml_name; |
3572 | ||
29dc5138 | 3573 | case '=': |
43e0224a | 3574 | c = next_char (dtp); |
29dc5138 | 3575 | if (c == '?') |
5e805e44 | 3576 | nml_query (dtp, '='); |
29dc5138 | 3577 | else |
5e805e44 | 3578 | unget_char (dtp, c); |
29dc5138 PT |
3579 | goto find_nml_name; |
3580 | ||
3581 | case '?': | |
5e805e44 | 3582 | nml_query (dtp, '?'); |
a0b012be | 3583 | goto find_nml_name; |
29dc5138 | 3584 | |
43e0224a JD |
3585 | case EOF: |
3586 | return; | |
3587 | ||
29dc5138 PT |
3588 | default: |
3589 | goto find_nml_name; | |
3590 | } | |
3591 | ||
3592 | /* Match the name of the namelist. */ | |
3593 | ||
5e805e44 | 3594 | nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len); |
29dc5138 | 3595 | |
5e805e44 | 3596 | if (dtp->u.p.nml_read_error) |
29dc5138 PT |
3597 | goto find_nml_name; |
3598 | ||
fc12098d | 3599 | /* A trailing space is required, we give a little latitude here, 10.9.1. */ |
43e0224a | 3600 | c = next_char (dtp); |
7b063fdc | 3601 | if (!is_separator(c) && c != '!') |
cf9293a1 JD |
3602 | { |
3603 | unget_char (dtp, c); | |
3604 | goto find_nml_name; | |
3605 | } | |
3606 | ||
bdd3085e JD |
3607 | unget_char (dtp, c); |
3608 | eat_separator (dtp); | |
a82094b7 | 3609 | |
29dc5138 PT |
3610 | /* Ready to read namelist objects. If there is an error in input |
3611 | from stdin, output the error message and continue. */ | |
3612 | ||
5e805e44 | 3613 | while (!dtp->u.p.input_complete) |
29dc5138 | 3614 | { |
f5e3ed2d | 3615 | if (!nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)) |
9443a185 | 3616 | goto nml_err_ret; |
353255cd JD |
3617 | |
3618 | /* Reset the previous namelist pointer if we know we are not going | |
3619 | to be doing multiple reads within a single namelist object. */ | |
3620 | if (prev_nl && prev_nl->var_rank == 0) | |
3621 | prev_nl = NULL; | |
e1721879 | 3622 | } |
5e805e44 | 3623 | |
5e805e44 | 3624 | free_saved (dtp); |
c9f15d9c | 3625 | free_line (dtp); |
29dc5138 PT |
3626 | return; |
3627 | ||
c86af7f3 | 3628 | |
29dc5138 PT |
3629 | nml_err_ret: |
3630 | ||
43e0224a | 3631 | /* All namelist error calls return from here */ |
5e805e44 | 3632 | free_saved (dtp); |
c9f15d9c | 3633 | free_line (dtp); |
d74b97cc | 3634 | generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); |
29dc5138 | 3635 | return; |
6de9cd9a | 3636 | } |