Patchwork [fortran] PR41600 - [OOP] SELECT TYPE with associate-name => exp: Arrays not supported

login
register
mail settings
Submitter Paul Richard Thomas
Date May 1, 2012, 9:10 p.m.
Message ID <CAGkQGi+e07=mdhL5jDFA4aQTi916YuSY5fdH2dFcZ6Yw3jDqww@mail.gmail.com>
Download mbox | patch
Permalink /patch/156240/
State New
Headers show

Comments

Paul Richard Thomas - May 1, 2012, 9:10 p.m.
Dear Tobias, dear all,

Please accept my apologies for the long delay in responding to the
review.  A combination of overwhelming daytime works and a complete
failure of my workstation at home have knocked me out for the last six
weeks.

Find attached a revised patch to fix PR 41600.

On Sun, Mar 18, 2012 at 11:16 PM, Tobias Burnus <burnus@net-b.de> wrote:
> Dear Paul,
>
> thanks for the patch.
>
> Paul Richard Thomas wrote:
>>
>> + /* Transfer the selector typespec to the associate name.  */
>> +
>> + copy_ts_from_selector_to_associate (gfc_expr *expr1, gfc_expr *expr2)
>> + {
>
>  I think it is not obvious which type spec is which. Maybe you could add a
> "(expr1)" and "(expr2)"  in the comment. (Alternatively, one could rename
> expr1 and expr2.)

Done - expr1 and expr2 are re
>
>> +   if (expr2->ts.type == BT_CLASS
>> +       &&  CLASS_DATA (expr2)->as
>> +       &&  expr2->ref&&  expr2->ref->type == REF_ARRAY)
>> +     {
>> +       if (expr2->ref->u.ar.type == AR_FULL)
>> +       expr2->rank = CLASS_DATA (expr2)->as->rank;
>> +       else if (expr2->ref->u.ar.type == AR_SECTION)
>> +       expr2->rank = expr2->ref->u.ar.dimen;
>> +     }
>
>
> I have a bad feeling about that one for code like:
>  dt%class(1:2)
>  class%class(1:2)
>  dt(1:2)%class
>  class(1:2)%class
> I fear that at least one of those will fail. In any case, assuming that - if
> the last ref is BT_CLASS - the expr->ref is the right one, looks wrong. But
> I might have missed some fine print and it is guaranteed to be always the
> correct.

This has been improved to ensure that the references are correctly treated.

Note that array_ref%class is now excluded, except for scalars; see
select_type_28.f03
Select_type_27.f03 deals with class%array_ref

>

>> +   /* Logic is a LOT clearer with separate functions for class and
>> derived
>> +      type temporaries! There are not many more lines of code either.  */
>>     if (ts->type == BT_CLASS)
>> !     tmp = select_class_set_tmp (ts);
>> !   else
>> !     tmp = select_derived_set_tmp (ts);
>
>
> While I concur with the comment, I think one should remove it. As patch
> explanation it makes sense, but as committed it is not helpful.

Done

>
>>     gfc_add_type (tmp->n.sym, ts, NULL);
>>
>> ! /* Copy across the array spec to the selector, taking care as to
>> !    whether or not it is a class object or not.  */
>
>
> The indention looks wrong.

FIxed

>
>
>> (iii) The error that is thrown in resolve_assoc_var is necessary
>> because wrong code is produced at the moment since the size of the
>> declared type, rather than the dynamic type, is used for allocation of
>> the temporary.  The necessary machinery is in place to fix this and I
>> will do so soon
>
>
> I assume that's:
>>
>> !       gfc_error ("CLASS selector at %L needs a temporary which is not "
>> !                "yet implemented",&target->where);
>
>
> But I think one should also look into:
>>
>> !      TODO Understand why class scalar expressions must be excluded.  */
>> !   if (sym->assoc&&  !(sym->ts.type == BT_CLASS&&  e->rank == 0))

I still do not see this but undertake to fix/understand.

>
>
> Overall, the patch looks okay - I am just unsure about the expr2->ref usage
> in copy_ts_from_selector_to_associate.

Thanks for the review - I hope that the new version is satisfactory.

Cheers

Paul

See above.
2012-05-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* trans-array.c (build_array_ref): New static function.
	(gfc_conv_array_ref, gfc_get_dataptr_offset): Call it.
	* trans-expr.c (gfc_get_vptr_from_expr): New function.
	(gfc_conv_derived_to_class): Add a new argument for a caller
	supplied vptr and use it if it is not NULL.
	(gfc_conv_procedure_call): Add NULL to call to above.
	symbol.c (gfc_is_associate_pointer): Return true if symbol is
	a class object.
	* trans-stmt.c (trans_associate_var): Handle class associate-
	names.
	* expr.c (gfc_get_variable_expr): Supply the array-spec if
	possible.
	* trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P
	for class types.
	* trans.h : Add prototypes for gfc_get_vptr_from_expr and
	gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P.
	* resolve.c (resolve_variable): For class arrays, ensure that
	the target expression has all the necessary _data references.
	(resolve_assoc_var): Throw a "not yet implemented" error for
	class array selectors that need a temporary.
	* match.c (copy_ts_from_selector_to_associate,
	select_derived_set_tmp, select_class_set_tmp): New functions.
	(select_type_set_tmp): Call one of last two new functions.
	(gfc_match_select_type): Copy_ts_from_selector_to_associate is
	called if associate-name is typed.

2012-05-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* gfortran.dg/select_type_26.f03 : New test.
	* gfortran.dg/select_type_27.f03 : New test.
	* gfortran.dg/select_type_28.f03 : New test.
Tobias Burnus - May 2, 2012, 5:34 a.m.
Dear Paul,

Paul Richard Thomas wrote:
> Find attached a revised patch to fix PR 41600.

Thanks for the patch. I think it is OK.

Regarding:

> !       if (ref&&  ref->type != REF_ARRAY&&  seen_array)
> ! 	{
> ! 	  gfc_error ("CLASS selector at %L is an array with CLASS "
> ! 		     "components; this is not allowed since the "
> ! 		     "elements could have different dynamic types",
> ! 		&target->where);

Could you open a PR for it? If possible with a test case.

Tobias
Paul Richard Thomas - May 2, 2012, 7:50 a.m.
Dear Tobias,

Thanks for completing the review.  I should be able to commit tonight.

> Thanks for the patch. I think it is OK.
>
> Regarding:
>
>> !       if (ref&&  ref->type != REF_ARRAY&&  seen_array)
>> !       {
>> !         gfc_error ("CLASS selector at %L is an array with CLASS "
>> !                    "components; this is not allowed since the "
>> !                    "elements could have different dynamic types",
>> !               &target->where);
>
>
> Could you open a PR for it? If possible with a test case.

select_type_28.f03 is that testcase (see below).  I am not sure what
the PR would be for - surely such selectors make no logical sense?
Oddly I can see no such restriction in the standard. Indeed, there
seems to me to be an identical diffculty with pointer assignment.
Maybe a message to clf would be in order?

Cheers

Paul

Cheers

Paul

  implicit none
  type t0
    integer :: j = 42
  end type t0
  type, extends(t0) :: t1
    integer :: k = 99
  end type t1
  type t
    integer :: i
    class(t0), allocatable :: foo
  end type t
  type(t) :: m(4)
  integer :: n

  do n = 1, 2
    allocate(m(n)%foo, source = t0(n*99))
  end do
  do n = 3, 4
    allocate(m(n)%foo, source = t1(n*99, n*999))
  end do

! The class components 'foo' of m(1:2) now have a different dynamic
type to those of m(3:4)

! An array of objects with ultimate class components cannot be a selector
! since each element could have a different dynamic type.

  select type(bar => m%foo) ! { dg-error "is an array with CLASS components" }
    type is(t0)
      if (any (bar%j .ne. [99, 198, 297, 396])) call abort
    type is(t1)
      call abort
  end select

end

Patch

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 186918)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_vtable_copy_get (tree decl)
*** 147,157 ****
  #undef VTABLE_COPY_FIELD
  
  
  /* Takes a derived type expression and returns the address of a temporary
!    class object of the 'declared' type.  */ 
! static void
  gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
! 			   gfc_typespec class_ts)
  {
    gfc_symbol *vtab;
    gfc_ss *ss;
--- 147,171 ----
  #undef VTABLE_COPY_FIELD
  
  
+ /* Obtain the vptr of the last class reference in an expression.  */
+ 
+ tree
+ gfc_get_vptr_from_expr (tree expr)
+ {
+   tree tmp = expr;
+   while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+     tmp = TREE_OPERAND (tmp, 0);
+   tmp = gfc_class_vptr_get (tmp);
+   return tmp;
+ }
+  
+ 
  /* Takes a derived type expression and returns the address of a temporary
!    class object of the 'declared' type.  If vptr is not NULL, this is
!    used for the temporary class object.  */ 
! void
  gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
! 			   gfc_typespec class_ts, tree vptr)
  {
    gfc_symbol *vtab;
    gfc_ss *ss;
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 167,177 ****
    /* Set the vptr.  */
    ctree =  gfc_class_vptr_get (var);
  
!   /* Remember the vtab corresponds to the derived type
!      not to the class declared type.  */
!   vtab = gfc_find_derived_vtab (e->ts.u.derived);
!   gcc_assert (vtab);
!   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
    gfc_add_modify (&parmse->pre, ctree,
  		  fold_convert (TREE_TYPE (ctree), tmp));
  
--- 181,199 ----
    /* Set the vptr.  */
    ctree =  gfc_class_vptr_get (var);
  
!   if (vptr != NULL_TREE)
!     {
!       /* Use the dynamic vptr.  */
!       tmp = vptr;
!     }
!   else
!     {
!       /* In this case the vtab corresponds to the derived type and the
! 	 vptr must point to it.  */
!       vtab = gfc_find_derived_vtab (e->ts.u.derived);
!       gcc_assert (vtab);
!       tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
!     }
    gfc_add_modify (&parmse->pre, ctree,
  		  fold_convert (TREE_TYPE (ctree), tmp));
  
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3531,3537 ****
  	  /* The derived type needs to be converted to a temporary
  	     CLASS object.  */
  	  gfc_init_se (&parmse, se);
! 	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
  	}
        else if (se->ss && se->ss->info->useflags)
  	{
--- 3553,3559 ----
  	  /* The derived type needs to be converted to a temporary
  	     CLASS object.  */
  	  gfc_init_se (&parmse, se);
! 	  gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
  	}
        else if (se->ss && se->ss->info->useflags)
  	{
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 186918)
--- gcc/fortran/trans-array.c	(working copy)
*************** add_to_offset (tree *cst_offset, tree *o
*** 3068,3073 ****
--- 3068,3103 ----
      }
  }
  
