[multiple changes]

2013-01-27 Paul Thomas  <pault@gcc.gnu.org>

	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  <pault@gcc.gnu.org>

	PR fortran/55789
	* gfortran.dg/associate_14.f90: New test.

	PR fortran/56047
	* gfortran.dg/associate_13.f90: New test.

From-SVN: r195492

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 102f21251e7687166559d8edc48b0e82483b857c..38ae004913cf5efe0717d160e5274b14bc641536 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2013-01-27 Paul Thomas  <pault@gcc.gnu.org>
+
+       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  <janus@gcc.gnu.org>
 
        PR fortran/56081

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index de1b729c3596f384e29c421320533138854a56c4..8bd06457ff4878f76ac4df5e57ac9f63c4b3ee9c 100644 (file)
--- 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 9ef30f6d3318abd197b77f41df4911ec81dcfa96..d8e7b6ded7a4e4d0e01133613803c473ea4b80e8 100644 (file)
--- 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 ed05c1001969e48ae716b1a7d1cc921e9c7f5a28..6be507fd676d0eb0c7353cf01e12cf51fcdaba42 100644 (file)
--- 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 ddb6d67aaf26dfa2b6587814d912ce119bada3d3..f2e6b9dd625ca0a4fd8155f4530f1677ba0e4cbb 100644 (file)
--- 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 db9f3679bf89b85b4846bbb10a6daf449c9d03e5..b2fbe881c944537517452777ae098a4c1d4b007e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2013-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+       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  <jakub@redhat.com>
 
        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 (file)
index 0000000..7c64d3f
--- /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  <juergen.reuter@desy.de>
+!
+  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 (file)
index 0000000..765e365
--- /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  <slayoo@staszic.waw.pl>
+!
+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
+