]>
Commit | Line | Data |
---|---|---|
a1ff2ab8 | 1 | /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 |
10256cbe | 2 | Free Software Foundation, Inc. |
6de9cd9a | 3 | Contributed by Andy Vaught |
29dc5138 | 4 | Namelist input contributed by Paul Thomas |
10256cbe | 5 | F2003 I/O support contributed by Jerry DeLisle |
6de9cd9a | 6 | |
bb408e87 | 7 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a DN |
8 | |
9 | Libgfortran is free software; you can redistribute it and/or modify | |
10 | it under the terms of the GNU General Public License as published by | |
748086b7 | 11 | the Free Software Foundation; either version 3, or (at your option) |
6de9cd9a DN |
12 | any later version. |
13 | ||
14 | Libgfortran is distributed in the hope that it will be useful, | |
15 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | GNU General Public License for more details. | |
18 | ||
748086b7 JJ |
19 | Under Section 7 of GPL version 3, you are granted additional |
20 | permissions described in the GCC Runtime Library Exception, version | |
21 | 3.1, as published by the Free Software Foundation. | |
22 | ||
23 | You should have received a copy of the GNU General Public License and | |
24 | a copy of the GCC Runtime Library Exception along with this program; | |
25 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
26 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
27 | |
28 | ||
36ae8a61 | 29 | #include "io.h" |
92cbdb68 JB |
30 | #include "fbuf.h" |
31 | #include "unix.h" | |
6de9cd9a | 32 | #include <string.h> |
7812c78c | 33 | #include <stdlib.h> |
6de9cd9a | 34 | #include <ctype.h> |
6de9cd9a DN |
35 | |
36 | ||
37 | /* List directed input. Several parsing subroutines are practically | |
7fcb1804 TS |
38 | reimplemented from formatted input, the reason being that there are |
39 | all kinds of small differences between formatted and list directed | |
40 | parsing. */ | |
6de9cd9a DN |
41 | |
42 | ||
43 | /* Subroutines for reading characters from the input. Because a | |
7fcb1804 TS |
44 | repeat count is ambiguous with an integer, we have to read the |
45 | whole digit string before seeing if there is a '*' which signals | |
46 | the repeat count. Since we can have a lot of potential leading | |
47 | zeros, we have to be able to back up by arbitrary amount. Because | |
48 | the input might not be seekable, we have to buffer the data | |
5e805e44 | 49 | ourselves. */ |
6de9cd9a DN |
50 | |
51 | #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ | |
52 | case '5': case '6': case '7': case '8': case '9' | |
53 | ||
94887ef4 | 54 | #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \ |
10256cbe | 55 | 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 == ' ' \ | |
10256cbe | 60 | || c == '\t' || c == '\r' || c == ';') |
6de9cd9a | 61 | |
7fcb1804 | 62 | /* Maximum repeat count. Less than ten times the maximum signed int32. */ |
6de9cd9a DN |
63 | |
64 | #define MAX_REPEAT 200000000 | |
65 | ||
24722ea9 JJ |
66 | #ifndef HAVE_SNPRINTF |
67 | # undef snprintf | |
68 | # define snprintf(str, size, ...) sprintf (str, __VA_ARGS__) | |
69 | #endif | |
6de9cd9a | 70 | |
7fcb1804 | 71 | /* Save a character to a string buffer, enlarging it as necessary. */ |
6de9cd9a DN |
72 | |
73 | static void | |
5e805e44 | 74 | push_char (st_parameter_dt *dtp, char c) |
6de9cd9a DN |
75 | { |
76 | char *new; | |
77 | ||
5e805e44 | 78 | if (dtp->u.p.saved_string == NULL) |
6de9cd9a | 79 | { |
7812c78c JD |
80 | dtp->u.p.saved_string = get_mem (SCRATCH_SIZE); |
81 | // memset below should be commented out. | |
5e805e44 JJ |
82 | memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE); |
83 | dtp->u.p.saved_length = SCRATCH_SIZE; | |
84 | dtp->u.p.saved_used = 0; | |
6de9cd9a DN |
85 | } |
86 | ||
5e805e44 | 87 | if (dtp->u.p.saved_used >= dtp->u.p.saved_length) |
6de9cd9a | 88 | { |
5e805e44 | 89 | dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; |
7812c78c JD |
90 | new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length); |
91 | if (new == NULL) | |
92 | generate_error (&dtp->common, LIBERROR_OS, NULL); | |
f3ed1d02 | 93 | dtp->u.p.saved_string = new; |
7812c78c JD |
94 | |
95 | // Also this should not be necessary. | |
96 | memset (new + dtp->u.p.saved_used, 0, | |
97 | dtp->u.p.saved_length - dtp->u.p.saved_used); | |
98 | ||
6de9cd9a DN |
99 | } |
100 | ||
5e805e44 | 101 | dtp->u.p.saved_string[dtp->u.p.saved_used++] = c; |
6de9cd9a DN |
102 | } |
103 | ||
104 | ||
7fcb1804 | 105 | /* Free the input buffer if necessary. */ |
6de9cd9a DN |
106 | |
107 | static void | |
5e805e44 | 108 | free_saved (st_parameter_dt *dtp) |
6de9cd9a | 109 | { |
5e805e44 | 110 | if (dtp->u.p.saved_string == NULL) |
6de9cd9a DN |
111 | return; |
112 | ||
bb408e87 | 113 | free (dtp->u.p.saved_string); |
6de9cd9a | 114 | |
5e805e44 JJ |
115 | dtp->u.p.saved_string = NULL; |
116 | dtp->u.p.saved_used = 0; | |
6de9cd9a DN |
117 | } |
118 | ||
119 | ||
c9f15d9c JD |
120 | /* Free the line buffer if necessary. */ |
121 | ||
122 | static void | |
123 | free_line (st_parameter_dt *dtp) | |
124 | { | |
17f46ec3 JD |
125 | dtp->u.p.item_count = 0; |
126 | dtp->u.p.line_buffer_enabled = 0; | |
127 | ||
c9f15d9c JD |
128 | if (dtp->u.p.line_buffer == NULL) |
129 | return; | |
130 | ||
bb408e87 | 131 | free (dtp->u.p.line_buffer); |
c9f15d9c JD |
132 | dtp->u.p.line_buffer = NULL; |
133 | } | |
134 | ||
135 | ||
6de9cd9a | 136 | static char |
5e805e44 | 137 | next_char (st_parameter_dt *dtp) |
6de9cd9a | 138 | { |
7812c78c | 139 | ssize_t length; |
8ad4c895 | 140 | gfc_offset record; |
15877a88 | 141 | char c; |
7812c78c | 142 | int cc; |
6de9cd9a | 143 | |
5e805e44 | 144 | if (dtp->u.p.last_char != '\0') |
6de9cd9a | 145 | { |
5e805e44 JJ |
146 | dtp->u.p.at_eol = 0; |
147 | c = dtp->u.p.last_char; | |
148 | dtp->u.p.last_char = '\0'; | |
6de9cd9a DN |
149 | goto done; |
150 | } | |
151 | ||
c9f15d9c JD |
152 | /* Read from line_buffer if enabled. */ |
153 | ||
154 | if (dtp->u.p.line_buffer_enabled) | |
155 | { | |
156 | dtp->u.p.at_eol = 0; | |
157 | ||
158 | c = dtp->u.p.line_buffer[dtp->u.p.item_count]; | |
159 | if (c != '\0' && dtp->u.p.item_count < 64) | |
160 | { | |
161 | dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0'; | |
162 | dtp->u.p.item_count++; | |
163 | goto done; | |
164 | } | |
165 | ||
17f46ec3 JD |
166 | dtp->u.p.item_count = 0; |
167 | dtp->u.p.line_buffer_enabled = 0; | |
c9f15d9c | 168 | } |
6de9cd9a | 169 | |
807fb853 JD |
170 | /* Handle the end-of-record and end-of-file conditions for |
171 | internal array unit. */ | |
d10fb73e | 172 | if (is_array_io (dtp)) |
6de9cd9a | 173 | { |
807fb853 | 174 | if (dtp->u.p.at_eof) |
8ad4c895 JD |
175 | longjmp (*dtp->u.p.eof_jump, 1); |
176 | ||
807fb853 JD |
177 | /* Check for "end-of-record" condition. */ |
178 | if (dtp->u.p.current_unit->bytes_left == 0) | |
179 | { | |
9370b3c0 TK |
180 | int finished; |
181 | ||
bbd6c8aa | 182 | c = '\n'; |
9370b3c0 TK |
183 | record = next_array_record (dtp, dtp->u.p.current_unit->ls, |
184 | &finished); | |
8ad4c895 | 185 | |
807fb853 | 186 | /* Check for "end-of-file" condition. */ |
9370b3c0 | 187 | if (finished) |
807fb853 JD |
188 | { |
189 | dtp->u.p.at_eof = 1; | |
807fb853 JD |
190 | goto done; |
191 | } | |
192 | ||
193 | record *= dtp->u.p.current_unit->recl; | |
7812c78c | 194 | if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) |
807fb853 JD |
195 | longjmp (*dtp->u.p.eof_jump, 1); |
196 | ||
197 | dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
bbd6c8aa | 198 | goto done; |
807fb853 | 199 | } |
6de9cd9a DN |
200 | } |
201 | ||
807fb853 | 202 | /* Get the next character and handle end-of-record conditions. */ |
c9f15d9c | 203 | |
f3ed1d02 JB |
204 | if (is_internal_unit (dtp)) |
205 | { | |
7812c78c JD |
206 | length = sread (dtp->u.p.current_unit->s, &c, 1); |
207 | if (length < 0) | |
208 | { | |
209 | generate_error (&dtp->common, LIBERROR_OS, NULL); | |
210 | return '\0'; | |
211 | } | |
212 | ||
d10fb73e | 213 | if (is_array_io (dtp)) |
8ad4c895 | 214 | { |
15877a88 JB |
215 | /* Check whether we hit EOF. */ |
216 | if (length == 0) | |
8ad4c895 | 217 | { |
d74b97cc | 218 | generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); |
8ad4c895 | 219 | return '\0'; |
15877a88 | 220 | } |
8ad4c895 | 221 | dtp->u.p.current_unit->bytes_left--; |
8ad4c895 | 222 | } |
334ff453 | 223 | else |
8ad4c895 | 224 | { |
15877a88 | 225 | if (dtp->u.p.at_eof) |
8ad4c895 JD |
226 | longjmp (*dtp->u.p.eof_jump, 1); |
227 | if (length == 0) | |
15877a88 JB |
228 | { |
229 | c = '\n'; | |
230 | dtp->u.p.at_eof = 1; | |
231 | } | |
8ad4c895 | 232 | } |
334ff453 PB |
233 | } |
234 | else | |
8ad4c895 | 235 | { |
7812c78c JD |
236 | cc = fbuf_getc (dtp->u.p.current_unit); |
237 | ||
238 | if (cc == EOF) | |
04b6b884 | 239 | { |
724cdffe | 240 | if (dtp->u.p.current_unit->endfile == AT_ENDFILE) |
04b6b884 | 241 | longjmp (*dtp->u.p.eof_jump, 1); |
724cdffe JD |
242 | dtp->u.p.current_unit->endfile = AT_ENDFILE; |
243 | c = '\n'; | |
04b6b884 | 244 | } |
7812c78c JD |
245 | else |
246 | c = (char) cc; | |
247 | if (is_stream_io (dtp) && cc != EOF) | |
248 | dtp->u.p.current_unit->strm_pos++; | |
249 | ||
8ad4c895 | 250 | } |
6de9cd9a | 251 | done: |
5e805e44 | 252 | dtp->u.p.at_eol = (c == '\n' || c == '\r'); |
6de9cd9a DN |
253 | return c; |
254 | } | |
255 | ||
256 | ||
7fcb1804 | 257 | /* Push a character back onto the input. */ |
6de9cd9a DN |
258 | |
259 | static void | |
5e805e44 | 260 | unget_char (st_parameter_dt *dtp, char c) |
6de9cd9a | 261 | { |
5e805e44 | 262 | dtp->u.p.last_char = c; |
6de9cd9a DN |
263 | } |
264 | ||
265 | ||
7fcb1804 TS |
266 | /* Skip over spaces in the input. Returns the nonspace character that |
267 | terminated the eating and also places it back on the input. */ | |
6de9cd9a DN |
268 | |
269 | static char | |
5e805e44 | 270 | eat_spaces (st_parameter_dt *dtp) |
6de9cd9a DN |
271 | { |
272 | char c; | |
273 | ||
274 | do | |
275 | { | |
5e805e44 | 276 | c = next_char (dtp); |
6de9cd9a DN |
277 | } |
278 | while (c == ' ' || c == '\t'); | |
279 | ||
5e805e44 | 280 | unget_char (dtp, c); |
6de9cd9a DN |
281 | return c; |
282 | } | |
283 | ||
284 | ||
667e2045 TB |
285 | /* This function reads characters through to the end of the current line and |
286 | just ignores them. */ | |
287 | ||
288 | static void | |
289 | eat_line (st_parameter_dt *dtp) | |
290 | { | |
291 | char c; | |
951b8fbe JD |
292 | |
293 | do | |
294 | c = next_char (dtp); | |
295 | while (c != '\n'); | |
667e2045 TB |
296 | } |
297 | ||
298 | ||
7fcb1804 TS |
299 | /* Skip over a separator. Technically, we don't always eat the whole |
300 | separator. This is because if we've processed the last input item, | |
301 | then a separator is unnecessary. Plus the fact that operating | |
302 | systems usually deliver console input on a line basis. | |
303 | ||
304 | The upshot is that if we see a newline as part of reading a | |
305 | separator, we stop reading. If there are more input items, we | |
306 | continue reading the separator with finish_separator() which takes | |
307 | care of the fact that we may or may not have seen a comma as part | |
308 | of the separator. */ | |
6de9cd9a DN |
309 | |
310 | static void | |
5e805e44 | 311 | eat_separator (st_parameter_dt *dtp) |
6de9cd9a | 312 | { |
8824fd4c | 313 | char c, n; |
6de9cd9a | 314 | |
5e805e44 JJ |
315 | eat_spaces (dtp); |
316 | dtp->u.p.comma_flag = 0; | |
6de9cd9a | 317 | |
5e805e44 | 318 | c = next_char (dtp); |
6de9cd9a DN |
319 | switch (c) |
320 | { | |
321 | case ',': | |
105b7136 | 322 | if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe JD |
323 | { |
324 | unget_char (dtp, c); | |
325 | break; | |
326 | } | |
327 | /* Fall through. */ | |
328 | case ';': | |
5e805e44 JJ |
329 | dtp->u.p.comma_flag = 1; |
330 | eat_spaces (dtp); | |
6de9cd9a DN |
331 | break; |
332 | ||
333 | case '/': | |
5e805e44 | 334 | dtp->u.p.input_complete = 1; |
6de9cd9a DN |
335 | break; |
336 | ||
94887ef4 | 337 | case '\r': |
78a15b1f | 338 | dtp->u.p.at_eol = 1; |
8824fd4c | 339 | n = next_char(dtp); |
36afed5a | 340 | if (n != '\n') |
78a15b1f | 341 | { |
36afed5a JD |
342 | unget_char (dtp, n); |
343 | break; | |
78a15b1f | 344 | } |
36afed5a | 345 | /* Fall through. */ |
8824fd4c | 346 | case '\n': |
5e805e44 | 347 | dtp->u.p.at_eol = 1; |
78a15b1f JD |
348 | if (dtp->u.p.namelist_mode) |
349 | { | |
350 | do | |
667e2045 TB |
351 | { |
352 | c = next_char (dtp); | |
353 | if (c == '!') | |
354 | { | |
355 | eat_line (dtp); | |
356 | c = next_char (dtp); | |
5a79ae84 JD |
357 | if (c == '!') |
358 | { | |
359 | eat_line (dtp); | |
360 | c = next_char (dtp); | |
361 | } | |
667e2045 TB |
362 | } |
363 | } | |
fb669c2b | 364 | while (c == '\n' || c == '\r' || c == ' ' || c == '\t'); |
78a15b1f JD |
365 | unget_char (dtp, c); |
366 | } | |
6de9cd9a DN |
367 | break; |
368 | ||
369 | case '!': | |
5e805e44 | 370 | if (dtp->u.p.namelist_mode) |
7fcb1804 | 371 | { /* Eat a namelist comment. */ |
6de9cd9a | 372 | do |
5e805e44 | 373 | c = next_char (dtp); |
6de9cd9a DN |
374 | while (c != '\n'); |
375 | ||
376 | break; | |
377 | } | |
378 | ||
7fcb1804 | 379 | /* Fall Through... */ |
6de9cd9a DN |
380 | |
381 | default: | |
5e805e44 | 382 | unget_char (dtp, c); |
6de9cd9a DN |
383 | break; |
384 | } | |
385 | } | |
386 | ||
387 | ||
7fcb1804 TS |
388 | /* Finish processing a separator that was interrupted by a newline. |
389 | If we're here, then another data item is present, so we finish what | |
390 | we started on the previous line. */ | |
6de9cd9a DN |
391 | |
392 | static void | |
5e805e44 | 393 | finish_separator (st_parameter_dt *dtp) |
6de9cd9a DN |
394 | { |
395 | char c; | |
396 | ||
f21edfd6 | 397 | restart: |
5e805e44 | 398 | eat_spaces (dtp); |
6de9cd9a | 399 | |
5e805e44 | 400 | c = next_char (dtp); |
6de9cd9a DN |
401 | switch (c) |
402 | { | |
403 | case ',': | |
5e805e44 JJ |
404 | if (dtp->u.p.comma_flag) |
405 | unget_char (dtp, c); | |
6de9cd9a DN |
406 | else |
407 | { | |
5e805e44 | 408 | c = eat_spaces (dtp); |
8824fd4c | 409 | if (c == '\n' || c == '\r') |
6de9cd9a DN |
410 | goto restart; |
411 | } | |
412 | ||
413 | break; | |
414 | ||
415 | case '/': | |
5e805e44 | 416 | dtp->u.p.input_complete = 1; |
b8df885f JD |
417 | if (!dtp->u.p.namelist_mode) |
418 | return; | |
6de9cd9a DN |
419 | break; |
420 | ||
421 | case '\n': | |
94887ef4 | 422 | case '\r': |
6de9cd9a DN |
423 | goto restart; |
424 | ||
425 | case '!': | |
5e805e44 | 426 | if (dtp->u.p.namelist_mode) |
6de9cd9a DN |
427 | { |
428 | do | |
5e805e44 | 429 | c = next_char (dtp); |
6de9cd9a DN |
430 | while (c != '\n'); |
431 | ||
432 | goto restart; | |
433 | } | |
434 | ||
435 | default: | |
5e805e44 | 436 | unget_char (dtp, c); |
6de9cd9a DN |
437 | break; |
438 | } | |
439 | } | |
440 | ||
9855448d | 441 | |
29dc5138 | 442 | /* This function is needed to catch bad conversions so that namelist can |
5e805e44 JJ |
443 | attempt to see if dtp->u.p.saved_string contains a new object name rather |
444 | than a bad value. */ | |
29dc5138 PT |
445 | |
446 | static int | |
5e805e44 | 447 | nml_bad_return (st_parameter_dt *dtp, char c) |
29dc5138 | 448 | { |
5e805e44 | 449 | if (dtp->u.p.namelist_mode) |
29dc5138 | 450 | { |
5e805e44 JJ |
451 | dtp->u.p.nml_read_error = 1; |
452 | unget_char (dtp, c); | |
29dc5138 PT |
453 | return 1; |
454 | } | |
455 | return 0; | |
456 | } | |
6de9cd9a | 457 | |
7fcb1804 TS |
458 | /* Convert an unsigned string to an integer. The length value is -1 |
459 | if we are working on a repeat count. Returns nonzero if we have a | |
5e805e44 | 460 | range problem. As a side effect, frees the dtp->u.p.saved_string. */ |
6de9cd9a DN |
461 | |
462 | static int | |
5e805e44 | 463 | convert_integer (st_parameter_dt *dtp, int length, int negative) |
6de9cd9a DN |
464 | { |
465 | char c, *buffer, message[100]; | |
466 | int m; | |
32aa3bff | 467 | GFC_INTEGER_LARGEST v, max, max10; |
6de9cd9a | 468 | |
5e805e44 | 469 | buffer = dtp->u.p.saved_string; |
6de9cd9a DN |
470 | v = 0; |
471 | ||
472 | max = (length == -1) ? MAX_REPEAT : max_value (length, 1); | |
473 | max10 = max / 10; | |
474 | ||
475 | for (;;) | |
476 | { | |
477 | c = *buffer++; | |
478 | if (c == '\0') | |
479 | break; | |
480 | c -= '0'; | |
481 | ||
482 | if (v > max10) | |
483 | goto overflow; | |
484 | v = 10 * v; | |
485 | ||
486 | if (v > max - c) | |
487 | goto overflow; | |
488 | v += c; | |
489 | } | |
490 | ||
491 | m = 0; | |
492 | ||
493 | if (length != -1) | |
494 | { | |
495 | if (negative) | |
496 | v = -v; | |
5e805e44 | 497 | set_integer (dtp->u.p.value, v, length); |
6de9cd9a DN |
498 | } |
499 | else | |
500 | { | |
5e805e44 | 501 | dtp->u.p.repeat_count = v; |
6de9cd9a | 502 | |
5e805e44 | 503 | if (dtp->u.p.repeat_count == 0) |
6de9cd9a | 504 | { |
d8163f5c TK |
505 | sprintf (message, "Zero repeat count in item %d of list input", |
506 | dtp->u.p.item_count); | |
6de9cd9a | 507 | |
d74b97cc | 508 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
509 | m = 1; |
510 | } | |
511 | } | |
512 | ||
5e805e44 | 513 | free_saved (dtp); |
6de9cd9a DN |
514 | return m; |
515 | ||
f21edfd6 | 516 | overflow: |
6de9cd9a | 517 | if (length == -1) |
d8163f5c TK |
518 | sprintf (message, "Repeat count overflow in item %d of list input", |
519 | dtp->u.p.item_count); | |
6de9cd9a | 520 | else |
d8163f5c TK |
521 | sprintf (message, "Integer overflow while reading item %d", |
522 | dtp->u.p.item_count); | |
6de9cd9a | 523 | |
5e805e44 | 524 | free_saved (dtp); |
d74b97cc | 525 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
526 | |
527 | return 1; | |
528 | } | |
529 | ||
530 | ||
7fcb1804 TS |
531 | /* Parse a repeat count for logical and complex values which cannot |
532 | begin with a digit. Returns nonzero if we are done, zero if we | |
533 | should continue on. */ | |
6de9cd9a DN |
534 | |
535 | static int | |
5e805e44 | 536 | parse_repeat (st_parameter_dt *dtp) |
6de9cd9a DN |
537 | { |
538 | char c, message[100]; | |
539 | int repeat; | |
540 | ||
5e805e44 | 541 | c = next_char (dtp); |
6de9cd9a DN |
542 | switch (c) |
543 | { | |
544 | CASE_DIGITS: | |
545 | repeat = c - '0'; | |
546 | break; | |
547 | ||
548 | CASE_SEPARATORS: | |
5e805e44 JJ |
549 | unget_char (dtp, c); |
550 | eat_separator (dtp); | |
6de9cd9a DN |
551 | return 1; |
552 | ||
553 | default: | |
5e805e44 | 554 | unget_char (dtp, c); |
6de9cd9a DN |
555 | return 0; |
556 | } | |
557 | ||
558 | for (;;) | |
559 | { | |
5e805e44 | 560 | c = next_char (dtp); |
6de9cd9a DN |
561 | switch (c) |
562 | { | |
563 | CASE_DIGITS: | |
564 | repeat = 10 * repeat + c - '0'; | |
565 | ||
566 | if (repeat > MAX_REPEAT) | |
567 | { | |
d8163f5c TK |
568 | sprintf (message, |
569 | "Repeat count overflow in item %d of list input", | |
570 | dtp->u.p.item_count); | |
6de9cd9a | 571 | |
d74b97cc | 572 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
573 | return 1; |
574 | } | |
575 | ||
576 | break; | |
577 | ||
578 | case '*': | |
579 | if (repeat == 0) | |
580 | { | |
d8163f5c TK |
581 | sprintf (message, |
582 | "Zero repeat count in item %d of list input", | |
583 | dtp->u.p.item_count); | |
6de9cd9a | 584 | |
d74b97cc | 585 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
586 | return 1; |
587 | } | |
588 | ||
589 | goto done; | |
590 | ||
591 | default: | |
592 | goto bad_repeat; | |
593 | } | |
594 | } | |
595 | ||
f21edfd6 | 596 | done: |
5e805e44 | 597 | dtp->u.p.repeat_count = repeat; |
6de9cd9a DN |
598 | return 0; |
599 | ||
f21edfd6 | 600 | bad_repeat: |
9855448d JD |
601 | |
602 | eat_line (dtp); | |
603 | free_saved (dtp); | |
d8163f5c TK |
604 | sprintf (message, "Bad repeat count in item %d of list input", |
605 | dtp->u.p.item_count); | |
d74b97cc | 606 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
607 | return 1; |
608 | } | |
609 | ||
610 | ||
c9f15d9c JD |
611 | /* To read a logical we have to look ahead in the input stream to make sure |
612 | there is not an equal sign indicating a variable name. To do this we use | |
613 | line_buffer to point to a temporary buffer, pushing characters there for | |
614 | possible later reading. */ | |
615 | ||
616 | static void | |
617 | l_push_char (st_parameter_dt *dtp, char c) | |
618 | { | |
c9f15d9c JD |
619 | if (dtp->u.p.line_buffer == NULL) |
620 | { | |
621 | dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE); | |
622 | memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE); | |
623 | } | |
624 | ||
625 | dtp->u.p.line_buffer[dtp->u.p.item_count++] = c; | |
626 | } | |
627 | ||
628 | ||
7fcb1804 | 629 | /* Read a logical character on the input. */ |
6de9cd9a DN |
630 | |
631 | static void | |
5e805e44 | 632 | read_logical (st_parameter_dt *dtp, int length) |
6de9cd9a DN |
633 | { |
634 | char c, message[100]; | |
c9f15d9c | 635 | int i, v; |
6de9cd9a | 636 | |
5e805e44 | 637 | if (parse_repeat (dtp)) |
6de9cd9a DN |
638 | return; |
639 | ||
c9f15d9c JD |
640 | c = tolower (next_char (dtp)); |
641 | l_push_char (dtp, c); | |
6de9cd9a DN |
642 | switch (c) |
643 | { | |
644 | case 't': | |
6de9cd9a | 645 | v = 1; |
c9f15d9c JD |
646 | c = next_char (dtp); |
647 | l_push_char (dtp, c); | |
648 | ||
649 | if (!is_separator(c)) | |
650 | goto possible_name; | |
651 | ||
652 | unget_char (dtp, c); | |
6de9cd9a DN |
653 | break; |
654 | case 'f': | |
6de9cd9a | 655 | v = 0; |
c9f15d9c JD |
656 | c = next_char (dtp); |
657 | l_push_char (dtp, c); | |
6de9cd9a | 658 | |
c9f15d9c JD |
659 | if (!is_separator(c)) |
660 | goto possible_name; | |
661 | ||
662 | unget_char (dtp, c); | |
663 | break; | |
10256cbe | 664 | |
6de9cd9a | 665 | case '.': |
c9f15d9c | 666 | c = tolower (next_char (dtp)); |
6de9cd9a DN |
667 | switch (c) |
668 | { | |
c9f15d9c JD |
669 | case 't': |
670 | v = 1; | |
671 | break; | |
672 | case 'f': | |
673 | v = 0; | |
674 | break; | |
675 | default: | |
676 | goto bad_logical; | |
6de9cd9a DN |
677 | } |
678 | ||
679 | break; | |
680 | ||
681 | CASE_SEPARATORS: | |
5e805e44 JJ |
682 | unget_char (dtp, c); |
683 | eat_separator (dtp); | |
7fcb1804 | 684 | return; /* Null value. */ |
6de9cd9a DN |
685 | |
686 | default: | |
17f46ec3 JD |
687 | /* Save the character in case it is the beginning |
688 | of the next object name. */ | |
689 | unget_char (dtp, c); | |
6de9cd9a DN |
690 | goto bad_logical; |
691 | } | |
692 | ||
5e805e44 JJ |
693 | dtp->u.p.saved_type = BT_LOGICAL; |
694 | dtp->u.p.saved_length = length; | |
6de9cd9a | 695 | |
7fcb1804 | 696 | /* Eat trailing garbage. */ |
6de9cd9a DN |
697 | do |
698 | { | |
5e805e44 | 699 | c = next_char (dtp); |
6de9cd9a DN |
700 | } |
701 | while (!is_separator (c)); | |
702 | ||
5e805e44 JJ |
703 | unget_char (dtp, c); |
704 | eat_separator (dtp); | |
5e805e44 | 705 | set_integer ((int *) dtp->u.p.value, v, length); |
4e72e1c5 | 706 | free_line (dtp); |
6de9cd9a DN |
707 | |
708 | return; | |
709 | ||
c9f15d9c JD |
710 | possible_name: |
711 | ||
712 | for(i = 0; i < 63; i++) | |
713 | { | |
714 | c = next_char (dtp); | |
715 | if (is_separator(c)) | |
716 | { | |
03e957f8 JD |
717 | /* All done if this is not a namelist read. */ |
718 | if (!dtp->u.p.namelist_mode) | |
719 | goto logical_done; | |
720 | ||
c9f15d9c JD |
721 | unget_char (dtp, c); |
722 | eat_separator (dtp); | |
723 | c = next_char (dtp); | |
724 | if (c != '=') | |
725 | { | |
726 | unget_char (dtp, c); | |
03e957f8 | 727 | goto logical_done; |
c9f15d9c JD |
728 | } |
729 | } | |
730 | ||
731 | l_push_char (dtp, c); | |
732 | if (c == '=') | |
733 | { | |
734 | dtp->u.p.nml_read_error = 1; | |
735 | dtp->u.p.line_buffer_enabled = 1; | |
736 | dtp->u.p.item_count = 0; | |
737 | return; | |
738 | } | |
03e957f8 JD |
739 | |
740 | } | |
c9f15d9c | 741 | |
f21edfd6 | 742 | bad_logical: |
29dc5138 | 743 | |
4e72e1c5 JD |
744 | free_line (dtp); |
745 | ||
5e805e44 | 746 | if (nml_bad_return (dtp, c)) |
29dc5138 PT |
747 | return; |
748 | ||
9855448d JD |
749 | eat_line (dtp); |
750 | free_saved (dtp); | |
d8163f5c | 751 | sprintf (message, "Bad logical value while reading item %d", |
5e805e44 | 752 | dtp->u.p.item_count); |
d74b97cc | 753 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
03e957f8 JD |
754 | return; |
755 | ||
756 | logical_done: | |
4e72e1c5 | 757 | |
03e957f8 JD |
758 | dtp->u.p.saved_type = BT_LOGICAL; |
759 | dtp->u.p.saved_length = length; | |
760 | set_integer ((int *) dtp->u.p.value, v, length); | |
4e72e1c5 JD |
761 | free_saved (dtp); |
762 | free_line (dtp); | |
6de9cd9a DN |
763 | } |
764 | ||
765 | ||
7fcb1804 TS |
766 | /* Reading integers is tricky because we can actually be reading a |
767 | repeat count. We have to store the characters in a buffer because | |
768 | we could be reading an integer that is larger than the default int | |
769 | used for repeat counts. */ | |
6de9cd9a DN |
770 | |
771 | static void | |
5e805e44 | 772 | read_integer (st_parameter_dt *dtp, int length) |
6de9cd9a DN |
773 | { |
774 | char c, message[100]; | |
775 | int negative; | |
776 | ||
777 | negative = 0; | |
778 | ||
5e805e44 | 779 | c = next_char (dtp); |
6de9cd9a DN |
780 | switch (c) |
781 | { | |
782 | case '-': | |
783 | negative = 1; | |
7fcb1804 | 784 | /* Fall through... */ |
6de9cd9a DN |
785 | |
786 | case '+': | |
5e805e44 | 787 | c = next_char (dtp); |
6de9cd9a DN |
788 | goto get_integer; |
789 | ||
7fcb1804 | 790 | CASE_SEPARATORS: /* Single null. */ |
5e805e44 JJ |
791 | unget_char (dtp, c); |
792 | eat_separator (dtp); | |
6de9cd9a DN |
793 | return; |
794 | ||
795 | CASE_DIGITS: | |
5e805e44 | 796 | push_char (dtp, c); |
6de9cd9a DN |
797 | break; |
798 | ||
799 | default: | |
800 | goto bad_integer; | |
801 | } | |
802 | ||
7fcb1804 | 803 | /* Take care of what may be a repeat count. */ |
6de9cd9a DN |
804 | |
805 | for (;;) | |
806 | { | |
5e805e44 | 807 | c = next_char (dtp); |
6de9cd9a DN |
808 | switch (c) |
809 | { | |
810 | CASE_DIGITS: | |
5e805e44 | 811 | push_char (dtp, c); |
6de9cd9a DN |
812 | break; |
813 | ||
814 | case '*': | |
5e805e44 | 815 | push_char (dtp, '\0'); |
6de9cd9a DN |
816 | goto repeat; |
817 | ||
7fcb1804 | 818 | CASE_SEPARATORS: /* Not a repeat count. */ |
6de9cd9a DN |
819 | goto done; |
820 | ||
821 | default: | |
822 | goto bad_integer; | |
823 | } | |
824 | } | |
825 | ||
f21edfd6 | 826 | repeat: |
5e805e44 | 827 | if (convert_integer (dtp, -1, 0)) |
6de9cd9a DN |
828 | return; |
829 | ||
7fcb1804 | 830 | /* Get the real integer. */ |
6de9cd9a | 831 | |
5e805e44 | 832 | c = next_char (dtp); |
6de9cd9a DN |
833 | switch (c) |
834 | { | |
835 | CASE_DIGITS: | |
836 | break; | |
837 | ||
838 | CASE_SEPARATORS: | |
5e805e44 JJ |
839 | unget_char (dtp, c); |
840 | eat_separator (dtp); | |
6de9cd9a DN |
841 | return; |
842 | ||
843 | case '-': | |
844 | negative = 1; | |
7fcb1804 | 845 | /* Fall through... */ |
6de9cd9a DN |
846 | |
847 | case '+': | |
5e805e44 | 848 | c = next_char (dtp); |
6de9cd9a DN |
849 | break; |
850 | } | |
851 | ||
f21edfd6 | 852 | get_integer: |
6de9cd9a DN |
853 | if (!isdigit (c)) |
854 | goto bad_integer; | |
5e805e44 | 855 | push_char (dtp, c); |
6de9cd9a DN |
856 | |
857 | for (;;) | |
858 | { | |
5e805e44 | 859 | c = next_char (dtp); |
6de9cd9a DN |
860 | switch (c) |
861 | { | |
862 | CASE_DIGITS: | |
5e805e44 | 863 | push_char (dtp, c); |
6de9cd9a DN |
864 | break; |
865 | ||
866 | CASE_SEPARATORS: | |
867 | goto done; | |
868 | ||
869 | default: | |
870 | goto bad_integer; | |
871 | } | |
872 | } | |
873 | ||
f21edfd6 | 874 | bad_integer: |
29dc5138 | 875 | |
5e805e44 | 876 | if (nml_bad_return (dtp, c)) |
29dc5138 | 877 | return; |
9855448d JD |
878 | |
879 | eat_line (dtp); | |
5e805e44 | 880 | free_saved (dtp); |
d8163f5c | 881 | sprintf (message, "Bad integer for item %d in list input", |
5e805e44 | 882 | dtp->u.p.item_count); |
d74b97cc | 883 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
884 | |
885 | return; | |
886 | ||
f21edfd6 | 887 | done: |
5e805e44 JJ |
888 | unget_char (dtp, c); |
889 | eat_separator (dtp); | |
6de9cd9a | 890 | |
5e805e44 JJ |
891 | push_char (dtp, '\0'); |
892 | if (convert_integer (dtp, length, negative)) | |
6de9cd9a | 893 | { |
5e805e44 | 894 | free_saved (dtp); |
6de9cd9a DN |
895 | return; |
896 | } | |
897 | ||
5e805e44 JJ |
898 | free_saved (dtp); |
899 | dtp->u.p.saved_type = BT_INTEGER; | |
6de9cd9a DN |
900 | } |
901 | ||
902 | ||
7fcb1804 | 903 | /* Read a character variable. */ |
6de9cd9a DN |
904 | |
905 | static void | |
5e805e44 | 906 | read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) |
6de9cd9a DN |
907 | { |
908 | char c, quote, message[100]; | |
909 | ||
7fcb1804 | 910 | quote = ' '; /* Space means no quote character. */ |
6de9cd9a | 911 | |
5e805e44 | 912 | c = next_char (dtp); |
6de9cd9a DN |
913 | switch (c) |
914 | { | |
915 | CASE_DIGITS: | |
5e805e44 | 916 | push_char (dtp, c); |
6de9cd9a DN |
917 | break; |
918 | ||
919 | CASE_SEPARATORS: | |
5e805e44 JJ |
920 | unget_char (dtp, c); /* NULL value. */ |
921 | eat_separator (dtp); | |
6de9cd9a DN |
922 | return; |
923 | ||
924 | case '"': | |
925 | case '\'': | |
926 | quote = c; | |
927 | goto get_string; | |
928 | ||
929 | default: | |
808a2225 | 930 | if (dtp->u.p.namelist_mode) |
c4a108fd | 931 | { |
a7f5d054 JD |
932 | unget_char (dtp, c); |
933 | return; | |
c4a108fd | 934 | } |
808a2225 | 935 | |
5e805e44 | 936 | push_char (dtp, c); |
6de9cd9a DN |
937 | goto get_string; |
938 | } | |
939 | ||
7fcb1804 | 940 | /* Deal with a possible repeat count. */ |
6de9cd9a DN |
941 | |
942 | for (;;) | |
943 | { | |
5e805e44 | 944 | c = next_char (dtp); |
6de9cd9a DN |
945 | switch (c) |
946 | { | |
947 | CASE_DIGITS: | |
5e805e44 | 948 | push_char (dtp, c); |
6de9cd9a DN |
949 | break; |
950 | ||
951 | CASE_SEPARATORS: | |
5e805e44 | 952 | unget_char (dtp, c); |
7fcb1804 | 953 | goto done; /* String was only digits! */ |
6de9cd9a DN |
954 | |
955 | case '*': | |
5e805e44 | 956 | push_char (dtp, '\0'); |
6de9cd9a DN |
957 | goto got_repeat; |
958 | ||
959 | default: | |
5e805e44 | 960 | push_char (dtp, c); |
7fcb1804 | 961 | goto get_string; /* Not a repeat count after all. */ |
6de9cd9a DN |
962 | } |
963 | } | |
964 | ||
f21edfd6 | 965 | got_repeat: |
5e805e44 | 966 | if (convert_integer (dtp, -1, 0)) |
6de9cd9a DN |
967 | return; |
968 | ||
7fcb1804 | 969 | /* Now get the real string. */ |
6de9cd9a | 970 | |
5e805e44 | 971 | c = next_char (dtp); |
6de9cd9a DN |
972 | switch (c) |
973 | { | |
974 | CASE_SEPARATORS: | |
5e805e44 JJ |
975 | unget_char (dtp, c); /* Repeated NULL values. */ |
976 | eat_separator (dtp); | |
6de9cd9a DN |
977 | return; |
978 | ||
979 | case '"': | |
980 | case '\'': | |
981 | quote = c; | |
982 | break; | |
983 | ||
984 | default: | |
5e805e44 | 985 | push_char (dtp, c); |
6de9cd9a DN |
986 | break; |
987 | } | |
988 | ||
f21edfd6 | 989 | get_string: |
6de9cd9a DN |
990 | for (;;) |
991 | { | |
5e805e44 | 992 | c = next_char (dtp); |
6de9cd9a DN |
993 | switch (c) |
994 | { | |
995 | case '"': | |
996 | case '\'': | |
997 | if (c != quote) | |
998 | { | |
5e805e44 | 999 | push_char (dtp, c); |
6de9cd9a DN |
1000 | break; |
1001 | } | |
1002 | ||
7fcb1804 TS |
1003 | /* See if we have a doubled quote character or the end of |
1004 | the string. */ | |
6de9cd9a | 1005 | |
5e805e44 | 1006 | c = next_char (dtp); |
6de9cd9a DN |
1007 | if (c == quote) |
1008 | { | |
5e805e44 | 1009 | push_char (dtp, quote); |
6de9cd9a DN |
1010 | break; |
1011 | } | |
1012 | ||
5e805e44 | 1013 | unget_char (dtp, c); |
6de9cd9a DN |
1014 | goto done; |
1015 | ||
1016 | CASE_SEPARATORS: | |
1017 | if (quote == ' ') | |
1018 | { | |
5e805e44 | 1019 | unget_char (dtp, c); |
6de9cd9a DN |
1020 | goto done; |
1021 | } | |
1022 | ||
8824fd4c | 1023 | if (c != '\n' && c != '\r') |
5e805e44 | 1024 | push_char (dtp, c); |
6de9cd9a DN |
1025 | break; |
1026 | ||
1027 | default: | |
5e805e44 | 1028 | push_char (dtp, c); |
6de9cd9a DN |
1029 | break; |
1030 | } | |
1031 | } | |
1032 | ||
f21edfd6 RH |
1033 | /* At this point, we have to have a separator, or else the string is |
1034 | invalid. */ | |
1035 | done: | |
5e805e44 | 1036 | c = next_char (dtp); |
7b063fdc | 1037 | if (is_separator (c) || c == '!') |
6de9cd9a | 1038 | { |
5e805e44 JJ |
1039 | unget_char (dtp, c); |
1040 | eat_separator (dtp); | |
1041 | dtp->u.p.saved_type = BT_CHARACTER; | |
808a2225 | 1042 | free_line (dtp); |
6de9cd9a DN |
1043 | } |
1044 | else | |
1045 | { | |
5e805e44 | 1046 | free_saved (dtp); |
d8163f5c | 1047 | sprintf (message, "Invalid string input in item %d", |
5e805e44 | 1048 | dtp->u.p.item_count); |
d74b97cc | 1049 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1050 | } |
1051 | } | |
1052 | ||
1053 | ||
7fcb1804 TS |
1054 | /* Parse a component of a complex constant or a real number that we |
1055 | are sure is already there. This is a straight real number parser. */ | |
6de9cd9a DN |
1056 | |
1057 | static int | |
5e805e44 | 1058 | parse_real (st_parameter_dt *dtp, void *buffer, int length) |
6de9cd9a DN |
1059 | { |
1060 | char c, message[100]; | |
1061 | int m, seen_dp; | |
1062 | ||
5e805e44 | 1063 | c = next_char (dtp); |
6de9cd9a DN |
1064 | if (c == '-' || c == '+') |
1065 | { | |
5e805e44 JJ |
1066 | push_char (dtp, c); |
1067 | c = next_char (dtp); | |
6de9cd9a DN |
1068 | } |
1069 | ||
105b7136 | 1070 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe JD |
1071 | c = '.'; |
1072 | ||
6de9cd9a | 1073 | if (!isdigit (c) && c != '.') |
c9f7e825 TB |
1074 | { |
1075 | if (c == 'i' || c == 'I' || c == 'n' || c == 'N') | |
1076 | goto inf_nan; | |
1077 | else | |
1078 | goto bad; | |
1079 | } | |
6de9cd9a | 1080 | |
5e805e44 | 1081 | push_char (dtp, c); |
6de9cd9a DN |
1082 | |
1083 | seen_dp = (c == '.') ? 1 : 0; | |
1084 | ||
1085 | for (;;) | |
1086 | { | |
5e805e44 | 1087 | c = next_char (dtp); |
105b7136 | 1088 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1089 | c = '.'; |
6de9cd9a DN |
1090 | switch (c) |
1091 | { | |
1092 | CASE_DIGITS: | |
5e805e44 | 1093 | push_char (dtp, c); |
6de9cd9a DN |
1094 | break; |
1095 | ||
1096 | case '.': | |
1097 | if (seen_dp) | |
1098 | goto bad; | |
1099 | ||
1100 | seen_dp = 1; | |
5e805e44 | 1101 | push_char (dtp, c); |
6de9cd9a DN |
1102 | break; |
1103 | ||
1104 | case 'e': | |
1105 | case 'E': | |
1106 | case 'd': | |
1107 | case 'D': | |
5e805e44 | 1108 | push_char (dtp, 'e'); |
6de9cd9a DN |
1109 | goto exp1; |
1110 | ||
1111 | case '-': | |
1112 | case '+': | |
5e805e44 JJ |
1113 | push_char (dtp, 'e'); |
1114 | push_char (dtp, c); | |
1115 | c = next_char (dtp); | |
6de9cd9a DN |
1116 | goto exp2; |
1117 | ||
1118 | CASE_SEPARATORS: | |
5e805e44 | 1119 | unget_char (dtp, c); |
6de9cd9a DN |
1120 | goto done; |
1121 | ||
1122 | default: | |
1123 | goto done; | |
1124 | } | |
1125 | } | |
1126 | ||
f21edfd6 | 1127 | exp1: |
5e805e44 | 1128 | c = next_char (dtp); |
6de9cd9a | 1129 | if (c != '-' && c != '+') |
5e805e44 | 1130 | push_char (dtp, '+'); |
6de9cd9a DN |
1131 | else |
1132 | { | |
5e805e44 JJ |
1133 | push_char (dtp, c); |
1134 | c = next_char (dtp); | |
6de9cd9a DN |
1135 | } |
1136 | ||
f21edfd6 | 1137 | exp2: |
6de9cd9a | 1138 | if (!isdigit (c)) |
78a15b1f | 1139 | goto bad; |
c9f7e825 | 1140 | |
5e805e44 | 1141 | push_char (dtp, c); |
6de9cd9a DN |
1142 | |
1143 | for (;;) | |
1144 | { | |
5e805e44 | 1145 | c = next_char (dtp); |
6de9cd9a DN |
1146 | switch (c) |
1147 | { | |
1148 | CASE_DIGITS: | |
5e805e44 | 1149 | push_char (dtp, c); |
6de9cd9a DN |
1150 | break; |
1151 | ||
1152 | CASE_SEPARATORS: | |
5e805e44 | 1153 | unget_char (dtp, c); |
6de9cd9a DN |
1154 | goto done; |
1155 | ||
1156 | default: | |
1157 | goto done; | |
1158 | } | |
1159 | } | |
1160 | ||
f21edfd6 | 1161 | done: |
5e805e44 JJ |
1162 | unget_char (dtp, c); |
1163 | push_char (dtp, '\0'); | |
6de9cd9a | 1164 | |
5e805e44 JJ |
1165 | m = convert_real (dtp, buffer, dtp->u.p.saved_string, length); |
1166 | free_saved (dtp); | |
6de9cd9a DN |
1167 | |
1168 | return m; | |
1169 | ||
c9f7e825 TB |
1170 | inf_nan: |
1171 | /* Match INF and Infinity. */ | |
1172 | if ((c == 'i' || c == 'I') | |
1173 | && ((c = next_char (dtp)) == 'n' || c == 'N') | |
1174 | && ((c = next_char (dtp)) == 'f' || c == 'F')) | |
1175 | { | |
1176 | c = next_char (dtp); | |
1177 | if ((c != 'i' && c != 'I') | |
1178 | || ((c == 'i' || c == 'I') | |
1179 | && ((c = next_char (dtp)) == 'n' || c == 'N') | |
1180 | && ((c = next_char (dtp)) == 'i' || c == 'I') | |
1181 | && ((c = next_char (dtp)) == 't' || c == 'T') | |
1182 | && ((c = next_char (dtp)) == 'y' || c == 'Y') | |
1183 | && (c = next_char (dtp)))) | |
1184 | { | |
1185 | if (is_separator (c)) | |
1186 | unget_char (dtp, c); | |
1187 | push_char (dtp, 'i'); | |
1188 | push_char (dtp, 'n'); | |
1189 | push_char (dtp, 'f'); | |
1190 | goto done; | |
1191 | } | |
1192 | } /* Match NaN. */ | |
1193 | else if (((c = next_char (dtp)) == 'a' || c == 'A') | |
1194 | && ((c = next_char (dtp)) == 'n' || c == 'N') | |
1195 | && (c = next_char (dtp))) | |
1196 | { | |
1197 | if (is_separator (c)) | |
1198 | unget_char (dtp, c); | |
1199 | push_char (dtp, 'n'); | |
1200 | push_char (dtp, 'a'); | |
1201 | push_char (dtp, 'n'); | |
83377c6a TB |
1202 | |
1203 | /* Match "NAN(alphanum)". */ | |
1204 | if (c == '(') | |
1205 | { | |
1206 | for ( ; c != ')'; c = next_char (dtp)) | |
1207 | if (is_separator (c)) | |
1208 | goto bad; | |
83377c6a | 1209 | |
83377c6a TB |
1210 | c = next_char (dtp); |
1211 | if (is_separator (c)) | |
1212 | unget_char (dtp, c); | |
1213 | } | |
c9f7e825 TB |
1214 | goto done; |
1215 | } | |
1216 | ||
f21edfd6 | 1217 | bad: |
9855448d JD |
1218 | |
1219 | if (nml_bad_return (dtp, c)) | |
1220 | return 0; | |
1221 | ||
1222 | eat_line (dtp); | |
5e805e44 | 1223 | free_saved (dtp); |
d8163f5c | 1224 | sprintf (message, "Bad floating point number for item %d", |
5e805e44 | 1225 | dtp->u.p.item_count); |
d74b97cc | 1226 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1227 | |
1228 | return 1; | |
1229 | } | |
1230 | ||
1231 | ||
7fcb1804 TS |
1232 | /* Reading a complex number is straightforward because we can tell |
1233 | what it is right away. */ | |
6de9cd9a DN |
1234 | |
1235 | static void | |
6b680210 | 1236 | read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size) |
6de9cd9a DN |
1237 | { |
1238 | char message[100]; | |
1239 | char c; | |
1240 | ||
5e805e44 | 1241 | if (parse_repeat (dtp)) |
6de9cd9a DN |
1242 | return; |
1243 | ||
5e805e44 | 1244 | c = next_char (dtp); |
6de9cd9a DN |
1245 | switch (c) |
1246 | { | |
1247 | case '(': | |
1248 | break; | |
1249 | ||
1250 | CASE_SEPARATORS: | |
5e805e44 JJ |
1251 | unget_char (dtp, c); |
1252 | eat_separator (dtp); | |
6de9cd9a DN |
1253 | return; |
1254 | ||
1255 | default: | |
1256 | goto bad_complex; | |
1257 | } | |
1258 | ||
5e805e44 | 1259 | eat_spaces (dtp); |
6b680210 | 1260 | if (parse_real (dtp, dest, kind)) |
6de9cd9a DN |
1261 | return; |
1262 | ||
b125b4cf | 1263 | eol_1: |
5e805e44 JJ |
1264 | eat_spaces (dtp); |
1265 | c = next_char (dtp); | |
b125b4cf PT |
1266 | if (c == '\n' || c== '\r') |
1267 | goto eol_1; | |
1268 | else | |
5e805e44 | 1269 | unget_char (dtp, c); |
b125b4cf | 1270 | |
105b7136 JD |
1271 | if (next_char (dtp) |
1272 | != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';')) | |
1273 | goto bad_complex; | |
6de9cd9a | 1274 | |
b125b4cf | 1275 | eol_2: |
5e805e44 JJ |
1276 | eat_spaces (dtp); |
1277 | c = next_char (dtp); | |
b125b4cf PT |
1278 | if (c == '\n' || c== '\r') |
1279 | goto eol_2; | |
1280 | else | |
5e805e44 | 1281 | unget_char (dtp, c); |
b125b4cf | 1282 | |
6b680210 | 1283 | if (parse_real (dtp, dest + size / 2, kind)) |
6de9cd9a DN |
1284 | return; |
1285 | ||
5e805e44 JJ |
1286 | eat_spaces (dtp); |
1287 | if (next_char (dtp) != ')') | |
6de9cd9a DN |
1288 | goto bad_complex; |
1289 | ||
5e805e44 | 1290 | c = next_char (dtp); |
6de9cd9a DN |
1291 | if (!is_separator (c)) |
1292 | goto bad_complex; | |
1293 | ||
5e805e44 JJ |
1294 | unget_char (dtp, c); |
1295 | eat_separator (dtp); | |
6de9cd9a | 1296 | |
5e805e44 JJ |
1297 | free_saved (dtp); |
1298 | dtp->u.p.saved_type = BT_COMPLEX; | |
6de9cd9a DN |
1299 | return; |
1300 | ||
f21edfd6 | 1301 | bad_complex: |
29dc5138 | 1302 | |
5e805e44 | 1303 | if (nml_bad_return (dtp, c)) |
29dc5138 PT |
1304 | return; |
1305 | ||
9855448d JD |
1306 | eat_line (dtp); |
1307 | free_saved (dtp); | |
d8163f5c | 1308 | sprintf (message, "Bad complex value in item %d of list input", |
5e805e44 | 1309 | dtp->u.p.item_count); |
d74b97cc | 1310 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1311 | } |
1312 | ||
1313 | ||
7fcb1804 | 1314 | /* Parse a real number with a possible repeat count. */ |
6de9cd9a DN |
1315 | |
1316 | static void | |
6b680210 | 1317 | read_real (st_parameter_dt *dtp, void * dest, int length) |
6de9cd9a DN |
1318 | { |
1319 | char c, message[100]; | |
1320 | int seen_dp; | |
78a15b1f | 1321 | int is_inf; |
6de9cd9a DN |
1322 | |
1323 | seen_dp = 0; | |
1324 | ||
5e805e44 | 1325 | c = next_char (dtp); |
105b7136 | 1326 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1327 | c = '.'; |
6de9cd9a DN |
1328 | switch (c) |
1329 | { | |
1330 | CASE_DIGITS: | |
5e805e44 | 1331 | push_char (dtp, c); |
6de9cd9a DN |
1332 | break; |
1333 | ||
1334 | case '.': | |
5e805e44 | 1335 | push_char (dtp, c); |
6de9cd9a DN |
1336 | seen_dp = 1; |
1337 | break; | |
1338 | ||
1339 | case '+': | |
1340 | case '-': | |
1341 | goto got_sign; | |
1342 | ||
1343 | CASE_SEPARATORS: | |
5e805e44 JJ |
1344 | unget_char (dtp, c); /* Single null. */ |
1345 | eat_separator (dtp); | |
6de9cd9a DN |
1346 | return; |
1347 | ||
c9f7e825 TB |
1348 | case 'i': |
1349 | case 'I': | |
1350 | case 'n': | |
1351 | case 'N': | |
1352 | goto inf_nan; | |
1353 | ||
6de9cd9a DN |
1354 | default: |
1355 | goto bad_real; | |
1356 | } | |
1357 | ||
7fcb1804 | 1358 | /* Get the digit string that might be a repeat count. */ |
6de9cd9a DN |
1359 | |
1360 | for (;;) | |
1361 | { | |
5e805e44 | 1362 | c = next_char (dtp); |
105b7136 | 1363 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1364 | c = '.'; |
6de9cd9a DN |
1365 | switch (c) |
1366 | { | |
1367 | CASE_DIGITS: | |
5e805e44 | 1368 | push_char (dtp, c); |
6de9cd9a DN |
1369 | break; |
1370 | ||
1371 | case '.': | |
10256cbe JD |
1372 | if (seen_dp) |
1373 | goto bad_real; | |
6de9cd9a DN |
1374 | |
1375 | seen_dp = 1; | |
5e805e44 | 1376 | push_char (dtp, c); |
6de9cd9a DN |
1377 | goto real_loop; |
1378 | ||
1379 | case 'E': | |
1380 | case 'e': | |
1381 | case 'D': | |
1382 | case 'd': | |
1383 | goto exp1; | |
1384 | ||
1385 | case '+': | |
1386 | case '-': | |
5e805e44 JJ |
1387 | push_char (dtp, 'e'); |
1388 | push_char (dtp, c); | |
1389 | c = next_char (dtp); | |
6de9cd9a DN |
1390 | goto exp2; |
1391 | ||
1392 | case '*': | |
5e805e44 | 1393 | push_char (dtp, '\0'); |
6de9cd9a DN |
1394 | goto got_repeat; |
1395 | ||
1396 | CASE_SEPARATORS: | |
10256cbe | 1397 | if (c != '\n' && c != ',' && c != '\r' && c != ';') |
5e805e44 | 1398 | unget_char (dtp, c); |
6de9cd9a DN |
1399 | goto done; |
1400 | ||
1401 | default: | |
1402 | goto bad_real; | |
1403 | } | |
1404 | } | |
1405 | ||
f21edfd6 | 1406 | got_repeat: |
5e805e44 | 1407 | if (convert_integer (dtp, -1, 0)) |
6de9cd9a DN |
1408 | return; |
1409 | ||
7fcb1804 | 1410 | /* Now get the number itself. */ |
6de9cd9a | 1411 | |
5e805e44 | 1412 | c = next_char (dtp); |
6de9cd9a | 1413 | if (is_separator (c)) |
7fcb1804 | 1414 | { /* Repeated null value. */ |
5e805e44 JJ |
1415 | unget_char (dtp, c); |
1416 | eat_separator (dtp); | |
6de9cd9a DN |
1417 | return; |
1418 | } | |
1419 | ||
1420 | if (c != '-' && c != '+') | |
5e805e44 | 1421 | push_char (dtp, '+'); |
6de9cd9a DN |
1422 | else |
1423 | { | |
1424 | got_sign: | |
5e805e44 JJ |
1425 | push_char (dtp, c); |
1426 | c = next_char (dtp); | |
6de9cd9a DN |
1427 | } |
1428 | ||
105b7136 | 1429 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe JD |
1430 | c = '.'; |
1431 | ||
6de9cd9a | 1432 | if (!isdigit (c) && c != '.') |
c9f7e825 TB |
1433 | { |
1434 | if (c == 'i' || c == 'I' || c == 'n' || c == 'N') | |
1435 | goto inf_nan; | |
1436 | else | |
1437 | goto bad_real; | |
1438 | } | |
6de9cd9a DN |
1439 | |
1440 | if (c == '.') | |
1441 | { | |
1442 | if (seen_dp) | |
1443 | goto bad_real; | |
1444 | else | |
1445 | seen_dp = 1; | |
1446 | } | |
1447 | ||
5e805e44 | 1448 | push_char (dtp, c); |
6de9cd9a | 1449 | |
f21edfd6 | 1450 | real_loop: |
6de9cd9a DN |
1451 | for (;;) |
1452 | { | |
5e805e44 | 1453 | c = next_char (dtp); |
105b7136 | 1454 | if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) |
10256cbe | 1455 | c = '.'; |
6de9cd9a DN |
1456 | switch (c) |
1457 | { | |
1458 | CASE_DIGITS: | |
5e805e44 | 1459 | push_char (dtp, c); |
6de9cd9a DN |
1460 | break; |
1461 | ||
1462 | CASE_SEPARATORS: | |
1463 | goto done; | |
1464 | ||
1465 | case '.': | |
1466 | if (seen_dp) | |
1467 | goto bad_real; | |
1468 | ||
1469 | seen_dp = 1; | |
5e805e44 | 1470 | push_char (dtp, c); |
6de9cd9a DN |
1471 | break; |
1472 | ||
1473 | case 'E': | |
1474 | case 'e': | |
1475 | case 'D': | |
1476 | case 'd': | |
1477 | goto exp1; | |
1478 | ||
1479 | case '+': | |
1480 | case '-': | |
5e805e44 JJ |
1481 | push_char (dtp, 'e'); |
1482 | push_char (dtp, c); | |
1483 | c = next_char (dtp); | |
6de9cd9a DN |
1484 | goto exp2; |
1485 | ||
1486 | default: | |
1487 | goto bad_real; | |
1488 | } | |
1489 | } | |
1490 | ||
f21edfd6 | 1491 | exp1: |
5e805e44 | 1492 | push_char (dtp, 'e'); |
6de9cd9a | 1493 | |
5e805e44 | 1494 | c = next_char (dtp); |
6de9cd9a | 1495 | if (c != '+' && c != '-') |
5e805e44 | 1496 | push_char (dtp, '+'); |
6de9cd9a DN |
1497 | else |
1498 | { | |
5e805e44 JJ |
1499 | push_char (dtp, c); |
1500 | c = next_char (dtp); | |
6de9cd9a DN |
1501 | } |
1502 | ||
f21edfd6 | 1503 | exp2: |
6de9cd9a DN |
1504 | if (!isdigit (c)) |
1505 | goto bad_real; | |
5e805e44 | 1506 | push_char (dtp, c); |
6de9cd9a DN |
1507 | |
1508 | for (;;) | |
1509 | { | |
5e805e44 | 1510 | c = next_char (dtp); |
6de9cd9a DN |
1511 | |
1512 | switch (c) | |
1513 | { | |
1514 | CASE_DIGITS: | |
5e805e44 | 1515 | push_char (dtp, c); |
6de9cd9a DN |
1516 | break; |
1517 | ||
1518 | CASE_SEPARATORS: | |
6de9cd9a DN |
1519 | goto done; |
1520 | ||
1521 | default: | |
1522 | goto bad_real; | |
1523 | } | |
1524 | } | |
1525 | ||
f21edfd6 | 1526 | done: |
5e805e44 JJ |
1527 | unget_char (dtp, c); |
1528 | eat_separator (dtp); | |
1529 | push_char (dtp, '\0'); | |
6b680210 | 1530 | if (convert_real (dtp, dest, dtp->u.p.saved_string, length)) |
6de9cd9a DN |
1531 | return; |
1532 | ||
5e805e44 JJ |
1533 | free_saved (dtp); |
1534 | dtp->u.p.saved_type = BT_REAL; | |
6de9cd9a DN |
1535 | return; |
1536 | ||
c9f7e825 | 1537 | inf_nan: |
b446725a TB |
1538 | l_push_char (dtp, c); |
1539 | is_inf = 0; | |
1540 | ||
c9f7e825 | 1541 | /* Match INF and Infinity. */ |
b446725a | 1542 | if (c == 'i' || c == 'I') |
c9f7e825 | 1543 | { |
b446725a TB |
1544 | c = next_char (dtp); |
1545 | l_push_char (dtp, c); | |
1546 | if (c != 'n' && c != 'N') | |
1547 | goto unwind; | |
1548 | c = next_char (dtp); | |
1549 | l_push_char (dtp, c); | |
1550 | if (c != 'f' && c != 'F') | |
1551 | goto unwind; | |
1552 | c = next_char (dtp); | |
1553 | l_push_char (dtp, c); | |
1554 | if (!is_separator (c)) | |
1555 | { | |
1556 | if (c != 'i' && c != 'I') | |
1557 | goto unwind; | |
1558 | c = next_char (dtp); | |
1559 | l_push_char (dtp, c); | |
1560 | if (c != 'n' && c != 'N') | |
1561 | goto unwind; | |
1562 | c = next_char (dtp); | |
1563 | l_push_char (dtp, c); | |
1564 | if (c != 'i' && c != 'I') | |
1565 | goto unwind; | |
1566 | c = next_char (dtp); | |
1567 | l_push_char (dtp, c); | |
1568 | if (c != 't' && c != 'T') | |
1569 | goto unwind; | |
1570 | c = next_char (dtp); | |
1571 | l_push_char (dtp, c); | |
1572 | if (c != 'y' && c != 'Y') | |
1573 | goto unwind; | |
1574 | c = next_char (dtp); | |
1575 | l_push_char (dtp, c); | |
1576 | } | |
1577 | is_inf = 1; | |
c9f7e825 | 1578 | } /* Match NaN. */ |
b446725a TB |
1579 | else |
1580 | { | |
1581 | c = next_char (dtp); | |
1582 | l_push_char (dtp, c); | |
1583 | if (c != 'a' && c != 'A') | |
1584 | goto unwind; | |
1585 | c = next_char (dtp); | |
1586 | l_push_char (dtp, c); | |
1587 | if (c != 'n' && c != 'N') | |
1588 | goto unwind; | |
1589 | c = next_char (dtp); | |
1590 | l_push_char (dtp, c); | |
83377c6a TB |
1591 | |
1592 | /* Match NAN(alphanum). */ | |
1593 | if (c == '(') | |
1594 | { | |
1595 | for (c = next_char (dtp); c != ')'; c = next_char (dtp)) | |
1596 | if (is_separator (c)) | |
1597 | goto unwind; | |
1598 | else | |
1599 | l_push_char (dtp, c); | |
1600 | ||
1601 | l_push_char (dtp, ')'); | |
1602 | c = next_char (dtp); | |
1603 | l_push_char (dtp, c); | |
1604 | } | |
b446725a TB |
1605 | } |
1606 | ||
78a15b1f | 1607 | if (!is_separator (c)) |
b446725a TB |
1608 | goto unwind; |
1609 | ||
78a15b1f JD |
1610 | if (dtp->u.p.namelist_mode) |
1611 | { | |
1612 | if (c == ' ' || c =='\n' || c == '\r') | |
1613 | { | |
1614 | do | |
1615 | c = next_char (dtp); | |
1616 | while (c == ' ' || c =='\n' || c == '\r'); | |
b446725a | 1617 | |
78a15b1f JD |
1618 | l_push_char (dtp, c); |
1619 | ||
1620 | if (c == '=') | |
1621 | goto unwind; | |
1622 | } | |
b446725a TB |
1623 | } |
1624 | ||
1625 | if (is_inf) | |
1626 | { | |
1627 | push_char (dtp, 'i'); | |
1628 | push_char (dtp, 'n'); | |
1629 | push_char (dtp, 'f'); | |
1630 | } | |
1631 | else | |
c9f7e825 TB |
1632 | { |
1633 | push_char (dtp, 'n'); | |
1634 | push_char (dtp, 'a'); | |
1635 | push_char (dtp, 'n'); | |
b446725a TB |
1636 | } |
1637 | ||
b446725a TB |
1638 | free_line (dtp); |
1639 | goto done; | |
1640 | ||
1641 | unwind: | |
1642 | if (dtp->u.p.namelist_mode) | |
1643 | { | |
1644 | dtp->u.p.nml_read_error = 1; | |
1645 | dtp->u.p.line_buffer_enabled = 1; | |
1646 | dtp->u.p.item_count = 0; | |
1647 | return; | |
c9f7e825 TB |
1648 | } |
1649 | ||
f21edfd6 | 1650 | bad_real: |
29dc5138 | 1651 | |
5e805e44 | 1652 | if (nml_bad_return (dtp, c)) |
29dc5138 PT |
1653 | return; |
1654 | ||
9855448d JD |
1655 | eat_line (dtp); |
1656 | free_saved (dtp); | |
d8163f5c | 1657 | sprintf (message, "Bad real number in item %d of list input", |
5e805e44 | 1658 | dtp->u.p.item_count); |
d74b97cc | 1659 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1660 | } |
1661 | ||
1662 | ||
7fcb1804 TS |
1663 | /* Check the current type against the saved type to make sure they are |
1664 | compatible. Returns nonzero if incompatible. */ | |
6de9cd9a DN |
1665 | |
1666 | static int | |
5e805e44 | 1667 | check_type (st_parameter_dt *dtp, bt type, int len) |
6de9cd9a DN |
1668 | { |
1669 | char message[100]; | |
1670 | ||
a11930ba | 1671 | if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) |
6de9cd9a | 1672 | { |
d8163f5c | 1673 | sprintf (message, "Read type %s where %s was expected for item %d", |
5e805e44 JJ |
1674 | type_name (dtp->u.p.saved_type), type_name (type), |
1675 | dtp->u.p.item_count); | |
6de9cd9a | 1676 | |
d74b97cc | 1677 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1678 | return 1; |
1679 | } | |
1680 | ||
a11930ba | 1681 | if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER) |
6de9cd9a DN |
1682 | return 0; |
1683 | ||
5e805e44 | 1684 | if (dtp->u.p.saved_length != len) |
6de9cd9a | 1685 | { |
d8163f5c | 1686 | sprintf (message, |
6de9cd9a | 1687 | "Read kind %d %s where kind %d is required for item %d", |
5e805e44 JJ |
1688 | dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len, |
1689 | dtp->u.p.item_count); | |
d74b97cc | 1690 | generate_error (&dtp->common, LIBERROR_READ_VALUE, message); |
6de9cd9a DN |
1691 | return 1; |
1692 | } | |
1693 | ||
1694 | return 0; | |
1695 | } | |
1696 | ||
1697 | ||
7fcb1804 TS |
1698 | /* Top level data transfer subroutine for list reads. Because we have |
1699 | to deal with repeat counts, the data item is always saved after | |
5e805e44 | 1700 | reading, usually in the dtp->u.p.value[] array. If a repeat count is |
7fcb1804 | 1701 | greater than one, we copy the data item multiple times. */ |
6de9cd9a | 1702 | |
18623fae | 1703 | static void |
51407486 TK |
1704 | list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p, |
1705 | int kind, size_t size) | |
6de9cd9a DN |
1706 | { |
1707 | char c; | |
cea93abb JD |
1708 | gfc_char4_t *q; |
1709 | int i, m; | |
5e805e44 | 1710 | jmp_buf eof_jump; |
6de9cd9a | 1711 | |
5e805e44 | 1712 | dtp->u.p.namelist_mode = 0; |
6de9cd9a | 1713 | |
5e805e44 JJ |
1714 | dtp->u.p.eof_jump = &eof_jump; |
1715 | if (setjmp (eof_jump)) | |
6de9cd9a | 1716 | { |
d74b97cc | 1717 | generate_error (&dtp->common, LIBERROR_END, NULL); |
690aefeb JD |
1718 | if (!is_internal_unit (dtp)) |
1719 | { | |
1720 | dtp->u.p.current_unit->endfile = AFTER_ENDFILE; | |
1721 | dtp->u.p.current_unit->current_record = 0; | |
1722 | } | |
5e805e44 | 1723 | goto cleanup; |
6de9cd9a DN |
1724 | } |
1725 | ||
5e805e44 | 1726 | if (dtp->u.p.first_item) |
6de9cd9a | 1727 | { |
5e805e44 JJ |
1728 | dtp->u.p.first_item = 0; |
1729 | dtp->u.p.input_complete = 0; | |
1730 | dtp->u.p.repeat_count = 1; | |
1731 | dtp->u.p.at_eol = 0; | |
7812c78c | 1732 | |
5e805e44 | 1733 | c = eat_spaces (dtp); |
6de9cd9a | 1734 | if (is_separator (c)) |
b8df885f JD |
1735 | { |
1736 | /* Found a null value. */ | |
5e805e44 JJ |
1737 | eat_separator (dtp); |
1738 | dtp->u.p.repeat_count = 0; | |
a7c633ea | 1739 | |
b8df885f | 1740 | /* eat_separator sets this flag if the separator was a comma. */ |
a7c633ea JD |
1741 | if (dtp->u.p.comma_flag) |
1742 | goto cleanup; | |
1743 | ||
b8df885f | 1744 | /* eat_separator sets this flag if the separator was a \n or \r. */ |
a7c633ea JD |
1745 | if (dtp->u.p.at_eol) |
1746 | finish_separator (dtp); | |
1747 | else | |
1748 | goto cleanup; | |
6de9cd9a DN |
1749 | } |
1750 | ||
1751 | } | |
1752 | else | |
1753 | { | |
5e805e44 | 1754 | if (dtp->u.p.repeat_count > 0) |
6de9cd9a | 1755 | { |
5e805e44 | 1756 | if (check_type (dtp, type, kind)) |
6de9cd9a DN |
1757 | return; |
1758 | goto set_value; | |
1759 | } | |
7812c78c JD |
1760 | |
1761 | if (dtp->u.p.input_complete) | |
1762 | goto cleanup; | |
6de9cd9a | 1763 | |
5e805e44 JJ |
1764 | if (dtp->u.p.at_eol) |
1765 | finish_separator (dtp); | |
6de9cd9a | 1766 | else |
c72477d6 | 1767 | { |
5e805e44 | 1768 | eat_spaces (dtp); |
b8df885f | 1769 | /* Trailing spaces prior to end of line. */ |
5e805e44 JJ |
1770 | if (dtp->u.p.at_eol) |
1771 | finish_separator (dtp); | |
c72477d6 | 1772 | } |
6de9cd9a | 1773 | |
a11930ba | 1774 | dtp->u.p.saved_type = BT_UNKNOWN; |
5e805e44 | 1775 | dtp->u.p.repeat_count = 1; |
6de9cd9a DN |
1776 | } |
1777 | ||
6de9cd9a DN |
1778 | switch (type) |
1779 | { | |
1780 | case BT_INTEGER: | |
5e805e44 | 1781 | read_integer (dtp, kind); |
6de9cd9a DN |
1782 | break; |
1783 | case BT_LOGICAL: | |
5e805e44 | 1784 | read_logical (dtp, kind); |
6de9cd9a DN |
1785 | break; |
1786 | case BT_CHARACTER: | |
5e805e44 | 1787 | read_character (dtp, kind); |
6de9cd9a DN |
1788 | break; |
1789 | case BT_REAL: | |
6b680210 JB |
1790 | read_real (dtp, p, kind); |
1791 | /* Copy value back to temporary if needed. */ | |
1792 | if (dtp->u.p.repeat_count > 0) | |
1793 | memcpy (dtp->u.p.value, p, kind); | |
6de9cd9a DN |
1794 | break; |
1795 | case BT_COMPLEX: | |
6b680210 JB |
1796 | read_complex (dtp, p, kind, size); |
1797 | /* Copy value back to temporary if needed. */ | |
1798 | if (dtp->u.p.repeat_count > 0) | |
1799 | memcpy (dtp->u.p.value, p, size); | |
6de9cd9a DN |
1800 | break; |
1801 | default: | |
5e805e44 | 1802 | internal_error (&dtp->common, "Bad type for list read"); |
6de9cd9a DN |
1803 | } |
1804 | ||
a11930ba | 1805 | if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN) |
5e805e44 | 1806 | dtp->u.p.saved_length = size; |
6de9cd9a | 1807 | |
5e805e44 JJ |
1808 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
1809 | goto cleanup; | |
6de9cd9a | 1810 | |
f21edfd6 | 1811 | set_value: |
5e805e44 | 1812 | switch (dtp->u.p.saved_type) |
6de9cd9a DN |
1813 | { |
1814 | case BT_COMPLEX: | |
6de9cd9a | 1815 | case BT_REAL: |
6b680210 JB |
1816 | if (dtp->u.p.repeat_count > 0) |
1817 | memcpy (p, dtp->u.p.value, size); | |
1818 | break; | |
1819 | ||
1820 | case BT_INTEGER: | |
6de9cd9a | 1821 | case BT_LOGICAL: |
5e805e44 | 1822 | memcpy (p, dtp->u.p.value, size); |
6de9cd9a DN |
1823 | break; |
1824 | ||
1825 | case BT_CHARACTER: | |
5e805e44 | 1826 | if (dtp->u.p.saved_string) |
cea93abb | 1827 | { |
5e805e44 JJ |
1828 | m = ((int) size < dtp->u.p.saved_used) |
1829 | ? (int) size : dtp->u.p.saved_used; | |
cea93abb JD |
1830 | if (kind == 1) |
1831 | memcpy (p, dtp->u.p.saved_string, m); | |
1832 | else | |
1833 | { | |
1834 | q = (gfc_char4_t *) p; | |
1835 | for (i = 0; i < m; i++) | |
1836 | q[i] = (unsigned char) dtp->u.p.saved_string[i]; | |
1837 | } | |
1838 | } | |
420aa7b8 | 1839 | else |
7fcb1804 | 1840 | /* Just delimiters encountered, nothing to copy but SPACE. */ |
04b0faec | 1841 | m = 0; |
6de9cd9a | 1842 | |
e5ef4b3b | 1843 | if (m < (int) size) |
cea93abb JD |
1844 | { |
1845 | if (kind == 1) | |
1846 | memset (((char *) p) + m, ' ', size - m); | |
1847 | else | |
1848 | { | |
1849 | q = (gfc_char4_t *) p; | |
1850 | for (i = m; i < (int) size; i++) | |
1851 | q[i] = (unsigned char) ' '; | |
1852 | } | |
1853 | } | |
6de9cd9a DN |
1854 | break; |
1855 | ||
a11930ba | 1856 | case BT_UNKNOWN: |
6de9cd9a | 1857 | break; |
a11930ba JD |
1858 | |
1859 | default: | |
1860 | internal_error (&dtp->common, "Bad type for list read"); | |
6de9cd9a DN |
1861 | } |
1862 | ||
5e805e44 JJ |
1863 | if (--dtp->u.p.repeat_count <= 0) |
1864 | free_saved (dtp); | |
1865 | ||
1866 | cleanup: | |
1867 | dtp->u.p.eof_jump = NULL; | |
6de9cd9a DN |
1868 | } |
1869 | ||
18623fae JB |
1870 | |
1871 | void | |
5e805e44 JJ |
1872 | list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind, |
1873 | size_t size, size_t nelems) | |
18623fae JB |
1874 | { |
1875 | size_t elem; | |
18623fae | 1876 | char *tmp; |
cea93abb JD |
1877 | size_t stride = type == BT_CHARACTER ? |
1878 | size * GFC_SIZE_OF_CHAR_KIND(kind) : size; | |
18623fae JB |
1879 | |
1880 | tmp = (char *) p; | |
1881 | ||
18623fae JB |
1882 | /* Big loop over all the elements. */ |
1883 | for (elem = 0; elem < nelems; elem++) | |
1884 | { | |
5e805e44 | 1885 | dtp->u.p.item_count++; |
cea93abb | 1886 | list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size); |
18623fae JB |
1887 | } |
1888 | } | |
1889 | ||
1890 | ||
7fcb1804 | 1891 | /* Finish a list read. */ |
6de9cd9a DN |
1892 | |
1893 | void | |
5e805e44 | 1894 | finish_list_read (st_parameter_dt *dtp) |
6de9cd9a DN |
1895 | { |
1896 | char c; | |
1897 | ||
5e805e44 | 1898 | free_saved (dtp); |
6de9cd9a | 1899 | |
7812c78c JD |
1900 | fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); |
1901 | ||
5e805e44 | 1902 | if (dtp->u.p.at_eol) |
6de9cd9a | 1903 | { |
5e805e44 | 1904 | dtp->u.p.at_eol = 0; |
6de9cd9a DN |
1905 | return; |
1906 | } | |
1907 | ||
6de9cd9a DN |
1908 | do |
1909 | { | |
5e805e44 | 1910 | c = next_char (dtp); |
6de9cd9a DN |
1911 | } |
1912 | while (c != '\n'); | |
724cdffe JD |
1913 | |
1914 | if (dtp->u.p.current_unit->endfile != NO_ENDFILE) | |
1915 | { | |
1916 | generate_error (&dtp->common, LIBERROR_END, NULL); | |
1917 | dtp->u.p.current_unit->endfile = AFTER_ENDFILE; | |
1918 | dtp->u.p.current_unit->current_record = 0; | |
1919 | } | |
6de9cd9a DN |
1920 | } |
1921 | ||
29dc5138 PT |
1922 | /* NAMELIST INPUT |
1923 | ||
5e805e44 | 1924 | void namelist_read (st_parameter_dt *dtp) |
29dc5138 PT |
1925 | calls: |
1926 | static void nml_match_name (char *name, int len) | |
5e805e44 JJ |
1927 | static int nml_query (st_parameter_dt *dtp) |
1928 | static int nml_get_obj_data (st_parameter_dt *dtp, | |
24722ea9 | 1929 | namelist_info **prev_nl, char *, size_t) |
29dc5138 | 1930 | calls: |
5e805e44 JJ |
1931 | static void nml_untouch_nodes (st_parameter_dt *dtp) |
1932 | static namelist_info * find_nml_node (st_parameter_dt *dtp, | |
1933 | char * var_name) | |
29dc5138 | 1934 | static int nml_parse_qualifier(descriptor_dimension * ad, |
5e805e44 | 1935 | array_loop_spec * ls, int rank, char *) |
29dc5138 | 1936 | static void nml_touch_nodes (namelist_info * nl) |
5e805e44 | 1937 | static int nml_read_obj (namelist_info *nl, index_type offset, |
24722ea9 | 1938 | namelist_info **prev_nl, char *, size_t, |
5e805e44 | 1939 | index_type clow, index_type chigh) |
29dc5138 PT |
1940 | calls: |
1941 | -itself- */ | |
1942 | ||
29dc5138 PT |
1943 | /* Inputs a rank-dimensional qualifier, which can contain |
1944 | singlets, doublets, triplets or ':' with the standard meanings. */ | |
1945 | ||
1946 | static try | |
5e805e44 | 1947 | nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, |
45dfbe77 JD |
1948 | array_loop_spec *ls, int rank, char *parse_err_msg, |
1949 | int *parsed_rank) | |
29dc5138 PT |
1950 | { |
1951 | int dim; | |
1952 | int indx; | |
1953 | int neg; | |
1954 | int null_flag; | |
45dfbe77 | 1955 | int is_array_section, is_char; |
29dc5138 PT |
1956 | char c; |
1957 | ||
45dfbe77 | 1958 | is_char = 0; |
25292a1b JD |
1959 | is_array_section = 0; |
1960 | dtp->u.p.expanded_read = 0; | |
1961 | ||
45dfbe77 JD |
1962 | /* See if this is a character substring qualifier we are looking for. */ |
1963 | if (rank == -1) | |
1964 | { | |
1965 | rank = 1; | |
1966 | is_char = 1; | |
1967 | } | |
1968 | ||
29dc5138 PT |
1969 | /* The next character in the stream should be the '('. */ |
1970 | ||
5e805e44 | 1971 | c = next_char (dtp); |
29dc5138 PT |
1972 | |
1973 | /* Process the qualifier, by dimension and triplet. */ | |
1974 | ||
1975 | for (dim=0; dim < rank; dim++ ) | |
1976 | { | |
1977 | for (indx=0; indx<3; indx++) | |
1978 | { | |
5e805e44 JJ |
1979 | free_saved (dtp); |
1980 | eat_spaces (dtp); | |
29dc5138 PT |
1981 | neg = 0; |
1982 | ||
b90ba157 | 1983 | /* Process a potential sign. */ |
5e805e44 | 1984 | c = next_char (dtp); |
29dc5138 PT |
1985 | switch (c) |
1986 | { | |
1987 | case '-': | |
1988 | neg = 1; | |
1989 | break; | |
1990 | ||
1991 | case '+': | |
1992 | break; | |
1993 | ||
1994 | default: | |
5e805e44 | 1995 | unget_char (dtp, c); |
29dc5138 PT |
1996 | break; |
1997 | } | |
1998 | ||
b90ba157 | 1999 | /* Process characters up to the next ':' , ',' or ')'. */ |
29dc5138 PT |
2000 | for (;;) |
2001 | { | |
5e805e44 | 2002 | c = next_char (dtp); |
29dc5138 PT |
2003 | |
2004 | switch (c) | |
2005 | { | |
2006 | case ':': | |
25292a1b | 2007 | is_array_section = 1; |
29dc5138 PT |
2008 | break; |
2009 | ||
2010 | case ',': case ')': | |
b90ba157 RH |
2011 | if ((c==',' && dim == rank -1) |
2012 | || (c==')' && dim < rank -1)) | |
29dc5138 | 2013 | { |
45dfbe77 JD |
2014 | if (is_char) |
2015 | sprintf (parse_err_msg, "Bad substring qualifier"); | |
2016 | else | |
2017 | sprintf (parse_err_msg, "Bad number of index fields"); | |
29dc5138 PT |
2018 | goto err_ret; |
2019 | } | |
2020 | break; | |
2021 | ||
2022 | CASE_DIGITS: | |
5e805e44 | 2023 | push_char (dtp, c); |
29dc5138 PT |
2024 | continue; |
2025 | ||
2026 | case ' ': case '\t': | |
5e805e44 JJ |
2027 | eat_spaces (dtp); |
2028 | c = next_char (dtp); | |
29dc5138 PT |
2029 | break; |
2030 | ||
2031 | default: | |
45dfbe77 JD |
2032 | if (is_char) |
2033 | sprintf (parse_err_msg, | |
2034 | "Bad character in substring qualifier"); | |
2035 | else | |
2036 | sprintf (parse_err_msg, "Bad character in index"); | |
29dc5138 PT |
2037 | goto err_ret; |
2038 | } | |
2039 | ||
5e805e44 JJ |
2040 | if ((c == ',' || c == ')') && indx == 0 |
2041 | && dtp->u.p.saved_string == 0) | |
29dc5138 | 2042 | { |
45dfbe77 JD |
2043 | if (is_char) |
2044 | sprintf (parse_err_msg, "Null substring qualifier"); | |
2045 | else | |
2046 | sprintf (parse_err_msg, "Null index field"); | |
29dc5138 PT |
2047 | goto err_ret; |
2048 | } | |
2049 | ||
5e805e44 | 2050 | if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0) |
b90ba157 | 2051 | || (indx == 2 && dtp->u.p.saved_string == 0)) |
29dc5138 | 2052 | { |
45dfbe77 JD |
2053 | if (is_char) |
2054 | sprintf (parse_err_msg, "Bad substring qualifier"); | |
2055 | else | |
2056 | sprintf (parse_err_msg, "Bad index triplet"); | |
2057 | goto err_ret; | |
2058 | } | |
2059 | ||
2060 | if (is_char && !is_array_section) | |
2061 | { | |
2062 | sprintf (parse_err_msg, | |
2063 | "Missing colon in substring qualifier"); | |
29dc5138 PT |
2064 | goto err_ret; |
2065 | } | |
2066 | ||
2067 | /* If '( : ? )' or '( ? : )' break and flag read failure. */ | |
2068 | null_flag = 0; | |
5e805e44 | 2069 | if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0) |
b90ba157 | 2070 | || (indx==1 && dtp->u.p.saved_string == 0)) |
29dc5138 PT |
2071 | { |
2072 | null_flag = 1; | |
2073 | break; | |
2074 | } | |
2075 | ||
2076 | /* Now read the index. */ | |
e9af03e0 | 2077 | if (convert_integer (dtp, sizeof(ssize_t), neg)) |
29dc5138 | 2078 | { |
45dfbe77 JD |
2079 | if (is_char) |
2080 | sprintf (parse_err_msg, "Bad integer substring qualifier"); | |
2081 | else | |
2082 | sprintf (parse_err_msg, "Bad integer in index"); | |
29dc5138 PT |
2083 | goto err_ret; |
2084 | } | |
2085 | break; | |
2086 | } | |
2087 | ||
b90ba157 | 2088 | /* Feed the index values to the triplet arrays. */ |
29dc5138 PT |
2089 | if (!null_flag) |
2090 | { | |
2091 | if (indx == 0) | |
e9af03e0 | 2092 | memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t)); |
29dc5138 | 2093 | if (indx == 1) |
e9af03e0 | 2094 | memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t)); |
29dc5138 | 2095 | if (indx == 2) |
e9af03e0 | 2096 | memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t)); |
29dc5138 PT |
2097 | } |
2098 | ||
b90ba157 | 2099 | /* Singlet or doublet indices. */ |
29dc5138 PT |
2100 | if (c==',' || c==')') |
2101 | { | |
2102 | if (indx == 0) | |
2103 | { | |
e9af03e0 | 2104 | memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t)); |
25292a1b JD |
2105 | |
2106 | /* If -std=f95/2003 or an array section is specified, | |
2107 | do not allow excess data to be processed. */ | |
2108 | if (is_array_section == 1 | |
58fc89f6 | 2109 | || !(compile_options.allow_std & GFC_STD_GNU)) |
25292a1b JD |
2110 | ls[dim].end = ls[dim].start; |
2111 | else | |
2112 | dtp->u.p.expanded_read = 1; | |
29dc5138 | 2113 | } |
45dfbe77 JD |
2114 | |
2115 | /* Check for non-zero rank. */ | |
2116 | if (is_array_section == 1 && ls[dim].start != ls[dim].end) | |
2117 | *parsed_rank = 1; | |
2118 | ||
29dc5138 PT |
2119 | break; |
2120 | } | |
2121 | } | |
2122 | ||
2f4d643d TB |
2123 | if (is_array_section == 1 && dtp->u.p.expanded_read == 1) |
2124 | { | |
2125 | int i; | |
2126 | dtp->u.p.expanded_read = 0; | |
2127 | for (i = 0; i < dim; i++) | |
2128 | ls[i].end = ls[i].start; | |
2129 | } | |
2130 | ||
b90ba157 | 2131 | /* Check the values of the triplet indices. */ |
dfb55fdc TK |
2132 | if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim])) |
2133 | || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])) | |
2134 | || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim])) | |
2135 | || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))) | |
29dc5138 | 2136 | { |
45dfbe77 JD |
2137 | if (is_char) |
2138 | sprintf (parse_err_msg, "Substring out of range"); | |
2139 | else | |
2140 | sprintf (parse_err_msg, "Index %d out of range", dim + 1); | |
29dc5138 PT |
2141 | goto err_ret; |
2142 | } | |
45dfbe77 | 2143 | |
29dc5138 | 2144 | if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) |
b90ba157 | 2145 | || (ls[dim].step == 0)) |
29dc5138 | 2146 | { |
d8163f5c | 2147 | sprintf (parse_err_msg, "Bad range in index %d", dim + 1); |
29dc5138 PT |
2148 | goto err_ret; |
2149 | } | |
2150 | ||
2151 | /* Initialise the loop index counter. */ | |
29dc5138 | 2152 | ls[dim].idx = ls[dim].start; |
29dc5138 | 2153 | } |
5e805e44 | 2154 | eat_spaces (dtp); |
29dc5138 PT |
2155 | return SUCCESS; |
2156 | ||
2157 | err_ret: | |
2158 | ||
2159 | return FAILURE; | |
2160 | } | |
2161 | ||
6de9cd9a | 2162 | static namelist_info * |
5e805e44 | 2163 | find_nml_node (st_parameter_dt *dtp, char * var_name) |
6de9cd9a | 2164 | { |
5e805e44 | 2165 | namelist_info * t = dtp->u.p.ionml; |
29dc5138 PT |
2166 | while (t != NULL) |
2167 | { | |
5e805e44 | 2168 | if (strcmp (var_name, t->var_name) == 0) |
29dc5138 PT |
2169 | { |
2170 | t->touched = 1; | |
2171 | return t; | |
2172 | } | |
2173 | t = t->next; | |
2174 | } | |
6de9cd9a DN |
2175 | return NULL; |
2176 | } | |
2177 | ||
29dc5138 PT |
2178 | /* Visits all the components of a derived type that have |
2179 | not explicitly been identified in the namelist input. | |
420aa7b8 | 2180 | touched is set and the loop specification initialised |
29dc5138 PT |
2181 | to default values */ |
2182 | ||
6de9cd9a | 2183 | static void |
29dc5138 | 2184 | nml_touch_nodes (namelist_info * nl) |
6de9cd9a | 2185 | { |
29dc5138 PT |
2186 | index_type len = strlen (nl->var_name) + 1; |
2187 | int dim; | |
2188 | char * ext_name = (char*)get_mem (len + 1); | |
88fdfd5a JB |
2189 | memcpy (ext_name, nl->var_name, len-1); |
2190 | memcpy (ext_name + len - 1, "%", 2); | |
29dc5138 | 2191 | for (nl = nl->next; nl; nl = nl->next) |
6de9cd9a | 2192 | { |
29dc5138 PT |
2193 | if (strncmp (nl->var_name, ext_name, len) == 0) |
2194 | { | |
2195 | nl->touched = 1; | |
2196 | for (dim=0; dim < nl->var_rank; dim++) | |
2197 | { | |
2198 | nl->ls[dim].step = 1; | |
dfb55fdc TK |
2199 | nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); |
2200 | nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); | |
29dc5138 PT |
2201 | nl->ls[dim].idx = nl->ls[dim].start; |
2202 | } | |
2203 | } | |
2204 | else | |
2205 | break; | |
6de9cd9a | 2206 | } |
bb408e87 | 2207 | free (ext_name); |
29dc5138 PT |
2208 | return; |
2209 | } | |
2210 | ||
2211 | /* Resets touched for the entire list of nml_nodes, ready for a | |
2212 | new object. */ | |
2213 | ||
2214 | static void | |
5e805e44 | 2215 | nml_untouch_nodes (st_parameter_dt *dtp) |
29dc5138 PT |
2216 | { |
2217 | namelist_info * t; | |
5e805e44 | 2218 | for (t = dtp->u.p.ionml; t; t = t->next) |
29dc5138 PT |
2219 | t->touched = 0; |
2220 | return; | |
2221 | } | |
2222 | ||
5e805e44 JJ |
2223 | /* Attempts to input name to namelist name. Returns |
2224 | dtp->u.p.nml_read_error = 1 on no match. */ | |
6de9cd9a | 2225 | |
29dc5138 | 2226 | static void |
5e805e44 | 2227 | nml_match_name (st_parameter_dt *dtp, const char *name, index_type len) |
29dc5138 PT |
2228 | { |
2229 | index_type i; | |
2230 | char c; | |
5e805e44 | 2231 | dtp->u.p.nml_read_error = 0; |
29dc5138 | 2232 | for (i = 0; i < len; i++) |
6de9cd9a | 2233 | { |
5e805e44 | 2234 | c = next_char (dtp); |
29dc5138 PT |
2235 | if (tolower (c) != tolower (name[i])) |
2236 | { | |
5e805e44 | 2237 | dtp->u.p.nml_read_error = 1; |
29dc5138 PT |
2238 | break; |
2239 | } | |
6de9cd9a DN |
2240 | } |
2241 | } | |
2242 | ||
29dc5138 PT |
2243 | /* If the namelist read is from stdin, output the current state of the |
2244 | namelist to stdout. This is used to implement the non-standard query | |
2245 | features, ? and =?. If c == '=' the full namelist is printed. Otherwise | |
2246 | the names alone are printed. */ | |
6de9cd9a | 2247 | |
29dc5138 | 2248 | static void |
5e805e44 | 2249 | nml_query (st_parameter_dt *dtp, char c) |
6de9cd9a | 2250 | { |
29dc5138 | 2251 | gfc_unit * temp_unit; |
6de9cd9a | 2252 | namelist_info * nl; |
29dc5138 PT |
2253 | index_type len; |
2254 | char * p; | |
15877a88 JB |
2255 | #ifdef HAVE_CRLF |
2256 | static const index_type endlen = 3; | |
2257 | static const char endl[] = "\r\n"; | |
2258 | static const char nmlend[] = "&end\r\n"; | |
2259 | #else | |
2260 | static const index_type endlen = 2; | |
2261 | static const char endl[] = "\n"; | |
2262 | static const char nmlend[] = "&end\n"; | |
2263 | #endif | |
6de9cd9a | 2264 | |
5e805e44 | 2265 | if (dtp->u.p.current_unit->unit_number != options.stdin_unit) |
29dc5138 | 2266 | return; |
6de9cd9a | 2267 | |
29dc5138 PT |
2268 | /* Store the current unit and transfer to stdout. */ |
2269 | ||
5e805e44 JJ |
2270 | temp_unit = dtp->u.p.current_unit; |
2271 | dtp->u.p.current_unit = find_unit (options.stdout_unit); | |
29dc5138 | 2272 | |
5e805e44 | 2273 | if (dtp->u.p.current_unit) |
6de9cd9a | 2274 | { |
5e805e44 JJ |
2275 | dtp->u.p.mode = WRITING; |
2276 | next_record (dtp, 0); | |
29dc5138 PT |
2277 | |
2278 | /* Write the namelist in its entirety. */ | |
2279 | ||
2280 | if (c == '=') | |
5e805e44 | 2281 | namelist_write (dtp); |
29dc5138 PT |
2282 | |
2283 | /* Or write the list of names. */ | |
2284 | ||
2285 | else | |
2286 | { | |
29dc5138 PT |
2287 | /* "&namelist_name\n" */ |
2288 | ||
5e805e44 | 2289 | len = dtp->namelist_name_len; |
15877a88 JB |
2290 | p = write_block (dtp, len + endlen); |
2291 | if (!p) | |
2292 | goto query_return; | |
29dc5138 | 2293 | memcpy (p, "&", 1); |
5e805e44 | 2294 | memcpy ((char*)(p + 1), dtp->namelist_name, len); |
15877a88 | 2295 | memcpy ((char*)(p + len + 1), &endl, endlen - 1); |
5e805e44 | 2296 | for (nl = dtp->u.p.ionml; nl; nl = nl->next) |
29dc5138 | 2297 | { |
29dc5138 PT |
2298 | /* " var_name\n" */ |
2299 | ||
2300 | len = strlen (nl->var_name); | |
15877a88 | 2301 | p = write_block (dtp, len + endlen); |
29dc5138 PT |
2302 | if (!p) |
2303 | goto query_return; | |
2304 | memcpy (p, " ", 1); | |
2305 | memcpy ((char*)(p + 1), nl->var_name, len); | |
15877a88 | 2306 | memcpy ((char*)(p + len + 1), &endl, endlen - 1); |
29dc5138 PT |
2307 | } |
2308 | ||
2309 | /* "&end\n" */ | |
2310 | ||
15877a88 | 2311 | p = write_block (dtp, endlen + 3); |
29dc5138 | 2312 | goto query_return; |
15877a88 | 2313 | memcpy (p, &nmlend, endlen + 3); |
29dc5138 PT |
2314 | } |
2315 | ||
2316 | /* Flush the stream to force immediate output. */ | |
2317 | ||
7812c78c JD |
2318 | fbuf_flush (dtp->u.p.current_unit, WRITING); |
2319 | sflush (dtp->u.p.current_unit->s); | |
5e805e44 | 2320 | unlock_unit (dtp->u.p.current_unit); |
6de9cd9a DN |
2321 | } |
2322 | ||
29dc5138 | 2323 | query_return: |
6de9cd9a | 2324 | |
29dc5138 | 2325 | /* Restore the current unit. */ |
6de9cd9a | 2326 | |
5e805e44 JJ |
2327 | dtp->u.p.current_unit = temp_unit; |
2328 | dtp->u.p.mode = READING; | |
29dc5138 PT |
2329 | return; |
2330 | } | |
2331 | ||
2332 | /* Reads and stores the input for the namelist object nl. For an array, | |
2333 | the function loops over the ranges defined by the loop specification. | |
2334 | This default to all the data or to the specification from a qualifier. | |
2335 | nml_read_obj recursively calls itself to read derived types. It visits | |
2336 | all its own components but only reads data for those that were touched | |
2337 | when the name was parsed. If a read error is encountered, an attempt is | |
2338 | made to return to read a new object name because the standard allows too | |
2339 | little data to be available. On the other hand, too much data is an | |
2340 | error. */ | |
2341 | ||
2342 | static try | |
5e805e44 JJ |
2343 | nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, |
2344 | namelist_info **pprev_nl, char *nml_err_msg, | |
24722ea9 | 2345 | size_t nml_err_msg_size, index_type clow, index_type chigh) |
29dc5138 | 2346 | { |
29dc5138 PT |
2347 | namelist_info * cmp; |
2348 | char * obj_name; | |
2349 | int nml_carry; | |
2350 | int len; | |
2351 | int dim; | |
2352 | index_type dlen; | |
2353 | index_type m; | |
f9bfed22 | 2354 | size_t obj_name_len; |
b8df885f | 2355 | void * pdata; |
29dc5138 PT |
2356 | |
2357 | /* This object not touched in name parsing. */ | |
2358 | ||
2359 | if (!nl->touched) | |
2360 | return SUCCESS; | |
2361 | ||
5e805e44 JJ |
2362 | dtp->u.p.repeat_count = 0; |
2363 | eat_spaces (dtp); | |
29dc5138 PT |
2364 | |
2365 | len = nl->len; | |
2366 | switch (nl->type) | |
2367 | { | |
a11930ba JD |
2368 | case BT_INTEGER: |
2369 | case BT_LOGICAL: | |
29dc5138 PT |
2370 | dlen = len; |
2371 | break; | |
2372 | ||
a11930ba | 2373 | case BT_REAL: |
e5ef4b3b JB |
2374 | dlen = size_from_real_kind (len); |
2375 | break; | |
2376 | ||
a11930ba | 2377 | case BT_COMPLEX: |
e5ef4b3b | 2378 | dlen = size_from_complex_kind (len); |
29dc5138 PT |
2379 | break; |
2380 | ||
a11930ba | 2381 | case BT_CHARACTER: |
29dc5138 | 2382 | dlen = chigh ? (chigh - clow + 1) : nl->string_length; |
6de9cd9a DN |
2383 | break; |
2384 | ||
2385 | default: | |
29dc5138 | 2386 | dlen = 0; |
6de9cd9a DN |
2387 | } |
2388 | ||
29dc5138 | 2389 | do |
6de9cd9a | 2390 | { |
29dc5138 | 2391 | /* Update the pointer to the data, using the current index vector */ |
6de9cd9a | 2392 | |
29dc5138 PT |
2393 | pdata = (void*)(nl->mem_pos + offset); |
2394 | for (dim = 0; dim < nl->var_rank; dim++) | |
dfb55fdc TK |
2395 | pdata = (void*)(pdata + (nl->ls[dim].idx |
2396 | - GFC_DESCRIPTOR_LBOUND(nl,dim)) | |
2397 | * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size); | |
77747e5f | 2398 | |
420aa7b8 | 2399 | /* Reset the error flag and try to read next value, if |
5e805e44 | 2400 | dtp->u.p.repeat_count=0 */ |
29dc5138 | 2401 | |
5e805e44 | 2402 | dtp->u.p.nml_read_error = 0; |
29dc5138 | 2403 | nml_carry = 0; |
5e805e44 | 2404 | if (--dtp->u.p.repeat_count <= 0) |
29dc5138 | 2405 | { |
5e805e44 | 2406 | if (dtp->u.p.input_complete) |
29dc5138 | 2407 | return SUCCESS; |
5e805e44 JJ |
2408 | if (dtp->u.p.at_eol) |
2409 | finish_separator (dtp); | |
2410 | if (dtp->u.p.input_complete) | |
29dc5138 PT |
2411 | return SUCCESS; |
2412 | ||
a11930ba | 2413 | dtp->u.p.saved_type = BT_UNKNOWN; |
5e805e44 | 2414 | free_saved (dtp); |
420aa7b8 | 2415 | |
6de9cd9a | 2416 | switch (nl->type) |
29dc5138 | 2417 | { |
a11930ba | 2418 | case BT_INTEGER: |
5e805e44 | 2419 | read_integer (dtp, len); |
6de9cd9a | 2420 | break; |
29dc5138 | 2421 | |
a11930ba | 2422 | case BT_LOGICAL: |
5e805e44 | 2423 | read_logical (dtp, len); |
6de9cd9a | 2424 | break; |
29dc5138 | 2425 | |
a11930ba | 2426 | case BT_CHARACTER: |
5e805e44 | 2427 | read_character (dtp, len); |
6de9cd9a | 2428 | break; |
29dc5138 | 2429 | |
a11930ba | 2430 | case BT_REAL: |
6b680210 JB |
2431 | /* Need to copy data back from the real location to the temp in order |
2432 | to handle nml reads into arrays. */ | |
2433 | read_real (dtp, pdata, len); | |
2434 | memcpy (dtp->u.p.value, pdata, dlen); | |
2435 | break; | |
29dc5138 | 2436 | |
a11930ba | 2437 | case BT_COMPLEX: |
6b680210 JB |
2438 | /* Same as for REAL, copy back to temp. */ |
2439 | read_complex (dtp, pdata, len, dlen); | |
2440 | memcpy (dtp->u.p.value, pdata, dlen); | |
2441 | break; | |
6de9cd9a | 2442 | |
a11930ba | 2443 | case BT_DERIVED: |
29dc5138 PT |
2444 | obj_name_len = strlen (nl->var_name) + 1; |
2445 | obj_name = get_mem (obj_name_len+1); | |
88fdfd5a JB |
2446 | memcpy (obj_name, nl->var_name, obj_name_len-1); |
2447 | memcpy (obj_name + obj_name_len - 1, "%", 2); | |
29dc5138 | 2448 | |
25292a1b JD |
2449 | /* If reading a derived type, disable the expanded read warning |
2450 | since a single object can have multiple reads. */ | |
2451 | dtp->u.p.expanded_read = 0; | |
2452 | ||
29dc5138 PT |
2453 | /* Now loop over the components. Update the component pointer |
2454 | with the return value from nml_write_obj. This loop jumps | |
420aa7b8 | 2455 | past nested derived types by testing if the potential |
29dc5138 PT |
2456 | component name contains '%'. */ |
2457 | ||
2458 | for (cmp = nl->next; | |
2459 | cmp && | |
2460 | !strncmp (cmp->var_name, obj_name, obj_name_len) && | |
2461 | !strchr (cmp->var_name + obj_name_len, '%'); | |
2462 | cmp = cmp->next) | |
2463 | { | |
2464 | ||
5e805e44 | 2465 | if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos), |
24722ea9 JJ |
2466 | pprev_nl, nml_err_msg, nml_err_msg_size, |
2467 | clow, chigh) == FAILURE) | |
883dd429 | 2468 | { |
bb408e87 | 2469 | free (obj_name); |
883dd429 PT |
2470 | return FAILURE; |
2471 | } | |
29dc5138 | 2472 | |
5e805e44 | 2473 | if (dtp->u.p.input_complete) |
883dd429 | 2474 | { |
bb408e87 | 2475 | free (obj_name); |
883dd429 PT |
2476 | return SUCCESS; |
2477 | } | |
29dc5138 PT |
2478 | } |
2479 | ||
bb408e87 | 2480 | free (obj_name); |
29dc5138 PT |
2481 | goto incr_idx; |
2482 | ||
2483 | default: | |
24722ea9 JJ |
2484 | snprintf (nml_err_msg, nml_err_msg_size, |
2485 | "Bad type for namelist object %s", nl->var_name); | |
5e805e44 | 2486 | internal_error (&dtp->common, nml_err_msg); |
29dc5138 PT |
2487 | goto nml_err_ret; |
2488 | } | |
2489 | } | |
6de9cd9a | 2490 | |
29dc5138 PT |
2491 | /* The standard permits array data to stop short of the number of |
2492 | elements specified in the loop specification. In this case, we | |
5e805e44 | 2493 | should be here with dtp->u.p.nml_read_error != 0. Control returns to |
29dc5138 | 2494 | nml_get_obj_data and an attempt is made to read object name. */ |
6de9cd9a | 2495 | |
5e805e44 JJ |
2496 | *pprev_nl = nl; |
2497 | if (dtp->u.p.nml_read_error) | |
25292a1b JD |
2498 | { |
2499 | dtp->u.p.expanded_read = 0; | |
2500 | return SUCCESS; | |
2501 | } | |
6de9cd9a | 2502 | |
a11930ba | 2503 | if (dtp->u.p.saved_type == BT_UNKNOWN) |
25292a1b JD |
2504 | { |
2505 | dtp->u.p.expanded_read = 0; | |
2506 | goto incr_idx; | |
2507 | } | |
29dc5138 | 2508 | |
5e805e44 | 2509 | switch (dtp->u.p.saved_type) |
29dc5138 PT |
2510 | { |
2511 | ||
2512 | case BT_COMPLEX: | |
2513 | case BT_REAL: | |
2514 | case BT_INTEGER: | |
2515 | case BT_LOGICAL: | |
5e805e44 | 2516 | memcpy (pdata, dtp->u.p.value, dlen); |
29dc5138 PT |
2517 | break; |
2518 | ||
2519 | case BT_CHARACTER: | |
5e805e44 | 2520 | m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used; |
29dc5138 | 2521 | pdata = (void*)( pdata + clow - 1 ); |
5e805e44 | 2522 | memcpy (pdata, dtp->u.p.saved_string, m); |
29dc5138 PT |
2523 | if (m < dlen) |
2524 | memset ((void*)( pdata + m ), ' ', dlen - m); | |
25292a1b | 2525 | break; |
29dc5138 PT |
2526 | |
2527 | default: | |
2528 | break; | |
2529 | } | |
2530 | ||
25292a1b JD |
2531 | /* Warn if a non-standard expanded read occurs. A single read of a |
2532 | single object is acceptable. If a second read occurs, issue a warning | |
2533 | and set the flag to zero to prevent further warnings. */ | |
2534 | if (dtp->u.p.expanded_read == 2) | |
2535 | { | |
2e444427 | 2536 | notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read."); |
25292a1b JD |
2537 | dtp->u.p.expanded_read = 0; |
2538 | } | |
2539 | ||
2540 | /* If the expanded read warning flag is set, increment it, | |
8b6dba81 | 2541 | indicating that a single read has occurred. */ |
25292a1b JD |
2542 | if (dtp->u.p.expanded_read >= 1) |
2543 | dtp->u.p.expanded_read++; | |
29dc5138 | 2544 | |
25292a1b | 2545 | /* Break out of loop if scalar. */ |
29dc5138 PT |
2546 | if (!nl->var_rank) |
2547 | break; | |
2548 | ||
2549 | /* Now increment the index vector. */ | |
2550 | ||
2551 | incr_idx: | |
2552 | ||
2553 | nml_carry = 1; | |
2554 | for (dim = 0; dim < nl->var_rank; dim++) | |
2555 | { | |
2556 | nl->ls[dim].idx += nml_carry * nl->ls[dim].step; | |
2557 | nml_carry = 0; | |
2558 | if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end)) | |
2559 | || | |
2560 | ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end))) | |
2561 | { | |
2562 | nl->ls[dim].idx = nl->ls[dim].start; | |
2563 | nml_carry = 1; | |
2564 | } | |
2565 | } | |
2566 | } while (!nml_carry); | |
2567 | ||
5e805e44 | 2568 | if (dtp->u.p.repeat_count > 1) |
29dc5138 | 2569 | { |
24722ea9 JJ |
2570 | snprintf (nml_err_msg, nml_err_msg_size, |
2571 | "Repeat count too large for namelist object %s", nl->var_name); | |
2572 | goto nml_err_ret; | |
29dc5138 PT |
2573 | } |
2574 | return SUCCESS; | |
2575 | ||
2576 | nml_err_ret: | |
2577 | ||
2578 | return FAILURE; | |
2579 | } | |
2580 | ||
2581 | /* Parses the object name, including array and substring qualifiers. It | |
2582 | iterates over derived type components, touching those components and | |
2583 | setting their loop specifications, if there is a qualifier. If the | |
2584 | object is itself a derived type, its components and subcomponents are | |
2585 | touched. nml_read_obj is called at the end and this reads the data in | |
2586 | the manner specified by the object name. */ | |
2587 | ||
2588 | static try | |
5e805e44 | 2589 | nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, |
24722ea9 | 2590 | char *nml_err_msg, size_t nml_err_msg_size) |
29dc5138 PT |
2591 | { |
2592 | char c; | |
29dc5138 | 2593 | namelist_info * nl; |
7672ae20 AJ |
2594 | namelist_info * first_nl = NULL; |
2595 | namelist_info * root_nl = NULL; | |
45dfbe77 | 2596 | int dim, parsed_rank; |
e3e2cdd1 | 2597 | int component_flag, qualifier_flag; |
5e805e44 | 2598 | index_type clow, chigh; |
45dfbe77 | 2599 | int non_zero_rank_count; |
29dc5138 PT |
2600 | |
2601 | /* Look for end of input or object name. If '?' or '=?' are encountered | |
2602 | in stdin, print the node names or the namelist to stdout. */ | |
2603 | ||
5e805e44 JJ |
2604 | eat_separator (dtp); |
2605 | if (dtp->u.p.input_complete) | |
29dc5138 PT |
2606 | return SUCCESS; |
2607 | ||
5e805e44 JJ |
2608 | if (dtp->u.p.at_eol) |
2609 | finish_separator (dtp); | |
2610 | if (dtp->u.p.input_complete) | |
29dc5138 PT |
2611 | return SUCCESS; |
2612 | ||
5e805e44 | 2613 | c = next_char (dtp); |
29dc5138 PT |
2614 | switch (c) |
2615 | { | |
2616 | case '=': | |
5e805e44 | 2617 | c = next_char (dtp); |
29dc5138 PT |
2618 | if (c != '?') |
2619 | { | |
d8163f5c | 2620 | sprintf (nml_err_msg, "namelist read: misplaced = sign"); |
29dc5138 PT |
2621 | goto nml_err_ret; |
2622 | } | |
5e805e44 | 2623 | nml_query (dtp, '='); |
29dc5138 PT |
2624 | return SUCCESS; |
2625 | ||
2626 | case '?': | |
5e805e44 | 2627 | nml_query (dtp, '?'); |
29dc5138 PT |
2628 | return SUCCESS; |
2629 | ||
2630 | case '$': | |
2631 | case '&': | |
5e805e44 JJ |
2632 | nml_match_name (dtp, "end", 3); |
2633 | if (dtp->u.p.nml_read_error) | |
29dc5138 | 2634 | { |
d8163f5c | 2635 | sprintf (nml_err_msg, "namelist not terminated with / or &end"); |
29dc5138 PT |
2636 | goto nml_err_ret; |
2637 | } | |
2638 | case '/': | |
5e805e44 | 2639 | dtp->u.p.input_complete = 1; |
29dc5138 PT |
2640 | return SUCCESS; |
2641 | ||
2642 | default : | |
2643 | break; | |
2644 | } | |
2645 | ||
e3e2cdd1 | 2646 | /* Untouch all nodes of the namelist and reset the flags that are set for |
29dc5138 PT |
2647 | derived type components. */ |
2648 | ||
5e805e44 | 2649 | nml_untouch_nodes (dtp); |
29dc5138 | 2650 | component_flag = 0; |
e3e2cdd1 | 2651 | qualifier_flag = 0; |
45dfbe77 | 2652 | non_zero_rank_count = 0; |
29dc5138 PT |
2653 | |
2654 | /* Get the object name - should '!' and '\n' be permitted separators? */ | |
2655 | ||
2656 | get_name: | |
2657 | ||
5e805e44 | 2658 | free_saved (dtp); |
29dc5138 PT |
2659 | |
2660 | do | |
2661 | { | |
78a15b1f JD |
2662 | if (!is_separator (c)) |
2663 | push_char (dtp, tolower(c)); | |
5e805e44 | 2664 | c = next_char (dtp); |
29dc5138 PT |
2665 | } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' )); |
2666 | ||
5e805e44 | 2667 | unget_char (dtp, c); |
29dc5138 PT |
2668 | |
2669 | /* Check that the name is in the namelist and get pointer to object. | |
2670 | Three error conditions exist: (i) An attempt is being made to | |
2671 | identify a non-existent object, following a failed data read or | |
2672 | (ii) The object name does not exist or (iii) Too many data items | |
2673 | are present for an object. (iii) gives the same error message | |
2674 | as (i) */ | |
2675 | ||
5e805e44 | 2676 | push_char (dtp, '\0'); |
29dc5138 PT |
2677 | |
2678 | if (component_flag) | |
2679 | { | |
5e805e44 JJ |
2680 | size_t var_len = strlen (root_nl->var_name); |
2681 | size_t saved_len | |
2682 | = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0; | |
2683 | char ext_name[var_len + saved_len + 1]; | |
2684 | ||
2685 | memcpy (ext_name, root_nl->var_name, var_len); | |
2686 | if (dtp->u.p.saved_string) | |
2687 | memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len); | |
2688 | ext_name[var_len + saved_len] = '\0'; | |
2689 | nl = find_nml_node (dtp, ext_name); | |
29dc5138 PT |
2690 | } |
2691 | else | |
5e805e44 | 2692 | nl = find_nml_node (dtp, dtp->u.p.saved_string); |
29dc5138 PT |
2693 | |
2694 | if (nl == NULL) | |
2695 | { | |
5e805e44 | 2696 | if (dtp->u.p.nml_read_error && *pprev_nl) |
24722ea9 JJ |
2697 | snprintf (nml_err_msg, nml_err_msg_size, |
2698 | "Bad data for namelist object %s", (*pprev_nl)->var_name); | |
29dc5138 PT |
2699 | |
2700 | else | |
24722ea9 JJ |
2701 | snprintf (nml_err_msg, nml_err_msg_size, |
2702 | "Cannot match namelist object name %s", | |
2703 | dtp->u.p.saved_string); | |
29dc5138 PT |
2704 | |
2705 | goto nml_err_ret; | |
2706 | } | |
2707 | ||
2708 | /* Get the length, data length, base pointer and rank of the variable. | |
2709 | Set the default loop specification first. */ | |
2710 | ||
2711 | for (dim=0; dim < nl->var_rank; dim++) | |
2712 | { | |
2713 | nl->ls[dim].step = 1; | |
dfb55fdc TK |
2714 | nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); |
2715 | nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); | |
29dc5138 PT |
2716 | nl->ls[dim].idx = nl->ls[dim].start; |
2717 | } | |
2718 | ||
2719 | /* Check to see if there is a qualifier: if so, parse it.*/ | |
2720 | ||
2721 | if (c == '(' && nl->var_rank) | |
2722 | { | |
45dfbe77 | 2723 | parsed_rank = 0; |
5e805e44 | 2724 | if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, |
24722ea9 | 2725 | nml_err_msg, &parsed_rank) == FAILURE) |
29dc5138 | 2726 | { |
24722ea9 JJ |
2727 | char *nml_err_msg_end = strchr (nml_err_msg, '\0'); |
2728 | snprintf (nml_err_msg_end, | |
2729 | nml_err_msg_size - (nml_err_msg_end - nml_err_msg), | |
2730 | " for namelist variable %s", nl->var_name); | |
29dc5138 PT |
2731 | goto nml_err_ret; |
2732 | } | |
45dfbe77 JD |
2733 | if (parsed_rank > 0) |
2734 | non_zero_rank_count++; | |
2735 | ||
e3e2cdd1 JD |
2736 | qualifier_flag = 1; |
2737 | ||
5e805e44 JJ |
2738 | c = next_char (dtp); |
2739 | unget_char (dtp, c); | |
29dc5138 | 2740 | } |
45dfbe77 JD |
2741 | else if (nl->var_rank > 0) |
2742 | non_zero_rank_count++; | |
29dc5138 PT |
2743 | |
2744 | /* Now parse a derived type component. The root namelist_info address | |
2745 | is backed up, as is the previous component level. The component flag | |
2746 | is set and the iteration is made by jumping back to get_name. */ | |
2747 | ||
2748 | if (c == '%') | |
2749 | { | |
a11930ba | 2750 | if (nl->type != BT_DERIVED) |
29dc5138 | 2751 | { |
24722ea9 JJ |
2752 | snprintf (nml_err_msg, nml_err_msg_size, |
2753 | "Attempt to get derived component for %s", nl->var_name); | |
29dc5138 PT |
2754 | goto nml_err_ret; |
2755 | } | |
2756 | ||
3423894f | 2757 | if (*pprev_nl == NULL || !component_flag) |
29dc5138 PT |
2758 | first_nl = nl; |
2759 | ||
2760 | root_nl = nl; | |
3423894f | 2761 | |
29dc5138 | 2762 | component_flag = 1; |
e3e2cdd1 | 2763 | |
5e805e44 | 2764 | c = next_char (dtp); |
29dc5138 | 2765 | goto get_name; |
29dc5138 PT |
2766 | } |
2767 | ||
2768 | /* Parse a character qualifier, if present. chigh = 0 is a default | |
2769 | that signals that the string length = string_length. */ | |
2770 | ||
2771 | clow = 1; | |
2772 | chigh = 0; | |
2773 | ||
a11930ba | 2774 | if (c == '(' && nl->type == BT_CHARACTER) |
29dc5138 | 2775 | { |
4b6903ec | 2776 | descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; |
965eec16 | 2777 | array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; |
29dc5138 | 2778 | |
24722ea9 | 2779 | if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank) |
45dfbe77 | 2780 | == FAILURE) |
29dc5138 | 2781 | { |
24722ea9 JJ |
2782 | char *nml_err_msg_end = strchr (nml_err_msg, '\0'); |
2783 | snprintf (nml_err_msg_end, | |
2784 | nml_err_msg_size - (nml_err_msg_end - nml_err_msg), | |
2785 | " for namelist variable %s", nl->var_name); | |
29dc5138 PT |
2786 | goto nml_err_ret; |
2787 | } | |
2788 | ||
2789 | clow = ind[0].start; | |
2790 | chigh = ind[0].end; | |
2791 | ||
2792 | if (ind[0].step != 1) | |
2793 | { | |
24722ea9 JJ |
2794 | snprintf (nml_err_msg, nml_err_msg_size, |
2795 | "Step not allowed in substring qualifier" | |
2796 | " for namelist object %s", nl->var_name); | |
29dc5138 PT |
2797 | goto nml_err_ret; |
2798 | } | |
2799 | ||
5e805e44 JJ |
2800 | c = next_char (dtp); |
2801 | unget_char (dtp, c); | |
29dc5138 PT |
2802 | } |
2803 | ||
45dfbe77 | 2804 | /* Make sure no extraneous qualifiers are there. */ |
29dc5138 PT |
2805 | |
2806 | if (c == '(') | |
2807 | { | |
24722ea9 JJ |
2808 | snprintf (nml_err_msg, nml_err_msg_size, |
2809 | "Qualifier for a scalar or non-character namelist object %s", | |
2810 | nl->var_name); | |
29dc5138 PT |
2811 | goto nml_err_ret; |
2812 | } | |
2813 | ||
45dfbe77 JD |
2814 | /* Make sure there is no more than one non-zero rank object. */ |
2815 | if (non_zero_rank_count > 1) | |
2816 | { | |
24722ea9 JJ |
2817 | snprintf (nml_err_msg, nml_err_msg_size, |
2818 | "Multiple sub-objects with non-zero rank in namelist object %s", | |
2819 | nl->var_name); | |
45dfbe77 JD |
2820 | non_zero_rank_count = 0; |
2821 | goto nml_err_ret; | |
2822 | } | |
2823 | ||
29dc5138 PT |
2824 | /* According to the standard, an equal sign MUST follow an object name. The |
2825 | following is possibly lax - it allows comments, blank lines and so on to | |
5e805e44 | 2826 | intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/ |
29dc5138 | 2827 | |
5e805e44 | 2828 | free_saved (dtp); |
29dc5138 | 2829 | |
5e805e44 JJ |
2830 | eat_separator (dtp); |
2831 | if (dtp->u.p.input_complete) | |
29dc5138 PT |
2832 | return SUCCESS; |
2833 | ||
5e805e44 JJ |
2834 | if (dtp->u.p.at_eol) |
2835 | finish_separator (dtp); | |
2836 | if (dtp->u.p.input_complete) | |
29dc5138 PT |
2837 | return SUCCESS; |
2838 | ||
5e805e44 | 2839 | c = next_char (dtp); |
29dc5138 PT |
2840 | |
2841 | if (c != '=') | |
2842 | { | |
24722ea9 JJ |
2843 | snprintf (nml_err_msg, nml_err_msg_size, |
2844 | "Equal sign must follow namelist object name %s", | |
2845 | nl->var_name); | |
29dc5138 PT |
2846 | goto nml_err_ret; |
2847 | } | |
e3e2cdd1 JD |
2848 | /* If a derived type, touch its components and restore the root |
2849 | namelist_info if we have parsed a qualified derived type | |
2850 | component. */ | |
2851 | ||
a11930ba | 2852 | if (nl->type == BT_DERIVED) |
e3e2cdd1 JD |
2853 | nml_touch_nodes (nl); |
2854 | ||
2855 | if (first_nl) | |
2856 | { | |
2857 | if (first_nl->var_rank == 0) | |
2858 | { | |
2859 | if (component_flag && qualifier_flag) | |
2860 | nl = first_nl; | |
2861 | } | |
2862 | else | |
2863 | nl = first_nl; | |
2864 | } | |
6de9cd9a | 2865 | |
24722ea9 JJ |
2866 | if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size, |
2867 | clow, chigh) == FAILURE) | |
29dc5138 PT |
2868 | goto nml_err_ret; |
2869 | ||
2870 | return SUCCESS; | |
2871 | ||
2872 | nml_err_ret: | |
2873 | ||
2874 | return FAILURE; | |
2875 | } | |
2876 | ||
2877 | /* Entry point for namelist input. Goes through input until namelist name | |
2878 | is matched. Then cycles through nml_get_obj_data until the input is | |
2879 | completed or there is an error. */ | |
2880 | ||
2881 | void | |
5e805e44 | 2882 | namelist_read (st_parameter_dt *dtp) |
29dc5138 PT |
2883 | { |
2884 | char c; | |
5e805e44 | 2885 | jmp_buf eof_jump; |
24722ea9 | 2886 | char nml_err_msg[200]; |
5e805e44 JJ |
2887 | /* Pointer to the previously read object, in case attempt is made to read |
2888 | new object name. Should this fail, error message can give previous | |
2889 | name. */ | |
2890 | namelist_info *prev_nl = NULL; | |
29dc5138 | 2891 | |
5e805e44 JJ |
2892 | dtp->u.p.namelist_mode = 1; |
2893 | dtp->u.p.input_complete = 0; | |
25292a1b | 2894 | dtp->u.p.expanded_read = 0; |
29dc5138 | 2895 | |
5e805e44 JJ |
2896 | dtp->u.p.eof_jump = &eof_jump; |
2897 | if (setjmp (eof_jump)) | |
29dc5138 | 2898 | { |
5e805e44 | 2899 | dtp->u.p.eof_jump = NULL; |
d74b97cc | 2900 | generate_error (&dtp->common, LIBERROR_END, NULL); |
29dc5138 PT |
2901 | return; |
2902 | } | |
2903 | ||
2904 | /* Look for &namelist_name . Skip all characters, testing for $nmlname. | |
2905 | Exit on success or EOF. If '?' or '=?' encountered in stdin, print | |
2906 | node names or namelist on stdout. */ | |
2907 | ||
2908 | find_nml_name: | |
5e805e44 | 2909 | switch (c = next_char (dtp)) |
29dc5138 PT |
2910 | { |
2911 | case '$': | |
2912 | case '&': | |
6de9cd9a | 2913 | break; |
29dc5138 | 2914 | |
4f8d744e JD |
2915 | case '!': |
2916 | eat_line (dtp); | |
2917 | goto find_nml_name; | |
2918 | ||
29dc5138 | 2919 | case '=': |
5e805e44 | 2920 | c = next_char (dtp); |
29dc5138 | 2921 | if (c == '?') |
5e805e44 | 2922 | nml_query (dtp, '='); |
29dc5138 | 2923 | else |
5e805e44 | 2924 | unget_char (dtp, c); |
29dc5138 PT |
2925 | goto find_nml_name; |
2926 | ||
2927 | case '?': | |
5e805e44 | 2928 | nml_query (dtp, '?'); |
29dc5138 PT |
2929 | |
2930 | default: | |
2931 | goto find_nml_name; | |
2932 | } | |
2933 | ||
2934 | /* Match the name of the namelist. */ | |
2935 | ||
5e805e44 | 2936 | nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len); |
29dc5138 | 2937 | |
5e805e44 | 2938 | if (dtp->u.p.nml_read_error) |
29dc5138 PT |
2939 | goto find_nml_name; |
2940 | ||
cf9293a1 JD |
2941 | /* A trailing space is required, we give a little lattitude here, 10.9.1. */ |
2942 | c = next_char (dtp); | |
7b063fdc | 2943 | if (!is_separator(c) && c != '!') |
cf9293a1 JD |
2944 | { |
2945 | unget_char (dtp, c); | |
2946 | goto find_nml_name; | |
2947 | } | |
2948 | ||
bdd3085e JD |
2949 | unget_char (dtp, c); |
2950 | eat_separator (dtp); | |
a82094b7 | 2951 | |
29dc5138 PT |
2952 | /* Ready to read namelist objects. If there is an error in input |
2953 | from stdin, output the error message and continue. */ | |
2954 | ||
5e805e44 | 2955 | while (!dtp->u.p.input_complete) |
29dc5138 | 2956 | { |
24722ea9 JJ |
2957 | if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg) |
2958 | == FAILURE) | |
29dc5138 | 2959 | { |
5e805e44 | 2960 | if (dtp->u.p.current_unit->unit_number != options.stdin_unit) |
29dc5138 | 2961 | goto nml_err_ret; |
e1721879 | 2962 | generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); |
6de9cd9a | 2963 | } |
e1721879 | 2964 | } |
5e805e44 JJ |
2965 | |
2966 | dtp->u.p.eof_jump = NULL; | |
2967 | free_saved (dtp); | |
c9f15d9c | 2968 | free_line (dtp); |
29dc5138 PT |
2969 | return; |
2970 | ||
2971 | /* All namelist error calls return from here */ | |
2972 | ||
2973 | nml_err_ret: | |
2974 | ||
5e805e44 JJ |
2975 | dtp->u.p.eof_jump = NULL; |
2976 | free_saved (dtp); | |
c9f15d9c | 2977 | free_line (dtp); |
d74b97cc | 2978 | generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); |
29dc5138 | 2979 | return; |
6de9cd9a | 2980 | } |