+ 
+ static tree
+ build_array_ref (tree desc, tree offset, tree decl)
+ {
+   tree tmp;
+ 
+   /* Class array references need special treatment because the assigned
+      type size needs to be used to point to the element.  */ 
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ 	&& TREE_CODE (desc) == COMPONENT_REF
+ 	&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+     {
+       tree type = gfc_get_element_type (TREE_TYPE (desc));
+       tmp = TREE_OPERAND (desc, 0);
+       tmp = gfc_get_class_array_ref (offset, tmp);
+       tmp = fold_convert (build_pointer_type (type), tmp);
+       tmp = build_fold_indirect_ref_loc (input_location, tmp);
+     }
+   else
+     {
+       tmp = gfc_conv_array_data (desc);
+       tmp = build_fold_indirect_ref_loc (input_location, tmp);
+       tmp = gfc_build_array_ref (tmp, offset, decl);
+     }
+ 
+   return tmp;
+ }
+ 
+ 
+ 
  /* Build an array reference.  se->expr already holds the array descriptor.
     This should be either a variable, indirect variable reference or component
     reference.  For arrays which do not have a descriptor, se->expr will be
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3195,3204 ****
      offset = fold_build2_loc (input_location, PLUS_EXPR,
  			      gfc_array_index_type, offset, cst_offset);
  
!   /* Access the calculated element.  */
!   tmp = gfc_conv_array_data (se->expr);
!   tmp = build_fold_indirect_ref (tmp);
!   se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
  }
  
  
