2010-02-20 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/36932
	PR fortran/36933
	PR fortran/43072
	PR fortran/43111
	* dependency.c (gfc_check_argument_var_dependency): Use enum
	value instead of arithmetic vaue for 'elemental'.
	(check_data_pointer_types): New function.
	(gfc_check_dependency): Call check_data_pointer_types.
	* trans-array.h : Change fourth argument of
	gfc_conv_array_parameter to boolean.
	* trans-array.c (gfc_conv_array_parameter): A contiguous array
	can be a dummy but it must not be assumed shape or deferred.
	Change fourth argument to boolean. Array constructor exprs will
	always be contiguous and do not need packing and unpacking.
	* trans-expr.c (gfc_conv_procedure_call): Clean up some white
	space and change fourth argument of gfc_conv_array_parameter
	to boolean.
	(gfc_trans_arrayfunc_assign): Change fourth argument of
	gfc_conv_array_parameter to boolean.
	* trans-io.c (gfc_convert_array_to_string): The same.
	* trans-intrinsic.c (gfc_conv_intrinsic_loc): The same.

2010-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/36932
	PR fortran/36933
	* gfortran.dg/dependency_26.f90: New test.

	PR fortran/43072
	* gfortran.dg/internal_pack_7.f90: New test.

	PR fortran/43111
	* gfortran.dg/internal_pack_8.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156926 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8776bd5..9efaf38 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+2010-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/36932
+       PR fortran/36933
+       PR fortran/43072
+       PR fortran/43111
+       * dependency.c (gfc_check_argument_var_dependency): Use enum
+       value instead of arithmetic vaue for 'elemental'.
+       (check_data_pointer_types): New function.
+       (gfc_check_dependency): Call check_data_pointer_types.
+       * trans-array.h : Change fourth argument of
+       gfc_conv_array_parameter to boolean.
+       * trans-array.c (gfc_conv_array_parameter): A contiguous array
+       can be a dummy but it must not be assumed shape or deferred.
+       Change fourth argument to boolean. Array constructor exprs will
+       always be contiguous and do not need packing and unpacking.
+       * trans-expr.c (gfc_conv_procedure_call): Clean up some white
+       space and change fourth argument of gfc_conv_array_parameter
+       to boolean.
+       (gfc_trans_arrayfunc_assign): Change fourth argument of
+       gfc_conv_array_parameter to boolean.
+       * trans-io.c (gfc_convert_array_to_string): The same.
+       * trans-intrinsic.c (gfc_conv_intrinsic_loc): The same.
+

 2010-02-20  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/42958
 2010-02-20  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/42958

diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index f597e6e..1f3d0ed 100644 (file)
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -467,7 +467,7 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
       /* In case of elemental subroutines, there is no dependency 
          between two same-range array references.  */
       if (gfc_ref_needs_temporary_p (expr->ref)
       /* In case of elemental subroutines, there is no dependency 
          between two same-range array references.  */
       if (gfc_ref_needs_temporary_p (expr->ref)

-         || gfc_check_dependency (var, expr, !elemental))
+         || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))

        {
          if (elemental == ELEM_DONT_CHECK_VARIABLE)
            {
        {
          if (elemental == ELEM_DONT_CHECK_VARIABLE)
            {


@@ -677,6 +677,78 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 }
 
 
 }
 
 

+/* Return true if there is no possibility of aliasing because of a type
+   mismatch between all the possible pointer references and the
+   potential target.  Note that this function is asymmetric in the
+   arguments and so must be called twice with the arguments exchanged.  */
+
+static bool
+check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
+{
+  gfc_component *cm1;
+  gfc_symbol *sym1;
+  gfc_symbol *sym2;
+  gfc_ref *ref1;
+  bool seen_component_ref;
+
+  if (expr1->expr_type != EXPR_VARIABLE
+       || expr1->expr_type != EXPR_VARIABLE)
+    return false;
+
+  sym1 = expr1->symtree->n.sym;
+  sym2 = expr2->symtree->n.sym;
+
+  /* Keep it simple for now.  */
+  if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
+    return false;
+
+  if (sym1->attr.pointer)
+    {
+      if (gfc_compare_types (&sym1->ts, &sym2->ts))
+       return false;
+    }
+
+  /* This is a conservative check on the components of the derived type
+     if no component references have been seen.  Since we will not dig
+     into the components of derived type components, we play it safe by
+     returning false.  First we check the reference chain and then, if
+     no component references have been seen, the components.  */
+  seen_component_ref = false;
+  if (sym1->ts.type == BT_DERIVED)
+    {
+      for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
+       {
+         if (ref1->type != REF_COMPONENT)
+           continue;
+
+         if (ref1->u.c.component->ts.type == BT_DERIVED)
+           return false;
+
+         if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
+               && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
+           return false;
+
+         seen_component_ref = true;
+       }
+    }
+
+  if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
+    {
+      for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
+       {
+         if (cm1->ts.type == BT_DERIVED)
+           return false;
+
+         if ((sym2->attr.pointer || cm1->attr.pointer)
+               && gfc_compare_types (&cm1->ts, &sym2->ts))
+           return false;
+       }
+    }
+
+  return true;
+}
+
+

 /* Return true if the statement body redefines the condition.  Returns
    true if expr2 depends on expr1.  expr1 should be a single term
    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 /* Return true if the statement body redefines the condition.  Returns
    true if expr2 depends on expr1.  expr1 should be a single term
    suitable for the lhs of an assignment.  The IDENTICAL flag indicates


@@ -726,7 +798,13 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
          /* If either variable is a pointer, assume the worst.  */
          /* TODO: -fassume-no-pointer-aliasing */
          if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
          /* If either variable is a pointer, assume the worst.  */
          /* TODO: -fassume-no-pointer-aliasing */
          if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))

-           return 1;
+           {
+             if (check_data_pointer_types (expr1, expr2)
+                   && check_data_pointer_types (expr2, expr1))
+               return 0;
+
+             return 1;
+           }

 
          /* Otherwise distinct symbols have no dependencies.  */
          return 0;
 
          /* Otherwise distinct symbols have no dependencies.  */
          return 0;

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ae39aed..2ea978d 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5459,7 +5459,7 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size)
 /* TODO: Optimize passing g77 arrays.  */
 
 void
 /* TODO: Optimize passing g77 arrays.  */
 
 void

-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,

                          const gfc_symbol *fsym, const char *proc_name,
                          tree *size)
 {
                          const gfc_symbol *fsym, const char *proc_name,
                          tree *size)
 {


@@ -5471,6 +5471,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
   bool full_array_var;
   bool this_array_result;
   bool contiguous;
   bool full_array_var;
   bool this_array_result;
   bool contiguous;

+  bool no_pack;

   gfc_symbol *sym;
   stmtblock_t block;
   gfc_ref *ref;
   gfc_symbol *sym;
   stmtblock_t block;
   gfc_ref *ref;


@@ -5519,8 +5520,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
          return;
        }
 
          return;
        }
 

-      if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE 
-          && !sym->attr.allocatable)
+      if (!sym->attr.pointer
+           && sym->as
+           && sym->as->type != AS_ASSUMED_SHAPE 
+            && !sym->attr.allocatable)

         {
          /* Some variables are declared directly, others are declared as
             pointers and allocated on the heap.  */
         {
          /* Some variables are declared directly, others are declared as
             pointers and allocated on the heap.  */


@@ -5547,8 +5550,32 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
         }
     }
 
         }
     }
 

