This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [4.5, Patch, Fortran] PR 36704: Procedure pointer as function result


2009/4/8 Tobias Burnus <burnus@net-b.de>:
>
> ! compile with -std=f95
> function f()
> ?intrinsic sin
> ?external f
> ?pointer f
> ?real f
> ! ICE without the following line
> ! strange error with that line
> ! ?f => sin
> end function f

Good catch. Already the following should be rejected with -std=f95:

  external f
  pointer f

So I guess I will open a separate PR for this. The F95 standard does
not explicitly mention procedure pointers anywhere, and forbids a
symbol to have the EXTERNAL and POINTER attributes at the same time
(see section 5.1).


> Some tiny nit found while reading the patch:
>
> ?function aux()
> ? ?external aux
> ? ?pointer aux
> ?end function
>
> Can you add a "aux=>something" line there? I know the warning is not
> triggered as the error message for "foo" comes earlier but ...
>
> module mo
> contains
> ?function j()
> ? ?procedure(),pointer :: j
> ? ?j => iabs
>
> Pedantically, I would add an "intrinsic iabs".

Ok, updated the test cases accordingly. I will commit the patch later
today, provided there are no further objections.

Cheers,
Janus



>> 2009-04-08 ?Janus Weil ?<janus@gcc.gnu.org>
>>
>> ? ? ? PR fortran/36704
>> ? ? ? * decl.c (add_hidden_procptr_result): New function for handling
>> ? ? ? procedure pointer return values by adding a hidden result variable.
>> ? ? ? (variable_decl,match_procedure_decl,gfc_match_function_decl,
>> ? ? ? gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
>> ? ? ? return values.
>> ? ? ? * parse.c (parse_interface): Add EXTERNAL attribute only after
>> ? ? ? FUNCTION/SUBROUTINE declaration is complete.
>> ? ? ? * primary.c (replace_hidden_procptr_result): New function for replacing
>> ? ? ? function symbol by hidden result variable.
>> ? ? ? (gfc_match_rvalue,match_variable): Replace symbol by hidden result
>> ? ? ? variable.
>> ? ? ? * resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
>> ? ? ? resolve_symbol): Allow for procedure pointer function results.
>> ? ? ? (resolve_fl_procedure): Conflict detection moved here from
>> ? ? ? 'check_conflict'.
>> ? ? ? * symbol.c (gfc_check_function_type): Allow for procedure pointer
>> ? ? ? function results.
>> ? ? ? (check_conflict): Move some conflict detection to resolution stage.
>> ? ? ? * trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
>> ? ? ? result variables.
>>
>>
>> 2009-04-08 ?Janus Weil ?<janus@gcc.gnu.org>
>>
>> ? ? ? PR fortran/36704
>> ? ? ? * gfortran.dg/external_procedures_1.f90: Modified.
>> ? ? ? * gfortran.dg/proc_ptr_result_1.f90: New.
>> ? ? ? * gfortran.dg/proc_ptr_result_2.f90: New.
>> ? ? ? * gfortran.dg/proc_ptr_result_3.f90: New.
>>
>
! { dg-do run }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

module mo
contains

  function j()
    procedure(),pointer :: j
    intrinsic iabs
    j => iabs
  end function

  subroutine sub(y)
    integer,intent(inout) :: y
    y = y**2
  end subroutine

end module


program proc_ptr_14
use mo
implicit none
intrinsic :: iabs
integer :: x
procedure(integer),pointer :: p,p2
procedure(sub),pointer :: ps

p => a()
if (p(-1)/=1) call abort()
p => b()
if (p(-2)/=2) call abort()
p => c()
if (p(-3)/=3) call abort()
p => d()
if (p(-4)/=4) call abort()
p => dd()
if (p(-4)/=4) call abort()
p => e(iabs)
if (p(-5)/=5) call abort()
p => ee()
if (p(-5)/=5) call abort()
p => f()
if (p(-6)/=6) call abort()
p => g()
if (p(-7)/=7) call abort()

ps => h(sub)
x = 2
call ps(x)
if (x/=4) call abort()

p => i()
if (p(-8)/=8) call abort()
p => j()
if (p(-9)/=9) call abort()

p => k(p2)
if (p(-10)/=p2(-10)) call abort()

p => l()
if (p(-11)/=11) call abort()

contains

  function a()
    procedure(integer),pointer :: a
    a => iabs
  end function

  function b()
    procedure(integer) :: b
    pointer :: b
    b => iabs
  end function

  function c()
    pointer :: c
    procedure(integer) :: c
    c => iabs
  end function

  function d()
    pointer :: d
    external d
    d => iabs
  end function

  function dd()
    pointer :: dd
    external :: dd
    integer :: dd
    dd => iabs
  end function

  function e(arg)
    external :: e,arg
    pointer :: e
    e => arg
  end function

  function ee()
    integer :: ee
    external :: ee
    pointer :: ee
    ee => iabs
  end function

  function f()
    pointer :: f
    interface
      integer function f(x)
        integer :: x
      end function
    end interface
    f => iabs
  end function

  function g()
    interface
      integer function g(x)
        integer :: x
      end function g
    end interface
    pointer :: g
    g => iabs
  end function

  function h(arg)
    interface
      subroutine arg(b)
        integer :: b
      end subroutine arg
    end interface
    pointer :: h
    interface
      subroutine h(a)
        integer :: a
      end subroutine h
    end interface
    h => arg
  end function

  function i()
    pointer :: i
    interface
      function i(x)
        integer :: i,x
      end function i
    end interface
    i => iabs
  end function

  function k(arg)
    procedure(),pointer :: k,arg
    k => iabs
    arg => k
  end function

  function l()
    procedure(iabs),pointer :: l
    integer :: i
    l => iabs
    if (l(-11)/=11) call abort()
  end function 

end

! { dg-final { cleanup-modules "mo" } }

! { dg-do compile }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

module proc_ptr_15

  interface
    function e(x)
      real :: x
      procedure(), pointer :: e
    end function e
  end interface

  interface
    function f(x)
      real :: x
      external :: f
      pointer :: f
    end function
  end interface

  interface
    function g(x)
      real :: x
      pointer :: g
      external :: g
    end function
  end interface

contains

  subroutine point_fun()
    call set_fun(aux)
  end subroutine

  subroutine set_fun(y)
    external :: y
  end subroutine

  function aux()
    external aux
    pointer aux
    intrinsic sin
    aux => sin
  end function

  function foo(x)
    real :: x
    interface
      subroutine foo(i)  ! { dg-error "attribute conflicts with" }
        integer :: i
      end subroutine
    end interface
    !pointer :: foo
  end function

end

! { dg-final { cleanup-modules "proc_ptr_15" } }


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]