--- 3225,3231 ----
      offset = fold_build2_loc (input_location, PLUS_EXPR,
  			      gfc_array_index_type, offset, cst_offset);
  
!   se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
  }
  
  
*************** gfc_get_dataptr_offset (stmtblock_t *blo
*** 6010,6019 ****
  	return;
      }
  
!   tmp = gfc_conv_array_data (desc);
!   tmp = build_fold_indirect_ref_loc (input_location,
! 				 tmp);
!   tmp = gfc_build_array_ref (tmp, offset, NULL);
  
    /* Offset the data pointer for pointer assignments from arrays with
       subreferences; e.g. my_integer => my_type(:)%integer_component.  */
--- 6037,6043 ----
  	return;
      }
  
!   tmp = build_array_ref (desc, offset, NULL);
  
    /* Offset the data pointer for pointer assignments from arrays with
       subreferences; e.g. my_integer => my_type(:)%integer_component.  */
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 186918)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_is_associate_pointer (gfc_symbol* sy
*** 4882,4887 ****
--- 4882,4890 ----
    if (!sym->assoc)
      return false;
  
+   if (sym->ts.type == BT_CLASS)
+     return true;
+ 
    if (!sym->assoc->variable)
      return false;
  
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 186918)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1140,1145 ****
--- 1140,1149 ----
    gfc_expr *e;
    tree tmp;
    bool class_target;
+   tree desc;
+   tree offset;
+   tree dim;
+   int n;
  
    gcc_assert (sym->assoc);
    e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1191,1198 ****
  			    gfc_finish_block (&se.post));
      }
  
!   /* CLASS arrays just need the descriptor to be directly assigned.  */
!   else if (class_target && sym->attr.dimension)
      {
        gfc_se se;
  
--- 1195,1203 ----
  			    gfc_finish_block (&se.post));
      }
  
