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
+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
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;
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;
}
}
+ 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
&& 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
&& 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)
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. */
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 "
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
+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.
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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff