This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: Procedure Pointers: a first patch
> (Also I'm seeing a couple of regressions right now, which I will have
> to look into ...)
Here is a new version of the patch, which fixes most of these.
The remaining failures now are:
FAIL: gfortran.dg/f2c_6.f90
FAIL: gfortran.dg/value_4.f90
FAIL: gfortran.fortran-torture/execute/entry_7.f90
All three of these result from the same problem: external
pointer-valued functions!
Consider a definition like this:
integer, external, pointer :: f
Is this object a procedure pointer to an integer-valued function?
Or is it an external definition for the following (pointer-valued) function:
function f()
integer, pointer:: f
...
end function
Good question, isn't it? At first sight it seems to be ambiguous. What
do you think?
Remark: The standard says in 5.1.2.6:
"A procedure that has both the EXTERNAL and POINTER attributes is a
procedure pointer."
So the above is a procedure pointer, and no external procedure? Is it that easy?
Also, how do I tell the difference between these two (which are
slightly less ambiguous):
interface
function f()
integer, pointer :: f
end function
end interface
***
interface
function f()
integer :: f
end function
end interface
pointer :: f
The first one is a pointer-valued function, the second one a procedure
pointer to an integer-valued function. No ambiguity here, right?
But how does gfortran know? Presently I'm identifying procedure
pointers as having
1) the "attr.pointer" attribute
2) one of these:
i) attr.procedure
ii) attr.external
iii) attr.flavor == FL_PROCEDURE && att.if_source == IFSRC_BODY
If those criteria are met, I delete the pointer attribute and set the
proc_pointer attribute (to distinguish it from normal pointers). The
problem is that this identifies both of the above cases as procedure
pointers.
Tricky stuff. Ideas, anyone?
Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90 (revision 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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->external
+ || (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY))
+ 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->if_source == IFSRC_IFBODY && attr->pointer)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->flavor = f;
return check_conflict (attr, name, where);
@@ -1451,6 +1472,12 @@ gfc_add_explicit_interface (gfc_symbol *
return FAILURE;
}
+ if (sym->attr.flavor == FL_PROCEDURE && source == IFSRC_IFBODY && sym->attr.pointer)
+ {
+ sym->attr.pointer = 0;
+ sym->attr.proc_pointer = 1;
+ }
+
sym->formal = formal;
sym->attr.if_source = source;
@@ -1616,6 +1643,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 +3546,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 +3565,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 +3747,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 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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 135859)
+++ 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: