1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist input contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
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
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
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'
54 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
57 /* This macro assumes that we're operating on a variable. */
59 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
60 || c == '\t' || c == '\r')
62 /* Maximum repeat count. Less than ten times the maximum signed int32. */
64 #define MAX_REPEAT 200000000
67 /* Save a character to a string buffer, enlarging it as necessary. */
70 push_char (st_parameter_dt
*dtp
, char c
)
74 if (dtp
->u
.p
.saved_string
== NULL
)
76 if (dtp
->u
.p
.scratch
== NULL
)
77 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
78 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
79 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
80 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
81 dtp
->u
.p
.saved_used
= 0;
84 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
86 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
87 new = get_mem (2 * dtp
->u
.p
.saved_length
);
89 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
91 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
92 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
93 free_mem (dtp
->u
.p
.saved_string
);
95 dtp
->u
.p
.saved_string
= new;
98 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
102 /* Free the input buffer if necessary. */
105 free_saved (st_parameter_dt
*dtp
)
107 if (dtp
->u
.p
.saved_string
== NULL
)
110 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
111 free_mem (dtp
->u
.p
.saved_string
);
113 dtp
->u
.p
.saved_string
= NULL
;
114 dtp
->u
.p
.saved_used
= 0;
118 /* Free the line buffer if necessary. */
121 free_line (st_parameter_dt
*dtp
)
123 if (dtp
->u
.p
.line_buffer
== NULL
)
126 free_mem (dtp
->u
.p
.line_buffer
);
127 dtp
->u
.p
.line_buffer
= NULL
;
132 next_char (st_parameter_dt
*dtp
)
138 if (dtp
->u
.p
.last_char
!= '\0')
141 c
= dtp
->u
.p
.last_char
;
142 dtp
->u
.p
.last_char
= '\0';
146 /* Read from line_buffer if enabled. */
148 if (dtp
->u
.p
.line_buffer_enabled
)
152 c
= dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
];
153 if (c
!= '\0' && dtp
->u
.p
.item_count
< 64)
155 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
] = '\0';
156 dtp
->u
.p
.item_count
++;
160 dtp
->u
.p
.item_count
= 0;
161 dtp
->u
.p
.line_buffer_enabled
= 0;
164 /* Handle the end-of-record and end-of-file conditions for
165 internal array unit. */
166 if (is_array_io (dtp
))
169 longjmp (*dtp
->u
.p
.eof_jump
, 1);
171 /* Check for "end-of-record" condition. */
172 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
175 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
177 /* Check for "end-of-file" condition. */
184 record
*= dtp
->u
.p
.current_unit
->recl
;
185 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
186 longjmp (*dtp
->u
.p
.eof_jump
, 1);
188 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
193 /* Get the next character and handle end-of-record conditions. */
197 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
199 if (is_stream_io (dtp
))
200 dtp
->u
.p
.current_unit
->strm_pos
++;
202 if (is_internal_unit (dtp
))
204 if (is_array_io (dtp
))
206 /* End of record is handled in the next pass through, above. The
207 check for NULL here is cautionary. */
210 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
214 dtp
->u
.p
.current_unit
->bytes_left
--;
220 longjmp (*dtp
->u
.p
.eof_jump
, 1);
231 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
236 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
237 longjmp (*dtp
->u
.p
.eof_jump
, 1);
238 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
245 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
250 /* Push a character back onto the input. */
253 unget_char (st_parameter_dt
*dtp
, char c
)
255 dtp
->u
.p
.last_char
= c
;
259 /* Skip over spaces in the input. Returns the nonspace character that
260 terminated the eating and also places it back on the input. */
263 eat_spaces (st_parameter_dt
*dtp
)
271 while (c
== ' ' || c
== '\t');
278 /* Skip over a separator. Technically, we don't always eat the whole
279 separator. This is because if we've processed the last input item,
280 then a separator is unnecessary. Plus the fact that operating
281 systems usually deliver console input on a line basis.
283 The upshot is that if we see a newline as part of reading a
284 separator, we stop reading. If there are more input items, we
285 continue reading the separator with finish_separator() which takes
286 care of the fact that we may or may not have seen a comma as part
290 eat_separator (st_parameter_dt
*dtp
)
295 dtp
->u
.p
.comma_flag
= 0;
301 dtp
->u
.p
.comma_flag
= 1;
306 dtp
->u
.p
.input_complete
= 1;
322 if (dtp
->u
.p
.namelist_mode
)
323 { /* Eat a namelist comment. */
331 /* Fall Through... */
340 /* Finish processing a separator that was interrupted by a newline.
341 If we're here, then another data item is present, so we finish what
342 we started on the previous line. */
345 finish_separator (st_parameter_dt
*dtp
)
356 if (dtp
->u
.p
.comma_flag
)
360 c
= eat_spaces (dtp
);
361 if (c
== '\n' || c
== '\r')
368 dtp
->u
.p
.input_complete
= 1;
369 if (!dtp
->u
.p
.namelist_mode
)
378 if (dtp
->u
.p
.namelist_mode
)
394 /* This function reads characters through to the end of the current line and
395 just ignores them. */
398 eat_line (st_parameter_dt
*dtp
)
401 if (!is_internal_unit (dtp
))
408 /* This function is needed to catch bad conversions so that namelist can
409 attempt to see if dtp->u.p.saved_string contains a new object name rather
413 nml_bad_return (st_parameter_dt
*dtp
, char c
)
415 if (dtp
->u
.p
.namelist_mode
)
417 dtp
->u
.p
.nml_read_error
= 1;
424 /* Convert an unsigned string to an integer. The length value is -1
425 if we are working on a repeat count. Returns nonzero if we have a
426 range problem. As a side effect, frees the dtp->u.p.saved_string. */
429 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
431 char c
, *buffer
, message
[100];
433 GFC_INTEGER_LARGEST v
, max
, max10
;
435 buffer
= dtp
->u
.p
.saved_string
;
438 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
463 set_integer (dtp
->u
.p
.value
, v
, length
);
467 dtp
->u
.p
.repeat_count
= v
;
469 if (dtp
->u
.p
.repeat_count
== 0)
471 sprintf (message
, "Zero repeat count in item %d of list input",
472 dtp
->u
.p
.item_count
);
474 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
484 sprintf (message
, "Repeat count overflow in item %d of list input",
485 dtp
->u
.p
.item_count
);
487 sprintf (message
, "Integer overflow while reading item %d",
488 dtp
->u
.p
.item_count
);
491 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
497 /* Parse a repeat count for logical and complex values which cannot
498 begin with a digit. Returns nonzero if we are done, zero if we
499 should continue on. */
502 parse_repeat (st_parameter_dt
*dtp
)
504 char c
, message
[100];
530 repeat
= 10 * repeat
+ c
- '0';
532 if (repeat
> MAX_REPEAT
)
535 "Repeat count overflow in item %d of list input",
536 dtp
->u
.p
.item_count
);
538 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
548 "Zero repeat count in item %d of list input",
549 dtp
->u
.p
.item_count
);
551 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
563 dtp
->u
.p
.repeat_count
= repeat
;
570 sprintf (message
, "Bad repeat count in item %d of list input",
571 dtp
->u
.p
.item_count
);
572 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
577 /* To read a logical we have to look ahead in the input stream to make sure
578 there is not an equal sign indicating a variable name. To do this we use
579 line_buffer to point to a temporary buffer, pushing characters there for
580 possible later reading. */
583 l_push_char (st_parameter_dt
*dtp
, char c
)
585 if (dtp
->u
.p
.line_buffer
== NULL
)
587 dtp
->u
.p
.line_buffer
= get_mem (SCRATCH_SIZE
);
588 memset (dtp
->u
.p
.line_buffer
, 0, SCRATCH_SIZE
);
591 dtp
->u
.p
.line_buffer
[dtp
->u
.p
.item_count
++] = c
;
595 /* Read a logical character on the input. */
598 read_logical (st_parameter_dt
*dtp
, int length
)
600 char c
, message
[100];
603 if (parse_repeat (dtp
))
606 c
= tolower (next_char (dtp
));
607 l_push_char (dtp
, c
);
613 l_push_char (dtp
, c
);
615 if (!is_separator(c
))
623 l_push_char (dtp
, c
);
625 if (!is_separator(c
))
631 c
= tolower (next_char (dtp
));
649 return; /* Null value. */
655 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
656 dtp
->u
.p
.saved_length
= length
;
658 /* Eat trailing garbage. */
663 while (!is_separator (c
));
667 dtp
->u
.p
.item_count
= 0;
668 dtp
->u
.p
.line_buffer_enabled
= 0;
669 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
676 for(i
= 0; i
< 63; i
++)
681 /* All done if this is not a namelist read. */
682 if (!dtp
->u
.p
.namelist_mode
)
695 l_push_char (dtp
, c
);
698 dtp
->u
.p
.nml_read_error
= 1;
699 dtp
->u
.p
.line_buffer_enabled
= 1;
700 dtp
->u
.p
.item_count
= 0;
710 if (nml_bad_return (dtp
, c
))
715 sprintf (message
, "Bad logical value while reading item %d",
716 dtp
->u
.p
.item_count
);
717 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
722 dtp
->u
.p
.item_count
= 0;
723 dtp
->u
.p
.line_buffer_enabled
= 0;
724 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
725 dtp
->u
.p
.saved_length
= length
;
726 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
732 /* Reading integers is tricky because we can actually be reading a
733 repeat count. We have to store the characters in a buffer because
734 we could be reading an integer that is larger than the default int
735 used for repeat counts. */
738 read_integer (st_parameter_dt
*dtp
, int length
)
740 char c
, message
[100];
750 /* Fall through... */
756 CASE_SEPARATORS
: /* Single null. */
769 /* Take care of what may be a repeat count. */
781 push_char (dtp
, '\0');
784 CASE_SEPARATORS
: /* Not a repeat count. */
793 if (convert_integer (dtp
, -1, 0))
796 /* Get the real integer. */
811 /* Fall through... */
842 if (nml_bad_return (dtp
, c
))
847 sprintf (message
, "Bad integer for item %d in list input",
848 dtp
->u
.p
.item_count
);
849 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
857 push_char (dtp
, '\0');
858 if (convert_integer (dtp
, length
, negative
))
865 dtp
->u
.p
.saved_type
= BT_INTEGER
;
869 /* Read a character variable. */
872 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
874 char c
, quote
, message
[100];
876 quote
= ' '; /* Space means no quote character. */
886 unget_char (dtp
, c
); /* NULL value. */
896 if (dtp
->u
.p
.namelist_mode
)
898 if (dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_APOSTROPHE
899 || dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_QUOTE
)
905 /* Check to see if we are seeing a namelist object name by using the
906 line buffer and looking ahead for an '=' or '('. */
907 l_push_char (dtp
, c
);
910 for(i
= 0; i
< 63; i
++)
920 l_push_char (dtp
, c
);
921 dtp
->u
.p
.item_count
= 0;
922 dtp
->u
.p
.line_buffer_enabled
= 1;
927 l_push_char (dtp
, c
);
928 if (c
== '=' || c
== '(')
930 dtp
->u
.p
.item_count
= 0;
931 dtp
->u
.p
.nml_read_error
= 1;
932 dtp
->u
.p
.line_buffer_enabled
= 1;
937 /* The string is too long to be a valid object name so assume that it
938 is a string to be read in as a value. */
939 dtp
->u
.p
.line_buffer_enabled
= 1;
947 /* Deal with a possible repeat count. */
960 goto done
; /* String was only digits! */
963 push_char (dtp
, '\0');
968 goto get_string
; /* Not a repeat count after all. */
973 if (convert_integer (dtp
, -1, 0))
976 /* Now get the real string. */
982 unget_char (dtp
, c
); /* Repeated NULL values. */
1010 /* See if we have a doubled quote character or the end of
1013 c
= next_char (dtp
);
1016 push_char (dtp
, quote
);
1020 unget_char (dtp
, c
);
1026 unget_char (dtp
, c
);
1030 if (c
!= '\n' && c
!= '\r')
1040 /* At this point, we have to have a separator, or else the string is
1043 c
= next_char (dtp
);
1044 if (is_separator (c
))
1046 unget_char (dtp
, c
);
1047 eat_separator (dtp
);
1048 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
1054 sprintf (message
, "Invalid string input in item %d",
1055 dtp
->u
.p
.item_count
);
1056 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1061 /* Parse a component of a complex constant or a real number that we
1062 are sure is already there. This is a straight real number parser. */
1065 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
1067 char c
, message
[100];
1070 c
= next_char (dtp
);
1071 if (c
== '-' || c
== '+')
1074 c
= next_char (dtp
);
1077 if (!isdigit (c
) && c
!= '.')
1082 seen_dp
= (c
== '.') ? 1 : 0;
1086 c
= next_char (dtp
);
1105 push_char (dtp
, 'e');
1110 push_char (dtp
, 'e');
1112 c
= next_char (dtp
);
1116 unget_char (dtp
, c
);
1125 c
= next_char (dtp
);
1126 if (c
!= '-' && c
!= '+')
1127 push_char (dtp
, '+');
1131 c
= next_char (dtp
);
1141 c
= next_char (dtp
);
1149 unget_char (dtp
, c
);
1158 unget_char (dtp
, c
);
1159 push_char (dtp
, '\0');
1161 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
1168 if (nml_bad_return (dtp
, c
))
1173 sprintf (message
, "Bad floating point number for item %d",
1174 dtp
->u
.p
.item_count
);
1175 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1181 /* Reading a complex number is straightforward because we can tell
1182 what it is right away. */
1185 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1190 if (parse_repeat (dtp
))
1193 c
= next_char (dtp
);
1200 unget_char (dtp
, c
);
1201 eat_separator (dtp
);
1209 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1214 c
= next_char (dtp
);
1215 if (c
== '\n' || c
== '\r')
1218 unget_char (dtp
, c
);
1220 if (next_char (dtp
) != ',')
1225 c
= next_char (dtp
);
1226 if (c
== '\n' || c
== '\r')
1229 unget_char (dtp
, c
);
1231 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1235 if (next_char (dtp
) != ')')
1238 c
= next_char (dtp
);
1239 if (!is_separator (c
))
1242 unget_char (dtp
, c
);
1243 eat_separator (dtp
);
1246 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1251 if (nml_bad_return (dtp
, c
))
1256 sprintf (message
, "Bad complex value in item %d of list input",
1257 dtp
->u
.p
.item_count
);
1258 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1262 /* Parse a real number with a possible repeat count. */
1265 read_real (st_parameter_dt
*dtp
, int length
)
1267 char c
, message
[100];
1272 c
= next_char (dtp
);
1289 unget_char (dtp
, c
); /* Single null. */
1290 eat_separator (dtp
);
1297 /* Get the digit string that might be a repeat count. */
1301 c
= next_char (dtp
);
1324 push_char (dtp
, 'e');
1326 c
= next_char (dtp
);
1330 push_char (dtp
, '\0');
1334 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1335 unget_char (dtp
, c
);
1344 if (convert_integer (dtp
, -1, 0))
1347 /* Now get the number itself. */
1349 c
= next_char (dtp
);
1350 if (is_separator (c
))
1351 { /* Repeated null value. */
1352 unget_char (dtp
, c
);
1353 eat_separator (dtp
);
1357 if (c
!= '-' && c
!= '+')
1358 push_char (dtp
, '+');
1363 c
= next_char (dtp
);
1366 if (!isdigit (c
) && c
!= '.')
1382 c
= next_char (dtp
);
1408 push_char (dtp
, 'e');
1410 c
= next_char (dtp
);
1419 push_char (dtp
, 'e');
1421 c
= next_char (dtp
);
1422 if (c
!= '+' && c
!= '-')
1423 push_char (dtp
, '+');
1427 c
= next_char (dtp
);
1437 c
= next_char (dtp
);
1454 unget_char (dtp
, c
);
1455 eat_separator (dtp
);
1456 push_char (dtp
, '\0');
1457 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1461 dtp
->u
.p
.saved_type
= BT_REAL
;
1466 if (nml_bad_return (dtp
, c
))
1471 sprintf (message
, "Bad real number in item %d of list input",
1472 dtp
->u
.p
.item_count
);
1473 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1477 /* Check the current type against the saved type to make sure they are
1478 compatible. Returns nonzero if incompatible. */
1481 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1485 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1487 sprintf (message
, "Read type %s where %s was expected for item %d",
1488 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1489 dtp
->u
.p
.item_count
);
1491 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1495 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1498 if (dtp
->u
.p
.saved_length
!= len
)
1501 "Read kind %d %s where kind %d is required for item %d",
1502 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1503 dtp
->u
.p
.item_count
);
1504 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, message
);
1512 /* Top level data transfer subroutine for list reads. Because we have
1513 to deal with repeat counts, the data item is always saved after
1514 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1515 greater than one, we copy the data item multiple times. */
1518 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1525 dtp
->u
.p
.namelist_mode
= 0;
1527 dtp
->u
.p
.eof_jump
= &eof_jump
;
1528 if (setjmp (eof_jump
))
1530 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
1534 if (dtp
->u
.p
.first_item
)
1536 dtp
->u
.p
.first_item
= 0;
1537 dtp
->u
.p
.input_complete
= 0;
1538 dtp
->u
.p
.repeat_count
= 1;
1539 dtp
->u
.p
.at_eol
= 0;
1541 c
= eat_spaces (dtp
);
1542 if (is_separator (c
))
1544 /* Found a null value. */
1545 eat_separator (dtp
);
1546 dtp
->u
.p
.repeat_count
= 0;
1548 /* eat_separator sets this flag if the separator was a comma. */
1549 if (dtp
->u
.p
.comma_flag
)
1552 /* eat_separator sets this flag if the separator was a \n or \r. */
1553 if (dtp
->u
.p
.at_eol
)
1554 finish_separator (dtp
);
1562 if (dtp
->u
.p
.input_complete
)
1565 if (dtp
->u
.p
.repeat_count
> 0)
1567 if (check_type (dtp
, type
, kind
))
1572 if (dtp
->u
.p
.at_eol
)
1573 finish_separator (dtp
);
1577 /* Trailing spaces prior to end of line. */
1578 if (dtp
->u
.p
.at_eol
)
1579 finish_separator (dtp
);
1582 dtp
->u
.p
.saved_type
= BT_NULL
;
1583 dtp
->u
.p
.repeat_count
= 1;
1589 read_integer (dtp
, kind
);
1592 read_logical (dtp
, kind
);
1595 read_character (dtp
, kind
);
1598 read_real (dtp
, kind
);
1601 read_complex (dtp
, kind
, size
);
1604 internal_error (&dtp
->common
, "Bad type for list read");
1607 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1608 dtp
->u
.p
.saved_length
= size
;
1610 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1614 switch (dtp
->u
.p
.saved_type
)
1620 memcpy (p
, dtp
->u
.p
.value
, size
);
1624 if (dtp
->u
.p
.saved_string
)
1626 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1627 ? (int) size
: dtp
->u
.p
.saved_used
;
1628 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1631 /* Just delimiters encountered, nothing to copy but SPACE. */
1635 memset (((char *) p
) + m
, ' ', size
- m
);
1642 if (--dtp
->u
.p
.repeat_count
<= 0)
1646 dtp
->u
.p
.eof_jump
= NULL
;
1651 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1652 size_t size
, size_t nelems
)
1659 /* Big loop over all the elements. */
1660 for (elem
= 0; elem
< nelems
; elem
++)
1662 dtp
->u
.p
.item_count
++;
1663 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1668 /* Finish a list read. */
1671 finish_list_read (st_parameter_dt
*dtp
)
1677 if (dtp
->u
.p
.at_eol
)
1679 dtp
->u
.p
.at_eol
= 0;
1685 c
= next_char (dtp
);
1692 void namelist_read (st_parameter_dt *dtp)
1694 static void nml_match_name (char *name, int len)
1695 static int nml_query (st_parameter_dt *dtp)
1696 static int nml_get_obj_data (st_parameter_dt *dtp,
1697 namelist_info **prev_nl, char *)
1699 static void nml_untouch_nodes (st_parameter_dt *dtp)
1700 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1702 static int nml_parse_qualifier(descriptor_dimension * ad,
1703 array_loop_spec * ls, int rank, char *)
1704 static void nml_touch_nodes (namelist_info * nl)
1705 static int nml_read_obj (namelist_info *nl, index_type offset,
1706 namelist_info **prev_nl, char *,
1707 index_type clow, index_type chigh)
1711 /* Inputs a rank-dimensional qualifier, which can contain
1712 singlets, doublets, triplets or ':' with the standard meanings. */
1715 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1716 array_loop_spec
*ls
, int rank
, char *parse_err_msg
,
1723 int is_array_section
, is_char
;
1727 is_array_section
= 0;
1728 dtp
->u
.p
.expanded_read
= 0;
1730 /* See if this is a character substring qualifier we are looking for. */
1737 /* The next character in the stream should be the '('. */
1739 c
= next_char (dtp
);
1741 /* Process the qualifier, by dimension and triplet. */
1743 for (dim
=0; dim
< rank
; dim
++ )
1745 for (indx
=0; indx
<3; indx
++)
1751 /* Process a potential sign. */
1752 c
= next_char (dtp
);
1763 unget_char (dtp
, c
);
1767 /* Process characters up to the next ':' , ',' or ')'. */
1770 c
= next_char (dtp
);
1775 is_array_section
= 1;
1779 if ((c
==',' && dim
== rank
-1)
1780 || (c
==')' && dim
< rank
-1))
1783 sprintf (parse_err_msg
, "Bad substring qualifier");
1785 sprintf (parse_err_msg
, "Bad number of index fields");
1794 case ' ': case '\t':
1796 c
= next_char (dtp
);
1801 sprintf (parse_err_msg
,
1802 "Bad character in substring qualifier");
1804 sprintf (parse_err_msg
, "Bad character in index");
1808 if ((c
== ',' || c
== ')') && indx
== 0
1809 && dtp
->u
.p
.saved_string
== 0)
1812 sprintf (parse_err_msg
, "Null substring qualifier");
1814 sprintf (parse_err_msg
, "Null index field");
1818 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1819 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1822 sprintf (parse_err_msg
, "Bad substring qualifier");
1824 sprintf (parse_err_msg
, "Bad index triplet");
1828 if (is_char
&& !is_array_section
)
1830 sprintf (parse_err_msg
,
1831 "Missing colon in substring qualifier");
1835 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1837 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1838 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
1844 /* Now read the index. */
1845 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
1848 sprintf (parse_err_msg
, "Bad integer substring qualifier");
1850 sprintf (parse_err_msg
, "Bad integer in index");
1856 /* Feed the index values to the triplet arrays. */
1860 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1862 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1864 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1867 /* Singlet or doublet indices. */
1868 if (c
==',' || c
==')')
1872 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1874 /* If -std=f95/2003 or an array section is specified,
1875 do not allow excess data to be processed. */
1876 if (is_array_section
== 1
1877 || compile_options
.allow_std
< GFC_STD_GNU
)
1878 ls
[dim
].end
= ls
[dim
].start
;
1880 dtp
->u
.p
.expanded_read
= 1;
1883 /* Check for non-zero rank. */
1884 if (is_array_section
== 1 && ls
[dim
].start
!= ls
[dim
].end
)
1891 /* Check the values of the triplet indices. */
1892 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1893 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1894 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1895 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1898 sprintf (parse_err_msg
, "Substring out of range");
1900 sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1904 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1905 || (ls
[dim
].step
== 0))
1907 sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1911 /* Initialise the loop index counter. */
1912 ls
[dim
].idx
= ls
[dim
].start
;
1922 static namelist_info
*
1923 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
1925 namelist_info
* t
= dtp
->u
.p
.ionml
;
1928 if (strcmp (var_name
, t
->var_name
) == 0)
1938 /* Visits all the components of a derived type that have
1939 not explicitly been identified in the namelist input.
1940 touched is set and the loop specification initialised
1941 to default values */
1944 nml_touch_nodes (namelist_info
* nl
)
1946 index_type len
= strlen (nl
->var_name
) + 1;
1948 char * ext_name
= (char*)get_mem (len
+ 1);
1949 memcpy (ext_name
, nl
->var_name
, len
-1);
1950 memcpy (ext_name
+ len
- 1, "%", 2);
1951 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1953 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1956 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1958 nl
->ls
[dim
].step
= 1;
1959 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1960 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1961 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1967 free_mem (ext_name
);
1971 /* Resets touched for the entire list of nml_nodes, ready for a
1975 nml_untouch_nodes (st_parameter_dt
*dtp
)
1978 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
1983 /* Attempts to input name to namelist name. Returns
1984 dtp->u.p.nml_read_error = 1 on no match. */
1987 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
1991 dtp
->u
.p
.nml_read_error
= 0;
1992 for (i
= 0; i
< len
; i
++)
1994 c
= next_char (dtp
);
1995 if (tolower (c
) != tolower (name
[i
]))
1997 dtp
->u
.p
.nml_read_error
= 1;
2003 /* If the namelist read is from stdin, output the current state of the
2004 namelist to stdout. This is used to implement the non-standard query
2005 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
2006 the names alone are printed. */
2009 nml_query (st_parameter_dt
*dtp
, char c
)
2011 gfc_unit
* temp_unit
;
2016 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2019 /* Store the current unit and transfer to stdout. */
2021 temp_unit
= dtp
->u
.p
.current_unit
;
2022 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
2024 if (dtp
->u
.p
.current_unit
)
2026 dtp
->u
.p
.mode
= WRITING
;
2027 next_record (dtp
, 0);
2029 /* Write the namelist in its entirety. */
2032 namelist_write (dtp
);
2034 /* Or write the list of names. */
2038 /* "&namelist_name\n" */
2040 len
= dtp
->namelist_name_len
;
2042 p
= write_block (dtp
, len
+ 3);
2044 p
= write_block (dtp
, len
+ 2);
2049 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
2051 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2053 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2055 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
2059 len
= strlen (nl
->var_name
);
2061 p
= write_block (dtp
, len
+ 3);
2063 p
= write_block (dtp
, len
+ 2);
2068 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
2070 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
2072 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
2079 p
= write_block (dtp
, 6);
2081 p
= write_block (dtp
, 5);
2086 memcpy (p
, "&end\r\n", 6);
2088 memcpy (p
, "&end\n", 5);
2092 /* Flush the stream to force immediate output. */
2094 flush (dtp
->u
.p
.current_unit
->s
);
2095 unlock_unit (dtp
->u
.p
.current_unit
);
2100 /* Restore the current unit. */
2102 dtp
->u
.p
.current_unit
= temp_unit
;
2103 dtp
->u
.p
.mode
= READING
;
2107 /* Reads and stores the input for the namelist object nl. For an array,
2108 the function loops over the ranges defined by the loop specification.
2109 This default to all the data or to the specification from a qualifier.
2110 nml_read_obj recursively calls itself to read derived types. It visits
2111 all its own components but only reads data for those that were touched
2112 when the name was parsed. If a read error is encountered, an attempt is
2113 made to return to read a new object name because the standard allows too
2114 little data to be available. On the other hand, too much data is an
2118 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
2119 namelist_info
**pprev_nl
, char *nml_err_msg
,
2120 index_type clow
, index_type chigh
)
2122 namelist_info
* cmp
;
2129 index_type obj_name_len
;
2132 /* This object not touched in name parsing. */
2137 dtp
->u
.p
.repeat_count
= 0;
2143 case GFC_DTYPE_INTEGER
:
2144 case GFC_DTYPE_LOGICAL
:
2148 case GFC_DTYPE_REAL
:
2149 dlen
= size_from_real_kind (len
);
2152 case GFC_DTYPE_COMPLEX
:
2153 dlen
= size_from_complex_kind (len
);
2156 case GFC_DTYPE_CHARACTER
:
2157 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
2166 /* Update the pointer to the data, using the current index vector */
2168 pdata
= (void*)(nl
->mem_pos
+ offset
);
2169 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2170 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
2171 nl
->dim
[dim
].stride
* nl
->size
);
2173 /* Reset the error flag and try to read next value, if
2174 dtp->u.p.repeat_count=0 */
2176 dtp
->u
.p
.nml_read_error
= 0;
2178 if (--dtp
->u
.p
.repeat_count
<= 0)
2180 if (dtp
->u
.p
.input_complete
)
2182 if (dtp
->u
.p
.at_eol
)
2183 finish_separator (dtp
);
2184 if (dtp
->u
.p
.input_complete
)
2187 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2188 after the switch block. */
2190 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
2195 case GFC_DTYPE_INTEGER
:
2196 read_integer (dtp
, len
);
2199 case GFC_DTYPE_LOGICAL
:
2200 read_logical (dtp
, len
);
2203 case GFC_DTYPE_CHARACTER
:
2204 read_character (dtp
, len
);
2207 case GFC_DTYPE_REAL
:
2208 read_real (dtp
, len
);
2211 case GFC_DTYPE_COMPLEX
:
2212 read_complex (dtp
, len
, dlen
);
2215 case GFC_DTYPE_DERIVED
:
2216 obj_name_len
= strlen (nl
->var_name
) + 1;
2217 obj_name
= get_mem (obj_name_len
+1);
2218 memcpy (obj_name
, nl
->var_name
, obj_name_len
-1);
2219 memcpy (obj_name
+ obj_name_len
- 1, "%", 2);
2221 /* If reading a derived type, disable the expanded read warning
2222 since a single object can have multiple reads. */
2223 dtp
->u
.p
.expanded_read
= 0;
2225 /* Now loop over the components. Update the component pointer
2226 with the return value from nml_write_obj. This loop jumps
2227 past nested derived types by testing if the potential
2228 component name contains '%'. */
2230 for (cmp
= nl
->next
;
2232 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
2233 !strchr (cmp
->var_name
+ obj_name_len
, '%');
2237 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
2238 pprev_nl
, nml_err_msg
, clow
, chigh
)
2241 free_mem (obj_name
);
2245 if (dtp
->u
.p
.input_complete
)
2247 free_mem (obj_name
);
2252 free_mem (obj_name
);
2256 sprintf (nml_err_msg
, "Bad type for namelist object %s",
2258 internal_error (&dtp
->common
, nml_err_msg
);
2263 /* The standard permits array data to stop short of the number of
2264 elements specified in the loop specification. In this case, we
2265 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2266 nml_get_obj_data and an attempt is made to read object name. */
2269 if (dtp
->u
.p
.nml_read_error
)
2271 dtp
->u
.p
.expanded_read
= 0;
2275 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2277 dtp
->u
.p
.expanded_read
= 0;
2281 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2282 This comes about because the read functions return BT_types. */
2284 switch (dtp
->u
.p
.saved_type
)
2291 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2295 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2296 pdata
= (void*)( pdata
+ clow
- 1 );
2297 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2299 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2306 /* Warn if a non-standard expanded read occurs. A single read of a
2307 single object is acceptable. If a second read occurs, issue a warning
2308 and set the flag to zero to prevent further warnings. */
2309 if (dtp
->u
.p
.expanded_read
== 2)
2311 notify_std (&dtp
->common
, GFC_STD_GNU
, "Non-standard expanded namelist read.");
2312 dtp
->u
.p
.expanded_read
= 0;
2315 /* If the expanded read warning flag is set, increment it,
2316 indicating that a single read has occurred. */
2317 if (dtp
->u
.p
.expanded_read
>= 1)
2318 dtp
->u
.p
.expanded_read
++;
2320 /* Break out of loop if scalar. */
2324 /* Now increment the index vector. */
2329 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2331 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2333 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2335 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2337 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2341 } while (!nml_carry
);
2343 if (dtp
->u
.p
.repeat_count
> 1)
2345 sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2356 /* Parses the object name, including array and substring qualifiers. It
2357 iterates over derived type components, touching those components and
2358 setting their loop specifications, if there is a qualifier. If the
2359 object is itself a derived type, its components and subcomponents are
2360 touched. nml_read_obj is called at the end and this reads the data in
2361 the manner specified by the object name. */
2364 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2369 namelist_info
* first_nl
= NULL
;
2370 namelist_info
* root_nl
= NULL
;
2371 int dim
, parsed_rank
;
2373 char parse_err_msg
[30];
2374 index_type clow
, chigh
;
2375 int non_zero_rank_count
;
2377 /* Look for end of input or object name. If '?' or '=?' are encountered
2378 in stdin, print the node names or the namelist to stdout. */
2380 eat_separator (dtp
);
2381 if (dtp
->u
.p
.input_complete
)
2384 if (dtp
->u
.p
.at_eol
)
2385 finish_separator (dtp
);
2386 if (dtp
->u
.p
.input_complete
)
2389 c
= next_char (dtp
);
2393 c
= next_char (dtp
);
2396 sprintf (nml_err_msg
, "namelist read: misplaced = sign");
2399 nml_query (dtp
, '=');
2403 nml_query (dtp
, '?');
2408 nml_match_name (dtp
, "end", 3);
2409 if (dtp
->u
.p
.nml_read_error
)
2411 sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2415 dtp
->u
.p
.input_complete
= 1;
2422 /* Untouch all nodes of the namelist and reset the flag that is set for
2423 derived type components. */
2425 nml_untouch_nodes (dtp
);
2427 non_zero_rank_count
= 0;
2429 /* Get the object name - should '!' and '\n' be permitted separators? */
2437 push_char (dtp
, tolower(c
));
2438 c
= next_char (dtp
);
2439 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2441 unget_char (dtp
, c
);
2443 /* Check that the name is in the namelist and get pointer to object.
2444 Three error conditions exist: (i) An attempt is being made to
2445 identify a non-existent object, following a failed data read or
2446 (ii) The object name does not exist or (iii) Too many data items
2447 are present for an object. (iii) gives the same error message
2450 push_char (dtp
, '\0');
2454 size_t var_len
= strlen (root_nl
->var_name
);
2456 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2457 char ext_name
[var_len
+ saved_len
+ 1];
2459 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2460 if (dtp
->u
.p
.saved_string
)
2461 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2462 ext_name
[var_len
+ saved_len
] = '\0';
2463 nl
= find_nml_node (dtp
, ext_name
);
2466 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2470 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2471 sprintf (nml_err_msg
, "Bad data for namelist object %s",
2472 (*pprev_nl
)->var_name
);
2475 sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2476 dtp
->u
.p
.saved_string
);
2481 /* Get the length, data length, base pointer and rank of the variable.
2482 Set the default loop specification first. */
2484 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2486 nl
->ls
[dim
].step
= 1;
2487 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2488 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2489 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2492 /* Check to see if there is a qualifier: if so, parse it.*/
2494 if (c
== '(' && nl
->var_rank
)
2497 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2498 parse_err_msg
, &parsed_rank
) == FAILURE
)
2500 sprintf (nml_err_msg
, "%s for namelist variable %s",
2501 parse_err_msg
, nl
->var_name
);
2505 if (parsed_rank
> 0)
2506 non_zero_rank_count
++;
2508 c
= next_char (dtp
);
2509 unget_char (dtp
, c
);
2511 else if (nl
->var_rank
> 0)
2512 non_zero_rank_count
++;
2514 /* Now parse a derived type component. The root namelist_info address
2515 is backed up, as is the previous component level. The component flag
2516 is set and the iteration is made by jumping back to get_name. */
2520 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2522 sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2527 if (!component_flag
)
2532 c
= next_char (dtp
);
2536 /* Parse a character qualifier, if present. chigh = 0 is a default
2537 that signals that the string length = string_length. */
2542 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2544 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2545 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2547 if (nml_parse_qualifier (dtp
, chd
, ind
, -1, parse_err_msg
, &parsed_rank
)
2550 sprintf (nml_err_msg
, "%s for namelist variable %s",
2551 parse_err_msg
, nl
->var_name
);
2555 clow
= ind
[0].start
;
2558 if (ind
[0].step
!= 1)
2560 sprintf (nml_err_msg
,
2561 "Step not allowed in substring qualifier"
2562 " for namelist object %s", nl
->var_name
);
2566 c
= next_char (dtp
);
2567 unget_char (dtp
, c
);
2570 /* If a derived type touch its components and restore the root
2571 namelist_info if we have parsed a qualified derived type
2574 if (nl
->type
== GFC_DTYPE_DERIVED
)
2575 nml_touch_nodes (nl
);
2579 /* Make sure no extraneous qualifiers are there. */
2583 sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2584 " namelist object %s", nl
->var_name
);
2588 /* Make sure there is no more than one non-zero rank object. */
2589 if (non_zero_rank_count
> 1)
2591 sprintf (nml_err_msg
, "Multiple sub-objects with non-zero rank in"
2592 " namelist object %s", nl
->var_name
);
2593 non_zero_rank_count
= 0;
2597 /* According to the standard, an equal sign MUST follow an object name. The
2598 following is possibly lax - it allows comments, blank lines and so on to
2599 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2603 eat_separator (dtp
);
2604 if (dtp
->u
.p
.input_complete
)
2607 if (dtp
->u
.p
.at_eol
)
2608 finish_separator (dtp
);
2609 if (dtp
->u
.p
.input_complete
)
2612 c
= next_char (dtp
);
2616 sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2621 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2631 /* Entry point for namelist input. Goes through input until namelist name
2632 is matched. Then cycles through nml_get_obj_data until the input is
2633 completed or there is an error. */
2636 namelist_read (st_parameter_dt
*dtp
)
2640 char nml_err_msg
[100];
2641 /* Pointer to the previously read object, in case attempt is made to read
2642 new object name. Should this fail, error message can give previous
2644 namelist_info
*prev_nl
= NULL
;
2646 dtp
->u
.p
.namelist_mode
= 1;
2647 dtp
->u
.p
.input_complete
= 0;
2648 dtp
->u
.p
.expanded_read
= 0;
2650 dtp
->u
.p
.eof_jump
= &eof_jump
;
2651 if (setjmp (eof_jump
))
2653 dtp
->u
.p
.eof_jump
= NULL
;
2654 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2658 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2659 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2660 node names or namelist on stdout. */
2663 switch (c
= next_char (dtp
))
2674 c
= next_char (dtp
);
2676 nml_query (dtp
, '=');
2678 unget_char (dtp
, c
);
2682 nml_query (dtp
, '?');
2688 /* Match the name of the namelist. */
2690 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2692 if (dtp
->u
.p
.nml_read_error
)
2695 /* A trailing space is required, we give a little lattitude here, 10.9.1. */
2696 c
= next_char (dtp
);
2697 if (!is_separator(c
))
2699 unget_char (dtp
, c
);
2703 /* Ready to read namelist objects. If there is an error in input
2704 from stdin, output the error message and continue. */
2706 while (!dtp
->u
.p
.input_complete
)
2708 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2712 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2715 u
= find_unit (options
.stderr_unit
);
2716 st_printf ("%s\n", nml_err_msg
);
2726 dtp
->u
.p
.eof_jump
= NULL
;
2731 /* All namelist error calls return from here */
2735 dtp
->u
.p
.eof_jump
= NULL
;
2738 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, nml_err_msg
);