-  if (contiguous && g77 && !this_array_result
-       && !expr->symtree->n.sym->attr.dummy)
+  /* There is no need to pack and unpack the array, if it is an array
+     constructor or contiguous and not deferred or assumed shape.  */
+  no_pack = ((sym && sym->as
+                 && !sym->attr.pointer
+                 && sym->as->type != AS_DEFERRED
+                 && sym->as->type != AS_ASSUMED_SHAPE)
+                     ||
+            (ref && ref->u.ar.as
+                 && ref->u.ar.as->type != AS_DEFERRED
+                 && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+
+  no_pack = g77 && !this_array_result
+               && (expr->expr_type == EXPR_ARRAY || (contiguous && no_pack));
+
+  if (no_pack)
+    {
+      gfc_conv_expr_descriptor (se, expr, ss);
+      if (expr->ts.type == BT_CHARACTER)
+       se->string_length = expr->ts.u.cl->backend_decl;
+      if (size)
+       array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_conv_array_data (se->expr);
+      return;
+    }
+
+  if (expr->expr_type == EXPR_ARRAY && g77)

     {
       gfc_conv_expr_descriptor (se, expr, ss);
       if (expr->ts.type == BT_CHARACTER)
     {
       gfc_conv_expr_descriptor (se, expr, ss);
       if (expr->ts.type == BT_CHARACTER)


@@ -5601,7 +5628,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
     {
       desc = se->expr;
       /* Repack the array.  */
     {
       desc = se->expr;
       /* Repack the array.  */

-

       if (gfc_option.warn_array_temp)
        {
          if (fsym)
       if (gfc_option.warn_array_temp)
        {
          if (fsym)

diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 6807fcb..2a6d272 100644 (file)
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -111,7 +111,7 @@ void gfc_conv_tmp_ref (gfc_se *);
 /* Evaluate an array expression.  */
 void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
 /* Convert an array for passing as an actual function parameter.  */
 /* Evaluate an array expression.  */
 void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
 /* Convert an array for passing as an actual function parameter.  */

-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int,
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, bool,

                               const gfc_symbol *, const char *, tree *);
 /* Evaluate and transpose a matrix expression.  */
 void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
                               const gfc_symbol *, const char *, tree *);
 /* Evaluate and transpose a matrix expression.  */
 void gfc_conv_array_transpose (gfc_se *, gfc_expr *);

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5c3aa85..276e645 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2827,18 +2827,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (!sym->attr.elemental)
        {
          gcc_assert (se->ss->type == GFC_SS_FUNCTION);
       if (!sym->attr.elemental)
        {
          gcc_assert (se->ss->type == GFC_SS_FUNCTION);

-          if (se->ss->useflags)
-            {
+         if (se->ss->useflags)
+           {

              gcc_assert ((!comp && gfc_return_by_reference (sym)
                           && sym->result->attr.dimension)
                          || (comp && comp->attr.dimension));
              gcc_assert ((!comp && gfc_return_by_reference (sym)
                           && sym->result->attr.dimension)
                          || (comp && comp->attr.dimension));

-              gcc_assert (se->loop != NULL);
+             gcc_assert (se->loop != NULL);

 
 

-              /* Access the previously obtained result.  */
-              gfc_conv_tmp_array_ref (se);
-              gfc_advance_se_ss_chain (se);
-              return 0;
-            }
+             /* Access the previously obtained result.  */
+             gfc_conv_tmp_array_ref (se);
+             gfc_advance_se_ss_chain (se);
+             return 0;
+           }

        }
       info = &se->ss->data.info;
     }
        }
       info = &se->ss->data.info;
     }


@@ -2872,9 +2872,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;

+

       if (e == NULL)
        {
       if (e == NULL)
        {

-

          if (se->ignore_optional)
            {
              /* Some intrinsics have already been resolved to the correct
          if (se->ignore_optional)
            {
              /* Some intrinsics have already been resolved to the correct


@@ -2883,15 +2883,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
            }
          else if (arg->label)
            {
            }
          else if (arg->label)
            {

-              has_alternate_specifier = 1;
-              continue;
+             has_alternate_specifier = 1;
+             continue;

            }
          else
            {
              /* Pass a NULL pointer for an absent arg.  */
              gfc_init_se (&parmse, NULL);
              parmse.expr = null_pointer_node;
            }
          else
            {
              /* Pass a NULL pointer for an absent arg.  */
              gfc_init_se (&parmse, NULL);
              parmse.expr = null_pointer_node;

-              if (arg->missing_arg_type == BT_CHARACTER)
+             if (arg->missing_arg_type == BT_CHARACTER)

                parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
            }
        }
                parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
            }
        }


@@ -2906,8 +2906,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       else if (se->ss && se->ss->useflags)
        {
          /* An elemental function inside a scalarized loop.  */
       else if (se->ss && se->ss->useflags)
        {
          /* An elemental function inside a scalarized loop.  */

-          gfc_init_se (&parmse, se);
-          gfc_conv_expr_reference (&parmse, e);
+         gfc_init_se (&parmse, se);
+         gfc_conv_expr_reference (&parmse, e);

          parm_kind = ELEMENTAL;
        }
       else
          parm_kind = ELEMENTAL;
        }
       else


@@ -2917,7 +2917,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          argss = gfc_walk_expr (e);
 
          if (argss == gfc_ss_terminator)
          argss = gfc_walk_expr (e);
 
          if (argss == gfc_ss_terminator)

-            {
+           {

              if (e->expr_type == EXPR_VARIABLE
                    && e->symtree->n.sym->attr.cray_pointee
                    && fsym && fsym->attr.flavor == FL_PROCEDURE)
              if (e->expr_type == EXPR_VARIABLE
                    && e->symtree->n.sym->attr.cray_pointee
                    && fsym && fsym->attr.flavor == FL_PROCEDURE)


@@ -3028,7 +3028,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                  ALLOCATABLE or assumed shape, we do not use g77's calling
                  convention, and pass the address of the array descriptor
                  instead. Otherwise we use g77's calling convention.  */
                  ALLOCATABLE or assumed shape, we do not use g77's calling
                  convention, and pass the address of the array descriptor
                  instead. Otherwise we use g77's calling convention.  */

-             int f;
+             bool f;

              f = (fsym != NULL)
                  && !(fsym->attr.pointer || fsym->attr.allocatable)
                  && fsym->as->type != AS_ASSUMED_SHAPE;
              f = (fsym != NULL)
                  && !(fsym->attr.pointer || fsym->attr.allocatable)
                  && fsym->as->type != AS_ASSUMED_SHAPE;


@@ -5036,7 +5036,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 

-  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
+  gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);

 
   if (expr1->ts.type == BT_DERIVED
        && expr1->ts.u.derived->attr.alloc_comp)
 
   if (expr1->ts.type == BT_DERIVED
        && expr1->ts.u.derived->attr.alloc_comp)

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 62bf146..ae60eb1 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4997,7 +4997,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
   if (ss == gfc_ss_terminator)
     gfc_conv_expr_reference (se, arg_expr);
   else
   if (ss == gfc_ss_terminator)
     gfc_conv_expr_reference (se, arg_expr);
   else

-    gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
+    gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);

   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
    
   /* Create a temporary variable for loc return value.  Without this, 
   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
    
   /* Create a temporary variable for loc return value.  Without this, 

diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index fd8a806..b0d0556 100644 (file)
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -620,7 +620,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
       return;
     }
 
       return;
     }
 

-  gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, NULL, NULL, &size);
+  gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);

   se->string_length = fold_convert (gfc_charlen_type_node, size);
 }
 
   se->string_length = fold_convert (gfc_charlen_type_node, size);
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0684638..226c755 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2010-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/36932
+       PR fortran/36933
+       * gfortran.dg/dependency_26.f90: New test.
+
+       PR fortran/43072
+       * gfortran.dg/internal_pack_7.f90: New test.
+
+       PR fortran/43111
+       * gfortran.dg/internal_pack_8.f90: New test.
+

 2010-02-20  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 
        PR 43128
 2010-02-20  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 
        PR 43128

diff --git a/gcc/testsuite/gfortran.dg/dependency_26.f90 b/gcc/testsuite/gfortran.dg/dependency_26.f90
new file mode 100644 (file)
index 0000000..df909b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependency_26.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR36932 and PR36933, in which unnecessary
+! temporaries were being generated.  The module m2 tests the
+! additional testcase in comment #3 of PR36932.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE M2
+  IMPLICIT NONE
+  TYPE particle
+   REAL :: r(3)
+  END TYPE
+CONTAINS
+  SUBROUTINE S1(p)
+     TYPE(particle), POINTER, DIMENSION(:) :: p
+     REAL :: b(3)
+     INTEGER :: i
+     b=pbc(p(i)%r)
+  END SUBROUTINE S1
+  FUNCTION pbc(b)
+     REAL :: b(3)
+     REAL :: pbc(3)
+     pbc=b
+  END FUNCTION
+END MODULE M2
+
+MODULE M1
+  IMPLICIT NONE
+  TYPE cell_type
+     REAL :: h(3,3)
+  END TYPE
+CONTAINS
+  SUBROUTINE S1(cell)
+     TYPE(cell_type), POINTER :: cell
+     REAL :: a(3)
+     REAL :: b(3) = [1, 2, 3]
+     a=MATMUL(cell%h,b)
+     if (ANY (INT (a) .ne. [30, 36, 42])) call abort
+  END SUBROUTINE S1
+END MODULE M1
+
+  use M1
+  TYPE(cell_type), POINTER :: cell
+  allocate (cell)
+  cell%h = reshape ([(real(i), i = 1, 9)], [3, 3])
+  call s1 (cell)
+end
+! { dg-final { cleanup-modules "M1" } }
+! { dg-final { scan-tree-dump-times "&a" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pack" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/internal_pack_7.f90 b/gcc/testsuite/gfortran.dg/internal_pack_7.f90
new file mode 100644 (file)
index 0000000..0bc30e5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/internal_pack_7.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR43072, in which unnecessary calls to
+! internal PACK/UNPACK were being generated.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE M1
+  PRIVATE
+  REAL, PARAMETER :: c(2)=(/(i,i=1,2)/)
+CONTAINS
+  ! WAS OK
+  SUBROUTINE S0
+    real :: r
+     r=0
+     r=S2(c)
+     r=S2((/(real(i),i=1,2)/)) ! See comment #1 of the PR
+  END SUBROUTINE S0
+  ! WAS NOT OK
+  SUBROUTINE S1
+    real :: r
+     r=0
+     r=r+S2(c)
+     r=r+S2((/(real(i),i=1,2)/)) ! See comment #1 of the PR
+  END SUBROUTINE S1
+
+  FUNCTION S2(c)
+     REAL, INTENT(IN) :: c(2)
+     s2=0
+  END FUNCTION S2
+END MODULE M1
+! { dg-final { cleanup-modules "M1" } }
+! { dg-final { scan-tree-dump-times "pack" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/internal_pack_8.f90 b/gcc/testsuite/gfortran.dg/internal_pack_8.f90
new file mode 100644 (file)
index 0000000..91d6a66
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/internal_pack_8.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! Test the fix for PR43111, in which necessary calls to
+! internal PACK/UNPACK were not being generated because
+! of an over agressive fix to PR41113/7.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+SUBROUTINE S2(I)
+ INTEGER :: I(4)
+ !write(6,*) I
+ IF (ANY(I.NE.(/3,5,7,9/))) CALL ABORT()
+END SUBROUTINE S2
+
+MODULE M1
+ TYPE T1
+  INTEGER, POINTER, DIMENSION(:) :: data
+ END TYPE T1
+CONTAINS
+ SUBROUTINE S1()
+   TYPE(T1) :: d
+   INTEGER, TARGET, DIMENSION(10) :: scratch=(/(i,i=1,10)/)
+   INTEGER :: i=2
+   d%data=>scratch(1:9:2)
+!   write(6,*) d%data(i:)
+   CALL S2(d%data(i:))
+ END SUBROUTINE S1
+END MODULE M1
+
+USE M1
+CALL S1
+END
+! { dg-final { cleanup-modules "M1" } }