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;
120 /* Free the line buffer if necessary. */
123 free_line (st_parameter_dt *dtp)
125 if (dtp->u.p.line_buffer == NULL)
128 free_mem (dtp->u.p.line_buffer);
129 dtp->u.p.line_buffer = NULL;
134 next_char (st_parameter_dt *dtp)
140 if (dtp->u.p.last_char != '\0')
143 c = dtp->u.p.last_char;
144 dtp->u.p.last_char = '\0';
148 /* Read from line_buffer if enabled. */
150 if (dtp->u.p.line_buffer_enabled)
154 c = dtp->u.p.line_buffer[dtp->u.p.item_count];
155 if (c != '\0' && dtp->u.p.item_count < 64)
157 dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
158 dtp->u.p.item_count++;
162 dtp->u.p.item_count = 0;
163 dtp->u.p.line_buffer_enabled = 0;
166 /* Handle the end-of-record condition for internal array unit */
167 if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0)
170 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
172 /* Check for "end-of-file" condition */
174 longjmp (*dtp->u.p.eof_jump, 1);
176 record *= dtp->u.p.current_unit->recl;
178 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
179 longjmp (*dtp->u.p.eof_jump, 1);
181 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
185 /* Get the next character and handle end-of-record conditions */
189 p = salloc_r (dtp->u.p.current_unit->s, &length);
191 if (is_internal_unit(dtp))
193 if (is_array_io(dtp))
195 /* End of record is handled in the next pass through, above. The
196 check for NULL here is cautionary. */
199 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
203 dtp->u.p.current_unit->bytes_left--;
209 longjmp (*dtp->u.p.eof_jump, 1);
220 generate_error (&dtp->common, ERROR_OS, NULL);
224 longjmp (*dtp->u.p.eof_jump, 1);
228 dtp->u.p.at_eol = (c == '\n' || c == '\r');
233 /* Push a character back onto the input. */
236 unget_char (st_parameter_dt *dtp, char c)
238 dtp->u.p.last_char = c;
242 /* Skip over spaces in the input. Returns the nonspace character that
243 terminated the eating and also places it back on the input. */
246 eat_spaces (st_parameter_dt *dtp)
254 while (c == ' ' || c == '\t');
261 /* Skip over a separator. Technically, we don't always eat the whole
262 separator. This is because if we've processed the last input item,
263 then a separator is unnecessary. Plus the fact that operating
264 systems usually deliver console input on a line basis.
266 The upshot is that if we see a newline as part of reading a
267 separator, we stop reading. If there are more input items, we
268 continue reading the separator with finish_separator() which takes
269 care of the fact that we may or may not have seen a comma as part
273 eat_separator (st_parameter_dt *dtp)
278 dtp->u.p.comma_flag = 0;
284 dtp->u.p.comma_flag = 1;
289 dtp->u.p.input_complete = 1;
308 if (dtp->u.p.namelist_mode)
309 { /* Eat a namelist comment. */
317 /* Fall Through... */
326 /* Finish processing a separator that was interrupted by a newline.
327 If we're here, then another data item is present, so we finish what
328 we started on the previous line. */
331 finish_separator (st_parameter_dt *dtp)
342 if (dtp->u.p.comma_flag)
346 c = eat_spaces (dtp);
347 if (c == '\n' || c == '\r')
354 dtp->u.p.input_complete = 1;
355 if (!dtp->u.p.namelist_mode) next_record (dtp, 0);
363 if (dtp->u.p.namelist_mode)
379 /* This function reads characters through to the end of the current line and
380 just ignores them. */
383 eat_line (st_parameter_dt *dtp)
386 if (!is_internal_unit (dtp))
393 /* This function is needed to catch bad conversions so that namelist can
394 attempt to see if dtp->u.p.saved_string contains a new object name rather
398 nml_bad_return (st_parameter_dt *dtp, char c)
400 if (dtp->u.p.namelist_mode)
402 dtp->u.p.nml_read_error = 1;
409 /* Convert an unsigned string to an integer. The length value is -1
410 if we are working on a repeat count. Returns nonzero if we have a
411 range problem. As a side effect, frees the dtp->u.p.saved_string. */
414 convert_integer (st_parameter_dt *dtp, int length, int negative)
416 char c, *buffer, message[100];
418 GFC_INTEGER_LARGEST v, max, max10;
420 buffer = dtp->u.p.saved_string;
423 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
448 set_integer (dtp->u.p.value, v, length);
452 dtp->u.p.repeat_count = v;
454 if (dtp->u.p.repeat_count == 0)
456 st_sprintf (message, "Zero repeat count in item %d of list input",
457 dtp->u.p.item_count);
459 generate_error (&dtp->common, ERROR_READ_VALUE, message);
469 st_sprintf (message, "Repeat count overflow in item %d of list input",
470 dtp->u.p.item_count);
472 st_sprintf (message, "Integer overflow while reading item %d",
473 dtp->u.p.item_count);
476 generate_error (&dtp->common, ERROR_READ_VALUE, message);
482 /* Parse a repeat count for logical and complex values which cannot
483 begin with a digit. Returns nonzero if we are done, zero if we
484 should continue on. */
487 parse_repeat (st_parameter_dt *dtp)
489 char c, message[100];
515 repeat = 10 * repeat + c - '0';
517 if (repeat > MAX_REPEAT)
520 "Repeat count overflow in item %d of list input",
521 dtp->u.p.item_count);
523 generate_error (&dtp->common, ERROR_READ_VALUE, message);
533 "Zero repeat count in item %d of list input",
534 dtp->u.p.item_count);
536 generate_error (&dtp->common, ERROR_READ_VALUE, message);
548 dtp->u.p.repeat_count = repeat;
555 st_sprintf (message, "Bad repeat count in item %d of list input",
556 dtp->u.p.item_count);
557 generate_error (&dtp->common, ERROR_READ_VALUE, message);
562 /* To read a logical we have to look ahead in the input stream to make sure
563 there is not an equal sign indicating a variable name. To do this we use
564 line_buffer to point to a temporary buffer, pushing characters there for
565 possible later reading. */
568 l_push_char (st_parameter_dt *dtp, char c)
570 if (dtp->u.p.line_buffer == NULL)
572 dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
573 memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
576 dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
580 /* Read a logical character on the input. */
583 read_logical (st_parameter_dt *dtp, int length)
585 char c, message[100];
588 if (parse_repeat (dtp))
591 c = tolower (next_char (dtp));
592 l_push_char (dtp, c);
598 l_push_char (dtp, c);
600 if (!is_separator(c))
608 l_push_char (dtp, c);
610 if (!is_separator(c))
616 c = tolower (next_char (dtp));
634 return; /* Null value. */
640 dtp->u.p.saved_type = BT_LOGICAL;
641 dtp->u.p.saved_length = length;
643 /* Eat trailing garbage. */
648 while (!is_separator (c));
652 dtp->u.p.item_count = 0;
653 dtp->u.p.line_buffer_enabled = 0;
654 set_integer ((int *) dtp->u.p.value, v, length);
660 for(i = 0; i < 63; i++)
665 /* All done if this is not a namelist read. */
666 if (!dtp->u.p.namelist_mode)
679 l_push_char (dtp, c);
682 dtp->u.p.nml_read_error = 1;
683 dtp->u.p.line_buffer_enabled = 1;
684 dtp->u.p.item_count = 0;
692 if (nml_bad_return (dtp, c))
697 if (dtp->u.p.line_buffer != NULL)
698 free_mem (dtp->u.p.line_buffer);
699 st_sprintf (message, "Bad logical value while reading item %d",
700 dtp->u.p.item_count);
701 generate_error (&dtp->common, ERROR_READ_VALUE, message);
706 dtp->u.p.item_count = 0;
707 dtp->u.p.line_buffer_enabled = 0;
708 dtp->u.p.saved_type = BT_LOGICAL;
709 dtp->u.p.saved_length = length;
710 set_integer ((int *) dtp->u.p.value, v, length);
714 /* Reading integers is tricky because we can actually be reading a
715 repeat count. We have to store the characters in a buffer because
716 we could be reading an integer that is larger than the default int
717 used for repeat counts. */
720 read_integer (st_parameter_dt *dtp, int length)
722 char c, message[100];
732 /* Fall through... */
738 CASE_SEPARATORS: /* Single null. */
751 /* Take care of what may be a repeat count. */
763 push_char (dtp, '\0');
766 CASE_SEPARATORS: /* Not a repeat count. */
775 if (convert_integer (dtp, -1, 0))
778 /* Get the real integer. */
793 /* Fall through... */
824 if (nml_bad_return (dtp, c))
829 st_sprintf (message, "Bad integer for item %d in list input",
830 dtp->u.p.item_count);
831 generate_error (&dtp->common, ERROR_READ_VALUE, message);
839 push_char (dtp, '\0');
840 if (convert_integer (dtp, length, negative))
847 dtp->u.p.saved_type = BT_INTEGER;
851 /* Read a character variable. */
854 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
856 char c, quote, message[100];
858 quote = ' '; /* Space means no quote character. */
868 unget_char (dtp, c); /* NULL value. */
878 if (dtp->u.p.namelist_mode)
887 /* Deal with a possible repeat count. */
900 goto done; /* String was only digits! */
903 push_char (dtp, '\0');
908 goto get_string; /* Not a repeat count after all. */
913 if (convert_integer (dtp, -1, 0))
916 /* Now get the real string. */
922 unget_char (dtp, c); /* Repeated NULL values. */
950 /* See if we have a doubled quote character or the end of
956 push_char (dtp, quote);
970 if (c != '\n' && c != '\r')
980 /* At this point, we have to have a separator, or else the string is
984 if (is_separator (c))
988 dtp->u.p.saved_type = BT_CHARACTER;
993 st_sprintf (message, "Invalid string input in item %d",
994 dtp->u.p.item_count);
995 generate_error (&dtp->common, ERROR_READ_VALUE, message);
1000 /* Parse a component of a complex constant or a real number that we
1001 are sure is already there. This is a straight real number parser. */
1004 parse_real (st_parameter_dt *dtp, void *buffer, int length)
1006 char c, message[100];
1009 c = next_char (dtp);
1010 if (c == '-' || c == '+')
1013 c = next_char (dtp);
1016 if (!isdigit (c) && c != '.')
1021 seen_dp = (c == '.') ? 1 : 0;
1025 c = next_char (dtp);
1044 push_char (dtp, 'e');
1049 push_char (dtp, 'e');
1051 c = next_char (dtp);
1055 unget_char (dtp, c);
1064 c = next_char (dtp);
1065 if (c != '-' && c != '+')
1066 push_char (dtp, '+');
1070 c = next_char (dtp);
1080 c = next_char (dtp);
1088 unget_char (dtp, c);
1097 unget_char (dtp, c);
1098 push_char (dtp, '\0');
1100 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
1107 if (nml_bad_return (dtp, c))
1112 st_sprintf (message, "Bad floating point number for item %d",
1113 dtp->u.p.item_count);
1114 generate_error (&dtp->common, ERROR_READ_VALUE, message);
1120 /* Reading a complex number is straightforward because we can tell
1121 what it is right away. */
1124 read_complex (st_parameter_dt *dtp, int kind, size_t size)
1129 if (parse_repeat (dtp))
1132 c = next_char (dtp);
1139 unget_char (dtp, c);
1140 eat_separator (dtp);
1148 if (parse_real (dtp, dtp->u.p.value, kind))
1153 c = next_char (dtp);
1154 if (c == '\n' || c== '\r')
1157 unget_char (dtp, c);
1159 if (next_char (dtp) != ',')
1164 c = next_char (dtp);
1165 if (c == '\n' || c== '\r')
1168 unget_char (dtp, c);
1170 if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
1174 if (next_char (dtp) != ')')
1177 c = next_char (dtp);
1178 if (!is_separator (c))
1181 unget_char (dtp, c);
1182 eat_separator (dtp);
1185 dtp->u.p.saved_type = BT_COMPLEX;
1190 if (nml_bad_return (dtp, c))
1195 st_sprintf (message, "Bad complex value in item %d of list input",
1196 dtp->u.p.item_count);
1197 generate_error (&dtp->common, ERROR_READ_VALUE, message);
1201 /* Parse a real number with a possible repeat count. */
1204 read_real (st_parameter_dt *dtp, int length)
1206 char c, message[100];
1211 c = next_char (dtp);
1228 unget_char (dtp, c); /* Single null. */
1229 eat_separator (dtp);
1236 /* Get the digit string that might be a repeat count. */
1240 c = next_char (dtp);
1263 push_char (dtp, 'e');
1265 c = next_char (dtp);
1269 push_char (dtp, '\0');
1273 if (c != '\n' && c != ',' && c != '\r')
1274 unget_char (dtp, c);
1283 if (convert_integer (dtp, -1, 0))
1286 /* Now get the number itself. */
1288 c = next_char (dtp);
1289 if (is_separator (c))
1290 { /* Repeated null value. */
1291 unget_char (dtp, c);
1292 eat_separator (dtp);
1296 if (c != '-' && c != '+')
1297 push_char (dtp, '+');
1302 c = next_char (dtp);
1305 if (!isdigit (c) && c != '.')
1321 c = next_char (dtp);
1347 push_char (dtp, 'e');
1349 c = next_char (dtp);
1358 push_char (dtp, 'e');
1360 c = next_char (dtp);
1361 if (c != '+' && c != '-')
1362 push_char (dtp, '+');
1366 c = next_char (dtp);
1376 c = next_char (dtp);
1393 unget_char (dtp, c);
1394 eat_separator (dtp);
1395 push_char (dtp, '\0');
1396 if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
1400 dtp->u.p.saved_type = BT_REAL;
1405 if (nml_bad_return (dtp, c))
1410 st_sprintf (message, "Bad real number in item %d of list input",
1411 dtp->u.p.item_count);
1412 generate_error (&dtp->common, ERROR_READ_VALUE, message);
1416 /* Check the current type against the saved type to make sure they are
1417 compatible. Returns nonzero if incompatible. */
1420 check_type (st_parameter_dt *dtp, bt type, int len)
1424 if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
1426 st_sprintf (message, "Read type %s where %s was expected for item %d",
1427 type_name (dtp->u.p.saved_type), type_name (type),
1428 dtp->u.p.item_count);
1430 generate_error (&dtp->common, ERROR_READ_VALUE, message);
1434 if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
1437 if (dtp->u.p.saved_length != len)
1439 st_sprintf (message,
1440 "Read kind %d %s where kind %d is required for item %d",
1441 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
1442 dtp->u.p.item_count);
1443 generate_error (&dtp->common, ERROR_READ_VALUE, message);
1451 /* Top level data transfer subroutine for list reads. Because we have
1452 to deal with repeat counts, the data item is always saved after
1453 reading, usually in the dtp->u.p.value[] array. If a repeat count is
1454 greater than one, we copy the data item multiple times. */
1457 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1464 dtp->u.p.namelist_mode = 0;
1466 dtp->u.p.eof_jump = &eof_jump;
1467 if (setjmp (eof_jump))
1469 generate_error (&dtp->common, ERROR_END, NULL);
1473 if (dtp->u.p.first_item)
1475 dtp->u.p.first_item = 0;
1476 dtp->u.p.input_complete = 0;
1477 dtp->u.p.repeat_count = 1;
1478 dtp->u.p.at_eol = 0;
1480 c = eat_spaces (dtp);
1481 if (is_separator (c))
1482 { /* Found a null value. */
1483 eat_separator (dtp);
1484 dtp->u.p.repeat_count = 0;
1486 /* eat_separator sets this flag if the separator was a comma */
1487 if (dtp->u.p.comma_flag)
1490 /* eat_separator sets this flag if the separator was a \n or \r */
1491 if (dtp->u.p.at_eol)
1492 finish_separator (dtp);
1500 if (dtp->u.p.input_complete)
1503 if (dtp->u.p.repeat_count > 0)
1505 if (check_type (dtp, type, kind))
1510 if (dtp->u.p.at_eol)
1511 finish_separator (dtp);
1515 /* trailing spaces prior to end of line */
1516 if (dtp->u.p.at_eol)
1517 finish_separator (dtp);
1520 dtp->u.p.saved_type = BT_NULL;
1521 dtp->u.p.repeat_count = 1;
1527 read_integer (dtp, kind);
1530 read_logical (dtp, kind);
1533 read_character (dtp, kind);
1536 read_real (dtp, kind);
1539 read_complex (dtp, kind, size);
1542 internal_error (&dtp->common, "Bad type for list read");
1545 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
1546 dtp->u.p.saved_length = size;
1548 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1552 switch (dtp->u.p.saved_type)
1558 memcpy (p, dtp->u.p.value, size);
1562 if (dtp->u.p.saved_string)
1564 m = ((int) size < dtp->u.p.saved_used)
1565 ? (int) size : dtp->u.p.saved_used;
1566 memcpy (p, dtp->u.p.saved_string, m);
1569 /* Just delimiters encountered, nothing to copy but SPACE. */
1573 memset (((char *) p) + m, ' ', size - m);
1580 if (--dtp->u.p.repeat_count <= 0)
1584 dtp->u.p.eof_jump = NULL;
1589 list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1590 size_t size, size_t nelems)
1597 /* Big loop over all the elements. */
1598 for (elem = 0; elem < nelems; elem++)
1600 dtp->u.p.item_count++;
1601 list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
1606 /* Finish a list read. */
1609 finish_list_read (st_parameter_dt *dtp)
1615 if (dtp->u.p.at_eol)
1617 dtp->u.p.at_eol = 0;
1623 c = next_char (dtp);
1630 void namelist_read (st_parameter_dt *dtp)
1632 static void nml_match_name (char *name, int len)
1633 static int nml_query (st_parameter_dt *dtp)
1634 static int nml_get_obj_data (st_parameter_dt *dtp,
1635 namelist_info **prev_nl, char *)
1637 static void nml_untouch_nodes (st_parameter_dt *dtp)
1638 static namelist_info * find_nml_node (st_parameter_dt *dtp,
1640 static int nml_parse_qualifier(descriptor_dimension * ad,
1641 array_loop_spec * ls, int rank, char *)
1642 static void nml_touch_nodes (namelist_info * nl)
1643 static int nml_read_obj (namelist_info *nl, index_type offset,
1644 namelist_info **prev_nl, char *,
1645 index_type clow, index_type chigh)
1649 /* Inputs a rank-dimensional qualifier, which can contain
1650 singlets, doublets, triplets or ':' with the standard meanings. */
1653 nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
1654 array_loop_spec *ls, int rank, char *parse_err_msg)
1662 /* The next character in the stream should be the '('. */
1664 c = next_char (dtp);
1666 /* Process the qualifier, by dimension and triplet. */
1668 for (dim=0; dim < rank; dim++ )
1670 for (indx=0; indx<3; indx++)
1676 /* Process a potential sign. */
1677 c = next_char (dtp);
1688 unget_char (dtp, c);
1692 /* Process characters up to the next ':' , ',' or ')'. */
1695 c = next_char (dtp);
1703 if ((c==',' && dim == rank -1)
1704 || (c==')' && dim < rank -1))
1706 st_sprintf (parse_err_msg,
1707 "Bad number of index fields");
1716 case ' ': case '\t':
1718 c = next_char (dtp);
1722 st_sprintf (parse_err_msg, "Bad character in index");
1726 if ((c == ',' || c == ')') && indx == 0
1727 && dtp->u.p.saved_string == 0)
1729 st_sprintf (parse_err_msg, "Null index field");
1733 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
1734 || (indx == 2 && dtp->u.p.saved_string == 0))
1736 st_sprintf(parse_err_msg, "Bad index triplet");
1740 /* If '( : ? )' or '( ? : )' break and flag read failure. */
1742 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
1743 || (indx==1 && dtp->u.p.saved_string == 0))
1749 /* Now read the index. */
1750 if (convert_integer (dtp, sizeof(ssize_t), neg))
1752 st_sprintf (parse_err_msg, "Bad integer in index");
1758 /* Feed the index values to the triplet arrays. */
1762 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
1764 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
1766 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
1769 /* Singlet or doublet indices. */
1770 if (c==',' || c==')')
1774 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
1775 ls[dim].end = ls[dim].start;
1781 /* Check the values of the triplet indices. */
1782 if ((ls[dim].start > (ssize_t)ad[dim].ubound)
1783 || (ls[dim].start < (ssize_t)ad[dim].lbound)
1784 || (ls[dim].end > (ssize_t)ad[dim].ubound)
1785 || (ls[dim].end < (ssize_t)ad[dim].lbound))
1787 st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
1790 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
1791 || (ls[dim].step == 0))
1793 st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
1797 /* Initialise the loop index counter. */
1798 ls[dim].idx = ls[dim].start;
1808 static namelist_info *
1809 find_nml_node (st_parameter_dt *dtp, char * var_name)
1811 namelist_info * t = dtp->u.p.ionml;
1814 if (strcmp (var_name, t->var_name) == 0)
1824 /* Visits all the components of a derived type that have
1825 not explicitly been identified in the namelist input.
1826 touched is set and the loop specification initialised
1827 to default values */
1830 nml_touch_nodes (namelist_info * nl)
1832 index_type len = strlen (nl->var_name) + 1;
1834 char * ext_name = (char*)get_mem (len + 1);
1835 strcpy (ext_name, nl->var_name);
1836 strcat (ext_name, "%");
1837 for (nl = nl->next; nl; nl = nl->next)
1839 if (strncmp (nl->var_name, ext_name, len) == 0)
1842 for (dim=0; dim < nl->var_rank; dim++)
1844 nl->ls[dim].step = 1;
1845 nl->ls[dim].end = nl->dim[dim].ubound;
1846 nl->ls[dim].start = nl->dim[dim].lbound;
1847 nl->ls[dim].idx = nl->ls[dim].start;
1853 free_mem (ext_name);
1857 /* Resets touched for the entire list of nml_nodes, ready for a
1861 nml_untouch_nodes (st_parameter_dt *dtp)
1864 for (t = dtp->u.p.ionml; t; t = t->next)
1869 /* Attempts to input name to namelist name. Returns
1870 dtp->u.p.nml_read_error = 1 on no match. */
1873 nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
1877 dtp->u.p.nml_read_error = 0;
1878 for (i = 0; i < len; i++)
1880 c = next_char (dtp);
1881 if (tolower (c) != tolower (name[i]))
1883 dtp->u.p.nml_read_error = 1;
1889 /* If the namelist read is from stdin, output the current state of the
1890 namelist to stdout. This is used to implement the non-standard query
1891 features, ? and =?. If c == '=' the full namelist is printed. Otherwise
1892 the names alone are printed. */
1895 nml_query (st_parameter_dt *dtp, char c)
1897 gfc_unit * temp_unit;
1902 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
1905 /* Store the current unit and transfer to stdout. */
1907 temp_unit = dtp->u.p.current_unit;
1908 dtp->u.p.current_unit = find_unit (options.stdout_unit);
1910 if (dtp->u.p.current_unit)
1912 dtp->u.p.mode = WRITING;
1913 next_record (dtp, 0);
1915 /* Write the namelist in its entirety. */
1918 namelist_write (dtp);
1920 /* Or write the list of names. */
1925 /* "&namelist_name\n" */
1927 len = dtp->namelist_name_len;
1929 p = write_block (dtp, len + 3);
1931 p = write_block (dtp, len + 2);
1936 memcpy ((char*)(p + 1), dtp->namelist_name, len);
1938 memcpy ((char*)(p + len + 1), "\r\n", 2);
1940 memcpy ((char*)(p + len + 1), "\n", 1);
1942 for (nl = dtp->u.p.ionml; nl; nl = nl->next)
1947 len = strlen (nl->var_name);
1949 p = write_block (dtp, len + 3);
1951 p = write_block (dtp, len + 2);
1956 memcpy ((char*)(p + 1), nl->var_name, len);
1958 memcpy ((char*)(p + len + 1), "\r\n", 2);
1960 memcpy ((char*)(p + len + 1), "\n", 1);
1967 p = write_block (dtp, 6);
1969 p = write_block (dtp, 5);
1974 memcpy (p, "&end\r\n", 6);
1976 memcpy (p, "&end\n", 5);
1980 /* Flush the stream to force immediate output. */
1982 flush (dtp->u.p.current_unit->s);
1983 unlock_unit (dtp->u.p.current_unit);
1988 /* Restore the current unit. */
1990 dtp->u.p.current_unit = temp_unit;
1991 dtp->u.p.mode = READING;
1995 /* Reads and stores the input for the namelist object nl. For an array,
1996 the function loops over the ranges defined by the loop specification.
1997 This default to all the data or to the specification from a qualifier.
1998 nml_read_obj recursively calls itself to read derived types. It visits
1999 all its own components but only reads data for those that were touched
2000 when the name was parsed. If a read error is encountered, an attempt is
2001 made to return to read a new object name because the standard allows too
2002 little data to be available. On the other hand, too much data is an
2006 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
2007 namelist_info **pprev_nl, char *nml_err_msg,
2008 index_type clow, index_type chigh)
2011 namelist_info * cmp;
2018 index_type obj_name_len;
2021 /* This object not touched in name parsing. */
2026 dtp->u.p.repeat_count = 0;
2033 case GFC_DTYPE_INTEGER:
2034 case GFC_DTYPE_LOGICAL:
2038 case GFC_DTYPE_REAL:
2039 dlen = size_from_real_kind (len);
2042 case GFC_DTYPE_COMPLEX:
2043 dlen = size_from_complex_kind (len);
2046 case GFC_DTYPE_CHARACTER:
2047 dlen = chigh ? (chigh - clow + 1) : nl->string_length;
2057 /* Update the pointer to the data, using the current index vector */
2059 pdata = (void*)(nl->mem_pos + offset);
2060 for (dim = 0; dim < nl->var_rank; dim++)
2061 pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
2062 nl->dim[dim].stride * nl->size);
2064 /* Reset the error flag and try to read next value, if
2065 dtp->u.p.repeat_count=0 */
2067 dtp->u.p.nml_read_error = 0;
2069 if (--dtp->u.p.repeat_count <= 0)
2071 if (dtp->u.p.input_complete)
2073 if (dtp->u.p.at_eol)
2074 finish_separator (dtp);
2075 if (dtp->u.p.input_complete)
2078 /* GFC_TYPE_UNKNOWN through for nulls and is detected
2079 after the switch block. */
2081 dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
2086 case GFC_DTYPE_INTEGER:
2087 read_integer (dtp, len);
2090 case GFC_DTYPE_LOGICAL:
2091 read_logical (dtp, len);
2094 case GFC_DTYPE_CHARACTER:
2095 read_character (dtp, len);
2098 case GFC_DTYPE_REAL:
2099 read_real (dtp, len);
2102 case GFC_DTYPE_COMPLEX:
2103 read_complex (dtp, len, dlen);
2106 case GFC_DTYPE_DERIVED:
2107 obj_name_len = strlen (nl->var_name) + 1;
2108 obj_name = get_mem (obj_name_len+1);
2109 strcpy (obj_name, nl->var_name);
2110 strcat (obj_name, "%");
2112 /* Now loop over the components. Update the component pointer
2113 with the return value from nml_write_obj. This loop jumps
2114 past nested derived types by testing if the potential
2115 component name contains '%'. */
2117 for (cmp = nl->next;
2119 !strncmp (cmp->var_name, obj_name, obj_name_len) &&
2120 !strchr (cmp->var_name + obj_name_len, '%');
2124 if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
2125 pprev_nl, nml_err_msg, clow, chigh)
2128 free_mem (obj_name);
2132 if (dtp->u.p.input_complete)
2134 free_mem (obj_name);
2139 free_mem (obj_name);
2143 st_sprintf (nml_err_msg, "Bad type for namelist object %s",
2145 internal_error (&dtp->common, nml_err_msg);
2150 /* The standard permits array data to stop short of the number of
2151 elements specified in the loop specification. In this case, we
2152 should be here with dtp->u.p.nml_read_error != 0. Control returns to
2153 nml_get_obj_data and an attempt is made to read object name. */
2156 if (dtp->u.p.nml_read_error)
2159 if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
2163 /* Note the switch from GFC_DTYPE_type to BT_type at this point.
2164 This comes about because the read functions return BT_types. */
2166 switch (dtp->u.p.saved_type)
2173 memcpy (pdata, dtp->u.p.value, dlen);
2177 m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
2178 pdata = (void*)( pdata + clow - 1 );
2179 memcpy (pdata, dtp->u.p.saved_string, m);
2181 memset ((void*)( pdata + m ), ' ', dlen - m);
2188 /* Break out of loop if scalar. */
2193 /* Now increment the index vector. */
2198 for (dim = 0; dim < nl->var_rank; dim++)
2200 nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
2202 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
2204 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
2206 nl->ls[dim].idx = nl->ls[dim].start;
2210 } while (!nml_carry);
2212 if (dtp->u.p.repeat_count > 1)
2214 st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
2225 /* Parses the object name, including array and substring qualifiers. It
2226 iterates over derived type components, touching those components and
2227 setting their loop specifications, if there is a qualifier. If the
2228 object is itself a derived type, its components and subcomponents are
2229 touched. nml_read_obj is called at the end and this reads the data in
2230 the manner specified by the object name. */
2233 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
2238 namelist_info * first_nl = NULL;
2239 namelist_info * root_nl = NULL;
2242 char parse_err_msg[30];
2243 index_type clow, chigh;
2245 /* Look for end of input or object name. If '?' or '=?' are encountered
2246 in stdin, print the node names or the namelist to stdout. */
2248 eat_separator (dtp);
2249 if (dtp->u.p.input_complete)
2252 if (dtp->u.p.at_eol)
2253 finish_separator (dtp);
2254 if (dtp->u.p.input_complete)
2257 c = next_char (dtp);
2261 c = next_char (dtp);
2264 st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
2267 nml_query (dtp, '=');
2271 nml_query (dtp, '?');
2276 nml_match_name (dtp, "end", 3);
2277 if (dtp->u.p.nml_read_error)
2279 st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
2283 dtp->u.p.input_complete = 1;
2290 /* Untouch all nodes of the namelist and reset the flag that is set for
2291 derived type components. */
2293 nml_untouch_nodes (dtp);
2296 /* Get the object name - should '!' and '\n' be permitted separators? */
2304 push_char (dtp, tolower(c));
2305 c = next_char (dtp);
2306 } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
2308 unget_char (dtp, c);
2310 /* Check that the name is in the namelist and get pointer to object.
2311 Three error conditions exist: (i) An attempt is being made to
2312 identify a non-existent object, following a failed data read or
2313 (ii) The object name does not exist or (iii) Too many data items
2314 are present for an object. (iii) gives the same error message
2317 push_char (dtp, '\0');
2321 size_t var_len = strlen (root_nl->var_name);
2323 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
2324 char ext_name[var_len + saved_len + 1];
2326 memcpy (ext_name, root_nl->var_name, var_len);
2327 if (dtp->u.p.saved_string)
2328 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
2329 ext_name[var_len + saved_len] = '\0';
2330 nl = find_nml_node (dtp, ext_name);
2333 nl = find_nml_node (dtp, dtp->u.p.saved_string);
2337 if (dtp->u.p.nml_read_error && *pprev_nl)
2338 st_sprintf (nml_err_msg, "Bad data for namelist object %s",
2339 (*pprev_nl)->var_name);
2342 st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
2343 dtp->u.p.saved_string);
2348 /* Get the length, data length, base pointer and rank of the variable.
2349 Set the default loop specification first. */
2351 for (dim=0; dim < nl->var_rank; dim++)
2353 nl->ls[dim].step = 1;
2354 nl->ls[dim].end = nl->dim[dim].ubound;
2355 nl->ls[dim].start = nl->dim[dim].lbound;
2356 nl->ls[dim].idx = nl->ls[dim].start;
2359 /* Check to see if there is a qualifier: if so, parse it.*/
2361 if (c == '(' && nl->var_rank)
2363 if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
2364 parse_err_msg) == FAILURE)
2366 st_sprintf (nml_err_msg, "%s for namelist variable %s",
2367 parse_err_msg, nl->var_name);
2370 c = next_char (dtp);
2371 unget_char (dtp, c);
2374 /* Now parse a derived type component. The root namelist_info address
2375 is backed up, as is the previous component level. The component flag
2376 is set and the iteration is made by jumping back to get_name. */
2381 if (nl->type != GFC_DTYPE_DERIVED)
2383 st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
2388 if (!component_flag)
2393 c = next_char (dtp);
2398 /* Parse a character qualifier, if present. chigh = 0 is a default
2399 that signals that the string length = string_length. */
2404 if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
2406 descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
2407 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
2409 if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
2411 st_sprintf (nml_err_msg, "%s for namelist variable %s",
2412 parse_err_msg, nl->var_name);
2416 clow = ind[0].start;
2419 if (ind[0].step != 1)
2421 st_sprintf (nml_err_msg,
2422 "Bad step in substring for namelist object %s",
2427 c = next_char (dtp);
2428 unget_char (dtp, c);
2431 /* If a derived type touch its components and restore the root
2432 namelist_info if we have parsed a qualified derived type
2435 if (nl->type == GFC_DTYPE_DERIVED)
2436 nml_touch_nodes (nl);
2440 /*make sure no extraneous qualifiers are there.*/
2444 st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
2445 " namelist object %s", nl->var_name);
2449 /* According to the standard, an equal sign MUST follow an object name. The
2450 following is possibly lax - it allows comments, blank lines and so on to
2451 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
2455 eat_separator (dtp);
2456 if (dtp->u.p.input_complete)
2459 if (dtp->u.p.at_eol)
2460 finish_separator (dtp);
2461 if (dtp->u.p.input_complete)
2464 c = next_char (dtp);
2468 st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
2473 if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
2483 /* Entry point for namelist input. Goes through input until namelist name
2484 is matched. Then cycles through nml_get_obj_data until the input is
2485 completed or there is an error. */
2488 namelist_read (st_parameter_dt *dtp)
2492 char nml_err_msg[100];
2493 /* Pointer to the previously read object, in case attempt is made to read
2494 new object name. Should this fail, error message can give previous
2496 namelist_info *prev_nl = NULL;
2498 dtp->u.p.namelist_mode = 1;
2499 dtp->u.p.input_complete = 0;
2501 dtp->u.p.eof_jump = &eof_jump;
2502 if (setjmp (eof_jump))
2504 dtp->u.p.eof_jump = NULL;
2505 generate_error (&dtp->common, ERROR_END, NULL);
2509 /* Look for &namelist_name . Skip all characters, testing for $nmlname.
2510 Exit on success or EOF. If '?' or '=?' encountered in stdin, print
2511 node names or namelist on stdout. */
2514 switch (c = next_char (dtp))
2521 c = next_char (dtp);
2523 nml_query (dtp, '=');
2525 unget_char (dtp, c);
2529 nml_query (dtp, '?');
2535 /* Match the name of the namelist. */
2537 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
2539 if (dtp->u.p.nml_read_error)
2542 /* Ready to read namelist objects. If there is an error in input
2543 from stdin, output the error message and continue. */
2545 while (!dtp->u.p.input_complete)
2547 if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
2551 if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
2554 u = find_unit (options.stderr_unit);
2555 st_printf ("%s\n", nml_err_msg);
2565 dtp->u.p.eof_jump = NULL;
2570 /* All namelist error calls return from here */
2574 dtp->u.p.eof_jump = NULL;
2577 generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);