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 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 59 Temple Place - Suite 330,
28 Boston, MA 02111-1307, USA. */
34 #include "libgfortran.h"
38 /* List directed input. Several parsing subroutines are practically
39 reimplemented from formatted input, the reason being that there are
40 all kinds of small differences between formatted and list directed
44 /* Subroutines for reading characters from the input. Because a
45 repeat count is ambiguous with an integer, we have to read the
46 whole digit string before seeing if there is a '*' which signals
47 the repeat count. Since we can have a lot of potential leading
48 zeros, we have to be able to back up by arbitrary amount. Because
49 the input might not be seekable, we have to buffer the data
50 ourselves. Data is buffered in scratch[] until it becomes too
51 large, after which we start allocating memory on the heap. */
53 static int repeat_count
, saved_length
, saved_used
, input_complete
, at_eol
;
54 static int comma_flag
, namelist_mode
;
56 static char last_char
, *saved_string
;
61 /* Storage area for values except for strings. Must be large enough
62 to hold a complex value (two reals) of the largest kind. */
64 static char value
[20];
66 #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
67 case '5': case '6': case '7': case '8': case '9'
69 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t'
71 /* This macro assumes that we're operating on a variable. */
73 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
76 /* Maximum repeat count. Less than ten times the maximum signed int32. */
78 #define MAX_REPEAT 200000000
81 /* Save a character to a string buffer, enlarging it as necessary. */
88 if (saved_string
== NULL
)
90 saved_string
= scratch
;
91 memset (saved_string
,0,SCRATCH_SIZE
);
92 saved_length
= SCRATCH_SIZE
;
96 if (saved_used
>= saved_length
)
98 saved_length
= 2 * saved_length
;
99 new = get_mem (2 * saved_length
);
101 memset (new,0,2 * saved_length
);
103 memcpy (new, saved_string
, saved_used
);
104 if (saved_string
!= scratch
)
105 free_mem (saved_string
);
110 saved_string
[saved_used
++] = c
;
114 /* Free the input buffer if necessary. */
119 if (saved_string
== NULL
)
122 if (saved_string
!= scratch
)
123 free_mem (saved_string
);
135 if (last_char
!= '\0')
145 p
= salloc_r (current_unit
->s
, &length
);
148 generate_error (ERROR_OS
, NULL
);
154 /* For internal files return a newline instead of signalling EOF. */
155 /* ??? This isn't quite right, but we don't handle internal files
156 with multiple records. */
157 if (is_internal_unit ())
160 longjmp (g
.eof_jump
, 1);
166 at_eol
= (c
== '\n');
171 /* Push a character back onto the input. */
180 /* Skip over spaces in the input. Returns the nonspace character that
181 terminated the eating and also places it back on the input. */
192 while (c
== ' ' || c
== '\t');
199 /* Skip over a separator. Technically, we don't always eat the whole
200 separator. This is because if we've processed the last input item,
201 then a separator is unnecessary. Plus the fact that operating
202 systems usually deliver console input on a line basis.
204 The upshot is that if we see a newline as part of reading a
205 separator, we stop reading. If there are more input items, we
206 continue reading the separator with finish_separator() which takes
207 care of the fact that we may or may not have seen a comma as part
237 { /* Eat a namelist comment. */
245 /* Fall Through... */
254 /* Finish processing a separator that was interrupted by a newline.
255 If we're here, then another data item is present, so we finish what
256 we started on the previous line. */
259 finish_separator (void)
306 /* Convert an unsigned string to an integer. The length value is -1
307 if we are working on a repeat count. Returns nonzero if we have a
308 range problem. As a side effect, frees the saved_string. */
311 convert_integer (int length
, int negative
)
313 char c
, *buffer
, message
[100];
315 int64_t v
, max
, max10
;
317 buffer
= saved_string
;
320 max
= (length
== -1) ? MAX_REPEAT
: max_value (length
, 1);
345 set_integer (value
, v
, length
);
351 if (repeat_count
== 0)
353 st_sprintf (message
, "Zero repeat count in item %d of list input",
356 generate_error (ERROR_READ_VALUE
, message
);
366 st_sprintf (message
, "Repeat count overflow in item %d of list input",
369 st_sprintf (message
, "Integer overflow while reading item %d",
373 generate_error (ERROR_READ_VALUE
, message
);
379 /* Parse a repeat count for logical and complex values which cannot
380 begin with a digit. Returns nonzero if we are done, zero if we
381 should continue on. */
386 char c
, message
[100];
412 repeat
= 10 * repeat
+ c
- '0';
414 if (repeat
> MAX_REPEAT
)
417 "Repeat count overflow in item %d of list input",
420 generate_error (ERROR_READ_VALUE
, message
);
430 "Zero repeat count in item %d of list input",
433 generate_error (ERROR_READ_VALUE
, message
);
445 repeat_count
= repeat
;
449 st_sprintf (message
, "Bad repeat count in item %d of list input",
452 generate_error (ERROR_READ_VALUE
, message
);
457 /* Read a logical character on the input. */
460 read_logical (int length
)
462 char c
, message
[100];
501 return; /* Null value. */
507 saved_type
= BT_LOGICAL
;
508 saved_length
= length
;
510 /* Eat trailing garbage. */
515 while (!is_separator (c
));
520 set_integer ((int *) value
, v
, length
);
525 st_sprintf (message
, "Bad logical value while reading item %d",
528 generate_error (ERROR_READ_VALUE
, message
);
532 /* Reading integers is tricky because we can actually be reading a
533 repeat count. We have to store the characters in a buffer because
534 we could be reading an integer that is larger than the default int
535 used for repeat counts. */
538 read_integer (int length
)
540 char c
, message
[100];
550 /* Fall through... */
556 CASE_SEPARATORS
: /* Single null. */
569 /* Take care of what may be a repeat count. */
584 CASE_SEPARATORS
: /* Not a repeat count. */
593 if (convert_integer (-1, 0))
596 /* Get the real integer. */
611 /* Fall through... */
643 st_sprintf (message
, "Bad integer for item %d in list input", g
.item_count
);
644 generate_error (ERROR_READ_VALUE
, message
);
653 if (convert_integer (length
, negative
))
660 saved_type
= BT_INTEGER
;
664 /* Read a character variable. */
667 read_character (int length
)
669 char c
, quote
, message
[100];
671 quote
= ' '; /* Space means no quote character. */
681 unget_char (c
); /* NULL value. */
695 /* Deal with a possible repeat count. */
708 goto done
; /* String was only digits! */
716 goto get_string
; /* Not a repeat count after all. */
721 if (convert_integer (-1, 0))
724 /* Now get the real string. */
730 unget_char (c
); /* Repeated NULL values. */
758 /* See if we have a doubled quote character or the end of
788 /* At this point, we have to have a separator, or else the string is
792 if (is_separator (c
))
796 saved_type
= BT_CHARACTER
;
801 st_sprintf (message
, "Invalid string input in item %d", g
.item_count
);
802 generate_error (ERROR_READ_VALUE
, message
);
807 /* Parse a component of a complex constant or a real number that we
808 are sure is already there. This is a straight real number parser. */
811 parse_real (void *buffer
, int length
)
813 char c
, message
[100];
817 if (c
== '-' || c
== '+')
823 if (!isdigit (c
) && c
!= '.')
828 seen_dp
= (c
== '.') ? 1 : 0;
872 if (c
!= '-' && c
!= '+')
907 m
= convert_real (buffer
, saved_string
, length
);
914 st_sprintf (message
, "Bad floating point number for item %d", g
.item_count
);
915 generate_error (ERROR_READ_VALUE
, message
);
921 /* Reading a complex number is straightforward because we can tell
922 what it is right away. */
925 read_complex (int length
)
949 if (parse_real (value
, length
))
953 if (next_char () != ',')
957 if (parse_real (value
+ length
, length
))
961 if (next_char () != ')')
965 if (!is_separator (c
))
972 saved_type
= BT_COMPLEX
;
976 st_sprintf (message
, "Bad complex value in item %d of list input",
979 generate_error (ERROR_READ_VALUE
, message
);
983 /* Parse a real number with a possible repeat count. */
986 read_real (int length
)
988 char c
, message
[100];
1010 unget_char (c
); /* Single null. */
1018 /* Get the digit string that might be a repeat count. */
1055 if (c
!= '\n' && c
!= ',')
1056 unget_char (c
); /* Real number that is just a digit-string. */
1065 if (convert_integer (-1, 0))
1068 /* Now get the number itself. */
1071 if (is_separator (c
))
1072 { /* Repeated null value. */
1078 if (c
!= '-' && c
!= '+')
1087 if (!isdigit (c
) && c
!= '.')
1143 if (c
!= '+' && c
!= '-')
1178 if (convert_real (value
, saved_string
, length
))
1182 saved_type
= BT_REAL
;
1186 st_sprintf (message
, "Bad real number in item %d of list input",
1189 generate_error (ERROR_READ_VALUE
, message
);
1193 /* Check the current type against the saved type to make sure they are
1194 compatible. Returns nonzero if incompatible. */
1197 check_type (bt type
, int len
)
1201 if (saved_type
!= BT_NULL
&& saved_type
!= type
)
1203 st_sprintf (message
, "Read type %s where %s was expected for item %d",
1204 type_name (saved_type
), type_name (type
), g
.item_count
);
1206 generate_error (ERROR_READ_VALUE
, message
);
1210 if (saved_type
== BT_NULL
|| saved_type
== BT_CHARACTER
)
1213 if (saved_length
!= len
)
1215 st_sprintf (message
,
1216 "Read kind %d %s where kind %d is required for item %d",
1217 saved_length
, type_name (saved_type
), len
, g
.item_count
);
1218 generate_error (ERROR_READ_VALUE
, message
);
1226 /* Top level data transfer subroutine for list reads. Because we have
1227 to deal with repeat counts, the data item is always saved after
1228 reading, usually in the value[] array. If a repeat count is
1229 greater than one, we copy the data item multiple times. */
1232 list_formatted_read (bt type
, void *p
, int len
)
1239 if (setjmp (g
.eof_jump
))
1241 generate_error (ERROR_END
, NULL
);
1253 if (is_separator (c
))
1254 { /* Found a null value. */
1258 finish_separator ();
1269 if (repeat_count
> 0)
1271 if (check_type (type
, len
))
1277 finish_separator ();
1281 /* trailing spaces prior to end of line */
1283 finish_separator ();
1286 saved_type
= BT_NULL
;
1299 read_character (len
);
1308 internal_error ("Bad type for list read");
1311 if (saved_type
!= BT_CHARACTER
&& saved_type
!= BT_NULL
)
1314 if (ioparm
.library_return
!= LIBRARY_OK
)
1327 memcpy (p
, value
, len
);
1333 m
= (len
< saved_used
) ? len
: saved_used
;
1334 memcpy (p
, saved_string
, m
);
1337 /* Just delimiters encountered, nothing to copy but SPACE. */
1341 memset (((char *) p
) + m
, ' ', len
- m
);
1348 if (--repeat_count
<= 0)
1358 /* Finish a list read. */
1361 finish_list_read (void)
1380 static namelist_info
*
1381 find_nml_node (char * var_name
)
1383 namelist_info
* t
= ionml
;
1386 if (strcmp (var_name
,t
->var_name
) == 0)
1388 t
->value_acquired
= 1;
1397 match_namelist_name (char *name
, int len
)
1401 char * namelist_name
= name
;
1404 /* Match the name of the namelist. */
1406 if (tolower (next_char ()) != tolower (namelist_name
[name_len
++]))
1409 generate_error (ERROR_READ_VALUE
, "Wrong namelist name found");
1413 while (name_len
< len
)
1416 if (tolower (c
) != tolower (namelist_name
[name_len
++]))
1422 /********************************************************************
1424 ********************************************************************/
1426 /* Process a namelist read. This subroutine initializes things,
1427 positions to the first element and
1428 FIXME: was this comment ever complete? */
1431 namelist_read (void)
1434 int name_matched
, next_name
;
1441 if (setjmp (g
.eof_jump
))
1443 generate_error (ERROR_END
, NULL
);
1464 generate_error (ERROR_READ_VALUE
, "Invalid character in namelist");
1468 /* Match the name of the namelist. */
1469 match_namelist_name(ioparm
.namelist_name
, ioparm
.namelist_name_len
);
1471 /* Ready to read namelist elements. */
1472 while (!input_complete
)
1482 match_namelist_name("end",3);
1496 nl
= find_nml_node (saved_string
);
1498 internal_error ("Can not match a namelist variable");
1504 /* skip any blanks or tabs after the = */
1516 read_character (len
);
1525 internal_error ("Bad type for namelist read");
1532 /* Fall through... */
1537 memcpy (p
, value
, len
);
1541 m
= (len
< saved_used
) ? len
: saved_used
;
1542 memcpy (p
, saved_string
, m
);
1545 memset (((char *) p
) + m
, ' ', len
- m
);
1555 push_char(tolower(c
));