Bug 45420 - [OOP] polymorphic TBP call in a CLASS DEFAULT clause
Summary: [OOP] polymorphic TBP call in a CLASS DEFAULT clause
Status: RESOLVED FIXED
Alias: None
Product: gcc
Classification: Unclassified
Component: fortran (show other bugs)
Version: 4.6.0
: P3 normal
Target Milestone: 4.6.0
Assignee: Not yet assigned to anyone
URL:
Keywords: wrong-code
Depends on:
Blocks:
 
Reported: 2010-08-26 17:43 UTC by janus
Modified: 2010-08-27 19:15 UTC (History)
3 users (show)

See Also:
Host:
Target:
Build:
Known to work:
Known to fail:
Last reconfirmed: 2010-08-26 19:55:39


Attachments

Note You need to log in before you can comment on or make changes to this bug.
Description janus 2010-08-26 17:43:04 UTC
Reported by Salvatore at http://gcc.gnu.org/ml/fortran/2010-08/msg00351.html.

Here is a slightly simplified version of the test case:


module base_mat_mod

 type  :: base_sparse_mat
 contains
   procedure, pass(a) :: get_fmt => base_get_fmt
 end type base_sparse_mat

contains

 function base_get_fmt(a) result(res)
   implicit none
   class(base_sparse_mat), intent(in) :: a
   character(len=5) :: res
   res = 'NULL'
 end function base_get_fmt

end module base_mat_mod


module d_base_mat_mod

 use base_mat_mod

 type, extends(base_sparse_mat) :: d_base_sparse_mat
 contains
   procedure, pass(a) :: get_fmt => d_base_get_fmt
 end type d_base_sparse_mat

 type, extends(d_base_sparse_mat) :: x_base_sparse_mat
 contains
   procedure, pass(a) :: get_fmt => x_base_get_fmt
 end type x_base_sparse_mat

contains

 function d_base_get_fmt(a) result(res)
   implicit none
   class(d_base_sparse_mat), intent(in) :: a
   character(len=5) :: res
   res = 'DBASE'
 end function d_base_get_fmt

 function x_base_get_fmt(a) result(res)
   implicit none
   class(x_base_sparse_mat), intent(in) :: a
   character(len=5) :: res
   res = 'XBASE'
 end function x_base_get_fmt

end module d_base_mat_mod


program bug20
  use d_base_mat_mod
  class(d_base_sparse_mat), allocatable  :: a

  allocate(x_base_sparse_mat :: a)
  write(0,*) 'Dynamic type on entry: ',a%get_fmt()

  select type(a)
  type is (d_base_sparse_mat)
    write(0,*) 'Dynamic type TYPE IS clause: ',a%get_fmt()
  class default
    write(0,*) 'Dynamic type CLASS DEFAULT clause: ',a%get_fmt()
  end select

end program bug20


Current output:

 Dynamic type on entry: XBASE
 Dynamic type CLASS DEFAULT clause: DBASE

Expected output:

 Dynamic type on entry: XBASE
 Dynamic type CLASS DEFAULT clause: XBASE
Comment 1 janus 2010-08-26 17:54:39 UTC
The dump shows that the first call to 'get_fmt' is executed dynamically as 'a.$vptr->get_fmt(...)', while the ones inside the SELECT TYPE block are resolved statically to 'd_base_get_fmt'. For the TYPE IS clause this is fine, but not so for CLASS DEFAULT, where a polymorphic call should be generated.

F08 quotes (chapter 8.1.9.2):

Within the block following a TYPE IS type guard statement, the associating entity (16.5.5) is not polymorphic (4.3.1.3), has the type named in the type guard statement, and has the type parameter values of the selector.

Within the block following a CLASS IS type guard statement, the associating entity is polymorphic and has the declared type named in the type guard statement. The type parameter values of the associating entity are the corresponding type parameter values of the selector.

Within the block following a CLASS DEFAULT type guard statement, the associating entity is polymorphic and has the same declared type as the selector. The type parameter values of the associating entity are those of the declared type of the selector.
Comment 2 janus 2010-08-26 19:55:39 UTC
It turns out this bug is rather easy to fix. The problem was the we used the temporary needed for the TYPE IS clause also in the CLASS DEFAULT clause (where we need none). The following patch fixes it (haven't checked for regressions yet):

Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 163470)
+++ gcc/fortran/match.c (working copy)
@@ -4460,6 +4460,12 @@ 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;
 
@@ -4702,6 +4708,7 @@ gfc_match_class_is (void)
       c->where = gfc_current_locus;
       c->ts.type = BT_UNKNOWN;
       new_st.ext.case_list = c;
+      select_type_set_tmp (NULL);
       return MATCH_YES;
     }
