2010-03-12 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/43291
	PR fortran/43326
	* resolve.c (resolve_compcall): Add new boolean dummy argument
	'class_members'. Only resolve expression at end if false.
	Remove redundant, static variable 'class_object'.
	(check_class_members): Add extra argument to call of
	resolve_compcall.
	(resolve_typebound_function): Renamed resolve_class_compcall.
	Do all the detection of class references here. Correct calls to
	resolve_compcall for extra argument.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

2010-03-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43291
	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_7.f03: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157411 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f9bde00..9fd831d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2010-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/43291
+       PR fortran/43326
+       * resolve.c (resolve_compcall): Add new boolean dummy argument
+       'class_members'. Only resolve expression at end if false.
+       Remove redundant, static variable 'class_object'.
+       (check_class_members): Add extra argument to call of
+       resolve_compcall.
+       (resolve_typebound_function): Renamed resolve_class_compcall.
+       Do all the detection of class references here. Correct calls to
+       resolve_compcall for extra argument.
+       (resolve_typebound_subroutine): resolve_class_typebound_call
+       renamed. Otherwise same as resolve_typebound_function.
+       (gfc_resolve_expr): Call resolve_typebound_function.
+       (resolve_code): Call resolve_typebound_subroutine.
+

 2010-03-10  Tobias Burnus  <burnus@net-b.de
 
        PR fortran/43303
 2010-03-10  Tobias Burnus  <burnus@net-b.de
 
        PR fortran/43303

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 16661fd..9a95d34 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5082,7 +5082,7 @@ resolve_typebound_call (gfc_code* c)
    resolving subroutine class methods, since we do not have to add a
    gfc_code each time. */
 static gfc_try
    resolving subroutine class methods, since we do not have to add a
    gfc_code each time. */
 static gfc_try

-resolve_compcall (gfc_expr* e, bool fcn)
+resolve_compcall (gfc_expr* e, bool fcn, bool class_members)

 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;


@@ -5132,10 +5132,10 @@ resolve_compcall (gfc_expr* e, bool fcn)
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 

-  /* Resolution is not necessary if this is a class subroutine; this
-     function only has to identify the specific proc. Resolution of
-     the call will be done next in resolve_typebound_call.  */
-  return fcn ? gfc_resolve_expr (e) : SUCCESS;
+  /* Resolution is not necessary when constructing component calls
+     for class members, since this must only be done for the
+     declared type, which is done afterwards.  */
+  return !class_members ? gfc_resolve_expr (e) : SUCCESS;

 }
 
 
 }
 
 


@@ -5147,7 +5147,6 @@ static gfc_expr *list_e;
 static void check_class_members (gfc_symbol *);
 static gfc_try class_try;
 static bool fcn_flag;
 static void check_class_members (gfc_symbol *);
 static gfc_try class_try;
 static bool fcn_flag;

-static gfc_symbol *class_object;

 
 
 static void
 
 
 static void


@@ -5202,7 +5201,7 @@ check_class_members (gfc_symbol *derived)
 
   /* Do the renaming, PASSing, generic => specific and other
      good things for each class member.  */
 
   /* Do the renaming, PASSing, generic => specific and other
      good things for each class member.  */

-  class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+  class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)

                                ? class_try : FAILURE;
 
   /* Now transfer the found symbol to the esym list.  */
                                ? class_try : FAILURE;
 
   /* Now transfer the found symbol to the esym list.  */


@@ -5337,9 +5336,13 @@ resolve_arg_exprs (gfc_actual_arglist *arg)
 }
 
 
 }
 
 

-/* Resolve a CLASS typebound function, or 'method'.  */
+/* Resolve a typebound function, or 'method'.  First separate all
+   the non-CLASS references by calling resolve_compcall directly.
+   Then treat the CLASS references by resolving for each of the class
+   members in turn.  */
+

 static gfc_try
 static gfc_try

-resolve_class_compcall (gfc_expr* e)
+resolve_typebound_function (gfc_expr* e)

 {
   gfc_symbol *derived, *declared;
   gfc_ref *new_ref;
 {
   gfc_symbol *derived, *declared;
   gfc_ref *new_ref;


@@ -5347,16 +5350,18 @@ resolve_class_compcall (gfc_expr* e)
   gfc_symtree *st;
 
   st = e->symtree;
   gfc_symtree *st;
 
   st = e->symtree;

-  class_object = st->n.sym;
+  if (st == NULL)
+    return resolve_compcall (e, true, false);

 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, e);
 
   /* Weed out cases of the ultimate component being a derived type.  */
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, e);
 
   /* Weed out cases of the ultimate component being a derived type.  */

-  if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+  if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+       || (!class_ref && st->n.sym->ts.type != BT_CLASS))

     {
       gfc_free_ref_list (new_ref);
     {
       gfc_free_ref_list (new_ref);

-      return resolve_compcall (e, true);
+      return resolve_compcall (e, true, false);

     }
 
   /* Resolve the argument expressions,  */
     }
 
   /* Resolve the argument expressions,  */


