mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-28 14:24:43 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

re PR fortran/29624 (Fortran 2003: Support intent for pointers)

Browse Source 
fortran/
2007-01-05  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-01-05  Tobias Burnus  <burnus@net-b.de>

        PR fortran/29624
        * gfortran.dg/alloc_alloc_expr_1.f90: Add check for
          invalid deallocate.
        * 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.

From-SVN: r120472
This commit is contained in:
Tobias Burnus 2007-01-05 10:08:37 +01:00
parent 150f069c1c
commit f17facacf2
13 changed files with 302 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -1,3 +1,15 @@
2007-01-05 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.
2007-01-03 Brooks Moses <brooks.moses@codesourcery.com>
PR 30371

44
gcc/fortran/expr.c
View File

@ -2188,12 +2188,25 @@ try
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;
if (sym->attr.intent == INTENT_IN)
/* Check INTENT(IN), unless the object itself is the component or
sub-component of 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 ("Can't assign to INTENT(IN) variable '%s' at %L",
gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
sym->name, &lvalue->where);
return FAILURE;
}
@ -2318,7 +2331,9 @@ try
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)
{
@ -2336,8 +2351,29 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
return FAILURE;
}
attr = gfc_variable_attr (lvalue, NULL);
if (!attr.pointer)
/* Check INTENT(IN), unless the object itself is the component or
sub-component of 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;

28
gcc/fortran/interface.c
View File

@ -1664,6 +1664,27 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
}
/* Given a symbol of a formal argument list and an expression,
return non-zero if their intents are compatible, zero otherwise. */
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. */
@ -1671,7 +1692,7 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
static try
check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
{
sym_intent a_intent, f_intent;
sym_intent f_intent;
for (;; f = f->next, a = a->next)
{
@ -1683,12 +1704,9 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
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))
if (!compare_parameter_intent(f->sym, a->expr))
{
gfc_error ("Procedure argument at %L is INTENT(IN) while interface "

102
gcc/fortran/resolve.c
View File

@ -3446,48 +3446,57 @@ static try
resolve_deallocate_expr (gfc_expr * e)
{
symbol_attribute attr;
int allocatable;
int allocatable, pointer, check_intent_in;
gfc_ref *ref;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
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;
pointer = e->symtree->n.sym->attr.pointer;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
if (ref->u.ar.type != AR_FULL)
{
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;
break;
}
}
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
break;
attr = gfc_expr_attr (e);
case REF_SUBSTRING:
allocatable = 0;
break;
}
if (allocatable == 0)
if (allocatable == 0 && attr.pointer == 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)
if (check_intent_in
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
@ -3609,7 +3618,7 @@ expr_to_initialize (gfc_expr * e)
static try
resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
int i, pointer, allocatable, dimension;
int i, pointer, allocatable, dimension, check_intent_in;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
@ -3618,6 +3627,9 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
gfc_symbol *sym;
gfc_alloc *a;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
@ -3655,26 +3667,31 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
if (ref->next != NULL)
pointer = 0;
break;
{
if (pointer)
check_intent_in = 0;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
switch (ref->type)
{
case REF_ARRAY:
if (ref->next != NULL)
pointer = 0;
break;
pointer = ref->u.c.component->pointer;
dimension = ref->u.c.component->dimension;
break;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
case REF_SUBSTRING:
allocatable = 0;
pointer = 0;
break;
}
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)
@ -3684,9 +3701,10 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
return FAILURE;
}
if (e->symtree->n.sym->attr.intent == INTENT_IN)
if (check_intent_in
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}

9
gcc/fortran/symbol.c
View File

@ -288,7 +288,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
{
a1 = pointer;
a2 = intent;
goto conflict;
standard = GFC_STD_F2003;
goto conflict_std;
}
/* Check for attributes not allowed in a BLOCK DATA. */
@ -571,14 +572,14 @@ conflict:
conflict_std:
if (name == NULL)
{
return gfc_notify_std (standard, "In the selected standard, %s attribute "
return gfc_notify_std (standard, "Fortran 2003: %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",
return gfc_notify_std (standard, "Fortran 2003: %s attribute "
"with %s attribute in '%s' at %L",
a1, a2, name, where);
}
}

14
gcc/testsuite/ChangeLog
View File

@ -1,4 +1,16 @@
2006-01-04 Brooks Moses <brooks.moses@codesourcery.com>
2006-01-05 Tobias Burnus <burnus@net-b.de>
PR fortran/29624
* gfortran.dg/alloc_alloc_expr_1.f90: Add check for
invalid deallocate.
* 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.
2007-01-04 Brooks Moses <brooks.moses@codesourcery.com>
PR 30235
* gfortran.dg/altreturn_2.f90: new test.

4
gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
View File

@ -24,6 +24,8 @@ program fc011
ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
print *, 'This program has three errors', PTR, ALLOC(1)
deallocate(ALLOCS(1)) ! { dg-error "must be ALLOCATABLE or a POINTER" }
print *, 'This program has four errors', PTR, ALLOC(1)
end program fc011

4
gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
View File

@ -16,13 +16,13 @@ contains
subroutine init2(x)
integer, allocatable, intent(in) :: x(:)
allocate(x(3)) ! { dg-error "Can't allocate" }
allocate(x(3)) ! { dg-error "Cannot allocate" }
end subroutine init2
subroutine kill(x)
integer, allocatable, intent(in) :: x(:)
deallocate(x) ! { dg-error "Can't deallocate" }
deallocate(x) ! { dg-error "Cannot deallocate" }
end subroutine kill
end program alloc_dummy

71
gcc/testsuite/gfortran.dg/pointer_intent_1.f90 Normal file
View File

@ -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

19
gcc/testsuite/gfortran.dg/pointer_intent_2.f90 Normal file
View File

@ -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

41
gcc/testsuite/gfortran.dg/pointer_intent_3.f90 Normal file
View File

@ -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

12
gcc/testsuite/gfortran.dg/protected_4.f90
View File

@ -21,6 +21,7 @@ program main
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" }
@ -30,6 +31,8 @@ program main
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
@ -37,9 +40,14 @@ contains
a3 = a3 + 1
end subroutine increment
subroutine pointer_assignments(p)
integer, pointer :: p ! with [pointer] intent(out)
p => null() ! this is invalid
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

5
gcc/testsuite/gfortran.dg/protected_6.f90
View File

@ -27,6 +27,7 @@ program main
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
@ -34,8 +35,8 @@ contains
a3 = a3 + 1
end subroutine increment
subroutine pointer_assignments(p)
integer, pointer :: p ! with [pointer] intent(out)
p => null() ! this is invalid
integer, pointer,intent (inout) :: p
p => null()
end subroutine pointer_assignments
end program main