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
)
127 if (dtp
->u
.p
.last_char
!= '\0')
130 c
= dtp
->u
.p
.last_char
;
131 dtp
->u
.p
.last_char
= '\0';
137 /* Handle the end-of-record condition for internal array unit */
138 if (is_array_io(dtp
) && dtp
->u
.p
.current_unit
->bytes_left
== 0)
141 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
143 /* Check for "end-of-file" condition */
145 longjmp (*dtp
->u
.p
.eof_jump
, 1);
147 record
*= dtp
->u
.p
.current_unit
->recl
;
149 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
150 longjmp (*dtp
->u
.p
.eof_jump
, 1);
152 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
156 /* Get the next character and handle end-of-record conditions */
157 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
159 if (is_internal_unit(dtp
))
161 if (is_array_io(dtp
))
163 /* End of record is handled in the next pass through, above. The
164 check for NULL here is cautionary. */
167 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
171 dtp
->u
.p
.current_unit
->bytes_left
--;
177 longjmp (*dtp
->u
.p
.eof_jump
, 1);
188 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
192 longjmp (*dtp
->u
.p
.eof_jump
, 1);
196 dtp
->u
.p
.at_eol
= (c
== '\n' || c
== '\r');
201 /* Push a character back onto the input. */
204 unget_char (st_parameter_dt
*dtp
, char c
)
206 dtp
->u
.p
.last_char
= c
;
210 /* Skip over spaces in the input. Returns the nonspace character that
211 terminated the eating and also places it back on the input. */
214 eat_spaces (st_parameter_dt
*dtp
)
222 while (c
== ' ' || c
== '\t');
229 /* Skip over a separator. Technically, we don't always eat the whole
230 separator. This is because if we've processed the last input item,
231 then a separator is unnecessary. Plus the fact that operating
232 systems usually deliver console input on a line basis.
234 The upshot is that if we see a newline as part of reading a
235 separator, we stop reading. If there are more input items, we
236 continue reading the separator with finish_separator() which takes
237 care of the fact that we may or may not have seen a comma as part
241 eat_separator (st_parameter_dt
*dtp
)
246 dtp
->u
.p
.comma_flag
= 0;
252 dtp
->u
.p
.comma_flag
= 1;
257 dtp
->u
.p
.input_complete
= 1;
276 if (dtp
->u
.p
.namelist_mode
)
277 { /* Eat a namelist comment. */
285 /* Fall Through... */
294 /* Finish processing a separator that was interrupted by a newline.
295 If we're here, then another data item is present, so we finish what
296 we started on the previous line. */
299 finish_separator (st_parameter_dt
*dtp
)
310 if (dtp
->u
.p
.comma_flag
)
314 c
= eat_spaces (dtp
);
315 if (c
== '\n' || c
== '\r')
322 dtp
->u
.p
.input_complete
= 1;
323 if (!dtp
->u
.p
.namelist_mode
) next_record (dtp
, 0);
331 if (dtp
->u
.p
.namelist_mode
)
346 /* This function is needed to catch bad conversions so that namelist can
347 attempt to see if dtp->u.p.saved_string contains a new object name rather
351 nml_bad_return (st_parameter_dt
*dtp
, char c
)
353 if (dtp
->u
.p
.namelist_mode
)
355 dtp
->u
.p
.nml_read_error
= 1;
362 /* Convert an unsigned string to an integer. The length value is -1
363 if we are working on a repeat count. Returns nonzero if we have a
364 range problem. As a side effect, frees the dtp->u.p.saved_string. */
367 convert_integer (st_parameter_dt
*dtp
, int length
, int negative
)
369 char c
, *buffer
, message
[100];
371 GFC_INTEGER_LARGEST v
, max
, max10
;
373 buffer
= dtp
->u
.p
.saved_string
;
376 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
401 set_integer (dtp
->u
.p
.value
, v
, length
);
405 dtp
->u
.p
.repeat_count
= v
;
407 if (dtp
->u
.p
.repeat_count
== 0)
409 st_sprintf (message
, "Zero repeat count in item %d of list input",
410 dtp
->u
.p
.item_count
);
412 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
422 st_sprintf (message
, "Repeat count overflow in item %d of list input",
423 dtp
->u
.p
.item_count
);
425 st_sprintf (message
, "Integer overflow while reading item %d",
426 dtp
->u
.p
.item_count
);
429 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
435 /* Parse a repeat count for logical and complex values which cannot
436 begin with a digit. Returns nonzero if we are done, zero if we
437 should continue on. */
440 parse_repeat (st_parameter_dt
*dtp
)
442 char c
, message
[100];
468 repeat
= 10 * repeat
+ c
- '0';
470 if (repeat
> MAX_REPEAT
)
473 "Repeat count overflow in item %d of list input",
474 dtp
->u
.p
.item_count
);
476 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
486 "Zero repeat count in item %d of list input",
487 dtp
->u
.p
.item_count
);
489 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
501 dtp
->u
.p
.repeat_count
= repeat
;
505 st_sprintf (message
, "Bad repeat count in item %d of list input",
506 dtp
->u
.p
.item_count
);
508 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
513 /* Read a logical character on the input. */
516 read_logical (st_parameter_dt
*dtp
, int length
)
518 char c
, message
[100];
521 if (parse_repeat (dtp
))
557 return; /* Null value. */
563 dtp
->u
.p
.saved_type
= BT_LOGICAL
;
564 dtp
->u
.p
.saved_length
= length
;
566 /* Eat trailing garbage. */
571 while (!is_separator (c
));
576 set_integer ((int *) dtp
->u
.p
.value
, v
, length
);
582 if (nml_bad_return (dtp
, c
))
585 st_sprintf (message
, "Bad logical value while reading item %d",
586 dtp
->u
.p
.item_count
);
588 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
592 /* Reading integers is tricky because we can actually be reading a
593 repeat count. We have to store the characters in a buffer because
594 we could be reading an integer that is larger than the default int
595 used for repeat counts. */
598 read_integer (st_parameter_dt
*dtp
, int length
)
600 char c
, message
[100];
610 /* Fall through... */
616 CASE_SEPARATORS
: /* Single null. */
629 /* Take care of what may be a repeat count. */
641 push_char (dtp
, '\0');
644 CASE_SEPARATORS
: /* Not a repeat count. */
653 if (convert_integer (dtp
, -1, 0))
656 /* Get the real integer. */
671 /* Fall through... */
702 if (nml_bad_return (dtp
, c
))
707 st_sprintf (message
, "Bad integer for item %d in list input",
708 dtp
->u
.p
.item_count
);
709 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
717 push_char (dtp
, '\0');
718 if (convert_integer (dtp
, length
, negative
))
725 dtp
->u
.p
.saved_type
= BT_INTEGER
;
729 /* Read a character variable. */
732 read_character (st_parameter_dt
*dtp
, int length
__attribute__ ((unused
)))
734 char c
, quote
, message
[100];
736 quote
= ' '; /* Space means no quote character. */
746 unget_char (dtp
, c
); /* NULL value. */
756 if (dtp
->u
.p
.namelist_mode
)
765 /* Deal with a possible repeat count. */
778 goto done
; /* String was only digits! */
781 push_char (dtp
, '\0');
786 goto get_string
; /* Not a repeat count after all. */
791 if (convert_integer (dtp
, -1, 0))
794 /* Now get the real string. */
800 unget_char (dtp
, c
); /* Repeated NULL values. */
828 /* See if we have a doubled quote character or the end of
834 push_char (dtp
, quote
);
848 if (c
!= '\n' && c
!= '\r')
858 /* At this point, we have to have a separator, or else the string is
862 if (is_separator (c
))
866 dtp
->u
.p
.saved_type
= BT_CHARACTER
;
871 st_sprintf (message
, "Invalid string input in item %d",
872 dtp
->u
.p
.item_count
);
873 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
878 /* Parse a component of a complex constant or a real number that we
879 are sure is already there. This is a straight real number parser. */
882 parse_real (st_parameter_dt
*dtp
, void *buffer
, int length
)
884 char c
, message
[100];
888 if (c
== '-' || c
== '+')
894 if (!isdigit (c
) && c
!= '.')
899 seen_dp
= (c
== '.') ? 1 : 0;
922 push_char (dtp
, 'e');
927 push_char (dtp
, 'e');
943 if (c
!= '-' && c
!= '+')
944 push_char (dtp
, '+');
976 push_char (dtp
, '\0');
978 m
= convert_real (dtp
, buffer
, dtp
->u
.p
.saved_string
, length
);
985 st_sprintf (message
, "Bad floating point number for item %d",
986 dtp
->u
.p
.item_count
);
987 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
993 /* Reading a complex number is straightforward because we can tell
994 what it is right away. */
997 read_complex (st_parameter_dt
*dtp
, int kind
, size_t size
)
1002 if (parse_repeat (dtp
))
1005 c
= next_char (dtp
);
1012 unget_char (dtp
, c
);
1013 eat_separator (dtp
);
1021 if (parse_real (dtp
, dtp
->u
.p
.value
, kind
))
1026 c
= next_char (dtp
);
1027 if (c
== '\n' || c
== '\r')
1030 unget_char (dtp
, c
);
1032 if (next_char (dtp
) != ',')
1037 c
= next_char (dtp
);
1038 if (c
== '\n' || c
== '\r')
1041 unget_char (dtp
, c
);
1043 if (parse_real (dtp
, dtp
->u
.p
.value
+ size
/ 2, kind
))
1047 if (next_char (dtp
) != ')')
1050 c
= next_char (dtp
);
1051 if (!is_separator (c
))
1054 unget_char (dtp
, c
);
1055 eat_separator (dtp
);
1058 dtp
->u
.p
.saved_type
= BT_COMPLEX
;
1063 if (nml_bad_return (dtp
, c
))
1066 st_sprintf (message
, "Bad complex value in item %d of list input",
1067 dtp
->u
.p
.item_count
);
1069 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1073 /* Parse a real number with a possible repeat count. */
1076 read_real (st_parameter_dt
*dtp
, int length
)
1078 char c
, message
[100];
1083 c
= next_char (dtp
);
1100 unget_char (dtp
, c
); /* Single null. */
1101 eat_separator (dtp
);
1108 /* Get the digit string that might be a repeat count. */
1112 c
= next_char (dtp
);
1135 push_char (dtp
, 'e');
1137 c
= next_char (dtp
);
1141 push_char (dtp
, '\0');
1145 if (c
!= '\n' && c
!= ',' && c
!= '\r')
1146 unget_char (dtp
, c
);
1155 if (convert_integer (dtp
, -1, 0))
1158 /* Now get the number itself. */
1160 c
= next_char (dtp
);
1161 if (is_separator (c
))
1162 { /* Repeated null value. */
1163 unget_char (dtp
, c
);
1164 eat_separator (dtp
);
1168 if (c
!= '-' && c
!= '+')
1169 push_char (dtp
, '+');
1174 c
= next_char (dtp
);
1177 if (!isdigit (c
) && c
!= '.')
1193 c
= next_char (dtp
);
1219 push_char (dtp
, 'e');
1221 c
= next_char (dtp
);
1230 push_char (dtp
, 'e');
1232 c
= next_char (dtp
);
1233 if (c
!= '+' && c
!= '-')
1234 push_char (dtp
, '+');
1238 c
= next_char (dtp
);
1248 c
= next_char (dtp
);
1265 unget_char (dtp
, c
);
1266 eat_separator (dtp
);
1267 push_char (dtp
, '\0');
1268 if (convert_real (dtp
, dtp
->u
.p
.value
, dtp
->u
.p
.saved_string
, length
))
1272 dtp
->u
.p
.saved_type
= BT_REAL
;
1277 if (nml_bad_return (dtp
, c
))
1280 st_sprintf (message
, "Bad real number in item %d of list input",
1281 dtp
->u
.p
.item_count
);
1283 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1287 /* Check the current type against the saved type to make sure they are
1288 compatible. Returns nonzero if incompatible. */
1291 check_type (st_parameter_dt
*dtp
, bt type
, int len
)
1295 if (dtp
->u
.p
.saved_type
!= BT_NULL
&& dtp
->u
.p
.saved_type
!= type
)
1297 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1298 type_name (dtp
->u
.p
.saved_type
), type_name (type
),
1299 dtp
->u
.p
.item_count
);
1301 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1305 if (dtp
->u
.p
.saved_type
== BT_NULL
|| dtp
->u
.p
.saved_type
== BT_CHARACTER
)
1308 if (dtp
->u
.p
.saved_length
!= len
)
1310 st_sprintf (message
,
1311 "Read kind %d %s where kind %d is required for item %d",
1312 dtp
->u
.p
.saved_length
, type_name (dtp
->u
.p
.saved_type
), len
,
1313 dtp
->u
.p
.item_count
);
1314 generate_error (&dtp
->common
, ERROR_READ_VALUE
, message
);
1322 /* Top level data transfer subroutine for list reads. Because we have
1323 to deal with repeat counts, the data item is always saved after
1324 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1325 greater than one, we copy the data item multiple times. */
1328 list_formatted_read_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1335 dtp
->u
.p
.namelist_mode
= 0;
1337 dtp
->u
.p
.eof_jump
= &eof_jump
;
1338 if (setjmp (eof_jump
))
1340 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1344 if (dtp
->u
.p
.first_item
)
1346 dtp
->u
.p
.first_item
= 0;
1347 dtp
->u
.p
.input_complete
= 0;
1348 dtp
->u
.p
.repeat_count
= 1;
1349 dtp
->u
.p
.at_eol
= 0;
1351 c
= eat_spaces (dtp
);
1352 if (is_separator (c
))
1353 { /* Found a null value. */
1354 eat_separator (dtp
);
1355 dtp
->u
.p
.repeat_count
= 0;
1357 /* eat_separator sets this flag if the separator was a comma */
1358 if (dtp
->u
.p
.comma_flag
)
1361 /* eat_separator sets this flag if the separator was a \n or \r */
1362 if (dtp
->u
.p
.at_eol
)
1363 finish_separator (dtp
);
1371 if (dtp
->u
.p
.input_complete
)
1374 if (dtp
->u
.p
.repeat_count
> 0)
1376 if (check_type (dtp
, type
, kind
))
1381 if (dtp
->u
.p
.at_eol
)
1382 finish_separator (dtp
);
1386 /* trailing spaces prior to end of line */
1387 if (dtp
->u
.p
.at_eol
)
1388 finish_separator (dtp
);
1391 dtp
->u
.p
.saved_type
= BT_NULL
;
1392 dtp
->u
.p
.repeat_count
= 1;
1398 read_integer (dtp
, kind
);
1401 read_logical (dtp
, kind
);
1404 read_character (dtp
, kind
);
1407 read_real (dtp
, kind
);
1410 read_complex (dtp
, kind
, size
);
1413 internal_error (&dtp
->common
, "Bad type for list read");
1416 if (dtp
->u
.p
.saved_type
!= BT_CHARACTER
&& dtp
->u
.p
.saved_type
!= BT_NULL
)
1417 dtp
->u
.p
.saved_length
= size
;
1419 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1423 switch (dtp
->u
.p
.saved_type
)
1429 memcpy (p
, dtp
->u
.p
.value
, size
);
1433 if (dtp
->u
.p
.saved_string
)
1435 m
= ((int) size
< dtp
->u
.p
.saved_used
)
1436 ? (int) size
: dtp
->u
.p
.saved_used
;
1437 memcpy (p
, dtp
->u
.p
.saved_string
, m
);
1440 /* Just delimiters encountered, nothing to copy but SPACE. */
1444 memset (((char *) p
) + m
, ' ', size
- m
);
1451 if (--dtp
->u
.p
.repeat_count
<= 0)
1455 dtp
->u
.p
.eof_jump
= NULL
;
1460 list_formatted_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1461 size_t size
, size_t nelems
)
1468 /* Big loop over all the elements. */
1469 for (elem
= 0; elem
< nelems
; elem
++)
1471 dtp
->u
.p
.item_count
++;
1472 list_formatted_read_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1477 /* Finish a list read. */
1480 finish_list_read (st_parameter_dt
*dtp
)
1486 if (dtp
->u
.p
.at_eol
)
1488 dtp
->u
.p
.at_eol
= 0;
1494 c
= next_char (dtp
);
1501 void namelist_read (st_parameter_dt *dtp)
1503 static void nml_match_name (char *name, int len)
1504 static int nml_query (st_parameter_dt *dtp)
1505 static int nml_get_obj_data (st_parameter_dt *dtp,
1506 namelist_info **prev_nl, char *)
1508 static void nml_untouch_nodes (st_parameter_dt *dtp)
1509 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1511 static int nml_parse_qualifier(descriptor_dimension * ad,
1512 array_loop_spec * ls, int rank, char *)
1513 static void nml_touch_nodes (namelist_info * nl)
1514 static int nml_read_obj (namelist_info *nl, index_type offset,
1515 namelist_info **prev_nl, char *,
1516 index_type clow, index_type chigh)
1520 /* Inputs a rank-dimensional qualifier, which can contain
1521 singlets, doublets, triplets or ':' with the standard meanings. */
1524 nml_parse_qualifier (st_parameter_dt
*dtp
, descriptor_dimension
*ad
,
1525 array_loop_spec
*ls
, int rank
, char *parse_err_msg
)
1533 /* The next character in the stream should be the '('. */
1535 c
= next_char (dtp
);
1537 /* Process the qualifier, by dimension and triplet. */
1539 for (dim
=0; dim
< rank
; dim
++ )
1541 for (indx
=0; indx
<3; indx
++)
1547 /* Process a potential sign. */
1548 c
= next_char (dtp
);
1559 unget_char (dtp
, c
);
1563 /* Process characters up to the next ':' , ',' or ')'. */
1566 c
= next_char (dtp
);
1574 if ((c
==',' && dim
== rank
-1)
1575 || (c
==')' && dim
< rank
-1))
1577 st_sprintf (parse_err_msg
,
1578 "Bad number of index fields");
1587 case ' ': case '\t':
1589 c
= next_char (dtp
);
1593 st_sprintf (parse_err_msg
, "Bad character in index");
1597 if ((c
== ',' || c
== ')') && indx
== 0
1598 && dtp
->u
.p
.saved_string
== 0)
1600 st_sprintf (parse_err_msg
, "Null index field");
1604 if ((c
== ':' && indx
== 1 && dtp
->u
.p
.saved_string
== 0)
1605 || (indx
== 2 && dtp
->u
.p
.saved_string
== 0))
1607 st_sprintf(parse_err_msg
, "Bad index triplet");
1611 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1613 if ((c
== ':' && indx
== 0 && dtp
->u
.p
.saved_string
== 0)
1614 || (indx
==1 && dtp
->u
.p
.saved_string
== 0))
1620 /* Now read the index. */
1621 if (convert_integer (dtp
, sizeof(ssize_t
), neg
))
1623 st_sprintf (parse_err_msg
, "Bad integer in index");
1629 /* Feed the index values to the triplet arrays. */
1633 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1635 memcpy (&ls
[dim
].end
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1637 memcpy (&ls
[dim
].step
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1640 /* Singlet or doublet indices. */
1641 if (c
==',' || c
==')')
1645 memcpy (&ls
[dim
].start
, dtp
->u
.p
.value
, sizeof(ssize_t
));
1646 ls
[dim
].end
= ls
[dim
].start
;
1652 /* Check the values of the triplet indices. */
1653 if ((ls
[dim
].start
> (ssize_t
)ad
[dim
].ubound
)
1654 || (ls
[dim
].start
< (ssize_t
)ad
[dim
].lbound
)
1655 || (ls
[dim
].end
> (ssize_t
)ad
[dim
].ubound
)
1656 || (ls
[dim
].end
< (ssize_t
)ad
[dim
].lbound
))
1658 st_sprintf (parse_err_msg
, "Index %d out of range", dim
+ 1);
1661 if (((ls
[dim
].end
- ls
[dim
].start
) * ls
[dim
].step
< 0)
1662 || (ls
[dim
].step
== 0))
1664 st_sprintf (parse_err_msg
, "Bad range in index %d", dim
+ 1);
1668 /* Initialise the loop index counter. */
1669 ls
[dim
].idx
= ls
[dim
].start
;
1679 static namelist_info
*
1680 find_nml_node (st_parameter_dt
*dtp
, char * var_name
)
1682 namelist_info
* t
= dtp
->u
.p
.ionml
;
1685 if (strcmp (var_name
, t
->var_name
) == 0)
1695 /* Visits all the components of a derived type that have
1696 not explicitly been identified in the namelist input.
1697 touched is set and the loop specification initialised
1698 to default values */
1701 nml_touch_nodes (namelist_info
* nl
)
1703 index_type len
= strlen (nl
->var_name
) + 1;
1705 char * ext_name
= (char*)get_mem (len
+ 1);
1706 strcpy (ext_name
, nl
->var_name
);
1707 strcat (ext_name
, "%");
1708 for (nl
= nl
->next
; nl
; nl
= nl
->next
)
1710 if (strncmp (nl
->var_name
, ext_name
, len
) == 0)
1713 for (dim
=0; dim
< nl
->var_rank
; dim
++)
1715 nl
->ls
[dim
].step
= 1;
1716 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
1717 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
1718 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
1724 free_mem (ext_name
);
1728 /* Resets touched for the entire list of nml_nodes, ready for a
1732 nml_untouch_nodes (st_parameter_dt
*dtp
)
1735 for (t
= dtp
->u
.p
.ionml
; t
; t
= t
->next
)
1740 /* Attempts to input name to namelist name. Returns
1741 dtp->u.p.nml_read_error = 1 on no match. */
1744 nml_match_name (st_parameter_dt
*dtp
, const char *name
, index_type len
)
1748 dtp
->u
.p
.nml_read_error
= 0;
1749 for (i
= 0; i
< len
; i
++)
1751 c
= next_char (dtp
);
1752 if (tolower (c
) != tolower (name
[i
]))
1754 dtp
->u
.p
.nml_read_error
= 1;
1760 /* If the namelist read is from stdin, output the current state of the
1761 namelist to stdout. This is used to implement the non-standard query
1762 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1763 the names alone are printed. */
1766 nml_query (st_parameter_dt
*dtp
, char c
)
1768 gfc_unit
* temp_unit
;
1773 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
1776 /* Store the current unit and transfer to stdout. */
1778 temp_unit
= dtp
->u
.p
.current_unit
;
1779 dtp
->u
.p
.current_unit
= find_unit (options
.stdout_unit
);
1781 if (dtp
->u
.p
.current_unit
)
1783 dtp
->u
.p
.mode
= WRITING
;
1784 next_record (dtp
, 0);
1786 /* Write the namelist in its entirety. */
1789 namelist_write (dtp
);
1791 /* Or write the list of names. */
1796 /* "&namelist_name\n" */
1798 len
= dtp
->namelist_name_len
;
1800 p
= write_block (dtp
, len
+ 3);
1802 p
= write_block (dtp
, len
+ 2);
1807 memcpy ((char*)(p
+ 1), dtp
->namelist_name
, len
);
1809 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1811 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1813 for (nl
= dtp
->u
.p
.ionml
; nl
; nl
= nl
->next
)
1818 len
= strlen (nl
->var_name
);
1820 p
= write_block (dtp
, len
+ 3);
1822 p
= write_block (dtp
, len
+ 2);
1827 memcpy ((char*)(p
+ 1), nl
->var_name
, len
);
1829 memcpy ((char*)(p
+ len
+ 1), "\r\n", 2);
1831 memcpy ((char*)(p
+ len
+ 1), "\n", 1);
1838 p
= write_block (dtp
, 6);
1840 p
= write_block (dtp
, 5);
1845 memcpy (p
, "&end\r\n", 6);
1847 memcpy (p
, "&end\n", 5);
1851 /* Flush the stream to force immediate output. */
1853 flush (dtp
->u
.p
.current_unit
->s
);
1854 unlock_unit (dtp
->u
.p
.current_unit
);
1859 /* Restore the current unit. */
1861 dtp
->u
.p
.current_unit
= temp_unit
;
1862 dtp
->u
.p
.mode
= READING
;
1866 /* Reads and stores the input for the namelist object nl. For an array,
1867 the function loops over the ranges defined by the loop specification.
1868 This default to all the data or to the specification from a qualifier.
1869 nml_read_obj recursively calls itself to read derived types. It visits
1870 all its own components but only reads data for those that were touched
1871 when the name was parsed. If a read error is encountered, an attempt is
1872 made to return to read a new object name because the standard allows too
1873 little data to be available. On the other hand, too much data is an
1877 nml_read_obj (st_parameter_dt
*dtp
, namelist_info
* nl
, index_type offset
,
1878 namelist_info
**pprev_nl
, char *nml_err_msg
,
1879 index_type clow
, index_type chigh
)
1882 namelist_info
* cmp
;
1889 index_type obj_name_len
;
1892 /* This object not touched in name parsing. */
1897 dtp
->u
.p
.repeat_count
= 0;
1904 case GFC_DTYPE_INTEGER
:
1905 case GFC_DTYPE_LOGICAL
:
1909 case GFC_DTYPE_REAL
:
1910 dlen
= size_from_real_kind (len
);
1913 case GFC_DTYPE_COMPLEX
:
1914 dlen
= size_from_complex_kind (len
);
1917 case GFC_DTYPE_CHARACTER
:
1918 dlen
= chigh
? (chigh
- clow
+ 1) : nl
->string_length
;
1928 /* Update the pointer to the data, using the current index vector */
1930 pdata
= (void*)(nl
->mem_pos
+ offset
);
1931 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
1932 pdata
= (void*)(pdata
+ (nl
->ls
[dim
].idx
- nl
->dim
[dim
].lbound
) *
1933 nl
->dim
[dim
].stride
* nl
->size
);
1935 /* Reset the error flag and try to read next value, if
1936 dtp->u.p.repeat_count=0 */
1938 dtp
->u
.p
.nml_read_error
= 0;
1940 if (--dtp
->u
.p
.repeat_count
<= 0)
1942 if (dtp
->u
.p
.input_complete
)
1944 if (dtp
->u
.p
.at_eol
)
1945 finish_separator (dtp
);
1946 if (dtp
->u
.p
.input_complete
)
1949 /* GFC_TYPE_UNKNOWN through for nulls and is detected
1950 after the switch block. */
1952 dtp
->u
.p
.saved_type
= GFC_DTYPE_UNKNOWN
;
1957 case GFC_DTYPE_INTEGER
:
1958 read_integer (dtp
, len
);
1961 case GFC_DTYPE_LOGICAL
:
1962 read_logical (dtp
, len
);
1965 case GFC_DTYPE_CHARACTER
:
1966 read_character (dtp
, len
);
1969 case GFC_DTYPE_REAL
:
1970 read_real (dtp
, len
);
1973 case GFC_DTYPE_COMPLEX
:
1974 read_complex (dtp
, len
, dlen
);
1977 case GFC_DTYPE_DERIVED
:
1978 obj_name_len
= strlen (nl
->var_name
) + 1;
1979 obj_name
= get_mem (obj_name_len
+1);
1980 strcpy (obj_name
, nl
->var_name
);
1981 strcat (obj_name
, "%");
1983 /* Now loop over the components. Update the component pointer
1984 with the return value from nml_write_obj. This loop jumps
1985 past nested derived types by testing if the potential
1986 component name contains '%'. */
1988 for (cmp
= nl
->next
;
1990 !strncmp (cmp
->var_name
, obj_name
, obj_name_len
) &&
1991 !strchr (cmp
->var_name
+ obj_name_len
, '%');
1995 if (nml_read_obj (dtp
, cmp
, (index_type
)(pdata
- nl
->mem_pos
),
1996 pprev_nl
, nml_err_msg
, clow
, chigh
)
1999 free_mem (obj_name
);
2003 if (dtp
->u
.p
.input_complete
)
2005 free_mem (obj_name
);
2010 free_mem (obj_name
);
2014 st_sprintf (nml_err_msg
, "Bad type for namelist object %s",
2016 internal_error (&dtp
->common
, nml_err_msg
);
2021 /* The standard permits array data to stop short of the number of
2022 elements specified in the loop specification. In this case, we
2023 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2024 nml_get_obj_data and an attempt is made to read object name. */
2027 if (dtp
->u
.p
.nml_read_error
)
2030 if (dtp
->u
.p
.saved_type
== GFC_DTYPE_UNKNOWN
)
2034 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2035 This comes about because the read functions return BT_types. */
2037 switch (dtp
->u
.p
.saved_type
)
2044 memcpy (pdata
, dtp
->u
.p
.value
, dlen
);
2048 m
= (dlen
< dtp
->u
.p
.saved_used
) ? dlen
: dtp
->u
.p
.saved_used
;
2049 pdata
= (void*)( pdata
+ clow
- 1 );
2050 memcpy (pdata
, dtp
->u
.p
.saved_string
, m
);
2052 memset ((void*)( pdata
+ m
), ' ', dlen
- m
);
2059 /* Break out of loop if scalar. */
2064 /* Now increment the index vector. */
2069 for (dim
= 0; dim
< nl
->var_rank
; dim
++)
2071 nl
->ls
[dim
].idx
+= nml_carry
* nl
->ls
[dim
].step
;
2073 if (((nl
->ls
[dim
].step
> 0) && (nl
->ls
[dim
].idx
> nl
->ls
[dim
].end
))
2075 ((nl
->ls
[dim
].step
< 0) && (nl
->ls
[dim
].idx
< nl
->ls
[dim
].end
)))
2077 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2081 } while (!nml_carry
);
2083 if (dtp
->u
.p
.repeat_count
> 1)
2085 st_sprintf (nml_err_msg
, "Repeat count too large for namelist object %s" ,
2096 /* Parses the object name, including array and substring qualifiers. It
2097 iterates over derived type components, touching those components and
2098 setting their loop specifications, if there is a qualifier. If the
2099 object is itself a derived type, its components and subcomponents are
2100 touched. nml_read_obj is called at the end and this reads the data in
2101 the manner specified by the object name. */
2104 nml_get_obj_data (st_parameter_dt
*dtp
, namelist_info
**pprev_nl
,
2109 namelist_info
* first_nl
= NULL
;
2110 namelist_info
* root_nl
= NULL
;
2113 char parse_err_msg
[30];
2114 index_type clow
, chigh
;
2116 /* Look for end of input or object name. If '?' or '=?' are encountered
2117 in stdin, print the node names or the namelist to stdout. */
2119 eat_separator (dtp
);
2120 if (dtp
->u
.p
.input_complete
)
2123 if (dtp
->u
.p
.at_eol
)
2124 finish_separator (dtp
);
2125 if (dtp
->u
.p
.input_complete
)
2128 c
= next_char (dtp
);
2132 c
= next_char (dtp
);
2135 st_sprintf (nml_err_msg
, "namelist read: missplaced = sign");
2138 nml_query (dtp
, '=');
2142 nml_query (dtp
, '?');
2147 nml_match_name (dtp
, "end", 3);
2148 if (dtp
->u
.p
.nml_read_error
)
2150 st_sprintf (nml_err_msg
, "namelist not terminated with / or &end");
2154 dtp
->u
.p
.input_complete
= 1;
2161 /* Untouch all nodes of the namelist and reset the flag that is set for
2162 derived type components. */
2164 nml_untouch_nodes (dtp
);
2167 /* Get the object name - should '!' and '\n' be permitted separators? */
2175 push_char (dtp
, tolower(c
));
2176 c
= next_char (dtp
);
2177 } while (!( c
=='=' || c
==' ' || c
=='\t' || c
=='(' || c
=='%' ));
2179 unget_char (dtp
, c
);
2181 /* Check that the name is in the namelist and get pointer to object.
2182 Three error conditions exist: (i) An attempt is being made to
2183 identify a non-existent object, following a failed data read or
2184 (ii) The object name does not exist or (iii) Too many data items
2185 are present for an object. (iii) gives the same error message
2188 push_char (dtp
, '\0');
2192 size_t var_len
= strlen (root_nl
->var_name
);
2194 = dtp
->u
.p
.saved_string
? strlen (dtp
->u
.p
.saved_string
) : 0;
2195 char ext_name
[var_len
+ saved_len
+ 1];
2197 memcpy (ext_name
, root_nl
->var_name
, var_len
);
2198 if (dtp
->u
.p
.saved_string
)
2199 memcpy (ext_name
+ var_len
, dtp
->u
.p
.saved_string
, saved_len
);
2200 ext_name
[var_len
+ saved_len
] = '\0';
2201 nl
= find_nml_node (dtp
, ext_name
);
2204 nl
= find_nml_node (dtp
, dtp
->u
.p
.saved_string
);
2208 if (dtp
->u
.p
.nml_read_error
&& *pprev_nl
)
2209 st_sprintf (nml_err_msg
, "Bad data for namelist object %s",
2210 (*pprev_nl
)->var_name
);
2213 st_sprintf (nml_err_msg
, "Cannot match namelist object name %s",
2214 dtp
->u
.p
.saved_string
);
2219 /* Get the length, data length, base pointer and rank of the variable.
2220 Set the default loop specification first. */
2222 for (dim
=0; dim
< nl
->var_rank
; dim
++)
2224 nl
->ls
[dim
].step
= 1;
2225 nl
->ls
[dim
].end
= nl
->dim
[dim
].ubound
;
2226 nl
->ls
[dim
].start
= nl
->dim
[dim
].lbound
;
2227 nl
->ls
[dim
].idx
= nl
->ls
[dim
].start
;
2230 /* Check to see if there is a qualifier: if so, parse it.*/
2232 if (c
== '(' && nl
->var_rank
)
2234 if (nml_parse_qualifier (dtp
, nl
->dim
, nl
->ls
, nl
->var_rank
,
2235 parse_err_msg
) == FAILURE
)
2237 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2238 parse_err_msg
, nl
->var_name
);
2241 c
= next_char (dtp
);
2242 unget_char (dtp
, c
);
2245 /* Now parse a derived type component. The root namelist_info address
2246 is backed up, as is the previous component level. The component flag
2247 is set and the iteration is made by jumping back to get_name. */
2252 if (nl
->type
!= GFC_DTYPE_DERIVED
)
2254 st_sprintf (nml_err_msg
, "Attempt to get derived component for %s",
2259 if (!component_flag
)
2264 c
= next_char (dtp
);
2269 /* Parse a character qualifier, if present. chigh = 0 is a default
2270 that signals that the string length = string_length. */
2275 if (c
== '(' && nl
->type
== GFC_DTYPE_CHARACTER
)
2277 descriptor_dimension chd
[1] = { {1, clow
, nl
->string_length
} };
2278 array_loop_spec ind
[1] = { {1, clow
, nl
->string_length
, 1} };
2280 if (nml_parse_qualifier (dtp
, chd
, ind
, 1, parse_err_msg
) == FAILURE
)
2282 st_sprintf (nml_err_msg
, "%s for namelist variable %s",
2283 parse_err_msg
, nl
->var_name
);
2287 clow
= ind
[0].start
;
2290 if (ind
[0].step
!= 1)
2292 st_sprintf (nml_err_msg
,
2293 "Bad step in substring for namelist object %s",
2298 c
= next_char (dtp
);
2299 unget_char (dtp
, c
);
2302 /* If a derived type touch its components and restore the root
2303 namelist_info if we have parsed a qualified derived type
2306 if (nl
->type
== GFC_DTYPE_DERIVED
)
2307 nml_touch_nodes (nl
);
2311 /*make sure no extraneous qualifiers are there.*/
2315 st_sprintf (nml_err_msg
, "Qualifier for a scalar or non-character"
2316 " namelist object %s", nl
->var_name
);
2320 /* According to the standard, an equal sign MUST follow an object name. The
2321 following is possibly lax - it allows comments, blank lines and so on to
2322 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2326 eat_separator (dtp
);
2327 if (dtp
->u
.p
.input_complete
)
2330 if (dtp
->u
.p
.at_eol
)
2331 finish_separator (dtp
);
2332 if (dtp
->u
.p
.input_complete
)
2335 c
= next_char (dtp
);
2339 st_sprintf (nml_err_msg
, "Equal sign must follow namelist object name %s",
2344 if (nml_read_obj (dtp
, nl
, 0, pprev_nl
, nml_err_msg
, clow
, chigh
) == FAILURE
)
2354 /* Entry point for namelist input. Goes through input until namelist name
2355 is matched. Then cycles through nml_get_obj_data until the input is
2356 completed or there is an error. */
2359 namelist_read (st_parameter_dt
*dtp
)
2363 char nml_err_msg
[100];
2364 /* Pointer to the previously read object, in case attempt is made to read
2365 new object name. Should this fail, error message can give previous
2367 namelist_info
*prev_nl
= NULL
;
2369 dtp
->u
.p
.namelist_mode
= 1;
2370 dtp
->u
.p
.input_complete
= 0;
2372 dtp
->u
.p
.eof_jump
= &eof_jump
;
2373 if (setjmp (eof_jump
))
2375 dtp
->u
.p
.eof_jump
= NULL
;
2376 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2380 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2381 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2382 node names or namelist on stdout. */
2385 switch (c
= next_char (dtp
))
2392 c
= next_char (dtp
);
2394 nml_query (dtp
, '=');
2396 unget_char (dtp
, c
);
2400 nml_query (dtp
, '?');
2406 /* Match the name of the namelist. */
2408 nml_match_name (dtp
, dtp
->namelist_name
, dtp
->namelist_name_len
);
2410 if (dtp
->u
.p
.nml_read_error
)
2413 /* Ready to read namelist objects. If there is an error in input
2414 from stdin, output the error message and continue. */
2416 while (!dtp
->u
.p
.input_complete
)
2418 if (nml_get_obj_data (dtp
, &prev_nl
, nml_err_msg
) == FAILURE
)
2422 if (dtp
->u
.p
.current_unit
->unit_number
!= options
.stdin_unit
)
2425 u
= find_unit (options
.stderr_unit
);
2426 st_printf ("%s\n", nml_err_msg
);
2436 dtp
->u
.p
.eof_jump
= NULL
;
2440 /* All namelist error calls return from here */
2444 dtp
->u
.p
.eof_jump
= NULL
;
2446 generate_error (&dtp
->common
, ERROR_READ_VALUE
, nml_err_msg
);