/* Copyright (C) 2002-2003 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 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 2, 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. You should have received a copy of the GNU General Public License along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "config.h" #include #include #include "libgfortran.h" #include "io.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. Data is buffered in scratch[] until it becomes too * large, after which we start allocating memory on the heap. */ static int repeat_count, saved_length, saved_used, input_complete, at_eol; static int comma_flag, namelist_mode; static char last_char, *saved_string; static bt saved_type; /* Storage area for values except for strings. Must be large enough * to hold a complex value (two reals) of the largest kind */ static char value[20]; #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' /* This macro assumes that we're operating on a variable */ #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \ || c == '\t') /* Maximum repeat count. Less than ten times the maximum signed int32. */ #define MAX_REPEAT 200000000 /* push_char()-- Save a character to a string buffer, enlarging it as * necessary. */ static void push_char (char c) { char *new; if (saved_string == NULL) { saved_string = scratch; memset (saved_string,0,SCRATCH_SIZE); saved_length = SCRATCH_SIZE; saved_used = 0; } if (saved_used >= saved_length) { saved_length = 2 * saved_length; new = get_mem (2 * saved_length); memset (new,0,2 * saved_length); memcpy (new, saved_string, saved_used); if (saved_string != scratch) free_mem (saved_string); saved_string = new; } saved_string[saved_used++] = c; } /* free_saved()-- Free the input buffer if necessary. */ static void free_saved (void) { if (saved_string == NULL) return; if (saved_string != scratch) free_mem (saved_string); saved_string = NULL; } static char next_char (void) { int length; char c, *p; if (last_char != '\0') { at_eol = 0; c = last_char; last_char = '\0'; goto done; } length = 1; p = salloc_r (current_unit->s, &length); if (p == NULL) { generate_error (ERROR_OS, NULL); return '\0'; } if (length == 0) longjmp (g.eof_jump, 1); c = *p; done: at_eol = (c == '\n'); return c; } /* unget_char()-- Push a character back onto the input */ static void unget_char (char c) { last_char = c; } /* eat_spaces()-- Skip over spaces in the input. Returns the nonspace * character that terminated the eating and also places it back on the * input. */ static char eat_spaces (void) { char c; do { c = next_char (); } while (c == ' ' || c == '\t'); unget_char (c); return c; } /* eat_separator()-- 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. */ static void eat_separator (void) { char c; eat_spaces (); comma_flag = 0; c = next_char (); switch (c) { case ',': comma_flag = 1; eat_spaces (); break; case '/': input_complete = 1; next_record (0); break; case '\n': break; case '!': if (namelist_mode) { /* Eat a namelist comment */ do c = next_char (); while (c != '\n'); break; } /* Fall Through */ default: unget_char (c); break; } } /* finish_separator()-- 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. */ static void finish_separator (void) { char c; restart: eat_spaces (); c = next_char (); switch (c) { case ',': if (comma_flag) unget_char (c); else { c = eat_spaces (); if (c == '\n') goto restart; } break; case '/': input_complete = 1; next_record (0); break; case '\n': goto restart; case '!': if (namelist_mode) { do c = next_char (); while (c != '\n'); goto restart; } default: unget_char (c); break; } } /* convert_integer()-- 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 * saved_string. */ static int convert_integer (int length, int negative) { char c, *buffer, message[100]; int m; int64_t v, max, max10; buffer = 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 (value, v, length); } else { repeat_count = v; if (repeat_count == 0) { st_sprintf (message, "Zero repeat count in item %d of list input", g.item_count); generate_error (ERROR_READ_VALUE, message); m = 1; } } free_saved (); return m; overflow: if (length == -1) st_sprintf (message, "Repeat count overflow in item %d of list input", g.item_count); else st_sprintf (message, "Integer overflow while reading item %d", g.item_count); free_saved (); generate_error (ERROR_READ_VALUE, message); return 1; } /* parse_repeat()-- 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 (void) { char c, message[100]; int repeat; c = next_char (); switch (c) { CASE_DIGITS: repeat = c - '0'; break; CASE_SEPARATORS: unget_char (c); eat_separator (); return 1; default: unget_char (c); return 0; } for (;;) { c = next_char (); switch (c) { CASE_DIGITS: repeat = 10 * repeat + c - '0'; if (repeat > MAX_REPEAT) { st_sprintf (message, "Repeat count overflow in item %d of list input", g.item_count); generate_error (ERROR_READ_VALUE, message); return 1; } break; case '*': if (repeat == 0) { st_sprintf (message, "Zero repeat count in item %d of list input", g.item_count); generate_error (ERROR_READ_VALUE, message); return 1; } goto done; default: goto bad_repeat; } } done: repeat_count = repeat; return 0; bad_repeat: st_sprintf (message, "Bad repeat count in item %d of list input", g.item_count); generate_error (ERROR_READ_VALUE, message); return 1; } /* read_logical()-- Read a logical character on the input */ static void read_logical (int length) { char c, message[100]; int v; if (parse_repeat ()) return; c = next_char (); switch (c) { case 't': case 'T': v = 1; break; case 'f': case 'F': v = 0; break; case '.': c = next_char (); switch (c) { case 't': case 'T': v = 1; break; case 'f': case 'F': v = 0; break; default: goto bad_logical; } break; CASE_SEPARATORS: unget_char (c); eat_separator (); return; /* Null value */ default: goto bad_logical; } saved_type = BT_LOGICAL; saved_length = length; /* Eat trailing garbage */ do { c = next_char (); } while (!is_separator (c)); unget_char (c); eat_separator (); free_saved (); set_integer ((int *) value, v, length); return; bad_logical: st_sprintf (message, "Bad logical value while reading item %d", g.item_count); generate_error (ERROR_READ_VALUE, message); } /* read_integer()-- 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 (int length) { char c, message[100]; int negative; negative = 0; c = next_char (); switch (c) { case '-': negative = 1; /* Fall through */ case '+': c = next_char (); goto get_integer; CASE_SEPARATORS: /* Single null */ unget_char (c); eat_separator (); return; CASE_DIGITS: push_char (c); break; default: goto bad_integer; } /* Take care of what may be a repeat count */ for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; case '*': push_char ('\0'); goto repeat; CASE_SEPARATORS: /* Not a repeat count */ goto done; default: goto bad_integer; } } repeat: if (convert_integer (-1, 0)) return; /* Get the real integer */ c = next_char (); switch (c) { CASE_DIGITS: break; CASE_SEPARATORS: unget_char (c); eat_separator (); return; case '-': negative = 1; /* Fall through */ case '+': c = next_char (); break; } get_integer: if (!isdigit (c)) goto bad_integer; push_char (c); for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; CASE_SEPARATORS: goto done; default: goto bad_integer; } } bad_integer: free_saved (); st_sprintf (message, "Bad integer for item %d in list input", g.item_count); generate_error (ERROR_READ_VALUE, message); return; done: unget_char (c); eat_separator (); push_char ('\0'); if (convert_integer (length, negative)) { free_saved (); return; } free_saved (); saved_type = BT_INTEGER; } /* read_character()-- Read a character variable */ static void read_character (int length) { char c, quote, message[100]; quote = ' '; /* Space means no quote character */ c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; CASE_SEPARATORS: unget_char (c); /* NULL value */ eat_separator (); return; case '"': case '\'': quote = c; goto get_string; default: push_char (c); goto get_string; } /* Deal with a possible repeat count */ for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; CASE_SEPARATORS: unget_char (c); goto done; /* String was only digits! */ case '*': push_char ('\0'); goto got_repeat; default: push_char (c); goto get_string; /* Not a repeat count after all */ } } got_repeat: if (convert_integer (-1, 0)) return; /* Now get the real string */ c = next_char (); switch (c) { CASE_SEPARATORS: unget_char (c); /* repeated NULL values */ eat_separator (); return; case '"': case '\'': quote = c; break; default: push_char (c); break; } get_string: for (;;) { c = next_char (); switch (c) { case '"': case '\'': if (c != quote) { push_char (c); break; } /* See if we have a doubled quote character or the end of the string */ c = next_char (); if (c == quote) { push_char (quote); break; } unget_char (c); goto done; CASE_SEPARATORS: if (quote == ' ') { unget_char (c); goto done; } if (c != '\n') push_char (c); break; default: push_char (c); break; } } /* At this point, we have to have a separator, or else the string is invalid */ done: c = next_char (); if (is_separator (c)) { unget_char (c); eat_separator (); saved_type = BT_CHARACTER; } else { free_saved (); st_sprintf (message, "Invalid string input in item %d", g.item_count); generate_error (ERROR_READ_VALUE, message); } } /* parse_real()-- 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 (void *buffer, int length) { char c, message[100]; int m, seen_dp; c = next_char (); if (c == '-' || c == '+') { push_char (c); c = next_char (); } if (!isdigit (c) && c != '.') goto bad; push_char (c); seen_dp = (c == '.') ? 1 : 0; for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; case '.': if (seen_dp) goto bad; seen_dp = 1; push_char (c); break; case 'e': case 'E': case 'd': case 'D': push_char ('e'); goto exp1; case '-': case '+': push_char ('e'); push_char (c); c = next_char (); goto exp2; CASE_SEPARATORS: unget_char (c); goto done; default: goto done; } } exp1: c = next_char (); if (c != '-' && c != '+') push_char ('+'); else { push_char (c); c = next_char (); } exp2: if (!isdigit (c)) goto bad; push_char (c); for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; CASE_SEPARATORS: unget_char (c); goto done; default: goto done; } } done: unget_char (c); push_char ('\0'); m = convert_real (buffer, saved_string, length); free_saved (); return m; bad: free_saved (); st_sprintf (message, "Bad floating point number for item %d", g.item_count); generate_error (ERROR_READ_VALUE, message); return 1; } /* read_complex()-- Reading a complex number is straightforward * because we can tell what it is right away. */ static void read_complex (int length) { char message[100]; char c; if (parse_repeat ()) return; c = next_char (); switch (c) { case '(': break; CASE_SEPARATORS: unget_char (c); eat_separator (); return; default: goto bad_complex; } eat_spaces (); if (parse_real (value, length)) return; eat_spaces (); if (next_char () != ',') goto bad_complex; eat_spaces (); if (parse_real (value + length, length)) return; eat_spaces (); if (next_char () != ')') goto bad_complex; c = next_char (); if (!is_separator (c)) goto bad_complex; unget_char (c); eat_separator (); free_saved (); saved_type = BT_COMPLEX; return; bad_complex: st_sprintf (message, "Bad complex value in item %d of list input", g.item_count); generate_error (ERROR_READ_VALUE, message); } /* read_real()-- Parse a real number with a possible repeat count. */ static void read_real (int length) { char c, message[100]; int seen_dp; seen_dp = 0; c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; case '.': push_char (c); seen_dp = 1; break; case '+': case '-': goto got_sign; CASE_SEPARATORS: unget_char (c); /* Single null */ eat_separator (); return; default: goto bad_real; } /* Get the digit string that might be a repeat count */ for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; case '.': if (seen_dp) goto bad_real; seen_dp = 1; push_char (c); goto real_loop; case 'E': case 'e': case 'D': case 'd': goto exp1; case '+': case '-': push_char ('e'); push_char (c); c = next_char (); goto exp2; case '*': push_char ('\0'); goto got_repeat; CASE_SEPARATORS: if (c != '\n') unget_char (c); /* Real number that is just a digit-string */ goto done; default: goto bad_real; } } got_repeat: if (convert_integer (-1, 0)) return; /* Now get the number itself */ c = next_char (); if (is_separator (c)) { /* Repeated null value */ unget_char (c); eat_separator (); return; } if (c != '-' && c != '+') push_char ('+'); else { got_sign: push_char (c); c = next_char (); } if (!isdigit (c) && c != '.') goto bad_real; if (c == '.') { if (seen_dp) goto bad_real; else seen_dp = 1; } push_char (c); real_loop: for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; CASE_SEPARATORS: goto done; case '.': if (seen_dp) goto bad_real; seen_dp = 1; push_char (c); break; case 'E': case 'e': case 'D': case 'd': goto exp1; case '+': case '-': push_char ('e'); push_char (c); c = next_char (); goto exp2; default: goto bad_real; } } exp1: push_char ('e'); c = next_char (); if (c != '+' && c != '-') push_char ('+'); else { push_char (c); c = next_char (); } exp2: if (!isdigit (c)) goto bad_real; push_char (c); for (;;) { c = next_char (); switch (c) { CASE_DIGITS: push_char (c); break; CASE_SEPARATORS: unget_char (c); eat_separator (); goto done; default: goto bad_real; } } done: push_char ('\0'); if (convert_real (value, saved_string, length)) return; free_saved (); saved_type = BT_REAL; return; bad_real: st_sprintf (message, "Bad real number in item %d of list input", g.item_count); generate_error (ERROR_READ_VALUE, message); } /* check_type()-- Check the current type against the saved type to * make sure they are compatible. Returns nonzero if incompatible. */ static int check_type (bt type, int len) { char message[100]; if (saved_type != BT_NULL && saved_type != type) { st_sprintf (message, "Read type %s where %s was expected for item %d", type_name (saved_type), type_name (type), g.item_count); generate_error (ERROR_READ_VALUE, message); return 1; } if (saved_type == BT_NULL || saved_type == BT_CHARACTER) return 0; if (saved_length != len) { st_sprintf (message, "Read kind %d %s where kind %d is required for item %d", saved_length, type_name (saved_type), len, g.item_count); generate_error (ERROR_READ_VALUE, message); return 1; } return 0; } /* list_formatted_read()-- 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 value[] array. If a * repeat count is greater than one, we copy the data item multiple * times. */ void list_formatted_read (bt type, void *p, int len) { char c; int m; namelist_mode = 0; if (setjmp (g.eof_jump)) { generate_error (ERROR_END, NULL); return; } if (g.first_item) { g.first_item = 0; input_complete = 0; repeat_count = 1; at_eol = 0; c = eat_spaces (); if (is_separator (c)) { /* Found a null value */ eat_separator (); repeat_count = 0; if (at_eol) finish_separator (); else return; } } else { if (input_complete) return; if (repeat_count > 0) { if (check_type (type, len)) return; goto set_value; } if (at_eol) finish_separator (); else eat_spaces (); saved_type = BT_NULL; repeat_count = 1; } switch (type) { case BT_INTEGER: read_integer (len); break; case BT_LOGICAL: read_logical (len); break; case BT_CHARACTER: read_character (len); break; case BT_REAL: read_real (len); break; case BT_COMPLEX: read_complex (len); break; default: internal_error ("Bad type for list read"); } if (saved_type != BT_CHARACTER && saved_type != BT_NULL) saved_length = len; if (ioparm.library_return != LIBRARY_OK) return; set_value: switch (saved_type) { case BT_COMPLEX: len = 2 * len; /* Fall through */ case BT_INTEGER: case BT_REAL: case BT_LOGICAL: memcpy (p, value, len); break; case BT_CHARACTER: if (saved_string) { m = (len < saved_used) ? len : saved_used; memcpy (p, saved_string, m); } else /* just delimiters encountered, nothing to copy but SPACE */ m = 0; if (m < len) memset (((char *) p) + m, ' ', len - m); break; case BT_NULL: break; } if (--repeat_count <= 0) free_saved (); } void init_at_eol() { at_eol = 0; } /* finish_list_read()-- Finish a list read */ void finish_list_read (void) { char c; free_saved (); if (at_eol) { at_eol = 0; return; } do { c = next_char (); } while (c != '\n'); } static namelist_info * find_nml_node (char * var_name) { namelist_info * t = ionml; while (t != NULL) { if (strcmp (var_name,t->var_name) == 0) { t->value_acquired = 1; return t; } t = t->next; } return NULL; } static void match_namelist_name (char *name, int len) { int name_len; char c; char * namelist_name = name; name_len = 0; /* Match the name of the namelist */ if (tolower (next_char ()) != tolower (namelist_name[name_len++])) { wrong_name: generate_error (ERROR_READ_VALUE, "Wrong namelist name found"); return; } while (name_len < len) { c = next_char (); if (tolower (c) != tolower (namelist_name[name_len++])) goto wrong_name; } } /******************************************************************** Namelist reads ********************************************************************/ /* namelist_read()-- Process a namelist read. This subroutine * initializes things, positions to the first element and */ void namelist_read (void) { char c; int name_matched, next_name ; namelist_info * nl; int len, m; void * p; namelist_mode = 1; if (setjmp (g.eof_jump)) { generate_error (ERROR_END, NULL); return; } restart: c = next_char (); switch (c) { case ' ': goto restart; case '!': do c = next_char (); while (c != '\n'); goto restart; case '&': break; default: generate_error (ERROR_READ_VALUE, "Invalid character in namelist"); return; } /* Match the name of the namelist */ match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len); /* Ready to read namelist elements */ for (;;) { c = next_char (); switch (c) { case '&': match_namelist_name("end",3); return; case '\\': return; case ' ': case '\n': case '\t': break; case ',': next_name = 1; break; case '=': name_matched = 1; nl = find_nml_node (saved_string); if (nl == NULL) internal_error ("Can not found a valid namelist var!"); free_saved(); len = nl->len; p = nl->mem_pos; switch (nl->type) { case BT_INTEGER: read_integer (len); break; case BT_LOGICAL: read_logical (len); break; case BT_CHARACTER: read_character (len); break; case BT_REAL: read_real (len); break; case BT_COMPLEX: read_complex (len); break; default: internal_error ("Bad type for namelist read"); } switch (saved_type) { case BT_COMPLEX: len = 2 * len; /* Fall through */ case BT_INTEGER: case BT_REAL: case BT_LOGICAL: memcpy (p, value, len); break; case BT_CHARACTER: m = (len < saved_used) ? len : saved_used; memcpy (p, saved_string, m); if (m < len) memset (((char *) p) + m, ' ', len - m); break; case BT_NULL: break; } break; default : push_char(c); break; } } }