This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran 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] | |
Hi Tobi, hi all, >>> Well, the problem is that the procedure pointer is passed as value and >>> not as reference. >>> See http://gcc.gnu.org/ml/fortran/2008-05/msg00299.html > > Try the attached patch (on top of your patch) and the attached test program: thanks a lot for taking care of this. I'm sorry have not yet managed to look into this myself, but my diploma thesis is keeping me insanely busy at the moment. > I'm not sure whether my patch is really elegant, but it seems to work ;-) I'd say functionality beats elegance here :) And indeed your patch works very well. I included it in the updated version of the complete procptr patch, which is attached. Your patch also fixes my test case "proc_ptr_6.f90". I included your test case into my series as "proc_ptr_7.f90", and also included Joost's original test case from PR32580 as "proc_ptr_8.f90". So, now that procptrs as actual arguments are working, do you think we can dare to commit the patch? Of course it does not fully implement all aspects of procedure pointers yet. Some things which are still missing are: procptr components, functions returning procptrs, procptrs in COMMON, some checking etc. On the other hand the patch already provides a solid implementation of the most important procptr functionality (which can surely stand up to what most other compilers have so far). The remaining features could be added in a follow-up patch. An early commit would also allow for wider testing. Any other arguments for/against committing now/later? Or is there anything else we should definitely include in the first commit? Cheers, Janus 2008-06-25 Janus Weil <janus@gcc.gnu.org> Tobias Burnus <burnus@net-b.de> Paul Thomas <pault@gcc.gnu.org> PR fortran/32580 * gfortran.h (struct gfc_symbol): New member "proc_pointer". * check.c (gfc_check_associated,gfc_check_null): Implement procedure pointers. * decl.c (match_procedure_decl): Ditto. * expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto. * interface.c (compare_actual_formal): Ditto. * match.h: Ditto. * match.c (gfc_match_pointer_assignment): Ditto. * parse.c (parse_interface): Ditto. * primary.c (gfc_match_rvalue,match_variable): Ditto. * resolve.c (resolve_fl_procedure): Ditto. * symbol.c (check_conflict,gfc_add_external,gfc_add_pointer, gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto. * trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl, create_function_arglist): Ditto. * trans-expr.c (gfc_conv_variable,gfc_conv_function_val, gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto. 2008-06-25 Janus Weil <janus@gcc.gnu.org> Tobias Burnus <burnus@net-b.de> PR fortran/32580 * gfortran.dg/c_f_pointer_tests_3.f90: Updated. * gfortran.dg/proc_decl_1.f90: Updated. * gfortran.dg/proc_ptr_1.f90: New. * gfortran.dg/proc_ptr_2.f90: New. * gfortran.dg/proc_ptr_3.f90: New. * gfortran.dg/proc_ptr_4.f90: New. * gfortran.dg/proc_ptr_5.f90: New. * gfortran.dg/proc_ptr_6.f90: New. * gfortran.dg/proc_ptr_7.f90: New. * gfortran.dg/proc_ptr_8.f90: New.
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90 (revision 137120)
+++ 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/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 (revision 137120)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 (working copy)
@@ -14,11 +14,11 @@ program test
type(c_funptr) :: cfunptr
integer(4), pointer :: fptr
integer(4), pointer :: fptr_array(:)
-! procedure(integer(4)), pointer :: fprocptr ! TODO
+ procedure(integer(4)), pointer :: fprocptr
call c_f_pointer(cptr, fptr)
call c_f_pointer(cptr, fptr_array, [ 1 ])
-! call c_f_procpointer(cfunptr, fprocptr) ! TODO
+ call c_f_procpointer(cfunptr, fprocptr)
end program test
! Make sure there is only a single function call:
@@ -30,6 +30,6 @@ end program test
! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } }
!
! Check c_f_procpointer
-! TODO { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } } TODO
+! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } }
!
! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 137120)
+++ 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 137120)
+++ 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);
@@ -1372,6 +1371,8 @@ gfc_conv_function_val (gfc_se * se, gfc_
if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
+ if (sym->attr.proc_pointer)
+ tmp = build_fold_indirect_ref (tmp);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
}
@@ -2498,9 +2499,10 @@ gfc_conv_function_call (gfc_se * se, gfc
else
{
gfc_conv_expr_reference (&parmse, e);
- if (fsym && fsym->attr.pointer
- && fsym->attr.flavor != FL_PROCEDURE
- && e->expr_type != EXPR_NULL)
+ if (fsym && e->expr_type != EXPR_NULL
+ && ((fsym->attr.pointer
+ && fsym->attr.flavor != FL_PROCEDURE)
+ || fsym->attr.proc_pointer))
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
@@ -3867,6 +3869,11 @@ gfc_trans_pointer_assignment (gfc_expr *
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
+
+ if (expr1->symtree->n.sym->attr.proc_pointer
+ && expr1->symtree->n.sym->attr.dummy)
+ lse.expr = build_fold_indirect_ref (lse.expr);
+
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_modify_expr (&block, lse.expr,
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 137120)
+++ 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:
@@ -557,13 +562,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);
@@ -619,11 +617,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);
@@ -866,6 +864,12 @@ gfc_add_external (symbol_attribute *attr
return FAILURE;
}
+ if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->external = 1;
return check_conflict (attr, NULL, where);
@@ -916,7 +920,20 @@ gfc_add_pointer (symbol_attribute *attr,
if (check_used (attr, NULL, where))
return FAILURE;
- attr->pointer = 1;
+ if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ {
+ duplicate_attr ("POINTER", where);
+ return FAILURE;
+ }
+
+ if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+ || (attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
return check_conflict (attr, NULL, where);
}
@@ -1641,6 +1658,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;
@@ -3574,7 +3593,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;
@@ -3593,7 +3612,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;
@@ -3773,21 +3795,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 137120)
+++ gcc/fortran/decl.c (working copy)
@@ -4065,6 +4065,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;
@@ -4183,7 +4184,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;
@@ -4203,6 +4204,40 @@ 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;
+
+ if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
+ != SUCCESS)
+ goto cleanup;
+
+ }
+
+ gfc_set_sym_referenced (sym);
+
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
@@ -4212,6 +4247,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 137120)
+++ gcc/fortran/gfortran.h (working copy)
@@ -620,7 +620,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 137120)
+++ gcc/fortran/expr.c (working copy)
@@ -2874,7 +2874,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);
@@ -2894,7 +2894,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)
{
@@ -2933,6 +2934,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 "
@@ -2974,7 +2979,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);
@@ -3024,7 +3029,7 @@ gfc_check_assign_symbol (gfc_symbol *sym
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer)
+ if (sym->attr.pointer || sym->attr.proc_pointer)
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 137120)
+++ gcc/fortran/resolve.c (working copy)
@@ -7330,7 +7330,8 @@ resolve_fl_procedure (gfc_symbol *sym, i
}
}
- if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
+ if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer)
{
gfc_error ("Function '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
@@ -7338,8 +7339,8 @@ resolve_fl_procedure (gfc_symbol *sym, i
}
/* An external symbol may not have an initializer because it is taken to be
- a procedure. */
- if (sym->attr.external && sym->value)
+ a procedure. Exception: Procedure Pointers. */
+ if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 137120)
+++ 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 137120)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -1104,6 +1104,44 @@ 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;
+
+ if (!sym->attr.use_assoc
+ && (sym->attr.save != SAVE_NONE || sym->attr.data
+ || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+ TREE_STATIC (decl) = 1;
+
+ if (TREE_STATIC (decl) && sym->value)
+ {
+ /* Add static initializer. */
+ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+ TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+ }
+
+ return decl;
+}
+
+
/* Get a basic decl for an external function. */
tree
@@ -1126,6 +1164,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
@@ -1540,6 +1581,9 @@ create_function_arglist (gfc_symbol * sy
type = gfc_sym_type (f->sym);
}
+ if (f->sym->attr.proc_pointer)
+ type = build_pointer_type (type);
+
/* Build a the argument declaration. */
parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 137120)
+++ 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/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 137120)
+++ gcc/fortran/parse.c (working copy)
@@ -1992,6 +1992,11 @@ loop:
new_state = COMP_SUBROUTINE;
else if (st == ST_FUNCTION)
new_state = COMP_FUNCTION;
+ if (gfc_new_block->attr.pointer)
+ {
+ gfc_new_block->attr.pointer = 0;
+ gfc_new_block->attr.proc_pointer = 1;
+ }
if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL) == FAILURE)
{
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 137120)
+++ gcc/fortran/check.c (working copy)
@@ -584,7 +584,7 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y
try
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
- symbol_attribute attr;
+ symbol_attribute attr1, attr2;
int i;
try t;
locus *where;
@@ -592,15 +592,15 @@ gfc_check_associated (gfc_expr *pointer,
where = &pointer->where;
if (pointer->expr_type == EXPR_VARIABLE)
- attr = gfc_variable_attr (pointer, NULL);
+ attr1 = gfc_variable_attr (pointer, NULL);
else if (pointer->expr_type == EXPR_FUNCTION)
- attr = pointer->symtree->n.sym->attr;
+ attr1 = pointer->symtree->n.sym->attr;
else if (pointer->expr_type == EXPR_NULL)
goto null_arg;
else
gcc_assert (0); /* Pointer must be a variable or a function. */
- if (!attr.pointer)
+ if (!attr1.pointer && !attr1.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
@@ -617,9 +617,9 @@ gfc_check_associated (gfc_expr *pointer,
goto null_arg;
if (target->expr_type == EXPR_VARIABLE)
- attr = gfc_variable_attr (target, NULL);
+ attr2 = gfc_variable_attr (target, NULL);
else if (target->expr_type == EXPR_FUNCTION)
- attr = target->symtree->n.sym->attr;
+ attr2 = target->symtree->n.sym->attr;
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
@@ -628,7 +628,7 @@ gfc_check_associated (gfc_expr *pointer,
return FAILURE;
}
- if (!attr.pointer && !attr.target)
+ if (attr1.pointer && !attr2.pointer && !attr2.target)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1],
@@ -2071,7 +2071,7 @@ gfc_check_null (gfc_expr *mold)
attr = gfc_variable_attr (mold, NULL);
- if (!attr.pointer)
+ if (!attr.pointer && !attr.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0],
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 137120)
+++ gcc/fortran/primary.c (working copy)
@@ -2323,6 +2323,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;
@@ -2399,6 +2402,27 @@ 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)
+ {
+ gfc_gobble_whitespace ();
+ if (sym->attr.function && gfc_peek_ascii_char () == '(')
+ /* Parse functions returning a procptr. */
+ goto function0;
+
+ 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 +2804,9 @@ match_variable (gfc_expr **result, int e
break;
}
+ if (sym->attr.proc_pointer)
+ break;
+
/* Fall through to error */
default:
Attachment:
proc_ptr_1.f90
Description: Binary data
Attachment:
proc_ptr_2.f90
Description: Binary data
Attachment:
proc_ptr_3.f90
Description: Binary data
Attachment:
proc_ptr_4.f90
Description: Binary data
Attachment:
proc_ptr_5.f90
Description: Binary data
Attachment:
proc_ptr_6.f90
Description: Binary data
/* Procedure pointer test. Used by proc_ptr_7.f90.
PR fortran/32580. */
int f(void) {
return 42;
}
void assignf_(int(**ptr)(void)) {
*ptr = f;
}
Attachment:
proc_ptr_7.f90
Description: Binary data
/* Used by proc_ptr_8.f90.
PR fortran/32580. */
int (*funpointer)(int);
int f(int t)
{
return t*3;
}
void init()
{
funpointer=f;
}
Attachment:
proc_ptr_8.f90
Description: Binary data
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |