re PR fortran/45271 ([OOP] Polymorphic code breaks when changing order of USE statements)

2010-08-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45271
	PR fortran/45290
	* class.c (add_proc_comp): Add static initializer for PPCs.
	(add_procs_to_declared_vtab): Modified comment.
	* module.c (mio_component): Add argument 'vtype'. Don't read/write the
	initializer if the component is part of a vtype.
	(mio_component_list): Add argument 'vtype', pass it on to
	'mio_component'.
	(mio_symbol): Modified call to 'mio_component_list'.
	* trans.h (gfc_conv_initializer): Modified prototype.
	(gfc_trans_assign_vtab_procs): Removed.
	* trans-common.c (create_common): Modified call to
	'gfc_conv_initializer'.
	* trans-decl.c (gfc_get_symbol_decl,get_proc_pointer_decl,
	gfc_emit_parameter_debug_info): Modified call to
	'gfc_conv_initializer'.
	(build_function_decl): Remove assertion.
	* trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign):
	Removed call to 'gfc_trans_assign_vtab_procs'.
	(gfc_conv_initializer): Add argument 'procptr'.
	(gfc_conv_structure): Modified call to 'gfc_conv_initializer'.
	(gfc_trans_assign_vtab_procs): Removed.
	* trans-stmt.c (gfc_trans_allocate): Removed call to
	'gfc_trans_assign_vtab_procs'.


2010-08-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44863
	PR fortran/45271
	PR fortran/45290
	* gfortran.dg/dynamic_dispatch_10.f03: New (PR 44863 comment #1).
	* gfortran.dg/pointer_init_5.f90: New (PR 45290 comment #6).
	* gfortran.dg/typebound_call_18.f03: New (PR 45271 comment #3).

From-SVN: r163445

gcc/fortran/ChangeLog

@@ -1,3 +1,30 @@
+2010-08-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45271
+	PR fortran/45290
+	* class.c (add_proc_comp): Add static initializer for PPCs.
+	(add_procs_to_declared_vtab): Modified comment.
+	* module.c (mio_component): Add argument 'vtype'. Don't read/write the
+	initializer if the component is part of a vtype.
+	(mio_component_list): Add argument 'vtype', pass it on to
+	'mio_component'.
+	(mio_symbol): Modified call to 'mio_component_list'.
+	* trans.h (gfc_conv_initializer): Modified prototype.
+	(gfc_trans_assign_vtab_procs): Removed.
+	* trans-common.c (create_common): Modified call to
+	'gfc_conv_initializer'.
+	* trans-decl.c (gfc_get_symbol_decl,get_proc_pointer_decl,
+	gfc_emit_parameter_debug_info): Modified call to
+	'gfc_conv_initializer'.
+	(build_function_decl): Remove assertion.
+	* trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign):
+	Removed call to 'gfc_trans_assign_vtab_procs'.
+	(gfc_conv_initializer): Add argument 'procptr'.
+	(gfc_conv_structure): Modified call to 'gfc_conv_initializer'.
+	(gfc_trans_assign_vtab_procs): Removed.
+	* trans-stmt.c (gfc_trans_allocate): Removed call to
+	'gfc_trans_assign_vtab_procs'.
+
 2010-08-21  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/36158

gcc/fortran/class.c

@@ -214,8 +214,6 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
       /* Add procedure component.  */
       if (gfc_add_component (vtype, name, &c) == FAILURE)
 	return;
-      if (tb->u.specific)
-	c->ts.interface = tb->u.specific->n.sym;
 
       if (!c->tb)
 	c->tb = XCNEW (gfc_typebound_proc);
@@ -228,17 +226,18 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
       c->attr.external = 1;
       c->attr.untyped = 1;
       c->attr.if_source = IFSRC_IFBODY;
-
-      /* A static initializer cannot be used here because the specific
-	function is not a constant; internal compiler error: in
-	output_constant, at varasm.c:4623  */
-      c->initializer = NULL;
     }
   else if (c->attr.proc_pointer && c->tb)
     {
       *c->tb = *tb;
       c->tb->ppc = 1;
-      c->ts.interface = tb->u.specific->n.sym;	  
+    }
+
+  if (tb->u.specific)
+    {
+      c->ts.interface = tb->u.specific->n.sym;
+      if (!tb->deferred)
+	c->initializer = gfc_get_variable_expr (tb->u.specific);
     }
 }
 
