mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-18 18:51:24 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/32580 (iso_c_binding c_f_procpointer / procedure pointers)

Browse Source 
2008-07-02  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-07-02  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.

Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r137386
This commit is contained in:
Janus Weil 2008-07-02 21:53:37 +02:00
parent 658896fbb8
commit 8fb74da43b
27 changed files with 625 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/fortran/ChangeLog
View File

@ -1,3 +1,26 @@
2008-07-02 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-07-02 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36590

16
gcc/fortran/check.c
View File

@ -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, gfc_expr *target)
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, gfc_expr *target)
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, gfc_expr *target)
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],

42
gcc/fortran/decl.c
View File

@ -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;
}

12
gcc/fortran/expr.c
View File

@ -2874,7 +2874,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
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 +2895,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
/* 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 +2935,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
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 "
@ -3024,7 +3030,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
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);

2
gcc/fortran/gfortran.h
View File

@ -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;

11
gcc/fortran/interface.c
View File

@ -1959,6 +1959,17 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
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

6
gcc/fortran/match.c
View File

@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see
#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;

2
gcc/fortran/match.h
View File

@ -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. */

5
gcc/fortran/parse.c
View File

@ -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)
{

27
gcc/fortran/primary.c
View File

@ -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 equiv_flag, int host_flag)
break;
}
if (sym->attr.proc_pointer)
break;
/* Fall through to error */
default:

7
gcc/fortran/resolve.c
View File

@ -7330,7 +7330,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
}
}
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, int mp_flag)
}
/* 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);

71
gcc/fortran/symbol.c
View File

@ -410,13 +410,19 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
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 +563,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
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 +618,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
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 +865,12 @@ gfc_add_external (symbol_attribute *attr, locus *where)
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 +921,20 @@ gfc_add_pointer (symbol_attribute *attr, locus *where)
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 +1659,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
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 +3594,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 +3613,10 @@ gen_fptr_param (gfc_formal_arglist **head,
/* 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 +3796,23 @@ build_formal_args (gfc_symbol *new_proc_sym,
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)
{

44
gcc/fortran/trans-decl.c
View File

@ -1104,6 +1104,44 @@ gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
}
/* 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 * sym)
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 * sym)
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);

17
gcc/fortran/trans-expr.c
View File

@ -480,8 +480,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * 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_symbol * sym)
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_symbol * sym,
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 * expr1, gfc_expr * expr2)
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,

15
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,18 @@
2008-07-02 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.
2008-07-02 Joseph Myers <joseph@codesourcery.com>
* gcc.target/arm/neon/polytypes.c: Use dg-message separately from

6
gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
View File

@ -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" } }

2
gcc/testsuite/gfortran.dg/proc_decl_1.f90
View File

@ -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

73
gcc/testsuite/gfortran.dg/proc_ptr_1.f90 Executable file
View File

@ -0,0 +1,73 @@
! { dg-do run }
!
! basic tests of PROCEDURE POINTERS
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
contains
subroutine proc1(arg)
character (5) :: arg
arg = "proc1"
end subroutine
integer function proc2(arg)
integer, intent(in) :: arg
proc2 = arg**2
end function
complex function proc3(re, im)
real, intent(in) :: re, im
proc3 = complex (re, im)
end function
end module
subroutine foo1
end subroutine
real function foo2()
foo2=6.3
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
if(ASSOCIATED(ptr3)) call abort()
NULLIFY(ptr1)
if (ASSOCIATED(ptr1)) call abort()
ptr1 => proc1
if (.not. ASSOCIATED(ptr1)) call abort()
call ptr1 (str)
if (str .ne. "proc1") call abort ()
ptr2 => NULL()
if (ASSOCIATED(ptr2)) call abort()
ptr2 => proc2
if (.not. ASSOCIATED(ptr2,proc2)) call abort()
if (10*ptr2 (10) .ne. 1000) call abort ()
ptr3 => NULL (ptr3)
if (ASSOCIATED(ptr3)) 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()
end program
! { dg-final { cleanup-modules "m" } }

14
gcc/testsuite/gfortran.dg/proc_ptr_2.f90 Executable file
View File

@ -0,0 +1,14 @@
! { dg-do compile }
!
! checking invalid code for PROCEDURE POINTERS
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
PROCEDURE(REAL), POINTER :: ptr
PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" }
ptr => cos(4.0) ! { dg-error "Invalid character" }
ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" }
end

45
gcc/testsuite/gfortran.dg/proc_ptr_3.f90 Executable file
View File

@ -0,0 +1,45 @@
! { dg-do run }
!
! PROCEDURE POINTERS without the PROCEDURE statement
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
real function e1(x)
real :: x
print *,'e1!',x
e1 = 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 :: e1,e2
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()
end

57
gcc/testsuite/gfortran.dg/proc_ptr_4.f90 Executable file
View File

@ -0,0 +1,57 @@
! { dg-do compile }
!
! PROCEDURE POINTERS & pointer-valued functions
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
interface
integer function f1()
end function
end interface
interface
function f2()
integer, pointer :: f2
end function
end interface
interface
function pp1()
integer :: pp1
end function
end interface
pointer :: pp1
pointer :: pp2
interface
function pp2()
integer :: pp2
end function
end interface
pointer :: pp3
interface
function pp3()
integer, pointer :: pp3
end function
end interface
interface
function pp4()
integer, pointer :: pp4
end function
end interface
pointer :: pp4
pp1 => f1
pp2 => pp1
f2 => f1 ! { dg-error "is not a variable" }
pp3 => f2
pp4 => pp3
end

33
gcc/testsuite/gfortran.dg/proc_ptr_5.f90 Executable file
View File

@ -0,0 +1,33 @@
! { dg-do run }
!
! NULL() initialization for PROCEDURE POINTERS
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
program main
implicit none
call test(.true.)
call test(.false.)
contains
integer function hello()
hello = 42
end function hello
subroutine test(first)
logical :: first
integer :: i
procedure(integer), pointer :: x => null()
if(first) then
if(associated(x)) call abort()
x => hello
else
if(.not. associated(x)) call abort()
i = x()
if(i /= 42) call abort()
end if
end subroutine test
end program main

39
gcc/testsuite/gfortran.dg/proc_ptr_6.f90 Executable file
View File

@ -0,0 +1,39 @@
! { dg-do run }
!
! PROCEDURE POINTERS as actual/formal arguments
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
subroutine foo(j)
INTEGER, INTENT(OUT) :: j
j = 6
end subroutine
program proc_ptr_6
PROCEDURE(),POINTER :: ptr1
PROCEDURE(REAL),POINTER :: ptr2
EXTERNAL foo
INTEGER :: k = 0
ptr1 => foo
call s_in(ptr1,k)
if (k /= 6) call abort()
call s_out(ptr2)
if (ptr2(-3.0) /= 3.0) call abort()
contains
subroutine s_in(p,i)
PROCEDURE(),POINTER,INTENT(IN) :: p
INTEGER, INTENT(OUT) :: i
call p(i)
end subroutine
subroutine s_out(p)
PROCEDURE(REAL),POINTER,INTENT(OUT) :: p
p => abs
end subroutine
end program

10
gcc/testsuite/gfortran.dg/proc_ptr_7.c Normal file
View File

@ -0,0 +1,10 @@
/* Procedure pointer test. Used by proc_ptr_7.f90.
PR fortran/32580. */
int f(void) {
return 42;
}
void assignf_(int(**ptr)(void)) {
*ptr = f;
}