@@ -5371,7 +5376,7 @@ resolve_class_compcall (gfc_expr* e)
   list_e = gfc_copy_expr (e);
   check_class_members (derived);
 
   list_e = gfc_copy_expr (e);
   check_class_members (derived);
 

-  class_try = (resolve_compcall (e, true) == SUCCESS)
+  class_try = (resolve_compcall (e, true, false) == SUCCESS)

                 ? class_try : FAILURE;
 
   /* Transfer the class list to the original expression.  Note that
                 ? class_try : FAILURE;
 
   /* Transfer the class list to the original expression.  Note that


@@ -5392,9 +5397,13 @@ resolve_class_compcall (gfc_expr* e)
   return class_try;
 }
 
   return class_try;
 }
 

-/* Resolve a CLASS typebound subroutine, or 'method'.  */
+/* Resolve a typebound subroutine, or 'method'.  First separate all
+   the non-CLASS references by calling resolve_typebound_call directly.
+   Then treat the CLASS references by resolving for each of the class
+   members in turn.  */
+

 static gfc_try
 static gfc_try

-resolve_class_typebound_call (gfc_code *code)
+resolve_typebound_subroutine (gfc_code *code)

 {
   gfc_symbol *derived, *declared;
   gfc_ref *new_ref;
 {
   gfc_symbol *derived, *declared;
   gfc_ref *new_ref;


@@ -5402,13 +5411,15 @@ resolve_class_typebound_call (gfc_code *code)
   gfc_symtree *st;
 
   st = code->expr1->symtree;
   gfc_symtree *st;
 
   st = code->expr1->symtree;

-  class_object = st->n.sym;
+  if (st == NULL)
+    return resolve_typebound_call (code);

 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
   /* Weed out cases of the ultimate component being a derived type.  */
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
   /* Weed out cases of the ultimate component being a derived type.  */

-  if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+  if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+       || (!class_ref && st->n.sym->ts.type != BT_CLASS))

     {
       gfc_free_ref_list (new_ref);
       return resolve_typebound_call (code);
     {
       gfc_free_ref_list (new_ref);
       return resolve_typebound_call (code);


@@ -5584,10 +5595,7 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
       break;
 
     case EXPR_COMPCALL:

-      if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
-       t = resolve_class_compcall (e);
-      else
-       t = resolve_compcall (e, true);
+      t = resolve_typebound_function (e);

       break;
 
     case EXPR_SUBSTRING:
       break;
 
     case EXPR_SUBSTRING:


@@ -8150,11 +8158,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 
        case EXEC_COMPCALL:
        compcall:
 
        case EXEC_COMPCALL:
        compcall:

-         if (code->expr1->symtree
-               && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
-           resolve_class_typebound_call (code);
-         else
-           resolve_typebound_call (code);
+         resolve_typebound_subroutine (code);

          break;
 
        case EXEC_CALL_PPC:
          break;
 
        case EXEC_CALL_PPC:

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ad50235..5db28bd 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2010-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/43291
+       PR fortran/43326
+       * gfortran.dg/dynamic_dispatch_7.f03: New test.
+

 2010-03-12  Kai Tietz  <kai.tietz@onevision.com>
 
        * gfortran.dg/default_format_denormal_1.f90: Don't assume
 2010-03-12  Kai Tietz  <kai.tietz@onevision.com>
 
        * gfortran.dg/default_format_denormal_1.f90: Don't assume

diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
new file mode 100644 (file)
index 0000000..a84d9f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
@@ -0,0 +1,64 @@
+! { dg-do run }
+! Test the fix for PR43291, which was a regression that caused
+! incorrect type mismatch errors at line 46. In the course of
+! fixing the PR, it was noted that the dynamic dispatch of the
+! final typebound call was not occurring - hence the dg-do run.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+!
+module m1
+  type  :: t1
+  contains 
+    procedure :: sizeof
+  end type
+contains
+  integer function sizeof(a)
+    class(t1) :: a
+    sizeof = 1
+  end function sizeof
+end module
+
+
+module m2
+  use m1
+  type, extends(t1) :: t2    
+  contains
+    procedure :: sizeof => sizeof2
+  end type
+contains
+  integer function sizeof2(a)
+    class(t2) :: a
+    sizeof2 = 2
+  end function
+end module
+
+
+module m3
+  use m2
+  type :: t3
+    class(t1), pointer  :: a 
+  contains
+    procedure :: sizeof => sizeof3
+  end type
+contains 
+  integer function sizeof3(a)
+    class(t3) :: a
+    sizeof3 = a%a%sizeof()
+  end function 
+end module
+
+  use m1
+  use m2
+  use m3
+  type(t1), target :: x
+  type(t2), target :: y
+  type(t3) :: z
+  z%a => x
+  if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
+  z%a => y
+  if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
+
+end
+
+! { dg-final { cleanup-modules "m1 m2 m3" } }
+