[Patch, fortran] PR26038 , PR25059 and PR25070 - miscellaneous fixes.

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

These are three fixes with no connection whatsoever.  However, they are 
easily identified in the patch and are self-explanatory.

(i) ICE with allocation of character(*) pointer:

2006-01-31  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/26038
   * gfortran.dg/allocate_char_star_scalar_1.f90: New test.

(ii) ICE after message on detection of non-PURE suboutine in interface 
assignment.

   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/25059
   * gfortran.dg/impure_assignment_1.f90: New test.

(iii) Check that ranks of actual argument and assumed shape dummy are 
the same.

   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..

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

Regtested together on FC3/Athlon.

OK for trunk and 4.1?

Paul


Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 110407)
--- gcc/fortran/interface.c	(working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 1241,1247 ****
  	}
  
        if (!compare_parameter
! 	  (f->sym, a->expr, ranks_must_agree, is_elemental))
  	{
  	  if (where)
  	    gfc_error ("Type/rank mismatch in argument '%s' at %L",
--- 1241,1250 ----
  	}
  
        if (!compare_parameter
! 	  (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",
*************** check_intents (gfc_formal_arglist * f, g
*** 1563,1568 ****
--- 1566,1575 ----
  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)
*************** gfc_procedure_use (gfc_symbol * sym, gfc
*** 1570,1577 ****
                   sym->name, where);
  
    if (sym->attr.if_source == IFSRC_UNKNOWN
!       || !compare_actual_formal (ap, sym->formal, 0,
! 			         sym->attr.elemental, where))
      return;
  
    check_intents (sym->formal, *ap);
--- 1577,1584 ----
                   sym->name, where);
  
    if (sym->attr.if_source == IFSRC_UNKNOWN
!       || !compare_actual_formal (ap, sym->formal, ranks_must_agree,
! 				 sym->attr.elemental, where))
      return;
  
    check_intents (sym->formal, *ap);
*************** gfc_extend_assign (gfc_code * c, gfc_nam
*** 1796,1808 ****
    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;
  }
  
--- 1803,1808 ----
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 110407)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 3256,3261 ****
--- 3256,3265 ----
  	  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);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 110407)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_code (gfc_code * code, gfc_names
*** 4241,4247 ****
  	    break;
  
  	  if (gfc_extend_assign (code, ns) == SUCCESS)
! 	    goto call;
  
  	  if (gfc_pure (NULL))
  	    {
--- 4241,4256 ----
  	    break;
  
  	  if (gfc_extend_assign (code, ns) == SUCCESS)
! 	    {
! 	      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))
  	    {
Index: gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90	(revision 0)
***************
*** 0 ****
--- 1,31 ----
+ ! { 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
\ No newline at end of file
Index: gcc/testsuite/gfortran.dg/impure_assignment_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/impure_assignment_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/impure_assignment_1.f90	(revision 0)
***************
*** 0 ****
--- 1,26 ----
+ ! { 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
Index: gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90	(revision 0)
***************
*** 0 ****
--- 1,25 ----
+ ! { 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
+