Patchwork [Fortran] F2008: TARGET actual to POINTER dummy with INTENT(IN)

login
register
mail settings
Submitter Tobias Burnus
Date Aug. 15, 2010, 3:02 p.m.
Message ID <4C68017B.8070407@net-b.de>
Download mbox | patch
Permalink /patch/61749/
State New
Headers show

Comments

Tobias Burnus - Aug. 15, 2010, 3:02 p.m.
Low-hanging but useful Fortran 2008 feature. F2008 allows passing a 
TARGET to a POINTER dummy which has INTENT(IN).

F2008, 12.5.2.7 Pointer dummy variables:

"If the dummy argument does not have the INTENT (IN), the actual 
argument shall be a pointer. Otherwise, the actual argument shall be a 
pointer or a valid target for the dummy pointer in a pointer assignment 
statement."

Build and regtested on x86-64-linux. OK for the trunk?

Tobias

Patch

2010-08-15  Tobias Burnus  <burnus@net-b.de>

	* interface.c (compare_pointer, ): Allow passing TARGETs to pointers dummies with intent(in).

2010-08-15  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/pointer_target_1.f90: New.
	* gfortran.dg/pointer_target_2.f90: New.
	* gfortran.dg/pointer_target_3.f90: New.

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 163252)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -1368,6 +1368,11 @@  compare_pointer (gfc_symbol *formal, gfc
   if (formal->attr.pointer)
     {
       attr = gfc_expr_attr (actual);
+
+      /* Fortran 2008 allows non-pointer actual arguments.  */
+      if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
+	return 2;
+
       if (!attr.pointer)
 	return 0;
     }
@@ -2113,6 +2133,17 @@  compare_actual_formal (gfc_actual_arglis
 	  return 0;
 	}
 
+      if (a->expr->expr_type != EXPR_NULL
+	  && (gfc_option.allow_std & GFC_STD_F2008) == 0
+	  && compare_pointer (f->sym, a->expr) == 2)
+	{
+	  if (where)
+	    gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+		       "pointer dummy '%s'", &a->expr->where,f->sym->name);
+	  return 0;
+	}
+	
+
       /* Fortran 2008, C1242.  */
       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
 	{
Index: gcc/testsuite/gfortran.dg/pointer_target_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_target_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_target_1.f90	(Revision 0)
@@ -0,0 +1,20 @@ 
+! { dg-do run }
+!
+! TARGET actual to POINTER dummy with INTENT(IN)
+!
+program test
+  implicit none
+  integer, target :: a
+  a = 66
+  call foo(a)
+  if (a /= 647) call abort()
+contains
+  subroutine foo(p)
+    integer, pointer, intent(in) :: p
+    if (a /= 66) call abort()
+    if (p /= 66) call abort()
+    p = 647
+    if (p /= 647) call abort()
+    if (a /= 647) call abort()
+  end subroutine foo
+end program test
Index: gcc/testsuite/gfortran.dg/pointer_target_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_target_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_target_2.f90	(Revision 0)
@@ -0,0 +1,21 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! TARGET actual to POINTER dummy with INTENT(IN)
+!
+program test
+  implicit none
+  integer, target :: a
+  a = 66
+  call foo(a) ! { dg-error "Fortran 2008: Non-pointer actual argument" }
+  if (a /= 647) call abort()
+contains
+  subroutine foo(p)
+    integer, pointer, intent(in) :: p
+    if (a /= 66) call abort()
+    if (p /= 66) call abort()
+    p = 647
+    if (p /= 647) call abort()
+    if (a /= 647) call abort()
+  end subroutine foo
+end program test
Index: gcc/testsuite/gfortran.dg/pointer_target_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_target_3.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_target_3.f90	(Revision 0)
@@ -0,0 +1,20 @@ 
+! { dg-do compile }
+!
+! TARGET actual to POINTER dummy with INTENT(IN)
+!
+program test
+  implicit none
+  integer, target :: a
+  integer :: b
+  call foo(a) ! OK
+  call foo(b) ! { dg-error "must be a pointer" }
+  call bar(a) ! { dg-error "must be a pointer" }
+  call bar(b) ! { dg-error "must be a pointer" }
+contains
+  subroutine foo(p)
+    integer, pointer, intent(in) :: p
+  end subroutine foo
+  subroutine bar(p)
+    integer, pointer :: p
+  end subroutine bar
+end program test