re PR fortran/17941 (gfortran: parser chokes on complex literal constant)

2004-01-23  Paul Brook  <paul@codesourcery.com>
	Steven G. Kargl  <kargls@comcast.net>

	PR fortran/17941
	* arith.c (gfc_convert_real): Remove sign handling.
	* primary.c (match_digits): Allow whitespace after initial sign.
	(match_real_const): Handle signs here.  Allow whitespace after
	initial sign.  Remove dead code.
	(match_const_complex_part): Remove.
	(match_complex_part): Use match_{real,integer}_const.
	(match_complex_constant): Cross-promote integer types.
testsuite/
	* gfortran.dg/real_const_1.f: New test.
	* gfortran.dg/real_const_2.f90: New test.
	* gfortran.dg/complex_int_1.f90: New test.

From-SVN: r94127

1 files changed, 51 insertions, 166 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 6496bcd..a2d1d1f 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -144,6 +144,7 @@ match_digits (int signflag, int radix, char *buffer)
     {
       if (buffer != NULL)
 	*buffer++ = c;
+      gfc_gobble_whitespace ();
       c = gfc_next_char ();
       length++;
     }
@@ -329,7 +330,8 @@ backup:
 }
 
 
-/* Match a real constant of some sort.  */
+/* 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)
@@ -338,6 +340,7 @@ match_real_constant (gfc_expr ** result, int signflag)
   locus old_loc, temp_loc;
   char *p, *buffer;
   gfc_expr *e;
+  bool negate;
 
   old_loc = gfc_current_locus;
   gfc_gobble_whitespace ();
@@ -348,12 +351,16 @@ match_real_constant (gfc_expr ** result, int signflag)
   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 ();
-      count++;
     }
 
   /* Scan significand.  */
@@ -392,7 +399,8 @@ match_real_constant (gfc_expr ** result, int signflag)
       break;
     }
 
-  if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
+  if (!seen_digits
+      || (c != 'e' && c != 'd' && c != 'q'))
     goto done;
   exp_char = c;
 
@@ -408,13 +416,6 @@ match_real_constant (gfc_expr ** result, int signflag)
 
   if (!ISDIGIT (c))
     {
-      /* TODO: seen_digits is always true at this point */
-      if (!seen_digits)
-	{
-	  gfc_current_locus = old_loc;
-	  return MATCH_NO;	/* ".e" can be something else */
-	}
-
       gfc_error ("Missing exponent in real number at %C");
       return MATCH_ERROR;
     }
@@ -426,7 +427,7 @@ match_real_constant (gfc_expr ** result, int signflag)
     }
 
 done:
-  /* See what we've got!  */
+  /* Check that we have a numeric constant.  */
   if (!seen_digits || (!seen_dp && exp_char == ' '))
     {
       gfc_current_locus = old_loc;
@@ -440,15 +441,26 @@ done:
   buffer = alloca (count + 1);
   memset (buffer, '\0', count + 1);
 
-  /* Hack for mpfr_set_str().  */
   p = buffer;
-  while (count > 0)
+  c = gfc_next_char ();
+  if (c == '+' || c == '-')
     {
-      *p = gfc_next_char ();
-      if (*p == 'd' || *p == 'q')
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+    }
+
+  /* Hack for mpfr_set_str().  */
+  for (;;)
+    {
+      if (c == 'd' || c == 'q')
 	*p = 'e';
+      else
+	*p = c;
       p++;
-      count--;
+      if (--count == 0)
+	break;
+
+      c = gfc_next_char ();
     }
 
   kind = get_kind ();
@@ -489,6 +501,8 @@ done:
     }
 
   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))
     {
@@ -994,152 +1008,6 @@ 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_current_locus = old_loc;
-  gfc_gobble_whitespace ();
-
-  buffer = alloca (count + 1);
-  memset (buffer, '\0', count + 1);
-
-  /* Hack for mpfr_set_str().  */
-  p = buffer;
-  while (count > 0)
-    {
-      c = gfc_next_char ();
-      if (c == 'd' || c == 'q')
-	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, true) < 0)
-	{
-	  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_current_locus = old_loc;
-  return MATCH_NO;
-}
-
-
 /* Match a real or imaginary part of a complex number.  */
 
 static match
@@ -1151,7 +1019,11 @@ match_complex_part (gfc_expr ** result)
   if (m != MATCH_NO)
     return m;
 
-  return match_const_complex_part (result);
+  m = match_real_constant (result, 1);
+  if (m != MATCH_NO)
+    return m;
+
+  return match_integer_constant (result, 1);
 }
 
 
@@ -1210,13 +1082,26 @@ match_complex_constant (gfc_expr ** result)
     goto cleanup;
 
   /* Decide on the kind of this complex number.  */
-  kind = gfc_kind_max (real, imag);
+  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 (kind != real->ts.kind)
+  if (real->ts.type != BT_REAL || kind != real->ts.kind)
     gfc_convert_type (real, &target, 2);
-  if (kind != imag->ts.kind)
+  if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
     gfc_convert_type (imag, &target, 2);
 
   e = gfc_convert_complex (real, imag, kind);