PROCEDURE declaration in v11 redux

[ender01]

Hello,

I'm (still) trying to set procedure pointers in a derived type. I've been able to get it to work in simple examples (thanks to Steve) but as soon as I try somthing more complicated (the derived type now contains an allocatable array of another derived type) it will not compile. Here's example code:

[cpp]module foo_Mod
   implicit none
   
   !  Precision constants
   integer, parameter:: HI=selected_real_kind(12)
   integer, parameter:: LO=selected_real_kind(5)
   integer, parameter:: I_HI=selected_int_kind(9)
   integer, parameter:: I_LO=selected_int_kind(4)
  
   !  Define foo object
	type foo
      integer(kind=I_LO) :: foo_size
		character(len=1), dimension(:), allocatable :: foo_var
	end type foo
	
	!  Define fooFoo object
   type fooFoo
      integer(kind=I_LO) :: foo_len
      type(foo), dimension(:), allocatable :: foo_var
      procedure(parse_FooFunc), pointer, pass(base_fooFoo) :: getSubfoo
   end type fooFoo
   
   !  Define abstract interfaces for type-bound procedures
   abstract interface
       function parse_FooFunc(base_fooFoo,l_Bound,u_Bound) 
         import
			type(fooFoo), intent(in)  :: base_fooFoo
			integer(kind=I_LO), intent(in)  :: l_Bound, u_Bound
			type(fooFoo) :: parse_FooFunc
	   end function parse_FooFunc
	end interface
	
	!  Define assignment interface
   interface assignment(=)
      module procedure set_foo
      module procedure set_fooFoo
   end interface
	
	!  Define generic interface for len function
   interface len
      module procedure get_Size
      module procedure get_Length
   end interface

