1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
5
6 This file is part of the GNU Fortran runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
12
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
26
27
28 #include "io.h"
29 #include "fbuf.h"
30 #include "unix.h"
31 #include <string.h>
32 #include <ctype.h>
33
34 typedef unsigned char uchar;
35
36
37 /* List directed input. Several parsing subroutines are practically
38 reimplemented from formatted input, the reason being that there are
39 all kinds of small differences between formatted and list directed
40 parsing. */
41
42
43 /* Subroutines for reading characters from the input. Because a
44 repeat count is ambiguous with an integer, we have to read the
45 whole digit string before seeing if there is a '*' which signals
46 the repeat count. Since we can have a lot of potential leading
47 zeros, we have to be able to back up by arbitrary amount. Because
48 the input might not be seekable, we have to buffer the data
49 ourselves. */
50
51 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
52 case '5': case '6': case '7': case '8': case '9'
53
54 #define CASE_SEPARATORS /* Fall through. */ \
55 case ' ': case ',': case '/': case '\n': \
56 case '\t': case '\r': case ';'
57
58 /* This macro assumes that we're operating on a variable. */
59
60 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
61 || c == '\t' || c == '\r' || c == ';' || \
62 (dtp->u.p.namelist_mode && c == '!'))
63
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
65
66 #define MAX_REPEAT 200000000
67
68
69 #define MSGLEN 100
70
71
72 /* Wrappers for calling the current worker functions. */
73
74 #define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
75 #define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c))
76
77 /* Worker function to save a default KIND=1 character to a string
78 buffer, enlarging it as necessary. */
79
80 static void
push_char_default(st_parameter_dt * dtp,int c)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
push_char4(st_parameter_dt * dtp,int c)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
free_saved(st_parameter_dt * dtp)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
free_line(st_parameter_dt * dtp)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
check_buffers(st_parameter_dt * dtp)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
next_char_default(st_parameter_dt * dtp)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
next_char_internal(st_parameter_dt * dtp)226 next_char_internal (st_parameter_dt *dtp)
227 {
228 ssize_t length;
229 gfc_offset record;
230 int c;
231
232 /* Always check the unget and line buffer first. */
233 if ((c = check_buffers (dtp)))
234 return c;
235
236 /* Handle the end-of-record and end-of-file conditions for
237 internal array unit. */
238 if (is_array_io (dtp))
239 {
240 if (dtp->u.p.at_eof)
241 return EOF;
242
243 /* Check for "end-of-record" condition. */
244 if (dtp->u.p.current_unit->bytes_left == 0)
245 {
246 int finished;
247
248 c = '\n';
249 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
250 &finished);
251
252 /* Check for "end-of-file" condition. */
253 if (finished)
254 {
255 dtp->u.p.at_eof = 1;
256 goto done;
257 }
258
259 record *= dtp->u.p.current_unit->recl;
260 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
261 return EOF;
262
263 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
264 goto done;
265 }
266 }
267
268 /* Get the next character and handle end-of-record conditions. */
269 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 }
280 else
281 length = 0;
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 }
308 dtp->u.p.current_unit->bytes_left--;
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
next_char_utf8(st_parameter_dt * dtp)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
unget_char(st_parameter_dt * dtp,int c)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
eat_spaces(st_parameter_dt * dtp)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
eat_line(st_parameter_dt * dtp)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
eat_separator(st_parameter_dt * dtp)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
finish_separator(st_parameter_dt * dtp)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
nml_bad_return(st_parameter_dt * dtp,char c)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
convert_integer(st_parameter_dt * dtp,int length,int negative)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
parse_repeat(st_parameter_dt * dtp)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
l_push_char(st_parameter_dt * dtp,char c)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
read_logical(st_parameter_dt * dtp,int length)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
read_integer(st_parameter_dt * dtp,int length)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
read_character(st_parameter_dt * dtp,int length)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
parse_real(st_parameter_dt * dtp,void * buffer,int length)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. */
1383 if (dtp->common.flags & IOPARM_DT_DEC_EXT)
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
read_complex(st_parameter_dt * dtp,void * dest,int kind,size_t size)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
read_real(st_parameter_dt * dtp,void * dest,int length)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. */
1834 if (dtp->common.flags & IOPARM_DT_DEC_EXT)
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
check_type(st_parameter_dt * dtp,bt type,int kind)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
set_workers(st_parameter_dt * dtp)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
list_formatted_read_scalar(st_parameter_dt * dtp,bt type,void * p,int kind,size_t size)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;
2103 size_t m;
2104 int c;
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;
2201 gfc_full_array_i4 vlist;
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 {
2259 m = (size < (size_t) dtp->u.p.saved_used)
2260 ? size : (size_t) dtp->u.p.saved_used;
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)
2265 for (size_t i = 0; i < m; i++)
2266 *q++ = *r++;
2267 else
2268 {
2269 if (kind == 1)
2270 memcpy (p, dtp->u.p.saved_string, m);
2271 else
2272 for (size_t i = 0; i < m; i++)
2273 *q++ = *r++;
2274 }
2275 }
2276 else
2277 /* Just delimiters encountered, nothing to copy but SPACE. */
2278 m = 0;
2279
2280 if (m < size)
2281 {
2282 if (kind == 1)
2283 memset (((char *) p) + m, ' ', size - m);
2284 else
2285 {
2286 q = (gfc_char4_t *) p;
2287 for (size_t i = m; i < size; i++)
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
list_formatted_read(st_parameter_dt * dtp,bt type,void * p,int kind,size_t size,size_t nelems)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
finish_list_read(st_parameter_dt * dtp)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
nml_parse_qualifier(st_parameter_dt * dtp,descriptor_dimension * ad,array_loop_spec * ls,int rank,bt nml_elem_type,char * parse_err_msg,size_t parse_err_msg_size,int * parsed_rank)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
extended_look_ahead(char * p,char * q)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
strcmp_extended_type(char * p,char * q)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 *
find_nml_node(st_parameter_dt * dtp,char * var_name)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
nml_touch_nodes(namelist_info * nl)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
nml_untouch_nodes(st_parameter_dt * dtp)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
nml_match_name(st_parameter_dt * dtp,const char * name,index_type len)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
nml_query(st_parameter_dt * dtp,char c)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
nml_read_obj(st_parameter_dt * dtp,namelist_info * nl,index_type offset,namelist_info ** pprev_nl,char * nml_err_msg,size_t nml_err_msg_size,index_type clow,index_type chigh)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;
2999 gfc_full_array_i4 vlist;
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
nml_get_obj_data(st_parameter_dt * dtp,namelist_info ** pprev_nl,char * nml_err_msg,size_t nml_err_msg_size)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
namelist_read(st_parameter_dt * dtp)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))
3617 goto nml_err_ret;
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 }
3638