@@ -296,7 +295,7 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
     {
       /* Make sure that the PPCs appear in the same order as in the parent.  */
       copy_vtab_proc_comps (super_type, vtype);
-      /* Only needed to get the PPC interfaces right.  */
+      /* Only needed to get the PPC initializers right.  */
       add_procs_to_declared_vtab (super_type, vtype);
     }
 

gcc/fortran/module.c

@@ -2343,7 +2343,7 @@ static void mio_formal_arglist (gfc_formal_arglist **formal);
 static void mio_typebound_proc (gfc_typebound_proc** proc);
 
 static void
-mio_component (gfc_component *c)
+mio_component (gfc_component *c, int vtype)
 {
   pointer_info *p;
   int n;
@@ -2373,7 +2373,8 @@ mio_component (gfc_component *c)
   mio_symbol_attribute (&c->attr);
   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 
 
-  mio_expr (&c->initializer);
+  if (!vtype)
+    mio_expr (&c->initializer);
 
   if (c->attr.proc_pointer)
     {
@@ -2408,7 +2409,7 @@ mio_component (gfc_component *c)
 
 
 static void
-mio_component_list (gfc_component **cp)
+mio_component_list (gfc_component **cp, int vtype)
 {
   gfc_component *c, *tail;
 
@@ -2417,7 +2418,7 @@ mio_component_list (gfc_component **cp)
   if (iomode == IO_OUTPUT)
     {
       for (c = *cp; c; c = c->next)
-	mio_component (c);
+	mio_component (c, vtype);
     }
   else
     {
@@ -2430,7 +2431,7 @@ mio_component_list (gfc_component **cp)
 	    break;
 
 	  c = gfc_get_component ();
-	  mio_component (c);
+	  mio_component (c, vtype);
 
 	  if (tail == NULL)
 	    *cp = c;
@@ -3597,7 +3598,7 @@ mio_symbol (gfc_symbol *sym)
   /* Note that components are always saved, even if they are supposed
      to be private.  Component access is checked during searching.  */
 
-  mio_component_list (&sym->components);
+  mio_component_list (&sym->components, sym->attr.vtype);
 
   if (sym->components != NULL)
     sym->component_access

gcc/fortran/trans-common.c

@@ -649,8 +649,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
 	      {
 		/* Add the initializer for this field.  */
 		tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
-		    TREE_TYPE (s->field), s->sym->attr.dimension,
+					    TREE_TYPE (s->field),
-		    s->sym->attr.pointer || s->sym->attr.allocatable);
+					    s->sym->attr.dimension,
+					    s->sym->attr.pointer
+					    || s->sym->attr.allocatable, false);
 
 		CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
 	      }

gcc/fortran/trans-decl.c

@@ -1034,6 +1034,9 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
 }
 
 
+static void build_function_decl (gfc_symbol * sym, bool global);
+
+
 /* Return the decl for a gfc_symbol, create it if it doesn't already
    exist.  */
 
@@ -1160,12 +1163,21 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	}
     }
 
-  /* Catch function declarations.  Only used for actual parameters and
-     procedure pointers.  */
   if (sym->attr.flavor == FL_PROCEDURE)
     {
-      decl = gfc_get_extern_function_decl (sym);
+      /* Catch function declarations. Only used for actual parameters,
-      gfc_set_decl_location (decl, &sym->declared_at);
+	 procedure pointers and procptr initialization targets.  */
+      if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
+	{
+	  decl = gfc_get_extern_function_decl (sym);
+	  gfc_set_decl_location (decl, &sym->declared_at);
+	}
+      else
+	{
+	  if (!sym->backend_decl)
+	    build_function_decl (sym, false);
+	  decl = sym->backend_decl;
+	}
       return decl;
     }
 
@@ -1281,8 +1293,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	 every time the procedure is entered. The TREE_STATIC is
 	 in this case due to -fmax-stack-var-size=.  */
       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
-	  TREE_TYPE (decl), sym->attr.dimension,
+						  TREE_TYPE (decl),
-	  sym->attr.pointer || sym->attr.allocatable);
+						  sym->attr.dimension,
+						  sym->attr.pointer
+						  || sym->attr.allocatable,
+						  sym->attr.proc_pointer);
     }
 
   if (!TREE_STATIC (decl)
@@ -1369,9 +1384,9 @@ get_proc_pointer_decl (gfc_symbol *sym)
     {
       /* Add static initializer.  */
       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
-	  TREE_TYPE (decl),
+						  TREE_TYPE (decl),
-	  sym->attr.proc_pointer ? false : sym->attr.dimension,
+						  sym->attr.dimension,
-	  sym->attr.proc_pointer);
+						  false, true);
     }
 
   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
