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