This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch,Fortran,Committed] PR29962 - more simplifiers for transformational intrinsics


And the next merge from Fortran-dev. Original patch:
 http://gcc.gnu.org/ml/fortran/2009-04/msg00001.html
 http://gcc.gnu.org/viewcvs?view=rev&revision=145573

Built, regtested and checked in on x86-64-linux:

Sending        gcc/fortran/ChangeLog
Sending        gcc/fortran/check.c
Sending        gcc/fortran/expr.c
Sending        gcc/fortran/intrinsic.c
Sending        gcc/fortran/intrinsic.h
Sending        gcc/fortran/simplify.c
Sending        gcc/testsuite/ChangeLog
Adding         gcc/testsuite/gfortran.dg/count_init_expr.f03
Adding         gcc/testsuite/gfortran.dg/product_init_expr.f03
Adding         gcc/testsuite/gfortran.dg/sum_init_expr.f03
Transmitting file data ..........
Committed revision 148249.

Tobias 
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 148248)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,5 +1,13 @@
 2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
 
+	PR fortran/25104
+	PR fortran/29962
+	* gfortran.dg/count_init_expr.f03
+	* gfortran.dg/product_init_expr.f03
+	* gfortran.dg/sum_init_expr.f03
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
 	PR fortran/36874
 	* gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted error message.
 	* gfortran.dg/zero_sized_1.f90: Removed checks with incompatible shapes.
