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]

Re: [Bug fortran/36932] unneeded temporary (2x)


I suppose that it helps to attach the "attached"...

On Sat, Feb 20, 2010 at 12:18 PM, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> I will commit the attached after bootstrapping and regtesting.
>
> On Fri, Feb 19, 2010 at 10:25 PM, Tobias Burnus <burnus@net-b.de> wrote:
>> Dear Paul,
>>
>> thanks for your work. Your patch is OK with a proper changelog and
>> adding a testcase for PR43111.
>
> See the attached and below.
>
>>
>> By the way, I encountered two cases where unnecessarily temporary is
>> still created:
>
> I'm on to it :-)
>
> Thanks
>
> Paul
>
> 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.
>



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 156923)
--- gcc/fortran/trans-array.c	(working copy)
*************** array_parameter_size (tree desc, gfc_exp
*** 5459,5465 ****
  /* TODO: Optimize passing g77 arrays.  */
  
  void
! gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
  			  const gfc_symbol *fsym, const char *proc_name,
  			  tree *size)
  {
--- 5459,5465 ----
  /* TODO: Optimize passing g77 arrays.  */
  
  void
! 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)
  {
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 5471,5476 ****
--- 5471,5477 ----
    bool full_array_var;
    bool this_array_result;
    bool contiguous;
+   bool no_pack;
    gfc_symbol *sym;
    stmtblock_t block;
    gfc_ref *ref;
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 5519,5526 ****
  	  return;
  	}
  
!       if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE 
!           && !sym->attr.allocatable)
          {
  	  /* Some variables are declared directly, others are declared as
  	     pointers and allocated on the heap.  */
--- 5520,5529 ----
  	  return;
  	}
  
!       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.  */
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 5547,5554 ****
          }
      }
  
!   if (contiguous && g77 && !this_array_result
! 	&& !expr->symtree->n.sym->attr.dummy)
      {
        gfc_conv_expr_descriptor (se, expr, ss);
        if (expr->ts.type == BT_CHARACTER)
--- 5550,5581 ----
          }
      }
  
!   /* 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_array_parameter (gfc_se * se, g
*** 5601,5607 ****
      {
        desc = se->expr;
        /* Repack the array.  */
- 
        if (gfc_option.warn_array_temp)
  	{
  	  if (fsym)
--- 5628,5633 ----
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 156923)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2827,2844 ****
        if (!sym->attr.elemental)
  	{
  	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
!           if (se->ss->useflags)
!             {
  	      gcc_assert ((!comp && gfc_return_by_reference (sym)
  			   && sym->result->attr.dimension)
  			  || (comp && comp->attr.dimension));
!               gcc_assert (se->loop != NULL);
  
!               /* Access the previously obtained result.  */
!               gfc_conv_tmp_array_ref (se);
!               gfc_advance_se_ss_chain (se);
!               return 0;
!             }
  	}
        info = &se->ss->data.info;
      }