@@ -1608,9 +1623,11 @@ build_function_decl (gfc_symbol * sym, bool global)
   tree result_decl;
   gfc_formal_arglist *f;
 
-  gcc_assert (!sym->backend_decl);
   gcc_assert (!sym->attr.external);
 
+  if (sym->backend_decl)
+    return;
+
   /* Set the line and filename.  sym->declared_at seems to point to the
      last statement for subroutines, but it'll do for now.  */
   gfc_set_backend_locus (&sym->declared_at);
@@ -3806,9 +3823,10 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
   TREE_USED (decl) = 1;
   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
     TREE_PUBLIC (decl) = 1;
-  DECL_INITIAL (decl)
+  DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
-    = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
+					      TREE_TYPE (decl),
-			    sym->attr.dimension, 0);
+					      sym->attr.dimension,
+					      false, false);
   debug_hooks->global_decl (decl);
 }
 

gcc/fortran/trans-expr.c

@@ -2574,7 +2574,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
      not to the class declared type.  */
   vtab = gfc_find_derived_vtab (e->ts.u.derived);
   gcc_assert (vtab);
-  gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, 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));
@@ -3946,11 +3945,11 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
 
 tree
 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
-		      bool array, bool pointer)
+		      bool array, bool pointer, bool procptr)
 {
   gfc_se se;
 
-  if (!(expr || pointer))
+  if (!(expr || pointer || procptr))
     return NULL_TREE;
 
   /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
@@ -3972,7 +3971,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
       return se.expr;
     }
   
-  if (array)
+  if (array && !procptr)
     {
       /* Arrays need special handling.  */
       if (pointer)
@@ -3983,7 +3982,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
       else
 	return gfc_conv_array_initializer (type, expr);
     }
-  else if (pointer)
+  else if (pointer || procptr)
     {
       if (!expr || expr->expr_type == EXPR_NULL)
 	return fold_convert (type, null_pointer_node);
@@ -4462,8 +4461,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
-	      TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+				      TREE_TYPE (cm->backend_decl),
-	      cm->attr.pointer || cm->attr.proc_pointer);
+				      cm->attr.dimension, cm->attr.pointer,
+				      cm->attr.proc_pointer);
 
 	  /* Append it to the constructor list.  */
 	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
@@ -5779,63 +5779,6 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
-/* Generate code to assign typebound procedures to a derived vtab.  */
-void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
-				  gfc_symbol *vtab)
-{
-  gfc_component *cmp;
-  tree vtb, ctree, proc, cond = NULL_TREE;
-  stmtblock_t body;
-
-  /* Point to the first procedure pointer.  */
-  cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
-  cmp = cmp->next;
-  if (!cmp)
-    return;
-  
-  vtb = gfc_get_symbol_decl (vtab);
-
-  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), vtb,
-		       cmp->backend_decl, NULL_TREE);
-  cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
-		      build_int_cst (TREE_TYPE (ctree), 0));
-
-  gfc_init_block (&body);
-  for (; cmp; cmp = cmp->next)
-    {
-      gfc_symbol *target = NULL;
-
-      /* This is required when typebound generic procedures are called
-	 with derived type targets.  The specific procedures do not get
-	 added to the vtype, which remains "empty".  */
-      if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
-	target = cmp->tb->u.specific->n.sym;
-      else
-	{
-	  gfc_symtree *st;
-	  st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
-	  if (st->n.tb && st->n.tb->u.specific)
-	    target = st->n.tb->u.specific->n.sym;
-	}
-
-      if (!target)
-	continue;
-
-      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
-			   vtb, cmp->backend_decl, NULL_TREE);
-      proc = gfc_get_symbol_decl (target);
-      proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
-      gfc_add_modify (&body, ctree, proc);
-    }
-
-  proc = gfc_finish_block (&body);
-
-  proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
-
-  gfc_add_expr_to_block (block, proc);
-}
-
-
 /* Special case for initializing a CLASS variable on allocation.
    A MEMCPY is needed to copy the full data of the dynamic type,
    which may be different from the declared type.  */
@@ -5887,7 +5830,6 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
 	  gfc_symtree *st;
 	  vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
 	  gcc_assert (vtab);
-	  gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
 	  rhs = gfc_get_expr ();
 	  rhs->expr_type = EXPR_VARIABLE;
 	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);

gcc/fortran/trans-stmt.c

