re PR fortran/26038 (ICE on allocation of assumed length CHARACTER dummy.)

2006-02-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26038
	* trans-stmt.c (gfc_trans_allocate): Provide assumed character length
	scalar with missing backend_decl for the hidden dummy charlen.

	PR fortran/25059
	* interface.c (gfc_extend_assign): Remove detection of non-PURE
	subroutine in assignment interface, with gfc_error, and put it in
	* resolve.c (resolve_code).

	PR fortran/25070
	* interface.c (gfc_procedure_use): Flag rank checking for non-
	elemental, contained or interface procedures in call to
	(compare_actual_formal), where ranks are checked for assumed
	shape arrays..

2006-02-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26038
	* gfortran.dg/allocate_char_star_scalar_1.f90: New test.

	PR fortran/25059
	* gfortran.dg/impure_assignment_1.f90: New test.

	PR fortran/25070
	* gfortran.dg/assumed_shape_ranks_1.f90: New test.

From-SVN: r110816

gcc/fortran/ChangeLog

+2006-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26038
+	* trans-stmt.c (gfc_trans_allocate): Provide assumed character length
+	scalar with missing backend_decl for the hidden dummy charlen.
+
+	PR fortran/25059
+	* interface.c (gfc_extend_assign): Remove detection of non-PURE
+	subroutine in assignment interface, with gfc_error, and put it in
+	* resolve.c (resolve_code).
+
+	PR fortran/25070
+	* interface.c (gfc_procedure_use): Flag rank checking for non-
+	elemental, contained or interface procedures in call to
+	(compare_actual_formal), where ranks are checked for assumed
+	shape arrays..
+
 2006-02-08  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR libfortran/25425

gcc/fortran/interface.c

@@ -1241,7 +1241,10 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 	}
 
       if (!compare_parameter
-	  (f->sym, a->expr, ranks_must_agree, is_elemental))
+	  (f->sym, a->expr,
+	   ranks_must_agree && f->sym->as
+	     && f->sym->as->type == AS_ASSUMED_SHAPE,
+	   is_elemental))
 	{
 	  if (where)
 	    gfc_error ("Type/rank mismatch in argument '%s' at %L",
@@ -1563,6 +1566,10 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
 void
 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
 {
+  int ranks_must_agree;
+  ranks_must_agree = !sym->attr.elemental && (sym->attr.contained
+			|| sym->attr.if_source == IFSRC_IFBODY);
+
   /* Warn about calls with an implicit interface.  */
   if (gfc_option.warn_implicit_interface
       && sym->attr.if_source == IFSRC_UNKNOWN)
@@ -1570,8 +1577,8 @@ gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
                  sym->name, where);
 
   if (sym->attr.if_source == IFSRC_UNKNOWN
-      || !compare_actual_formal (ap, sym->formal, 0,
-			         sym->attr.elemental, where))
+      || !compare_actual_formal (ap, sym->formal, ranks_must_agree,
+				 sym->attr.elemental, where))
     return;
 
   check_intents (sym->formal, *ap);
@@ -1796,13 +1803,6 @@ gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
   c->expr2 = NULL;
   c->ext.actual = actual;
 
-  if (gfc_pure (NULL) && !gfc_pure (sym))
-    {
-      gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
-		 "PURE", sym->name, &c->loc);
-      return FAILURE;
-    }
-
   return SUCCESS;
 }
 

gcc/fortran/resolve.c

@@ -4241,7 +4241,16 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
 	    break;
 
 	  if (gfc_extend_assign (code, ns) == SUCCESS)
-	    goto call;
+	    {
+	      if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+		{
+		  gfc_error ("Subroutine '%s' called instead of assignment at "
+			     "%L must be PURE", code->symtree->n.sym->name,
+			     &code->loc);
+		  break;
+		}
+	      goto call;
+	    }
 
 	  if (gfc_pure (NULL))
 	    {

gcc/fortran/trans-stmt.c

@@ -3455,6 +3455,10 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_add_modify_expr (&se.pre, val, tmp);
 
 	  tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+
+	  if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
+	    tmp = se.string_length;
+
 	  parm = gfc_chainon_list (NULL_TREE, val);
 	  parm = gfc_chainon_list (parm, tmp);
 	  parm = gfc_chainon_list (parm, pstat);

gcc/testsuite/ChangeLog

+2006-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26038
+	* gfortran.dg/allocate_char_star_scalar_1.f90: New test.
+
+	PR fortran/25059
+	* gfortran.dg/impure_assignment_1.f90: New test.
+
+	PR fortran/25070
+	* gfortran.dg/assumed_shape_ranks_1.f90: New test.
+
 2006-02-09  J"orn Rennecke <joern.rennecke@st.com>
 
 	PR target/26141

gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90

+! { dg-do compile }
+! Tests the patch for PR26038 that used to ICE in gfc_trans_allocate
+! for the want of a string_length to pass to the library.
+! Contributed by hjl@lucon.org && Erik Edelmann  <eedelmanncc.gnu.org>
+module moo
+
+contains
+
+    subroutine foo(self)
+        character(*) :: self
+        pointer :: self
+
+        nullify(self)
+        allocate(self)          ! Used to ICE here
+        print *, len(self)
+    end subroutine
+
+end module moo
+
+
+program hum
+
+    use moo
+
+    character(5), pointer :: p
+    character(10), pointer :: q
+
+    call foo(p)
+    call foo(q)
+
+end program hum

gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90

+! { dg-do compile }
+! Tests fix for PR25070; was no error for actual and assumed shape
+! dummy ranks not matching.
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+
+module addon
+  interface extra
+    function foo (y)
+      integer :: foo (2), y (:)
+    end function foo
+  end interface extra
+end module addon
+
+  use addon
+  INTEGER :: I(2,2)
+  I=RESHAPE((/1,2,3,4/),(/2,2/))
+  CALL TST(I)   ! { dg-error "Type/rank mismatch in argument" }
+  i = foo (i)   ! { dg-error "Type/rank mismatch|Incompatible ranks" }
+CONTAINS
+  SUBROUTINE TST(I)
+    INTEGER :: I(:)
+    write(6,*) I
+  END SUBROUTINE TST
+END
+

gcc/testsuite/gfortran.dg/impure_assignment_1.f90

+! { dg-do compile }
+! Tests fix for PR25059, which gave and ICE after error message  
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+MODULE M1
+ TYPE T1
+  INTEGER :: I
+ END TYPE T1
+ INTERFACE ASSIGNMENT(=)
+   MODULE PROCEDURE S1
+ END INTERFACE
+CONTAINS
+   SUBROUTINE S1(I,J)
+     TYPE(T1), INTENT(OUT):: I
+     TYPE(T1), INTENT(IN) :: J
+     I%I=J%I**2
+   END SUBROUTINE S1
+END MODULE M1
+
+USE M1
+CONTAINS
+PURE SUBROUTINE S2(I,J)
+     TYPE(T1), INTENT(OUT):: I
+     TYPE(T1), INTENT(IN) :: J
+     I=J                      ! { dg-error "must be PURE" }
+END SUBROUTINE S2
+END
\ No newline at end of file