From aa271860870b642b35b39938fdb39ff30af70c43 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 27 Jan 2013 07:09:06 +0000 Subject: [PATCH] [multiple changes] 2013-01-27 Paul Thomas PR fortran/55789 PR fortran/56047 * gfortran.h : Add associate_var to symbol_attr. * resolve.c (resolve_assoc_var): Set associate_var attribute. If the target class_ok is set, set it for the associate variable. * check.c (allocatable_check): Associate variables should not have the allocatable attribute even if their symbols do. * class.c (gfc_build_class_symbol): Symbols with associate_var set will always have a good class container. 2013-01-27 Paul Thomas PR fortran/55789 * gfortran.dg/associate_14.f90: New test. PR fortran/56047 * gfortran.dg/associate_13.f90: New test. From-SVN: r195492 --- gcc/fortran/ChangeLog | 13 +++++ gcc/fortran/check.c | 2 +- gcc/fortran/class.c | 2 +- gcc/fortran/gfortran.h | 5 +- gcc/fortran/resolve.c | 7 +++ gcc/testsuite/ChangeLog | 8 ++++ gcc/testsuite/gfortran.dg/associate_13.f90 | 21 ++++++++ gcc/testsuite/gfortran.dg/associate_14.f90 | 56 ++++++++++++++++++++++ 8 files changed, 110 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_13.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_14.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 102f21251e7..38ae004913c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2013-01-27 Paul Thomas + + PR fortran/55789 + PR fortran/56047 + * gfortran.h : Add associate_var to symbol_attr. + * resolve.c (resolve_assoc_var): Set associate_var attribute. + If the target class_ok is set, set it for the associate + variable. + * check.c (allocatable_check): Associate variables should not + have the allocatable attribute even if their symbols do. + * class.c (gfc_build_class_symbol): Symbols with associate_var + set will always have a good class container. + 2013-01-23 Janus Weil PR fortran/56081 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index de1b729c359..8bd06457ff4 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -454,7 +454,7 @@ allocatable_check (gfc_expr *e, int n) symbol_attribute attr; attr = gfc_variable_attr (e, NULL); - if (!attr.allocatable) + if (!attr.allocatable || attr.associate_var) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 9ef30f6d331..d8e7b6ded7a 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -568,7 +568,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, return SUCCESS; attr->class_ok = attr->dummy || attr->pointer || attr->allocatable - || attr->select_type_temporary; + || attr->select_type_temporary || attr->associate_var; if (!attr->class_ok) /* We can not build the class container yet. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ed05c100196..6be507fd676 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -803,8 +803,9 @@ typedef struct private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1, defined_assign_comp:1, unlimited_polymorphic:1; - /* This is a temporary selector for SELECT TYPE. */ - unsigned select_type_temporary:1; + /* This is a temporary selector for SELECT TYPE or an associate + variable for SELECT_TYPE or ASSOCIATE. */ + unsigned select_type_temporary:1, associate_var:1; /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ddb6d67aaf2..f2e6b9dd625 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8325,6 +8325,13 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) has no corank. */ sym->as->corank = 0; } + + /* Mark this as an associate variable. */ + sym->attr.associate_var = 1; + + /* If the target is a good class object, so is the associate variable. */ + if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) + sym->attr.class_ok = 1; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index db9f3679bf8..b2fbe881c94 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2013-01-27 Paul Thomas + + PR fortran/55789 + * gfortran.dg/associate_14.f90: New test. + + PR fortran/56047 + * gfortran.dg/associate_13.f90: New test. + 2013-01-25 Jakub Jelinek PR tree-optimization/56098 diff --git a/gcc/testsuite/gfortran.dg/associate_13.f90 b/gcc/testsuite/gfortran.dg/associate_13.f90 new file mode 100644 index 00000000000..7c64d3f0aa7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_13.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Tests the fix for PR56047. This is actually a development of +! the test case of comment #10. +! +! Reported by Juergen Reuter +! + implicit none + type :: process_variant_def_t + integer :: i + end type + type :: process_component_def_t + class(process_variant_def_t), allocatable :: variant_def + end type + type(process_component_def_t), dimension(1:2) :: initial + allocate (initial(1)%variant_def, source = process_variant_def_t (99)) + associate (template => initial(1)%variant_def) + template%i = 77 + end associate + if (initial(1)%variant_def%i .ne. 77) call abort +end diff --git a/gcc/testsuite/gfortran.dg/associate_14.f90 b/gcc/testsuite/gfortran.dg/associate_14.f90 new file mode 100644 index 00000000000..765e36520c6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_14.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! Tests the fix for PR55984. +! +! Contributed by Sylwester Arabas +! +module bcd_m + type, abstract :: bcd_t + contains + procedure(bcd_fill_halos), deferred :: fill_halos + end type + abstract interface + subroutine bcd_fill_halos(this) + import :: bcd_t + class(bcd_t ) :: this + end subroutine + end interface +end module + +module solver_m + use bcd_m + type, abstract :: solver_t + integer :: n, hlo + class(bcd_t), pointer :: bcx, bcy + contains + procedure(solver_advop), deferred :: advop + end type + abstract interface + subroutine solver_advop(this) + import solver_t + class(solver_t) :: this + end subroutine + end interface + contains +end module + +module solver_mpdata_m + use solver_m + type :: mpdata_t + class(bcd_t), pointer :: bcx, bcy + contains + procedure :: advop => mpdata_advop + end type + contains + subroutine mpdata_advop(this) + class(mpdata_t) :: this + associate ( bcx => this%bcx, bcy => this%bcy ) + call bcx%fill_halos() + end associate + end subroutine +end module + + use solver_mpdata_m + class(mpdata_t), allocatable :: that + call mpdata_advop (that) +end + -- 2.30.2