Check in gcc sources for prebuilt toolchains in Eclair.

1 files changed, 2485 insertions, 0 deletions

diff --git a/gcc-4.2.1/gcc/fortran/primary.c b/gcc-4.2.1/gcc/fortran/primary.c
new file mode 100644
index 000000000..443b6fe62
--- /dev/null
+++ b/gcc-4.2.1/gcc/fortran/primary.c
@@ -0,0 +1,2485 @@
+/* Primary expression subroutines
+   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "match.h"
+#include "parse.h"
+
+/* Matches a kind-parameter expression, which is either a named
+   symbolic constant or a nonnegative integer constant.  If
+   successful, sets the kind value to the correct integer.  */
+
+static match
+match_kind_param (int *kind)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  const char *p;
+  match m;
+
+  m = gfc_match_small_literal_int (kind, NULL);
+  if (m != MATCH_NO)
+    return m;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_symbol (name, NULL, 1, &sym))
+    return MATCH_ERROR;
+
+  if (sym == NULL)
+    return MATCH_NO;
+
+  if (sym->attr.flavor != FL_PARAMETER)
+    return MATCH_NO;
+
+  p = gfc_extract_int (sym->value, kind);
+  if (p != NULL)
+    return MATCH_NO;
+
+  if (*kind < 0)
+    return MATCH_NO;
+
+  return MATCH_YES;
+}
+
+
+/* Get a trailing kind-specification for non-character variables.
+   Returns:
+      the integer kind value or:
+      -1 if an error was generated
+      -2 if no kind was found */
+
+static int
+get_kind (void)
+{
+  int kind;
+  match m;
+
+  if (gfc_match_char ('_') != MATCH_YES)
+    return -2;
+
+  m = match_kind_param (&kind);
+  if (m == MATCH_NO)
+    gfc_error ("Missing kind-parameter at %C");
+
+  return (m == MATCH_YES) ? kind : -1;
+}
+
+
+/* Given a character and a radix, see if the character is a valid
+   digit in that radix.  */
+
+static int
+check_digit (int c, int radix)
+{
+  int r;
+
+  switch (radix)
+    {
+    case 2:
+      r = ('0' <= c && c <= '1');
+      break;
+
+    case 8:
+      r = ('0' <= c && c <= '7');
+      break;
+
+    case 10:
+      r = ('0' <= c && c <= '9');
+      break;
+
+    case 16:
+      r = ISXDIGIT (c);
+      break;
+
+    default:
+      gfc_internal_error ("check_digit(): bad radix");
+    }
+
+  return r;
+}
+
+
+/* Match the digit string part of an integer if signflag is not set,
+   the signed digit string part if signflag is set.  If the buffer 
+   is NULL, we just count characters for the resolution pass.  Returns 
+   the number of characters matched, -1 for no match.  */
+
+static int
+match_digits (int signflag, int radix, char *buffer)
+{
+  locus old_loc;
+  int length, c;
+
+  length = 0;
+  c = gfc_next_char ();
+
+  if (signflag && (c == '+' || c == '-'))
+    {
+      if (buffer != NULL)
+	*buffer++ = c;
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+      length++;
+    }
+
+  if (!check_digit (c, radix))
+    return -1;
+
+  length++;
+  if (buffer != NULL)
+    *buffer++ = c;
+
+  for (;;)
+    {
+      old_loc = gfc_current_locus;
+      c = gfc_next_char ();
+
+      if (!check_digit (c, radix))
+	break;
+
+      if (buffer != NULL)
+	*buffer++ = c;
+      length++;
+    }
+
+  gfc_current_locus = old_loc;
+
+  return length;
+}
+
+
+/* Match an integer (digit string and optional kind).  
+   A sign will be accepted if signflag is set.  */
+
+static match
+match_integer_constant (gfc_expr ** result, int signflag)
+{
+  int length, kind;
+  locus old_loc;
+  char *buffer;
+  gfc_expr *e;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  length = match_digits (signflag, 10, NULL);
+  gfc_current_locus = old_loc;
+  if (length == -1)
+    return MATCH_NO;
+
+  buffer = alloca (length + 1);
+  memset (buffer, '\0', length + 1);
+
+  gfc_gobble_whitespace ();
+
+  match_digits (signflag, 10, buffer);
+
+  kind = get_kind ();
+  if (kind == -2)
+    kind = gfc_default_integer_kind;
+  if (kind == -1)
+    return MATCH_ERROR;
+
+  if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
+    {
+      gfc_error ("Integer kind %d at %C not available", kind);
+      return MATCH_ERROR;
+    }
+
+  e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
+
+  if (gfc_range_check (e) != ARITH_OK)
+    {
+      gfc_error ("Integer too big for its kind at %C");
+
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  *result = e;
+  return MATCH_YES;
+}
+
+
+/* Match a Hollerith constant.  */
+
+static match
+match_hollerith_constant (gfc_expr ** result)
+{
+  locus old_loc;
+  gfc_expr * e = NULL;
+  const char * msg;
+  char * buffer;
+  int num;
+  int i;  
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  if (match_integer_constant (&e, 0) == MATCH_YES
+	&& gfc_match_char ('h') == MATCH_YES)
+    {
+      if (gfc_notify_std (GFC_STD_LEGACY,
+		"Extension: Hollerith constant at %C")
+		== FAILURE)
+	goto cleanup;
+
+      msg = gfc_extract_int (e, &num);
+      if (msg != NULL)
+	{
+	  gfc_error (msg);
+	  goto cleanup;
+	}
+      if (num == 0)
+	{
+	  gfc_error ("Invalid Hollerith constant: %L must contain at least one "
+			"character", &old_loc);
+	  goto cleanup;
+	}
+      if (e->ts.kind != gfc_default_integer_kind)
+	{
+	  gfc_error ("Invalid Hollerith constant: Integer kind at %L "
+		"should be default", &old_loc);
+	  goto cleanup;
+	}
+      else
+	{
+	  buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
+	  for (i = 0; i < num; i++)
+	    {
+	      buffer[i] = gfc_next_char_literal (1);
+	    }
+	  gfc_free_expr (e);
+	  e = gfc_constant_result (BT_HOLLERITH,
+		gfc_default_character_kind, &gfc_current_locus);
+	  e->value.character.string = gfc_getmem (num+1);
+	  memcpy (e->value.character.string, buffer, num);
+	  e->value.character.string[num] = '\0';
+	  e->value.character.length = num;
+	  *result = e;
+	  return MATCH_YES;
+	}
+    }
+
+  gfc_free_expr (e);
+  gfc_current_locus = old_loc;
+  return MATCH_NO;
+
+cleanup:
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+}
+
+
+/* Match a binary, octal or hexadecimal constant that can be found in
+   a DATA statement.  The standard permits b'010...', o'73...', and
+   z'a1...' where b, o, and z can be capital letters.  This function
+   also accepts postfixed forms of the constants: '01...'b, '73...'o,
+   and 'a1...'z.  An additional extension is the use of x for z.  */
+
+static match
+match_boz_constant (gfc_expr ** result)
+{
+  int post, radix, delim, length, x_hex, kind;
+  locus old_loc, start_loc;
+  char *buffer;
+  gfc_expr *e;
+
+  start_loc = old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  x_hex = 0;
+  switch (post = gfc_next_char ())
+    {
+    case 'b':
+      radix = 2;
+      post = 0;
+      break;
+    case 'o':
+      radix = 8;
+      post = 0;
+      break;
+    case 'x':
+      x_hex = 1;
+      /* Fall through.  */
+    case 'z':
+      radix = 16;
+      post = 0;
+      break;
+    case '\'':
+      /* Fall through.  */
+    case '\"':
+      delim = post;
+      post = 1;
+      radix = 16;  /* Set to accept any valid digit string.  */
+      break;
+    default:
+      goto backup;
+    }
+
+  /* No whitespace allowed here.  */
+
+  if (post == 0)
+    delim = gfc_next_char ();
+
+  if (delim != '\'' && delim != '\"')
+    goto backup;
+
+  if (x_hex && pedantic
+      && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
+			  "constant at %C uses non-standard syntax.")
+	  == FAILURE))
+      return MATCH_ERROR;
+
+  old_loc = gfc_current_locus;
+
+  length = match_digits (0, radix, NULL);
+  if (length == -1)
+    {
+      gfc_error ("Empty set of digits in BOZ constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_next_char () != delim)
+    {
+      gfc_error ("Illegal character in BOZ constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (post == 1)
+    {
+      switch (gfc_next_char ())
+	{
+	case 'b':
+	  radix = 2;
+	  break;
+	case 'o':
+	  radix = 8;
+	  break;
+	case 'x':
+	  /* Fall through.  */
+	case 'z':
+	  radix = 16;
+	  break;
+	default:
+	  goto backup;
+	}
+	gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
+			"at %C uses non-standard postfix syntax.");
+    }
+
+  gfc_current_locus = old_loc;
+
+  buffer = alloca (length + 1);
+  memset (buffer, '\0', length + 1);
+
+  match_digits (0, radix, buffer);
+  gfc_next_char ();    /* Eat delimiter.  */
+  if (post == 1)
+    gfc_next_char ();  /* Eat postfixed b, o, z, or x.  */
+
+  /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
+     "If a data-stmt-constant is a boz-literal-constant, the corresponding
+     variable shall be of type integer.  The boz-literal-constant is treated
+     as if it were an int-literal-constant with a kind-param that specifies
+     the representation method with the largest decimal exponent range
+     supported by the processor."  */
+
+  kind = gfc_max_integer_kind;
+  e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
+
+  if (gfc_range_check (e) != ARITH_OK)
+    {
+      gfc_error ("Integer too big for integer kind %i at %C", kind);
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  *result = e;
+  return MATCH_YES;
+
+backup:
+  gfc_current_locus = start_loc;
+  return MATCH_NO;
+}
+
+
+/* Match a real constant of some sort.  Allow a signed constant if signflag
+   is nonzero.  Allow integer constants if allow_int is true.  */
+
+static match
+match_real_constant (gfc_expr ** result, int signflag)
+{
+  int kind, c, count, seen_dp, seen_digits, exp_char;
+  locus old_loc, temp_loc;
+  char *p, *buffer;
+  gfc_expr *e;
+  bool negate;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  e = NULL;
+
+  count = 0;
+  seen_dp = 0;
+  seen_digits = 0;
+  exp_char = ' ';
+  negate = FALSE;
+
+  c = gfc_next_char ();
+  if (signflag && (c == '+' || c == '-'))
+    {
+      if (c == '-')
+	negate = TRUE;
+
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+    }
+
+  /* Scan significand.  */
+  for (;; c = gfc_next_char (), count++)
+    {
+      if (c == '.')
+	{
+	  if (seen_dp)
+	    goto done;
+
+	  /* Check to see if "." goes with a following operator like ".eq.".  */
+	  temp_loc = gfc_current_locus;
+	  c = gfc_next_char ();
+
+	  if (c == 'e' || c == 'd' || c == 'q')
+	    {
+	      c = gfc_next_char ();
+	      if (c == '.')
+		goto done;	/* Operator named .e. or .d.  */
+	    }
+
+	  if (ISALPHA (c))
+	    goto done;		/* Distinguish 1.e9 from 1.eq.2 */
+
+	  gfc_current_locus = temp_loc;
+	  seen_dp = 1;
+	  continue;
+	}
+
+      if (ISDIGIT (c))
+	{
+	  seen_digits = 1;
+	  continue;
+	}
+
+      break;
+    }
+
+  if (!seen_digits
+      || (c != 'e' && c != 'd' && c != 'q'))
+    goto done;
+  exp_char = c;
+
+  /* Scan exponent.  */
+  c = gfc_next_char ();
+  count++;
+
+  if (c == '+' || c == '-')
+    {				/* optional sign */
+      c = gfc_next_char ();
+      count++;
+    }
+
+  if (!ISDIGIT (c))
+    {
+      gfc_error ("Missing exponent in real number at %C");
+      return MATCH_ERROR;
+    }
+
+  while (ISDIGIT (c))
+    {
+      c = gfc_next_char ();
+      count++;
+    }
+
+done:
+  /* Check that we have a numeric constant.  */
+  if (!seen_digits || (!seen_dp && exp_char == ' '))
+    {
+      gfc_current_locus = old_loc;
+      return MATCH_NO;
+    }
+
+  /* Convert the number.  */
+  gfc_current_locus = old_loc;
+  gfc_gobble_whitespace ();
+
+  buffer = alloca (count + 1);
+  memset (buffer, '\0', count + 1);
+
+  p = buffer;
+  c = gfc_next_char ();
+  if (c == '+' || c == '-')
+    {
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+    }
+
+  /* Hack for mpfr_set_str().  */
+  for (;;)
+    {
+      if (c == 'd' || c == 'q')
+	*p = 'e';
+      else
+	*p = c;
+      p++;
+      if (--count == 0)
+	break;
+
+      c = gfc_next_char ();
+    }
+
+  kind = get_kind ();
+  if (kind == -1)
+    goto cleanup;
+
+  switch (exp_char)
+    {
+    case 'd':
+      if (kind != -2)
+	{
+	  gfc_error
+	    ("Real number at %C has a 'd' exponent and an explicit kind");
+	  goto cleanup;
+	}
+      kind = gfc_default_double_kind;
+      break;
+
+    default:
+      if (kind == -2)
+	kind = gfc_default_real_kind;
+
+      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+	{
+	  gfc_error ("Invalid real kind %d at %C", kind);
+	  goto cleanup;
+	}
+    }
+
+  e = gfc_convert_real (buffer, kind, &gfc_current_locus);
+  if (negate)
+    mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+
+  switch (gfc_range_check (e))
+    {
+    case ARITH_OK:
+      break;
+    case ARITH_OVERFLOW:
+      gfc_error ("Real constant overflows its kind at %C");
+      goto cleanup;
+
+    case ARITH_UNDERFLOW:
+      if (gfc_option.warn_underflow)
+        gfc_warning ("Real constant underflows its kind at %C");
+      mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_range_check() returned bad value");
+    }
+
+  *result = e;
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+}
+
+
+/* Match a substring reference.  */
+
+static match
+match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
+{
+  gfc_expr *start, *end;
+  locus old_loc;
+  gfc_ref *ref;
+  match m;
+
+  start = NULL;
+  end = NULL;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match_char ('(');
+  if (m != MATCH_YES)
+    return MATCH_NO;
+
+  if (gfc_match_char (':') != MATCH_YES)
+    {
+      if (init)
+	m = gfc_match_init_expr (&start);
+      else
+	m = gfc_match_expr (&start);
+
+      if (m != MATCH_YES)
+	{
+	  m = MATCH_NO;
+	  goto cleanup;
+	}
+
+      m = gfc_match_char (':');
+      if (m != MATCH_YES)
+	goto cleanup;
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      if (init)
+	m = gfc_match_init_expr (&end);
+      else
+	m = gfc_match_expr (&end);
+
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      m = gfc_match_char (')');
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  /* Optimize away the (:) reference.  */
+  if (start == NULL && end == NULL)
+    ref = NULL;
+  else
+    {
+      ref = gfc_get_ref ();
+
+      ref->type = REF_SUBSTRING;
+      if (start == NULL)
+	start = gfc_int_expr (1);
+      ref->u.ss.start = start;
+      if (end == NULL && cl)
+	end = gfc_copy_expr (cl->length);
+      ref->u.ss.end = end;
+      ref->u.ss.length = cl;
+    }
+
+  *result = ref;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in SUBSTRING specification at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_free_expr (start);
+  gfc_free_expr (end);
+
+  gfc_current_locus = old_loc;
+  return m;
+}
+
+
+/* Reads the next character of a string constant, taking care to
+   return doubled delimiters on the input as a single instance of
+   the delimiter.
+
+   Special return values are:
+     -1   End of the string, as determined by the delimiter
+     -2   Unterminated string detected
+
+   Backslash codes are also expanded at this time.  */
+
+static int
+next_string_char (char delimiter)
+{
+  locus old_locus;
+  int c;
+
+  c = gfc_next_char_literal (1);
+
+  if (c == '\n')
+    return -2;
+
+  if (gfc_option.flag_backslash && c == '\\')
+    {
+      old_locus = gfc_current_locus;
+
+      switch (gfc_next_char_literal (1))
+	{
+	case 'a':
+	  c = '\a';
+	  break;
+	case 'b':
+	  c = '\b';
+	  break;
+	case 't':
+	  c = '\t';
+	  break;
+	case 'f':
+	  c = '\f';
+	  break;
+	case 'n':
+	  c = '\n';
+	  break;
+	case 'r':
+	  c = '\r';
+	  break;
+	case 'v':
+	  c = '\v';
+	  break;
+	case '\\':
+	  c = '\\';
+	  break;
+
+	default:
+	  /* Unknown backslash codes are simply not expanded */
+	  gfc_current_locus = old_locus;
+	  break;
+	}
+
+      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+	gfc_warning ("Extension: backslash character at %C");
+    }
+
+  if (c != delimiter)
+    return c;
+
+  old_locus = gfc_current_locus;
+  c = gfc_next_char_literal (0);
+
+  if (c == delimiter)
+    return c;
+  gfc_current_locus = old_locus;
+
+  return -1;
+}
+
+
+/* Special case of gfc_match_name() that matches a parameter kind name
+   before a string constant.  This takes case of the weird but legal
+   case of:
+
+     kind_____'string'
+
+   where kind____ is a parameter. gfc_match_name() will happily slurp
+   up all the underscores, which leads to problems.  If we return
+   MATCH_YES, the parse pointer points to the final underscore, which
+   is not part of the name.  We never return MATCH_ERROR-- errors in
+   the name will be detected later.  */
+
+static match
+match_charkind_name (char *name)
+{
+  locus old_loc;
+  char c, peek;
+  int len;
+
+  gfc_gobble_whitespace ();
+  c = gfc_next_char ();
+  if (!ISALPHA (c))
+    return MATCH_NO;
+
+  *name++ = c;
+  len = 1;
+
+  for (;;)
+    {
+      old_loc = gfc_current_locus;
+      c = gfc_next_char ();
+
+      if (c == '_')
+	{
+	  peek = gfc_peek_char ();
+
+	  if (peek == '\'' || peek == '\"')
+	    {
+	      gfc_current_locus = old_loc;
+	      *name = '\0';
+	      return MATCH_YES;
+	    }
+	}
+
+      if (!ISALNUM (c)
+	  && c != '_'
+	  && (gfc_option.flag_dollar_ok && c != '$'))
+	break;
+
+      *name++ = c;
+      if (++len > GFC_MAX_SYMBOL_LEN)
+	break;
+    }
+
+  return MATCH_NO;
+}
+
+
+/* See if the current input matches a character constant.  Lots of
+   contortions have to be done to match the kind parameter which comes
+   before the actual string.  The main consideration is that we don't
+   want to error out too quickly.  For example, we don't actually do
+   any validation of the kinds until we have actually seen a legal
+   delimiter.  Using match_kind_param() generates errors too quickly.  */
+
+static match
+match_string_constant (gfc_expr ** result)
+{
+  char *p, name[GFC_MAX_SYMBOL_LEN + 1];
+  int i, c, kind, length, delimiter, warn_ampersand;
+  locus old_locus, start_locus;
+  gfc_symbol *sym;
+  gfc_expr *e;
+  const char *q;
+  match m;
+
+  old_locus = gfc_current_locus;
+
+  gfc_gobble_whitespace ();
+
+  start_locus = gfc_current_locus;
+
+  c = gfc_next_char ();
+  if (c == '\'' || c == '"')
+    {
+      kind = gfc_default_character_kind;
+      goto got_delim;
+    }
+
+  if (ISDIGIT (c))
+    {
+      kind = 0;
+
+      while (ISDIGIT (c))
+	{
+	  kind = kind * 10 + c - '0';
+	  if (kind > 9999999)
+	    goto no_match;
+	  c = gfc_next_char ();
+	}
+
+    }
+  else
+    {
+      gfc_current_locus = old_locus;
+
+      m = match_charkind_name (name);
+      if (m != MATCH_YES)
+	goto no_match;
+
+      if (gfc_find_symbol (name, NULL, 1, &sym)
+	  || sym == NULL
+	  || sym->attr.flavor != FL_PARAMETER)
+	goto no_match;
+
+      kind = -1;
+      c = gfc_next_char ();
+    }
+
+  if (c == ' ')
+    {
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+    }
+
+  if (c != '_')
+    goto no_match;
+
+  gfc_gobble_whitespace ();
+  start_locus = gfc_current_locus;
+
+  c = gfc_next_char ();
+  if (c != '\'' && c != '"')
+    goto no_match;
+
+  if (kind == -1)
+    {
+      q = gfc_extract_int (sym->value, &kind);
+      if (q != NULL)
+	{
+	  gfc_error (q);
+	  return MATCH_ERROR;
+	}
+    }
+
+  if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
+    {
+      gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
+      return MATCH_ERROR;
+    }
+
+got_delim:
+  /* Scan the string into a block of memory by first figuring out how
+     long it is, allocating the structure, then re-reading it.  This
+     isn't particularly efficient, but string constants aren't that
+     common in most code.  TODO: Use obstacks?  */
+
+  delimiter = c;
+  length = 0;
+
+  for (;;)
+    {
+      c = next_string_char (delimiter);
+      if (c == -1)
+	break;
+      if (c == -2)
+	{
+	  gfc_current_locus = start_locus;
+	  gfc_error ("Unterminated character constant beginning at %C");
+	  return MATCH_ERROR;
+	}
+
+      length++;
+    }
+
+  /* Peek at the next character to see if it is a b, o, z, or x for the
+     postfixed BOZ literal constants.  */
+  c = gfc_peek_char ();
+  if (c == 'b' || c == 'o' || c =='z' || c == 'x')
+    goto no_match;
+
+
+  e = gfc_get_expr ();
+
+  e->expr_type = EXPR_CONSTANT;
+  e->ref = NULL;
+  e->ts.type = BT_CHARACTER;
+  e->ts.kind = kind;
+  e->where = start_locus;
+
+  e->value.character.string = p = gfc_getmem (length + 1);
+  e->value.character.length = length;
+
+  gfc_current_locus = start_locus;
+  gfc_next_char ();		/* Skip delimiter */
+
+  /* We disable the warning for the following loop as the warning has already
+     been printed in the loop above.  */
+  warn_ampersand = gfc_option.warn_ampersand;
+  gfc_option.warn_ampersand = 0;
+
+  for (i = 0; i < length; i++)
+    *p++ = next_string_char (delimiter);
+
+  *p = '\0';	/* TODO: C-style string is for development/debug purposes.  */
+  gfc_option.warn_ampersand = warn_ampersand;
+
+  if (next_string_char (delimiter) != -1)
+    gfc_internal_error ("match_string_constant(): Delimiter not found");
+
+  if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
+    e->expr_type = EXPR_SUBSTRING;
+
+  *result = e;
+
+  return MATCH_YES;
+
+no_match:
+  gfc_current_locus = old_locus;
+  return MATCH_NO;
+}
+
+
+/* Match a .true. or .false.  */
+
+static match
+match_logical_constant (gfc_expr ** result)
+{
+  static mstring logical_ops[] = {
+    minit (".false.", 0),
+    minit (".true.", 1),
+    minit (NULL, -1)
+  };
+
+  gfc_expr *e;
+  int i, kind;
+
+  i = gfc_match_strings (logical_ops);
+  if (i == -1)
+    return MATCH_NO;
+
+  kind = get_kind ();
+  if (kind == -1)
+    return MATCH_ERROR;
+  if (kind == -2)
+    kind = gfc_default_logical_kind;
+
+  if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
+    {
+      gfc_error ("Bad kind for logical constant at %C");
+      return MATCH_ERROR;
+    }
+
+  e = gfc_get_expr ();
+
+  e->expr_type = EXPR_CONSTANT;
+  e->value.logical = i;
+  e->ts.type = BT_LOGICAL;
+  e->ts.kind = kind;
+  e->where = gfc_current_locus;
+
+  *result = e;
+  return MATCH_YES;
+}
+
+
+/* Match a real or imaginary part of a complex constant that is a
+   symbolic constant.  */
+
+static match
+match_sym_complex_part (gfc_expr ** result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  gfc_expr *e;
+  match m;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
+    return MATCH_NO;
+
+  if (sym->attr.flavor != FL_PARAMETER)
+    {
+      gfc_error ("Expected PARAMETER symbol in complex constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_numeric_ts (&sym->value->ts))
+    {
+      gfc_error ("Numeric PARAMETER required in complex constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (sym->value->rank != 0)
+    {
+      gfc_error ("Scalar PARAMETER required in complex constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
+		      "complex constant at %C") == FAILURE)
+    return MATCH_ERROR;
+
+  switch (sym->value->ts.type)
+    {
+    case BT_REAL:
+      e = gfc_copy_expr (sym->value);
+      break;
+
+    case BT_COMPLEX:
+      e = gfc_complex2real (sym->value, sym->value->ts.kind);
+      if (e == NULL)
+	goto error;
+      break;
+
+    case BT_INTEGER:
+      e = gfc_int2real (sym->value, gfc_default_real_kind);
+      if (e == NULL)
+	goto error;
+      break;
+
+    default:
+      gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
+    }
+
+  *result = e;			/* e is a scalar, real, constant expression */
+  return MATCH_YES;
+
+error:
+  gfc_error ("Error converting PARAMETER constant in complex constant at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a real or imaginary part of a complex number.  */
+
+static match
+match_complex_part (gfc_expr ** result)
+{
+  match m;
+
+  m = match_sym_complex_part (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_real_constant (result, 1);
+  if (m != MATCH_NO)
+    return m;
+
+  return match_integer_constant (result, 1);
+}
+
+
+/* Try to match a complex constant.  */
+
+static match
+match_complex_constant (gfc_expr ** result)
+{
+  gfc_expr *e, *real, *imag;
+  gfc_error_buf old_error;
+  gfc_typespec target;
+  locus old_loc;
+  int kind;
+  match m;
+
+  old_loc = gfc_current_locus;
+  real = imag = e = NULL;
+
+  m = gfc_match_char ('(');
+  if (m != MATCH_YES)
+    return m;
+
+  gfc_push_error (&old_error);
+
+  m = match_complex_part (&real);
+  if (m == MATCH_NO)
+    {
+      gfc_free_error (&old_error);
+      goto cleanup;
+    }
+
+  if (gfc_match_char (',') == MATCH_NO)
+    {
+      gfc_pop_error (&old_error);
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  /* If m is error, then something was wrong with the real part and we
+     assume we have a complex constant because we've seen the ','.  An
+     ambiguous case here is the start of an iterator list of some
+     sort. These sort of lists are matched prior to coming here.  */
+
+  if (m == MATCH_ERROR)
+    {
+      gfc_free_error (&old_error);
+      goto cleanup;
+    }
+  gfc_pop_error (&old_error);
+
+  m = match_complex_part (&imag);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  m = gfc_match_char (')');
+  if (m == MATCH_NO)
+    {
+      /* Give the matcher for implied do-loops a chance to run.  This
+	 yields a much saner error message for (/ (i, 4=i, 6) /).  */
+      if (gfc_peek_char () == '=')
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+      else
+    goto syntax;
+    }
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  /* Decide on the kind of this complex number.  */
+  if (real->ts.type == BT_REAL)
+    {
+      if (imag->ts.type == BT_REAL)
+	kind = gfc_kind_max (real, imag);
+      else
+	kind = real->ts.kind;
+    }
+  else
+    {
+      if (imag->ts.type == BT_REAL)
+	kind = imag->ts.kind;
+      else
+	kind = gfc_default_real_kind;
+    }
+  target.type = BT_REAL;
+  target.kind = kind;
+
+  if (real->ts.type != BT_REAL || kind != real->ts.kind)
+    gfc_convert_type (real, &target, 2);
+  if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
+    gfc_convert_type (imag, &target, 2);
+
+  e = gfc_convert_complex (real, imag, kind);
+  e->where = gfc_current_locus;
+
+  gfc_free_expr (real);
+  gfc_free_expr (imag);
+
+  *result = e;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in COMPLEX constant at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_free_expr (e);
+  gfc_free_expr (real);
+  gfc_free_expr (imag);
+  gfc_current_locus = old_loc;
+
+  return m;
+}
+
+
+/* Match constants in any of several forms.  Returns nonzero for a
+   match, zero for no match.  */
+
+match
+gfc_match_literal_constant (gfc_expr ** result, int signflag)
+{
+  match m;
+
+  m = match_complex_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_string_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_boz_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_real_constant (result, signflag);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_hollerith_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_integer_constant (result, signflag);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_logical_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  return MATCH_NO;
+}
+
+
+/* Match a single actual argument value.  An actual argument is
+   usually an expression, but can also be a procedure name.  If the
+   argument is a single name, it is not always possible to tell
+   whether the name is a dummy procedure or not.  We treat these cases
+   by creating an argument that looks like a dummy procedure and
+   fixing things later during resolution.  */
+
+static match
+match_actual_arg (gfc_expr ** result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symtree *symtree;
+  locus where, w;
+  gfc_expr *e;
+  int c;
+
+  where = gfc_current_locus;
+
+  switch (gfc_match_name (name))
+    {
+    case MATCH_ERROR:
+      return MATCH_ERROR;
+
+    case MATCH_NO:
+      break;
+
+    case MATCH_YES:
+      w = gfc_current_locus;
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+      gfc_current_locus = w;
+
+      if (c != ',' && c != ')')
+	break;
+
+      if (gfc_find_sym_tree (name, NULL, 1, &symtree))
+	break;
+      /* Handle error elsewhere.  */
+
+      /* Eliminate a couple of common cases where we know we don't
+         have a function argument.  */
+      if (symtree == NULL)
+        {
+	  gfc_get_sym_tree (name, NULL, &symtree);
+          gfc_set_sym_referenced (symtree->n.sym);
+        }
+      else
+	{
+          gfc_symbol *sym;
+
+          sym = symtree->n.sym;
+          gfc_set_sym_referenced (sym);
+	  if (sym->attr.flavor != FL_PROCEDURE
+	      && sym->attr.flavor != FL_UNKNOWN)
+	    break;
+
+	  /* If the symbol is a function with itself as the result and
+	     is being defined, then we have a variable.  */
+	  if (sym->attr.function && sym->result == sym)
+	    {
+	      if (gfc_current_ns->proc_name == sym
+		  || (gfc_current_ns->parent != NULL
+		      && gfc_current_ns->parent->proc_name == sym))
+		break;
+
+	      if (sym->attr.entry
+		  && (sym->ns == gfc_current_ns
+		      || sym->ns == gfc_current_ns->parent))
+		{
+		  gfc_entry_list *el = NULL;
+
+		  for (el = sym->ns->entries; el; el = el->next)
+		    if (sym == el->sym)
+		      break;
+
+		  if (el)
+		    break;
+		}
+	    }
+	}
+
+      e = gfc_get_expr ();	/* Leave it unknown for now */
+      e->symtree = symtree;
+      e->expr_type = EXPR_VARIABLE;
+      e->ts.type = BT_PROCEDURE;
+      e->where = where;
+
+      *result = e;
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = where;
+  return gfc_match_expr (result);
+}
+
+
+/* Match a keyword argument.  */
+
+static match
+match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_actual_arglist *a;
+  locus name_locus;
+  match m;
+
+  name_locus = gfc_current_locus;
+  m = gfc_match_name (name);
+
+  if (m != MATCH_YES)
+    goto cleanup;
+  if (gfc_match_char ('=') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = match_actual_arg (&actual->expr);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  /* Make sure this name has not appeared yet.  */
+
+  if (name[0] != '\0')
+    {
+      for (a = base; a; a = a->next)
+	if (a->name != NULL && strcmp (a->name, name) == 0)
+	  {
+	    gfc_error
+	      ("Keyword '%s' at %C has already appeared in the current "
+	       "argument list", name);
+	    return MATCH_ERROR;
+	  }
+    }
+
+  actual->name = gfc_get_string (name);
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = name_locus;
+  return m;
+}
+
+
+/* Match an argument list function, such as %VAL.  */
+
+static match
+match_arg_list_function (gfc_actual_arglist *result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_locus;
+  match m;
+
+  old_locus = gfc_current_locus;
+
+  if (gfc_match_char ('%') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = gfc_match ("%n (", name);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (name[0] != '\0')
+    {
+      switch (name[0])
+	{
+	case 'l':
+	  if (strncmp(name, "loc", 3) == 0)
+	    {
+	      result->name = "%LOC";
+	      break;
+	    }
+	case 'r':
+	  if (strncmp(name, "ref", 3) == 0)
+	    {
+	      result->name = "%REF";
+	      break;
+	    }
+	case 'v':
+	  if (strncmp(name, "val", 3) == 0)
+	    {
+	      result->name = "%VAL";
+	      break;
+	    }
+	default:
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
+		      "function at %C") == FAILURE)
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  m = match_actual_arg (&result->expr);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = old_locus;
+  return m;
+}
+
+
+/* Matches an actual argument list of a function or subroutine, from
+   the opening parenthesis to the closing parenthesis.  The argument
+   list is assumed to allow keyword arguments because we don't know if
+   the symbol associated with the procedure has an implicit interface
+   or not.  We make sure keywords are unique. If SUB_FLAG is set,
+   we're matching the argument list of a subroutine.  */
+
+match
+gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
+{
+  gfc_actual_arglist *head, *tail;
+  int seen_keyword;
+  gfc_st_label *label;
+  locus old_loc;
+  match m;
+
+  *argp = tail = NULL;
+  old_loc = gfc_current_locus;
+
+  seen_keyword = 0;
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    return (sub_flag) ? MATCH_YES : MATCH_NO;
+
+  if (gfc_match_char (')') == MATCH_YES)
+    return MATCH_YES;
+  head = NULL;
+
+  for (;;)
+    {
+      if (head == NULL)
+	head = tail = gfc_get_actual_arglist ();
+      else
+	{
+	  tail->next = gfc_get_actual_arglist ();
+	  tail = tail->next;
+	}
+
+      if (sub_flag && gfc_match_char ('*') == MATCH_YES)
+	{
+	  m = gfc_match_st_label (&label);
+	  if (m == MATCH_NO)
+	    gfc_error ("Expected alternate return label at %C");
+	  if (m != MATCH_YES)
+	    goto cleanup;
+
+	  tail->label = label;
+	  goto next;
+	}
+
+      /* After the first keyword argument is seen, the following
+         arguments must also have keywords.  */
+      if (seen_keyword)
+	{
+	  m = match_keyword_arg (tail, head);
+
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error
+		("Missing keyword name in actual argument list at %C");
+	      goto cleanup;
+	    }
+
+	}
+      else
+	{
+	  /* Try an argument list function, like %VAL.  */
+	  m = match_arg_list_function (tail);
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+
+	  /* See if we have the first keyword argument.  */
+	  if (m == MATCH_NO)
+	    {
+	      m = match_keyword_arg (tail, head);
+	      if (m == MATCH_YES)
+		seen_keyword = 1;
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	    }
+
+	  if (m == MATCH_NO)
+	    {
+	      /* Try for a non-keyword argument.  */
+	      m = match_actual_arg (&tail->expr);
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	      if (m == MATCH_NO)
+		goto syntax;
+	    }
+	}
+
+
+    next:
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  *argp = head;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in argument list at %C");
+
+cleanup:
+  gfc_free_actual_arglist (head);
+  gfc_current_locus = old_loc;
+
+  return MATCH_ERROR;
+}
+
+
+/* Used by match_varspec() to extend the reference list by one
+   element.  */
+
+static gfc_ref *
+extend_ref (gfc_expr * primary, gfc_ref * tail)
+{
+
+  if (primary->ref == NULL)
+    primary->ref = tail = gfc_get_ref ();
+  else
+    {
+      if (tail == NULL)
+	gfc_internal_error ("extend_ref(): Bad tail");
+      tail->next = gfc_get_ref ();
+      tail = tail->next;
+    }
+
+  return tail;
+}
+
+
+/* Match any additional specifications associated with the current
+   variable like member references or substrings.  If equiv_flag is
+   set we only match stuff that is allowed inside an EQUIVALENCE
+   statement.  */
+
+static match
+match_varspec (gfc_expr * primary, int equiv_flag)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_ref *substring, *tail;
+  gfc_component *component;
+  gfc_symbol *sym = primary->symtree->n.sym;
+  match m;
+
+  tail = NULL;
+
+  if ((equiv_flag && gfc_peek_char () == '(')
+      || sym->attr.dimension)
+    {
+      /* In EQUIVALENCE, we don't know yet whether we are seeing
+	 an array, character variable or array of character
+	 variables.  We'll leave the decision till resolve
+	 time.  */
+      tail = extend_ref (primary, tail);
+      tail->type = REF_ARRAY;
+
+      m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
+			       equiv_flag);
+      if (m != MATCH_YES)
+	return m;
+
+      if (equiv_flag && gfc_peek_char () == '(')
+	{
+	  tail = extend_ref (primary, tail);
+	  tail->type = REF_ARRAY;
+
+	  m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+	  if (m != MATCH_YES)
+	    return m;
+	}
+    }
+
+  primary->ts = sym->ts;
+
+  if (equiv_flag)
+    return MATCH_YES;
+
+  if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
+    goto check_substring;
+
+  sym = sym->ts.derived;
+
+  for (;;)
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	gfc_error ("Expected structure component name at %C");
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      component = gfc_find_component (sym, name);
+      if (component == NULL)
+	return MATCH_ERROR;
+
+      tail = extend_ref (primary, tail);
+      tail->type = REF_COMPONENT;
+
+      tail->u.c.component = component;
+      tail->u.c.sym = sym;
+
+      primary->ts = component->ts;
+
+      if (component->as != NULL)
+	{
+	  tail = extend_ref (primary, tail);
+	  tail->type = REF_ARRAY;
+
+	  m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
+	  if (m != MATCH_YES)
+	    return m;
+	}
+
+      if (component->ts.type != BT_DERIVED
+	  || gfc_match_char ('%') != MATCH_YES)
+	break;
+
+      sym = component->ts.derived;
+    }
+
+check_substring:
+  if (primary->ts.type == BT_UNKNOWN)
+    {
+      if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+       {
+         gfc_set_default_type (sym, 0, sym->ns);
+         primary->ts = sym->ts;
+       }
+    }
+
+  if (primary->ts.type == BT_CHARACTER)
+    {
+      switch (match_substring (primary->ts.cl, equiv_flag, &substring))
+	{
+	case MATCH_YES:
+	  if (tail == NULL)
+	    primary->ref = substring;
+	  else
+	    tail->next = substring;
+
+	  if (primary->expr_type == EXPR_CONSTANT)
+	    primary->expr_type = EXPR_SUBSTRING;
+
+	  if (substring)
+	    primary->ts.cl = NULL;
+
+	  break;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Given an expression that is a variable, figure out what the
+   ultimate variable's type and attribute is, traversing the reference
+   structures if necessary.
+
+   This subroutine is trickier than it looks.  We start at the base
+   symbol and store the attribute.  Component references load a
+   completely new attribute.
+
+   A couple of rules come into play.  Subobjects of targets are always
+   targets themselves.  If we see a component that goes through a
+   pointer, then the expression must also be a target, since the
+   pointer is associated with something (if it isn't core will soon be
+   dumped).  If we see a full part or section of an array, the
+   expression is also an array.
+
+   We can have at most one full array reference.  */
+
+symbol_attribute
+gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
+{
+  int dimension, pointer, allocatable, target;
+  symbol_attribute attr;
+  gfc_ref *ref;
+
+  if (expr->expr_type != EXPR_VARIABLE)
+    gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
+
+  ref = expr->ref;
+  attr = expr->symtree->n.sym->attr;
+
+  dimension = attr.dimension;
+  pointer = attr.pointer;
+  allocatable = attr.allocatable;
+
+  target = attr.target;
+  if (pointer)
+    target = 1;
+
+  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
+    *ts = expr->symtree->n.sym->ts;
+
+  for (; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+
+	switch (ref->u.ar.type)
+	  {
+	  case AR_FULL:
+	    dimension = 1;
+	    break;
+
+	  case AR_SECTION:
+	    allocatable = pointer = 0;
+	    dimension = 1;
+	    break;
+
+	  case AR_ELEMENT:
+	    allocatable = pointer = 0;
+	    break;
+
+	  case AR_UNKNOWN:
+	    gfc_internal_error ("gfc_variable_attr(): Bad array reference");
+	  }
+
+	break;
+
+      case REF_COMPONENT:
+	gfc_get_component_attr (&attr, ref->u.c.component);
+	if (ts != NULL)
+	  *ts = ref->u.c.component->ts;
+
+	pointer = ref->u.c.component->pointer;
+	allocatable = ref->u.c.component->allocatable;
+	if (pointer)
+	  target = 1;
+
+	break;
+
+      case REF_SUBSTRING:
+	allocatable = pointer = 0;
+	break;
+      }
+
+  attr.dimension = dimension;
+  attr.pointer = pointer;
+  attr.allocatable = allocatable;
+  attr.target = target;
+
+  return attr;
+}
+
+
+/* Return the attribute from a general expression.  */
+
+symbol_attribute
+gfc_expr_attr (gfc_expr * e)
+{
+  symbol_attribute attr;
+
+  switch (e->expr_type)
+    {
+    case EXPR_VARIABLE:
+      attr = gfc_variable_attr (e, NULL);
+      break;
+
+    case EXPR_FUNCTION:
+      gfc_clear_attr (&attr);
+
+      if (e->value.function.esym != NULL)
+	attr = e->value.function.esym->result->attr;
+
+      /* TODO: NULL() returns pointers.  May have to take care of this
+         here.  */
+
+      break;
+
+    default:
+      gfc_clear_attr (&attr);
+      break;
+    }
+
+  return attr;
+}
+
+
+/* Match a structure constructor.  The initial symbol has already been
+   seen.  */
+
+match
+gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
+{
+  gfc_constructor *head, *tail;
+  gfc_component *comp;
+  gfc_expr *e;
+  locus where;
+  match m;
+
+  head = tail = NULL;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  where = gfc_current_locus;
+
+  gfc_find_component (sym, NULL);
+
+  for (comp = sym->components; comp; comp = comp->next)
+    {
+      if (head == NULL)
+	tail = head = gfc_get_constructor ();
+      else
+	{
+	  tail->next = gfc_get_constructor ();
+	  tail = tail->next;
+	}
+
+      m = gfc_match_expr (&tail->expr);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (gfc_match_char (',') == MATCH_YES)
+	{
+	  if (comp->next == NULL)
+	    {
+	      gfc_error
+		("Too many components in structure constructor at %C");
+	      goto cleanup;
+	    }
+
+	  continue;
+	}
+
+      break;
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  if (comp->next != NULL)
+    {
+      gfc_error ("Too few components in structure constructor at %C");
+      goto cleanup;
+    }
+
+  e = gfc_get_expr ();
+
+  e->expr_type = EXPR_STRUCTURE;
+
+  e->ts.type = BT_DERIVED;
+  e->ts.derived = sym;
+  e->where = where;
+
+  e->value.constructor = head;
+
+  *result = e;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in structure constructor at %C");
+
+cleanup:
+  gfc_free_constructor (head);
+  return MATCH_ERROR;
+}
+
+
+/* Matches a variable name followed by anything that might follow it--
+   array reference, argument list of a function, etc.  */
+
+match
+gfc_match_rvalue (gfc_expr ** result)
+{
+  gfc_actual_arglist *actual_arglist;
+  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_state_data *st;
+  gfc_symbol *sym;
+  gfc_symtree *symtree;
+  locus where, old_loc;
+  gfc_expr *e;
+  match m, m2;
+  int i;
+  gfc_typespec *ts;
+  bool implicit_char;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
+    i = gfc_get_sym_tree (name, NULL, &symtree);
+  else
+    i = gfc_get_ha_sym_tree (name, &symtree);
+
+  if (i)
+    return MATCH_ERROR;
+
+  sym = symtree->n.sym;
+  e = NULL;
+  where = gfc_current_locus;
+
+  gfc_set_sym_referenced (sym);
+
+  if (sym->attr.function && sym->result == sym)
+    {
+      /* See if this is a directly recursive function call.  */
+      gfc_gobble_whitespace ();
+      if (sym->attr.recursive
+	    && gfc_peek_char () == '('
+	    && gfc_current_ns->proc_name == sym)
+	{
+	  if (!sym->attr.dimension)
+	    goto function0;
+
+	  gfc_error ("'%s' is array valued and directly recursive "
+		     "at %C , so the keyword RESULT must be specified "
+		     "in the FUNCTION statement", sym->name);
+	  return MATCH_ERROR;
+	}
+	
+      if (gfc_current_ns->proc_name == sym
+	  || (gfc_current_ns->parent != NULL
+	      && gfc_current_ns->parent->proc_name == sym))
+	goto variable;
+
+      if (sym->attr.entry
+	  && (sym->ns == gfc_current_ns
+	      || sym->ns == gfc_current_ns->parent))
+	{
+	  gfc_entry_list *el = NULL;
+	  
+	  for (el = sym->ns->entries; el; el = el->next)
+	    if (sym == el->sym)
+	      goto variable;
+	}
+    }
+
+  if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
+    goto function0;
+
+  if (sym->attr.generic)
+    goto generic_function;
+
+  switch (sym->attr.flavor)
+    {
+    case FL_VARIABLE:
+    variable:
+      if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
+	  && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+	gfc_set_default_type (sym, 0, sym->ns);
+
+      e = gfc_get_expr ();
+
+      e->expr_type = EXPR_VARIABLE;
+      e->symtree = symtree;
+
+      m = match_varspec (e, 0);
+      break;
+
+    case FL_PARAMETER:
+      /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
+	 end up here.  Unfortunately, sym->value->expr_type is set to 
+	 EXPR_CONSTANT, and so the if () branch would be followed without
+	 the !sym->as check.  */
+      if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
+	e = gfc_copy_expr (sym->value);
+      else
+	{
+	  e = gfc_get_expr ();
+	  e->expr_type = EXPR_VARIABLE;
+	}
+
+      e->symtree = symtree;
+      m = match_varspec (e, 0);
+      break;
+
+    case FL_DERIVED:
+      sym = gfc_use_derived (sym);
+      if (sym == NULL)
+	m = MATCH_ERROR;
+      else
+        m = gfc_match_structure_constructor (sym, &e);
+      break;
+
+    /* If we're here, then the name is known to be the name of a
+       procedure, yet it is not sure to be the name of a function.  */
+    case FL_PROCEDURE:
+      if (sym->attr.subroutine)
+	{
+	  gfc_error ("Unexpected use of subroutine name '%s' at %C",
+		     sym->name);
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      /* At this point, the name has to be a non-statement function.
+         If the name is the same as the current function being
+         compiled, then we have a variable reference (to the function
+         result) if the name is non-recursive.  */
+
+      st = gfc_enclosing_unit (NULL);
+
+      if (st != NULL && st->state == COMP_FUNCTION
+	  && st->sym == sym
+	  && !sym->attr.recursive)
+	{
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+
+	  m = match_varspec (e, 0);
+	  break;
+	}
+
+    /* Match a function reference.  */
+    function0:
+      m = gfc_match_actual_arglist (0, &actual_arglist);
+      if (m == MATCH_NO)
+	{
+	  if (sym->attr.proc == PROC_ST_FUNCTION)
+	    gfc_error ("Statement function '%s' requires argument list at %C",
+		       sym->name);
+	  else
+	    gfc_error ("Function '%s' requires an argument list at %C",
+		       sym->name);
+
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      if (m != MATCH_YES)
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      gfc_get_ha_sym_tree (name, &symtree);	/* Can't fail */
+      sym = symtree->n.sym;
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+      e->expr_type = EXPR_FUNCTION;
+      e->value.function.actual = actual_arglist;
+      e->where = gfc_current_locus;
+
+      if (sym->as != NULL)
+	e->rank = sym->as->rank;
+
+      if (!sym->attr.function
+	  && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      if (sym->result == NULL)
+	sym->result = sym;
+
+      m = MATCH_YES;
+      break;
+
+    case FL_UNKNOWN:
+
+      /* Special case for derived type variables that get their types
+         via an IMPLICIT statement.  This can't wait for the
+         resolution phase.  */
+
+      if (gfc_peek_char () == '%'
+	  && sym->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+	gfc_set_default_type (sym, 0, sym->ns);
+
+      /* If the symbol has a dimension attribute, the expression is a
+         variable.  */
+
+      if (sym->attr.dimension)
+	{
+	  if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+			      sym->name, NULL) == FAILURE)
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+	  m = match_varspec (e, 0);
+	  break;
+	}
+
+      /* Name is not an array, so we peek to see if a '(' implies a
+         function call or a substring reference.  Otherwise the
+         variable is just a scalar.  */
+
+      gfc_gobble_whitespace ();
+      if (gfc_peek_char () != '(')
+	{
+	  /* Assume a scalar variable */
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+
+	  if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+			      sym->name, NULL) == FAILURE)
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  e->ts = sym->ts;
+	  m = match_varspec (e, 0);
+	  break;
+	}
+
+      /* See if this is a function reference with a keyword argument
+	 as first argument. We do this because otherwise a spurious
+	 symbol would end up in the symbol table.  */
+
+      old_loc = gfc_current_locus;
+      m2 = gfc_match (" ( %n =", argname);
+      gfc_current_locus = old_loc;
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+
+      if (m2 != MATCH_YES)
+	{
+	  /* Try to figure out whether we're dealing with a character type.
+	     We're peeking ahead here, because we don't want to call 
+	     match_substring if we're dealing with an implicitly typed
+	     non-character variable.  */
+	  implicit_char = false;
+	  if (sym->ts.type == BT_UNKNOWN)
+	    {
+	      ts = gfc_get_default_type (sym,NULL);
+	      if (ts->type == BT_CHARACTER)
+		implicit_char = true;
+	    }
+
+	  /* See if this could possibly be a substring reference of a name
+	     that we're not sure is a variable yet.  */
+
+	  if ((implicit_char || sym->ts.type == BT_CHARACTER)
+	      && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
+	    {
+
+	      e->expr_type = EXPR_VARIABLE;
+
+	      if (sym->attr.flavor != FL_VARIABLE
+		  && gfc_add_flavor (&sym->attr, FL_VARIABLE,
+				     sym->name, NULL) == FAILURE)
+		{
+		  m = MATCH_ERROR;
+		  break;
+		}
+
+	      if (sym->ts.type == BT_UNKNOWN
+		  && gfc_set_default_type (sym, 1, NULL) == FAILURE)
+		{
+		  m = MATCH_ERROR;
+		  break;
+		}
+
+	      e->ts = sym->ts;
+	      if (e->ref)
+		e->ts.cl = NULL;
+	      m = MATCH_YES;
+	      break;
+	    }
+	}
+
+      /* Give up, assume we have a function.  */
+
+      gfc_get_sym_tree (name, NULL, &symtree);	/* Can't fail */
+      sym = symtree->n.sym;
+      e->expr_type = EXPR_FUNCTION;
+
+      if (!sym->attr.function
+	  && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      sym->result = sym;
+
+      m = gfc_match_actual_arglist (0, &e->value.function.actual);
+      if (m == MATCH_NO)
+	gfc_error ("Missing argument list in function '%s' at %C", sym->name);
+
+      if (m != MATCH_YES)
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      /* If our new function returns a character, array or structure
+         type, it might have subsequent references.  */
+
+      m = match_varspec (e, 0);
+      if (m == MATCH_NO)
+	m = MATCH_YES;
+
+      break;
+
+    generic_function:
+      gfc_get_sym_tree (name, NULL, &symtree);	/* Can't fail */
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+      e->expr_type = EXPR_FUNCTION;
+
+      m = gfc_match_actual_arglist (0, &e->value.function.actual);
+      break;
+
+    default:
+      gfc_error ("Symbol at %C is not appropriate for an expression");
+      return MATCH_ERROR;
+    }
+
+  if (m == MATCH_YES)
+    {
+      e->where = where;
+      *result = e;
+    }
+  else
+    gfc_free_expr (e);
+
+  return m;
+}
+
+
+/* Match a variable, ie something that can be assigned to.  This
+   starts as a symbol, can be a structure component or an array
+   reference.  It can be a function if the function doesn't have a
+   separate RESULT variable.  If the symbol has not been previously
+   seen, we assume it is a variable.
+
+   This function is called by two interface functions:
+   gfc_match_variable, which has host_flag = 1, and
+   gfc_match_equiv_variable, with host_flag = 0, to restrict the
+   match of the symbol to the local scope.  */
+
+static match
+match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
+{
+  gfc_symbol *sym;
+  gfc_symtree *st;
+  gfc_expr *expr;
+  locus where;
+  match m;
+
+  /* Since nothing has any business being an lvalue in a module
+     specification block, an interface block or a contains section,
+     we force the changed_symbols mechanism to work by setting
+     host_flag to 0. This prevents valid symbols that have the name
+     of keywords, such as 'end', being turned into variables by
+     failed matching to assignments for, eg., END INTERFACE.  */
+  if (gfc_current_state () == COMP_MODULE
+      || gfc_current_state () == COMP_INTERFACE
+      || gfc_current_state () == COMP_CONTAINS)
+    host_flag = 0;
+
+  m = gfc_match_sym_tree (&st, host_flag);
+  if (m != MATCH_YES)
+    return m;
+  where = gfc_current_locus;
+
+  sym = st->n.sym;
+  gfc_set_sym_referenced (sym);
+  switch (sym->attr.flavor)
+    {
+    case FL_VARIABLE:
+      break;
+
+    case FL_UNKNOWN:
+      if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+			  sym->name, NULL) == FAILURE)
+	return MATCH_ERROR;
+      break;
+
+    case FL_PARAMETER:
+      if (equiv_flag)
+	gfc_error ("Named constant at %C in an EQUIVALENCE");
+      else
+	gfc_error ("Cannot assign to a named constant at %C");
+      return MATCH_ERROR;
+      break;
+
+    case FL_PROCEDURE:
+      /* Check for a nonrecursive function result */
+      if (sym->attr.function && (sym->result == sym || sym->attr.entry)
+	  && !sym->attr.external)
+	{
+	  /* If a function result is a derived type, then the derived
+	     type may still have to be resolved.  */
+
+	  if (sym->ts.type == BT_DERIVED
+	      && gfc_use_derived (sym->ts.derived) == NULL)
+	    return MATCH_ERROR;
+	  break;
+	}
+
+      /* Fall through to error */
+
+    default:
+      gfc_error ("Expected VARIABLE at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Special case for derived type variables that get their types
+     via an IMPLICIT statement.  This can't wait for the
+     resolution phase.  */
+
+    {
+      gfc_namespace * implicit_ns;
+
+      if (gfc_current_ns->proc_name == sym)
+	implicit_ns = gfc_current_ns;
+      else
+	implicit_ns = sym->ns;
+	
+      if (gfc_peek_char () == '%'
+	  && sym->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+	gfc_set_default_type (sym, 0, implicit_ns);
+    }
+
+  expr = gfc_get_expr ();
+
+  expr->expr_type = EXPR_VARIABLE;
+  expr->symtree = st;
+  expr->ts = sym->ts;
+  expr->where = where;
+
+  /* Now see if we have to do more.  */
+  m = match_varspec (expr, equiv_flag);
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (expr);
+      return m;
+    }
+
+  *result = expr;
+  return MATCH_YES;
+}
+
+match
+gfc_match_variable (gfc_expr ** result, int equiv_flag)
+{
+  return match_variable (result, equiv_flag, 1);
+}
+
+match
+gfc_match_equiv_variable (gfc_expr ** result)
+{
+  return match_variable (result, 1, 0);
+}
+