Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

1 files changed, 2214 insertions, 0 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
new file mode 100644
index 0000000..03e9757
--- /dev/null
+++ b/gcc/fortran/primary.c
@@ -0,0 +1,2214 @@
+/* Primary expression subroutines
+   Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GNU G95.
+
+GNU G95 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.
+
+GNU G95 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 GNU G95; 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 "system.h"
+#include "flags.h"
+
+#include <string.h>
+#include <stdlib.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);
+  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 = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f');
+      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;
+      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_set_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_set_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) == -1)
+    {
+      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 binary, octal or hexadecimal constant that can be found in
+   a DATA statement.  */
+
+static match
+match_boz_constant (gfc_expr ** result)
+{
+  int radix, delim, length;
+  locus old_loc;
+  char *buffer;
+  gfc_expr *e;
+  const char *rname;
+
+  old_loc = *gfc_current_locus ();
+  gfc_gobble_whitespace ();
+
+  switch (gfc_next_char ())
+    {
+    case 'b':
+      radix = 2;
+      rname = "binary";
+      break;
+    case 'o':
+      radix = 8;
+      rname = "octal";
+      break;
+    case 'x':
+      if (pedantic)
+       gfc_warning_now ("Hexadecimal constant at %C uses non-standard "
+                        "syntax. Use \"Z\" instead.");
+      /* Fall through.  */
+    case 'z':
+      radix = 16;
+      rname = "hexadecimal";
+      break;
+    default:
+      goto backup;
+    }
+
+  /* No whitespace allowed here.  */
+
+  delim = gfc_next_char ();
+  if (delim != '\'' && delim != '\"')
+    goto backup;
+
+  old_loc = *gfc_current_locus ();
+
+  length = match_digits (0, radix, NULL);
+  if (length == -1)
+    {
+      gfc_error ("Empty set of digits in %s constants at %C", rname);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_next_char () != delim)
+    {
+      gfc_error ("Illegal character in %s constant at %C.", rname);
+      return MATCH_ERROR;
+    }
+
+  gfc_set_locus (&old_loc);
+
+  buffer = alloca (length + 1);
+  memset (buffer, '\0', length + 1);
+
+  match_digits (0, radix, buffer);
+  gfc_next_char ();
+
+  e = gfc_convert_integer (buffer, gfc_default_integer_kind (), radix,
+			   gfc_current_locus ());
+
+  if (gfc_range_check (e) != ARITH_OK)
+    {
+      gfc_error ("Integer too big for default integer kind at %C");
+
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  *result = e;
+  return MATCH_YES;
+
+backup:
+  gfc_set_locus (&old_loc);
+  return MATCH_NO;
+}
+
+
+/* Match a real constant of some sort.  */
+
+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;
+
+  old_loc = *gfc_current_locus ();
+  gfc_gobble_whitespace ();
+
+  e = NULL;
+
+  count = 0;
+  seen_dp = 0;
+  seen_digits = 0;
+  exp_char = ' ';
+
+  c = gfc_next_char ();
+  if (signflag && (c == '+' || c == '-'))
+    {
+      c = gfc_next_char ();
+      count++;
+    }
+
+  /* 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_set_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))
+    {
+      /* TODO: seen_digits is always true at this point */
+      if (!seen_digits)
+	{
+	  gfc_set_locus (&old_loc);
+	  return MATCH_NO;	/* ".e" can be something else */
+	}
+
+      gfc_error ("Missing exponent in real number at %C");
+      return MATCH_ERROR;
+    }
+
+  while (ISDIGIT (c))
+    {
+      c = gfc_next_char ();
+      count++;
+    }
+
+done:
+  /* See what we've got!  */
+  if (!seen_digits || (!seen_dp && exp_char == ' '))
+    {
+      gfc_set_locus (&old_loc);
+      return MATCH_NO;
+    }
+
+  /* Convert the number.  */
+  gfc_set_locus (&old_loc);
+  gfc_gobble_whitespace ();
+
+  buffer = alloca (count + 1);
+  memset (buffer, '\0', count + 1);
+
+  /* Hack for mpf_init_set_str().  */
+  p = buffer;
+  while (count > 0)
+    {
+      *p = gfc_next_char ();
+      if (*p == 'd' || *p == 'q')
+	*p = 'e';
+      p++;
+      count--;
+    }
+
+  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;
+
+    case 'q':
+      if (kind != -2)
+	{
+	  gfc_error
+	    ("Real number at %C has a 'q' exponent and an explicit kind");
+	  goto cleanup;
+	}
+      kind = gfc_option.q_kind;
+      break;
+
+    default:
+      if (kind == -2)
+	kind = gfc_default_real_kind ();
+
+      if (gfc_validate_kind (BT_REAL, kind) == -1)
+	{
+	  gfc_error ("Invalid real kind %d at %C", kind);
+	  goto cleanup;
+	}
+    }
+
+  e = gfc_convert_real (buffer, kind, gfc_current_locus ());
+
+  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:
+      gfc_error ("Real constant underflows its kind at %C");
+      goto cleanup;
+
+    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_set_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 (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_set_locus (&old_locus);
+	  break;
+	}
+    }
+
+  if (c != delimiter)
+    return c;
+
+  old_locus = *gfc_current_locus ();
+  c = gfc_next_char_literal (1);
+
+  if (c == delimiter)
+    return c;
+  gfc_set_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: weird 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_set_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;
+  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_set_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) == -1)
+    {
+      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_set_locus (&start_locus);
+	  gfc_error ("Unterminated character constant beginning at %C");
+	  return MATCH_ERROR;
+	}
+
+      length++;
+    }
+
+  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_set_locus (&start_locus);
+  gfc_next_char ();		/* Skip delimiter */
+
+  for (i = 0; i < length; i++)
+    *p++ = next_string_char (delimiter);
+
+  *p = '\0';	/* TODO: C-style string is for development/debug purposes.  */
+
+  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_set_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) == -1)
+    gfc_error ("Bad kind for logical constant at %C");
+
+  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;
+    }
+
+  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 the real and imaginary parts of a complex number.  This
+   subroutine is essentially match_real_constant() modified in a
+   couple of ways: A sign is always allowed and numbers that would
+   look like an integer to match_real_constant() are automatically
+   created as floating point numbers.  The messiness involved with
+   making sure a decimal point belongs to the number and not a
+   trailing operator is not necessary here either (Hooray!).  */
+
+static match
+match_const_complex_part (gfc_expr ** result)
+{
+  int kind, seen_digits, seen_dp, count;
+  char *p, c, exp_char, *buffer;
+  locus old_loc;
+
+  old_loc = *gfc_current_locus ();
+  gfc_gobble_whitespace ();
+
+  seen_dp = 0;
+  seen_digits = 0;
+  count = 0;
+  exp_char = ' ';
+
+  c = gfc_next_char ();
+  if (c == '-' || c == '+')
+    {
+      c = gfc_next_char ();
+      count++;
+    }
+
+  for (;; c = gfc_next_char (), count++)
+    {
+      if (c == '.')
+	{
+	  if (seen_dp)
+	    goto no_match;
+	  seen_dp = 1;
+	  continue;
+	}
+
+      if (ISDIGIT (c))
+	{
+	  seen_digits = 1;
+	  continue;
+	}
+
+      break;
+    }
+
+  if (!seen_digits || (c != 'd' && c != 'e'))
+    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:
+  if (!seen_digits)
+    goto no_match;
+
+  /* Convert the number.  */
+  gfc_set_locus (&old_loc);
+  gfc_gobble_whitespace ();
+
+  buffer = alloca (count + 1);
+  memset (buffer, '\0', count + 1);
+
+  /* Hack for mpf_init_set_str().  */
+  p = buffer;
+  while (count > 0)
+    {
+      c = gfc_next_char ();
+      if (c == 'd')
+	c = 'e';
+      *p++ = c;
+      count--;
+    }
+
+  *p = '\0';
+
+  kind = get_kind ();
+  if (kind == -1)
+    return MATCH_ERROR;
+
+  /* If the number looked like an integer, forget about a kind we may
+     have seen, otherwise validate the kind against real kinds.  */
+  if (seen_dp == 0 && exp_char == ' ')
+    {
+      if (kind == -2)
+	kind = gfc_default_integer_kind ();
+
+    }
+  else
+    {
+      if (exp_char == 'd')
+	{
+	  if (kind != -2)
+	    {
+	      gfc_error
+		("Real number at %C has a 'd' exponent and an explicit kind");
+	      return MATCH_ERROR;
+	    }
+	  kind = gfc_default_double_kind ();
+
+	}
+      else
+	{
+	  if (kind == -2)
+	    kind = gfc_default_real_kind ();
+	}
+
+      if (gfc_validate_kind (BT_REAL, kind) == -1)
+	{
+	  gfc_error ("Invalid real kind %d at %C", kind);
+	  return MATCH_ERROR;
+	}
+    }
+
+  *result = gfc_convert_real (buffer, kind, gfc_current_locus ());
+  return MATCH_YES;
+
+no_match:
+  gfc_set_locus (&old_loc);
+  return MATCH_NO;
+}
+
+
+/* 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;
+
+  return match_const_complex_part (result);
+}
+
+
+/* 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)
+    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)
+    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)
+    goto syntax;
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  /* Decide on the kind of this complex number.  */
+  kind = gfc_kind_max (real, imag);
+  target.type = BT_REAL;
+  target.kind = kind;
+
+  if (kind != real->ts.kind)
+    gfc_convert_type (real, &target, 2);
+  if (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_set_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_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_set_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->result == sym
+	      && (gfc_current_ns->proc_name == sym
+		  || (gfc_current_ns->parent != NULL
+		      && gfc_current_ns->parent->proc_name == sym)))
+	    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_set_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 (strcmp (a->name, name) == 0)
+	  {
+	    gfc_error
+	      ("Keyword '%s' at %C has already appeared in the current "
+	       "argument list", name);
+	    return MATCH_ERROR;
+	  }
+    }
+
+  strcpy (actual->name, name);
+  return MATCH_YES;
+
+cleanup:
+  gfc_set_locus (&name_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.  */
+
+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, 0);
+	  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
+	{
+	  /* See if we have the first keyword argument.  */
+	  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_set_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;
+  match m;
+
+  tail = NULL;
+
+  if (primary->symtree->n.sym->attr.dimension
+      || (equiv_flag
+	  && gfc_peek_char () == '('))
+    {
+
+      tail = extend_ref (primary, tail);
+      tail->type = REF_ARRAY;
+
+      m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
+                               equiv_flag);
+      if (m != MATCH_YES)
+	return m;
+    }
+
+  sym = primary->symtree->n.sym;
+  primary->ts = sym->ts;
+
+  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_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;
+
+	  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, 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;
+
+  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:
+	    pointer = 0;
+	    dimension = 1;
+	    break;
+
+	  case AR_ELEMENT:
+	    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;
+	if (pointer)
+	  target = 1;
+
+	break;
+
+      case REF_SUBSTRING:
+	pointer = 0;
+	break;
+      }
+
+  attr.dimension = dimension;
+  attr.pointer = pointer;
+  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.  */
+
+static match
+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];
+  gfc_state_data *st;
+  gfc_symbol *sym;
+  gfc_symtree *symtree;
+  locus where;
+  gfc_expr *e;
+  match m;
+  int i;
+
+  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
+      && (gfc_current_ns->proc_name == sym
+	  || (gfc_current_ns->parent != NULL
+	      && gfc_current_ns->parent->proc_name == 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:
+      if (sym->value
+	  && sym->value->expr_type != EXPR_ARRAY)
+	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 = 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, 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 () == '%'
+	  && 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, 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, NULL) == FAILURE)
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  e->ts = sym->ts;
+	  m = match_varspec (e, 0);
+	  break;
+	}
+
+      /* See if this could possibly be a substring reference of a name
+         that we're not sure is a variable yet.  */
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+
+      if ((sym->ts.type == BT_UNKNOWN || 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, 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;
+	  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, 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.  */
+
+match
+gfc_match_variable (gfc_expr ** result, int equiv_flag)
+{
+  gfc_symbol *sym;
+  gfc_symtree *st;
+  gfc_expr *expr;
+  locus where;
+  match m;
+
+  m = gfc_match_sym_tree (&st, 1);
+  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, NULL) == FAILURE)
+	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.  */
+
+      if (gfc_peek_char () == '%'
+	  && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+	gfc_set_default_type (sym, 0, sym->ns);
+
+      break;
+
+    case FL_PROCEDURE:
+      /* Check for a nonrecursive function result */
+      if (sym->attr.function && (sym->result == sym || sym->attr.entry))
+	{
+
+	  /* 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;
+    }
+
+  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;
+}