From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- libgfortran/io/list_read.c | 3077 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3077 insertions(+) create mode 100644 libgfortran/io/list_read.c (limited to 'libgfortran/io/list_read.c') diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c new file mode 100644 index 000000000..198f9a702 --- /dev/null +++ b/libgfortran/io/list_read.c @@ -0,0 +1,3077 @@ +/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011 + Free Software Foundation, Inc. + Contributed by Andy Vaught + Namelist input contributed by Paul Thomas + F2003 I/O support contributed by Jerry DeLisle + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + + +#include "io.h" +#include "fbuf.h" +#include "unix.h" +#include +#include +#include + + +/* List directed input. Several parsing subroutines are practically + reimplemented from formatted input, the reason being that there are + all kinds of small differences between formatted and list directed + parsing. */ + + +/* Subroutines for reading characters from the input. Because a + repeat count is ambiguous with an integer, we have to read the + whole digit string before seeing if there is a '*' which signals + the repeat count. Since we can have a lot of potential leading + zeros, we have to be able to back up by arbitrary amount. Because + the input might not be seekable, we have to buffer the data + ourselves. */ + +#define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ + case '5': case '6': case '7': case '8': case '9' + +#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \ + case '\r': case ';' + +/* This macro assumes that we're operating on a variable. */ + +#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \ + || c == '\t' || c == '\r' || c == ';') + +/* Maximum repeat count. Less than ten times the maximum signed int32. */ + +#define MAX_REPEAT 200000000 + +#ifndef HAVE_SNPRINTF +# undef snprintf +# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__) +#endif + +/* Save a character to a string buffer, enlarging it as necessary. */ + +static void +push_char (st_parameter_dt *dtp, char c) +{ + char *new; + + if (dtp->u.p.saved_string == NULL) + { + dtp->u.p.saved_string = get_mem (SCRATCH_SIZE); + // memset below should be commented out. + memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE); + dtp->u.p.saved_length = SCRATCH_SIZE; + dtp->u.p.saved_used = 0; + } + + if (dtp->u.p.saved_used >= dtp->u.p.saved_length) + { + dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; + new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length); + if (new == NULL) + generate_error (&dtp->common, LIBERROR_OS, NULL); + dtp->u.p.saved_string = new; + + // Also this should not be necessary. + memset (new + dtp->u.p.saved_used, 0, + dtp->u.p.saved_length - dtp->u.p.saved_used); + + } + + dtp->u.p.saved_string[dtp->u.p.saved_used++] = c; +} + + +/* Free the input buffer if necessary. */ + +static void +free_saved (st_parameter_dt *dtp) +{ + if (dtp->u.p.saved_string == NULL) + return; + + free (dtp->u.p.saved_string); + + dtp->u.p.saved_string = NULL; + dtp->u.p.saved_used = 0; +} + + +/* Free the line buffer if necessary. */ + +static void +free_line (st_parameter_dt *dtp) +{ + dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_enabled = 0; + + if (dtp->u.p.line_buffer == NULL) + return; + + free (dtp->u.p.line_buffer); + dtp->u.p.line_buffer = NULL; +} + + +static int +next_char (st_parameter_dt *dtp) +{ + ssize_t length; + gfc_offset record; + int c; + + if (dtp->u.p.last_char != EOF - 1) + { + dtp->u.p.at_eol = 0; + c = dtp->u.p.last_char; + dtp->u.p.last_char = EOF - 1; + goto done; + } + + /* Read from line_buffer if enabled. */ + + if (dtp->u.p.line_buffer_enabled) + { + dtp->u.p.at_eol = 0; + + c = dtp->u.p.line_buffer[dtp->u.p.item_count]; + if (c != '\0' && dtp->u.p.item_count < 64) + { + dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0'; + dtp->u.p.item_count++; + goto done; + } + + dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_enabled = 0; + } + + /* Handle the end-of-record and end-of-file conditions for + internal array unit. */ + if (is_array_io (dtp)) + { + if (dtp->u.p.at_eof) + return EOF; + + /* Check for "end-of-record" condition. */ + if (dtp->u.p.current_unit->bytes_left == 0) + { + int finished; + + c = '\n'; + record = next_array_record (dtp, dtp->u.p.current_unit->ls, + &finished); + + /* Check for "end-of-file" condition. */ + if (finished) + { + dtp->u.p.at_eof = 1; + goto done; + } + + record *= dtp->u.p.current_unit->recl; + if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) + return EOF; + + dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; + goto done; + } + } + + /* Get the next character and handle end-of-record conditions. */ + + if (is_internal_unit (dtp)) + { + char cc; + length = sread (dtp->u.p.current_unit->s, &cc, 1); + c = cc; + if (length < 0) + { + generate_error (&dtp->common, LIBERROR_OS, NULL); + return '\0'; + } + + if (is_array_io (dtp)) + { + /* Check whether we hit EOF. */ + if (length == 0) + { + generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); + return '\0'; + } + dtp->u.p.current_unit->bytes_left--; + } + else + { + if (dtp->u.p.at_eof) + return EOF; + if (length == 0) + { + c = '\n'; + dtp->u.p.at_eof = 1; + } + } + } + else + { + c = fbuf_getc (dtp->u.p.current_unit); + if (c != EOF && is_stream_io (dtp)) + dtp->u.p.current_unit->strm_pos++; + } +done: + dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF); + return c; +} + + +/* Push a character back onto the input. */ + +static void +unget_char (st_parameter_dt *dtp, int c) +{ + dtp->u.p.last_char = c; +} + + +/* Skip over spaces in the input. Returns the nonspace character that + terminated the eating and also places it back on the input. */ + +static int +eat_spaces (st_parameter_dt *dtp) +{ + int c; + + do + c = next_char (dtp); + while (c != EOF && (c == ' ' || c == '\t')); + + unget_char (dtp, c); + return c; +} + + +/* This function reads characters through to the end of the current + line and just ignores them. Returns 0 for success and LIBERROR_END + if it hit EOF. */ + +static int +eat_line (st_parameter_dt *dtp) +{ + int c; + + do + c = next_char (dtp); + while (c != EOF && c != '\n'); + if (c == EOF) + return LIBERROR_END; + return 0; +} + + +/* Skip over a separator. Technically, we don't always eat the whole + separator. This is because if we've processed the last input item, + then a separator is unnecessary. Plus the fact that operating + systems usually deliver console input on a line basis. + + The upshot is that if we see a newline as part of reading a + separator, we stop reading. If there are more input items, we + continue reading the separator with finish_separator() which takes + care of the fact that we may or may not have seen a comma as part + of the separator. + + Returns 0 for success, and non-zero error code otherwise. */ + +static int +eat_separator (st_parameter_dt *dtp) +{ + int c, n; + int err = 0; + + eat_spaces (dtp); + dtp->u.p.comma_flag = 0; + + if ((c = next_char (dtp)) == EOF) + return LIBERROR_END; + switch (c) + { + case ',': + if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + { + unget_char (dtp, c); + break; + } + /* Fall through. */ + case ';': + dtp->u.p.comma_flag = 1; + eat_spaces (dtp); + break; + + case '/': + dtp->u.p.input_complete = 1; + break; + + case '\r': + dtp->u.p.at_eol = 1; + if ((n = next_char(dtp)) == EOF) + return LIBERROR_END; + if (n != '\n') + { + unget_char (dtp, n); + break; + } + /* Fall through. */ + case '\n': + dtp->u.p.at_eol = 1; + if (dtp->u.p.namelist_mode) + { + do + { + if ((c = next_char (dtp)) == EOF) + return LIBERROR_END; + if (c == '!') + { + err = eat_line (dtp); + if (err) + return err; + c = '\n'; + } + } + while (c == '\n' || c == '\r' || c == ' ' || c == '\t'); + unget_char (dtp, c); + } + break; + + case '!': + if (dtp->u.p.namelist_mode) + { /* Eat a namelist comment. */ + err = eat_line (dtp); + if (err) + return err; + + break; + } + + /* Fall Through... */ + + default: + unget_char (dtp, c); + break; + } + return err; +} + + +/* Finish processing a separator that was interrupted by a newline. + If we're here, then another data item is present, so we finish what + we started on the previous line. Return 0 on success, error code + on failure. */ + +static int +finish_separator (st_parameter_dt *dtp) +{ + int c; + int err; + + restart: + eat_spaces (dtp); + + if ((c = next_char (dtp)) == EOF) + return LIBERROR_END; + switch (c) + { + case ',': + if (dtp->u.p.comma_flag) + unget_char (dtp, c); + else + { + if ((c = eat_spaces (dtp)) == EOF) + return LIBERROR_END; + if (c == '\n' || c == '\r') + goto restart; + } + + break; + + case '/': + dtp->u.p.input_complete = 1; + if (!dtp->u.p.namelist_mode) + return err; + break; + + case '\n': + case '\r': + goto restart; + + case '!': + if (dtp->u.p.namelist_mode) + { + err = eat_line (dtp); + if (err) + return err; + goto restart; + } + + default: + unget_char (dtp, c); + break; + } + return err; +} + + +/* This function is needed to catch bad conversions so that namelist can + attempt to see if dtp->u.p.saved_string contains a new object name rather + than a bad value. */ + +static int +nml_bad_return (st_parameter_dt *dtp, char c) +{ + if (dtp->u.p.namelist_mode) + { + dtp->u.p.nml_read_error = 1; + unget_char (dtp, c); + return 1; + } + return 0; +} + +/* Convert an unsigned string to an integer. The length value is -1 + if we are working on a repeat count. Returns nonzero if we have a + range problem. As a side effect, frees the dtp->u.p.saved_string. */ + +static int +convert_integer (st_parameter_dt *dtp, int length, int negative) +{ + char c, *buffer, message[100]; + int m; + GFC_INTEGER_LARGEST v, max, max10; + + buffer = dtp->u.p.saved_string; + v = 0; + + max = (length == -1) ? MAX_REPEAT : max_value (length, 1); + max10 = max / 10; + + for (;;) + { + c = *buffer++; + if (c == '\0') + break; + c -= '0'; + + if (v > max10) + goto overflow; + v = 10 * v; + + if (v > max - c) + goto overflow; + v += c; + } + + m = 0; + + if (length != -1) + { + if (negative) + v = -v; + set_integer (dtp->u.p.value, v, length); + } + else + { + dtp->u.p.repeat_count = v; + + if (dtp->u.p.repeat_count == 0) + { + sprintf (message, "Zero repeat count in item %d of list input", + dtp->u.p.item_count); + + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + m = 1; + } + } + + free_saved (dtp); + return m; + + overflow: + if (length == -1) + sprintf (message, "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); + else + sprintf (message, "Integer overflow while reading item %d", + dtp->u.p.item_count); + + free_saved (dtp); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + + return 1; +} + + +/* Parse a repeat count for logical and complex values which cannot + begin with a digit. Returns nonzero if we are done, zero if we + should continue on. */ + +static int +parse_repeat (st_parameter_dt *dtp) +{ + char message[100]; + int c, repeat; + + if ((c = next_char (dtp)) == EOF) + goto bad_repeat; + switch (c) + { + CASE_DIGITS: + repeat = c - '0'; + break; + + CASE_SEPARATORS: + unget_char (dtp, c); + eat_separator (dtp); + return 1; + + default: + unget_char (dtp, c); + return 0; + } + + for (;;) + { + c = next_char (dtp); + switch (c) + { + CASE_DIGITS: + repeat = 10 * repeat + c - '0'; + + if (repeat > MAX_REPEAT) + { + sprintf (message, + "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); + + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + return 1; + } + + break; + + case '*': + if (repeat == 0) + { + sprintf (message, + "Zero repeat count in item %d of list input", + dtp->u.p.item_count); + + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + return 1; + } + + goto done; + + default: + goto bad_repeat; + } + } + + done: + dtp->u.p.repeat_count = repeat; + return 0; + + bad_repeat: + + free_saved (dtp); + if (c == EOF) + { + hit_eof (dtp); + return 1; + } + else + eat_line (dtp); + sprintf (message, "Bad repeat count in item %d of list input", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + return 1; +} + + +/* To read a logical we have to look ahead in the input stream to make sure + there is not an equal sign indicating a variable name. To do this we use + line_buffer to point to a temporary buffer, pushing characters there for + possible later reading. */ + +static void +l_push_char (st_parameter_dt *dtp, char c) +{ + if (dtp->u.p.line_buffer == NULL) + { + dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE); + memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE); + } + + dtp->u.p.line_buffer[dtp->u.p.item_count++] = c; +} + + +/* Read a logical character on the input. */ + +static void +read_logical (st_parameter_dt *dtp, int length) +{ + char message[100]; + int c, i, v; + + if (parse_repeat (dtp)) + return; + + c = tolower (next_char (dtp)); + l_push_char (dtp, c); + switch (c) + { + case 't': + v = 1; + c = next_char (dtp); + l_push_char (dtp, c); + + if (!is_separator(c) && c != EOF) + goto possible_name; + + unget_char (dtp, c); + break; + case 'f': + v = 0; + c = next_char (dtp); + l_push_char (dtp, c); + + if (!is_separator(c) && c != EOF) + goto possible_name; + + unget_char (dtp, c); + break; + + case '.': + c = tolower (next_char (dtp)); + switch (c) + { + case 't': + v = 1; + break; + case 'f': + v = 0; + break; + default: + goto bad_logical; + } + + break; + + CASE_SEPARATORS: + unget_char (dtp, c); + eat_separator (dtp); + return; /* Null value. */ + + default: + /* Save the character in case it is the beginning + of the next object name. */ + unget_char (dtp, c); + goto bad_logical; + } + + dtp->u.p.saved_type = BT_LOGICAL; + dtp->u.p.saved_length = length; + + /* Eat trailing garbage. */ + do + c = next_char (dtp); + while (c != EOF && !is_separator (c)); + + unget_char (dtp, c); + eat_separator (dtp); + set_integer ((int *) dtp->u.p.value, v, length); + free_line (dtp); + + return; + + possible_name: + + for(i = 0; i < 63; i++) + { + c = next_char (dtp); + if (is_separator(c)) + { + /* All done if this is not a namelist read. */ + if (!dtp->u.p.namelist_mode) + goto logical_done; + + unget_char (dtp, c); + eat_separator (dtp); + c = next_char (dtp); + if (c != '=') + { + unget_char (dtp, c); + goto logical_done; + } + } + + l_push_char (dtp, c); + if (c == '=') + { + dtp->u.p.nml_read_error = 1; + dtp->u.p.line_buffer_enabled = 1; + dtp->u.p.item_count = 0; + return; + } + + } + + bad_logical: + + free_line (dtp); + + if (nml_bad_return (dtp, c)) + return; + + free_saved (dtp); + if (c == EOF) + { + hit_eof (dtp); + return; + } + else if (c != '\n') + eat_line (dtp); + sprintf (message, "Bad logical value while reading item %d", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + return; + + logical_done: + + dtp->u.p.saved_type = BT_LOGICAL; + dtp->u.p.saved_length = length; + set_integer ((int *) dtp->u.p.value, v, length); + free_saved (dtp); + free_line (dtp); +} + + +/* Reading integers is tricky because we can actually be reading a + repeat count. We have to store the characters in a buffer because + we could be reading an integer that is larger than the default int + used for repeat counts. */ + +static void +read_integer (st_parameter_dt *dtp, int length) +{ + char message[100]; + int c, negative; + + negative = 0; + + c = next_char (dtp); + switch (c) + { + case '-': + negative = 1; + /* Fall through... */ + + case '+': + if ((c = next_char (dtp)) == EOF) + goto bad_integer; + goto get_integer; + + CASE_SEPARATORS: /* Single null. */ + unget_char (dtp, c); + eat_separator (dtp); + return; + + CASE_DIGITS: + push_char (dtp, c); + break; + + default: + goto bad_integer; + } + + /* Take care of what may be a repeat count. */ + + for (;;) + { + c = next_char (dtp); + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + case '*': + push_char (dtp, '\0'); + goto repeat; + + CASE_SEPARATORS: /* Not a repeat count. */ + case EOF: + goto done; + + default: + goto bad_integer; + } + } + + repeat: + if (convert_integer (dtp, -1, 0)) + return; + + /* Get the real integer. */ + + if ((c = next_char (dtp)) == EOF) + goto bad_integer; + switch (c) + { + CASE_DIGITS: + break; + + CASE_SEPARATORS: + unget_char (dtp, c); + eat_separator (dtp); + return; + + case '-': + negative = 1; + /* Fall through... */ + + case '+': + c = next_char (dtp); + break; + } + + get_integer: + if (!isdigit (c)) + goto bad_integer; + push_char (dtp, c); + + for (;;) + { + c = next_char (dtp); + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + CASE_SEPARATORS: + goto done; + + default: + goto bad_integer; + } + } + + bad_integer: + + if (nml_bad_return (dtp, c)) + return; + + free_saved (dtp); + if (c == EOF) + { + hit_eof (dtp); + return; + } + else if (c != '\n') + eat_line (dtp); + sprintf (message, "Bad integer for item %d in list input", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + + return; + + done: + unget_char (dtp, c); + eat_separator (dtp); + + push_char (dtp, '\0'); + if (convert_integer (dtp, length, negative)) + { + free_saved (dtp); + return; + } + + free_saved (dtp); + dtp->u.p.saved_type = BT_INTEGER; +} + + +/* Read a character variable. */ + +static void +read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) +{ + char quote, message[100]; + int c; + + quote = ' '; /* Space means no quote character. */ + + if ((c = next_char (dtp)) == EOF) + goto eof; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + CASE_SEPARATORS: + unget_char (dtp, c); /* NULL value. */ + eat_separator (dtp); + return; + + case '"': + case '\'': + quote = c; + goto get_string; + + default: + if (dtp->u.p.namelist_mode) + { + unget_char (dtp, c); + return; + } + + push_char (dtp, c); + goto get_string; + } + + /* Deal with a possible repeat count. */ + + for (;;) + { + if ((c = next_char (dtp)) == EOF) + goto eof; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + CASE_SEPARATORS: + unget_char (dtp, c); + goto done; /* String was only digits! */ + + case '*': + push_char (dtp, '\0'); + goto got_repeat; + + default: + push_char (dtp, c); + goto get_string; /* Not a repeat count after all. */ + } + } + + got_repeat: + if (convert_integer (dtp, -1, 0)) + return; + + /* Now get the real string. */ + + if ((c = next_char (dtp)) == EOF) + goto eof; + switch (c) + { + CASE_SEPARATORS: + unget_char (dtp, c); /* Repeated NULL values. */ + eat_separator (dtp); + return; + + case '"': + case '\'': + quote = c; + break; + + default: + push_char (dtp, c); + break; + } + + get_string: + for (;;) + { + if ((c = next_char (dtp)) == EOF) + goto done_eof; + switch (c) + { + case '"': + case '\'': + if (c != quote) + { + push_char (dtp, c); + break; + } + + /* See if we have a doubled quote character or the end of + the string. */ + + if ((c = next_char (dtp)) == EOF) + goto eof; + if (c == quote) + { + push_char (dtp, quote); + break; + } + + unget_char (dtp, c); + goto done; + + CASE_SEPARATORS: + if (quote == ' ') + { + unget_char (dtp, c); + goto done; + } + + if (c != '\n' && c != '\r') + push_char (dtp, c); + break; + + default: + push_char (dtp, c); + break; + } + } + + /* At this point, we have to have a separator, or else the string is + invalid. */ + done: + c = next_char (dtp); + done_eof: + if (is_separator (c) || c == '!' || c == EOF) + { + unget_char (dtp, c); + eat_separator (dtp); + dtp->u.p.saved_type = BT_CHARACTER; + free_line (dtp); + } + else + { + free_saved (dtp); + sprintf (message, "Invalid string input in item %d", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + } + return; + + eof: + free_saved (dtp); + hit_eof (dtp); +} + + +/* Parse a component of a complex constant or a real number that we + are sure is already there. This is a straight real number parser. */ + +static int +parse_real (st_parameter_dt *dtp, void *buffer, int length) +{ + char message[100]; + int c, m, seen_dp; + + if ((c = next_char (dtp)) == EOF) + goto bad; + + if (c == '-' || c == '+') + { + push_char (dtp, c); + if ((c = next_char (dtp)) == EOF) + goto bad; + } + + if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + c = '.'; + + if (!isdigit (c) && c != '.') + { + if (c == 'i' || c == 'I' || c == 'n' || c == 'N') + goto inf_nan; + else + goto bad; + } + + push_char (dtp, c); + + seen_dp = (c == '.') ? 1 : 0; + + for (;;) + { + if ((c = next_char (dtp)) == EOF) + goto bad; + if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + c = '.'; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + case '.': + if (seen_dp) + goto bad; + + seen_dp = 1; + push_char (dtp, c); + break; + + case 'e': + case 'E': + case 'd': + case 'D': + push_char (dtp, 'e'); + goto exp1; + + case '-': + case '+': + push_char (dtp, 'e'); + push_char (dtp, c); + if ((c = next_char (dtp)) == EOF) + goto bad; + goto exp2; + + CASE_SEPARATORS: + goto done; + + default: + goto done; + } + } + + exp1: + if ((c = next_char (dtp)) == EOF) + goto bad; + if (c != '-' && c != '+') + push_char (dtp, '+'); + else + { + push_char (dtp, c); + c = next_char (dtp); + } + + exp2: + if (!isdigit (c)) + goto bad; + + push_char (dtp, c); + + for (;;) + { + if ((c = next_char (dtp)) == EOF) + goto bad; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + CASE_SEPARATORS: + unget_char (dtp, c); + goto done; + + default: + goto done; + } + } + + done: + unget_char (dtp, c); + push_char (dtp, '\0'); + + m = convert_real (dtp, buffer, dtp->u.p.saved_string, length); + free_saved (dtp); + + return m; + + inf_nan: + /* Match INF and Infinity. */ + if ((c == 'i' || c == 'I') + && ((c = next_char (dtp)) == 'n' || c == 'N') + && ((c = next_char (dtp)) == 'f' || c == 'F')) + { + c = next_char (dtp); + if ((c != 'i' && c != 'I') + || ((c == 'i' || c == 'I') + && ((c = next_char (dtp)) == 'n' || c == 'N') + && ((c = next_char (dtp)) == 'i' || c == 'I') + && ((c = next_char (dtp)) == 't' || c == 'T') + && ((c = next_char (dtp)) == 'y' || c == 'Y') + && (c = next_char (dtp)))) + { + if (is_separator (c)) + unget_char (dtp, c); + push_char (dtp, 'i'); + push_char (dtp, 'n'); + push_char (dtp, 'f'); + goto done; + } + } /* Match NaN. */ + else if (((c = next_char (dtp)) == 'a' || c == 'A') + && ((c = next_char (dtp)) == 'n' || c == 'N') + && (c = next_char (dtp))) + { + if (is_separator (c)) + unget_char (dtp, c); + push_char (dtp, 'n'); + push_char (dtp, 'a'); + push_char (dtp, 'n'); + + /* Match "NAN(alphanum)". */ + if (c == '(') + { + for ( ; c != ')'; c = next_char (dtp)) + if (is_separator (c)) + goto bad; + + c = next_char (dtp); + if (is_separator (c)) + unget_char (dtp, c); + } + goto done; + } + + bad: + + if (nml_bad_return (dtp, c)) + return 0; + + free_saved (dtp); + if (c == EOF) + { + hit_eof (dtp); + return 1; + } + else if (c != '\n') + eat_line (dtp); + sprintf (message, "Bad floating point number for item %d", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + + return 1; +} + + +/* Reading a complex number is straightforward because we can tell + what it is right away. */ + +static void +read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size) +{ + char message[100]; + int c; + + if (parse_repeat (dtp)) + return; + + c = next_char (dtp); + switch (c) + { + case '(': + break; + + CASE_SEPARATORS: + unget_char (dtp, c); + eat_separator (dtp); + return; + + default: + goto bad_complex; + } + +eol_1: + eat_spaces (dtp); + c = next_char (dtp); + if (c == '\n' || c== '\r') + goto eol_1; + else + unget_char (dtp, c); + + if (parse_real (dtp, dest, kind)) + return; + +eol_2: + eat_spaces (dtp); + c = next_char (dtp); + if (c == '\n' || c== '\r') + goto eol_2; + else + unget_char (dtp, c); + + if (next_char (dtp) + != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';')) + goto bad_complex; + +eol_3: + eat_spaces (dtp); + c = next_char (dtp); + if (c == '\n' || c== '\r') + goto eol_3; + else + unget_char (dtp, c); + + if (parse_real (dtp, dest + size / 2, kind)) + return; + +eol_4: + eat_spaces (dtp); + c = next_char (dtp); + if (c == '\n' || c== '\r') + goto eol_4; + else + unget_char (dtp, c); + + if (next_char (dtp) != ')') + goto bad_complex; + + c = next_char (dtp); + if (!is_separator (c)) + goto bad_complex; + + unget_char (dtp, c); + eat_separator (dtp); + + free_saved (dtp); + dtp->u.p.saved_type = BT_COMPLEX; + return; + + bad_complex: + + if (nml_bad_return (dtp, c)) + return; + + free_saved (dtp); + if (c == EOF) + { + hit_eof (dtp); + return; + } + else if (c != '\n') + eat_line (dtp); + sprintf (message, "Bad complex value in item %d of list input", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); +} + + +/* Parse a real number with a possible repeat count. */ + +static void +read_real (st_parameter_dt *dtp, void * dest, int length) +{ + char message[100]; + int c; + int seen_dp; + int is_inf; + + seen_dp = 0; + + c = next_char (dtp); + if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + c = '.'; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + case '.': + push_char (dtp, c); + seen_dp = 1; + break; + + case '+': + case '-': + goto got_sign; + + CASE_SEPARATORS: + unget_char (dtp, c); /* Single null. */ + eat_separator (dtp); + return; + + case 'i': + case 'I': + case 'n': + case 'N': + goto inf_nan; + + default: + goto bad_real; + } + + /* Get the digit string that might be a repeat count. */ + + for (;;) + { + c = next_char (dtp); + if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + c = '.'; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + case '.': + if (seen_dp) + goto bad_real; + + seen_dp = 1; + push_char (dtp, c); + goto real_loop; + + case 'E': + case 'e': + case 'D': + case 'd': + goto exp1; + + case '+': + case '-': + push_char (dtp, 'e'); + push_char (dtp, c); + c = next_char (dtp); + goto exp2; + + case '*': + push_char (dtp, '\0'); + goto got_repeat; + + CASE_SEPARATORS: + if (c != '\n' && c != ',' && c != '\r' && c != ';') + unget_char (dtp, c); + goto done; + + default: + goto bad_real; + } + } + + got_repeat: + if (convert_integer (dtp, -1, 0)) + return; + + /* Now get the number itself. */ + + if ((c = next_char (dtp)) == EOF) + goto bad_real; + if (is_separator (c)) + { /* Repeated null value. */ + unget_char (dtp, c); + eat_separator (dtp); + return; + } + + if (c != '-' && c != '+') + push_char (dtp, '+'); + else + { + got_sign: + push_char (dtp, c); + if ((c = next_char (dtp)) == EOF) + goto bad_real; + } + + if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + c = '.'; + + if (!isdigit (c) && c != '.') + { + if (c == 'i' || c == 'I' || c == 'n' || c == 'N') + goto inf_nan; + else + goto bad_real; + } + + if (c == '.') + { + if (seen_dp) + goto bad_real; + else + seen_dp = 1; + } + + push_char (dtp, c); + + real_loop: + for (;;) + { + c = next_char (dtp); + if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) + c = '.'; + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + CASE_SEPARATORS: + case EOF: + goto done; + + case '.': + if (seen_dp) + goto bad_real; + + seen_dp = 1; + push_char (dtp, c); + break; + + case 'E': + case 'e': + case 'D': + case 'd': + goto exp1; + + case '+': + case '-': + push_char (dtp, 'e'); + push_char (dtp, c); + c = next_char (dtp); + goto exp2; + + default: + goto bad_real; + } + } + + exp1: + push_char (dtp, 'e'); + + if ((c = next_char (dtp)) == EOF) + goto bad_real; + if (c != '+' && c != '-') + push_char (dtp, '+'); + else + { + push_char (dtp, c); + c = next_char (dtp); + } + + exp2: + if (!isdigit (c)) + goto bad_real; + push_char (dtp, c); + + for (;;) + { + c = next_char (dtp); + + switch (c) + { + CASE_DIGITS: + push_char (dtp, c); + break; + + CASE_SEPARATORS: + case EOF: + goto done; + + default: + goto bad_real; + } + } + + done: + unget_char (dtp, c); + eat_separator (dtp); + push_char (dtp, '\0'); + if (convert_real (dtp, dest, dtp->u.p.saved_string, length)) + return; + + free_saved (dtp); + dtp->u.p.saved_type = BT_REAL; + return; + + inf_nan: + l_push_char (dtp, c); + is_inf = 0; + + /* Match INF and Infinity. */ + if (c == 'i' || c == 'I') + { + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'n' && c != 'N') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'f' && c != 'F') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (!is_separator (c)) + { + if (c != 'i' && c != 'I') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'n' && c != 'N') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'i' && c != 'I') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 't' && c != 'T') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'y' && c != 'Y') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + } + is_inf = 1; + } /* Match NaN. */ + else + { + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'a' && c != 'A') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'n' && c != 'N') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + + /* Match NAN(alphanum). */ + if (c == '(') + { + for (c = next_char (dtp); c != ')'; c = next_char (dtp)) + if (is_separator (c)) + goto unwind; + else + l_push_char (dtp, c); + + l_push_char (dtp, ')'); + c = next_char (dtp); + l_push_char (dtp, c); + } + } + + if (!is_separator (c)) + goto unwind; + + if (dtp->u.p.namelist_mode) + { + if (c == ' ' || c =='\n' || c == '\r') + { + do + { + if ((c = next_char (dtp)) == EOF) + goto bad_real; + } + while (c == ' ' || c =='\n' || c == '\r'); + + l_push_char (dtp, c); + + if (c == '=') + goto unwind; + } + } + + if (is_inf) + { + push_char (dtp, 'i'); + push_char (dtp, 'n'); + push_char (dtp, 'f'); + } + else + { + push_char (dtp, 'n'); + push_char (dtp, 'a'); + push_char (dtp, 'n'); + } + + free_line (dtp); + goto done; + + unwind: + if (dtp->u.p.namelist_mode) + { + dtp->u.p.nml_read_error = 1; + dtp->u.p.line_buffer_enabled = 1; + dtp->u.p.item_count = 0; + return; + } + + bad_real: + + if (nml_bad_return (dtp, c)) + return; + + free_saved (dtp); + if (c == EOF) + { + hit_eof (dtp); + return; + } + else if (c != '\n') + eat_line (dtp); + + sprintf (message, "Bad real number in item %d of list input", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); +} + + +/* Check the current type against the saved type to make sure they are + compatible. Returns nonzero if incompatible. */ + +static int +check_type (st_parameter_dt *dtp, bt type, int len) +{ + char message[100]; + + if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) + { + sprintf (message, "Read type %s where %s was expected for item %d", + type_name (dtp->u.p.saved_type), type_name (type), + dtp->u.p.item_count); + + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + return 1; + } + + if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER) + return 0; + + if (dtp->u.p.saved_length != len) + { + sprintf (message, + "Read kind %d %s where kind %d is required for item %d", + dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len, + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + return 1; + } + + return 0; +} + + +/* Top level data transfer subroutine for list reads. Because we have + to deal with repeat counts, the data item is always saved after + reading, usually in the dtp->u.p.value[] array. If a repeat count is + greater than one, we copy the data item multiple times. */ + +static int +list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, + int kind, size_t size) +{ + gfc_char4_t *q; + int c, i, m; + int err = 0; + + dtp->u.p.namelist_mode = 0; + + if (dtp->u.p.first_item) + { + dtp->u.p.first_item = 0; + dtp->u.p.input_complete = 0; + dtp->u.p.repeat_count = 1; + dtp->u.p.at_eol = 0; + + if ((c = eat_spaces (dtp)) == EOF) + { + err = LIBERROR_END; + goto cleanup; + } + if (is_separator (c)) + { + /* Found a null value. */ + eat_separator (dtp); + dtp->u.p.repeat_count = 0; + + /* eat_separator sets this flag if the separator was a comma. */ + if (dtp->u.p.comma_flag) + goto cleanup; + + /* eat_separator sets this flag if the separator was a \n or \r. */ + if (dtp->u.p.at_eol) + finish_separator (dtp); + else + goto cleanup; + } + + } + else + { + if (dtp->u.p.repeat_count > 0) + { + if (check_type (dtp, type, kind)) + return err; + goto set_value; + } + + if (dtp->u.p.input_complete) + goto cleanup; + + if (dtp->u.p.at_eol) + finish_separator (dtp); + else + { + eat_spaces (dtp); + /* Trailing spaces prior to end of line. */ + if (dtp->u.p.at_eol) + finish_separator (dtp); + } + + dtp->u.p.saved_type = BT_UNKNOWN; + dtp->u.p.repeat_count = 1; + } + + switch (type) + { + case BT_INTEGER: + read_integer (dtp, kind); + break; + case BT_LOGICAL: + read_logical (dtp, kind); + break; + case BT_CHARACTER: + read_character (dtp, kind); + break; + case BT_REAL: + read_real (dtp, p, kind); + /* Copy value back to temporary if needed. */ + if (dtp->u.p.repeat_count > 0) + memcpy (dtp->u.p.value, p, kind); + break; + case BT_COMPLEX: + read_complex (dtp, p, kind, size); + /* Copy value back to temporary if needed. */ + if (dtp->u.p.repeat_count > 0) + memcpy (dtp->u.p.value, p, size); + break; + default: + internal_error (&dtp->common, "Bad type for list read"); + } + + if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN) + dtp->u.p.saved_length = size; + + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) + goto cleanup; + + set_value: + switch (dtp->u.p.saved_type) + { + case BT_COMPLEX: + case BT_REAL: + if (dtp->u.p.repeat_count > 0) + memcpy (p, dtp->u.p.value, size); + break; + + case BT_INTEGER: + case BT_LOGICAL: + memcpy (p, dtp->u.p.value, size); + break; + + case BT_CHARACTER: + if (dtp->u.p.saved_string) + { + m = ((int) size < dtp->u.p.saved_used) + ? (int) size : dtp->u.p.saved_used; + if (kind == 1) + memcpy (p, dtp->u.p.saved_string, m); + else + { + q = (gfc_char4_t *) p; + for (i = 0; i < m; i++) + q[i] = (unsigned char) dtp->u.p.saved_string[i]; + } + } + else + /* Just delimiters encountered, nothing to copy but SPACE. */ + m = 0; + + if (m < (int) size) + { + if (kind == 1) + memset (((char *) p) + m, ' ', size - m); + else + { + q = (gfc_char4_t *) p; + for (i = m; i < (int) size; i++) + q[i] = (unsigned char) ' '; + } + } + break; + + case BT_UNKNOWN: + break; + + default: + internal_error (&dtp->common, "Bad type for list read"); + } + + if (--dtp->u.p.repeat_count <= 0) + free_saved (dtp); + +cleanup: + if (err == LIBERROR_END) + hit_eof (dtp); + return err; +} + + +void +list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind, + size_t size, size_t nelems) +{ + size_t elem; + char *tmp; + size_t stride = type == BT_CHARACTER ? + size * GFC_SIZE_OF_CHAR_KIND(kind) : size; + int err; + + tmp = (char *) p; + + /* Big loop over all the elements. */ + for (elem = 0; elem < nelems; elem++) + { + dtp->u.p.item_count++; + err = list_formatted_read_scalar (dtp, type, tmp + stride*elem, + kind, size); + if (err) + break; + } +} + + +/* Finish a list read. */ + +void +finish_list_read (st_parameter_dt *dtp) +{ + int err; + + free_saved (dtp); + + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); + + if (dtp->u.p.at_eol) + { + dtp->u.p.at_eol = 0; + return; + } + + err = eat_line (dtp); + if (err == LIBERROR_END) + hit_eof (dtp); +} + +/* NAMELIST INPUT + +void namelist_read (st_parameter_dt *dtp) +calls: + static void nml_match_name (char *name, int len) + static int nml_query (st_parameter_dt *dtp) + static int nml_get_obj_data (st_parameter_dt *dtp, + namelist_info **prev_nl, char *, size_t) +calls: + static void nml_untouch_nodes (st_parameter_dt *dtp) + static namelist_info * find_nml_node (st_parameter_dt *dtp, + char * var_name) + static int nml_parse_qualifier(descriptor_dimension * ad, + array_loop_spec * ls, int rank, char *) + static void nml_touch_nodes (namelist_info * nl) + static int nml_read_obj (namelist_info *nl, index_type offset, + namelist_info **prev_nl, char *, size_t, + index_type clow, index_type chigh) +calls: + -itself- */ + +/* Inputs a rank-dimensional qualifier, which can contain + singlets, doublets, triplets or ':' with the standard meanings. */ + +static try +nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, + array_loop_spec *ls, int rank, char *parse_err_msg, + int *parsed_rank) +{ + int dim; + int indx; + int neg; + int null_flag; + int is_array_section, is_char; + int c; + + is_char = 0; + is_array_section = 0; + dtp->u.p.expanded_read = 0; + + /* See if this is a character substring qualifier we are looking for. */ + if (rank == -1) + { + rank = 1; + is_char = 1; + } + + /* The next character in the stream should be the '('. */ + + if ((c = next_char (dtp)) == EOF) + return FAILURE; + + /* Process the qualifier, by dimension and triplet. */ + + for (dim=0; dim < rank; dim++ ) + { + for (indx=0; indx<3; indx++) + { + free_saved (dtp); + eat_spaces (dtp); + neg = 0; + + /* Process a potential sign. */ + if ((c = next_char (dtp)) == EOF) + return FAILURE; + switch (c) + { + case '-': + neg = 1; + break; + + case '+': + break; + + default: + unget_char (dtp, c); + break; + } + + /* Process characters up to the next ':' , ',' or ')'. */ + for (;;) + { + if ((c = next_char (dtp)) == EOF) + return FAILURE; + + switch (c) + { + case ':': + is_array_section = 1; + break; + + case ',': case ')': + if ((c==',' && dim == rank -1) + || (c==')' && dim < rank -1)) + { + if (is_char) + sprintf (parse_err_msg, "Bad substring qualifier"); + else + sprintf (parse_err_msg, "Bad number of index fields"); + goto err_ret; + } + break; + + CASE_DIGITS: + push_char (dtp, c); + continue; + + case ' ': case '\t': + eat_spaces (dtp); + if ((c = next_char (dtp) == EOF)) + return FAILURE; + break; + + default: + if (is_char) + sprintf (parse_err_msg, + "Bad character in substring qualifier"); + else + sprintf (parse_err_msg, "Bad character in index"); + goto err_ret; + } + + if ((c == ',' || c == ')') && indx == 0 + && dtp->u.p.saved_string == 0) + { + if (is_char) + sprintf (parse_err_msg, "Null substring qualifier"); + else + sprintf (parse_err_msg, "Null index field"); + goto err_ret; + } + + if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0) + || (indx == 2 && dtp->u.p.saved_string == 0)) + { + if (is_char) + sprintf (parse_err_msg, "Bad substring qualifier"); + else + sprintf (parse_err_msg, "Bad index triplet"); + goto err_ret; + } + + if (is_char && !is_array_section) + { + sprintf (parse_err_msg, + "Missing colon in substring qualifier"); + goto err_ret; + } + + /* If '( : ? )' or '( ? : )' break and flag read failure. */ + null_flag = 0; + if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0) + || (indx==1 && dtp->u.p.saved_string == 0)) + { + null_flag = 1; + break; + } + + /* Now read the index. */ + if (convert_integer (dtp, sizeof(ssize_t), neg)) + { + if (is_char) + sprintf (parse_err_msg, "Bad integer substring qualifier"); + else + sprintf (parse_err_msg, "Bad integer in index"); + goto err_ret; + } + break; + } + + /* Feed the index values to the triplet arrays. */ + if (!null_flag) + { + if (indx == 0) + memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t)); + if (indx == 1) + memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t)); + if (indx == 2) + memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t)); + } + + /* Singlet or doublet indices. */ + if (c==',' || c==')') + { + if (indx == 0) + { + memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t)); + + /* If -std=f95/2003 or an array section is specified, + do not allow excess data to be processed. */ + if (is_array_section == 1 + || !(compile_options.allow_std & GFC_STD_GNU) + || dtp->u.p.ionml->type == BT_DERIVED) + ls[dim].end = ls[dim].start; + else + dtp->u.p.expanded_read = 1; + } + + /* Check for non-zero rank. */ + if (is_array_section == 1 && ls[dim].start != ls[dim].end) + *parsed_rank = 1; + + break; + } + } + + if (is_array_section == 1 && dtp->u.p.expanded_read == 1) + { + int i; + dtp->u.p.expanded_read = 0; + for (i = 0; i < dim; i++) + ls[i].end = ls[i].start; + } + + /* Check the values of the triplet indices. */ + if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim])) + || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])) + || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim])) + || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))) + { + if (is_char) + sprintf (parse_err_msg, "Substring out of range"); + else + sprintf (parse_err_msg, "Index %d out of range", dim + 1); + goto err_ret; + } + + if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) + || (ls[dim].step == 0)) + { + sprintf (parse_err_msg, "Bad range in index %d", dim + 1); + goto err_ret; + } + + /* Initialise the loop index counter. */ + ls[dim].idx = ls[dim].start; + } + eat_spaces (dtp); + return SUCCESS; + +err_ret: + + return FAILURE; +} + +static namelist_info * +find_nml_node (st_parameter_dt *dtp, char * var_name) +{ + namelist_info * t = dtp->u.p.ionml; + while (t != NULL) + { + if (strcmp (var_name, t->var_name) == 0) + { + t->touched = 1; + return t; + } + t = t->next; + } + return NULL; +} + +/* Visits all the components of a derived type that have + not explicitly been identified in the namelist input. + touched is set and the loop specification initialised + to default values */ + +static void +nml_touch_nodes (namelist_info * nl) +{ + index_type len = strlen (nl->var_name) + 1; + int dim; + char * ext_name = (char*)get_mem (len + 1); + memcpy (ext_name, nl->var_name, len-1); + memcpy (ext_name + len - 1, "%", 2); + for (nl = nl->next; nl; nl = nl->next) + { + if (strncmp (nl->var_name, ext_name, len) == 0) + { + nl->touched = 1; + for (dim=0; dim < nl->var_rank; dim++) + { + nl->ls[dim].step = 1; + nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); + nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); + nl->ls[dim].idx = nl->ls[dim].start; + } + } + else + break; + } + free (ext_name); + return; +} + +/* Resets touched for the entire list of nml_nodes, ready for a + new object. */ + +static void +nml_untouch_nodes (st_parameter_dt *dtp) +{ + namelist_info * t; + for (t = dtp->u.p.ionml; t; t = t->next) + t->touched = 0; + return; +} + +/* Attempts to input name to namelist name. Returns + dtp->u.p.nml_read_error = 1 on no match. */ + +static void +nml_match_name (st_parameter_dt *dtp, const char *name, index_type len) +{ + index_type i; + int c; + + dtp->u.p.nml_read_error = 0; + for (i = 0; i < len; i++) + { + c = next_char (dtp); + if (c == EOF || (tolower (c) != tolower (name[i]))) + { + dtp->u.p.nml_read_error = 1; + break; + } + } +} + +/* If the namelist read is from stdin, output the current state of the + namelist to stdout. This is used to implement the non-standard query + features, ? and =?. If c == '=' the full namelist is printed. Otherwise + the names alone are printed. */ + +static void +nml_query (st_parameter_dt *dtp, char c) +{ + gfc_unit * temp_unit; + namelist_info * nl; + index_type len; + char * p; +#ifdef HAVE_CRLF + static const index_type endlen = 2; + static const char endl[] = "\r\n"; + static const char nmlend[] = "&end\r\n"; +#else + static const index_type endlen = 1; + static const char endl[] = "\n"; + static const char nmlend[] = "&end\n"; +#endif + + if (dtp->u.p.current_unit->unit_number != options.stdin_unit) + return; + + /* Store the current unit and transfer to stdout. */ + + temp_unit = dtp->u.p.current_unit; + dtp->u.p.current_unit = find_unit (options.stdout_unit); + + if (dtp->u.p.current_unit) + { + dtp->u.p.mode = WRITING; + next_record (dtp, 0); + + /* Write the namelist in its entirety. */ + + if (c == '=') + namelist_write (dtp); + + /* Or write the list of names. */ + + else + { + /* "&namelist_name\n" */ + + len = dtp->namelist_name_len; + p = write_block (dtp, len - 1 + endlen); + if (!p) + goto query_return; + memcpy (p, "&", 1); + memcpy ((char*)(p + 1), dtp->namelist_name, len); + memcpy ((char*)(p + len + 1), &endl, endlen); + for (nl = dtp->u.p.ionml; nl; nl = nl->next) + { + /* " var_name\n" */ + + len = strlen (nl->var_name); + p = write_block (dtp, len + endlen); + if (!p) + goto query_return; + memcpy (p, " ", 1); + memcpy ((char*)(p + 1), nl->var_name, len); + memcpy ((char*)(p + len + 1), &endl, endlen); + } + + /* "&end\n" */ + + p = write_block (dtp, endlen + 4); + if (!p) + goto query_return; + memcpy (p, &nmlend, endlen + 4); + } + + /* Flush the stream to force immediate output. */ + + fbuf_flush (dtp->u.p.current_unit, WRITING); + sflush (dtp->u.p.current_unit->s); + unlock_unit (dtp->u.p.current_unit); + } + +query_return: + + /* Restore the current unit. */ + + dtp->u.p.current_unit = temp_unit; + dtp->u.p.mode = READING; + return; +} + +/* Reads and stores the input for the namelist object nl. For an array, + the function loops over the ranges defined by the loop specification. + This default to all the data or to the specification from a qualifier. + nml_read_obj recursively calls itself to read derived types. It visits + all its own components but only reads data for those that were touched + when the name was parsed. If a read error is encountered, an attempt is + made to return to read a new object name because the standard allows too + little data to be available. On the other hand, too much data is an + error. */ + +static try +nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, + namelist_info **pprev_nl, char *nml_err_msg, + size_t nml_err_msg_size, index_type clow, index_type chigh) +{ + namelist_info * cmp; + char * obj_name; + int nml_carry; + int len; + int dim; + index_type dlen; + index_type m; + size_t obj_name_len; + void * pdata; + + /* This object not touched in name parsing. */ + + if (!nl->touched) + return SUCCESS; + + dtp->u.p.repeat_count = 0; + eat_spaces (dtp); + + len = nl->len; + switch (nl->type) + { + case BT_INTEGER: + case BT_LOGICAL: + dlen = len; + break; + + case BT_REAL: + dlen = size_from_real_kind (len); + break; + + case BT_COMPLEX: + dlen = size_from_complex_kind (len); + break; + + case BT_CHARACTER: + dlen = chigh ? (chigh - clow + 1) : nl->string_length; + break; + + default: + dlen = 0; + } + + do + { + /* Update the pointer to the data, using the current index vector */ + + pdata = (void*)(nl->mem_pos + offset); + for (dim = 0; dim < nl->var_rank; dim++) + pdata = (void*)(pdata + (nl->ls[dim].idx + - GFC_DESCRIPTOR_LBOUND(nl,dim)) + * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size); + + /* Reset the error flag and try to read next value, if + dtp->u.p.repeat_count=0 */ + + dtp->u.p.nml_read_error = 0; + nml_carry = 0; + if (--dtp->u.p.repeat_count <= 0) + { + if (dtp->u.p.input_complete) + return SUCCESS; + if (dtp->u.p.at_eol) + finish_separator (dtp); + if (dtp->u.p.input_complete) + return SUCCESS; + + dtp->u.p.saved_type = BT_UNKNOWN; + free_saved (dtp); + + switch (nl->type) + { + case BT_INTEGER: + read_integer (dtp, len); + break; + + case BT_LOGICAL: + read_logical (dtp, len); + break; + + case BT_CHARACTER: + read_character (dtp, len); + break; + + case BT_REAL: + /* Need to copy data back from the real location to the temp in order + to handle nml reads into arrays. */ + read_real (dtp, pdata, len); + memcpy (dtp->u.p.value, pdata, dlen); + break; + + case BT_COMPLEX: + /* Same as for REAL, copy back to temp. */ + read_complex (dtp, pdata, len, dlen); + memcpy (dtp->u.p.value, pdata, dlen); + break; + + case BT_DERIVED: + obj_name_len = strlen (nl->var_name) + 1; + obj_name = get_mem (obj_name_len+1); + memcpy (obj_name, nl->var_name, obj_name_len-1); + memcpy (obj_name + obj_name_len - 1, "%", 2); + + /* If reading a derived type, disable the expanded read warning + since a single object can have multiple reads. */ + dtp->u.p.expanded_read = 0; + + /* Now loop over the components. Update the component pointer + with the return value from nml_write_obj. This loop jumps + past nested derived types by testing if the potential + component name contains '%'. */ + + for (cmp = nl->next; + cmp && + !strncmp (cmp->var_name, obj_name, obj_name_len) && + !strchr (cmp->var_name + obj_name_len, '%'); + cmp = cmp->next) + { + + if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos), + pprev_nl, nml_err_msg, nml_err_msg_size, + clow, chigh) == FAILURE) + { + free (obj_name); + return FAILURE; + } + + if (dtp->u.p.input_complete) + { + free (obj_name); + return SUCCESS; + } + } + + free (obj_name); + goto incr_idx; + + default: + snprintf (nml_err_msg, nml_err_msg_size, + "Bad type for namelist object %s", nl->var_name); + internal_error (&dtp->common, nml_err_msg); + goto nml_err_ret; + } + } + + /* The standard permits array data to stop short of the number of + elements specified in the loop specification. In this case, we + should be here with dtp->u.p.nml_read_error != 0. Control returns to + nml_get_obj_data and an attempt is made to read object name. */ + + *pprev_nl = nl; + if (dtp->u.p.nml_read_error) + { + dtp->u.p.expanded_read = 0; + return SUCCESS; + } + + if (dtp->u.p.saved_type == BT_UNKNOWN) + { + dtp->u.p.expanded_read = 0; + goto incr_idx; + } + + switch (dtp->u.p.saved_type) + { + + case BT_COMPLEX: + case BT_REAL: + case BT_INTEGER: + case BT_LOGICAL: + memcpy (pdata, dtp->u.p.value, dlen); + break; + + case BT_CHARACTER: + if (dlen < dtp->u.p.saved_used) + { + if (compile_options.bounds_check) + { + snprintf (nml_err_msg, nml_err_msg_size, + "Namelist object '%s' truncated on read.", + nl->var_name); + generate_warning (&dtp->common, nml_err_msg); + } + m = dlen; + } + else + m = dtp->u.p.saved_used; + pdata = (void*)( pdata + clow - 1 ); + memcpy (pdata, dtp->u.p.saved_string, m); + if (m < dlen) + memset ((void*)( pdata + m ), ' ', dlen - m); + break; + + default: + break; + } + + /* Warn if a non-standard expanded read occurs. A single read of a + single object is acceptable. If a second read occurs, issue a warning + and set the flag to zero to prevent further warnings. */ + if (dtp->u.p.expanded_read == 2) + { + notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read."); + dtp->u.p.expanded_read = 0; + } + + /* If the expanded read warning flag is set, increment it, + indicating that a single read has occurred. */ + if (dtp->u.p.expanded_read >= 1) + dtp->u.p.expanded_read++; + + /* Break out of loop if scalar. */ + if (!nl->var_rank) + break; + + /* Now increment the index vector. */ + +incr_idx: + + nml_carry = 1; + for (dim = 0; dim < nl->var_rank; dim++) + { + nl->ls[dim].idx += nml_carry * nl->ls[dim].step; + nml_carry = 0; + if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end)) + || + ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end))) + { + nl->ls[dim].idx = nl->ls[dim].start; + nml_carry = 1; + } + } + } while (!nml_carry); + + if (dtp->u.p.repeat_count > 1) + { + snprintf (nml_err_msg, nml_err_msg_size, + "Repeat count too large for namelist object %s", nl->var_name); + goto nml_err_ret; + } + return SUCCESS; + +nml_err_ret: + + return FAILURE; +} + +/* Parses the object name, including array and substring qualifiers. It + iterates over derived type components, touching those components and + setting their loop specifications, if there is a qualifier. If the + object is itself a derived type, its components and subcomponents are + touched. nml_read_obj is called at the end and this reads the data in + the manner specified by the object name. */ + +static try +nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, + char *nml_err_msg, size_t nml_err_msg_size) +{ + int c; + namelist_info * nl; + namelist_info * first_nl = NULL; + namelist_info * root_nl = NULL; + int dim, parsed_rank; + int component_flag, qualifier_flag; + index_type clow, chigh; + int non_zero_rank_count; + + /* Look for end of input or object name. If '?' or '=?' are encountered + in stdin, print the node names or the namelist to stdout. */ + + eat_separator (dtp); + if (dtp->u.p.input_complete) + return SUCCESS; + + if (dtp->u.p.at_eol) + finish_separator (dtp); + if (dtp->u.p.input_complete) + return SUCCESS; + + if ((c = next_char (dtp)) == EOF) + return FAILURE; + switch (c) + { + case '=': + if ((c = next_char (dtp)) == EOF) + return FAILURE; + if (c != '?') + { + sprintf (nml_err_msg, "namelist read: misplaced = sign"); + goto nml_err_ret; + } + nml_query (dtp, '='); + return SUCCESS; + + case '?': + nml_query (dtp, '?'); + return SUCCESS; + + case '$': + case '&': + nml_match_name (dtp, "end", 3); + if (dtp->u.p.nml_read_error) + { + sprintf (nml_err_msg, "namelist not terminated with / or &end"); + goto nml_err_ret; + } + case '/': + dtp->u.p.input_complete = 1; + return SUCCESS; + + default : + break; + } + + /* Untouch all nodes of the namelist and reset the flags that are set for + derived type components. */ + + nml_untouch_nodes (dtp); + component_flag = 0; + qualifier_flag = 0; + non_zero_rank_count = 0; + + /* Get the object name - should '!' and '\n' be permitted separators? */ + +get_name: + + free_saved (dtp); + + do + { + if (!is_separator (c)) + push_char (dtp, tolower(c)); + if ((c = next_char (dtp)) == EOF) + return FAILURE; + } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' )); + + unget_char (dtp, c); + + /* Check that the name is in the namelist and get pointer to object. + Three error conditions exist: (i) An attempt is being made to + identify a non-existent object, following a failed data read or + (ii) The object name does not exist or (iii) Too many data items + are present for an object. (iii) gives the same error message + as (i) */ + + push_char (dtp, '\0'); + + if (component_flag) + { + size_t var_len = strlen (root_nl->var_name); + size_t saved_len + = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0; + char ext_name[var_len + saved_len + 1]; + + memcpy (ext_name, root_nl->var_name, var_len); + if (dtp->u.p.saved_string) + memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len); + ext_name[var_len + saved_len] = '\0'; + nl = find_nml_node (dtp, ext_name); + } + else + nl = find_nml_node (dtp, dtp->u.p.saved_string); + + if (nl == NULL) + { + if (dtp->u.p.nml_read_error && *pprev_nl) + snprintf (nml_err_msg, nml_err_msg_size, + "Bad data for namelist object %s", (*pprev_nl)->var_name); + + else + snprintf (nml_err_msg, nml_err_msg_size, + "Cannot match namelist object name %s", + dtp->u.p.saved_string); + + goto nml_err_ret; + } + + /* Get the length, data length, base pointer and rank of the variable. + Set the default loop specification first. */ + + for (dim=0; dim < nl->var_rank; dim++) + { + nl->ls[dim].step = 1; + nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); + nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); + nl->ls[dim].idx = nl->ls[dim].start; + } + +/* Check to see if there is a qualifier: if so, parse it.*/ + + if (c == '(' && nl->var_rank) + { + parsed_rank = 0; + if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, + nml_err_msg, &parsed_rank) == FAILURE) + { + char *nml_err_msg_end = strchr (nml_err_msg, '\0'); + snprintf (nml_err_msg_end, + nml_err_msg_size - (nml_err_msg_end - nml_err_msg), + " for namelist variable %s", nl->var_name); + goto nml_err_ret; + } + if (parsed_rank > 0) + non_zero_rank_count++; + + qualifier_flag = 1; + + if ((c = next_char (dtp)) == EOF) + return FAILURE; + unget_char (dtp, c); + } + else if (nl->var_rank > 0) + non_zero_rank_count++; + + /* Now parse a derived type component. The root namelist_info address + is backed up, as is the previous component level. The component flag + is set and the iteration is made by jumping back to get_name. */ + + if (c == '%') + { + if (nl->type != BT_DERIVED) + { + snprintf (nml_err_msg, nml_err_msg_size, + "Attempt to get derived component for %s", nl->var_name); + goto nml_err_ret; + } + + if (*pprev_nl == NULL || !component_flag) + first_nl = nl; + + root_nl = nl; + + component_flag = 1; + if ((c = next_char (dtp)) == EOF) + return FAILURE; + goto get_name; + } + + /* Parse a character qualifier, if present. chigh = 0 is a default + that signals that the string length = string_length. */ + + clow = 1; + chigh = 0; + + if (c == '(' && nl->type == BT_CHARACTER) + { + descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; + array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; + + if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank) + == FAILURE) + { + char *nml_err_msg_end = strchr (nml_err_msg, '\0'); + snprintf (nml_err_msg_end, + nml_err_msg_size - (nml_err_msg_end - nml_err_msg), + " for namelist variable %s", nl->var_name); + goto nml_err_ret; + } + + clow = ind[0].start; + chigh = ind[0].end; + + if (ind[0].step != 1) + { + snprintf (nml_err_msg, nml_err_msg_size, + "Step not allowed in substring qualifier" + " for namelist object %s", nl->var_name); + goto nml_err_ret; + } + + if ((c = next_char (dtp)) == EOF) + return FAILURE; + unget_char (dtp, c); + } + + /* Make sure no extraneous qualifiers are there. */ + + if (c == '(') + { + snprintf (nml_err_msg, nml_err_msg_size, + "Qualifier for a scalar or non-character namelist object %s", + nl->var_name); + goto nml_err_ret; + } + + /* Make sure there is no more than one non-zero rank object. */ + if (non_zero_rank_count > 1) + { + snprintf (nml_err_msg, nml_err_msg_size, + "Multiple sub-objects with non-zero rank in namelist object %s", + nl->var_name); + non_zero_rank_count = 0; + goto nml_err_ret; + } + +/* According to the standard, an equal sign MUST follow an object name. The + following is possibly lax - it allows comments, blank lines and so on to + intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/ + + free_saved (dtp); + + eat_separator (dtp); + if (dtp->u.p.input_complete) + return SUCCESS; + + if (dtp->u.p.at_eol) + finish_separator (dtp); + if (dtp->u.p.input_complete) + return SUCCESS; + + if ((c = next_char (dtp)) == EOF) + return FAILURE; + + if (c != '=') + { + snprintf (nml_err_msg, nml_err_msg_size, + "Equal sign must follow namelist object name %s", + nl->var_name); + goto nml_err_ret; + } + /* If a derived type, touch its components and restore the root + namelist_info if we have parsed a qualified derived type + component. */ + + if (nl->type == BT_DERIVED) + nml_touch_nodes (nl); + + if (first_nl) + { + if (first_nl->var_rank == 0) + { + if (component_flag && qualifier_flag) + nl = first_nl; + } + else + nl = first_nl; + } + + if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size, + clow, chigh) == FAILURE) + goto nml_err_ret; + + return SUCCESS; + +nml_err_ret: + + return FAILURE; +} + +/* Entry point for namelist input. Goes through input until namelist name + is matched. Then cycles through nml_get_obj_data until the input is + completed or there is an error. */ + +void +namelist_read (st_parameter_dt *dtp) +{ + int c; + char nml_err_msg[200]; + + /* Initialize the error string buffer just in case we get an unexpected fail + somewhere and end up at nml_err_ret. */ + strcpy (nml_err_msg, "Internal namelist read error"); + + /* Pointer to the previously read object, in case attempt is made to read + new object name. Should this fail, error message can give previous + name. */ + namelist_info *prev_nl = NULL; + + dtp->u.p.namelist_mode = 1; + dtp->u.p.input_complete = 0; + dtp->u.p.expanded_read = 0; + + /* Look for &namelist_name . Skip all characters, testing for $nmlname. + Exit on success or EOF. If '?' or '=?' encountered in stdin, print + node names or namelist on stdout. */ + +find_nml_name: + c = next_char (dtp); + switch (c) + { + case '$': + case '&': + break; + + case '!': + eat_line (dtp); + goto find_nml_name; + + case '=': + c = next_char (dtp); + if (c == '?') + nml_query (dtp, '='); + else + unget_char (dtp, c); + goto find_nml_name; + + case '?': + nml_query (dtp, '?'); + goto find_nml_name; + + case EOF: + return; + + default: + goto find_nml_name; + } + + /* Match the name of the namelist. */ + + nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len); + + if (dtp->u.p.nml_read_error) + goto find_nml_name; + + /* A trailing space is required, we give a little lattitude here, 10.9.1. */ + c = next_char (dtp); + if (!is_separator(c) && c != '!') + { + unget_char (dtp, c); + goto find_nml_name; + } + + unget_char (dtp, c); + eat_separator (dtp); + + /* Ready to read namelist objects. If there is an error in input + from stdin, output the error message and continue. */ + + while (!dtp->u.p.input_complete) + { + if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg) + == FAILURE) + { + if (dtp->u.p.current_unit->unit_number != options.stdin_unit) + goto nml_err_ret; + generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); + } + + /* Reset the previous namelist pointer if we know we are not going + to be doing multiple reads within a single namelist object. */ + if (prev_nl && prev_nl->var_rank == 0) + prev_nl = NULL; + } + + free_saved (dtp); + free_line (dtp); + return; + + +nml_err_ret: + + /* All namelist error calls return from here */ + free_saved (dtp); + free_line (dtp); + generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); + return; +} -- cgit v1.2.3