re PR fortran/40604 (ICE with -fcheck=pointer)

2009-07-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40604
        * intrinsic.c (gfc_convert_type_warn): Set sym->result.
        * trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer
        for optional arguments.

2009-07-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40604
        * gfortran.dg/pointer_check_6.f90: New test.

From-SVN: r149405

gcc/fortran/ChangeLog

+2009-07-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40604
+	* intrinsic.c (gfc_convert_type_warn): Set sym->result.
+	* trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer
+	for optional arguments.
+
 2009-07-08  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40675

gcc/fortran/intrinsic.c

@@ -3994,6 +3994,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   new_expr->shape = gfc_copy_shape (shape, rank);
 
   gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
+  new_expr->symtree->n.sym->result = new_expr->symtree->n.sym;
   new_expr->symtree->n.sym->ts = *ts;
   new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   new_expr->symtree->n.sym->attr.function = 1;

gcc/fortran/trans-expr.c

@@ -2784,37 +2784,86 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       /* Add argument checking of passing an unallocated/NULL actual to
          a nonallocatable/nonpointer dummy.  */
 
-      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER)
+      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
         {
-	  gfc_symbol *sym;
+	  symbol_attribute *attr;
 	  char *msg;
 	  tree cond;
 
 	  if (e->expr_type == EXPR_VARIABLE)
-	    sym = e->symtree->n.sym;
+	    attr = &e->symtree->n.sym->attr;
 	  else if (e->expr_type == EXPR_FUNCTION)
-	    sym = e->symtree->n.sym->result;
-	  else
-	    goto end_pointer_check;
+	    {
+	      /* 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 (sym->attr.allocatable
-	      && (fsym == NULL || !fsym->attr.allocatable))
-	    asprintf (&msg, "Allocatable actual argument '%s' is not "
-		      "allocated", sym->name);
-	  else if (sym->attr.pointer
-	      && (fsym == NULL || !fsym->attr.pointer))
-	    asprintf (&msg, "Pointer actual argument '%s' is not "
-		      "associated", sym->name);
-          else if (sym->attr.proc_pointer
-	      && (fsym == NULL || !fsym->attr.proc_pointer))
-	    asprintf (&msg, "Proc-pointer actual argument '%s' is not "
-		      "associated", sym->name);
+	      if (e->symtree->n.sym->attr.generic)
+		attr = &e->value.function.esym->attr;
+	      else
+		attr = &e->symtree->n.sym->result->attr;
+	    }
 	  else
 	    goto end_pointer_check;
 
-	  cond  = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
-			       fold_convert (TREE_TYPE (parmse.expr),
-					     null_pointer_node));
+          if (attr->optional)
+	    {
+              /* If the actual argument is an optional pointer/allocatable and
+		 the formal argument takes an nonpointer optional value,
+		 it is invalid to pass a non-present argument on, even
+		 though there is no technical reason for this in gfortran.
+		 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
+	      tree present, nullptr, type;
+
+	      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
+		       && (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
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+	      present = gfc_conv_expr_present (e->symtree->n.sym);
+	      type = TREE_TYPE (present);
+	      present = fold_build2 (EQ_EXPR, boolean_type_node, present,
+				     fold_convert (type, null_pointer_node));
+	      type = TREE_TYPE (parmse.expr);
+	      nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+				     fold_convert (type, null_pointer_node));
+	      cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
+				  present, nullptr);
+	    }
+          else
+	    {
+	      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
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      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);
+	      else
+		goto end_pointer_check;
+
+
+	      cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+				  fold_convert (TREE_TYPE (parmse.expr),
+						null_pointer_node));
+	    }
  
 	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
 				   msg);

gcc/testsuite/ChangeLog

+2009-07-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40604
+	* gfortran.dg/pointer_check_6.f90: New test.
+
 2009-07-08  Adam Nemet  <anemet@caviumnetworks.com>
 
 	* gcc.target/mips/truncate-5.c: New test.

gcc/testsuite/gfortran.dg/pointer_check_6.f90

+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+!
+! { dg-shouldfail "pointer check" }
+! { dg-output ".*At line 104 of file .*Fortran runtime error: Pointer actual argument 'a' is not associated.*" }
+!
+! PR fortran/40604
+!
+! The following cases are all valid, but were failing
+! for one or the other reason.
+!
+! Contributed by Janus Weil and Tobias Burnus.
+!
+
+subroutine test1()
+  call test(uec=-1)
+contains 
+  subroutine test(str,uec)
+    implicit none
+    character*(*), intent(in), optional:: str
+    integer, intent(in), optional :: uec
+  end subroutine
+end subroutine test1
+
+module m
+  interface matrixMult
+     Module procedure matrixMult_C2
+  End Interface
+contains
+  subroutine test
+    implicit none
+    complex, dimension(0:3,0:3) :: m1,m2
+    print *,Trace(MatrixMult(m1,m2))
+  end subroutine
+  complex function trace(a)
+    implicit none
+    complex, intent(in),  dimension(0:3,0:3) :: a 
+  end function trace
+  function matrixMult_C2(a,b) result(matrix)
+    implicit none
+    complex, dimension(0:3,0:3) :: matrix,a,b
+  end function matrixMult_C2
+end module m
+
+SUBROUTINE plotdop(amat)
+      IMPLICIT NONE
+      REAL,    INTENT (IN) :: amat(3,3)
+      integer :: i1
+      real :: pt(3)
+      i1 = 1
+      pt = MATMUL(amat,(/i1,i1,i1/))
+END SUBROUTINE plotdop
+
+        FUNCTION evaluateFirst(s,n)result(number)
+          IMPLICIT NONE
+          CHARACTER(len =*), INTENT(inout) :: s
+          INTEGER,OPTIONAL                 :: n
+          REAL                             :: number
+          number = 1.1
+        end function
+
+SUBROUTINE rw_inp(scpos)
+      IMPLICIT NONE
+      REAL scpos
+
+      interface
+        FUNCTION evaluateFirst(s,n)result(number)
+          IMPLICIT NONE
+          CHARACTER(len =*), INTENT(inout) :: s
+          INTEGER,OPTIONAL                 :: n
+          REAL                             :: number
+        end function
+      end interface
+
+      CHARACTER(len=100) :: line
+      scpos = evaluatefirst(line)
+END SUBROUTINE rw_inp
+
+program test
+  integer, pointer :: a
+!  nullify(a)
+  allocate(a)
+  a = 1
+  call sub1a(a)
+  call sub1b(a)
+  call sub1c()
+contains
+  subroutine sub1a(a)
+   integer, pointer :: a
+   call sub2(a)
+   call sub3(a)
+   call sub4(a)
+  end subroutine sub1a
+  subroutine sub1b(a)
+   integer, pointer,optional :: a
+   call sub2(a)
+   call sub3(a)
+   call sub4(a)
+  end subroutine sub1b
+  subroutine sub1c(a)
+   integer, pointer,optional :: a
+   call sub4(a)
+!   call sub2(a)  ! << Invalid - working correctly, but not allowed in F2003
+   call sub3(a) ! << INVALID
+  end subroutine sub1c
+  subroutine sub4(b)
+    integer, optional,pointer :: b
+  end subroutine
+  subroutine sub2(b)
+    integer, optional :: b
+  end subroutine
+  subroutine sub3(b)
+    integer :: b
+  end subroutine
+end
+
+
+! { dg-final { cleanup-modules "m" } }