re PR fortran/38883 (ICE for MVBITS with derived type argument that has run-time subscripts)

2009-01-27  Daniel Kraft  <d@domob.eu>

	PR fortran/38883
	* trans-stmt.c (gfc_conv_elemental_dependencies):  Create temporary
	for the real type needed to make it work for subcomponent-references.

2009-01-27  Daniel Kraft  <d@domob.eu>

	PR fortran/38883
	* gfortran.dg/mvbits_6.f90:  New test.
	* gfortran.dg/mvbits_7.f90:  New test.
	* gfortran.dg/mvbits_8.f90:  New test.

From-SVN: r143707

gcc/fortran/ChangeLog

+2009-01-27  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38883
+	* trans-stmt.c (gfc_conv_elemental_dependencies):  Create temporary
+	for the real type needed to make it work for subcomponent-references.
+
 2009-01-21  Daniel Kraft  <d@domob.eu>
 
 	* trans-stmt.c (gfc_conv_elemental_dependencies):  Cleaned up comment.

gcc/fortran/trans-stmt.c

@@ -213,7 +213,6 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
   gfc_ss_info *info;
   gfc_symbol *fsym;
   int n;
-  stmtblock_t block;
   tree data;
   tree offset;
   tree size;
@@ -252,7 +251,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 	    && gfc_check_fncall_dependency (e, fsym->attr.intent,
 					    sym, arg0, check_variable))
 	{
-	  tree initial;
+	  tree initial, temptype;
 	  stmtblock_t temp_post;
 
 	  /* Make a local loopinfo for the temporary creation, so that
@@ -278,24 +277,31 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 	  else
 	    initial = NULL_TREE;
 
-	  /* Generate the temporary.  Merge the block so that the
-	     declarations are put at the right binding level.  Cleaning up the
-	     temporary should be the very last thing done, so we add the code to
-	     a new block and add it to se->post as last instructions.  */
+	  /* Find the type of the temporary to create; we don't use the type
+	     of e itself as this breaks for subcomponent-references in e (where
+	     the type of e is that of the final reference, but parmse.expr's
+	     type corresponds to the full derived-type).  */
+	  /* TODO: Fix this somehow so we don't need a temporary of the whole
+	     array but instead only the components referenced.  */
+	  temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor.  */
+	  gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
+	  temptype = TREE_TYPE (temptype);
+	  temptype = gfc_get_element_type (temptype);
+
+	  /* Generate the temporary.  Cleaning up the temporary should be the
+	     very last thing done, so we add the code to a new block and add it
+	     to se->post as last instructions.  */
 	  size = gfc_create_var (gfc_array_index_type, NULL);
 	  data = gfc_create_var (pvoid_type_node, NULL);
-	  gfc_start_block (&block);
 	  gfc_init_block (&temp_post);
-	  tmp = gfc_typenode_for_spec (&e->ts);
 	  tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
-					     &tmp_loop, info, tmp,
+					     &tmp_loop, info, temptype,
 					     initial,
 					     false, true, false,
 					     &arg->expr->where);
 	  gfc_add_modify (&se->pre, size, tmp);
 	  tmp = fold_convert (pvoid_type_node, info->data);
 	  gfc_add_modify (&se->pre, data, tmp);
-	  gfc_merge_block_scope (&block);
 
 	  /* Calculate the offset for the temporary.  */
 	  offset = gfc_index_zero_node;
@@ -315,7 +321,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 	  tmp = build_call_expr (gfor_fndecl_in_unpack, 2, parmse.expr, data);
 	  gfc_add_expr_to_block (&se->post, tmp);
 
-	  gfc_add_block_to_block (&se->pre, &parmse.pre);
+	  /* parmse.pre is already added above.  */
 	  gfc_add_block_to_block (&se->post, &parmse.post);
 	  gfc_add_block_to_block (&se->post, &temp_post);
 	}

gcc/testsuite/ChangeLog

