URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [io/] [list_read.c] - Rev 766
Go to most recent revision | Compare with Previous | Blame | View Log
/* 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 <http://www.gnu.org/licenses/>. */ #include "io.h" #include "fbuf.h" #include "unix.h" #include <string.h> #include <stdlib.h> #include <ctype.h> /* 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 #define MSGLEN 100 /* 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[MSGLEN]; 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) { snprintf (message, MSGLEN, "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) snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input", dtp->u.p.item_count); else snprintf (message, MSGLEN, "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[MSGLEN]; 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) { snprintf (message, MSGLEN, "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) { snprintf (message, MSGLEN, "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); snprintf (message, MSGLEN, "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[MSGLEN]; 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); snprintf (message, MSGLEN, "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[MSGLEN]; 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: case EOF: 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); snprintf (message, MSGLEN, "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[MSGLEN]; 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); snprintf (message, MSGLEN, "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[MSGLEN]; 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; done_infnan: unget_char (dtp, c); push_char (dtp, '\0'); m = convert_infnan (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_infnan; } } /* 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_infnan; } 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); snprintf (message, MSGLEN, "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[MSGLEN]; 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); snprintf (message, MSGLEN, "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[MSGLEN]; 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: 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); unget_char (dtp, c); eat_separator (dtp); push_char (dtp, '\0'); if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length)) return; free_saved (dtp); dtp->u.p.saved_type = BT_REAL; return; 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); snprintf (message, MSGLEN, "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[MSGLEN]; if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) { snprintf (message, MSGLEN, "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) { snprintf (message, MSGLEN, "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, size_t parse_err_msg_size, 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) snprintf (parse_err_msg, parse_err_msg_size, "Bad substring qualifier"); else snprintf (parse_err_msg, parse_err_msg_size, "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) snprintf (parse_err_msg, parse_err_msg_size, "Bad character in substring qualifier"); else snprintf (parse_err_msg, parse_err_msg_size, "Bad character in index"); goto err_ret; } if ((c == ',' || c == ')') && indx == 0 && dtp->u.p.saved_string == 0) { if (is_char) snprintf (parse_err_msg, parse_err_msg_size, "Null substring qualifier"); else snprintf (parse_err_msg, parse_err_msg_size, "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) snprintf (parse_err_msg, parse_err_msg_size, "Bad substring qualifier"); else snprintf (parse_err_msg, parse_err_msg_size, "Bad index triplet"); goto err_ret; } if (is_char && !is_array_section) { snprintf (parse_err_msg, parse_err_msg_size, "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(index_type), neg)) { if (is_char) snprintf (parse_err_msg, parse_err_msg_size, "Bad integer substring qualifier"); else snprintf (parse_err_msg, parse_err_msg_size, "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(index_type)); if (indx == 1) memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type)); if (indx == 2) memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type)); } /* Singlet or doublet indices. */ if (c==',' || c==')') { if (indx == 0) { memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type)); /* 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 > GFC_DIMENSION_UBOUND(ad[dim])) || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim])) || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim])) || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim]))) { if (is_char) snprintf (parse_err_msg, parse_err_msg_size, "Substring out of range"); else snprintf (parse_err_msg, parse_err_msg_size, "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)) { snprintf (parse_err_msg, parse_err_msg_size, "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 = 3; static const char endl[] = "\r\n"; static const char nmlend[] = "&end\r\n"; #else static const index_type endlen = 2; 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 + endlen); if (!p) goto query_return; memcpy (p, "&", 1); memcpy ((char*)(p + 1), dtp->namelist_name, len); memcpy ((char*)(p + len + 1), &endl, endlen - 1); 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 - 1); } /* "&end\n" */ p = write_block (dtp, endlen + 3); goto query_return; memcpy (p, &nmlend, endlen + 3); } /* 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 != '?') { snprintf (nml_err_msg, nml_err_msg_size, "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) { snprintf (nml_err_msg, nml_err_msg_size, "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, nml_err_msg_size, &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, nml_err_msg_size, &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, '?'); 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; }
Go to most recent revision | Compare with Previous | Blame | View Log