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

7 files changed, 135 insertions, 173 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c692f37..2cb1958 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+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.
+
 2005-01-23  James A. Morrison  <phython@gcc.gnu.org>
 
 	PR fortran/19294
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index eff7e90..924eea0 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -1928,15 +1928,9 @@ gfc_expr *
 gfc_convert_real (const char *buffer, int kind, locus * where)
 {
   gfc_expr *e;
-  const char *t;
 
   e = gfc_constant_result (BT_REAL, kind, where);
-  /* A leading plus is allowed in Fortran, but not by mpfr_set_str */
-  if (buffer[0] == '+')
-    t = buffer + 1;
-  else
-    t = buffer;
-  mpfr_set_str (e->value.real, t, 10, GFC_RND_MODE);
+  mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
 
   return e;
 }
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);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f47668b..bb6cc25 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2004-01-23  Steven G. Kargl  <kargls@comcast.net>
+	Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17941
+	* gfortran.dg/real_const_1.f: New test.
+	* gfortran.dg/real_const_2.f90: New test.
+	* gfortran.dg/complex_int_1.f90: New test.
+
 2005-01-23  Bud Davis  <bdavis9659@comcast.net>
 
 	PR fortran/19313
diff --git a/gcc/testsuite/gfortran.dg/complex_int_1.f90 b/gcc/testsuite/gfortran.dg/complex_int_1.f90
new file mode 100644
index 0000000..f287d8c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/complex_int_1.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Complex constants with integer components should take ther kind from
+! the real typed component, or default complex type if both components have
+! integer type.
+program prog
+  call test1 ((1_8, 1.0_4))
+  call test2 ((1_8, 2_8))
+contains
+subroutine test1(x)
+  complex(4) :: x
+end subroutine
+subroutine test2(x)
+  complex :: x
+end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/real_const_1.f b/gcc/testsuite/gfortran.dg/real_const_1.f
new file mode 100644
index 0000000..97b7f27
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/real_const_1.f
@@ -0,0 +1,24 @@
+c { dg-do run }
+c
+c Fixed form test program for PR 17941 (signed constants with spaces)
+c
+      program real_const_1
+      complex c0, c1, c2, c3, c4
+      real rp(4), rn(4)
+      parameter (c0 = (-0.5, -     0.5))
+      parameter (c1 = (-     0.5, +     0.5))
+      parameter (c2 = (-    0.5E2, +0.5))
+      parameter (c3 = (-0.5, +     0.5E-2))
+      parameter (c4 = (-     1, +     1))
+      data rn /- 1.0, - 1d0, - 1.d0, - 10.d-1/
+      data rp /+ 1.0, + 1d0, + 1.d0, + 10.d-1/
+      real, parameter :: del = 1.e-5
+
+      if (abs(c0 - cmplx(-0.5,-0.5)) > del) call abort
+      if (abs(c1 - cmplx(-0.5,+0.5)) > del) call abort
+      if (abs(c2 - cmplx(-0.5E2,+0.5)) > del) call abort
+      if (abs(c3 - cmplx(-0.5,+0.5E-2)) > del) call abort
+      if (abs(c4 - cmplx(-1.0,+1.0)) > del) call abort
+      if (any (abs (rp - 1.0) > del)) call abort
+      if (any (abs (rn + 1.0) > del)) call abort
+      end program
diff --git a/gcc/testsuite/gfortran.dg/real_const_2.f90 b/gcc/testsuite/gfortran.dg/real_const_2.f90
new file mode 100644
index 0000000..552012e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/real_const_2.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+!
+! Free form test program for PR 17941 (signed constants with spaces)
+!
+program real_const_2
+  complex c0, c1, c2, c3, c4
+  real rp(4), rn(4)
+  parameter (c0 = (-0.5, -     0.5))
+  parameter (c1 = (-     0.5, +     0.5))
+  parameter (c2 = (-    0.5E2, +0.5))
+  parameter (c3 = (-0.5, +     0.5E-2))
+  parameter (c4 = (-     1, +     1))
+  data rn /- 1.0, - 1d0, - 1.d0, - 10.d-1/
+  data rp /+ 1.0, + 1d0, + 1.d0, + 10.d-1/
+  real, parameter :: del = 1.e-5
+
+  if (abs(c0 - cmplx(-0.5,-0.5)) > del) call abort
+  if (abs(c1 - cmplx(-0.5,+0.5)) > del) call abort
+  if (abs(c2 - cmplx(-0.5E2,+0.5)) > del) call abort
+  if (abs(c3 - cmplx(-0.5,+0.5E-2)) > del) call abort
+  if (abs(c4 - cmplx(-1.0,+1.0)) > del) call abort
+  if (any (abs (rp - 1.0) > del)) call abort
+  if (any (abs (rn + 1.0) > del)) call abort
+end program