From b89a63b916340ef29aa94710e43dced8b2fcf129 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 21 Sep 2017 18:40:21 +0000 Subject: [PATCH] re PR fortran/52832 ([F03] ASSOCIATE construct with proc-pointer selector is rejected) 2017-09-21 Paul Thomas 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 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 --- gcc/fortran/ChangeLog | 26 ++++++++ gcc/fortran/match.c | 11 +++- gcc/fortran/primary.c | 69 ++++++++++++++++------ gcc/fortran/resolve.c | 14 +++++ gcc/testsuite/ChangeLog | 22 ++++++- gcc/testsuite/gfortran.dg/associate_26.f90 | 15 +++++ gcc/testsuite/gfortran.dg/associate_27.f90 | 23 ++++++++ gcc/testsuite/gfortran.dg/associate_28.f90 | 64 ++++++++++++++++++++ gcc/testsuite/gfortran.dg/associate_29.f90 | 30 ++++++++++ gcc/testsuite/gfortran.dg/associate_30.f90 | 15 +++++ gcc/testsuite/gfortran.dg/associate_31.f90 | 39 ++++++++++++ 11 files changed, 306 insertions(+), 22 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_26.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_27.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_28.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_29.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_30.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_31.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4dac286aaeb..32d3b217a98 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,29 @@ +2017-09-21 Paul Thomas + + 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 * openmp.c (gfc_match_oacc_wait): Don't restrict wait directive diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 6e9125f9a71..4d657e0bc34 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 21e5be2b40a..8537d9305d5 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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)) - { - sym->attr.dimension = 1; - if (sym->as == NULL && sym->assoc + gfc_ref *ref = NULL; + + if (!sym->assoc->dangling && tgt_expr) + { + 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) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 89dea5f7ae2..a3a62deb6d1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ce407c667b5..7b4805218c0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,23 @@ +2017-09-21 Paul Thomas + + 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 * gnat.dg/discr48.adb: New test. @@ -42,7 +62,7 @@ Jeff Law * 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. diff --git a/gcc/testsuite/gfortran.dg/associate_26.f90 b/gcc/testsuite/gfortran.dg/associate_26.f90 new file mode 100644 index 00000000000..ae19acaf777 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_26.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Test the fix for PR78152 +! +! Contributed by +! +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 diff --git a/gcc/testsuite/gfortran.dg/associate_27.f90 b/gcc/testsuite/gfortran.dg/associate_27.f90 new file mode 100644 index 00000000000..6fcb8a990fd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_27.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Test the fix for PR80120 +! +! Contributed by Marco Restelli +! +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 diff --git a/gcc/testsuite/gfortran.dg/associate_28.f90 b/gcc/testsuite/gfortran.dg/associate_28.f90 new file mode 100644 index 00000000000..8715472799e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_28.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! Test the fix for PR81903 +! +! Contributed by Karl May +! +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 diff --git a/gcc/testsuite/gfortran.dg/associate_29.f90 b/gcc/testsuite/gfortran.dg/associate_29.f90 new file mode 100644 index 00000000000..786e3c52e8b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_29.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! Test the fix for PR82121 +! +! Contributed by Iain Miller +! +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 diff --git a/gcc/testsuite/gfortran.dg/associate_30.f90 b/gcc/testsuite/gfortran.dg/associate_30.f90 new file mode 100644 index 00000000000..ad15d8bf576 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_30.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Test the fix for PR67543 +! +! Contributed by Gerhard Steinmetz +! + 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 diff --git a/gcc/testsuite/gfortran.dg/associate_31.f90 b/gcc/testsuite/gfortran.dg/associate_31.f90 new file mode 100644 index 00000000000..aa0b44c5ad6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_31.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR52832 +! +! Contributed by Tobias Burnus +! + 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 -- 2.30.2