!   /* Derived type temporaries, arising from TYPE IS, just need the
!      descriptor of class arrays to be assigned directly.  */
!   else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension)
      {
        gfc_se se;
  
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1217,1223 ****
        gcc_assert (!sym->attr.dimension);
  
        gfc_init_se (&se, NULL);
!       gfc_conv_expr (&se, e);
  
        tmp = TREE_TYPE (sym->backend_decl);
        tmp = gfc_build_addr_expr (tmp, se.expr);
--- 1222,1268 ----
        gcc_assert (!sym->attr.dimension);
  
        gfc_init_se (&se, NULL);
! 
!       /* Class associate-names come this way because they are
! 	 unconditionally associate pointers and the symbol is scalar.  */
!       if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
! 	{
! 	  /* For a class array we need a descriptor for the selector.  */
! 	  gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e));
! 
! 	  /* Obtain a temporary class container for the result.  */ 
! 	  gfc_conv_class_to_class (&se, e, sym->ts, false);
! 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
! 
! 	  /* Set the offset.  */
! 	  desc = gfc_class_data_get (se.expr);
! 	  offset = gfc_index_zero_node;
! 	  for (n = 0; n < e->rank; n++)
! 	    {
! 	      dim = gfc_rank_cst[n];
! 	      tmp = fold_build2_loc (input_location, MULT_EXPR,
! 				     gfc_array_index_type,
! 				     gfc_conv_descriptor_stride_get (desc, dim),
! 				     gfc_conv_descriptor_lbound_get (desc, dim));
! 	      offset = fold_build2_loc (input_location, MINUS_EXPR,
! 				        gfc_array_index_type,
! 				        offset, tmp);
! 	    }
! 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
! 	}
!       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
! 	       && CLASS_DATA (e)->attr.dimension)
! 	{
! 	  /* This is bound to be a class array element.  */
! 	  gfc_conv_expr_reference (&se, e);
! 	  /* Get the _vptr component of the class object.  */ 
! 	  tmp = gfc_get_vptr_from_expr (se.expr);
! 	  /* Obtain a temporary class container for the result.  */
! 	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
! 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
! 	}
!       else
! 	gfc_conv_expr (&se, e);
  
        tmp = TREE_TYPE (sym->backend_decl);
        tmp = gfc_build_addr_expr (tmp, se.expr);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 186918)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_get_variable_expr (gfc_symtree *var)
*** 3821,3826 ****
--- 3821,3829 ----
        e->ref = gfc_get_ref ();
        e->ref->type = REF_ARRAY;
        e->ref->u.ar.type = AR_FULL;
+       e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
+ 					     ? CLASS_DATA (var->n.sym)->as
+ 					     : var->n.sym->as);
      }
  
    return e;
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c	(revision 186918)
--- gcc/fortran/trans-types.c	(working copy)
*************** gfc_typenode_for_spec (gfc_typespec * sp
*** 1106,1111 ****
--- 1106,1114 ----
      case BT_CLASS:
        basetype = gfc_get_derived_type (spec->u.derived);
  
+       if (spec->type == BT_CLASS)
+ 	GFC_CLASS_TYPE_P (basetype) = 1;
+ 
        /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
           type and kind to fit a (void *) and the basetype returned was a
           ptr_type_node.  We need to pass up this new information to the
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 186918)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_vtable_size_get (tree);
*** 348,355 ****
--- 348,357 ----
  tree gfc_vtable_extends_get (tree);
  tree gfc_vtable_def_init_get (tree);
  tree gfc_vtable_copy_get (tree);
+ tree gfc_get_vptr_from_expr (tree);
  tree gfc_get_class_array_ref (tree, tree);
  tree gfc_copy_class_to_class (tree, tree, tree);
+ void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
  void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
  
  /* Initialize an init/cleanup block.  */
*************** struct GTY((variable_size)) lang_decl {
*** 827,832 ****
--- 829,836 ----
  #define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
  /* Fortran POINTER type.  */
  #define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
+ /* Fortran CLASS type.  */
+ #define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
  /* The GFC_TYPE_ARRAY_* members are present in both descriptor and
     descriptorless array types.  */
  #define GFC_TYPE_ARRAY_LBOUND(node, dim) \
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 186918)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_variable (gfc_expr *e)
*** 5081,5089 ****
      }
  
    /* If this is an associate-name, it may be parsed with an array reference
!      in error even though the target is scalar.  Fail directly in this case.  */
!   if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
!     return FAILURE;
  
    if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
      sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
--- 5081,5095 ----
      }
  
    /* If this is an associate-name, it may be parsed with an array reference
!      in error even though the target is scalar.  Fail directly in this case.
!      TODO Understand why class scalar expressions must be excluded.  */
!   if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
!     {
!       if (sym->ts.type == BT_CLASS)
! 	gfc_fix_class_refs (e);
!       if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
! 	return FAILURE;
!     }
  
    if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
      sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
*************** gfc_type_is_extensible (gfc_symbol *sym)
*** 7928,7934 ****
  }
  
  
! /* Resolve an associate name:  Resolve target and ensure the type-spec is
     correct as well as possibly the array-spec.  */
  
  static void
--- 7934,7940 ----
  }
  
  