+2009-01-27  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38883
+	* gfortran.dg/mvbits_6.f90:  New test.
+	* gfortran.dg/mvbits_7.f90:  New test.
+	* gfortran.dg/mvbits_8.f90:  New test.
+
 2009-01-27  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/38503

gcc/testsuite/gfortran.dg/mvbits_6.f90

+! { dg-do compile }
+
+! PR fortran/38883
+! This ICE'd because the temporary-creation in the MVBITS call was wrong.
+! This is the original test from the PR, the complicated version.
+
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+
+     module yg0009_stuff
+
+      type unseq
+         integer I
+      end type
+
+      contains
+
+      SUBROUTINE YG0009(TDA2L,NF4,NF3,NF1,MF1,MF4,MF3)
+        TYPE(UNSEQ) TDA2L(NF4,NF3)
+
+        CALL MVBITS (TDA2L(NF4:NF1:MF1,NF1:NF3)%I,2, &
+          4, TDA2L(-MF4:-MF1:-NF1,-MF1:-MF3)%I, 3)
+
+      END SUBROUTINE
+
+      end module yg0009_stuff
+
+      program try_yg0009
+      use yg0009_stuff
+      type(unseq)  tda2l(4,3)
+
+      call yg0009(tda2l,4,3,1,-1,-4,-3)
+
+      end

gcc/testsuite/gfortran.dg/mvbits_7.f90

+! { dg-do run }
+
+! PR fortran/38883
+! This ICE'd because the temporary-creation in the MVBITS call was wrong.
+
+! Contributed by Paul Richard Thomas <paul.richard.thomas@gmail.com>
+
+  type t
+    integer  ::  I
+    character(9)  :: chr
+  end type
+  type(t) :: x(4,3)
+  type(t) :: y(4,3)
+  x = reshape ([((t (i*j, "a"),i = 1,4), j=1,3)], [4,3])
+  call foo (x)
+  y = reshape ([((t (i*j*2, "a"),i = 1,4), j=1,3)], [4,3])
+  call bar(y, 4, 3, 1, -1, -4, -3)
+  if (any (x%i .ne. y%i)) call abort
+contains
+  SUBROUTINE foo (x)
+    TYPE(t) x(4, 3)      ! No dependency at all
+    CALL MVBITS (x%i, 0, 6, x%i, 8)
+    x%i = x%i * 2
+  END SUBROUTINE
+  SUBROUTINE bar (x, NF4, NF3, NF1, MF1, MF4, MF3)
+    TYPE(t) x(NF4, NF3)  ! Dependency through variable indices
+    CALL MVBITS (x(NF4:NF1:MF1, NF1:NF3)%i, 1, &
+                 6, x(-MF4:-MF1:-NF1, -MF1:-MF3)%i, 9)
+  END SUBROUTINE
+end

gcc/testsuite/gfortran.dg/mvbits_8.f90

+! { dg-do run }
+
+! PR fortran/38883
+! This ICE'd because the temporary-creation in the MVBITS call was wrong.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  TYPE inner
+    INTEGER :: i
+    INTEGER :: j
+  END TYPE inner
+
+  TYPE outer
+    TYPE(inner) :: comp(2)
+  END TYPE outer
+
+  TYPE(outer) :: var
+
+  var%comp%i = (/ 1, 2 /)
+  var%comp%j = (/ 3, 4 /)
+
+  CALL foobar (var, 1, 2)
+
+  IF (ANY (var%comp%i /= (/ 1, 2 /))) CALL abort ()
+  IF (ANY (var%comp%j /= (/ 3, 4 /))) CALL abort ()
+
+CONTAINS
+
+  SUBROUTINE foobar (x, lower, upper)
+    TYPE(outer), INTENT(INOUT) :: x
+    INTEGER, INTENT(IN) :: lower, upper
+    CALL MVBITS (x%comp%i, 1, 2, x%comp(lower:upper)%i, 1)
+  END SUBROUTINE foobar
+
+END PROGRAM main