@@ -4441,7 +4441,6 @@ gfc_trans_allocate (gfc_code * code)
 		{
 		  vtab = gfc_find_derived_vtab (ts->u.derived);
 		  gcc_assert (vtab);
-		  gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
 		  gfc_init_se (&lse, NULL);
 		  lse.want_pointer = 1;
 		  gfc_conv_expr (&lse, lhs);

gcc/fortran/trans.h

@@ -433,7 +433,7 @@ void gfc_set_decl_location (tree, locus *);
 tree gfc_get_symbol_decl (gfc_symbol *);
 
 /* Build a static initializer.  */
-tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool);
+tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool);
 
 /* Assign a default initializer to a derived type.  */
 void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool);
@@ -527,9 +527,6 @@ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
 /* Generate code for a pointer assignment.  */
 tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
 
-/* Generate code to assign typebound procedures to a derived vtab.  */
-void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*, gfc_symbol*);
-
 /* Initialize function decls for library functions.  */
 void gfc_build_intrinsic_lib_fndecls (void);
 /* Create function decls for IO library functions.  */

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+2010-08-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44863
+	PR fortran/45271
+	PR fortran/45290
+	* gfortran.dg/dynamic_dispatch_10.f03: New (PR 44863 comment #1).
+	* gfortran.dg/pointer_init_5.f90: New (PR 45290 comment #6).
+	* gfortran.dg/typebound_call_18.f03: New (PR 45271 comment #3).
+
 2010-08-21  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/36158

gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03

@@ -0,0 +1,171 @@
+! { dg-do run }
+!
+! [OOP] Fortran runtime error: internal error: bad hash value in dynamic dispatch
+!
+! Contributed by David Car <david.car7@gmail.com>
+
+module BaseStrategy
+
+  type, public, abstract :: Strategy
+   contains
+     procedure(strategy_update), pass( this ), deferred :: update
+     procedure(strategy_pre_update), pass( this ), deferred :: preUpdate
+     procedure(strategy_post_update), pass( this ), deferred :: postUpdate
+  end type Strategy
+
+  abstract interface
+     subroutine strategy_update( this )
+       import Strategy
+       class (Strategy), target, intent(in) :: this
+     end subroutine strategy_update
+  end interface
+
+  abstract interface
+     subroutine strategy_pre_update( this )
+       import Strategy
+       class (Strategy), target, intent(in) :: this
+     end subroutine strategy_pre_update
+  end interface
+
+  abstract interface
+     subroutine strategy_post_update( this )
+       import Strategy
+       class (Strategy), target, intent(in) :: this
+     end subroutine strategy_post_update
+  end interface
+     
+end module BaseStrategy
+
+!==============================================================================
+
+module LaxWendroffStrategy
+
+  use BaseStrategy
+
+  private :: update, preUpdate, postUpdate
+
+  type, public, extends( Strategy ) :: LaxWendroff
+     class (Strategy), pointer :: child => null()
+     contains
+       procedure, pass( this ) :: update
+       procedure, pass( this ) :: preUpdate
+       procedure, pass( this ) :: postUpdate
+  end type LaxWendroff
+
+contains
+
+  subroutine update( this )
+    class (LaxWendroff), target, intent(in) :: this
+
+    print *, 'Calling LaxWendroff update'
+  end subroutine update
+
+  subroutine preUpdate( this )
+    class (LaxWendroff), target, intent(in) :: this
+    
+    print *, 'Calling LaxWendroff preUpdate'
+  end subroutine preUpdate
+
+  subroutine postUpdate( this )
+    class (LaxWendroff), target, intent(in) :: this
+    
+    print *, 'Calling LaxWendroff postUpdate'
+  end subroutine postUpdate
+  
+end module LaxWendroffStrategy
+
+!==============================================================================
+
+module KEStrategy
+
+  use BaseStrategy
+  ! Uncomment the line below and it runs fine
+  ! use LaxWendroffStrategy
+
+  private :: update, preUpdate, postUpdate
+
+  type, public, extends( Strategy ) :: KE
+     class (Strategy), pointer :: child => null()
+     contains
+       procedure, pass( this ) :: update
+       procedure, pass( this ) :: preUpdate
+       procedure, pass( this ) :: postUpdate
+  end type KE
+  
+contains
+
+  subroutine init( this, other )
+    class (KE), intent(inout) :: this
+    class (Strategy), target, intent(in) :: other
+
+    this % child => other
+  end subroutine init
+
+  subroutine update( this )
+    class (KE), target, intent(in) :: this
+
+    if ( associated( this % child ) ) then
+       call this % child % update()
+    end if
+
+    print *, 'Calling KE update'
+  end subroutine update
+
+ subroutine preUpdate( this )
+    class (KE), target, intent(in) :: this
+    
+    if ( associated( this % child ) ) then
+       call this % child % preUpdate()
+    end if
+
+    print *, 'Calling KE preUpdate'
+  end subroutine preUpdate
+
+  subroutine postUpdate( this )
+    class (KE), target, intent(in) :: this
+
+    if ( associated( this % child ) ) then
+       call this % child % postUpdate()
+    end if
+    
+    print *, 'Calling KE postUpdate'
+  end subroutine postUpdate
+  
+end module KEStrategy
+
+!==============================================================================
+
+program main
+
+  use LaxWendroffStrategy
+  use KEStrategy
+
+  type :: StratSeq
+     class (Strategy), pointer :: strat => null()
+  end type StratSeq
+
+  type (LaxWendroff), target :: lw_strat
+  type (KE), target :: ke_strat
+
+  type (StratSeq), allocatable, dimension( : ) :: seq
+  
+  allocate( seq(10) )
+
+  call init( ke_strat, lw_strat )
+  call ke_strat % preUpdate()
+  call ke_strat % update()
+  call ke_strat % postUpdate()
+  ! call lw_strat % update()
+
+  seq( 1 ) % strat => ke_strat
+  seq( 2 ) % strat => lw_strat
+
+  call seq( 1 ) % strat % update()
+
+  do i = 1, 2
+     call seq( i ) % strat % update()
+  end do
+
+end
+
+! { dg-final { cleanup-modules "BaseStrategy LaxWendroffStrategy KEStrategy" } }

gcc/testsuite/gfortran.dg/pointer_init_5.f90

@@ -0,0 +1,42 @@
+! { dg-do run }
+!
+! PR 45290: [F08] pointer initialization
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+implicit none
+
+procedure(f1), pointer :: pp => f1
+
+type :: t
+  procedure(f2), pointer, nopass :: ppc => f2
+end type
+
+contains
+
+  integer function f1()
+    f1 = 42
+  end function
+
+  integer function f2()
+    f2 = 43
+  end function
+
+end module
+
+
+program test_ptr_init
+
+use m
+implicit none
+
+type (t) :: u
+
+if (pp()/=42) call abort()
+if (u%ppc()/=43) call abort()
+
+end
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/typebound_call_18.f03

@@ -0,0 +1,67 @@
+! { dg-do run }
+!
+! PR 45271: [OOP] Polymorphic code breaks when changing order of USE statements
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+
+module abstract_vector
+  implicit none
+  type, abstract :: vector_class
+  contains
+    procedure(op_assign_v_v), deferred :: assign
+  end type vector_class
+  abstract interface
+    subroutine op_assign_v_v(this,v)
+      import vector_class
+      class(vector_class), intent(inout) :: this
+      class(vector_class), intent(in)    :: v
+    end subroutine
+  end interface
+end module abstract_vector
+
+module concrete_vector
+  use abstract_vector
+  implicit none
+  type, extends(vector_class) :: trivial_vector_type
+  contains
+    procedure :: assign => my_assign
+  end type
+contains
+  subroutine my_assign (this,v)
+    class(trivial_vector_type), intent(inout) :: this
+    class(vector_class),        intent(in)    :: v
+    write (*,*) 'Oops in concrete_vector::my_assign'
+    call abort ()
+  end subroutine
+end module concrete_vector
+
+module concrete_gradient
+  use abstract_vector
+  implicit none
+  type, extends(vector_class) :: trivial_gradient_type
+  contains
+    procedure :: assign => my_assign
+  end type
+contains
+  subroutine my_assign (this,v)
+    class(trivial_gradient_type), intent(inout) :: this
+    class(vector_class),          intent(in)    :: v
+    write (*,*) 'concrete_gradient::my_assign'
+  end subroutine
+end module concrete_gradient
+
+program main
+  !--- exchange these two lines to make the code work:
+  use concrete_vector    ! (1)
+  use concrete_gradient  ! (2)
+  !---
+  implicit none
+  type(trivial_gradient_type)      :: g_initial
+  class(vector_class),  allocatable :: g
+  print *, "cg: before g%assign"
+  allocate(trivial_gradient_type :: g)
+  call g%assign (g_initial)
+  print *, "cg: after  g%assign"
+end program main
+
+! { dg-final { cleanup-modules "abstract_vector concrete_vector concrete_gradient" } }