! /* Resolve an associate-name:  Resolve target and ensure the type-spec is
     correct as well as possibly the array-spec.  */
  
  static void
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 7984,7991 ****
        sym->attr.dimension = 0;
        return;
      }
!   if (target->rank > 0)
      sym->attr.dimension = 1;
  
    if (sym->attr.dimension)
      {
--- 7990,8037 ----
        sym->attr.dimension = 0;
        return;
      }
! 
!   /* We cannot deal with class selectors that need temporaries.  */
!   if (target->ts.type == BT_CLASS
! 	&& gfc_ref_needs_temporary_p (target->ref))
!     {
!       gfc_error ("CLASS selector at %L needs a temporary which is not "
! 		 "yet implemented", &target->where);
!       return;
!     }
! 
!   if (target->ts.type == BT_CLASS)
!     {
!       gfc_ref *ref;
!       bool seen_array = false;
!       for (ref = target->ref; ref; ref = ref->next)
! 	{
! 	  if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
! 	    seen_array = true;
! 
! 	  if (!ref->next)
! 	    break;
! 	}
! 
!       if (ref && ref->type != REF_ARRAY && seen_array)
! 	{
! 	  gfc_error ("CLASS selector at %L is an array with CLASS "
! 		     "components; this is not allowed since the "
! 		     "elements could have different dynamic types",
! 		     &target->where);
! 	  return;
! 	}
!     }
! 
!   if (target->ts.type != BT_CLASS && target->rank > 0)
      sym->attr.dimension = 1;
+   else if (target->ts.type == BT_CLASS)
+     gfc_fix_class_refs (target);
+ 
+   /* The associate-name will have a correct type by now. Make absolutely
+      sure that it has not picked up a dimension attribute.  */
+   if (sym->ts.type == BT_CLASS)
+     sym->attr.dimension = 0;
  
    if (sym->attr.dimension)
      {
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 186918)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_select (void)
*** 5112,5117 ****
--- 5112,5189 ----
  }
  
  
+ /* Transfer the selector typespec to the associate name.  */
+ 
+ static void
+ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+ {
+   gfc_ref *ref;
+   gfc_symbol *assoc_sym;
+ 
+   assoc_sym = associate->symtree->n.sym;
+ 
+   /* Ensure that any array reference is resolved.  */
+   gfc_resolve_expr (selector);
+ 
+   /* At this stage the expression rank and arrayspec dimensions have
+      not been completely sorted out. We must get the expr2->rank
+      right here, so that the correct class container is obtained.  */
+   ref = selector->ref;
+   while (ref && ref->next)
+     ref = ref->next;
+ 
+   if (selector->ts.type == BT_CLASS
+ 	&& CLASS_DATA (selector)->as
+ 	&& ref && ref->type == REF_ARRAY)
+     {
+       if (ref->u.ar.type == AR_FULL)
+ 	selector->rank = CLASS_DATA (selector)->as->rank;
+       else if (ref->u.ar.type == AR_SECTION)
+ 	selector->rank = ref->u.ar.dimen;
+       else
+ 	selector->rank = 0;
+     }
+ 
+   if (selector->ts.type != BT_CLASS)
+     {
+       /* The correct class container has to be available.  */
+       if (selector->rank)
+ 	{
+ 	  assoc_sym->attr.dimension = 1;
+ 	  assoc_sym->as = gfc_get_array_spec ();
+ 	  assoc_sym->as->rank = selector->rank;
+ 	  assoc_sym->as->type = AS_DEFERRED;
+ 	}
+       else
+ 	assoc_sym->as = NULL;
+ 
+       assoc_sym->ts.type = BT_CLASS;
+       assoc_sym->ts.u.derived = selector->ts.u.derived;
+       assoc_sym->attr.pointer = 1;
+       gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
+ 			      &assoc_sym->as, false);
+     }
+   else
+     {
+       /* The correct class container has to be available.  */
+       if (selector->rank)
+ 	{
+ 	  assoc_sym->attr.dimension = 1;
+ 	  assoc_sym->as = gfc_get_array_spec ();
+ 	  assoc_sym->as->rank = selector->rank;
+ 	  assoc_sym->as->type = AS_DEFERRED;
+ 	}
+       else
+ 	assoc_sym->as = NULL;
+       assoc_sym->ts.type = BT_CLASS;
+       assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
+       assoc_sym->attr.pointer = 1;
+       gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
+ 			      &assoc_sym->as, false);
+     }
+ }
+ 
+ 
  /* Push the current selector onto the SELECT TYPE stack.  */
  
  static void
*************** select_type_push (gfc_symbol *sel)
*** 5126,5189 ****
  }
  
  
! /* Set the temporary for the current SELECT TYPE selector.  */
  
