This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: Procedure Pointers: a first patch
Hi all,
> I have some more things, which fail. Maybe it makes sense to check-in a
> half-finished patch and continue with the fixing of the smaller items later.
I guess that would make sense. Maybe one can leave out the most exotic
special cases for a start. At least I want to make procptrs work as
formal arguments and return values, then I guess we can start to think
about committing the patch.
I attached a new version, together with some test cases, which should
give you an idea of what the patch can handle at this point.
> implicit none
> external foo
> interface
> subroutine bar()
> end subroutine bar
> end interface
> pointer :: bar
> bar => foo
> end
>
> Error: 'bar' at (1) is not a variable
Works now (see proc_ptr_3.f90).
> Add a test case that "allocate(procptr)" fails. (It currently correctly
> gives an error.)
Done (actually my test cases are still a bit sketchy and not ready for
dejagnu yet).
> The following program should be rejected:
>
> intrinsic sin
> call foo(sin)
> contains
> subroutine foo(x)
> procedure(), pointer :: x
> end subroutine foo
> end
>
> "If a dummy argument is a procedure pointer, the associated actual argument
> shall be a procedure pointer, a reference to a function that returns a
> procedure pointer, or a reference to the NULL intrinsic function."
> (12.4.1.3)
This was rejected already, but with a misleading error message, so I
put in a new one.
At the remaining stuff I will have a look soon (or disregard it as "exotic" ;)
For the moment I'm working on procptr formal arguments and return
values (see proc_ptr_4.f90). In particular I have trouble seeing why I
get a segfault there. Any help appreciated.
(Also I'm seeing a couple of regressions right now, which I will have
to look into ...)
Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90 (revision 135849)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90 (working copy)
@@ -40,8 +40,6 @@ program prog
procedure(dcos) :: my1
procedure(amax0) :: my2 ! { dg-error "not allowed in PROCEDURE statement" }
- procedure(),pointer:: ptr ! { dg-error "not yet implemented" }
-
type t
procedure(),pointer:: p ! { dg-error "not yet implemented" }
end type
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 135849)
+++ gcc/fortran/interface.c (working copy)
@@ -1959,6 +1959,17 @@ compare_actual_formal (gfc_actual_arglis
return 0;
}
+ /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
+ is provided for a procedure pointer formal argument. */
+ if (f->sym->attr.proc_pointer
+ && !a->expr->symtree->n.sym->attr.proc_pointer)
+ {
+ if (where)
+ gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 135849)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -480,8 +480,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr
else if (sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
- gcc_assert (se->want_pointer);
- if (!sym->attr.dummy)
+ if (!sym->attr.dummy && !sym->attr.proc_pointer)
{
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
se->expr = build_fold_addr_expr (se->expr);
@@ -2319,6 +2318,27 @@ gfc_conv_function_call (gfc_se * se, gfc
return 0;
}
+ else if (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+ {
+ gfc_se cptrse;
+ gfc_se fptrse;
+
+ gfc_init_se (&cptrse, NULL);
+ gfc_conv_expr (&cptrse, arg->expr);
+ gfc_add_block_to_block (&se->pre, &cptrse.pre);
+ gfc_add_block_to_block (&se->post, &cptrse.post);
+
+ gfc_init_se (&fptrse, NULL);
+ gfc_conv_expr (&fptrse, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &fptrse.pre);
+ gfc_add_block_to_block (&se->post, &fptrse.post);
+
+ tmp = arg->next->expr->symtree->n.sym->backend_decl;
+ se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
+ fold_convert (TREE_TYPE (tmp), cptrse.expr));
+
+ return 0;
+ }
else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
gfc_se arg1se;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 135849)
+++ gcc/fortran/symbol.c (working copy)
@@ -410,13 +410,18 @@ check_conflict (symbol_attribute *attr,
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
- case FL_PROCEDURE:
case FL_DERIVED:
case FL_PARAMETER:
a1 = gfc_code2string (flavors, attr->flavor);
a2 = save;
goto conflict;
+ case FL_PROCEDURE:
+ if (attr->proc_pointer) break;
+ a1 = gfc_code2string (flavors, attr->flavor);
+ a2 = save;
+ goto conflict;
+
case FL_VARIABLE:
case FL_NAMELIST:
default:
@@ -555,13 +560,6 @@ check_conflict (symbol_attribute *attr,
conf (procedure, value)
conf (procedure, volatile_)
conf (procedure, entry)
- /* TODO: Implement procedure pointers. */
- if (attr->procedure && attr->pointer)
- {
- gfc_error ("Fortran 2003: Procedure pointers at %L are "
- "not yet implemented in gfortran", where);
- return FAILURE;
- }
a1 = gfc_code2string (flavors, attr->flavor);
@@ -617,11 +615,11 @@ check_conflict (symbol_attribute *attr,
break;
case FL_PROCEDURE:
- conf2 (intent);
+ if (!attr->proc_pointer)
+ conf2 (intent);
if (attr->subroutine)
{
- conf2 (pointer);
conf2 (target);
conf2 (allocatable);
conf2 (result);
@@ -848,6 +846,12 @@ gfc_add_external (symbol_attribute *attr
return FAILURE;
}
+ if (attr->pointer)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->external = 1;
return check_conflict (attr, NULL, where);
@@ -898,7 +902,18 @@ gfc_add_pointer (symbol_attribute *attr,
if (check_used (attr, NULL, where))
return FAILURE;
- attr->pointer = 1;
+ if (attr->pointer)
+ {
+ duplicate_attr ("POINTER", where);
+ return FAILURE;
+ }
+
+ if (attr->procedure || attr->function || attr->subroutine || attr->external
+ || (attr->flavor == FL_PROCEDURE))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
return check_conflict (attr, NULL, where);
}
@@ -1319,6 +1334,12 @@ gfc_add_flavor (symbol_attribute *attr,
return FAILURE;
}
+ if (f == FL_PROCEDURE && attr->pointer)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->flavor = f;
return check_conflict (attr, name, where);
@@ -1616,6 +1637,8 @@ gfc_copy_attr (symbol_attribute *dest, s
goto fail;
if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
goto fail;
+ if (src->proc_pointer)
+ dest->proc_pointer = 1;
return SUCCESS;
@@ -3517,7 +3540,7 @@ static void
gen_fptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
- gfc_namespace *ns, const char *f_ptr_name)
+ gfc_namespace *ns, const char *f_ptr_name, int proc)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
@@ -3536,7 +3559,10 @@ gen_fptr_param (gfc_formal_arglist **hea
/* Set up the necessary fields for the fptr output param sym. */
param_sym->refs++;
- param_sym->attr.pointer = 1;
+ if (proc)
+ param_sym->attr.proc_pointer = 1;
+ else
+ param_sym->attr.pointer = 1;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
@@ -3715,21 +3741,23 @@ build_formal_args (gfc_symbol *new_proc_
gfc_current_ns->proc_name = new_proc_sym;
/* Generate the params. */
- if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
- (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr");
-
+ gfc_current_ns, "fptr", 1);
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 0);
/* If we're dealing with c_f_pointer, it has an optional third arg. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_shape_param (&head, &tail,
- (const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
- }
+ gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+
}
else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 135849)
+++ gcc/fortran/decl.c (working copy)
@@ -4033,6 +4033,7 @@ match_procedure_decl (void)
locus old_loc, entry_loc;
gfc_symbol *sym, *proc_if = NULL;
int num;
+ gfc_expr *initializer = NULL;
old_loc = entry_loc = gfc_current_locus;
@@ -4149,7 +4150,7 @@ got_ts:
return MATCH_ERROR;
}
- if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_external (&sym->attr, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
@@ -4169,6 +4170,36 @@ got_ts:
sym->attr.function = sym->ts.interface->attr.function;
}
+ if (gfc_match (" =>") == MATCH_YES)
+ {
+ if (!current_attr.pointer)
+ {
+ gfc_error ("Initialization at %C isn't for a pointer variable");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ m = gfc_match_null (&initializer);
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Pointer initialization requires a NULL() at %C");
+ m = MATCH_ERROR;
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Initialization of pointer at %C is not allowed in "
+ "a PURE procedure");
+ m = MATCH_ERROR;
+ }
+
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ }
+
+ gfc_set_sym_referenced (sym);
+
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
@@ -4178,6 +4209,11 @@ got_ts:
syntax:
gfc_error ("Syntax error in PROCEDURE statement at %C");
return MATCH_ERROR;
+
+cleanup:
+ /* Free stuff up and return. */
+ gfc_free_expr (initializer);
+ return m;
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 135849)
+++ gcc/fortran/gfortran.h (working copy)
@@ -619,7 +619,7 @@ typedef struct
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
- implied_index:1, subref_array_pointer:1;
+ implied_index:1, subref_array_pointer:1, proc_pointer:1;
ENUM_BITFIELD (save_state) save:2;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 135849)
+++ gcc/fortran/expr.c (working copy)
@@ -2873,7 +2873,7 @@ gfc_check_pointer_assign (gfc_expr *lval
int is_pure;
int pointer, check_intent_in;
- if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
+ if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN && !lvalue->symtree->n.sym->attr.proc_pointer)
{
gfc_error ("Pointer assignment target is not a POINTER at %L",
&lvalue->where);
@@ -2893,7 +2893,8 @@ gfc_check_pointer_assign (gfc_expr *lval
/* Check INTENT(IN), unless the object itself is the component or
sub-component of a pointer. */
check_intent_in = 1;
- pointer = lvalue->symtree->n.sym->attr.pointer;
+ pointer = lvalue->symtree->n.sym->attr.pointer
+ | lvalue->symtree->n.sym->attr.proc_pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
{
@@ -2932,6 +2933,10 @@ gfc_check_pointer_assign (gfc_expr *lval
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
+ /* TODO checks on rvalue for a procedure pointer assignment. */
+ if (lvalue->symtree->n.sym->attr.proc_pointer)
+ return SUCCESS;
+
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L; attempted "
@@ -2973,7 +2978,7 @@ gfc_check_pointer_assign (gfc_expr *lval
lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
attr = gfc_expr_attr (rvalue);
- if (!attr.target && !attr.pointer)
+ if (!attr.target && !attr.pointer && lvalue->ts.type!=BT_PROCEDURE)
{
gfc_error ("Pointer assignment target is neither TARGET "
"nor POINTER at %L", &rvalue->where);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 135849)
+++ gcc/fortran/match.c (working copy)
@@ -26,6 +26,7 @@ along with GCC; see the file COPYING3.
#include "match.h"
#include "parse.h"
+int gfc_matching_procptr_assignment = 0;
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
@@ -1329,6 +1330,7 @@ gfc_match_pointer_assignment (void)
old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
+ gfc_matching_procptr_assignment = 0;
m = gfc_match (" %v =>", &lvalue);
if (m != MATCH_YES)
@@ -1337,7 +1339,11 @@ gfc_match_pointer_assignment (void)
goto cleanup;
}
+ if (lvalue->symtree->n.sym->attr.proc_pointer)
+ gfc_matching_procptr_assignment = 1;
+
m = gfc_match (" %e%t", &rvalue);
+ gfc_matching_procptr_assignment = 0;
if (m != MATCH_YES)
goto cleanup;
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 135849)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -1104,6 +1104,31 @@ gfc_restore_sym (gfc_symbol * sym, gfc_s
}
+/* Declare a procedure pointer. */
+
+static tree
+get_proc_pointer_decl (gfc_symbol *sym)
+{
+ tree decl;
+
+ decl = sym->backend_decl;
+ if (decl)
+ return decl;
+
+ decl = build_decl (VAR_DECL, get_identifier (sym->name),
+ build_pointer_type (gfc_get_function_type (sym)));
+
+ if (sym->ns->proc_name->backend_decl == current_function_decl
+ || sym->attr.contained)
+ gfc_add_decl_to_function (decl);
+ else
+ gfc_add_decl_to_parent_function (decl);
+
+ sym->backend_decl = decl;
+ return decl;
+}
+
+
/* Get a basic decl for an external function. */
tree
@@ -1126,6 +1151,9 @@ gfc_get_extern_function_decl (gfc_symbol
to know that. */
gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
+ if (sym->attr.proc_pointer)
+ return get_proc_pointer_decl (sym);
+
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 135849)
+++ gcc/fortran/match.h (working copy)
@@ -33,6 +33,8 @@ extern gfc_symbol *gfc_new_block;
separate. */
extern gfc_st_label *gfc_statement_label;
+extern int gfc_matching_procptr_assignment;
+
/****************** All gfc_match* routines *****************/
/* match.c. */
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 135849)
+++ gcc/fortran/primary.c (working copy)
@@ -2324,6 +2324,9 @@ gfc_match_rvalue (gfc_expr **result)
}
}
+ if (gfc_matching_procptr_assignment)
+ goto procptr0;
+
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
goto function0;
@@ -2400,6 +2403,23 @@ gfc_match_rvalue (gfc_expr **result)
/* If we're here, then the name is known to be the name of a
procedure, yet it is not sure to be the name of a function. */
case FL_PROCEDURE:
+
+ /* Procedure Pointer Assignments. */
+ procptr0:
+ if (gfc_matching_procptr_assignment)
+ {
+ if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+ if (gfc_intrinsic_name (sym->name, 0)
+ || gfc_intrinsic_name (sym->name, 1))
+ sym->attr.intrinsic = 1;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = symtree;
+ m = match_varspec (e, 0);
+ /* TODO: Parse functions returning a procptr. */
+ break;
+ }
+
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
@@ -2781,6 +2801,9 @@ match_variable (gfc_expr **result, int e
break;
}
+ if (sym->attr.proc_pointer)
+ break;
+
/* Fall through to error */
default:
! basic tests of PROCEDURE POINTERS
module m
contains
subroutine proc1(arg)
character (5) :: arg
arg = "proc1"
print *,"proc1!"
end subroutine
integer function proc2(arg)
integer, intent(in) :: arg
proc2 = arg**2
print *,"proc2!"
end function
complex function proc3(re, im)
real, intent(in) :: re, im
proc3 = complex (re, im)
print *,"proc3!"
end function
end module
subroutine foo1
print *,"foo1!"
end subroutine
real function foo2()
foo2=6.3
print *,"foo2!"
end function
program procPtrTest
use m, only: proc1, proc2, proc3
character (5) :: str
PROCEDURE(proc1), POINTER :: ptr1
PROCEDURE(proc2), POINTER :: ptr2
PROCEDURE(proc3), POINTER :: ptr3 => NULL()
PROCEDURE(REAL), SAVE, POINTER :: ptr4
PROCEDURE(), POINTER :: ptr5,ptr6
external :: foo1,foo2
real :: foo2
ptr1 => proc1
call ptr1 (str)
if (str .ne. "proc1") call abort ()
ptr2 => proc2
if (10*ptr2 (10) .ne. 1000) call abort ()
ptr3 => proc3
if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort ()
ptr4 => cos
if (ptr4(0.0)/=1.0) call abort()
ptr5 => foo1
call ptr5()
ptr6 => foo2
if (ptr6()/=6.3) call abort()
print *,"success!"
end program
! checking invalid code for PROCEDURE POINTERS
program proc_ptr_2
implicit none
PROCEDURE(REAL), POINTER :: ptr
PROCEDURE(REAL), SAVE :: noptr ! forbidden !
ptr => cos(4.0) ! forbidden !
allocate(ptr) ! forbidden !
end program
! PROCEDURE POINTERS without the PROCEDURE statement
real function e1(x)
real :: x
print *,'e1!',x
bar = x * 3.0
end function
subroutine e2(a,b)
real, intent(inout) :: a
real, intent(in) :: b
print *,'e2!',a,b
a = a + b
end subroutine
program proc_ptr_3
real, external, pointer :: fp
pointer :: sp
interface
subroutine sp(a,b)
real, intent(inout) :: a
real, intent(in) :: b
end subroutine sp
end interface
external :: foo,bar
real :: c = 1.2
fp => e1
if (abs(fp(2.5)-7.5)>0.01) call abort()
sp => e2
call sp(c,3.4)
if (abs(c-4.6)>0.01) call abort()
print *,'success!'
end
! PROCEDURE POINTERS as actual/formal arguments (and return values)
subroutine foo
print *,"foo"
end subroutine
program proc_ptr_4
PROCEDURE(),POINTER :: ptr1
PROCEDURE(REAL),POINTER :: ptr2
EXTERNAL foo
ptr1 => foo
call s_in(ptr1)
!call s_out(sin) ! forbidden !
call s_out(ptr2)
print *,ptr2(-3.0) ! segmentation fault !?!
contains
subroutine s_in(p)
PROCEDURE(),POINTER,INTENT(IN) :: p
call p()
end subroutine
subroutine s_out(p)
PROCEDURE(REAL),POINTER,INTENT(OUT) :: p
p => abs
end subroutine
! function f() result(r)
! PROCEDURE(),POINTER :: r
! end function
end program