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

login
register
mail settings
Submitter Paul Richard Thomas
Date March 18, 2012, 8:09 p.m.
Message ID <CAGkQGiKq=747mNY6JcxzOVDFFiQGZLhe_EfwSBTPSYfujaQR_A@mail.gmail.com>
Download mbox | patch
Permalink /patch/147425/
State New
Headers show

Comments

Paul Richard Thomas - March 18, 2012, 8:09 p.m.
Dear All,

Please find attached a fix for PR41600 plus some.  It is reasonably
straightforward but the following should be noted:
(i) gfc_get_vptr_from_expr exploits that seeming fact that tracing
back any class expression through TREE_OPERAND 0 eventually gets one
back to the class expression.  I will root through the various
functions that operate on class objects to remove the front-endery
that does the same thing but in a much more cumbersome way;
(ii) GFC_CLASS_TYPE_P has been introduced, as it should have been in
the first place :-(  Its first use is in (i);
(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; and
(iv) select_type_set_tmp was broken up to make the logic more
transparent.  The result is only a little longer than it would have
been without the calls to select_derived_set_tmp and
select_class_set_tmp.

There is quite a lot of retrospective tidying up to do using (i) and (ii)!

Bootstraps and regtests on FC9/x86_64 - OK for trunk?

Cheers

Paul

2012-03-18  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-03-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* gfortran.dg/select_type_26.f03 : New test.
Tobias Burnus - March 18, 2012, 10:16 p.m.
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.)

> +   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.

> +   /* 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.

>      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.

> (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))

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

Tobias

Patch

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 185482)
--- 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/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 185482)
--- 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
*** 3518,3524 ****
  	  /* 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)
  	{
--- 3540,3546 ----
  	  /* 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/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 185482)
--- 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 185482)
--- 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 185482)
--- 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 185482)
--- 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 185482)
--- 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 185482)
--- 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,8015 ----
        sym->attr.dimension = 0;
        return;
      }
! 
!   /* We cannot deal with class selectors that need temporaries.  
!      Note: This breaks associate_1.f03 and associate_5.f03.  */
!   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 && 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 185482)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_select (void)
*** 5112,5117 ****
--- 5112,5177 ----
  }
  
  
+ /* Transfer the selector typespec to the associate name.  */
+ 
+ static void
+ copy_ts_from_selector_to_associate (gfc_expr *expr1, gfc_expr *expr2)
+ {
+   gfc_symbol *sym = expr1->symtree->n.sym;
+ 
+   /* Ensure that any array reference is resolved.  */
+   gfc_resolve_expr (expr2);
+ 
+   /* 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 right class container is obtained.  */
+   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;
+     }
+ 
+   if (expr2->ts.type != BT_CLASS)
+     {
+       /* The correct class container has to be available.  */
+       if (expr2->rank)
+ 	{
+ 	  sym->attr.dimension = 1;
+ 	  sym->as = gfc_get_array_spec ();
+ 	  sym->as->rank = expr2->rank;
+ 	  sym->as->type = AS_DEFERRED;
+ 	}
+       else
+ 	sym->as = NULL;
+       sym->ts.type = BT_CLASS;
+       sym->ts.u.derived = expr2->ts.u.derived;
+       sym->attr.pointer = 1;
+       gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+     }
+   else
+     {
+       /* The correct class container has to be available.  */
+       if (expr2->rank)
+ 	{
+ 	  sym->attr.dimension = 1;
+ 	  sym->as = gfc_get_array_spec ();
+ 	  sym->as->rank = expr2->rank;
+ 	  sym->as->type = AS_DEFERRED;
+ 	}
+       else
+ 	sym->as = NULL;
+       sym->ts.type = BT_CLASS;
+       sym->ts.u.derived = CLASS_DATA (expr2)->ts.u.derived;
+       sym->attr.pointer = 1;
+       gfc_build_class_symbol (&sym->ts, &sym->attr, &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.  */
--- 5186,5288 ----
  }
  
  
! /* 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
--- 5293,5299 ----
    select_type_stack->tmp = tmp;
  }
  
!   
  /* Match a SELECT TYPE statement.  */
  
  match
*************** gfc_match_select_type (void)
*** 5204,5209 ****
--- 5303,5309 ----
    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
      {
--- 5325,5340 ----
  	  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,80 ----
+ ! { 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) :: m
+   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
+ end
+