]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/io/list_read.c
1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
25 #include "libgfortran.h"
29 /* List directed input. Several parsing subroutines are practically
30 * reimplemented from formatted input, the reason being that there are
31 * all kinds of small differences between formatted and list directed
35 /* Subroutines for reading characters from the input. Because a
36 * repeat count is ambiguous with an integer, we have to read the
37 * whole digit string before seeing if there is a '*' which signals
38 * the repeat count. Since we can have a lot of potential leading
39 * zeros, we have to be able to back up by arbitrary amount. Because
40 * the input might not be seekable, we have to buffer the data
41 * ourselves. Data is buffered in scratch[] until it becomes too
42 * large, after which we start allocating memory on the heap. */
44 static int repeat_count
, saved_length
, saved_used
, input_complete
, at_eol
;
45 static int comma_flag
, namelist_mode
;
47 static char last_char
, *saved_string
;
52 /* Storage area for values except for strings. Must be large enough
53 * to hold a complex value (two reals) of the largest kind */
55 static char value
[20];
57 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
58 case '5': case '6': case '7': case '8': case '9'
60 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t'
62 /* This macro assumes that we're operating on a variable */
64 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
67 /* Maximum repeat count. Less than ten times the maximum signed int32. */
69 #define MAX_REPEAT 200000000
72 /* push_char()-- Save a character to a string buffer, enlarging it as
80 if (saved_string
== NULL
)
82 saved_string
= scratch
;
83 memset (saved_string
,0,SCRATCH_SIZE
);
84 saved_length
= SCRATCH_SIZE
;
88 if (saved_used
>= saved_length
)
90 saved_length
= 2 * saved_length
;
91 new = get_mem (2 * saved_length
);
93 memset (new,0,2 * saved_length
);
95 memcpy (new, saved_string
, saved_used
);
96 if (saved_string
!= scratch
)
97 free_mem (saved_string
);
102 saved_string
[saved_used
++] = c
;
106 /* free_saved()-- Free the input buffer if necessary. */
112 if (saved_string
== NULL
)
115 if (saved_string
!= scratch
)
116 free_mem (saved_string
);
128 if (last_char
!= '\0')
138 p
= salloc_r (current_unit
->s
, &length
);
141 generate_error (ERROR_OS
, NULL
);
146 longjmp (g
.eof_jump
, 1);
150 at_eol
= (c
== '\n');
155 /* unget_char()-- Push a character back onto the input */
165 /* eat_spaces()-- Skip over spaces in the input. Returns the nonspace
166 * character that terminated the eating and also places it back on the
178 while (c
== ' ' || c
== '\t');
185 /* eat_separator()-- Skip over a separator. Technically, we don't
186 * always eat the whole separator. This is because if we've processed
187 * the last input item, then a separator is unnecessary. Plus the
188 * fact that operating systems usually deliver console input on a line
191 * The upshot is that if we see a newline as part of reading a
192 * separator, we stop reading. If there are more input items, we
193 * continue reading the separator with finish_separator() which takes
194 * care of the fact that we may or may not have seen a comma as part
195 * of the separator. */
223 { /* Eat a namelist comment */
240 /* finish_separator()-- Finish processing a separator that was
241 * interrupted by a newline. If we're here, then another data item is
242 * present, so we finish what we started on the previous line. */
245 finish_separator (void)
292 /* convert_integer()-- Convert an unsigned string to an integer. The
293 * length value is -1 if we are working on a repeat count. Returns
294 * nonzero if we have a range problem. As a side effect, frees the
298 convert_integer (int length
, int negative
)
300 char c
, *buffer
, message
[100];
302 int64_t v
, max
, max10
;
304 buffer
= saved_string
;
307 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
332 set_integer (value
, v
, length
);
338 if (repeat_count
== 0)
340 st_sprintf (message
, "Zero repeat count in item %d of list input",
343 generate_error (ERROR_READ_VALUE
, message
);
353 st_sprintf (message
, "Repeat count overflow in item %d of list input",
356 st_sprintf (message
, "Integer overflow while reading item %d",
360 generate_error (ERROR_READ_VALUE
, message
);
366 /* parse_repeat()-- Parse a repeat count for logical and complex
367 * values which cannot begin with a digit. Returns nonzero if we are
368 * done, zero if we should continue on. */
373 char c
, message
[100];
399 repeat
= 10 * repeat
+ c
- '0';
401 if (repeat
> MAX_REPEAT
)
404 "Repeat count overflow in item %d of list input",
407 generate_error (ERROR_READ_VALUE
, message
);
417 "Zero repeat count in item %d of list input",
420 generate_error (ERROR_READ_VALUE
, message
);
432 repeat_count
= repeat
;
436 st_sprintf (message
, "Bad repeat count in item %d of list input",
439 generate_error (ERROR_READ_VALUE
, message
);
444 /* read_logical()-- Read a logical character on the input */
447 read_logical (int length
)
449 char c
, message
[100];
488 return; /* Null value */
494 saved_type
= BT_LOGICAL
;
495 saved_length
= length
;
497 /* Eat trailing garbage */
503 while (!is_separator (c
));
508 set_integer ((int *) value
, v
, length
);
513 st_sprintf (message
, "Bad logical value while reading item %d",
516 generate_error (ERROR_READ_VALUE
, message
);
520 /* read_integer()-- Reading integers is tricky because we can actually
521 * be reading a repeat count. We have to store the characters in a
522 * buffer because we could be reading an integer that is larger than the
523 * default int used for repeat counts. */
526 read_integer (int length
)
528 char c
, message
[100];
544 CASE_SEPARATORS
: /* Single null */
557 /* Take care of what may be a repeat count */
572 CASE_SEPARATORS
: /* Not a repeat count */
581 if (convert_integer (-1, 0))
584 /* Get the real integer */
631 st_sprintf (message
, "Bad integer for item %d in list input", g
.item_count
);
632 generate_error (ERROR_READ_VALUE
, message
);
641 if (convert_integer (length
, negative
))
648 saved_type
= BT_INTEGER
;
652 /* read_character()-- Read a character variable */
655 read_character (int length
)
657 char c
, quote
, message
[100];
659 quote
= ' '; /* Space means no quote character */
669 unget_char (c
); /* NULL value */
683 /* Deal with a possible repeat count */
696 goto done
; /* String was only digits! */
704 goto get_string
; /* Not a repeat count after all */
709 if (convert_integer (-1, 0))
712 /* Now get the real string */
718 unget_char (c
); /* repeated NULL values */
746 /* See if we have a doubled quote character or the end of the string */
775 /* At this point, we have to have a separator, or else the string is invalid */
779 if (is_separator (c
))
783 saved_type
= BT_CHARACTER
;
788 st_sprintf (message
, "Invalid string input in item %d", g
.item_count
);
789 generate_error (ERROR_READ_VALUE
, message
);
794 /* parse_real()-- Parse a component of a complex constant or a real
795 * number that we are sure is already there. This is a straight real
799 parse_real (void *buffer
, int length
)
801 char c
, message
[100];
805 if (c
== '-' || c
== '+')
811 if (!isdigit (c
) && c
!= '.')
816 seen_dp
= (c
== '.') ? 1 : 0;
860 if (c
!= '-' && c
!= '+')
895 m
= convert_real (buffer
, saved_string
, length
);
902 st_sprintf (message
, "Bad floating point number for item %d", g
.item_count
);
903 generate_error (ERROR_READ_VALUE
, message
);
909 /* read_complex()-- Reading a complex number is straightforward
910 * because we can tell what it is right away. */
913 read_complex (int length
)
937 if (parse_real (value
, length
))
941 if (next_char () != ',')
945 if (parse_real (value
+ length
, length
))
949 if (next_char () != ')')
953 if (!is_separator (c
))
960 saved_type
= BT_COMPLEX
;
964 st_sprintf (message
, "Bad complex value in item %d of list input",
967 generate_error (ERROR_READ_VALUE
, message
);
971 /* read_real()-- Parse a real number with a possible repeat count. */
974 read_real (int length
)
976 char c
, message
[100];
998 unget_char (c
); /* Single null */
1006 /* Get the digit string that might be a repeat count */
1044 unget_char (c
); /* Real number that is just a digit-string */
1053 if (convert_integer (-1, 0))
1056 /* Now get the number itself */
1059 if (is_separator (c
))
1060 { /* Repeated null value */
1066 if (c
!= '-' && c
!= '+')
1075 if (!isdigit (c
) && c
!= '.')
1131 if (c
!= '+' && c
!= '-')
1166 if (convert_real (value
, saved_string
, length
))
1170 saved_type
= BT_REAL
;
1174 st_sprintf (message
, "Bad real number in item %d of list input",
1177 generate_error (ERROR_READ_VALUE
, message
);
1181 /* check_type()-- Check the current type against the saved type to
1182 * make sure they are compatible. Returns nonzero if incompatible. */
1185 check_type (bt type
, int len
)
1189 if (saved_type
!= BT_NULL
&& saved_type
!= type
)
1191 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1192 type_name (saved_type
), type_name (type
), g
.item_count
);
1194 generate_error (ERROR_READ_VALUE
, message
);
1198 if (saved_type
== BT_NULL
|| saved_type
== BT_CHARACTER
)
1201 if (saved_length
!= len
)
1203 st_sprintf (message
,
1204 "Read kind %d %s where kind %d is required for item %d",
1205 saved_length
, type_name (saved_type
), len
, g
.item_count
);
1206 generate_error (ERROR_READ_VALUE
, message
);
1214 /* list_formatted_read()-- Top level data transfer subroutine for list
1215 * reads. Because we have to deal with repeat counts, the data item
1216 * is always saved after reading, usually in the value[] array. If a
1217 * repeat count is greater than one, we copy the data item multiple
1221 list_formatted_read (bt type
, void *p
, int len
)
1228 if (setjmp (g
.eof_jump
))
1230 generate_error (ERROR_END
, NULL
);
1242 if (is_separator (c
))
1243 { /* Found a null value */
1247 finish_separator ();
1258 if (repeat_count
> 0)
1260 if (check_type (type
, len
))
1266 finish_separator ();
1270 saved_type
= BT_NULL
;
1284 read_character (len
);
1293 internal_error ("Bad type for list read");
1296 if (saved_type
!= BT_CHARACTER
&& saved_type
!= BT_NULL
)
1299 if (ioparm
.library_return
!= LIBRARY_OK
)
1312 memcpy (p
, value
, len
);
1316 m
= (len
< saved_used
) ? len
: saved_used
;
1317 memcpy (p
, saved_string
, m
);
1320 memset (((char *) p
) + m
, ' ', len
- m
);
1327 if (--repeat_count
<= 0)
1337 /* finish_list_read()-- Finish a list read */
1340 finish_list_read (void)
1360 static namelist_info
*
1361 find_nml_node (char * var_name
)
1363 namelist_info
* t
= ionml
;
1366 if (strcmp (var_name
,t
->var_name
) == 0)
1368 t
->value_acquired
= 1;
1377 match_namelist_name (char *name
, int len
)
1381 char * namelist_name
= name
;
1384 /* Match the name of the namelist */
1386 if (tolower (next_char ()) != tolower (namelist_name
[name_len
++]))
1389 generate_error (ERROR_READ_VALUE
, "Wrong namelist name found");
1393 while (name_len
< len
)
1396 if (tolower (c
) != tolower (namelist_name
[name_len
++]))
1402 /********************************************************************
1404 ********************************************************************/
1406 /* namelist_read()-- Process a namelist read. This subroutine
1407 * initializes things, positions to the first element and */
1410 namelist_read (void)
1413 int name_matched
, next_name
;
1420 if (setjmp (g
.eof_jump
))
1422 generate_error (ERROR_END
, NULL
);
1443 generate_error (ERROR_READ_VALUE
, "Invalid character in namelist");
1447 /* Match the name of the namelist */
1448 match_namelist_name(ioparm
.namelist_name
, ioparm
.namelist_name_len
);
1450 /* Ready to read namelist elements */
1457 match_namelist_name("end",3);
1471 nl
= find_nml_node (saved_string
);
1473 internal_error ("Can not found a valid namelist var!");
1487 read_character (len
);
1496 internal_error ("Bad type for namelist read");
1508 memcpy (p
, value
, len
);
1512 m
= (len
< saved_used
) ? len
: saved_used
;
1513 memcpy (p
, saved_string
, m
);
1516 memset (((char *) p
) + m
, ' ', len
- m
);