mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-04 04:50:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/52832 ([F03] ASSOCIATE construct with proc-pointer selector is rejected)

Browse Source 
2017-09-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52832
	* match.c (gfc_match_associate): Before failing the association
	try again, allowing a proc pointer selector.

	PR fortran/80120
	PR fortran/81903
	PR fortran/82121
	* primary.c (gfc_match_varspec): Introduce 'tgt_expr', which
	points to the associate selector, if any. Go through selector
	references, after resolution for variables, to catch any full
	or section array references. If a class associate name does
	not have the same declared type as the selector, resolve the
	selector and copy the declared type to the associate name.
	Before throwing a no implicit type error, resolve all allowed
	selector expressions, and copy the resulting typespec.

	PR fortran/67543
	* resolve.c (resolve_assoc_var): Selector must cannot be the
	NULL expression and it must have a type.

	PR fortran/78152
	* resolve.c (resolve_symbol): Allow associate names to be
	coarrays.

2017-09-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78512
	* gfortran.dg/associate_26.f90 : New test.

	PR fortran/80120
	* gfortran.dg/associate_27.f90 : New test.

	PR fortran/81903
	* gfortran.dg/associate_28.f90 : New test.

	PR fortran/82121
	* gfortran.dg/associate_29.f90 : New test.

	PR fortran/67543
	* gfortran.dg/associate_30.f90 : New test.

	PR fortran/52832
	* gfortran.dg/associate_31.f90 : New test.

From-SVN: r253077
This commit is contained in:
Paul Thomas 2017-09-21 18:40:21 +00:00
parent 2bc668c274
commit b89a63b916
11 changed files with 305 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2017-09-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/52832
* match.c (gfc_match_associate): Before failing the association
try again, allowing a proc pointer selector.
PR fortran/80120
PR fortran/81903
PR fortran/82121
* primary.c (gfc_match_varspec): Introduce 'tgt_expr', which
points to the associate selector, if any. Go through selector
references, after resolution for variables, to catch any full
or section array references. If a class associate name does
not have the same declared type as the selector, resolve the
selector and copy the declared type to the associate name.
Before throwing a no implicit type error, resolve all allowed
selector expressions, and copy the resulting typespec.
PR fortran/67543
* resolve.c (resolve_assoc_var): Selector must cannot be the
NULL expression and it must have a type.
PR fortran/78152
* resolve.c (resolve_symbol): Allow associate names to be
coarrays.
2017-09-21 Cesar Philippidis <cesar@codesourcery.com>
* openmp.c (gfc_match_oacc_wait): Don't restrict wait directive

11
gcc/fortran/match.c
View File

@ -1885,8 +1885,15 @@ gfc_match_associate (void)
if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
!= MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
/* Have another go, allowing for procedure pointer selectors. */
gfc_matching_procptr_assignment = 1;
if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
!= MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
}
gfc_matching_procptr_assignment = 0;
}
newAssoc->where = gfc_current_locus;

67
gcc/fortran/primary.c
View File