! static void
! select_type_set_tmp (gfc_typespec *ts)
  {
    char name[GFC_MAX_SYMBOL_LEN];
    gfc_symtree *tmp;
    
!   if (!ts)
      {
!       select_type_stack->tmp = NULL;
!       return;
      }
    
!   if (!gfc_type_is_extensible (ts->u.derived))
!     return;
  
!   if (ts->type == BT_CLASS)
!     sprintf (name, "__tmp_class_%s", ts->u.derived->name);
!   else
!     sprintf (name, "__tmp_type_%s", ts->u.derived->name);
    gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
    gfc_add_type (tmp->n.sym, ts, NULL);
  
! /* Copy across the array spec to the selector, taking care as to
!    whether or not it is a class object or not.  */
    if (select_type_stack->selector->ts.type == BT_CLASS
-       && select_type_stack->selector->attr.class_ok
        && (CLASS_DATA (select_type_stack->selector)->attr.dimension
  	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
      {
!       if (ts->type == BT_CLASS)
! 	{
! 	  CLASS_DATA (tmp->n.sym)->attr.dimension
  		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
! 	  CLASS_DATA (tmp->n.sym)->attr.codimension
  		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
! 	  CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
! 	  CLASS_DATA (tmp->n.sym)->as
! 			= CLASS_DATA (select_type_stack->selector)->as;
! 	}
!       else
! 	{
! 	  tmp->n.sym->attr.dimension
! 		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
! 	  tmp->n.sym->attr.codimension
! 		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
! 	  tmp->n.sym->as = gfc_get_array_spec ();
! 	  tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
! 	}
      }
  
    gfc_set_sym_referenced (tmp->n.sym);
    gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
    tmp->n.sym->attr.select_type_temporary = 1;
    if (ts->type == BT_CLASS)
!     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
! 			    &tmp->n.sym->as, false);
  
    /* Add an association for it, so the rest of the parser knows it is
       an associate-name.  The target will be set during resolution.  */
--- 5198,5300 ----
  }
  
  
! /* Set the temporary for the current derived type SELECT TYPE selector.  */
  
! static gfc_symtree *
! select_derived_set_tmp (gfc_typespec *ts)
  {
    char name[GFC_MAX_SYMBOL_LEN];
    gfc_symtree *tmp;
    
!   sprintf (name, "__tmp_type_%s", ts->u.derived->name);
!   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
!   gfc_add_type (tmp->n.sym, ts, NULL);
! 
!   /* Copy across the array spec to the selector.  */
!   if (select_type_stack->selector->ts.type == BT_CLASS
!       && select_type_stack->selector->attr.class_ok
!       && (CLASS_DATA (select_type_stack->selector)->attr.dimension
! 	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
      {
!       tmp->n.sym->attr.dimension
! 		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
!       tmp->n.sym->attr.codimension
! 		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
!       tmp->n.sym->as
! 	= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
      }
+ 
+   gfc_set_sym_referenced (tmp->n.sym);
+   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+   tmp->n.sym->attr.select_type_temporary = 1;
+ 
+   return tmp;
+ }
+ 
+ 
+ /* Set the temporary for the current class SELECT TYPE selector.  */
+ 
+ static gfc_symtree *
+ select_class_set_tmp (gfc_typespec *ts)
+ {
+   char name[GFC_MAX_SYMBOL_LEN];
+   gfc_symtree *tmp;
    
!   if (select_type_stack->selector->ts.type == BT_CLASS
!       && !select_type_stack->selector->attr.class_ok)
!     return NULL;
  
!   sprintf (name, "__tmp_class_%s", ts->u.derived->name);
    gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
    gfc_add_type (tmp->n.sym, ts, NULL);
  
! /* Copy across the array spec to the selector.  */
    if (select_type_stack->selector->ts.type == BT_CLASS
        && (CLASS_DATA (select_type_stack->selector)->attr.dimension
  	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
      {
!       tmp->n.sym->attr.pointer = 1;
!       tmp->n.sym->attr.dimension
  		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
!       tmp->n.sym->attr.codimension
  		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
!       tmp->n.sym->as
! 	= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
      }
  
    gfc_set_sym_referenced (tmp->n.sym);
    gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
    tmp->n.sym->attr.select_type_temporary = 1;
+   gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+ 			  &tmp->n.sym->as, false);
+ 
+   return tmp;
+ }
+ 
+ 
+ static void
+ select_type_set_tmp (gfc_typespec *ts)
+ {
+   gfc_symtree *tmp;
+ 
+   if (!ts)
+     {
+       select_type_stack->tmp = NULL;
+       return;
+     }
+   
+   if (!gfc_type_is_extensible (ts->u.derived))
+     return;
+ 
+   /* Logic is a LOT clearer with separate functions for class and derived
+      type temporaries! There are not many more lines of code either.  */
    if (ts->type == BT_CLASS)
!     tmp = select_class_set_tmp (ts);
!   else
!     tmp = select_derived_set_tmp (ts);
! 
!   if (tmp == NULL)
!     return;
  
    /* Add an association for it, so the rest of the parser knows it is
       an associate-name.  The target will be set during resolution.  */
*************** select_type_set_tmp (gfc_typespec *ts)
*** 5194,5200 ****
    select_type_stack->tmp = tmp;
  }
  
! 
  /* Match a SELECT TYPE statement.  */
  
  match
--- 5305,5311 ----
    select_type_stack->tmp = tmp;
  }
  
!   
  /* Match a SELECT TYPE statement.  */
  
  match
*************** gfc_match_select_type (void)
*** 5204,5209 ****
--- 5315,5321 ----
    match m;
    char name[GFC_MAX_SYMBOL_LEN];
    bool class_array;
+   gfc_symbol *sym;
  
    m = gfc_match_label ();
    if (m == MATCH_ERROR)
*************** gfc_match_select_type (void)
*** 5225,5237 ****
  	  m = MATCH_ERROR;
  	  goto cleanup;
  	}
        if (expr2->ts.type == BT_UNKNOWN)
! 	expr1->symtree->n.sym->attr.untyped = 1;
        else
! 	expr1->symtree->n.sym->ts = expr2->ts;
!       expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
!       expr1->symtree->n.sym->attr.referenced = 1;
!       expr1->symtree->n.sym->attr.class_ok = 1;
      }
    else
      {
--- 5337,5352 ----
  	  m = MATCH_ERROR;
  	  goto cleanup;
  	}
+ 
+       sym = expr1->symtree->n.sym;
        if (expr2->ts.type == BT_UNKNOWN)
! 	sym->attr.untyped = 1;
        else
! 	copy_ts_from_selector_to_associate (expr1, expr2);
! 
!       sym->attr.flavor = FL_VARIABLE;
!       sym->attr.referenced = 1;
!       sym->attr.class_ok = 1;
      }
    else
      {
Index: gcc/testsuite/gfortran.dg/select_type_26.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_26.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/select_type_26.f03	(revision 0)
***************
*** 0 ****
--- 1,109 ----
+ ! { dg-do run }
+ ! Tests fix for PR41600 and further SELECT TYPE functionality.
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+   implicit none
+   type t0
+     integer :: j = 42
+   end type t0
+ 
+   type, extends(t0) :: t1
+     integer :: k = 99
+   end type t1
+ 
+   type t
+     integer :: i
+     class(t0), allocatable :: foo(:)
+   end type t
+ 
+   type t_scalar
+     integer :: i
+     class(t0), allocatable :: foo
+   end type t_scalar
+ 
+   type(t) :: m
+   type(t_scalar) :: m1(4)
+   integer :: n
+ 
+ ! Test the fix for PR41600 itself - first with m%foo of declared type.
+   allocate(m%foo(3), source = [(t0(n), n = 1,3)])
+   select type(bar => m%foo)
+     type is(t0)
+       if (any (bar%j .ne. [1,2,3])) call abort
+     type is(t1)
+       call abort
+   end select
+ 
+   deallocate(m%foo)
+   allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
+ 
+ ! Then with m%foo of another dynamic type.
+   select type(bar => m%foo)
+     type is(t0)
+       call abort
+     type is(t1)
+       if (any (bar%k .ne. [40,50,60])) call abort
+   end select
+ 
+ ! Try it with a selector array section.
+   select type(bar => m%foo(2:3))
+     type is(t0)
+       call abort
+     type is(t1)
+       if (any (bar%k .ne. [50,60])) call abort
+   end select
+ 
+ ! Try it with a selector array element.
+   select type(bar => m%foo(2))
+     type is(t0)
+       call abort
+     type is(t1)
+       if (bar%k .ne. 50) call abort
+   end select
+ 
+ ! Now try class is and a selector which is an array section of an associate name.
+   select type(bar => m%foo)
+     type is(t0)
+       call abort
+     class is (t1)
+       if (any (bar%j .ne. [4,5,6])) call abort
+       select type (foobar => bar(3:2:-1))
+         type is (t1)
+           if (any (foobar%k .ne. [60,50])) call abort
+         end select
+   end select
+ 
+ ! Now try class is and a selector which is an array element of an associate name.
+   select type(bar => m%foo)
+     type is(t0)
+       call abort
+     class is (t1)
+       if (any (bar%j .ne. [4,5,6])) call abort
+       select type (foobar => bar(2))
+         type is (t1)
+           if (foobar%k .ne. 50) call abort
+         end select
+   end select
+ 
+ ! Check class a component of an element of an array. Note that an array of such
+ ! objects cannot be allowed since the elements could have different dynamic types.
+   do n = 1, 2
+     allocate(m1(n)%foo, source = t1(n*99, n*999))
+   end do
+   do n = 3, 4
+     allocate(m1(n)%foo, source = t0(n*99))
+   end do
+   select type(bar => m1(3)%foo)
+     type is(t0)
+       if (bar%j .ne. 297) call abort
+     type is(t1)
+       call abort
+   end select
+   select type(bar => m1(1)%foo)
+     type is(t0)
+       call abort
+     type is(t1)
+       if (bar%k .ne. 999) call abort
+   end select
+ end
Index: gcc/testsuite/gfortran.dg/select_type_27.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_27.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/select_type_27.f03	(revision 0)
***************
*** 0 ****
--- 1,114 ----
+ ! { dg-do run }
+ ! Tests fix for PR41600 and further SELECT TYPE functionality.
+ ! This differs from the original and select_type_26.f03 by 'm'
+ ! being a class object rather than a derived type.
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+   implicit none
+   type t0
+     integer :: j = 42
+   end type t0
+ 
+   type, extends(t0) :: t1
+     integer :: k = 99
+   end type t1
+ 
+   type t
+     integer :: i
+     class(t0), allocatable :: foo(:)
+   end type t
+ 
+   type t_scalar
+     integer :: i
+     class(t0), allocatable :: foo
+   end type t_scalar
+ 
+   class(t), allocatable :: m
+   class(t_scalar), allocatable :: m1(:)
+   integer :: n
+ 
+   allocate (m)
+   allocate (m1(4))
+ 
+ ! Test the fix for PR41600 itself - first with m%foo of declared type.
+   allocate(m%foo(3), source = [(t0(n), n = 1,3)])
+   select type(bar => m%foo)
+     type is(t0)
+       if (any (bar%j .ne. [1,2,3])) call abort
+     type is(t1)
+       call abort
+   end select
+ 
+   deallocate(m%foo)
+   allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
+ 
+ ! Then with m%foo of another dynamic type.
+   select type(bar => m%foo)
+     type is(t0)
+       call abort
+     type is(t1)
+       if (any (bar%k .ne. [40,50,60])) call abort
+   end select
+ 
+ ! Try it with a selector array section.
+   select type(bar => m%foo(2:3))
+     type is(t0)
+       call abort
+     type is(t1)
+       if (any (bar%k .ne. [50,60])) call abort
+   end select
+ 
+ ! Try it with a selector array element.
+   select type(bar => m%foo(2))
+     type is(t0)
+       call abort
+     type is(t1)
+       if (bar%k .ne. 50) call abort
+   end select
+ 
+ ! Now try class is and a selector which is an array section of an associate name.
+   select type(bar => m%foo)
+     type is(t0)
+       call abort
+     class is (t1)
+       if (any (bar%j .ne. [4,5,6])) call abort
+       select type (foobar => bar(3:2:-1))
+         type is (t1)
+           if (any (foobar%k .ne. [60,50])) call abort
+         end select
+   end select
+ 
+ ! Now try class is and a selector which is an array element of an associate name.
+   select type(bar => m%foo)
+     type is(t0)
+       call abort
+     class is (t1)
+       if (any (bar%j .ne. [4,5,6])) call abort
+       select type (foobar => bar(2))
+         type is (t1)
+           if (foobar%k .ne. 50) call abort
+         end select
+   end select
+ 
+ ! Check class a component of an element of an array. Note that an array of such
+ ! objects cannot be allowed since the elements could have different dynamic types.
+   do n = 1, 2
+     allocate(m1(n)%foo, source = t1(n*99, n*999))
+   end do
+   do n = 3, 4
+     allocate(m1(n)%foo, source = t0(n*99))
+   end do
+   select type(bar => m1(3)%foo)
+     type is(t0)
+       if (bar%j .ne. 297) call abort
+     type is(t1)
+       call abort
+   end select
+   select type(bar => m1(1)%foo)
+     type is(t0)
+       call abort
+     type is(t1)
+       if (bar%k .ne. 999) call abort
+   end select
+ end
Index: gcc/testsuite/gfortran.dg/select_type_28.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_28.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/select_type_28.f03	(revision 0)
***************
*** 0 ****
--- 1,35 ----
+ ! { dg-do compile }
+ ! SELECT TYPE.
+ !
+   implicit none
+   type t0
+     integer :: j = 42
+   end type t0
+   type, extends(t0) :: t1
+     integer :: k = 99
+   end type t1
+   type t
+     integer :: i
+     class(t0), allocatable :: foo
+   end type t
+   type(t) :: m(4)
+   integer :: n
+ 
+   do n = 1, 2
+     allocate(m(n)%foo, source = t0(n*99))
+   end do
+   do n = 3, 4
+     allocate(m(n)%foo, source = t1(n*99, n*999))
+   end do
+ 
+ ! An array of objects with ultimate class components cannot be a selector
+ ! since each element could have a different dynamic type.
+ 
+   select type(bar => m%foo) ! { dg-error "is an array with CLASS components" }
+     type is(t0)
+       if (any (bar%j .ne. [99, 198, 297, 396])) call abort
+     type is(t1)
+       call abort
+   end select
+ 
+ end