re PR fortran/45438 ([OOP] ICE with -fcheck=pointer)

2010-09-20  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45438
	* trans-expr.c (gfc_conv_procedure_call): Fix pointer checking for
	TBPs, PPCs and pointer/allocatable components.

2010-09-20  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45438
	* gfortran.dg/pointer_check_7.f90: New.

From-SVN: r164462

gcc/fortran/ChangeLog

+2010-09-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45438
+	* trans-expr.c (gfc_conv_procedure_call): Fix pointer checking for
+	TBPs, PPCs and pointer/allocatable components.
+
 2010-09-20  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/45081

gcc/fortran/trans-expr.c

@@ -3169,27 +3169,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
         {
-	  symbol_attribute *attr;
+	  symbol_attribute attr;
 	  char *msg;
 	  tree cond;
 
-	  if (e->expr_type == EXPR_VARIABLE)
-	    attr = &e->symtree->n.sym->attr;
-	  else if (e->expr_type == EXPR_FUNCTION)
-	    {
-	      /* For intrinsic functions, the gfc_attr are not available.  */
-	      if (e->symtree->n.sym->attr.generic && e->value.function.isym)
-		goto end_pointer_check;
-
-	      if (e->symtree->n.sym->attr.generic)
-		attr = &e->value.function.esym->attr;
-	      else
-		attr = &e->symtree->n.sym->result->attr;
-	    }
+	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
+	    attr = gfc_expr_attr (e);
 	  else
 	    goto end_pointer_check;
 
-          if (attr->optional)
+          if (attr.optional)
 	    {
               /* If the actual argument is an optional pointer/allocatable and
 		 the formal argument takes an nonpointer optional value,
@@ -3198,16 +3187,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
 	      tree present, null_ptr, type;
 
-	      if (attr->allocatable
+	      if (attr.allocatable
 		  && (fsym == NULL || !fsym->attr.allocatable))
 		asprintf (&msg, "Allocatable actual argument '%s' is not "
 			  "allocated or not present", e->symtree->n.sym->name);
-	      else if (attr->pointer
+	      else if (attr.pointer
 		       && (fsym == NULL || !fsym->attr.pointer))
 		asprintf (&msg, "Pointer actual argument '%s' is not "
 			  "associated or not present",
 			  e->symtree->n.sym->name);
-	      else if (attr->proc_pointer
+	      else if (attr.proc_pointer
 		       && (fsym == NULL || !fsym->attr.proc_pointer))
 		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
 			  "associated or not present",
@@ -3231,15 +3220,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
           else
 	    {
-	      if (attr->allocatable
+	      if (attr.allocatable
 		  && (fsym == NULL || !fsym->attr.allocatable))
 		asprintf (&msg, "Allocatable actual argument '%s' is not "
 		      "allocated", e->symtree->n.sym->name);
-	      else if (attr->pointer
+	      else if (attr.pointer
 		       && (fsym == NULL || !fsym->attr.pointer))
 		asprintf (&msg, "Pointer actual argument '%s' is not "
 		      "associated", e->symtree->n.sym->name);
-	      else if (attr->proc_pointer
+	      else if (attr.proc_pointer
 		       && (fsym == NULL || !fsym->attr.proc_pointer))
 		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
 		      "associated", e->symtree->n.sym->name);

gcc/testsuite/ChangeLog

+2010-09-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45438
+	* gfortran.dg/pointer_check_7.f90: New.
+
 2010-09-20  Jakub Jelinek  <jakub@redhat.com>
 
 	PR rtl-optimization/45728

gcc/testsuite/gfortran.dg/pointer_check_7.f90

+! { dg-do compile }
+! { dg-options "-fcheck=pointer" }
+!
+! PR 45438: [4.6 Regression] [OOP] ICE with -fcheck=pointer
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+module base_mat_mod
+
+  implicit none 
+
+  type  :: base_sparse_mat
+  contains 
+    procedure :: get_fmt
+  end type
+
+contains
+
+  function get_fmt(a) result(res)
+    class(base_sparse_mat), intent(in) :: a
+    character(len=5) :: res
+    res = 'NULL'
+  end function
+
+  subroutine errlog(name)
+    character(len=*) :: name
+  end subroutine
+
+  subroutine test (a)
+    class(base_sparse_mat), intent(in) :: a
+    call errlog(a%get_fmt())
+  end subroutine
+
+end module
+
+! { dg-final { cleanup-modules "base_mat_mod" } }