Index: gcc/testsuite/gfortran.dg/product_init_expr.f03
===================================================================
--- gcc/testsuite/gfortran.dg/product_init_expr.f03	(Revision 0)
+++ gcc/testsuite/gfortran.dg/product_init_expr.f03	(Revision 0)
@@ -0,0 +1,66 @@
+! { dg-do "run" }
+! { dg-options "-fno-inline" }
+!
+! PRODUCT as initialization expression.
+!
+! This test compares results of simplifier of PRODUCT
+! with the corresponding inlined or library routine(s).
+!
+
+  IMPLICIT NONE
+
+  INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] )
+  INTEGER, PARAMETER :: imatrix_prod = PRODUCT (imatrix)
+  INTEGER, PARAMETER :: imatrix_prod_d1(4) = PRODUCT (imatrix, dim=1)
+  INTEGER, PARAMETER :: imatrix_prod_d2(2) = PRODUCT (imatrix, dim=2)
+  LOGICAL, PARAMETER :: i_equal_prod = ALL ([PRODUCT( imatrix_prod_d1 ) ==  PRODUCT ( imatrix_prod_d2 ), &
+                                             PRODUCT( imatrix_prod_d1 ) == imatrix_prod])
+  LOGICAL, PARAMETER :: i_empty_prod = PRODUCT(imatrix, mask=.FALSE.) == 1
+
+  REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0 ], [2, 4] )
+  REAL, PARAMETER :: rmatrix_prod = PRODUCT (rmatrix)
+  REAL, PARAMETER :: rmatrix_prod_d1(4) = PRODUCT (rmatrix, dim=1)
+  REAL, PARAMETER :: rmatrix_prod_d2(2) = PRODUCT (rmatrix, dim=2)
+  LOGICAL, PARAMETER :: r_equal_prod = ALL ([PRODUCT( rmatrix_prod_d1 ) ==  PRODUCT ( rmatrix_prod_d2 ), &
+                                             PRODUCT( rmatrix_prod_d1 ) == rmatrix_prod])
+  LOGICAL, PARAMETER :: r_empty_prod = PRODUCT(rmatrix, mask=.FALSE.) == 1.0
+
+  IF (.NOT. ALL ([i_equal_prod, i_empty_prod])) CALL abort()
+  IF (.NOT. ALL ([r_equal_prod, r_empty_prod])) CALL abort()
+
+  CALL ilib (imatrix, imatrix_prod)
+  CALL ilib_with_dim (imatrix, 1, imatrix_prod_d1)
+  CALL ilib_with_dim (imatrix, 2, imatrix_prod_d2)
+  CALL rlib (rmatrix, rmatrix_prod)
+  CALL rlib_with_dim (rmatrix, 1, rmatrix_prod_d1)
+  CALL rlib_with_dim (rmatrix, 2, rmatrix_prod_d2)
+
+CONTAINS
+  SUBROUTINE ilib (array, result)
+    INTEGER, DIMENSION(:,:), INTENT(in) :: array
+    INTEGER, INTENT(in) :: result
+    IF (PRODUCT(array) /= result) CALL abort()
+  END SUBROUTINE
+
+  SUBROUTINE ilib_with_dim (array, dim, result)
+    INTEGER, DIMENSION(:,:), INTENT(in) :: array
+    INTEGER, INTENT(iN)                 :: dim
+    INTEGER, DIMENSION(:), INTENT(in)   :: result
+    IF (ANY (PRODUCT (array, dim=dim) /= result)) CALL abort()
+  END SUBROUTINE
+
+  SUBROUTINE rlib (array, result)
+    REAL, DIMENSION(:,:), INTENT(in) :: array
+    REAL, INTENT(in) :: result
+    IF (ABS(PRODUCT(array) - result) > 2e-6) CALL abort()
+  END SUBROUTINE
+
+  SUBROUTINE rlib_with_dim (array, dim, result)
+    REAL, DIMENSION(:,:), INTENT(in) :: array
+    INTEGER, INTENT(iN)              :: dim
+    REAL, DIMENSION(:), INTENT(in)   :: result
+    IF (ANY (ABS(PRODUCT (array, dim=dim) - result) > 2e-6)) CALL abort()
+  END SUBROUTINE
+END
+
+
Index: gcc/testsuite/gfortran.dg/sum_init_expr.f03
===================================================================
--- gcc/testsuite/gfortran.dg/sum_init_expr.f03	(Revision 0)
+++ gcc/testsuite/gfortran.dg/sum_init_expr.f03	(Revision 0)
@@ -0,0 +1,66 @@
+! { dg-do "run" }
+! { dg-options "-fno-inline" }
+!
+! SUM as initialization expression.
+!
+! This test compares results of simplifier of SUM 
+! with the corresponding inlined or library routine(s).
+!
+
+  IMPLICIT NONE
+
+  INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] )
+  INTEGER, PARAMETER :: imatrix_sum = SUM (imatrix)
+  INTEGER, PARAMETER :: imatrix_sum_d1(4) = SUM (imatrix, dim=1)
+  INTEGER, PARAMETER :: imatrix_sum_d2(2) = SUM (imatrix, dim=2)
+  LOGICAL, PARAMETER :: i_equal_sum = ALL ([SUM( imatrix_sum_d1 ) ==  SUM ( imatrix_sum_d2 ), &
+                                            SUM( imatrix_sum_d1 ) == imatrix_sum])
+  LOGICAL, PARAMETER :: i_empty_sum = SUM(imatrix, mask=.FALSE.) == 0
+
+  REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, 8.8 ], [2, 4] )
+  REAL, PARAMETER :: rmatrix_sum = SUM (rmatrix)
+  REAL, PARAMETER :: rmatrix_sum_d1(4) = SUM (rmatrix, dim=1)
+  REAL, PARAMETER :: rmatrix_sum_d2(2) = SUM (rmatrix, dim=2)
+  LOGICAL, PARAMETER :: r_equal_sum = ALL ([SUM( rmatrix_sum_d1 ) ==  SUM ( rmatrix_sum_d2 ), &
+                                            SUM( rmatrix_sum_d1 ) == rmatrix_sum])
+  LOGICAL, PARAMETER :: r_empty_sum = SUM(rmatrix, mask=.FALSE.) == 0.0
+
+  IF (.NOT. ALL ([i_equal_sum, i_empty_sum])) CALL abort()
+  IF (.NOT. ALL ([r_equal_sum, r_empty_sum])) CALL abort()
+
+  CALL ilib (imatrix, imatrix_sum)
+  CALL ilib_with_dim (imatrix, 1, imatrix_sum_d1)
+  CALL ilib_with_dim (imatrix, 2, imatrix_sum_d2)
+  CALL rlib (rmatrix, rmatrix_sum)
+  CALL rlib_with_dim (rmatrix, 1, rmatrix_sum_d1)
+  CALL rlib_with_dim (rmatrix, 2, rmatrix_sum_d2)
+
+CONTAINS
+  SUBROUTINE ilib (array, result)
+    INTEGER, DIMENSION(:,:), INTENT(in) :: array
+    INTEGER, INTENT(in) :: result
+    IF (SUM(array) /= result) CALL abort()
+  END SUBROUTINE
+
+  SUBROUTINE ilib_with_dim (array, dim, result)
+    INTEGER, DIMENSION(:,:), INTENT(in) :: array
+    INTEGER, INTENT(iN)                 :: dim
+    INTEGER, DIMENSION(:), INTENT(in)   :: result
+    IF (ANY (SUM (array, dim=dim) /= result)) CALL abort()
+  END SUBROUTINE
+
+  SUBROUTINE rlib (array, result)
+    REAL, DIMENSION(:,:), INTENT(in) :: array
+    REAL, INTENT(in) :: result
+    IF (ABS(SUM(array) - result) > 2e-6) CALL abort()
+  END SUBROUTINE
+
+  SUBROUTINE rlib_with_dim (array, dim, result)
+    REAL, DIMENSION(:,:), INTENT(in) :: array
+    INTEGER, INTENT(iN)              :: dim
+    REAL, DIMENSION(:), INTENT(in)   :: result
+    IF (ANY (ABS(SUM (array, dim=dim) - result) > 2e-6)) CALL abort()
+  END SUBROUTINE
+END
+
+
Index: gcc/testsuite/gfortran.dg/count_init_expr.f03
===================================================================
--- gcc/testsuite/gfortran.dg/count_init_expr.f03	(Revision 0)
+++ gcc/testsuite/gfortran.dg/count_init_expr.f03	(Revision 0)
@@ -0,0 +1,15 @@
+! { dg-do "run" }
+
+  INTEGER            :: i
+  INTEGER, PARAMETER :: m(4,4) = RESHAPE([ (i, i=1, 16) ], [4, 4] )
+  INTEGER, PARAMETER :: sevens = COUNT (m == 7)
+  INTEGER, PARAMETER :: odd(4) = COUNT (MOD(m, 2) == 1, dim=1)
+  INTEGER, PARAMETER :: even = COUNT (MOD(m, 2) == 0)
+
+  IF (sevens /= 1) CALL abort()
+  IF (ANY(odd /= [ 2,2,2,2 ])) CALL abort()
+  IF (even /= 8) CALL abort()
+
+  ! check the kind parameter
+  IF (KIND(COUNT (m == 7, KIND=2)) /= 2) CALL abort()
+END
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(Revision 148248)
+++ gcc/fortran/intrinsic.c	(Arbeitskopie)
@@ -1189,7 +1189,7 @@ add_functions (void)
   make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
 
   add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