@ -1937,6 +1937,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
gfc_ref *substring, *tail, *tmp;
gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym;
gfc_expr *tgt_expr = NULL;
match m;
bool unknown;
char sep;
@ -1965,6 +1966,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
}
}
if (sym->assoc && sym->assoc->target)
tgt_expr = sym->assoc->target;
/* For associate names, we may not yet know whether they are arrays or not.
If the selector expression is unambiguously an array; eg. a full array
or an array section, then the associate name must be an array and we can
@ -1976,26 +1980,43 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
&& sym->ts.type != BT_CLASS
&& !sym->attr.dimension)
{
if ((!sym->assoc->dangling
&& sym->assoc->target
&& sym->assoc->target->ref
&& sym->assoc->target->ref->type == REF_ARRAY
&& (sym->assoc->target->ref->u.ar.type == AR_FULL
|| sym->assoc->target->ref->u.ar.type == AR_SECTION))
||
(!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
&& sym->assoc->st
&& sym->assoc->st->n.sym
&& sym->assoc->st->n.sym->attr.dimension == 0))
gfc_ref *ref = NULL;
if (!sym->assoc->dangling && tgt_expr)
{
sym->attr.dimension = 1;
if (sym->as == NULL && sym->assoc
if (tgt_expr->expr_type == EXPR_VARIABLE)
gfc_resolve_expr (tgt_expr);
ref = tgt_expr->ref;
for (; ref; ref = ref->next)
if (ref->type == REF_ARRAY
&& (ref->u.ar.type == AR_FULL
|| ref->u.ar.type == AR_SECTION))
break;
}
if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
&& sym->assoc->st
&& sym->assoc->st->n.sym
&& sym->assoc->st->n.sym->attr.dimension == 0))
{
sym->attr.dimension = 1;
if (sym->as == NULL
&& sym->assoc->st
&& sym->assoc->st->n.sym
&& sym->assoc->st->n.sym->as)
sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
}
}
else if (sym->ts.type == BT_CLASS
&& tgt_expr
&& tgt_expr->expr_type == EXPR_VARIABLE
&& sym->ts.u.derived != tgt_expr->ts.u.derived)
{
gfc_resolve_expr (tgt_expr);
if (tgt_expr->rank)
sym->ts.u.derived = tgt_expr->ts.u.derived;
}
if ((equiv_flag && gfc_peek_ascii_char () == '(')
|| gfc_peek_ascii_char () == '[' || sym->attr.codimension
@ -2055,14 +2076,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
/* Before throwing an error try resolving the target expression of
associate names. This should resolve function calls, for example. */
/* See if there is a usable typespec in the "no IMPLICIT type" error. */
if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
{
if (sym->assoc && sym->assoc->target)
bool permissible;
/* These target expressions can ge resolved at any time. */
permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
&& (tgt_expr->symtree->n.sym->attr.use_assoc
|| tgt_expr->symtree->n.sym->attr.host_assoc
|| tgt_expr->symtree->n.sym->attr.if_source
== IFSRC_DECL);
permissible = permissible
|| (tgt_expr && tgt_expr->expr_type == EXPR_OP);
if (permissible)
{
gfc_resolve_expr (sym->assoc->target);
sym->ts = sym->assoc->target->ts;
gfc_resolve_expr (tgt_expr);
sym->ts = tgt_expr->ts;
}
if (sym->ts.type == BT_UNKNOWN)

14
gcc/fortran/resolve.c
View File

@ -8396,11 +8396,23 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
sym->attr.subref_array_pointer = 1;
}
if (target->expr_type == EXPR_NULL)
{
gfc_error ("Selector at %L cannot be NULL()", &target->where);
return;
}
else if (target->ts.type == BT_UNKNOWN)
{
gfc_error ("Selector at %L has no type", &target->where);
return;
}
/* Get type if this was not already set. Note that it can be
some other type than the target in case this is a SELECT TYPE
selector! So we must not update when the type is already there. */
if (sym->ts.type == BT_UNKNOWN)
sym->ts = target->ts;
gcc_assert (sym->ts.type != BT_UNKNOWN);
/* See if this is a valid association-to-variable. */
@ -11926,6 +11938,7 @@ deferred_requirements (gfc_symbol *sym)
if (sym->ts.deferred
&& !(sym->attr.pointer
|| sym->attr.allocatable
|| sym->attr.associate_var
|| sym->attr.omp_udr_artificial_var))
{
gfc_error ("Entity %qs at %L has a deferred type parameter and "
@ -14763,6 +14776,7 @@ resolve_symbol (gfc_symbol *sym)
if (class_attr.codimension
&& !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
|| sym->attr.select_type_temporary
|| sym->attr.associate_var
|| (sym->ns->save_all && !sym->attr.automatic)
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program

22
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,23 @@
2017-09-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/78512
* gfortran.dg/associate_26.f90 : New test.
PR fortran/80120
* gfortran.dg/associate_27.f90 : New test.
PR fortran/81903
* gfortran.dg/associate_28.f90 : New test.
PR fortran/82121
* gfortran.dg/associate_29.f90 : New test.
PR fortran/67543
* gfortran.dg/associate_30.f90 : New test.
PR fortran/52832
* gfortran.dg/associate_31.f90 : New test.
2017-09-21 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/discr48.adb: New test.
@ -42,7 +62,7 @@
Jeff Law <law@redhat.com>
* gcc.dg/stack-check-5.c: Add argument for s390.
* lib/target-supports.exp:
* lib/target-supports.exp:
(check_effective_target_supports_stack_clash_protection): Enable for
s390/s390x targets.

15
gcc/testsuite/gfortran.dg/associate_26.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Test the fix for PR78152
!
! Contributed by <physiker@toast2.net>
!
program co_assoc
implicit none
integer, parameter :: p = 5
real, allocatable :: a(:,:)[:,:]
allocate (a(p,p)[2,*])
associate (i => a(1:p, 1:p))
end associate
end program co_assoc

23
gcc/testsuite/gfortran.dg/associate_27.f90 Normal file
View File

@ -0,0 +1,23 @@
! { dg-do run }
!
! Test the fix for PR80120
!
! Contributed by Marco Restelli <mrestelli@gmail.com>
!
program p
implicit none
type :: t
character(len=25) :: text(2)
end type t
type(t) :: x
x%text(1) = "ABC"
x%text(2) = "defgh"
associate( c => x%text )
if (c(1)(:maxval(len_trim(c))) .ne. trim (x%text(1))) call abort
if (c(2)(:maxval(len_trim(c))) .ne. trim (x%text(2))) call abort
end associate
end program p

64
gcc/testsuite/gfortran.dg/associate_28.f90 Normal file
View File

@ -0,0 +1,64 @@
! { dg-do run }
!
! Test the fix for PR81903
!
! Contributed by Karl May <karl.may0@freenet.de>
!
Module TestMod_A
Type :: TestType_A
Real, Allocatable :: a(:,:)
End type TestType_A
End Module TestMod_A
Module TestMod_B
Type :: TestType_B
Real, Pointer, contiguous :: a(:,:)
End type TestType_B
End Module TestMod_B
Module TestMod_C
use TestMod_A
use TestMod_B
Implicit None
Type :: TestType_C
Class(TestType_A), Pointer :: TT_A(:)
Type(TestType_B), Allocatable :: TT_B(:)
contains
Procedure, Pass :: SetPt => SubSetPt
End type TestType_C
Interface
Module Subroutine SubSetPt(this)
class(TestType_C), Intent(InOut), Target :: this
End Subroutine
End Interface
End Module TestMod_C
Submodule(TestMod_C) SetPt
contains
Module Procedure SubSetPt
Implicit None
integer :: i
integer :: sum_a = 0
outer:block
associate(x=>this%TT_B,y=>this%TT_A)
Do i=1,size(x)
x(i)%a=>y(i)%a
sum_a = sum_a + sum (int (x(i)%a))
End Do
end associate
End block outer
if (sum_a .ne. 30) call abort
End Procedure
End Submodule SetPt
Program Test
use TestMod_C
use TestMod_A
Implicit None
Type(TestType_C) :: tb
Type(TestType_A), allocatable, Target :: ta(:)
integer :: i
real :: src(2,2) = reshape ([(real(i), i = 1,4)],[2,2])
allocate(ta(2),tb%tt_b(2))
do i=1,size(ta)
allocate(ta(i)%a(2,2), source = src*real(i))
End do
tb%TT_A=>ta
call tb%setpt()
End Program Test

30
gcc/testsuite/gfortran.dg/associate_29.f90 Normal file
View File

@ -0,0 +1,30 @@
! { dg-do compile }
!
! Test the fix for PR82121
!
! Contributed by Iain Miller <iain.miller@ecmwf.int>
!
MODULE YOMCDDH
IMPLICIT NONE
SAVE
TYPE :: TCDDH
CHARACTER(len=12),ALLOCATABLE :: CADHTLS(:)
END TYPE TCDDH
CHARACTER(len=12),ALLOCATABLE :: CADHTTS(:)
TYPE(TCDDH), POINTER :: YRCDDH => NULL()
END MODULE YOMCDDH
SUBROUTINE SUCDDH()
USE YOMCDDH , ONLY : YRCDDH,CADHTTS
IMPLICIT NONE
ALLOCATE (YRCDDH%CADHTLS(20))
ALLOCATE (CADHTTS(20))
ASSOCIATE(CADHTLS=>YRCDDH%CADHTLS, NORMCHAR=>CADHTTS)
! Direct reference to character array compiled correctly
! YRCDDH%CADHTLS(1)='SVGTLF'
! Reference to associated variable name failed to compile
CADHTLS(2)='SVGTLT'
NORMCHAR(1)='SVLTTC'
END ASSOCIATE
END SUBROUTINE SUCDDH

15
gcc/testsuite/gfortran.dg/associate_30.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do compile }
!
! Test the fix for PR67543
!
! Contributed by Gerhard Steinmetz <gerhard.steinmetz.fortran@t-online.de>
!
subroutine s1
associate (x => null()) ! { dg-error "cannot be NULL()" }
end associate
end subroutine
subroutine s2
associate (x => [null()]) ! { dg-error "has no type" }
end associate
end subroutine

39
gcc/testsuite/gfortran.dg/associate_31.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do run }
!
! Test the fix for PR52832
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
subroutine testSub()
interface
integer function fcn1 (arg)
integer :: arg
end function
integer function fcn2 (arg)
integer :: arg
end function
end interface
procedure(fcn1), pointer :: r
r => fcn2
associate (k => r)
if (r(42) .ne. 84) call abort
end associate
r => fcn1
associate (k => r)
if (r(42) .ne. 42) call abort
end associate
end subroutine testSub
integer function fcn1 (arg)
integer :: arg;
fcn2 = arg
end function
integer function fcn2 (arg)
integer :: arg;
fcn2 = arg*2
end function
call testSub
end