re PR fortran/29387 (ICE on character array function of variable length)

2006-10-31  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29387
	* trans-intrinsic.c (gfc_conv_intrinsic_len): Rearrange to have
	a specific case for EXPR_VARIABLE and, in default, build an ss
	to call gfc_conv_expr_descriptor for array expressions..

	PR fortran/29490
	* trans-expr.c (gfc_set_interface_mapping_bounds): In the case
	that GFC_TYPE_ARRAY_LBOUND is not available, use descriptor
	values for it and GFC_TYPE_ARRAY_UBOUND.

	PR fortran/29641
	* trans-types.c (gfc_get_derived_type): If the derived type
	namespace has neither a parent nor a proc_name, set NULL for
	the search namespace.


2006-10-31  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29387
	* gfortran.dg/intrinsic_actual_2.f90: New test.

	PR fortran/29490
	* gfortran.dg/actual_array_interface_1.f90: New test.

	PR fortran/29641
	* gfortran.dg/used_types_11.f90: New test.

From-SVN: r118220

8 files changed, 151 insertions, 33 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f6ea479..3fd834c7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2006-10-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29387
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Rearrange to have
+	a specific case for EXPR_VARIABLE and, in default, build an ss
+	to call gfc_conv_expr_descriptor for array expressions..
+
+	PR fortran/29490
+	* trans-expr.c (gfc_set_interface_mapping_bounds): In the case
+	that GFC_TYPE_ARRAY_LBOUND is not available, use descriptor
+	values for it and GFC_TYPE_ARRAY_UBOUND.
+
+	PR fortran/29641
+	* trans-types.c (gfc_get_derived_type): If the derived type
+	namespace has neither a parent nor a proc_name, set NULL for
+	the search namespace.
+
 2006-10-30  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/29452
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e5c9f24..f4fcea5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1296,10 +1296,17 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
   offset = gfc_index_zero_node;
   for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
     {
+      dim = gfc_rank_cst[n];
       GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
-      if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
+      if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
+	{
+	  GFC_TYPE_ARRAY_LBOUND (type, n)
+		= gfc_conv_descriptor_lbound (desc, dim);
+	  GFC_TYPE_ARRAY_UBOUND (type, n)
+		= gfc_conv_descriptor_ubound (desc, dim);
+	}
+      else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
 	{
-	  dim = gfc_rank_cst[n];
 	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 			     gfc_conv_descriptor_ubound (desc, dim),
 			     gfc_conv_descriptor_lbound (desc, dim));
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 44d439d..d031878 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2429,6 +2429,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
   gfc_symbol *sym;
   gfc_se argse;
   gfc_expr *arg;
+  gfc_ss *ss;
 
   gcc_assert (!se->ss);
 
@@ -2448,32 +2449,37 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
       get_array_ctor_strlen (arg->value.constructor, &len);
       break;
 
-    default:
-	if (arg->expr_type == EXPR_VARIABLE
-	    && (arg->ref == NULL || (arg->ref->next == NULL
-				     && arg->ref->type == REF_ARRAY)))
-	  {
-	    /* This doesn't catch all cases.
-	       See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
-	       and the surrounding thread.  */
-	    sym = arg->symtree->n.sym;
-	    decl = gfc_get_symbol_decl (sym);
-	    if (decl == current_function_decl && sym->attr.function
+    case EXPR_VARIABLE:
+      if (arg->ref == NULL
+	    || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
+	{
+	  /* This doesn't catch all cases.
+	     See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
+	     and the surrounding thread.  */
+	  sym = arg->symtree->n.sym;
+	  decl = gfc_get_symbol_decl (sym);
+	  if (decl == current_function_decl && sym->attr.function
 		&& (sym->result == sym))
-	      decl = gfc_get_fake_result_decl (sym, 0);
-
-	    len = sym->ts.cl->backend_decl;
-	    gcc_assert (len);
-	  }
-	else
-	  {
-	    /* Anybody stupid enough to do this deserves inefficient code.  */
-	    gfc_init_se (&argse, se);
-	    gfc_conv_expr (&argse, arg);
-	    gfc_add_block_to_block (&se->pre, &argse.pre);
-	    gfc_add_block_to_block (&se->post, &argse.post);
-	    len = argse.string_length;
+	    decl = gfc_get_fake_result_decl (sym, 0);
+
+	  len = sym->ts.cl->backend_decl;
+	  gcc_assert (len);
+	  break;
 	}
+
+      /* Otherwise fall through.  */
+
+    default:
+      /* Anybody stupid enough to do this deserves inefficient code.  */
+      ss = gfc_walk_expr (arg);
+      gfc_init_se (&argse, se);
+      if (ss == gfc_ss_terminator)
+	gfc_conv_expr (&argse, arg);
+      else
+	gfc_conv_expr_descriptor (&argse, arg, ss);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      len = argse.string_length;
       break;
     }
   se->expr = convert (type, len);
@@ -3020,8 +3026,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
       else
         {
           /* A pointer to an array.  */
-          arg1se.descriptor_only = 1;
-          gfc_conv_expr_lhs (&arg1se, arg1->expr);
+          gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
         }
       gfc_add_block_to_block (&se->pre, &arg1se.pre);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bff025c..ecae593 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1482,11 +1482,15 @@ gfc_get_derived_type (gfc_symbol * derived)
 	 building anew so that potential dummy and actual arguments use the
 	 same TREE_TYPE.  If an equal type is found without a backend_decl,
 	 build the parent version and use it in the current namespace.  */
-
-      /* Derived types in an interface body obtain their parent reference
-	 through the proc_name symbol.  */
-      ns = derived->ns->parent ? derived->ns->parent
-			       : derived->ns->proc_name->ns;
+      if (derived->ns->parent)
+	ns = derived->ns->parent;
+      else if (derived->ns->proc_name)
+	/* Derived types in an interface body obtain their parent reference
+	   through the proc_name symbol.  */
+	ns = derived->ns->proc_name->ns;
+      else
+	/* Sometimes there isn't a parent reference!  */
+	ns = NULL;
 
       for (; ns; ns = ns->parent)
 	{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 23519e1..ec77c16 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2006-10-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29387
+	* gfortran.dg/intrinsic_actual_2.f90: New test.
+
+	PR fortran/29490
+	* gfortran.dg/actual_array_interface_1.f90: New test.
+
+	PR fortran/29641
+	* gfortran.dg/used_types_11.f90: New test.
+	
 2006-10-30  Dirk Mueller  <dmueller@suse.de>
 
 	* g++.old-deja/g++.pt/eichin01a.C (main): Fix prototype.
diff --git a/gcc/testsuite/gfortran.dg/actual_array_interface_1.f90 b/gcc/testsuite/gfortran.dg/actual_array_interface_1.f90
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_array_interface_1.f90
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_actual_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_actual_2.f90
new file mode 100644
index 0000000..d24d21f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_actual_2.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! Tests the fix for PR29387, in which array valued arguments of
+! LEN and ASSOCIATED would cause an ICE.
+!
+! Contributed by Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+!
+  TYPE T1 
+    INTEGER, POINTER :: I=>NULL() 
+  END TYPE T1 
+  character(20) res
+
+  j = 10
+  PRINT *, LEN(SUB(8))
+  PRINT *, LEN(SUB(j))
+! print *, len(SUB(j + 2)//"a")   ! This still fails (no charlen).
+  print *, len(bar(2))
+
+  IF(.NOT.ASSOCIATED(F1(10))) CALL ABORT() 
+
+CONTAINS
+
+  FUNCTION SUB(I)  
+    CHARACTER(LEN=I) :: SUB(1)
+    PRINT *, LEN(SUB(1))
+  END FUNCTION
+
+  FUNCTION BAR(I)  
+    CHARACTER(LEN=I*10) :: BAR(1)
+    PRINT *, LEN(BAR)
+  END FUNCTION
+
+  FUNCTION F1(I) RESULT(R) 
+   TYPE(T1), DIMENSION(:), POINTER :: R 
+   INTEGER :: I 
+   ALLOCATE(R(I)) 
+  END FUNCTION F1 
+END 
diff --git a/gcc/testsuite/gfortran.dg/used_types_11.f90 b/gcc/testsuite/gfortran.dg/used_types_11.f90
new file mode 100644
index 0000000..b3f4eaa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_types_11.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! Tests the patch for PR 29641, in which an ICE would occur with
+! the ordering of USE statements below.
+!
+! Contributed by Jakub Jelinek <jakub@gcc.gnu.org>
+!
+module A
+  type :: T
+    integer :: u
+  end type T
+end module A
+
+module B
+contains
+  function foo()
+    use A
+    type(T), pointer :: foo
+    nullify (foo)
+  end function foo
+end module B
+
+subroutine bar()
+  use B             ! The order here is important
+  use A             ! If use A comes before use B, it works
+  type(T), pointer :: x
+  x => foo()
+end subroutine bar
+
+  use B
+  use A
+  type(T), pointer :: x
+  type(T), target  :: y
+  x => y
+  print *, associated (x)
+  x => foo ()
+  print *, associated (x)
+end