/* 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);
--- /dev/null
+! { 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" } }
OSDN Git Service
