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