{
if (buffer != NULL)
*buffer++ = c;
+ gfc_gobble_whitespace ();
c = gfc_next_char ();
length++;
}
}
-/* 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)
locus old_loc, temp_loc;
char *p, *buffer;
gfc_expr *e;
+ bool negate;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
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. */
break;
}
- if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits
+ || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
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;
}
}
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;
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 ();
}
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))
{
}
-/* 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
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);
}
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);
--- /dev/null
+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
--- /dev/null
+! { 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