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;
237 if (dtp
->u
.p
.namelist_mode
)
238 { /* Eat a namelist comment. */
246 /* Fall Through... */
255 /* Finish processing a separator that was interrupted by a newline.
256 If we're here, then another data item is present, so we finish what
257 we started on the previous line. */
260 finish_separator (st_parameter_dt
*dtp
)
271 if (dtp
->u
.p
.comma_flag
)
275 c
= eat_spaces (dtp
);
276 if (c
== '\n' || c
== '\r')
283 dtp
->u
.p
.input_complete
= 1;
284 if (!dtp
->u
.p
.namelist_mode
) next_record (dtp
, 0);
292 if (dtp
->u
.p
.namelist_mode
)
307 /* This function is needed to catch bad conversions so that namelist can
308 attempt to see if dtp->u.p.saved_string contains a new object name rather
312 nml_bad_return (st_parameter_dt
*dtp
, char c
)
314 if (dtp
->u
.p
.namelist_mode
)
316 dtp
->u
.p
.nml_read_error
= 1;
323 /* Convert an unsigned string to an integer. The length value is -1
324 if we are working on a repeat count. Returns nonzero if we have a
325 range problem. As a side effect, frees the dtp->u.p.saved_string. */
328 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
330 char c
, *buffer
, message
[100];
332 GFC_INTEGER_LARGEST v
, max
, max10
;
334 buffer
= dtp
->u
.p
.saved_string
;
337 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
362 set_integer (dtp
->u
.p
.value
, v
, length
);
366 dtp
->u
.p
.repeat_count
= v
;
368 if (dtp
->u
.p
.repeat_count
== 0)
370 st_sprintf (message
, "Zero repeat count in item %d of list input",
371 dtp
->u
.p
.item_count
);
373 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
383 st_sprintf (message
, "Repeat count overflow in item %d of list input",
384 dtp
->u
.p
.item_count
);
386 st_sprintf (message
, "Integer overflow while reading item %d",
387 dtp
->u
.p
.item_count
);
390 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
396 /* Parse a repeat count for logical and complex values which cannot
397 begin with a digit. Returns nonzero if we are done, zero if we
398 should continue on. */
401 parse_repeat (st_parameter_dt
*dtp
)
403 char c
, message
[100];
429 repeat
= 10 * repeat
+ c
- '0';
431 if (repeat
> MAX_REPEAT
)
434 "Repeat count overflow in item %d of list input",
435 dtp
->u
.p
.item_count
);
437 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
447 "Zero repeat count in item %d of list input",
448 dtp
->u
.p
.item_count
);
450 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
462 dtp
->u
.p
.repeat_count
= repeat
;
466 st_sprintf (message
, "Bad repeat count in item %d of list input",
467 dtp
->u
.p
.item_count
);
469 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
474 /* Read a logical character on the input. */
477 read_logical (st_parameter_dt
*dtp
, int length
)
479 char c
, message
[100];
482 if (parse_repeat (dtp
))
518 return; /* Null value. */
524 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
525 dtp
->u
.p
.saved_length
= length
;
527 /* Eat trailing garbage. */
532 while (!is_separator (c
));
537 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
543 if (nml_bad_return (dtp
, c
))
546 st_sprintf (message
, "Bad logical value while reading item %d",
547 dtp
->u
.p
.item_count
);
549 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
553 /* Reading integers is tricky because we can actually be reading a
554 repeat count. We have to store the characters in a buffer because
555 we could be reading an integer that is larger than the default int
556 used for repeat counts. */
559 read_integer (st_parameter_dt
*dtp
, int length
)
561 char c
, message
[100];
571 /* Fall through... */
577 CASE_SEPARATORS
: /* Single null. */
590 /* Take care of what may be a repeat count. */
602 push_char (dtp
, '\0');
605 CASE_SEPARATORS
: /* Not a repeat count. */
614 if (convert_integer (dtp
, -1, 0))
617 /* Get the real integer. */
632 /* Fall through... */
663 if (nml_bad_return (dtp
, c
))
668 st_sprintf (message
, "Bad integer for item %d in list input",
669 dtp
->u
.p
.item_count
);
670 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
678 push_char (dtp
, '\0');
679 if (convert_integer (dtp
, length
, negative
))
686 dtp
->u
.p
.saved_type
= BT_INTEGER
;
690 /* Read a character variable. */
693 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
695 char c
, quote
, message
[100];
697 quote
= ' '; /* Space means no quote character. */
707 unget_char (dtp
, c
); /* NULL value. */
717 if (dtp
->u
.p
.namelist_mode
)
726 /* Deal with a possible repeat count. */
739 goto done
; /* String was only digits! */
742 push_char (dtp
, '\0');
747 goto get_string
; /* Not a repeat count after all. */
752 if (convert_integer (dtp
, -1, 0))
755 /* Now get the real string. */
761 unget_char (dtp
, c
); /* Repeated NULL values. */
789 /* See if we have a doubled quote character or the end of
795 push_char (dtp
, quote
);
809 if (c
!= '\n' && c
!= '\r')
819 /* At this point, we have to have a separator, or else the string is
823 if (is_separator (c
))
827 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
832 st_sprintf (message
, "Invalid string input in item %d",
833 dtp
->u
.p
.item_count
);
834 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
839 /* Parse a component of a complex constant or a real number that we
840 are sure is already there. This is a straight real number parser. */
843 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
845 char c
, message
[100];
849 if (c
== '-' || c
== '+')
855 if (!isdigit (c
) && c
!= '.')
860 seen_dp
= (c
== '.') ? 1 : 0;
883 push_char (dtp
, 'e');
888 push_char (dtp
, 'e');
904 if (c
!= '-' && c
!= '+')
905 push_char (dtp
, '+');
937 push_char (dtp
, '\0');
939 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
946 st_sprintf (message
, "Bad floating point number for item %d",
947 dtp
->u
.p
.item_count
);
948 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
954 /* Reading a complex number is straightforward because we can tell
955 what it is right away. */
958 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
963 if (parse_repeat (dtp
))
982 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
988 if (c
== '\n' || c
== '\r')
993 if (next_char (dtp
) != ',')
999 if (c
== '\n' || c
== '\r')
1002 unget_char (dtp
, c
);
1004 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1008 if (next_char (dtp
) != ')')
1011 c
= next_char (dtp
);
1012 if (!is_separator (c
))
1015 unget_char (dtp
, c
);
1016 eat_separator (dtp
);
1019 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1024 if (nml_bad_return (dtp
, c
))
1027 st_sprintf (message
, "Bad complex value in item %d of list input",
1028 dtp
->u
.p
.item_count
);
1030 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1034 /* Parse a real number with a possible repeat count. */
1037 read_real (st_parameter_dt
*dtp
, int length
)
1039 char c
, message
[100];
1044 c
= next_char (dtp
);
1061 unget_char (dtp
, c
); /* Single null. */
1062 eat_separator (dtp
);
1069 /* Get the digit string that might be a repeat count. */
1073 c
= next_char (dtp
);
1096 push_char (dtp
, 'e');
1098 c
= next_char (dtp
);
1102 push_char (dtp
, '\0');
1106 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1107 unget_char (dtp
, c
);
1116 if (convert_integer (dtp
, -1, 0))
1119 /* Now get the number itself. */
1121 c
= next_char (dtp
);
1122 if (is_separator (c
))
1123 { /* Repeated null value. */
1124 unget_char (dtp
, c
);
1125 eat_separator (dtp
);
1129 if (c
!= '-' && c
!= '+')
1130 push_char (dtp
, '+');
1135 c
= next_char (dtp
);
1138 if (!isdigit (c
) && c
!= '.')
1154 c
= next_char (dtp
);
1180 push_char (dtp
, 'e');
1182 c
= next_char (dtp
);
1191 push_char (dtp
, 'e');
1193 c
= next_char (dtp
);
1194 if (c
!= '+' && c
!= '-')
1195 push_char (dtp
, '+');
1199 c
= next_char (dtp
);
1209 c
= next_char (dtp
);
1226 unget_char (dtp
, c
);
1227 eat_separator (dtp
);
1228 push_char (dtp
, '\0');
1229 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1233 dtp
->u
.p
.saved_type
= BT_REAL
;
1238 if (nml_bad_return (dtp
, c
))
1241 st_sprintf (message
, "Bad real number in item %d of list input",
1242 dtp
->u
.p
.item_count
);
1244 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1248 /* Check the current type against the saved type to make sure they are
1249 compatible. Returns nonzero if incompatible. */
1252 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1256 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1258 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1259 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1260 dtp
->u
.p
.item_count
);
1262 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1266 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1269 if (dtp
->u
.p
.saved_length
!= len
)
1271 st_sprintf (message
,
1272 "Read kind %d %s where kind %d is required for item %d",
1273 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1274 dtp
->u
.p
.item_count
);
1275 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1283 /* Top level data transfer subroutine for list reads. Because we have
1284 to deal with repeat counts, the data item is always saved after
1285 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1286 greater than one, we copy the data item multiple times. */
1289 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1296 dtp
->u
.p
.namelist_mode
= 0;
1298 dtp
->u
.p
.eof_jump
= &eof_jump
;
1299 if (setjmp (eof_jump
))
1301 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1305 if (dtp
->u
.p
.first_item
)
1307 dtp
->u
.p
.first_item
= 0;
1308 dtp
->u
.p
.input_complete
= 0;
1309 dtp
->u
.p
.repeat_count
= 1;
1310 dtp
->u
.p
.at_eol
= 0;
1312 c
= eat_spaces (dtp
);
1313 if (is_separator (c
))
1314 { /* Found a null value. */
1315 eat_separator (dtp
);
1316 dtp
->u
.p
.repeat_count
= 0;
1317 if (dtp
->u
.p
.at_eol
)
1318 finish_separator (dtp
);
1326 if (dtp
->u
.p
.input_complete
)
1329 if (dtp
->u
.p
.repeat_count
> 0)
1331 if (check_type (dtp
, type
, kind
))
1336 if (dtp
->u
.p
.at_eol
)
1337 finish_separator (dtp
);
1341 /* trailing spaces prior to end of line */
1342 if (dtp
->u
.p
.at_eol
)
1343 finish_separator (dtp
);
1346 dtp
->u
.p
.saved_type
= BT_NULL
;
1347 dtp
->u
.p
.repeat_count
= 1;
1353 read_integer (dtp
, kind
);
1356 read_logical (dtp
, kind
);
1359 read_character (dtp
, kind
);
1362 read_real (dtp
, kind
);
1365 read_complex (dtp
, kind
, size
);
1368 internal_error (&dtp
->common
, "Bad type for list read");
1371 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1372 dtp
->u
.p
.saved_length
= size
;
1374 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1378 switch (dtp
->u
.p
.saved_type
)
1384 memcpy (p
, dtp
->u
.p
.value
, size
);
1388 if (dtp
->u
.p
.saved_string
)
1390 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1391 ? (int) size
: dtp
->u
.p
.saved_used
;
1392 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1395 /* Just delimiters encountered, nothing to copy but SPACE. */
1399 memset (((char *) p
) + m
, ' ', size
- m
);
1406 if (--dtp
->u
.p
.repeat_count
<= 0)
1410 dtp
->u
.p
.eof_jump
= NULL
;
1415 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1416 size_t size
, size_t nelems
)
1423 /* Big loop over all the elements. */
1424 for (elem
= 0; elem
< nelems
; elem
++)
1426 dtp
->u
.p
.item_count
++;
1427 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1432 /* Finish a list read. */
1435 finish_list_read (st_parameter_dt
*dtp
)
1441 if (dtp
->u
.p
.at_eol
)
1443 dtp
->u
.p
.at_eol
= 0;
1449 c
= next_char (dtp
);
1456 void namelist_read (st_parameter_dt *dtp)
1458 static void nml_match_name (char *name, int len)
1459 static int nml_query (st_parameter_dt *dtp)
1460 static int nml_get_obj_data (st_parameter_dt *dtp,
1461 namelist_info **prev_nl, char *)
1463 static void nml_untouch_nodes (st_parameter_dt *dtp)
1464 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1466 static int nml_parse_qualifier(descriptor_dimension * ad,
1467 array_loop_spec * ls, int rank, char *)
1468 static void nml_touch_nodes (namelist_info * nl)
1469 static int nml_read_obj (namelist_info *nl, index_type offset,
1470 namelist_info **prev_nl, char *,
1471 index_type clow, index_type chigh)
1475 /* Inputs a rank-dimensional qualifier, which can contain
1476 singlets, doublets, triplets or ':' with the standard meanings. */
1479 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1480 array_loop_spec
*ls
, int rank
, char *parse_err_msg
)
1488 /* The next character in the stream should be the '('. */
1490 c
= next_char (dtp
);
1492 /* Process the qualifier, by dimension and triplet. */
1494 for (dim
=0; dim
< rank
; dim
++ )
1496 for (indx
=0; indx
<3; indx
++)
1502 /* Process a potential sign. */
1503 c
= next_char (dtp
);
1514 unget_char (dtp
, c
);
1518 /* Process characters up to the next ':' , ',' or ')'. */
1521 c
= next_char (dtp
);
1529 if ((c
==',' && dim
== rank
-1)
1530 || (c
==')' && dim
< rank
-1))
1532 st_sprintf (parse_err_msg
,
1533 "Bad number of index fields");
1542 case ' ': case '\t':
1544 c
= next_char (dtp
);
1548 st_sprintf (parse_err_msg
, "Bad character in index");
1552 if ((c
== ',' || c
== ')') && indx
== 0
1553 && dtp
->u
.p
.saved_string
== 0)
1555 st_sprintf (parse_err_msg
, "Null index field");
1559 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1560 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1562 st_sprintf(parse_err_msg
, "Bad index triplet");
1566 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1568 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1569 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
1575 /* Now read the index. */
1576 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
1578 st_sprintf (parse_err_msg
, "Bad integer in index");
1584 /* Feed the index values to the triplet arrays. */
1588 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1590 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1592 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1595 /* Singlet or doublet indices. */
1596 if (c
==',' || c
==')')
1600 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1601 ls
[dim
].end
= ls
[dim
].start
;
1607 /* Check the values of the triplet indices. */
1608 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1609 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1610 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1611 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1613 st_sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1616 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1617 || (ls
[dim
].step
== 0))
1619 st_sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1623 /* Initialise the loop index counter. */
1624 ls
[dim
].idx
= ls
[dim
].start
;
1634 static namelist_info
*
1635 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
1637 namelist_info
* t
= dtp
->u
.p
.ionml
;
1640 if (strcmp (var_name
, t
->var_name
) == 0)
1650 /* Visits all the components of a derived type that have
1651 not explicitly been identified in the namelist input.
1652 touched is set and the loop specification initialised
1653 to default values */
1656 nml_touch_nodes (namelist_info
* nl
)
1658 index_type len
= strlen (nl
->var_name
) + 1;
1660 char * ext_name
= (char*)get_mem (len
+ 1);
1661 strcpy (ext_name
, nl
->var_name
);
1662 strcat (ext_name
, "%");
1663 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1665 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1668 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1670 nl
->ls
[dim
].step
= 1;
1671 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1672 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1673 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1679 free_mem (ext_name
);
1683 /* Resets touched for the entire list of nml_nodes, ready for a
1687 nml_untouch_nodes (st_parameter_dt
*dtp
)
1690 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
1695 /* Attempts to input name to namelist name. Returns
1696 dtp->u.p.nml_read_error = 1 on no match. */
1699 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
1703 dtp
->u
.p
.nml_read_error
= 0;
1704 for (i
= 0; i
< len
; i
++)
1706 c
= next_char (dtp
);
1707 if (tolower (c
) != tolower (name
[i
]))
1709 dtp
->u
.p
.nml_read_error
= 1;
1715 /* If the namelist read is from stdin, output the current state of the
1716 namelist to stdout. This is used to implement the non-standard query
1717 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1718 the names alone are printed. */
1721 nml_query (st_parameter_dt
*dtp
, char c
)
1723 gfc_unit
* temp_unit
;
1728 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
1731 /* Store the current unit and transfer to stdout. */
1733 temp_unit
= dtp
->u
.p
.current_unit
;
1734 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
1736 if (dtp
->u
.p
.current_unit
)
1738 dtp
->u
.p
.mode
= WRITING
;
1739 next_record (dtp
, 0);
1741 /* Write the namelist in its entirety. */
1744 namelist_write (dtp
);
1746 /* Or write the list of names. */
1751 /* "&namelist_name\n" */
1753 len
= dtp
->namelist_name_len
;
1755 p
= write_block (dtp
, len
+ 3);
1757 p
= write_block (dtp
, len
+ 2);
1762 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
1764 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1766 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1768 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
1773 len
= strlen (nl
->var_name
);
1775 p
= write_block (dtp
, len
+ 3);
1777 p
= write_block (dtp
, len
+ 2);
1782 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1784 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1786 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1793 p
= write_block (dtp
, 6);
1795 p
= write_block (dtp
, 5);
1800 memcpy (p
, "&end\r\n", 6);
1802 memcpy (p
, "&end\n", 5);
1806 /* Flush the stream to force immediate output. */
1808 flush (dtp
->u
.p
.current_unit
->s
);
1809 unlock_unit (dtp
->u
.p
.current_unit
);
1814 /* Restore the current unit. */
1816 dtp
->u
.p
.current_unit
= temp_unit
;
1817 dtp
->u
.p
.mode
= READING
;
1821 /* Reads and stores the input for the namelist object nl. For an array,
1822 the function loops over the ranges defined by the loop specification.
1823 This default to all the data or to the specification from a qualifier.
1824 nml_read_obj recursively calls itself to read derived types. It visits
1825 all its own components but only reads data for those that were touched
1826 when the name was parsed. If a read error is encountered, an attempt is
1827 made to return to read a new object name because the standard allows too
1828 little data to be available. On the other hand, too much data is an
1832 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
1833 namelist_info
**pprev_nl
, char *nml_err_msg
,
1834 index_type clow
, index_type chigh
)
1837 namelist_info
* cmp
;
1844 index_type obj_name_len
;
1847 /* This object not touched in name parsing. */
1852 dtp
->u
.p
.repeat_count
= 0;
1859 case GFC_DTYPE_INTEGER
:
1860 case GFC_DTYPE_LOGICAL
:
1864 case GFC_DTYPE_REAL
:
1865 dlen
= size_from_real_kind (len
);
1868 case GFC_DTYPE_COMPLEX
:
1869 dlen
= size_from_complex_kind (len
);
1872 case GFC_DTYPE_CHARACTER
:
1873 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
1883 /* Update the pointer to the data, using the current index vector */
1885 pdata
= (void*)(nl
->mem_pos
+ offset
);
1886 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
1887 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
1888 nl
->dim
[dim
].stride
* nl
->size
);
1890 /* Reset the error flag and try to read next value, if
1891 dtp->u.p.repeat_count=0 */
1893 dtp
->u
.p
.nml_read_error
= 0;
1895 if (--dtp
->u
.p
.repeat_count
<= 0)
1897 if (dtp
->u
.p
.input_complete
)
1899 if (dtp
->u
.p
.at_eol
)
1900 finish_separator (dtp
);
1901 if (dtp
->u
.p
.input_complete
)
1904 /* GFC_TYPE_UNKNOWN through for nulls and is detected
1905 after the switch block. */
1907 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
1912 case GFC_DTYPE_INTEGER
:
1913 read_integer (dtp
, len
);
1916 case GFC_DTYPE_LOGICAL
:
1917 read_logical (dtp
, len
);
1920 case GFC_DTYPE_CHARACTER
:
1921 read_character (dtp
, len
);
1924 case GFC_DTYPE_REAL
:
1925 read_real (dtp
, len
);
1928 case GFC_DTYPE_COMPLEX
:
1929 read_complex (dtp
, len
, dlen
);
1932 case GFC_DTYPE_DERIVED
:
1933 obj_name_len
= strlen (nl
->var_name
) + 1;
1934 obj_name
= get_mem (obj_name_len
+1);
1935 strcpy (obj_name
, nl
->var_name
);
1936 strcat (obj_name
, "%");
1938 /* Now loop over the components. Update the component pointer
1939 with the return value from nml_write_obj. This loop jumps
1940 past nested derived types by testing if the potential
1941 component name contains '%'. */
1943 for (cmp
= nl
->next
;
1945 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
1946 !strchr (cmp
->var_name
+ obj_name_len
, '%');
1950 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
1951 pprev_nl
, nml_err_msg
, clow
, chigh
)
1954 free_mem (obj_name
);
1958 if (dtp
->u
.p
.input_complete
)
1960 free_mem (obj_name
);
1965 free_mem (obj_name
);
1969 st_sprintf (nml_err_msg
, "Bad type for namelist object %s",
1971 internal_error (&dtp
->common
, nml_err_msg
);
1976 /* The standard permits array data to stop short of the number of
1977 elements specified in the loop specification. In this case, we
1978 should be here with dtp->u.p.nml_read_error != 0. Control returns to
1979 nml_get_obj_data and an attempt is made to read object name. */
1982 if (dtp
->u
.p
.nml_read_error
)
1985 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
1989 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
1990 This comes about because the read functions return BT_types. */
1992 switch (dtp
->u
.p
.saved_type
)
1999 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2003 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2004 pdata
= (void*)( pdata
+ clow
- 1 );
2005 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2007 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2014 /* Break out of loop if scalar. */
2019 /* Now increment the index vector. */
2024 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2026 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2028 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2030 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2032 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2036 } while (!nml_carry
);
2038 if (dtp
->u
.p
.repeat_count
> 1)
2040 st_sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2051 /* Parses the object name, including array and substring qualifiers. It
2052 iterates over derived type components, touching those components and
2053 setting their loop specifications, if there is a qualifier. If the
2054 object is itself a derived type, its components and subcomponents are
2055 touched. nml_read_obj is called at the end and this reads the data in
2056 the manner specified by the object name. */
2059 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2064 namelist_info
* first_nl
= NULL
;
2065 namelist_info
* root_nl
= NULL
;
2068 char parse_err_msg
[30];
2069 index_type clow
, chigh
;
2071 /* Look for end of input or object name. If '?' or '=?' are encountered
2072 in stdin, print the node names or the namelist to stdout. */
2074 eat_separator (dtp
);
2075 if (dtp
->u
.p
.input_complete
)
2078 if (dtp
->u
.p
.at_eol
)
2079 finish_separator (dtp
);
2080 if (dtp
->u
.p
.input_complete
)
2083 c
= next_char (dtp
);
2087 c
= next_char (dtp
);
2090 st_sprintf (nml_err_msg
, "namelist read: missplaced = sign");
2093 nml_query (dtp
, '=');
2097 nml_query (dtp
, '?');
2102 nml_match_name (dtp
, "end", 3);
2103 if (dtp
->u
.p
.nml_read_error
)
2105 st_sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2109 dtp
->u
.p
.input_complete
= 1;
2116 /* Untouch all nodes of the namelist and reset the flag that is set for
2117 derived type components. */
2119 nml_untouch_nodes (dtp
);
2122 /* Get the object name - should '!' and '\n' be permitted separators? */
2130 push_char (dtp
, tolower(c
));
2131 c
= next_char (dtp
);
2132 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2134 unget_char (dtp
, c
);
2136 /* Check that the name is in the namelist and get pointer to object.
2137 Three error conditions exist: (i) An attempt is being made to
2138 identify a non-existent object, following a failed data read or
2139 (ii) The object name does not exist or (iii) Too many data items
2140 are present for an object. (iii) gives the same error message
2143 push_char (dtp
, '\0');
2147 size_t var_len
= strlen (root_nl
->var_name
);
2149 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2150 char ext_name
[var_len
+ saved_len
+ 1];
2152 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2153 if (dtp
->u
.p
.saved_string
)
2154 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2155 ext_name
[var_len
+ saved_len
] = '\0';
2156 nl
= find_nml_node (dtp
, ext_name
);
2159 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2163 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2164 st_sprintf (nml_err_msg
, "Bad data for namelist object %s",
2165 (*pprev_nl
)->var_name
);
2168 st_sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2169 dtp
->u
.p
.saved_string
);
2174 /* Get the length, data length, base pointer and rank of the variable.
2175 Set the default loop specification first. */
2177 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2179 nl
->ls
[dim
].step
= 1;
2180 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2181 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2182 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2185 /* Check to see if there is a qualifier: if so, parse it.*/
2187 if (c
== '(' && nl
->var_rank
)
2189 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2190 parse_err_msg
) == FAILURE
)
2192 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2193 parse_err_msg
, nl
->var_name
);
2196 c
= next_char (dtp
);
2197 unget_char (dtp
, c
);
2200 /* Now parse a derived type component. The root namelist_info address
2201 is backed up, as is the previous component level. The component flag
2202 is set and the iteration is made by jumping back to get_name. */
2207 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2209 st_sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2214 if (!component_flag
)
2219 c
= next_char (dtp
);
2224 /* Parse a character qualifier, if present. chigh = 0 is a default
2225 that signals that the string length = string_length. */
2230 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2232 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2233 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2235 if (nml_parse_qualifier (dtp
, chd
, ind
, 1, parse_err_msg
) == FAILURE
)
2237 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2238 parse_err_msg
, nl
->var_name
);
2242 clow
= ind
[0].start
;
2245 if (ind
[0].step
!= 1)
2247 st_sprintf (nml_err_msg
,
2248 "Bad step in substring for namelist object %s",
2253 c
= next_char (dtp
);
2254 unget_char (dtp
, c
);
2257 /* If a derived type touch its components and restore the root
2258 namelist_info if we have parsed a qualified derived type
2261 if (nl
->type
== GFC_DTYPE_DERIVED
)
2262 nml_touch_nodes (nl
);
2266 /*make sure no extraneous qualifiers are there.*/
2270 st_sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2271 " namelist object %s", nl
->var_name
);
2275 /* According to the standard, an equal sign MUST follow an object name. The
2276 following is possibly lax - it allows comments, blank lines and so on to
2277 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2281 eat_separator (dtp
);
2282 if (dtp
->u
.p
.input_complete
)
2285 if (dtp
->u
.p
.at_eol
)
2286 finish_separator (dtp
);
2287 if (dtp
->u
.p
.input_complete
)
2290 c
= next_char (dtp
);
2294 st_sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2299 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2309 /* Entry point for namelist input. Goes through input until namelist name
2310 is matched. Then cycles through nml_get_obj_data until the input is
2311 completed or there is an error. */
2314 namelist_read (st_parameter_dt
*dtp
)
2318 char nml_err_msg
[100];
2319 /* Pointer to the previously read object, in case attempt is made to read
2320 new object name. Should this fail, error message can give previous
2322 namelist_info
*prev_nl
= NULL
;
2324 dtp
->u
.p
.namelist_mode
= 1;
2325 dtp
->u
.p
.input_complete
= 0;
2327 dtp
->u
.p
.eof_jump
= &eof_jump
;
2328 if (setjmp (eof_jump
))
2330 dtp
->u
.p
.eof_jump
= NULL
;
2331 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2335 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2336 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2337 node names or namelist on stdout. */
2340 switch (c
= next_char (dtp
))
2347 c
= next_char (dtp
);
2349 nml_query (dtp
, '=');
2351 unget_char (dtp
, c
);
2355 nml_query (dtp
, '?');
2361 /* Match the name of the namelist. */
2363 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2365 if (dtp
->u
.p
.nml_read_error
)
2368 /* Ready to read namelist objects. If there is an error in input
2369 from stdin, output the error message and continue. */
2371 while (!dtp
->u
.p
.input_complete
)
2373 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2377 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2380 u
= find_unit (options
.stderr_unit
);
2381 st_printf ("%s\n", nml_err_msg
);
2391 dtp
->u
.p
.eof_jump
= NULL
;
2395 /* All namelist error calls return from here */
2399 dtp
->u
.p
.eof_jump
= NULL
;
2401 generate_error (&dtp
->common
, ERROR_READ_VALUE
, nml_err_msg
);