1 /* Copyright (C) 2002, 2003, 2004, 2005 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. */
35 #include "libgfortran.h"
39 /* List directed input. Several parsing subroutines are practically
40 reimplemented from formatted input, the reason being that there are
41 all kinds of small differences between formatted and list directed
45 /* Subroutines for reading characters from the input. Because a
46 repeat count is ambiguous with an integer, we have to read the
47 whole digit string before seeing if there is a '*' which signals
48 the repeat count. Since we can have a lot of potential leading
49 zeros, we have to be able to back up by arbitrary amount. Because
50 the input might not be seekable, we have to buffer the data
53 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
54 case '5': case '6': case '7': case '8': case '9'
56 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
59 /* This macro assumes that we're operating on a variable. */
61 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
62 || c == '\t' || c == '\r')
64 /* Maximum repeat count. Less than ten times the maximum signed int32. */
66 #define MAX_REPEAT 200000000
69 /* Save a character to a string buffer, enlarging it as necessary. */
72 push_char (st_parameter_dt
*dtp
, char c
)
76 if (dtp
->u
.p
.saved_string
== NULL
)
78 if (dtp
->u
.p
.scratch
== NULL
)
79 dtp
->u
.p
.scratch
= get_mem (SCRATCH_SIZE
);
80 dtp
->u
.p
.saved_string
= dtp
->u
.p
.scratch
;
81 memset (dtp
->u
.p
.saved_string
, 0, SCRATCH_SIZE
);
82 dtp
->u
.p
.saved_length
= SCRATCH_SIZE
;
83 dtp
->u
.p
.saved_used
= 0;
86 if (dtp
->u
.p
.saved_used
>= dtp
->u
.p
.saved_length
)
88 dtp
->u
.p
.saved_length
= 2 * dtp
->u
.p
.saved_length
;
89 new = get_mem (2 * dtp
->u
.p
.saved_length
);
91 memset (new, 0, 2 * dtp
->u
.p
.saved_length
);
93 memcpy (new, dtp
->u
.p
.saved_string
, dtp
->u
.p
.saved_used
);
94 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
95 free_mem (dtp
->u
.p
.saved_string
);
97 dtp
->u
.p
.saved_string
= new;
100 dtp
->u
.p
.saved_string
[dtp
->u
.p
.saved_used
++] = c
;
104 /* Free the input buffer if necessary. */
107 free_saved (st_parameter_dt
*dtp
)
109 if (dtp
->u
.p
.saved_string
== NULL
)
112 if (dtp
->u
.p
.saved_string
!= dtp
->u
.p
.scratch
)
113 free_mem (dtp
->u
.p
.saved_string
);
115 dtp
->u
.p
.saved_string
= NULL
;
116 dtp
->u
.p
.saved_used
= 0;
121 next_char (st_parameter_dt
*dtp
)
126 if (dtp
->u
.p
.last_char
!= '\0')
129 c
= dtp
->u
.p
.last_char
;
130 dtp
->u
.p
.last_char
= '\0';
136 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
139 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
145 /* For internal files return a newline instead of signalling EOF. */
146 /* ??? This isn't quite right, but we don't handle internal files
147 with multiple records. */
148 if (is_internal_unit (dtp
))
151 longjmp (*dtp
->u
.p
.eof_jump
, 1);
157 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
162 /* Push a character back onto the input. */
165 unget_char (st_parameter_dt
*dtp
, char c
)
167 dtp
->u
.p
.last_char
= c
;
171 /* Skip over spaces in the input. Returns the nonspace character that
172 terminated the eating and also places it back on the input. */
175 eat_spaces (st_parameter_dt
*dtp
)
183 while (c
== ' ' || c
== '\t');
190 /* Skip over a separator. Technically, we don't always eat the whole
191 separator. This is because if we've processed the last input item,
192 then a separator is unnecessary. Plus the fact that operating
193 systems usually deliver console input on a line basis.
195 The upshot is that if we see a newline as part of reading a
196 separator, we stop reading. If there are more input items, we
197 continue reading the separator with finish_separator() which takes
198 care of the fact that we may or may not have seen a comma as part
202 eat_separator (st_parameter_dt
*dtp
)
207 dtp
->u
.p
.comma_flag
= 0;
213 dtp
->u
.p
.comma_flag
= 1;
218 dtp
->u
.p
.input_complete
= 1;
227 if (dtp
->u
.p
.namelist_mode
)
228 { /* Eat a namelist comment. */
236 /* Fall Through... */
245 /* Finish processing a separator that was interrupted by a newline.
246 If we're here, then another data item is present, so we finish what
247 we started on the previous line. */
250 finish_separator (st_parameter_dt
*dtp
)
261 if (dtp
->u
.p
.comma_flag
)
265 c
= eat_spaces (dtp
);
273 dtp
->u
.p
.input_complete
= 1;
274 if (!dtp
->u
.p
.namelist_mode
) next_record (dtp
, 0);
282 if (dtp
->u
.p
.namelist_mode
)
297 /* This function is needed to catch bad conversions so that namelist can
298 attempt to see if dtp->u.p.saved_string contains a new object name rather
302 nml_bad_return (st_parameter_dt
*dtp
, char c
)
304 if (dtp
->u
.p
.namelist_mode
)
306 dtp
->u
.p
.nml_read_error
= 1;
313 /* Convert an unsigned string to an integer. The length value is -1
314 if we are working on a repeat count. Returns nonzero if we have a
315 range problem. As a side effect, frees the dtp->u.p.saved_string. */
318 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
320 char c
, *buffer
, message
[100];
322 GFC_INTEGER_LARGEST v
, max
, max10
;
324 buffer
= dtp
->u
.p
.saved_string
;
327 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
352 set_integer (dtp
->u
.p
.value
, v
, length
);
356 dtp
->u
.p
.repeat_count
= v
;
358 if (dtp
->u
.p
.repeat_count
== 0)
360 st_sprintf (message
, "Zero repeat count in item %d of list input",
361 dtp
->u
.p
.item_count
);
363 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
373 st_sprintf (message
, "Repeat count overflow in item %d of list input",
374 dtp
->u
.p
.item_count
);
376 st_sprintf (message
, "Integer overflow while reading item %d",
377 dtp
->u
.p
.item_count
);
380 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
386 /* Parse a repeat count for logical and complex values which cannot
387 begin with a digit. Returns nonzero if we are done, zero if we
388 should continue on. */
391 parse_repeat (st_parameter_dt
*dtp
)
393 char c
, message
[100];
419 repeat
= 10 * repeat
+ c
- '0';
421 if (repeat
> MAX_REPEAT
)
424 "Repeat count overflow in item %d of list input",
425 dtp
->u
.p
.item_count
);
427 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
437 "Zero repeat count in item %d of list input",
438 dtp
->u
.p
.item_count
);
440 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
452 dtp
->u
.p
.repeat_count
= repeat
;
456 st_sprintf (message
, "Bad repeat count in item %d of list input",
457 dtp
->u
.p
.item_count
);
459 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
464 /* Read a logical character on the input. */
467 read_logical (st_parameter_dt
*dtp
, int length
)
469 char c
, message
[100];
472 if (parse_repeat (dtp
))
508 return; /* Null value. */
514 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
515 dtp
->u
.p
.saved_length
= length
;
517 /* Eat trailing garbage. */
522 while (!is_separator (c
));
527 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
533 if (nml_bad_return (dtp
, c
))
536 st_sprintf (message
, "Bad logical value while reading item %d",
537 dtp
->u
.p
.item_count
);
539 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
543 /* Reading integers is tricky because we can actually be reading a
544 repeat count. We have to store the characters in a buffer because
545 we could be reading an integer that is larger than the default int
546 used for repeat counts. */
549 read_integer (st_parameter_dt
*dtp
, int length
)
551 char c
, message
[100];
561 /* Fall through... */
567 CASE_SEPARATORS
: /* Single null. */
580 /* Take care of what may be a repeat count. */
592 push_char (dtp
, '\0');
595 CASE_SEPARATORS
: /* Not a repeat count. */
604 if (convert_integer (dtp
, -1, 0))
607 /* Get the real integer. */
622 /* Fall through... */
653 if (nml_bad_return (dtp
, c
))
658 st_sprintf (message
, "Bad integer for item %d in list input",
659 dtp
->u
.p
.item_count
);
660 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
668 push_char (dtp
, '\0');
669 if (convert_integer (dtp
, length
, negative
))
676 dtp
->u
.p
.saved_type
= BT_INTEGER
;
680 /* Read a character variable. */
683 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
685 char c
, quote
, message
[100];
687 quote
= ' '; /* Space means no quote character. */
697 unget_char (dtp
, c
); /* NULL value. */
707 if (dtp
->u
.p
.namelist_mode
)
716 /* Deal with a possible repeat count. */
729 goto done
; /* String was only digits! */
732 push_char (dtp
, '\0');
737 goto get_string
; /* Not a repeat count after all. */
742 if (convert_integer (dtp
, -1, 0))
745 /* Now get the real string. */
751 unget_char (dtp
, c
); /* Repeated NULL values. */
779 /* See if we have a doubled quote character or the end of
785 push_char (dtp
, quote
);
809 /* At this point, we have to have a separator, or else the string is
813 if (is_separator (c
))
817 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
822 st_sprintf (message
, "Invalid string input in item %d",
823 dtp
->u
.p
.item_count
);
824 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
829 /* Parse a component of a complex constant or a real number that we
830 are sure is already there. This is a straight real number parser. */
833 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
835 char c
, message
[100];
839 if (c
== '-' || c
== '+')
845 if (!isdigit (c
) && c
!= '.')
850 seen_dp
= (c
== '.') ? 1 : 0;
873 push_char (dtp
, 'e');
878 push_char (dtp
, 'e');
894 if (c
!= '-' && c
!= '+')
895 push_char (dtp
, '+');
927 push_char (dtp
, '\0');
929 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
936 st_sprintf (message
, "Bad floating point number for item %d",
937 dtp
->u
.p
.item_count
);
938 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
944 /* Reading a complex number is straightforward because we can tell
945 what it is right away. */
948 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
953 if (parse_repeat (dtp
))
972 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
978 if (c
== '\n' || c
== '\r')
983 if (next_char (dtp
) != ',')
989 if (c
== '\n' || c
== '\r')
994 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
998 if (next_char (dtp
) != ')')
1001 c
= next_char (dtp
);
1002 if (!is_separator (c
))
1005 unget_char (dtp
, c
);
1006 eat_separator (dtp
);
1009 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1014 if (nml_bad_return (dtp
, c
))
1017 st_sprintf (message
, "Bad complex value in item %d of list input",
1018 dtp
->u
.p
.item_count
);
1020 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1024 /* Parse a real number with a possible repeat count. */
1027 read_real (st_parameter_dt
*dtp
, int length
)
1029 char c
, message
[100];
1034 c
= next_char (dtp
);
1051 unget_char (dtp
, c
); /* Single null. */
1052 eat_separator (dtp
);
1059 /* Get the digit string that might be a repeat count. */
1063 c
= next_char (dtp
);
1086 push_char (dtp
, 'e');
1088 c
= next_char (dtp
);
1092 push_char (dtp
, '\0');
1096 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1097 unget_char (dtp
, c
);
1106 if (convert_integer (dtp
, -1, 0))
1109 /* Now get the number itself. */
1111 c
= next_char (dtp
);
1112 if (is_separator (c
))
1113 { /* Repeated null value. */
1114 unget_char (dtp
, c
);
1115 eat_separator (dtp
);
1119 if (c
!= '-' && c
!= '+')
1120 push_char (dtp
, '+');
1125 c
= next_char (dtp
);
1128 if (!isdigit (c
) && c
!= '.')
1144 c
= next_char (dtp
);
1170 push_char (dtp
, 'e');
1172 c
= next_char (dtp
);
1181 push_char (dtp
, 'e');
1183 c
= next_char (dtp
);
1184 if (c
!= '+' && c
!= '-')
1185 push_char (dtp
, '+');
1189 c
= next_char (dtp
);
1199 c
= next_char (dtp
);
1216 unget_char (dtp
, c
);
1217 eat_separator (dtp
);
1218 push_char (dtp
, '\0');
1219 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1223 dtp
->u
.p
.saved_type
= BT_REAL
;
1228 if (nml_bad_return (dtp
, c
))
1231 st_sprintf (message
, "Bad real number in item %d of list input",
1232 dtp
->u
.p
.item_count
);
1234 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1238 /* Check the current type against the saved type to make sure they are
1239 compatible. Returns nonzero if incompatible. */
1242 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1246 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1248 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1249 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1250 dtp
->u
.p
.item_count
);
1252 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1256 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1259 if (dtp
->u
.p
.saved_length
!= len
)
1261 st_sprintf (message
,
1262 "Read kind %d %s where kind %d is required for item %d",
1263 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1264 dtp
->u
.p
.item_count
);
1265 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1273 /* Top level data transfer subroutine for list reads. Because we have
1274 to deal with repeat counts, the data item is always saved after
1275 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1276 greater than one, we copy the data item multiple times. */
1279 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1286 dtp
->u
.p
.namelist_mode
= 0;
1288 dtp
->u
.p
.eof_jump
= &eof_jump
;
1289 if (setjmp (eof_jump
))
1291 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1295 if (dtp
->u
.p
.first_item
)
1297 dtp
->u
.p
.first_item
= 0;
1298 dtp
->u
.p
.input_complete
= 0;
1299 dtp
->u
.p
.repeat_count
= 1;
1300 dtp
->u
.p
.at_eol
= 0;
1302 c
= eat_spaces (dtp
);
1303 if (is_separator (c
))
1304 { /* Found a null value. */
1305 eat_separator (dtp
);
1306 dtp
->u
.p
.repeat_count
= 0;
1307 if (dtp
->u
.p
.at_eol
)
1308 finish_separator (dtp
);
1316 if (dtp
->u
.p
.input_complete
)
1319 if (dtp
->u
.p
.repeat_count
> 0)
1321 if (check_type (dtp
, type
, kind
))
1326 if (dtp
->u
.p
.at_eol
)
1327 finish_separator (dtp
);
1331 /* trailing spaces prior to end of line */
1332 if (dtp
->u
.p
.at_eol
)
1333 finish_separator (dtp
);
1336 dtp
->u
.p
.saved_type
= BT_NULL
;
1337 dtp
->u
.p
.repeat_count
= 1;
1343 read_integer (dtp
, kind
);
1346 read_logical (dtp
, kind
);
1349 read_character (dtp
, kind
);
1352 read_real (dtp
, kind
);
1355 read_complex (dtp
, kind
, size
);
1358 internal_error (&dtp
->common
, "Bad type for list read");
1361 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1362 dtp
->u
.p
.saved_length
= size
;
1364 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1368 switch (dtp
->u
.p
.saved_type
)
1374 memcpy (p
, dtp
->u
.p
.value
, size
);
1378 if (dtp
->u
.p
.saved_string
)
1380 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1381 ? (int) size
: dtp
->u
.p
.saved_used
;
1382 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1385 /* Just delimiters encountered, nothing to copy but SPACE. */
1389 memset (((char *) p
) + m
, ' ', size
- m
);
1396 if (--dtp
->u
.p
.repeat_count
<= 0)
1400 dtp
->u
.p
.eof_jump
= NULL
;
1405 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1406 size_t size
, size_t nelems
)
1413 /* Big loop over all the elements. */
1414 for (elem
= 0; elem
< nelems
; elem
++)
1416 dtp
->u
.p
.item_count
++;
1417 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1422 /* Finish a list read. */
1425 finish_list_read (st_parameter_dt
*dtp
)
1431 if (dtp
->u
.p
.at_eol
)
1433 dtp
->u
.p
.at_eol
= 0;
1439 c
= next_char (dtp
);
1446 void namelist_read (st_parameter_dt *dtp)
1448 static void nml_match_name (char *name, int len)
1449 static int nml_query (st_parameter_dt *dtp)
1450 static int nml_get_obj_data (st_parameter_dt *dtp,
1451 namelist_info **prev_nl, char *)
1453 static void nml_untouch_nodes (st_parameter_dt *dtp)
1454 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1456 static int nml_parse_qualifier(descriptor_dimension * ad,
1457 array_loop_spec * ls, int rank, char *)
1458 static void nml_touch_nodes (namelist_info * nl)
1459 static int nml_read_obj (namelist_info *nl, index_type offset,
1460 namelist_info **prev_nl, char *,
1461 index_type clow, index_type chigh)
1465 /* Inputs a rank-dimensional qualifier, which can contain
1466 singlets, doublets, triplets or ':' with the standard meanings. */
1469 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1470 array_loop_spec
*ls
, int rank
, char *parse_err_msg
)
1478 /* The next character in the stream should be the '('. */
1480 c
= next_char (dtp
);
1482 /* Process the qualifier, by dimension and triplet. */
1484 for (dim
=0; dim
< rank
; dim
++ )
1486 for (indx
=0; indx
<3; indx
++)
1492 /* Process a potential sign. */
1493 c
= next_char (dtp
);
1504 unget_char (dtp
, c
);
1508 /* Process characters up to the next ':' , ',' or ')'. */
1511 c
= next_char (dtp
);
1519 if ((c
==',' && dim
== rank
-1)
1520 || (c
==')' && dim
< rank
-1))
1522 st_sprintf (parse_err_msg
,
1523 "Bad number of index fields");
1532 case ' ': case '\t':
1534 c
= next_char (dtp
);
1538 st_sprintf (parse_err_msg
, "Bad character in index");
1542 if ((c
== ',' || c
== ')') && indx
== 0
1543 && dtp
->u
.p
.saved_string
== 0)
1545 st_sprintf (parse_err_msg
, "Null index field");
1549 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1550 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1552 st_sprintf(parse_err_msg
, "Bad index triplet");
1556 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1558 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1559 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
1565 /* Now read the index. */
1566 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
1568 st_sprintf (parse_err_msg
, "Bad integer in index");
1574 /* Feed the index values to the triplet arrays. */
1578 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1580 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1582 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1585 /* Singlet or doublet indices. */
1586 if (c
==',' || c
==')')
1590 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1591 ls
[dim
].end
= ls
[dim
].start
;
1597 /* Check the values of the triplet indices. */
1598 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1599 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1600 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1601 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1603 st_sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1606 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1607 || (ls
[dim
].step
== 0))
1609 st_sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1613 /* Initialise the loop index counter. */
1614 ls
[dim
].idx
= ls
[dim
].start
;
1624 static namelist_info
*
1625 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
1627 namelist_info
* t
= dtp
->u
.p
.ionml
;
1630 if (strcmp (var_name
, t
->var_name
) == 0)
1640 /* Visits all the components of a derived type that have
1641 not explicitly been identified in the namelist input.
1642 touched is set and the loop specification initialised
1643 to default values */
1646 nml_touch_nodes (namelist_info
* nl
)
1648 index_type len
= strlen (nl
->var_name
) + 1;
1650 char * ext_name
= (char*)get_mem (len
+ 1);
1651 strcpy (ext_name
, nl
->var_name
);
1652 strcat (ext_name
, "%");
1653 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1655 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1658 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1660 nl
->ls
[dim
].step
= 1;
1661 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1662 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1663 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1669 free_mem (ext_name
);
1673 /* Resets touched for the entire list of nml_nodes, ready for a
1677 nml_untouch_nodes (st_parameter_dt
*dtp
)
1680 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
1685 /* Attempts to input name to namelist name. Returns
1686 dtp->u.p.nml_read_error = 1 on no match. */
1689 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
1693 dtp
->u
.p
.nml_read_error
= 0;
1694 for (i
= 0; i
< len
; i
++)
1696 c
= next_char (dtp
);
1697 if (tolower (c
) != tolower (name
[i
]))
1699 dtp
->u
.p
.nml_read_error
= 1;
1705 /* If the namelist read is from stdin, output the current state of the
1706 namelist to stdout. This is used to implement the non-standard query
1707 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1708 the names alone are printed. */
1711 nml_query (st_parameter_dt
*dtp
, char c
)
1713 gfc_unit
* temp_unit
;
1718 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
1721 /* Store the current unit and transfer to stdout. */
1723 temp_unit
= dtp
->u
.p
.current_unit
;
1724 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
1726 if (dtp
->u
.p
.current_unit
)
1728 dtp
->u
.p
.mode
= WRITING
;
1729 next_record (dtp
, 0);
1731 /* Write the namelist in its entirety. */
1734 namelist_write (dtp
);
1736 /* Or write the list of names. */
1741 /* "&namelist_name\n" */
1743 len
= dtp
->namelist_name_len
;
1744 p
= write_block (dtp
, len
+ 2);
1748 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
1749 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1750 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
1755 len
= strlen (nl
->var_name
);
1756 p
= write_block (dtp
, len
+ 2);
1760 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1761 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1766 p
= write_block (dtp
, 5);
1769 memcpy (p
, "&end\n", 5);
1772 /* Flush the stream to force immediate output. */
1774 flush (dtp
->u
.p
.current_unit
->s
);
1775 unlock_unit (dtp
->u
.p
.current_unit
);
1780 /* Restore the current unit. */
1782 dtp
->u
.p
.current_unit
= temp_unit
;
1783 dtp
->u
.p
.mode
= READING
;
1787 /* Reads and stores the input for the namelist object nl. For an array,
1788 the function loops over the ranges defined by the loop specification.
1789 This default to all the data or to the specification from a qualifier.
1790 nml_read_obj recursively calls itself to read derived types. It visits
1791 all its own components but only reads data for those that were touched
1792 when the name was parsed. If a read error is encountered, an attempt is
1793 made to return to read a new object name because the standard allows too
1794 little data to be available. On the other hand, too much data is an
1798 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
1799 namelist_info
**pprev_nl
, char *nml_err_msg
,
1800 index_type clow
, index_type chigh
)
1803 namelist_info
* cmp
;
1810 index_type obj_name_len
;
1813 /* This object not touched in name parsing. */
1818 dtp
->u
.p
.repeat_count
= 0;
1825 case GFC_DTYPE_INTEGER
:
1826 case GFC_DTYPE_LOGICAL
:
1830 case GFC_DTYPE_REAL
:
1831 dlen
= size_from_real_kind (len
);
1834 case GFC_DTYPE_COMPLEX
:
1835 dlen
= size_from_complex_kind (len
);
1838 case GFC_DTYPE_CHARACTER
:
1839 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
1849 /* Update the pointer to the data, using the current index vector */
1851 pdata
= (void*)(nl
->mem_pos
+ offset
);
1852 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
1853 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
1854 nl
->dim
[dim
].stride
* nl
->size
);
1856 /* Reset the error flag and try to read next value, if
1857 dtp->u.p.repeat_count=0 */
1859 dtp
->u
.p
.nml_read_error
= 0;
1861 if (--dtp
->u
.p
.repeat_count
<= 0)
1863 if (dtp
->u
.p
.input_complete
)
1865 if (dtp
->u
.p
.at_eol
)
1866 finish_separator (dtp
);
1867 if (dtp
->u
.p
.input_complete
)
1870 /* GFC_TYPE_UNKNOWN through for nulls and is detected
1871 after the switch block. */
1873 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
1878 case GFC_DTYPE_INTEGER
:
1879 read_integer (dtp
, len
);
1882 case GFC_DTYPE_LOGICAL
:
1883 read_logical (dtp
, len
);
1886 case GFC_DTYPE_CHARACTER
:
1887 read_character (dtp
, len
);
1890 case GFC_DTYPE_REAL
:
1891 read_real (dtp
, len
);
1894 case GFC_DTYPE_COMPLEX
:
1895 read_complex (dtp
, len
, dlen
);
1898 case GFC_DTYPE_DERIVED
:
1899 obj_name_len
= strlen (nl
->var_name
) + 1;
1900 obj_name
= get_mem (obj_name_len
+1);
1901 strcpy (obj_name
, nl
->var_name
);
1902 strcat (obj_name
, "%");
1904 /* Now loop over the components. Update the component pointer
1905 with the return value from nml_write_obj. This loop jumps
1906 past nested derived types by testing if the potential
1907 component name contains '%'. */
1909 for (cmp
= nl
->next
;
1911 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
1912 !strchr (cmp
->var_name
+ obj_name_len
, '%');
1916 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
1917 pprev_nl
, nml_err_msg
, clow
, chigh
)
1920 free_mem (obj_name
);
1924 if (dtp
->u
.p
.input_complete
)
1926 free_mem (obj_name
);
1931 free_mem (obj_name
);
1935 st_sprintf (nml_err_msg
, "Bad type for namelist object %s",
1937 internal_error (&dtp
->common
, nml_err_msg
);
1942 /* The standard permits array data to stop short of the number of
1943 elements specified in the loop specification. In this case, we
1944 should be here with dtp->u.p.nml_read_error != 0. Control returns to
1945 nml_get_obj_data and an attempt is made to read object name. */
1948 if (dtp
->u
.p
.nml_read_error
)
1951 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
1955 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
1956 This comes about because the read functions return BT_types. */
1958 switch (dtp
->u
.p
.saved_type
)
1965 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
1969 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
1970 pdata
= (void*)( pdata
+ clow
- 1 );
1971 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
1973 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
1980 /* Break out of loop if scalar. */
1985 /* Now increment the index vector. */
1990 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
1992 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
1994 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
1996 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
1998 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2002 } while (!nml_carry
);
2004 if (dtp
->u
.p
.repeat_count
> 1)
2006 st_sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2017 /* Parses the object name, including array and substring qualifiers. It
2018 iterates over derived type components, touching those components and
2019 setting their loop specifications, if there is a qualifier. If the
2020 object is itself a derived type, its components and subcomponents are
2021 touched. nml_read_obj is called at the end and this reads the data in
2022 the manner specified by the object name. */
2025 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2030 namelist_info
* first_nl
= NULL
;
2031 namelist_info
* root_nl
= NULL
;
2034 char parse_err_msg
[30];
2035 index_type clow
, chigh
;
2037 /* Look for end of input or object name. If '?' or '=?' are encountered
2038 in stdin, print the node names or the namelist to stdout. */
2040 eat_separator (dtp
);
2041 if (dtp
->u
.p
.input_complete
)
2044 if (dtp
->u
.p
.at_eol
)
2045 finish_separator (dtp
);
2046 if (dtp
->u
.p
.input_complete
)
2049 c
= next_char (dtp
);
2053 c
= next_char (dtp
);
2056 st_sprintf (nml_err_msg
, "namelist read: missplaced = sign");
2059 nml_query (dtp
, '=');
2063 nml_query (dtp
, '?');
2068 nml_match_name (dtp
, "end", 3);
2069 if (dtp
->u
.p
.nml_read_error
)
2071 st_sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2075 dtp
->u
.p
.input_complete
= 1;
2082 /* Untouch all nodes of the namelist and reset the flag that is set for
2083 derived type components. */
2085 nml_untouch_nodes (dtp
);
2088 /* Get the object name - should '!' and '\n' be permitted separators? */
2096 push_char (dtp
, tolower(c
));
2097 c
= next_char (dtp
);
2098 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2100 unget_char (dtp
, c
);
2102 /* Check that the name is in the namelist and get pointer to object.
2103 Three error conditions exist: (i) An attempt is being made to
2104 identify a non-existent object, following a failed data read or
2105 (ii) The object name does not exist or (iii) Too many data items
2106 are present for an object. (iii) gives the same error message
2109 push_char (dtp
, '\0');
2113 size_t var_len
= strlen (root_nl
->var_name
);
2115 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2116 char ext_name
[var_len
+ saved_len
+ 1];
2118 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2119 if (dtp
->u
.p
.saved_string
)
2120 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2121 ext_name
[var_len
+ saved_len
] = '\0';
2122 nl
= find_nml_node (dtp
, ext_name
);
2125 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2129 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2130 st_sprintf (nml_err_msg
, "Bad data for namelist object %s",
2131 (*pprev_nl
)->var_name
);
2134 st_sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2135 dtp
->u
.p
.saved_string
);
2140 /* Get the length, data length, base pointer and rank of the variable.
2141 Set the default loop specification first. */
2143 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2145 nl
->ls
[dim
].step
= 1;
2146 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2147 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2148 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2151 /* Check to see if there is a qualifier: if so, parse it.*/
2153 if (c
== '(' && nl
->var_rank
)
2155 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2156 parse_err_msg
) == FAILURE
)
2158 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2159 parse_err_msg
, nl
->var_name
);
2162 c
= next_char (dtp
);
2163 unget_char (dtp
, c
);
2166 /* Now parse a derived type component. The root namelist_info address
2167 is backed up, as is the previous component level. The component flag
2168 is set and the iteration is made by jumping back to get_name. */
2173 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2175 st_sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2180 if (!component_flag
)
2185 c
= next_char (dtp
);
2190 /* Parse a character qualifier, if present. chigh = 0 is a default
2191 that signals that the string length = string_length. */
2196 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2198 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2199 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2201 if (nml_parse_qualifier (dtp
, chd
, ind
, 1, parse_err_msg
) == FAILURE
)
2203 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2204 parse_err_msg
, nl
->var_name
);
2208 clow
= ind
[0].start
;
2211 if (ind
[0].step
!= 1)
2213 st_sprintf (nml_err_msg
,
2214 "Bad step in substring for namelist object %s",
2219 c
= next_char (dtp
);
2220 unget_char (dtp
, c
);
2223 /* If a derived type touch its components and restore the root
2224 namelist_info if we have parsed a qualified derived type
2227 if (nl
->type
== GFC_DTYPE_DERIVED
)
2228 nml_touch_nodes (nl
);
2232 /*make sure no extraneous qualifiers are there.*/
2236 st_sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2237 " namelist object %s", nl
->var_name
);
2241 /* According to the standard, an equal sign MUST follow an object name. The
2242 following is possibly lax - it allows comments, blank lines and so on to
2243 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2247 eat_separator (dtp
);
2248 if (dtp
->u
.p
.input_complete
)
2251 if (dtp
->u
.p
.at_eol
)
2252 finish_separator (dtp
);
2253 if (dtp
->u
.p
.input_complete
)
2256 c
= next_char (dtp
);
2260 st_sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2265 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2275 /* Entry point for namelist input. Goes through input until namelist name
2276 is matched. Then cycles through nml_get_obj_data until the input is
2277 completed or there is an error. */
2280 namelist_read (st_parameter_dt
*dtp
)
2284 char nml_err_msg
[100];
2285 /* Pointer to the previously read object, in case attempt is made to read
2286 new object name. Should this fail, error message can give previous
2288 namelist_info
*prev_nl
= NULL
;
2290 dtp
->u
.p
.namelist_mode
= 1;
2291 dtp
->u
.p
.input_complete
= 0;
2293 dtp
->u
.p
.eof_jump
= &eof_jump
;
2294 if (setjmp (eof_jump
))
2296 dtp
->u
.p
.eof_jump
= NULL
;
2297 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2301 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2302 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2303 node names or namelist on stdout. */
2306 switch (c
= next_char (dtp
))
2313 c
= next_char (dtp
);
2315 nml_query (dtp
, '=');
2317 unget_char (dtp
, c
);
2321 nml_query (dtp
, '?');
2327 /* Match the name of the namelist. */
2329 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2331 if (dtp
->u
.p
.nml_read_error
)
2334 /* Ready to read namelist objects. If there is an error in input
2335 from stdin, output the error message and continue. */
2337 while (!dtp
->u
.p
.input_complete
)
2339 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2343 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2346 u
= find_unit (options
.stderr_unit
);
2347 st_printf ("%s\n", nml_err_msg
);
2357 dtp
->u
.p
.eof_jump
= NULL
;
2361 /* All namelist error calls return from here */
2365 dtp
->u
.p
.eof_jump
= NULL
;
2367 generate_error (&dtp
->common
, ERROR_READ_VALUE
, nml_err_msg
);