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 freaks,
here goes another update to my procptr patch, taking care of the
following items in Tobi's list:
> ! rejects-valid:
>
> intrinsic sin
> procedure(real), pointer :: a
> a => sin ! Error: Function 'sin' requires an argument list at (1)
> end
>
> ! ice-on-invalid-code:
>
> intrinsic sin
> procedure(real), pointer :: a
> a => sin(4.0) ! ICE in fold_convert, at fold-const.c:2527
> end
>
> ! rejects-valid:
>
> procedure(real), save, pointer :: a
> 1
> Error: PROCEDURE attribute conflicts with SAVE attribute in 'a' at (1)
>
> "C1214 If a procedure entity has the INTENT attribute or SAVE attribute, it
> shall also have the POINTER attribute."
>
> ! rejects-valid:
>
> procedure(one), pointer :: a => null()
> 1
> Error: Initialization at (1) isn't for a pointer variable
>
> ! rejects-valid:
>
> external foo
> procedure(), pointer :: a
> a => foo
> call a()
> end
> ! Error: 'a' at (1) has a type, which is not consistent with the CALL at (2)
>
> ! rejects-valid:
>
> integer :: i, foo
> external foo
> procedure(), pointer :: a
> a => foo
> i = a()
> end
> ! Error: Can't convert PROCEDURE to INTEGER(4) at (1)
Basically all of these should work now.
The last one does compile (provided one implements foo somewhere), but
it only gives useful results if foo is declared as real, because the
return value of "a" is also real (implicitly).
One remaining problem is that the two last snippets work each on their
own, but not when combined into one single program.
I also tried to make PR32580 work, and bashed some error messages, but
now I get:
test32580.f90:(.text+0x33): undefined reference to
`__iso_c_binding_c_f_procpointer_u0'
And I don't quite see what the problem is.
Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90 (revision 135801)
+++ 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/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 135801)
+++ 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);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 135801)
+++ 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->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);
@@ -621,7 +619,6 @@ check_conflict (symbol_attribute *attr,
if (attr->subroutine)
{
- conf2 (pointer);
conf2 (target);
conf2 (allocatable);
conf2 (result);
@@ -3517,7 +3514,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 +3533,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 +3715,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 135801)
+++ 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;
@@ -4169,6 +4170,45 @@ got_ts:
sym->attr.function = sym->ts.interface->attr.function;
}
+ /* Transfer the attribute so that there is no confusion further down
+ the line. */
+ if (sym->attr.pointer)
+ {
+ sym->attr.pointer = 0;
+ sym->attr.proc_pointer = 1;
+ sym->attr.external = 1;
+ }
+
+ 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 +4218,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 135801)
+++ 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 135801)
+++ 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.procedure==0)
{
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/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 135801)
+++ 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.c
===================================================================
--- gcc/fortran/match.c (revision 135801)
+++ 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/match.h
===================================================================
--- gcc/fortran/match.h (revision 135801)
+++ 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 135801)
+++ 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,22 @@ 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);
+ break;
+ }
+
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
@@ -2780,6 +2799,9 @@ match_variable (gfc_expr **result, int e
return MATCH_ERROR;
break;
}
+ /* Check for procedure pointer. */
+ if (sym->attr.procedure && sym->attr.proc_pointer)
+ break;
/* Fall through to error */