contains
   function new_foo(foo_len,foo_var) result(newFoo)
      implicit none
      
      character(len=1), dimension(:), intent(in), optional :: foo_var
      integer(kind=I_LO), intent(in), optional :: foo_len
      type(foo) :: newFoo
      
      integer(kind=I_LO) :: fooLen
      logical :: alloc_Flag
      
      !  See if optional arguements are present
      if (present(foo_len)) then
         fooLen = foo_len
      else
         fooLen = 0
      end if
      
      alloc_Flag = .False.
      if (present(foo_var)) then
         alloc_Flag = .True.
      end if
      
      !  Construct new foo object
      newFoo%foo_size = fooLen
      if (alloc_Flag) then
         allocate(newFoo%foo_var(len(foo_var)))
         newFoo%foo_var = foo_var
      end if
      
      return
   end function new_foo
   
   pure subroutine set_foo(base_foo,new_fooVar)
		   implicit none

			type(foo), intent(inout)  :: base_foo
			character(len=*), intent(in) :: new_fooVar
			
			integer(kind=I_LO) :: kount, new_Size
			
			logical :: alloc_Flag, assoc_Flag
			
			!  Get length of new foo_var
         new_Size = len(new_fooVar)
			
			!  As this may be a redefinition of base_foo check allocation
         !  status and set alloc_Flag to true if foo_var must be allocated
         alloc_Flag = .not. allocated(base_foo%foo_var)
         
         !  Test that any allocation is appropriate
         if (.not. alloc_Flag) then
            !  foo_var has already been allocated, is it the right size
            alloc_Flag = len(base_foo) /= new_Size
            
            !  If foo_var has the wrong size, deallocate
            if (alloc_Flag) then
               deallocate(base_foo%foo_var)
            end if
         end if

         !  If necessary, resize and allocate storage array
         if (alloc_Flag) then
            base_foo%foo_size = new_Size
            allocate(base_foo%foo_var(new_Size))
         end if

         !  Assign new foo_var to base foo object
         do kount = 1,len(base_foo)
            base_foo%foo_var(kount) = new_fooVar(kount:kount)
         end do
         
         return
      end subroutine set_foo
      
      pure function get_Size(base_foo)  result(foo_Size)
		   implicit none

			type(foo), intent(in)  :: base_foo
			integer(kind=I_LO) :: foo_Size
			
			!  Extract foo_var size
			foo_Size = base_foo%foo_size

      end function get_Size
      
      function new_fooFoo(fooFoo_len,fooFoo_var) result(newFooFoo)
         implicit none
         
         type(foo), dimension(:), intent(in), optional :: fooFoo_var
         integer(kind=I_LO), intent(in), optional :: fooFoo_len
         type(fooFoo) :: newFooFoo
         
         integer(kind=I_LO) :: fooFooLen
         logical :: alloc_Flag
         
         !  See if optional arguements are present
         if (present(fooFoo_len)) then
            fooFooLen = fooFoo_len
         else
            fooFooLen = 0
         end if
         
         alloc_Flag = .False.
         if (present(fooFoo_var)) then
            alloc_Flag = .True.
         end if
         
         !  Construct new foo object
         newFooFoo%foo_len = fooFooLen
         if (alloc_Flag) then
            allocate(newFooFoo%foo_var(size(fooFoo_var)))
            newFooFoo%foo_var = fooFoo_var
         end if
         
         !  Associate function pointers
         newFooFoo%getSubfoo => get_Subfoo
         
         return
      end function new_fooFoo
      
      pure subroutine set_fooFoo(base_fooFoo,foo_Foo)
		   implicit none
		   
		   type(fooFoo), intent(inout) :: base_fooFoo
		   type(foo), dimension(:), intent(in) :: foo_Foo
		   
		   integer(kind=I_LO) :: kount, new_fooLen
			
			logical :: alloc_Flag, assoc_Flag
			
			!  Get length of new fooFoo
         new_fooLen = size(foo_Foo)
			
			!  As this may be a redefinition of the fooFoo check allocation
         !  status and set alloc_Flag to true if foo_var must be allocated
         alloc_Flag = .not. allocated(base_fooFoo%foo_var)
         
         !  Test that any allocation is appropriate
         if (.not. alloc_Flag) then
            !  foo_var has already been allocated, is it the right size
            alloc_Flag = len(base_fooFoo) /= new_fooLen
            
            !  If string has the wrong size, deallocate
            if (alloc_Flag) then
               deallocate(base_fooFoo%foo_var)
            end if
         end if

         !  If necessary, resize and allocate storage array
         if (alloc_Flag) then
            base_fooFoo%foo_Len = new_fooLen
            allocate(base_fooFoo%foo_var(new_fooLen))
         end if

         !  Assign new foo_var to base fooFoo object
         base_fooFoo%foo_var = foo_foo
         
         return
		end subroutine set_fooFoo
		
		pure function get_Length(base_fooFoo)  result(foo_Len)
		   implicit none

			type(fooFoo), intent(in)  :: base_fooFoo
			integer(kind=I_LO) :: foo_Len
			
			!  Extract fooFoo length
			foo_Len = base_fooFoo%foo_Len

      end function get_Length
		
		function get_Subfoo(base_fooFoo,l_Bound,u_Bound)
		   implicit none
		   
		   type(fooFoo), intent(in) :: base_fooFoo
		   integer(kind=I_LO), intent(in) :: l_Bound, u_Bound
		   type(fooFoo) :: get_Subfoo
		   
		   !  Create an allocatable object for work
		   type(foo), dimension(:), allocatable :: work
		   
		   integer(kind=I_LO) :: kount, indx, N_lo, N_up
		   logical :: range_Flag
		   
		   !  Make sure that bounds are appropriate
		   !  No graceful exit - exception handling (can't print in pure routine)
		   range_Flag = .True.
		   if (l_Bound < 1 .or. l_Bound > len(base_fooFoo)) then
		      !  l_Bound is not in range
		      !stop 'get_Substring: Lower bound not in range.'
		      range_Flag = .False.
		   elseif (u_Bound < 1 .or. u_Bound > len(base_fooFoo)) then
		      !  u_Bound is not in range
		      !stop 'get_Substring: Upper bound not in range.'
		      range_Flag = .False.
		   elseif (u_Bound < l_Bound) then
		      !  Upper bound is less than lower bound, print warning
		      !write(*,*) '(Warning) get_Substring: Upper bound < Lower bound.'
		      !write(*,*) 'Reversing order of bounds'
		      N_lo = u_Bound
		      N_up = l_Bound
		   else
		      !  Everything is fine, do straight mapping to loop parameters
		      N_lo = l_Bound
		      N_up = u_Bound
		   end if
		   
		   !  If all is well with subfoo bounds, proceed
		   if (range_Flag) then
		      !  Allocate work space
		      allocate(work(N_up-N_lo+1))
   		   
		      !  Loop over base_fooFoo's elements and extract the desired foos
		      do kount = N_lo,N_up
		         indx = kount - N_lo + 1
		         work(indx) = base_fooFoo%foo_var(kount)
		      end do
   		   
		      !  Spawn new fooFoo object associated with work array
		      get_Subfoo = work
		   end if
		   
		   return
		end function get_Subfoo

end module foo_Mod[/cpp]

When I try to complile this, I get an error message #8178: The procedure pointer and the procedure target must have matching arguments. This is on the assignment:

[cpp]newFooFoo%getSubfoo => get_Subfoo
[/cpp]

in the function new_fooFoo. Any ideas why the compiler thinks that the arguments don't match?

Thanks,

Rich

[Steven_L_Intel1 · Accepted solution]

I believe that this is our bug ID DPD200050116 which is being fixed for s future release. The problem occurs when you do a pointer assignment of a contained procedure. Since I think a lot of people will be doing this, I will ask that the fix be released as soon as possible.

[ender01]

Quoting - Steve Lionel (Intel)

I believe that this is our bug ID DPD200050116 which is being fixed for s future release. The problem occurs when you do a pointer assignment of a contained procedure. Since I think a lot of people will be doing this, I will ask that the fix be released as soon as possible.

Thanks Steve! I can stop banging my head on the desk now. I think that you're right, if you're going to support OO you've gotta support that, it's part of the data encapsulation paradigm. I also noticed that I can't hide the individual fields of a derived type. Will that be supported any time soon? Thanks again!

Rich

[Steven_L_Intel1]

Public components of a private type and private components of a public type? That's still some time away.

[ender01]

Quoting - Steve Lionel (Intel)

Public components of a private type and private components of a public type? That's still some time away.

Yup, though I'm interested more in the latter rather than the former.

Thanks,

Rich