OSDN Git Service

2009-07-09 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 9 Jul 2009 09:42:34 +0000 (09:42 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 9 Jul 2009 09:42:34 +0000 (09:42 +0000)
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149405 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/intrinsic.c
gcc/fortran/trans-expr.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/pointer_check_6.f90 [new file with mode: 0644]

index 77c5f61..3f3feec 100644 (file)
@@ -1,3 +1,10 @@
+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
index 7bb10ec..9402234 100644 (file)
@@ -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;
index d4ee169..fe33286 100644 (file)
@@ -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);
index 3dcfad3..63b2df4 100644 (file)
@@ -1,3 +1,8 @@
+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.
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_6.f90 b/gcc/testsuite/gfortran.dg/pointer_check_6.f90
new file mode 100644 (file)
index 0000000..2f7373f
--- /dev/null
@@ -0,0 +1,118 @@
+! { 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" } }