47
gcc/testsuite/gfortran.dg/proc_ptr_7.f90 Normal file
View File

@ -0,0 +1,47 @@
! { dg-do run }
! { dg-additional-sources proc_ptr_7.c }
!
! PR fortran/32580
! Procedure pointer test
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
program proc_pointer_test
use iso_c_binding, only: c_int
implicit none
interface
subroutine assignF(f)
import c_int
procedure(Integer(c_int)), pointer :: f
end subroutine
end interface
procedure(Integer(c_int)), pointer :: ptr
call assignF(ptr)
if(ptr() /= 42) call abort()
ptr => f55
if(ptr() /= 55) call abort()
call foo(ptr)
if(ptr() /= 65) call abort()
contains
subroutine foo(a)
procedure(integer(c_int)), pointer :: a
if(a() /= 55) call abort()
a => f65
if(a() /= 65) call abort()
end subroutine foo
integer(c_int) function f55()
f55 = 55
end function f55
integer(c_int) function f65()
f65 = 65
end function f65
end program proc_pointer_test

14
gcc/testsuite/gfortran.dg/proc_ptr_8.c Normal file
View File

@ -0,0 +1,14 @@
/* Used by proc_ptr_8.f90.
PR fortran/32580. */
int (*funpointer)(int);
int f(int t)
{
return t*3;
}
void init()
{
funpointer=f;
}

34
gcc/testsuite/gfortran.dg/proc_ptr_8.f90 Normal file
View File

@ -0,0 +1,34 @@
! { dg-do run }
! { dg-additional-sources proc_ptr_8.c }
!
! PR fortran/32580
! Original test case
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
MODULE X
USE ISO_C_BINDING
INTERFACE
INTEGER(KIND=C_INT) FUNCTION mytype( a ) BIND(C)
USE ISO_C_BINDING
INTEGER(KIND=C_INT), VALUE :: a
END FUNCTION
SUBROUTINE init() BIND(C,name="init")
END SUBROUTINE
END INTERFACE
TYPE(C_FUNPTR), BIND(C,name="funpointer") :: funpointer
END MODULE X
USE X
PROCEDURE(mytype), POINTER :: ptype
CALL init()
CALL C_F_PROCPOINTER(funpointer,ptype)
if (ptype(3) /= 9) call abort()
END
! { dg-final { cleanup-modules "X" } }