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