This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patches,fortran] Add POINTER INTENT(*) support (PR29624)
- From: Tobias Burnus <burnus at net-b dot de>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 12 Dec 2006 12:20:23 +0100
- Subject: [patches,fortran] Add POINTER INTENT(*) support (PR29624)
:ADDPATCH fortran:
The standard can be found at
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=29624#c0
In a nutshell: With intent(in) the pointer dummy argument's association
shall not be changed, the target may.
Thanks to Tobias S. for pointing out that I was looking at the wrong
thing in terms of attributes.
Quick remark to compound structures:
- If the last subobject is a pointer & its association is changed, I
check whether somewhere higher up in the hierarchy is already a pointer,
because then the subobject is a target of that one. => Modification allowed.
- If the last subobject is a pointer & its value target value is changed
=> Modification always allowed
- If the last subobject is a nonpointer: Check whether somewhere higher
up in the hierarchy is already a pointer, because then the subobject is
a target of that one. => Modification allowed.
Regression tested on x86_64-unknown-linux-gnu.
Tobias
fortran/
2006-12-12 Tobias Burnus <burnus@net-b.de>
PR fortran/29624
* interface.c (compare_parameter_intent): New function.
(check_intents): Support pointer intents.
* symbol.c (check_conflict): Support pointer intents,
better conflict_std message.
* expr.c (gfc_check_assign,gfc_check_pointer_assign):
Support pointer intents.
* resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
Support pointer intents.
testsuite/
2006-12-12 Tobias Burnus <burnus@net-b.de>
PR fortran/29624
* gfortran.dg/allocatable_dummy_2.f90: Update dg-error.
* gfortran.dg/protected_4.f90: Add pointer intent check.
* gfortran.dg/protected_6.f90: Add pointer intent check.
* gfortran.dg/pointer_intent_1.f90: New test.
* gfortran.dg/pointer_intent_2.f90: New test.
* gfortran.dg/pointer_intent_3.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (Revision 119747)
--- gcc/fortran/interface.c (Arbeitskopie)
*************** check_some_aliasing (gfc_formal_arglist
*** 1648,1653 ****
--- 1648,1675 ----
}
+ /* Given a symbol of a formal argument list and an expression, see if
+ their intents are compatible. Returns nonzero if compatible,
+ zero if not compatible. */
+
+ static int
+ compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
+ {
+ if (actual->symtree->n.sym->attr.pointer
+ && !formal->attr.pointer)
+ return 1;
+
+ if (actual->symtree->n.sym->attr.intent != INTENT_IN)
+ return 1;
+
+ if (formal->attr.intent == INTENT_INOUT
+ || formal->attr.intent == INTENT_OUT)
+ return 0;
+
+ return 1;
+ }
+
+
/* Given formal and actual argument lists that correspond to one
another, check that they are compatible in the sense that intents
are not mismatched. */
*************** check_some_aliasing (gfc_formal_arglist
*** 1655,1661 ****
static try
check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
{
! sym_intent a_intent, f_intent;
for (;; f = f->next, a = a->next)
{
--- 1677,1683 ----
static try
check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
{
! sym_intent f_intent;
for (;; f = f->next, a = a->next)
{
*************** check_intents (gfc_formal_arglist * f, g
*** 1667,1678 ****
if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
continue;
- a_intent = a->expr->symtree->n.sym->attr.intent;
f_intent = f->sym->attr.intent;
! if (a_intent == INTENT_IN
! && (f_intent == INTENT_INOUT
! || f_intent == INTENT_OUT))
{
gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
--- 1689,1697 ----
if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
continue;
f_intent = f->sym->attr.intent;
! if (!compare_parameter_intent(f->sym, a->expr))
{
gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (Revision 119747)
--- gcc/fortran/symbol.c (Arbeitskopie)
*************** check_conflict (symbol_attribute * attr,
*** 288,294 ****
{
a1 = pointer;
a2 = intent;
! goto conflict;
}
/* Check for attributes not allowed in a BLOCK DATA. */
--- 288,295 ----
{
a1 = pointer;
a2 = intent;
! standard = GFC_STD_F2003;
! goto conflict_std;
}
/* Check for attributes not allowed in a BLOCK DATA. */
*************** conflict:
*** 571,584 ****
conflict_std:
if (name == NULL)
{
! return gfc_notify_std (standard, "In the selected standard, %s attribute "
! "conflicts with %s attribute at %L", a1, a2,
! where);
}
else
{
! return gfc_notify_std (standard, "In the selected standard, %s attribute "
! "conflicts with %s attribute in '%s' at %L",
a1, a2, name, where);
}
}
--- 572,589 ----
conflict_std:
if (name == NULL)
{
! return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
! "at %L",
! (standard == GFC_STD_F2003)
! ? "Fortran 2003" : "Not in the selected standard",
! a1, a2, where);
}
else
{
! return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
! "in '%s' at %L",
! (standard == GFC_STD_F2003)
! ? "Fortran 2003" : "Not in the selected standard",
a1, a2, name, where);
}
}
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (Revision 119747)
--- gcc/fortran/expr.c (Arbeitskopie)
*************** try
*** 2188,2199 ****
gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
{
gfc_symbol *sym;
sym = lvalue->symtree->n.sym;
! if (sym->attr.intent == INTENT_IN)
{
! gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
sym->name, &lvalue->where);
return FAILURE;
}
--- 2188,2212 ----
gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
{
gfc_symbol *sym;
+ gfc_ref *ref;
+ int has_pointer;
sym = lvalue->symtree->n.sym;
! /* Check INTENT(IN), unless the object itself of higher up in the
! hierarchy is a pointer. */
! has_pointer = sym->attr.pointer;
!
! for (ref = lvalue->ref; ref; ref = ref->next)
! if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
! {
! has_pointer = 1;
! break;
! }
!
! if (!has_pointer && sym->attr.intent == INTENT_IN)
{
! gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
sym->name, &lvalue->where);
return FAILURE;
}
*************** try
*** 2318,2324 ****
--- 2331,2339 ----
gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
{
symbol_attribute attr;
+ gfc_ref *ref;
int is_pure;
+ int pointer, check_intent_in;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
{
*************** gfc_check_pointer_assign (gfc_expr * lva
*** 2336,2343 ****
return FAILURE;
}
! attr = gfc_variable_attr (lvalue, NULL);
! if (!attr.pointer)
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
--- 2351,2379 ----
return FAILURE;
}
!
! /* Check INTENT(IN), unless the object itself of higher up in the
! hierarchy is a pointer. */
! check_intent_in = 1;
! pointer = lvalue->symtree->n.sym->attr.pointer;
!
! for (ref = lvalue->ref; ref; ref = ref->next)
! {
! if (pointer)
! check_intent_in = 0;
!
! if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
! pointer = 1;
! }
!
! if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
! {
! gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
! lvalue->symtree->n.sym->name, &lvalue->where);
! return FAILURE;
! }
!
! if (!pointer)
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (Revision 119747)
--- gcc/fortran/resolve.c (Arbeitskopie)
*************** derived_inaccessible (gfc_symbol *sym)
*** 3317,3365 ****
static try
resolve_deallocate_expr (gfc_expr * e)
{
! symbol_attribute attr;
! int allocatable;
gfc_ref *ref;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
- attr = gfc_expr_attr (e);
- if (attr.pointer)
- return SUCCESS;
-
if (e->expr_type != EXPR_VARIABLE)
goto bad;
allocatable = e->symtree->n.sym->attr.allocatable;
for (ref = e->ref; ref; ref = ref->next)
! switch (ref->type)
! {
! case REF_ARRAY:
! if (ref->u.ar.type != AR_FULL)
! allocatable = 0;
! break;
! case REF_COMPONENT:
! allocatable = (ref->u.c.component->as != NULL
! && ref->u.c.component->as->type == AS_DEFERRED);
! break;
! case REF_SUBSTRING:
! allocatable = 0;
! break;
! }
! if (allocatable == 0)
{
bad:
gfc_error ("Expression in DEALLOCATE statement at %L must be "
"ALLOCATABLE or a POINTER", &e->where);
}
! if (e->symtree->n.sym->attr.intent == INTENT_IN)
{
! gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
--- 3317,3372 ----
static try
resolve_deallocate_expr (gfc_expr * e)
{
! int allocatable, pointer, check_intent_in;
gfc_ref *ref;
+ /* Check INTENT(IN), unless an object higher up in the
+ hierarchy is a pointer. */
+ check_intent_in = 1;
+
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
if (e->expr_type != EXPR_VARIABLE)
goto bad;
allocatable = e->symtree->n.sym->attr.allocatable;
+ pointer = e->symtree->n.sym->attr.pointer;
for (ref = e->ref; ref; ref = ref->next)
! {
! if (pointer)
! check_intent_in = 0;
! switch (ref->type)
! {
! case REF_ARRAY:
! if (ref->u.ar.type != AR_FULL)
! allocatable = 0;
! break;
! case REF_COMPONENT:
! allocatable = (ref->u.c.component->as != NULL
! && ref->u.c.component->as->type == AS_DEFERRED);
! pointer = ref->u.c.component->pointer;
! break;
! case REF_SUBSTRING:
! allocatable = 0;
! break;
! }
! }
!
! if (allocatable == 0 && pointer == 0)
{
bad:
gfc_error ("Expression in DEALLOCATE statement at %L must be "
"ALLOCATABLE or a POINTER", &e->where);
}
! if (check_intent_in
! && e->symtree->n.sym->attr.intent == INTENT_IN)
{
! gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
*************** expr_to_initialize (gfc_expr * e)
*** 3481,3487 ****
static try
resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
! int i, pointer, allocatable, dimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
--- 3488,3494 ----
static try
resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
! int i, pointer, allocatable, dimension, check_intent_in;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3490,3495 ****
--- 3497,3506 ----
gfc_symbol *sym;
gfc_alloc *a;
+ /* Check INTENT(IN), unless an object higher up in the
+ hierarchy is a pointer. */
+ check_intent_in = 1;
+
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3527,3552 ****
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
! switch (ref->type)
! {
! case REF_ARRAY:
! if (ref->next != NULL)
! pointer = 0;
! break;
!
! case REF_COMPONENT:
! allocatable = (ref->u.c.component->as != NULL
! && ref->u.c.component->as->type == AS_DEFERRED);
!
! pointer = ref->u.c.component->pointer;
! dimension = ref->u.c.component->dimension;
! break;
! case REF_SUBSTRING:
! allocatable = 0;
! pointer = 0;
! break;
! }
}
if (allocatable == 0 && pointer == 0)
--- 3538,3568 ----
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
! {
! if (pointer)
! check_intent_in = 0;
! switch (ref->type)
! {
! case REF_ARRAY:
! if (ref->next != NULL)
! pointer = 0;
! break;
!
! case REF_COMPONENT:
! allocatable = (ref->u.c.component->as != NULL
! && ref->u.c.component->as->type == AS_DEFERRED);
!
! pointer = ref->u.c.component->pointer;
! dimension = ref->u.c.component->dimension;
! break;
!
! case REF_SUBSTRING:
! allocatable = 0;
! pointer = 0;
! break;
! }
! }
}
if (allocatable == 0 && pointer == 0)
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3556,3564 ****
return FAILURE;
}
! if (e->symtree->n.sym->attr.intent == INTENT_IN)
{
! gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
--- 3572,3581 ----
return FAILURE;
}
! if (check_intent_in
! && e->symtree->n.sym->attr.intent == INTENT_IN)
{
! gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
Index: gcc/testsuite/gfortran.dg/protected_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_4.f90 (Revision 119747)
--- gcc/testsuite/gfortran.dg/protected_4.f90 (Arbeitskopie)
*************** program main
*** 21,26 ****
--- 21,27 ----
use protmod
implicit none
integer :: j
+ logical :: asgnd
protected :: j ! { dg-error "only allowed in specification part of a module" }
a = 43 ! { dg-error "Assigning to PROTECTED variable" }
ap => null() ! { dg-error "Assigning to PROTECTED variable" }
*************** program main
*** 30,35 ****
--- 31,38 ----
allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
ap = 73 ! { dg-error "Assigning to PROTECTED variable" }
call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+ call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
+ asgnd = pointer_check(ap)
contains
subroutine increment(a1,a3)
integer, intent(inout) :: a1, a3
*************** contains
*** 37,45 ****
a3 = a3 + 1
end subroutine increment
subroutine pointer_assignments(p)
! integer, pointer :: p ! with [pointer] intent(out)
! p => null() ! this is invalid
end subroutine pointer_assignments
end program main
module test
--- 40,53 ----
a3 = a3 + 1
end subroutine increment
subroutine pointer_assignments(p)
! integer, pointer,intent(out) :: p
! p => null()
end subroutine pointer_assignments
+ function pointer_check(p)
+ integer, pointer,intent(in) :: p
+ logical :: pointer_check
+ pointer_check = associated(p)
+ end function pointer_check
end program main
module test
Index: gcc/testsuite/gfortran.dg/protected_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_6.f90 (Revision 119747)
--- gcc/testsuite/gfortran.dg/protected_6.f90 (Arbeitskopie)
*************** program main
*** 27,32 ****
--- 27,33 ----
allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
ap = 73 ! { dg-error "Assigning to PROTECTED variable" }
call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+ call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
contains
subroutine increment(a1,a3)
integer, intent(inout) :: a1, a3
*************** contains
*** 34,41 ****
a3 = a3 + 1
end subroutine increment
subroutine pointer_assignments(p)
! integer, pointer :: p ! with [pointer] intent(out)
! p => null() ! this is invalid
end subroutine pointer_assignments
end program main
--- 35,42 ----
a3 = a3 + 1
end subroutine increment
subroutine pointer_assignments(p)
! integer, pointer,intent (inout) :: p
! p => null()
end subroutine pointer_assignments
end program main
Index: gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 (Revision 119747)
--- gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 (Arbeitskopie)
*************** contains
*** 16,28 ****
subroutine init2(x)
integer, allocatable, intent(in) :: x(:)
! allocate(x(3)) ! { dg-error "Can't allocate" }
end subroutine init2
subroutine kill(x)
integer, allocatable, intent(in) :: x(:)
! deallocate(x) ! { dg-error "Can't deallocate" }
end subroutine kill
end program alloc_dummy
--- 16,28 ----
subroutine init2(x)
integer, allocatable, intent(in) :: x(:)
! allocate(x(3)) ! { dg-error "Cannot allocate" }
end subroutine init2
subroutine kill(x)
integer, allocatable, intent(in) :: x(:)
! deallocate(x) ! { dg-error "Cannot deallocate" }
end subroutine kill
end program alloc_dummy
Index: gcc/testsuite/gfortran.dg/pointer_intent_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_intent_1.f90 (Revision 0)
--- gcc/testsuite/gfortran.dg/pointer_intent_1.f90 (Revision 0)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-run }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! Pointer intent test
+ ! PR fortran/29624
+ !
+ ! Valid program
+ program test
+ implicit none
+ type myT
+ integer :: x
+ integer, pointer :: point
+ end type myT
+ integer, pointer :: p
+ type(myT), pointer :: t
+ type(myT) :: t2
+ allocate(p,t)
+ allocate(t%point)
+ t%point = 55
+ p = 33
+ call a(p,t)
+ deallocate(p)
+ nullify(p)
+ call a(p,t)
+ call nonpointer(t2)
+ contains
+ subroutine a(p,t)
+ integer, pointer,intent(in) :: p
+ type(myT), pointer, intent(in) :: t
+ integer, pointer :: tmp
+ if(.not.associated(p)) return
+ if(p /= 33) call abort()
+ p = 7
+ if (associated(t)) then
+ ! allocating is valid as we don't change the status
+ ! of the pointer "t", only of it's target
+ t%x = -15
+ if(.not.associated(t%point)) call abort()
+ if(t%point /= 55) call abort()
+ nullify(t%point)
+ allocate(tmp)
+ t%point => tmp
+ deallocate(t%point)
+ t%point => null(t%point)
+ tmp => null(tmp)
+ allocate(t%point)
+ t%point = 27
+ if(t%point /= 27) call abort()
+ if(t%x /= -15) call abort()
+ call foo(t)
+ if(t%x /= 32) call abort()
+ if(t%point /= -98) call abort()
+ end if
+ call b(p)
+ if(p /= 5) call abort()
+ end subroutine
+ subroutine b(v)
+ integer, intent(out) :: v
+ v = 5
+ end subroutine b
+ subroutine foo(comp)
+ type(myT), intent(inout) :: comp
+ if(comp%x /= -15) call abort()
+ !if(comp%point /= 27) call abort()
+ comp%x = 32
+ comp%point = -98
+ end subroutine foo
+ subroutine nonpointer(t)
+ type(myT), intent(in) :: t
+ t%point = 7
+ end subroutine nonpointer
+ end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_intent_2.f90 (Revision 0)
--- gcc/testsuite/gfortran.dg/pointer_intent_2.f90 (Revision 0)
***************
*** 0 ****
--- 1,19 ----
+ ! { dg-compile }
+ ! { dg-options "-std=f95" }
+ ! { dg-shouldfail "Fortran 2003 feature with -std=f95" }
+ !
+ ! Pointer intent test
+ ! PR fortran/29624
+ !
+ ! Fortran 2003 features in Fortran 95
+ program test
+ implicit none
+ integer, pointer :: p
+ allocate(p)
+ p = 33
+ call a(p) ! { dg-error "Type/rank mismatch in argument" }
+ contains
+ subroutine a(p)! { dg-error "has no IMPLICIT type" }
+ integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute with INTENT attribute" }
+ end subroutine
+ end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_intent_3.f90 (Revision 0)
--- gcc/testsuite/gfortran.dg/pointer_intent_3.f90 (Revision 0)
***************
*** 0 ****
--- 1,41 ----
+ ! { dg-compile }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! { dg-shouldfail "Invalid code" }
+ !
+ ! Pointer intent test
+ ! PR fortran/29624
+ !
+ ! Valid program
+ program test
+ implicit none
+ type myT
+ integer :: j = 5
+ integer, pointer :: jp => null()
+ end type myT
+ integer, pointer :: p
+ type(myT) :: t
+ call a(p)
+ call b(t)
+ contains
+ subroutine a(p)
+ integer, pointer,intent(in) :: p
+ p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+ nullify(p) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+ allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+ call c(p) ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" }
+ deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+ end subroutine
+ subroutine c(p)
+ integer, pointer, intent(inout) :: p
+ nullify(p)
+ end subroutine c
+ subroutine b(t)
+ type(myT),intent(in) :: t
+ t%jp = 5
+ t%jp => null(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+ nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+ t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+ allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+ deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+ end subroutine b
+ end program