Procedure Pointers: a first patch

[Tobias Burnus]

Janus Weil wrote:
> after fixing a few bugs related to PROCEDURE and INTERFACE statements,
> I think it's time for me to return to my procedure pointer patch
> (recent version attached),
>   
Some other comments:

+      case FL_PROCEDURE:
+        if (attr->proc_pointer) break;
+        a1 = gfc_code2string (flavors, attr->flavor);
+            a2 = save;
+        goto conflict;

I think here for a2 a tab got lost.



Issues which should be fixed, but can be deferred to later patches 
(lists here to make sure they are not forgotten and saving me the work 
to go through a stack of old mails again). (They are sometimes only 
loosely related to procpointers themselves. In no particular order.)

* * *

Patch should contain test cases.

* * *

TODO: Check whether proc-pointer-returning functions work.

* * *

procedure(), pointer :: x
common /com/ x
end

Error: PROCEDURE attribute of 'x' conflicts with VARIABLE attribute at (1)

R558 common-block-object is variable-name [ ( explicit-shape-spec-list ) ]
           or proc-pointer-name

I think this should be rather trivial to implement.

* * *

procedure(), pointer :: x => null()
if(associated(x)) call abort()
end

Currently fails with:
Error: 'pointer' argument of 'associated' intrinsic at (1) must be a POINTER

* * *

As the -fdump-tree-original dump shows, "x" is never NULLed in:

procedure(), pointer :: x => null()
call x()
end

* * *

procedure(), pointer :: p
call foo(null(p))
contains
subroutine foo(x)
procedure(), pointer :: x
end subroutine foo
end

Error: 'mold' argument of 'null' intrinsic at (1) must be a POINTER

If you are there, you can also fix:

use iso_c_binding
type(c_funptr)::p
call foo(null(p))
contains
subroutine foo(x)
type(c_funptr)  :: x
end subroutine foo
end

and also the same for type(c_ptr).

* * *

integer, pointer :: p
call foo(p)
contains
subroutine foo()
procedure(), pointer :: x
end subroutine foo
end

I think the error message should be more helpful:
Error: More actual than formal arguments in procedure call at (1)

* * *

use iso_c_binding
implicit none
type(c_funptr) :: cptr
integer,pointer :: fptr
call c_f_pointer(cptr,fptr) ! INVALID, but accepted
end

Can you fix it? (type(c_funptr) is invalid for c_f_pointer.) I think the 
other permutations work, but one should check them.


* * *

"7.4.2.2 Procedure pointer assignment" [...]
"If proc-pointer-object has an explicit interface, its characteristics 
shall be the same as proc-target except that proc-target may be pure 
even if proc-pointer-object is not pure and proc-target may be an 
elemental intrinsic procedure even if proc-pointer-object is not elemental.

"If the characteristics of proc-pointer-object or proc-target are such 
that an explicit interface is required, both proc-pointer-object and 
proc-target shall have an explicit interface.

"If proc-pointer-object has an implicit interface and is explicitly 
typed or referenced as a function, proc target shall be a function. If 
proc-pointer-object has an implicit interface and is referenced as a 
subroutine, proc-target shall be a subroutine.

"If proc-target and proc-pointer-object are functions, they shall have 
the same type; corresponding type parameters shall either both be 
deferred or both have the same value."

I believe the following program is thus invalid as the assumed-shape 
array requires an explicit interface:

external foo
interface
 subroutine bar(a)
    integer :: a(:)
 end subroutine bar
end interface
procedure(), pointer :: a
procedure(bar), pointer :: b
a => bar
b => foo
end

* * *

The following program is rejected:

Error: 'p' at (1) is not a variable
Error: Actual argument for 'p' must be a pointer at (1)


! PROCEDURE POINTERS as actual/formal arguments (and return values)
subroutine foo
  print *,"foo"
end subroutine

program proc_ptr_4
implicit none
PROCEDURE(),POINTER :: ptr1
PROCEDURE(REAL),POINTER :: ptr2
EXTERNAL foo

ptr1 => foo
call s_in(ptr1)
call s_out(ptr2)
print *,ptr2(-3.0)

contains

subroutine s_in(p)
  PROCEDURE(),POINTER,INTENT(IN) :: p
  call p()
end subroutine

subroutine s_out(p)
  PROCEDURE(REAL),POINTER,INTENT(OUT) :: p
  intrinsic abs
  p => abs
end subroutine
end program


Tobias