Comment 3 Salvatore Filippone 2010-08-27 07:37:12 UTC
(In reply to comment #2)
> It turns out this bug is rather easy to fix. The problem was the we used the
> temporary needed for the TYPE IS clause also in the CLASS DEFAULT clause (where
> we need none). The following patch fixes it (haven't checked for regressions
> yet):
> 
Hi, 
First, the patch did not apply cleanly, the first hunk was rejected. I applied it by hand, and I got a problem down the road in my library: 
===============================================================
gfortran -ggdb -I.. -I../modules -I. -c psb_srwextd.f90
psb_srwextd.f90:76.13:

      call aa%mv_to_coo(actmp,info)
             1
Error: Actual argument at (1) must be definable as the dummy argument 'a' is INTENT = OUT/INOUT
psb_srwextd.f90:84.39:

      if (info == psb_success_) call aa%mv_from_coo(actmp,info)
                                       1
Error: Actual argument at (1) must be definable as the dummy argument 'a' is INTENT = OUT/INOUT
============================================================================
The relevant piece of code is as follows:
============================================================================
subroutine psb_srwextd(nr,a,info,b,rowscale)
  use psb_sparse_mod, psb_protect_name => psb_srwextd
  implicit none

  ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes)
  integer, intent(in)                          :: nr
  type(psb_s_sparse_mat), intent(inout)        :: a
  integer,intent(out)                          :: info
  type(psb_s_sparse_mat), intent(in), optional :: b
  logical,intent(in), optional                 :: rowscale

  integer :: i,j,ja,jb,err_act,nza,nzb
  character(len=20)                 :: name, ch_err
  type(psb_s_coo_sparse_mat)        :: actmp
  logical  rowscale_ 

  name='psb_srwextd'
  info  = psb_success_
  call psb_erractionsave(err_act)

  if (nr > a%get_nrows()) then 
    select type(aa=> a%a) 
    type is (psb_s_csr_sparse_mat)
      if (present(b)) then 
        call psb_rwextd(nr,aa,info,b%a,rowscale)
      else
        call psb_rwextd(nr,aa,info,rowscale=rowscale)
      end if
    type is (psb_s_coo_sparse_mat) 
      if (present(b)) then 
        call psb_rwextd(nr,aa,info,b%a,rowscale=rowscale)
      else
        call psb_rwextd(nr,aa,info,rowscale=rowscale)
      end if
    class default
      call aa%mv_to_coo(actmp,info)
      if (info == psb_success_) then 
        if (present(b)) then 
          call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale)
        else
          call psb_rwextd(nr,actmp,info,rowscale=rowscale)
        end if
      end if
      if (info == psb_success_) call aa%mv_from_coo(actmp,info)
    end select
  end if
  if (info /= psb_success_) goto 9999

  call psb_erractionrestore(err_act)
  return

9999 continue
  call psb_erractionrestore(err_act)
  if (err_act == psb_act_abort_) then
     call psb_error()
     return
  end if
  return

end subroutine psb_srwextd
==================================================================
The calls to AA%MV_TO ad AA%MV_FROM should be able to modify AA, since 
1. AA => A%A
2. A is an INOUT dummy argument. 
Comment 4 janus 2010-08-27 09:06:44 UTC
(In reply to comment #3)
> First, the patch did not apply cleanly, the first hunk was rejected. I applied
> it by hand, and I got a problem down the road in my library: 
> ===============================================================
> gfortran -ggdb -I.. -I../modules -I. -c psb_srwextd.f90
> psb_srwextd.f90:76.13:
> 
>       call aa%mv_to_coo(actmp,info)
>              1
> Error: Actual argument at (1) must be definable as the dummy argument 'a' is
> INTENT = OUT/INOUT
> psb_srwextd.f90:84.39:
> 
>       if (info == psb_success_) call aa%mv_from_coo(actmp,info)
>                                        1
> Error: Actual argument at (1) must be definable as the dummy argument 'a' is
> INTENT = OUT/INOUT

I tried to reproduce this by modifying your original test case, but did not succeed so far. Can you provide a standalone test case for this problem? My feeling is that this is another bug uncovered by the fix for the previous one.

The patch in comment #2 is free of testsuite regressions and certainly does the right thing.
Comment 5 Salvatore Filippone 2010-08-27 11:38:31 UTC
(In reply to comment #4)
> (In reply to comment #3)
> I tried to reproduce this by modifying your original test case, but did not
> succeed so far. Can you provide a standalone test case for this problem? My
> feeling is that this is another bug uncovered by the fix for the previous one.
> 
> The patch in comment #2 is free of testsuite regressions and certainly does the
> right thing.
> 

Ok, go ahead with this fix, and I will open a new PR as appropriate. 

Comment 6 Salvatore Filippone 2010-08-27 14:40:05 UTC
(In reply to comment #3)
       end if
>     class default
>       call aa%mv_to_coo(actmp,info)
>       if (info == psb_success_) then 
>         if (present(b)) then 
>           call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale)
>         else
>           call psb_rwextd(nr,actmp,info,rowscale=rowscale)
>         end if
>       end if
>       if (info == psb_success_) call aa%mv_from_coo(actmp,info)
>     end select
>
If however  I change the code as follows:
     select type(aa => a%a)
            ........
     class default
       call a%a%mv_to_coo(actmp,info)
  .......

it compiles. 
Comment 7 janus 2010-08-27 19:02:32 UTC
Subject: Bug 45420

Author: janus
Date: Fri Aug 27 19:02:15 2010
New Revision: 163594

URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=163594
Log:
2010-08-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45420
	* match.c (select_type_set_tmp): Add the possibility to reset the
	temporary to NULL.
	(gfc_match_class_is): Reset the temporary in CLASS DEFAULT clauses.


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

	PR fortran/45420
	* gfortran.dg/select_type_15.f03: New.

Added:
    trunk/gcc/testsuite/gfortran.dg/select_type_15.f03
Modified:
    trunk/gcc/fortran/ChangeLog
    trunk/gcc/fortran/match.c
    trunk/gcc/testsuite/ChangeLog

Comment 8 janus 2010-08-27 19:14:38 UTC
Fixed with r163594. Closing.

(Salvatore, please open a new PR for your problem in comment #3 if you have reduced it.)
Comment 9 janus 2010-08-27 19:15:26 UTC
Closing.