--- 2827,2844 ----
        if (!sym->attr.elemental)
  	{
  	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
! 	  if (se->ss->useflags)
! 	    {
  	      gcc_assert ((!comp && gfc_return_by_reference (sym)
  			   && sym->result->attr.dimension)
  			  || (comp && comp->attr.dimension));
! 	      gcc_assert (se->loop != NULL);
  
! 	      /* Access the previously obtained result.  */
! 	      gfc_conv_tmp_array_ref (se);
! 	      gfc_advance_se_ss_chain (se);
! 	      return 0;
! 	    }
  	}
        info = &se->ss->data.info;
      }
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2872,2880 ****
        e = arg->expr;
        fsym = formal ? formal->sym : NULL;
        parm_kind = MISSING;
        if (e == NULL)
  	{
- 
  	  if (se->ignore_optional)
  	    {
  	      /* Some intrinsics have already been resolved to the correct
--- 2872,2880 ----
        e = arg->expr;
        fsym = formal ? formal->sym : NULL;
        parm_kind = MISSING;
+ 
        if (e == NULL)
  	{
  	  if (se->ignore_optional)
  	    {
  	      /* Some intrinsics have already been resolved to the correct
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2883,2897 ****
  	    }
  	  else if (arg->label)
  	    {
!               has_alternate_specifier = 1;
!               continue;
  	    }
  	  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)
  		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
  	    }
  	}
--- 2883,2897 ----
  	    }
  	  else if (arg->label)
  	    {
! 	      has_alternate_specifier = 1;
! 	      continue;
  	    }
  	  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)
  		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
  	    }
  	}
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2906,2913 ****
        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);
  	  parm_kind = ELEMENTAL;
  	}
        else
--- 2906,2913 ----
        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);
  	  parm_kind = ELEMENTAL;
  	}
        else
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2917,2923 ****
  	  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)
--- 2917,2923 ----
  	  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)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3028,3034 ****
                   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;
  	      f = (fsym != NULL)
  		  && !(fsym->attr.pointer || fsym->attr.allocatable)
  		  && fsym->as->type != AS_ASSUMED_SHAPE;
--- 3028,3034 ----
                   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.  */
! 	      bool f;
  	      f = (fsym != NULL)
  		  && !(fsym->attr.pointer || fsym->attr.allocatable)
  		  && fsym->as->type != AS_ASSUMED_SHAPE;
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5036,5042 ****
    gfc_start_block (&se.pre);
    se.want_pointer = 1;
  
!   gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
  
    if (expr1->ts.type == BT_DERIVED
  	&& expr1->ts.u.derived->attr.alloc_comp)
--- 5036,5042 ----
    gfc_start_block (&se.pre);
    se.want_pointer = 1;
  
!   gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
  
    if (expr1->ts.type == BT_DERIVED
  	&& expr1->ts.u.derived->attr.alloc_comp)
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 156923)
--- gcc/fortran/trans-array.h	(working copy)
*************** void gfc_conv_tmp_ref (gfc_se *);
*** 111,117 ****
  /* 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,
  			       const gfc_symbol *, const char *, tree *);
  /* Evaluate and transpose a matrix expression.  */
  void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
--- 111,117 ----
  /* 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 *, bool,
  			       const gfc_symbol *, const char *, tree *);
  /* Evaluate and transpose a matrix expression.  */
  void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c	(revision 156923)
--- gcc/fortran/trans-io.c	(working copy)
*************** gfc_convert_array_to_string (gfc_se * se
*** 620,626 ****
        return;
      }
  
!   gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, NULL, NULL, &size);
    se->string_length = fold_convert (gfc_charlen_type_node, size);
  }
  
--- 620,626 ----
        return;
      }
  
!   gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
    se->string_length = fold_convert (gfc_charlen_type_node, size);
  }
  
Index: gcc/fortran/dependency.c
===================================================================
*** gcc/fortran/dependency.c	(revision 156923)
--- gcc/fortran/dependency.c	(working copy)
*************** gfc_check_argument_var_dependency (gfc_e
*** 467,473 ****
        /* 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))
  	{
  	  if (elemental == ELEM_DONT_CHECK_VARIABLE)
  	    {
--- 467,473 ----
        /* 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 == NOT_ELEMENTAL))
  	{
  	  if (elemental == ELEM_DONT_CHECK_VARIABLE)
  	    {
*************** gfc_are_equivalenced_arrays (gfc_expr *e
*** 677,682 ****
--- 677,754 ----
  }
  
  
+ /* 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
*************** gfc_check_dependency (gfc_expr *expr1, g
*** 726,732 ****
  	  /* 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;
  
  	  /* Otherwise distinct symbols have no dependencies.  */
  	  return 0;
--- 798,810 ----
  	  /* 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 (check_data_pointer_types (expr1, expr2)
! 		    && check_data_pointer_types (expr2, expr1))
! 		return 0;
! 
! 	      return 1;
! 	    }
  
  	  /* Otherwise distinct symbols have no dependencies.  */
  	  return 0;
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 156923)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_intrinsic_loc (gfc_se * se, gfc
*** 4997,5003 ****
    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);
    se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
     
    /* Create a temporary variable for loc return value.  Without this, 
--- 4997,5003 ----
    if (ss == gfc_ss_terminator)
      gfc_conv_expr_reference (se, arg_expr);
    else
!     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, 
Index: gcc/testsuite/gfortran.dg/dependency_26.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dependency_26.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/dependency_26.f90	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/internal_pack_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/internal_pack_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/internal_pack_7.f90	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/internal_pack_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/internal_pack_8.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/internal_pack_8.f90	(revision 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" } }

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