OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

simplify.c (gfc_simplify_modulo): Re-arrange code to test whether 'P' is zero and issue an error if it is.

Browse Source 
2018-09-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	* simplify.c (gfc_simplify_modulo): Re-arrange code to test whether
	'P' is zero and issue an error if it is.
	* gfortran.dg/modulo_check: New test.

From-SVN: r264070
This commit is contained in:
Jerry DeLisle 2018-09-03 18:38:20 +00:00
parent a5e8b06074
commit 53dede15de
4 changed files with 60 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/fortran/ChangeLog
View File

@ -1,3 +1,8 @@
2018-09-03 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* simplify.c (gfc_simplify_modulo): Re-arrange code to test whether
'P' is zero and issue an error if it is.
2018-08-31 Paul Thomas <pault@gcc.gnu.org>
PR fortran/86328

83
gcc/fortran/simplify.c
View File

@ -5525,52 +5525,55 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
gfc_expr *result;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
/* First check p. */
if (p->expr_type != EXPR_CONSTANT)
return NULL;
/* p shall not be 0. */
switch (p->ts.type)
{
case BT_INTEGER:
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
"P", &p->where);
return &gfc_bad_expr;
}
break;
case BT_REAL:
if (mpfr_cmp_ui (p->value.real, 0) == 0)
{
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
"P", &p->where);
return &gfc_bad_expr;
}
break;
default:
gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
}
if (a->expr_type != EXPR_CONSTANT)
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
case BT_INTEGER:
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
/* Result is processor-dependent. This processor just opts
to not handle it at all. */
gfc_error ("Second argument of MODULO at %L is zero", &a->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
if (a->ts.type == BT_INTEGER)
mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
break;
case BT_REAL:
if (mpfr_cmp_ui (p->value.real, 0) == 0)
{
/* Result is processor-dependent. */
gfc_error ("Second argument of MODULO at %L is zero", &p->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
gfc_set_model_kind (kind);
mpfr_fmod (result->value.real, a->value.real, p->value.real,
GFC_RND_MODE);
if (mpfr_cmp_ui (result->value.real, 0) != 0)
{
if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
mpfr_add (result->value.real, result->value.real, p->value.real,
GFC_RND_MODE);
}
else
mpfr_copysign (result->value.real, result->value.real,
p->value.real, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
else
{
gfc_set_model_kind (kind);
mpfr_fmod (result->value.real, a->value.real, p->value.real,
GFC_RND_MODE);
if (mpfr_cmp_ui (result->value.real, 0) != 0)
{
if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
mpfr_add (result->value.real, result->value.real, p->value.real,
GFC_RND_MODE);
}
else
mpfr_copysign (result->value.real, result->value.real,
p->value.real, GFC_RND_MODE);
}
return range_check (result, "MODULO");

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2018-09-03 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* gfortran.dg/modulo_check: New test.
2018-09-03 Richard Biener <rguenther@suse.de>
PR tree-optimization/87177

8
gcc/testsuite/gfortran.dg/modulo_check.f90 Normal file
View File

@ -0,0 +1,8 @@
! { dg-do compile }
! Test checks on modulo with p == 0
program p
logical :: a(2) = (modulo([2,3],0) == 0) ! { dg-error "shall not be zero" }
integer :: b = count(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" }
integer :: c = all(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" }
integer :: d = any(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" }
end program