-	     gfc_check_all_any, NULL, gfc_resolve_all,
+	     gfc_check_all_any, gfc_simplify_all, gfc_resolve_all,
 	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 
   make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
@@ -1211,7 +1211,7 @@ add_functions (void)
   make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
 
   add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
-	     gfc_check_all_any, NULL, gfc_resolve_any,
+	     gfc_check_all_any, gfc_simplify_any, gfc_resolve_any,
 	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 
   make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
@@ -1451,7 +1451,7 @@ add_functions (void)
 
   add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
 	     BT_INTEGER, di, GFC_STD_F95,
-	     gfc_check_count, NULL, gfc_resolve_count,
+	     gfc_check_count, gfc_simplify_count, gfc_resolve_count,
 	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
 	     kind, BT_INTEGER, di, OPTIONAL);
 
@@ -2228,7 +2228,7 @@ add_functions (void)
   make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
 
   add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-		gfc_check_product_sum, NULL, gfc_resolve_product,
+		gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product,
 		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
 		msk, BT_LOGICAL, dl, OPTIONAL);
 
@@ -2466,7 +2466,7 @@ add_functions (void)
   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
 
   add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-		gfc_check_product_sum, NULL, gfc_resolve_sum,
+		gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
 		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
 		msk, BT_LOGICAL, dl, OPTIONAL);
 
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(Revision 148248)
+++ gcc/fortran/intrinsic.h	(Arbeitskopie)
@@ -200,10 +200,12 @@ gfc_expr *gfc_simplify_adjustl (gfc_expr
 gfc_expr *gfc_simplify_adjustr (gfc_expr *);
 gfc_expr *gfc_simplify_aimag (gfc_expr *);
 gfc_expr *gfc_simplify_aint (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_all (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dint (gfc_expr *);
 gfc_expr *gfc_simplify_anint (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dnint (gfc_expr *);
 gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_asin (gfc_expr *);
 gfc_expr *gfc_simplify_asinh (gfc_expr *);
 gfc_expr *gfc_simplify_atan (gfc_expr *);
@@ -224,6 +226,7 @@ gfc_expr *gfc_simplify_complex (gfc_expr
 gfc_expr *gfc_simplify_conjg (gfc_expr *);
 gfc_expr *gfc_simplify_cos (gfc_expr *);
 gfc_expr *gfc_simplify_cosh (gfc_expr *);
+gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dble (gfc_expr *);
 gfc_expr *gfc_simplify_digits (gfc_expr *);
@@ -293,6 +296,7 @@ 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_precision (gfc_expr *);
+gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_radix (gfc_expr *);
 gfc_expr *gfc_simplify_range (gfc_expr *);
 gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *);
@@ -315,6 +319,7 @@ gfc_expr *gfc_simplify_size (gfc_expr *,
 gfc_expr *gfc_simplify_sngl (gfc_expr *);
 gfc_expr *gfc_simplify_spacing (gfc_expr *);
 gfc_expr *gfc_simplify_sqrt (gfc_expr *);
+gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_tan (gfc_expr *);
 gfc_expr *gfc_simplify_tanh (gfc_expr *);
 gfc_expr *gfc_simplify_tiny (gfc_expr *);
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 148248)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,5 +1,29 @@
 2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
 
+	PR fortran/25104
+	PR fortran/29962
+	* check.c (gfc_check_all_any): Check rank of DIM.
+	(gfc_check_count): Likewise.
+	* intrinsic.h (gfc_simplify_all): New prototype.
+	(gfc_simplify_any): Likewise.
+	(gfc_simplify_count): Likewise.
+	(gfc_simplify_sum): Likewise.
+	(gfc_simplify_product): Likewise.
+	* intrinsic.c (add_functions): Added new simplifier callbacks.
+	* simplify.c (transformational_result): New.
+	(simplify_transformation_to_scalar): New.
+	(simplify_transformation_to_array): New.
+	(gfc_count): New.
+	(gfc_simplify_all): New.
+	(gfc_simplify_any): New.
+	(gfc_simplify_count): New.
+	(gfc_simplify_sum): New.
+	(gfc_simplify_product): New.
+	* expr.c (check_transformational): Allow additional transformational
+	intrinsics in initialization expression.
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
 	* check.c (dim_rank_check): Return SUCCESS if DIM=NULL.
 	(gfc_check_lbound): Removed (now) redundant check for DIM=NULL.
 	(gfc_check_minloc_maxloc): Likewise.
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 148248)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -2128,9 +2128,9 @@ check_transformational (gfc_expr *e)
   };
 
   static const char * const trans_func_f2003[] =  {
-    "dot_product", "matmul", "null", "pack", "repeat",
-    "reshape", "selected_char_kind", "selected_int_kind",
-    "selected_real_kind", "transfer", "transpose", "trim", NULL
+    "all", "any", "count", "dot_product", "matmul", "null", "pack",
+    "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
+    "selected_real_kind", "sum", "transfer", "transpose", "trim", NULL
   };
 
   int i;
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(Revision 148248)
+++ gcc/fortran/check.c	(Arbeitskopie)
@@ -522,6 +522,9 @@ gfc_check_all_any (gfc_expr *mask, gfc_e
   if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
 
+  if (dim_rank_check (dim, mask, 0) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -859,6 +862,8 @@ gfc_check_count (gfc_expr *mask, gfc_exp
     return FAILURE;
   if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
+  if (dim_rank_check (dim, mask, 0) == FAILURE)
+    return FAILURE;
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c	(Revision 148248)
+++ gcc/fortran/simplify.c	(Arbeitskopie)
@@ -387,6 +387,246 @@ compute_dot_product (gfc_constructor *ct
   return result;
 }
 
+
+/* Build a result expression for transformational intrinsics, 
+   depending on DIM. */
+
+static gfc_expr *
+transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
+			 int kind, locus* where)
+{
+  gfc_expr *result;
+  int i, nelem;
+
+  if (!dim || array->rank == 1)
+    return gfc_constant_result (type, kind, where);
+
+  result = gfc_start_constructor (type, kind, where);
+  result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+  result->rank = array->rank - 1;
+
+  /* gfc_array_size() would count the number of elements in the constructor,
+     we have not built those yet.  */
+  nelem = 1;
+  for  (i = 0; i < result->rank; ++i)
+    nelem *= mpz_get_ui (result->shape[i]);
+
+  for (i = 0; i < nelem; ++i)
+    {
+      gfc_expr *e = gfc_constant_result (type, kind, where);
+      gfc_append_constructor (result, e);
+    }
+
+  return result;
+}
+
+
+typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
+
+/* Wrapper function, implements 'op1 += 1'. Only called if MASK
+   of COUNT intrinsic is .TRUE..
+
+   Interface and implimentation mimics arith functions as
+   gfc_add, gfc_multiply, etc.  */
+
+static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr *result;
+
+  gcc_assert (op1->ts.type == BT_INTEGER);
+  gcc_assert (op2->ts.type == BT_LOGICAL);
+  gcc_assert (op2->value.logical);
+
+  result = gfc_copy_expr (op1);
+  mpz_add_ui (result->value.integer, result->value.integer, 1);
+
+  gfc_free_expr (op1);
+  gfc_free_expr (op2);
+  return result;
+}
+
+
+/* Transforms an ARRAY with operation OP, according to MASK, to a
+   scalar RESULT. E.g. called if
+
+     REAL, PARAMETER :: array(n, m) = ...
+     REAL, PARAMETER :: s = SUM(array)
+
+  where OP == gfc_add().  */
+
+static gfc_expr *
+simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
+				   transformational_op op)
+{
+  gfc_expr *a, *m;
+  gfc_constructor *array_ctor, *mask_ctor;
+
+  /* Shortcut for constant .FALSE. MASK.  */
+  if (mask
+      && mask->expr_type == EXPR_CONSTANT
+      && !mask->value.logical)
+    return result;
+
+  array_ctor = array->value.constructor;
+  mask_ctor = NULL;
+  if (mask && mask->expr_type == EXPR_ARRAY)
+    mask_ctor = mask->value.constructor;
+
+  while (array_ctor)
+    {
+      a = array_ctor->expr;
+      array_ctor = array_ctor->next;
+
+      /* A constant MASK equals .TRUE. here and can be ignored.  */
+      if (mask_ctor)
+	{
+	  m = mask_ctor->expr;
+	  mask_ctor = mask_ctor->next;
+	  if (!m->value.logical)
+	    continue;
+	}
+
+      result = op (result, gfc_copy_expr (a));
+    }
+
+  return result;
+}
+
+/* Transforms an ARRAY with operation OP, according to MASK, to an
+   array RESULT. E.g. called if
+
+     REAL, PARAMETER :: array(n, m) = ...
+     REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
+
+  where OP == gfc_multiply().  */
+
+static gfc_expr *
+simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
+				  gfc_expr *mask, transformational_op op)
+{
+  mpz_t size;
+  int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+  gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
+  gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+
+  int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+      sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+      tmpstride[GFC_MAX_DIMENSIONS];
+
+  /* Shortcut for constant .FALSE. MASK.  */
+  if (mask
+      && mask->expr_type == EXPR_CONSTANT
+      && !mask->value.logical)
+    return result;
+
+  /* Build an indexed table for array element expressions to minimize
+     linked-list traversal. Masked elements are set to NULL.  */
+  gfc_array_size (array, &size);
+  arraysize = mpz_get_ui (size);
+
+  arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+
+  array_ctor = array->value.constructor;
+  mask_ctor = NULL;
+  if (mask && mask->expr_type == EXPR_ARRAY)
+    mask_ctor = mask->value.constructor;
+
+  for (i = 0; i < arraysize; ++i)
+    {
+      arrayvec[i] = array_ctor->expr;
+      array_ctor = array_ctor->next;
+
+      if (mask_ctor)
+	{
+	  if (!mask_ctor->expr->value.logical)
+	    arrayvec[i] = NULL;
+
+	  mask_ctor = mask_ctor->next;
+	}
+    }
+
+  /* Same for the result expression.  */
+  gfc_array_size (result, &size);
+  resultsize = mpz_get_ui (size);
+  mpz_clear (size);
+
+  resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+  result_ctor = result->value.constructor;
+  for (i = 0; i < resultsize; ++i)
+    {
+      resultvec[i] = result_ctor->expr;
+      result_ctor = result_ctor->next;
+    }
+
+  gfc_extract_int (dim, &dim_index);
+  dim_index -= 1;               /* zero-base index */
+  dim_extent = 0;
+  dim_stride = 0;
+
+  for (i = 0, n = 0; i < array->rank; ++i)
+    {
+      count[i] = 0;
+      tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+      if (i == dim_index)
+	{
+	  dim_extent = mpz_get_si (array->shape[i]);
+	  dim_stride = tmpstride[i];
+	  continue;
+	}
+
+      extent[n] = mpz_get_si (array->shape[i]);
+      sstride[n] = tmpstride[i];
+      dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+      n += 1;
+    }
+
+  done = false;
+  base = arrayvec;
+  dest = resultvec;
+  while (!done)
+    {
+      for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+	if (*src)
+	  *dest = op (*dest, gfc_copy_expr (*src));
+
+      count[0]++;
+      base += sstride[0];
+      dest += dstride[0];
+
+      n = 0;
+      while (!done && count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  base -= sstride[n] * extent[n];
+	  dest -= dstride[n] * extent[n];
+
+	  n++;
+	  if (n < result->rank)
+	    {
+	      count [n]++;
+	      base += sstride[n];
+	      dest += dstride[n];
+	    }
+	  else
+	    done = true;
+       }
+    }
+
+  /* Place updated expression in result constructor.  */
+  result_ctor = result->value.constructor;
+  for (i = 0; i < resultsize; ++i)
+    {
+      result_ctor->expr = resultvec[i];
+      result_ctor = result_ctor->next;
+    }
+
+  gfc_free (arrayvec);
+  gfc_free (resultvec);
+  return result;
+}
+
+
+
 /********************** Simplification functions *****************************/
 
 gfc_expr *
@@ -658,6 +898,25 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr
 
 
 gfc_expr *
+gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (mask)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  result = transformational_result (mask, dim, mask->ts.type,
+				    mask->ts.kind, &mask->where);
+  init_result_expr (result, true, NULL);
+
+  return !dim || mask->rank == 1 ?
+    simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
+    simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
+}
+
+
+gfc_expr *
 gfc_simplify_dint (gfc_expr *e)
 {
   gfc_expr *rtrunc, *result;
@@ -723,6 +982,25 @@ gfc_simplify_and (gfc_expr *x, gfc_expr
 
 
 gfc_expr *
+gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (mask)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  result = transformational_result (mask, dim, mask->ts.type,
+				    mask->ts.kind, &mask->where);
+  init_result_expr (result, false, NULL);
+
+  return !dim || mask->rank == 1 ?
+    simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
+    simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
+}
+
+
+gfc_expr *
 gfc_simplify_dnint (gfc_expr *e)
 {
   gfc_expr *result;
@@ -1222,6 +1500,32 @@ gfc_simplify_cosh (gfc_expr *x)
 
 
 gfc_expr *
+gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (mask)
+      || !gfc_is_constant_expr (dim)
+      || !gfc_is_constant_expr (kind))
+    return NULL;
+
+  result = transformational_result (mask, dim,
+				    BT_INTEGER,
+				    get_kind (BT_INTEGER, kind, "COUNT",
+					      gfc_default_integer_kind),
+				    &mask->where);
+
+  init_result_expr (result, 0, NULL);
+
+  /* Passing MASK twice, once as data array, once as mask.
+     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);
+}
+
+
+gfc_expr *
 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
 {
 
@@ -3706,6 +4010,30 @@ gfc_simplify_precision (gfc_expr *e)
 
 
 gfc_expr *
+gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (array)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  if (mask
+      && !is_constant_array_expr (mask)
+      && mask->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = transformational_result (array, dim, array->ts.type,
+				    array->ts.kind, &array->where);
+  init_result_expr (result, 1, NULL);
+
+  return !dim || array->rank == 1 ?
+    simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
+    simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
+}
+
+
+gfc_expr *
 gfc_simplify_radix (gfc_expr *e)
 {
   gfc_expr *result;
@@ -4827,6 +5155,30 @@ negative_arg:
 }
 
 
+gfc_expr *
+gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (array)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  if (mask
+      && !is_constant_array_expr (mask)
+      && mask->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = transformational_result (array, dim, array->ts.type,
+				    array->ts.kind, &array->where);
+  init_result_expr (result, 0, NULL);
+
+  return !dim || array->rank == 1 ?
+    simplify_transformation_to_scalar (result, array, mask, gfc_add) :
+    simplify_transformation_to_array (result, array, dim, mask, gfc_add);
+}
+
+
 gfc_expr *
 gfc_simplify_tan (gfc_expr *x)
 {

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]