1 /* Copyright (C) 2002, 2003, 2004 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 /* Save a character to a string buffer, enlarging it as necessary. */
79 if (saved_string
== NULL
)
81 saved_string
= scratch
;
82 memset (saved_string
,0,SCRATCH_SIZE
);
83 saved_length
= SCRATCH_SIZE
;
87 if (saved_used
>= saved_length
)
89 saved_length
= 2 * saved_length
;
90 new = get_mem (2 * saved_length
);
92 memset (new,0,2 * saved_length
);
94 memcpy (new, saved_string
, saved_used
);
95 if (saved_string
!= scratch
)
96 free_mem (saved_string
);
101 saved_string
[saved_used
++] = c
;
105 /* Free the input buffer if necessary. */
111 if (saved_string
== NULL
)
114 if (saved_string
!= scratch
)
115 free_mem (saved_string
);
127 if (last_char
!= '\0')
137 p
= salloc_r (current_unit
->s
, &length
);
140 generate_error (ERROR_OS
, NULL
);
146 /* For internal files return a newline instead of signalling EOF. */
147 /* ??? This isn't quite right, but we don't handle internal files
148 with multiple records. */
149 if (is_internal_unit ())
152 longjmp (g
.eof_jump
, 1);
158 at_eol
= (c
== '\n');
163 /* Push a character back onto the input. */
173 /* Skip over spaces in the input. Returns the nonspace character that
174 terminated the eating and also places it back on the input. */
185 while (c
== ' ' || c
== '\t');
192 /* Skip over a separator. Technically, we don't always eat the whole
193 separator. This is because if we've processed the last input item,
194 then a separator is unnecessary. Plus the fact that operating
195 systems usually deliver console input on a line basis.
197 The upshot is that if we see a newline as part of reading a
198 separator, we stop reading. If there are more input items, we
199 continue reading the separator with finish_separator() which takes
200 care of the fact that we may or may not have seen a comma as part
230 { /* Eat a namelist comment. */
238 /* Fall Through... */
247 /* Finish processing a separator that was interrupted by a newline.
248 If we're here, then another data item is present, so we finish what
249 we started on the previous line. */
252 finish_separator (void)
299 /* Convert an unsigned string to an integer. The length value is -1
300 if we are working on a repeat count. Returns nonzero if we have a
301 range problem. As a side effect, frees the saved_string. */
304 convert_integer (int length
, int negative
)
306 char c
, *buffer
, message
[100];
308 int64_t v
, max
, max10
;
310 buffer
= saved_string
;
313 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
338 set_integer (value
, v
, length
);
344 if (repeat_count
== 0)
346 st_sprintf (message
, "Zero repeat count in item %d of list input",
349 generate_error (ERROR_READ_VALUE
, message
);
359 st_sprintf (message
, "Repeat count overflow in item %d of list input",
362 st_sprintf (message
, "Integer overflow while reading item %d",
366 generate_error (ERROR_READ_VALUE
, message
);
372 /* Parse a repeat count for logical and complex values which cannot
373 begin with a digit. Returns nonzero if we are done, zero if we
374 should continue on. */
379 char c
, message
[100];
405 repeat
= 10 * repeat
+ c
- '0';
407 if (repeat
> MAX_REPEAT
)
410 "Repeat count overflow in item %d of list input",
413 generate_error (ERROR_READ_VALUE
, message
);
423 "Zero repeat count in item %d of list input",
426 generate_error (ERROR_READ_VALUE
, message
);
438 repeat_count
= repeat
;
442 st_sprintf (message
, "Bad repeat count in item %d of list input",
445 generate_error (ERROR_READ_VALUE
, message
);
450 /* Read a logical character on the input. */
453 read_logical (int length
)
455 char c
, message
[100];
494 return; /* Null value. */
500 saved_type
= BT_LOGICAL
;
501 saved_length
= length
;
503 /* Eat trailing garbage. */
508 while (!is_separator (c
));
513 set_integer ((int *) value
, v
, length
);
518 st_sprintf (message
, "Bad logical value while reading item %d",
521 generate_error (ERROR_READ_VALUE
, message
);
525 /* Reading integers is tricky because we can actually be reading a
526 repeat count. We have to store the characters in a buffer because
527 we could be reading an integer that is larger than the default int
528 used for repeat counts. */
531 read_integer (int length
)
533 char c
, message
[100];
543 /* Fall through... */
549 CASE_SEPARATORS
: /* Single null. */
562 /* Take care of what may be a repeat count. */
577 CASE_SEPARATORS
: /* Not a repeat count. */
586 if (convert_integer (-1, 0))
589 /* Get the real integer. */
604 /* Fall through... */
636 st_sprintf (message
, "Bad integer for item %d in list input", g
.item_count
);
637 generate_error (ERROR_READ_VALUE
, message
);
646 if (convert_integer (length
, negative
))
653 saved_type
= BT_INTEGER
;
657 /* Read a character variable. */
660 read_character (int length
)
662 char c
, quote
, message
[100];
664 quote
= ' '; /* Space means no quote character. */
674 unget_char (c
); /* NULL value. */
688 /* Deal with a possible repeat count. */
701 goto done
; /* String was only digits! */
709 goto get_string
; /* Not a repeat count after all. */
714 if (convert_integer (-1, 0))
717 /* Now get the real string. */
723 unget_char (c
); /* Repeated NULL values. */
751 /* See if we have a doubled quote character or the end of
781 /* At this point, we have to have a separator, or else the string is
786 if (is_separator (c
))
790 saved_type
= BT_CHARACTER
;
795 st_sprintf (message
, "Invalid string input in item %d", g
.item_count
);
796 generate_error (ERROR_READ_VALUE
, message
);
801 /* Parse a component of a complex constant or a real number that we
802 are sure is already there. This is a straight real number parser. */
805 parse_real (void *buffer
, int length
)
807 char c
, message
[100];
811 if (c
== '-' || c
== '+')
817 if (!isdigit (c
) && c
!= '.')
822 seen_dp
= (c
== '.') ? 1 : 0;
866 if (c
!= '-' && c
!= '+')
901 m
= convert_real (buffer
, saved_string
, length
);
908 st_sprintf (message
, "Bad floating point number for item %d", g
.item_count
);
909 generate_error (ERROR_READ_VALUE
, message
);
915 /* Reading a complex number is straightforward because we can tell
916 what it is right away. */
919 read_complex (int length
)
943 if (parse_real (value
, length
))
947 if (next_char () != ',')
951 if (parse_real (value
+ length
, length
))
955 if (next_char () != ')')
959 if (!is_separator (c
))
966 saved_type
= BT_COMPLEX
;
970 st_sprintf (message
, "Bad complex value in item %d of list input",
973 generate_error (ERROR_READ_VALUE
, message
);
977 /* Parse a real number with a possible repeat count. */
980 read_real (int length
)
982 char c
, message
[100];
1004 unget_char (c
); /* Single null. */
1012 /* Get the digit string that might be a repeat count. */
1050 unget_char (c
); /* Real number that is just a digit-string. */
1059 if (convert_integer (-1, 0))
1062 /* Now get the number itself. */
1065 if (is_separator (c
))
1066 { /* Repeated null value. */
1072 if (c
!= '-' && c
!= '+')
1081 if (!isdigit (c
) && c
!= '.')
1137 if (c
!= '+' && c
!= '-')
1172 if (convert_real (value
, saved_string
, length
))
1176 saved_type
= BT_REAL
;
1180 st_sprintf (message
, "Bad real number in item %d of list input",
1183 generate_error (ERROR_READ_VALUE
, message
);
1187 /* Check the current type against the saved type to make sure they are
1188 compatible. Returns nonzero if incompatible. */
1191 check_type (bt type
, int len
)
1195 if (saved_type
!= BT_NULL
&& saved_type
!= type
)
1197 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1198 type_name (saved_type
), type_name (type
), g
.item_count
);
1200 generate_error (ERROR_READ_VALUE
, message
);
1204 if (saved_type
== BT_NULL
|| saved_type
== BT_CHARACTER
)
1207 if (saved_length
!= len
)
1209 st_sprintf (message
,
1210 "Read kind %d %s where kind %d is required for item %d",
1211 saved_length
, type_name (saved_type
), len
, g
.item_count
);
1212 generate_error (ERROR_READ_VALUE
, message
);
1220 /* Top level data transfer subroutine for list reads. Because we have
1221 to deal with repeat counts, the data item is always saved after
1222 reading, usually in the value[] array. If a repeat count is
1223 greater than one, we copy the data item multiple times. */
1226 list_formatted_read (bt type
, void *p
, int len
)
1233 if (setjmp (g
.eof_jump
))
1235 generate_error (ERROR_END
, NULL
);
1247 if (is_separator (c
))
1248 { /* Found a null value. */
1252 finish_separator ();
1263 if (repeat_count
> 0)
1265 if (check_type (type
, len
))
1271 finish_separator ();
1275 /* trailing spaces prior to end of line */
1277 finish_separator ();
1280 saved_type
= BT_NULL
;
1294 read_character (len
);
1303 internal_error ("Bad type for list read");
1306 if (saved_type
!= BT_CHARACTER
&& saved_type
!= BT_NULL
)
1309 if (ioparm
.library_return
!= LIBRARY_OK
)
1322 memcpy (p
, value
, len
);
1328 m
= (len
< saved_used
) ? len
: saved_used
;
1329 memcpy (p
, saved_string
, m
);
1332 /* Just delimiters encountered, nothing to copy but SPACE. */
1336 memset (((char *) p
) + m
, ' ', len
- m
);
1343 if (--repeat_count
<= 0)
1353 /* Finish a list read. */
1356 finish_list_read (void)
1376 static namelist_info
*
1377 find_nml_node (char * var_name
)
1379 namelist_info
* t
= ionml
;
1382 if (strcmp (var_name
,t
->var_name
) == 0)
1384 t
->value_acquired
= 1;
1393 match_namelist_name (char *name
, int len
)
1397 char * namelist_name
= name
;
1400 /* Match the name of the namelist. */
1402 if (tolower (next_char ()) != tolower (namelist_name
[name_len
++]))
1405 generate_error (ERROR_READ_VALUE
, "Wrong namelist name found");
1409 while (name_len
< len
)
1412 if (tolower (c
) != tolower (namelist_name
[name_len
++]))
1418 /********************************************************************
1420 ********************************************************************/
1422 /* Process a namelist read. This subroutine initializes things,
1423 positions to the first element and
1424 FIXME: was this comment ever complete? */
1427 namelist_read (void)
1430 int name_matched
, next_name
;
1437 if (setjmp (g
.eof_jump
))
1439 generate_error (ERROR_END
, NULL
);
1460 generate_error (ERROR_READ_VALUE
, "Invalid character in namelist");
1464 /* Match the name of the namelist. */
1465 match_namelist_name(ioparm
.namelist_name
, ioparm
.namelist_name_len
);
1467 /* Ready to read namelist elements. */
1468 while (!input_complete
)
1478 match_namelist_name("end",3);
1492 nl
= find_nml_node (saved_string
);
1494 internal_error ("Can not match a namelist variable");
1500 /* skip any blanks or tabs after the = */
1512 read_character (len
);
1521 internal_error ("Bad type for namelist read");
1528 /* Fall through... */
1533 memcpy (p
, value
, len
);
1537 m
= (len
< saved_used
) ? len
: saved_used
;
1538 memcpy (p
, saved_string
, m
);
1541 memset (((char *) p
) + m
, ' ', len
- m
);
1551 push_char(tolower(c
));