diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 31 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 15 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 6 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 105 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 36 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 110 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 123 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/norm2_1.f90 | 91 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/norm2_2.f90 | 14 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/norm2_3.f90 | 95 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/norm_4.f90 | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/parity_1.f90 | 40 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/parity_2.f90 | 13 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/parity_3.f90 | 10 |
17 files changed, 718 insertions, 18 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a15c136..ba1ee59 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2010-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/33197 + * gcc/fortran/intrinsic.c (add_functions): Add norm2 and parity. + * gcc/fortran/intrinsic.h (gfc_check_norm2, gfc_check_parity): + gfc_simplify_norm2, gfc_simplify_parity, gfc_resolve_norm2, + gfc_resolve_parity): New prototypes. + * gcc/fortran/gfortran.h (gfc_isym_id): New enum items + GFC_ISYM_NORM2 and GFC_ISYM_PARITY. + * gcc/fortran/iresolve.c (gfc_resolve_norm2, + gfc_resolve_parity): New functions. + * gcc/fortran/check.c (gfc_check_norm2, gfc_check_parity): + New functions. + * gcc/fortran/trans-intrinsic.c (gfc_conv_intrinsic_arith, + gfc_conv_intrinsic_function): Handle NORM2 and PARITY. + * gcc/fortran/intrinsic.texi (NORM2, PARITY): Add. + * gcc/fortran/simplify.c (simplify_transformation_to_array): + Add post-processing opterator. + (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count, + gfc_simplify_product, gfc_simplify_sum): Update call. + (add_squared, do_sqrt, gfc_simplify_norm2, do_xor, + gfc_simplify_parity): New functions. + 2010-08-27 Janus Weil <janus@gcc.gnu.org> PR fortran/45420 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 36efffa..0ff6b6e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2432,6 +2432,21 @@ gfc_check_new_line (gfc_expr *a) gfc_try +gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) +{ + if (type_check (array, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, false) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +gfc_try gfc_check_null (gfc_expr *mold) { symbol_attribute attr; @@ -2540,6 +2555,22 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) gfc_try +gfc_check_parity (gfc_expr *mask, gfc_expr *dim) +{ + if (type_check (mask, 0, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (array_check (mask, 0) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, mask, false) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_precision (gfc_expr *x) { if (real_or_complex_check (x, 0) == FAILURE) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c84c633..0a2f52f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -464,11 +464,13 @@ enum gfc_isym_id GFC_ISYM_NEAREST, GFC_ISYM_NEW_LINE, GFC_ISYM_NINT, + GFC_ISYM_NORM2, GFC_ISYM_NOT, GFC_ISYM_NULL, GFC_ISYM_NUMIMAGES, GFC_ISYM_OR, GFC_ISYM_PACK, + GFC_ISYM_PARITY, GFC_ISYM_PERROR, GFC_ISYM_PRECISION, GFC_ISYM_PRESENT, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 9087106..2ce3482 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2268,6 +2268,13 @@ add_functions (void) make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95); + add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2, + x, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008); + add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_null, gfc_simplify_null, NULL, mo, BT_INTEGER, di, OPTIONAL); @@ -2284,6 +2291,14 @@ add_functions (void) make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95); + + add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity, + msk, BT_LOGICAL, dl, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008); + add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_precision, gfc_simplify_precision, NULL, x, BT_UNKNOWN, 0, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 5de0116..2c101d3 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -108,8 +108,10 @@ gfc_try gfc_check_minloc_maxloc (gfc_actual_arglist *); gfc_try gfc_check_minval_maxval (gfc_actual_arglist *); gfc_try gfc_check_nearest (gfc_expr *, gfc_expr *); gfc_try gfc_check_new_line (gfc_expr *); +gfc_try gfc_check_norm2 (gfc_expr *, gfc_expr *); gfc_try gfc_check_null (gfc_expr *); gfc_try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_parity (gfc_expr *, gfc_expr *); gfc_try gfc_check_precision (gfc_expr *); gfc_try gfc_check_present (gfc_expr *); gfc_try gfc_check_product_sum (gfc_actual_arglist *); @@ -307,12 +309,14 @@ gfc_expr *gfc_simplify_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); gfc_expr *gfc_simplify_num_images (void); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_parity (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_precision (gfc_expr *); gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_radix (gfc_expr *); @@ -473,9 +477,11 @@ void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_nearest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_norm2 (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_not (gfc_expr *, gfc_expr *); void gfc_resolve_or (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_parity (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_realpart (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index f258e51..c4767f5 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -203,11 +203,13 @@ Some basic guidelines for editing this document: * @code{NEAREST}: NEAREST, Nearest representable number * @code{NEW_LINE}: NEW_LINE, New line character * @code{NINT}: NINT, Nearest whole number +* @code{NORM2}: NORM2, Euclidean vector norm * @code{NOT}: NOT, Logical negation * @code{NULL}: NULL, Function that returns an disassociated pointer * @code{NUM_IMAGES}: NUM_IMAGES, Number of images * @code{OR}: OR, Bitwise logical OR * @code{PACK}: PACK, Pack an array into an array of rank one +* @code{PARITY}: PARITY, Reduction with exclusive OR * @code{PERROR}: PERROR, Print system error message * @code{PRECISION}: PRECISION, Decimal precision of a real kind * @code{PRESENT}: PRESENT, Determine whether an optional dummy argument is specified @@ -8471,6 +8473,57 @@ end program test_nint +@node NORM2 +@section @code{NORM2} --- Euclidean vector norms +@fnindex NORM2 +@cindex Euclidean vector norm +@cindex L2 vector norm +@cindex norm, Euclidean + +@table @asis +@item @emph{Description}: +Calculates the Euclidean vector norm (@math{L_2}) norm of +of @var{ARRAY} along dimension @var{DIM}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = NORM2(ARRAY[, DIM])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{REAL} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the square root of the sum of all +elements in @var{ARRAY} squared is returned. Otherwise, an array of +rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY}, and a +shape similar to that of @var{ARRAY} with dimension @var{DIM} dropped +is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_sum + REAL :: x(5) = [ real :: 1, 2, 3, 4, 5 ] + print *, NORM2(x) ! = sqrt(55.) ~ 7.416 +END PROGRAM +@end smallexample +@end table + + + @node NOT @section @code{NOT} --- Logical negation @fnindex NOT @@ -8717,6 +8770,58 @@ END PROGRAM +@node PARITY +@section @code{PARITY} --- Reduction with exclusive OR +@fnindex PARITY +@cindex Parity +@cindex Reduction, XOR +@cindex XOR reduction + +@table @asis +@item @emph{Description}: +Calculates the partity, i.e. the reduction using @code{.XOR.}, +of @var{MASK} along dimension @var{DIM}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = PARITY(MASK[, DIM])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{LOGICAL} @tab Shall be an array of type @code{LOGICAL} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{MASK}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{MASK}. + +If @var{DIM} is absent, a scalar with the parity of all elements in +@var{MASK} is returned, i.e. true if an odd number of elements is +@code{.true.} and false otherwise. If @var{DIM} is present, an array +of rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY}, +and a shape similar to that of @var{MASK} with dimension @var{DIM} +dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_sum + LOGICAL :: x(2) = [ .true., .false. ] + print *, PARITY(x) ! prints "T" (true). +END PROGRAM +@end smallexample +@end table + + + @node PERROR @section @code{PERROR} --- Print system error message @fnindex PERROR diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 6565187..5a187ee 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1825,6 +1825,23 @@ gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) void +gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + gfc_resolve_dim_arg (dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("norm2_r%d"), array->ts.kind); +} + + +void gfc_resolve_not (gfc_expr *f, gfc_expr *i) { f->ts = i->ts; @@ -1889,6 +1906,25 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, void +gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + gfc_resolve_dim_arg (dim); + } + + resolve_mask_arg (array); + + f->value.function.name + = gfc_get_string (PREFIX ("parity_l%d"), array->ts.kind); +} + + +void gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) { diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 4cb29fb..98955bb 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -488,11 +488,12 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * REAL, PARAMETER :: array(n, m) = ... REAL, PARAMETER :: s(n) = PROD(array, DIM=1) - where OP == gfc_multiply(). */ + where OP == gfc_multiply(). The result might be post processed using post_op. */ static gfc_expr * simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, transformational_op op) + gfc_expr *mask, transformational_op op, + transformational_op post_op) { mpz_t size; int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; @@ -606,7 +607,10 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d result_ctor = gfc_constructor_first (result->value.constructor); for (i = 0; i < resultsize; ++i) { - result_ctor->expr = resultvec[i]; + if (post_op) + result_ctor->expr = post_op (result_ctor->expr, resultvec[i]); + else + result_ctor->expr = resultvec[i]; result_ctor = gfc_constructor_next (result_ctor); } @@ -896,7 +900,7 @@ gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) return !dim || mask->rank == 1 ? simplify_transformation_to_scalar (result, mask, NULL, gfc_and) : - simplify_transformation_to_array (result, mask, dim, NULL, gfc_and); + simplify_transformation_to_array (result, mask, dim, NULL, gfc_and, NULL); } @@ -982,7 +986,7 @@ gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) return !dim || mask->rank == 1 ? simplify_transformation_to_scalar (result, mask, NULL, gfc_or) : - simplify_transformation_to_array (result, mask, dim, NULL, gfc_or); + simplify_transformation_to_array (result, mask, dim, NULL, gfc_or, NULL); } @@ -1679,7 +1683,7 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) Whenever gfc_count is called, '1' is added to the result. */ return !dim || mask->rank == 1 ? simplify_transformation_to_scalar (result, mask, mask, gfc_count) : - simplify_transformation_to_array (result, mask, dim, mask, gfc_count); + simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); } @@ -4048,6 +4052,65 @@ gfc_simplify_idnint (gfc_expr *e) } +static gfc_expr * +add_squared (gfc_expr *result, gfc_expr *e) +{ + mpfr_t tmp; + + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + gfc_set_model_kind (result->ts.kind); + mpfr_init (tmp); + mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE); + mpfr_add (result->value.real, result->value.real, tmp, + GFC_RND_MODE); + mpfr_clear (tmp); + + return result; +} + + +static gfc_expr * +do_sqrt (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + return result; +} + + +gfc_expr * +gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (e) + || (dim != NULL && !gfc_is_constant_expr (dim))) + return NULL; + + result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); + init_result_expr (result, 0, NULL); + + if (!dim || e->rank == 1) + { + result = simplify_transformation_to_scalar (result, e, NULL, + add_squared); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + } + else + result = simplify_transformation_to_array (result, e, dim, NULL, + add_squared, &do_sqrt); + + return result; +} + + gfc_expr * gfc_simplify_not (gfc_expr *e) { @@ -4198,6 +4261,37 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) } +static gfc_expr * +do_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_LOGICAL + && result->expr_type == EXPR_CONSTANT); + + result->value.logical = result->value.logical != e->value.logical; + return result; +} + + + +gfc_expr * +gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (e) + || (dim != NULL && !gfc_is_constant_expr (dim))) + return NULL; + + result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); + init_result_expr (result, 0, NULL); + + return (!dim || e->rank == 1) + ? simplify_transformation_to_scalar (result, e, NULL, do_xor) + : simplify_transformation_to_array (result, e, dim, NULL, do_xor, NULL); +} + + gfc_expr * gfc_simplify_precision (gfc_expr *e) { @@ -4227,7 +4321,7 @@ gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) return !dim || array->rank == 1 ? simplify_transformation_to_scalar (result, array, mask, gfc_multiply) : - simplify_transformation_to_array (result, array, dim, mask, gfc_multiply); + simplify_transformation_to_array (result, array, dim, mask, gfc_multiply, NULL); } @@ -5390,7 +5484,7 @@ gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) return !dim || array->rank == 1 ? simplify_transformation_to_scalar (result, array, mask, gfc_add) : - simplify_transformation_to_array (result, array, dim, mask, gfc_add); + simplify_transformation_to_array (result, array, dim, mask, gfc_add, NULL); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 373770f..e0805d0 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1810,9 +1810,11 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Inline implementation of the sum and product intrinsics. */ static void -gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) +gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, + bool norm2) { tree resvar; + tree scale = NULL_TREE; tree type; stmtblock_t body; stmtblock_t block; @@ -1835,8 +1837,20 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) type = gfc_typenode_for_spec (&expr->ts); /* Initialize the result. */ resvar = gfc_create_var (type, "val"); - if (op == PLUS_EXPR) + if (norm2) + { + /* result = 0.0; + scale = 1.0. */ + scale = gfc_create_var (type, "scale"); + gfc_add_modify (&se->pre, scale, + gfc_build_const (type, integer_one_node)); + tmp = gfc_build_const (type, integer_zero_node); + } + else if (op == PLUS_EXPR) tmp = gfc_build_const (type, integer_zero_node); + else if (op == NE_EXPR) + /* PARITY. */ + tmp = convert (type, boolean_false_node); else tmp = gfc_build_const (type, integer_one_node); @@ -1848,9 +1862,16 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) arrayss = gfc_walk_expr (arrayexpr); gcc_assert (arrayss != gfc_ss_terminator); - actual = actual->next->next; - gcc_assert (actual); - maskexpr = actual->expr; + if (op == NE_EXPR || norm2) + /* PARITY and NORM2. */ + maskexpr = NULL; + else + { + actual = actual->next->next; + gcc_assert (actual); + maskexpr = actual->expr; + } + if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); @@ -1896,15 +1917,77 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_expr_val (&arrayse, arrayexpr); gfc_add_block_to_block (&block, &arrayse.pre); - tmp = fold_build2 (op, type, resvar, arrayse.expr); - gfc_add_modify (&block, resvar, tmp); + if (norm2) + { + /* if (x(i) != 0.0) + { + absX = abs(x(i)) + if (absX > scale) + { + val = scale/absX; + result = 1.0 + result * val * val; + scale = absX; + } + else + { + val = absX/scale; + result += val * val; + } + } */ + tree res1, res2, cond, absX, val; + stmtblock_t ifblock1, ifblock2, ifblock3; + + gfc_init_block (&ifblock1); + + absX = gfc_create_var (type, "absX"); + gfc_add_modify (&ifblock1, absX, + fold_build1 (ABS_EXPR, type, arrayse.expr)); + val = gfc_create_var (type, "val"); + gfc_add_expr_to_block (&ifblock1, val); + + gfc_init_block (&ifblock2); + gfc_add_modify (&ifblock2, val, + fold_build2 (RDIV_EXPR, type, scale, absX)); + res1 = fold_build2 (MULT_EXPR, type, val, val); + res1 = fold_build2 (MULT_EXPR, type, resvar, res1); + res1 = fold_build2 (PLUS_EXPR, type, res1, + gfc_build_const (type, integer_one_node)); + gfc_add_modify (&ifblock2, resvar, res1); + gfc_add_modify (&ifblock2, scale, absX); + res1 = gfc_finish_block (&ifblock2); + + gfc_init_block (&ifblock3); + gfc_add_modify (&ifblock3, val, + fold_build2 (RDIV_EXPR, type, absX, scale)); + res2 = fold_build2 (MULT_EXPR, type, val, val); + res2 = fold_build2 (PLUS_EXPR, type, resvar, res2); + gfc_add_modify (&ifblock3, resvar, res2); + res2 = gfc_finish_block (&ifblock3); + + cond = fold_build2 (GT_EXPR, boolean_type_node, absX, scale); + tmp = build3_v (COND_EXPR, cond, res1, res2); + gfc_add_expr_to_block (&ifblock1, tmp); + tmp = gfc_finish_block (&ifblock1); + + cond = fold_build2 (NE_EXPR, boolean_type_node, arrayse.expr, + gfc_build_const (type, integer_zero_node)); + + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = fold_build2 (op, type, resvar, arrayse.expr); + gfc_add_modify (&block, resvar, tmp); + } + gfc_add_block_to_block (&block, &arrayse.post); if (maskss) { /* We enclose the above in if (mask) {...} . */ - tmp = gfc_finish_block (&block); + tmp = gfc_finish_block (&block); tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt (input_location)); } @@ -1937,6 +2020,16 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_cleanup_loop (&loop); + if (norm2) + { + /* result = scale * sqrt(result). */ + tree sqrt; + sqrt = builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind); + resvar = build_call_expr_loc (input_location, + sqrt, 1, resvar); + resvar = fold_build2 (MULT_EXPR, type, scale, resvar); + } + se->expr = resvar; } @@ -5288,6 +5381,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_nearest (se, expr); break; + case GFC_ISYM_NORM2: + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true); + break; + case GFC_ISYM_NOT: gfc_conv_intrinsic_not (se, expr); break; @@ -5296,12 +5393,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); break; + case GFC_ISYM_PARITY: + gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false); + break; + case GFC_ISYM_PRESENT: gfc_conv_intrinsic_present (se, expr); break; case GFC_ISYM_PRODUCT: - gfc_conv_intrinsic_arith (se, expr, MULT_EXPR); + gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false); break; case GFC_ISYM_RRSPACING: @@ -5338,7 +5439,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_SUM: - gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); break; case GFC_ISYM_TRANSFER: @@ -5508,6 +5609,8 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) case GFC_ISYM_MAXVAL: case GFC_ISYM_MINLOC: case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PARITY: case GFC_ISYM_PRODUCT: case GFC_ISYM_SUM: case GFC_ISYM_SHAPE: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bf91799..d1f0a8c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2010-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/33197 + * gcc/testsuite/gfortran.dg/norm2_1.f90: New. + * gcc/testsuite/gfortran.dg/norm2_2.f90: New. + * gcc/testsuite/gfortran.dg/norm2_3.f90: New. + * gcc/testsuite/gfortran.dg/norm2_4.f90: New. + * gcc/testsuite/gfortran.dg/parity_1.f90: New. + * gcc/testsuite/gfortran.dg/parity_2.f90: New. + * gcc/testsuite/gfortran.dg/parity_3.f90: New. + 2010-08-27 Janus Weil <janus@gcc.gnu.org> PR fortran/45420 diff --git a/gcc/testsuite/gfortran.dg/norm2_1.f90 b/gcc/testsuite/gfortran.dg/norm2_1.f90 new file mode 100644 index 0000000..6d69e6b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/norm2_1.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +real :: a(3) = [real :: 1, 2, huge(3.0)] +real :: b(3) = [real :: 1, 2, 3] +real :: c(4) = [real :: 1, 2, 3, -1] +real :: e(0) = [real :: ] +real :: f(4) = [real :: 0, 0, 3, 0 ] + +real :: d(4,1) = RESHAPE ([real :: 1, 2, 3, -1], [4,1]) +real :: g(4,1) = RESHAPE ([real :: 0, 0, 4, -1], [4,1]) + +! Check compile-time version + +if (abs (NORM2 ([real :: 1, 2, huge(3.0)]) - huge(3.0)) & + > epsilon(0.0)*huge(3.0)) call abort() + +if (abs (SNORM2([real :: 1, 2, huge(3.0)],3) - huge(3.0)) & + > epsilon(0.0)*huge(3.0)) call abort() + +if (abs (SNORM2([real :: 1, 2, 3],3) - NORM2([real :: 1, 2, 3])) & + > epsilon(0.0)*SNORM2([real :: 1, 2, 3],3)) call abort() + +if (NORM2([real :: ]) /= 0.0) call abort() +if (abs (NORM2([real :: 0, 0, 3, 0]) - 3.0) > epsilon(0.0)) call abort() + +! Check TREE version + +if (abs (NORM2 (a) - huge(3.0)) & + > epsilon(0.0)*huge(3.0)) call abort() + +if (abs (SNORM2(b,3) - NORM2(b)) & + > epsilon(0.0)*SNORM2(b,3)) call abort() + +if (abs (SNORM2(c,4) - NORM2(c)) & + > epsilon(0.0)*SNORM2(c,4)) call abort() + +if (ANY (abs (abs(d(:,1)) - NORM2(d, 2)) & + > epsilon(0.0))) call abort() + +! Check libgfortran version + +if (ANY (abs (SNORM2(d,4) - NORM2(d, 1)) & + > epsilon(0.0)*SNORM2(d,4))) call abort() + +if (abs (SNORM2(f,4) - NORM2(f, 1)) & + > epsilon(0.0)*SNORM2(d,4)) call abort() + +if (ANY (abs (abs(g(:,1)) - NORM2(g, 2)) & + > epsilon(0.0))) call abort() + +contains + ! NORM2 algorithm based on BLAS, cf. + ! http://www.netlib.org/blas/snrm2.f + REAL FUNCTION SNORM2 (X,n) + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: X(n) + + REAL :: absXi, scale, SSQ + INTEGER :: i + + INTRINSIC :: ABS, SQRT + + IF (N < 1) THEN + snorm2 = 0.0 + ELSE IF (N == 1) THEN + snorm2 = ABS(X(1)) + ELSE + scale = 0.0 + SSQ = 1.0 + + DO i = 1, N + IF (X(i) /= 0.0) THEN + absXi = ABS(X(i)) + IF (scale < absXi) THEN + SSQ = 1.0 + SSQ * (scale/absXi)**2 + scale = absXi + ELSE + SSQ = SSQ + (absXi/scale)**2 + END IF + END IF + END DO + snorm2 = scale * SQRT(SSQ) + END IF + END FUNCTION SNORM2 +end diff --git a/gcc/testsuite/gfortran.dg/norm2_2.f90 b/gcc/testsuite/gfortran.dg/norm2_2.f90 new file mode 100644 index 0000000..d6ad7aa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/norm2_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +print *, norm2([1, 2]) ! { dg-error "must be REAL" } +print *, norm2([cmplx(1.0,2.0)]) ! { dg-error "must be REAL" } +print *, norm2(1.0) ! { dg-error "must be an array" } +print *, norm2([1.0, 2.0], dim=2) ! { dg-error "not a valid dimension index" } +end diff --git a/gcc/testsuite/gfortran.dg/norm2_3.f90 b/gcc/testsuite/gfortran.dg/norm2_3.f90 new file mode 100644 index 0000000..a1a3b3f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/norm2_3.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +integer,parameter :: qp = selected_real_kind (precision (0.0d0)+1) + +real(qp) :: a(3) = [real(qp) :: 1, 2, huge(3.0_qp)] +real(qp) :: b(3) = [real(qp) :: 1, 2, 3] +real(qp) :: c(4) = [real(qp) :: 1, 2, 3, -1] +real(qp) :: e(0) = [real(qp) :: ] +real(qp) :: f(4) = [real(qp) :: 0, 0, 3, 0 ] + +real(qp) :: d(4,1) = RESHAPE ([real(qp) :: 1, 2, 3, -1], [4,1]) +real(qp) :: g(4,1) = RESHAPE ([real(qp) :: 0, 0, 4, -1], [4,1]) + +! Check compile-time version + +if (abs (NORM2 ([real(qp) :: 1, 2, huge(3.0_qp)]) - huge(3.0_qp)) & + > epsilon(0.0_qp)*huge(3.0_qp)) call abort() + +if (abs (SNORM2([real(qp) :: 1, 2, huge(3.0_qp)],3) - huge(3.0_qp)) & + > epsilon(0.0_qp)*huge(3.0_qp)) call abort() + +if (abs (SNORM2([real(qp) :: 1, 2, 3],3) - NORM2([real(qp) :: 1, 2, 3])) & + > epsilon(0.0_qp)*SNORM2([real(qp) :: 1, 2, 3],3)) call abort() + +if (NORM2([real(qp) :: ]) /= 0.0_qp) call abort() +if (abs (NORM2([real(qp) :: 0, 0, 3, 0]) - 3.0_qp) > epsilon(0.0_qp)) call abort() + +! Check TREE version + +if (abs (NORM2 (a) - huge(3.0_qp)) & + > epsilon(0.0_qp)*huge(3.0_qp)) call abort() + +if (abs (SNORM2(b,3) - NORM2(b)) & + > epsilon(0.0_qp)*SNORM2(b,3)) call abort() + +if (abs (SNORM2(c,4) - NORM2(c)) & + > epsilon(0.0_qp)*SNORM2(c,4)) call abort() + +if (ANY (abs (abs(d(:,1)) - NORM2(d, 2)) & + > epsilon(0.0_qp))) call abort() + +! Check libgfortran version + +if (ANY (abs (SNORM2(d,4) - NORM2(d, 1)) & + > epsilon(0.0_qp)*SNORM2(d,4))) call abort() + +if (abs (SNORM2(f,4) - NORM2(f, 1)) & + > epsilon(0.0_qp)*SNORM2(d,4)) call abort() + +if (ANY (abs (abs(g(:,1)) - NORM2(g, 2)) & + > epsilon(0.0_qp))) call abort() + +contains + ! NORM2 algorithm based on BLAS, cf. + ! http://www.netlib.org/blas/snrm2.f + REAL(qp) FUNCTION SNORM2 (X,n) + INTEGER, INTENT(IN) :: n + REAL(qp), INTENT(IN) :: X(n) + + REAL(qp) :: absXi, scale, SSQ + INTEGER :: i + + INTRINSIC :: ABS, SQRT + + IF (N < 1) THEN + snorm2 = 0.0_qp + ELSE IF (N == 1) THEN + snorm2 = ABS(X(1)) + ELSE + scale = 0.0_qp + SSQ = 1.0_qp + + DO i = 1, N + IF (X(i) /= 0.0_qp) THEN + absXi = ABS(X(i)) + IF (scale < absXi) THEN + SSQ = 1.0_qp + SSQ * (scale/absXi)**2 + scale = absXi + ELSE + SSQ = SSQ + (absXi/scale)**2 + END IF + END IF + END DO + snorm2 = scale * SQRT(SSQ) + END IF + END FUNCTION SNORM2 +end diff --git a/gcc/testsuite/gfortran.dg/norm_4.f90 b/gcc/testsuite/gfortran.dg/norm_4.f90 new file mode 100644 index 0000000..276b174 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/norm_4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +print *, norm2([1.0, 2.0]) ! { dg-error "has no IMPLICIT type" } +end diff --git a/gcc/testsuite/gfortran.dg/parity_1.f90 b/gcc/testsuite/gfortran.dg/parity_1.f90 new file mode 100644 index 0000000..05f9537 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parity_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Check implementation of PARITY +! +implicit none + +integer :: i +logical :: Lt(1) = [ .true. ] +logical :: Lf(1) = [ .false.] +logical :: Ltf(2) = [ .true., .false. ] +logical :: Ltftf(4) = [.true., .false., .true.,.false.] + +if (parity([logical ::]) .neqv. .false.) call abort() +if (parity([.true., .false.]) .neqv. .true.) call abort() +if (parity([.true.]) .neqv. .true.) call abort() +if (parity([.false.]) .neqv. .false.) call abort() +if (parity([.true., .false., .true.,.false.]) .neqv. .false.) call abort() +if (parity(reshape([.true., .false., .true.,.false.],[2,2])) & + .neqv. .false.) call abort() +if (any (parity(reshape([.true., .false., .true.,.false.],[2,2]),dim=1) & + .neqv. [.true., .true.])) call abort() +if (any (parity(reshape([.true., .false., .true.,.false.],[2,2]),dim=2) & + .neqv. [.false., .false.])) call abort() + +i = 0 +if (parity(Lt(1:i)) .neqv. .false.) call abort() +if (parity(Ltf) .neqv. .true.) call abort() +if (parity(Lt) .neqv. .true.) call abort() +if (parity(Lf) .neqv. .false.) call abort() +if (parity(Ltftf) .neqv. .false.) call abort() +if (parity(reshape(Ltftf,[2,2])) & + .neqv. .false.) call abort() +if (any (parity(reshape(Ltftf,[2,2]),dim=1) & + .neqv. [.true., .true.])) call abort() +if (any (parity(reshape(Ltftf,[2,2]),dim=2) & + .neqv. [.false., .false.])) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/parity_2.f90 b/gcc/testsuite/gfortran.dg/parity_2.f90 new file mode 100644 index 0000000..5ff11da --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parity_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/33197 +! +! Check implementation of PARITY +! +implicit none +print *, parity([real ::]) ! { dg-error "must be LOGICAL" }) +print *, parity([integer ::]) ! { dg-error "must be LOGICAL" } +print *, parity([logical ::]) +print *, parity(.true.) ! { dg-error "must be an array" } +end diff --git a/gcc/testsuite/gfortran.dg/parity_3.f90 b/gcc/testsuite/gfortran.dg/parity_3.f90 new file mode 100644 index 0000000..88d674d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parity_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Check implementation of PARITY +! +implicit none +print *, parity([.true.]) ! { dg-error "has no IMPLICIT type" } +end |