FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/39630 ([F03] Procedure Pointer Components)

Browse source 
2009-05-06  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/39630
	* decl.c (match_procedure_interface): New function to match the
	interface for a PROCEDURE statement.
	(match_procedure_decl): Call match_procedure_interface.
	(match_ppc_decl): New function to match the declaration of a
	procedure pointer component.
	(gfc_match_procedure):  Call match_ppc_decl.
	(match_binding_attributes): Add new argument 'ppc' and handle the
	POINTER attribute for procedure pointer components.
	(match_procedure_in_type,gfc_match_generic): Added new argument to
	match_binding_attributes.
	* dump-parse-tree.c (show_expr,show_components,show_code_node): Handle
	procedure pointer components.
	* expr.c (free_expr0,gfc_copy_expr,gfc_simplify_expr): Handle EXPR_PPC.
	(gfc_check_pointer_assign): Handle procedure pointer components, but no
	full checking yet.
	(is_proc_ptr_comp): New function to determine if an expression is a
	procedure pointer component.
	* gfortran.h (expr_t): Add EXPR_PPC.
	(symbol_attribute): Add new member 'proc_pointer_comp'.
	(gfc_component): Add new member 'formal'.
	(gfc_exec_op): Add EXEC_CALL_PPC.
	(gfc_get_default_type): Changed first argument.
	(is_proc_ptr_comp): Add prototype.
	(gfc_match_varspec): Add new argument.
	* interface.c (compare_actual_formal): Handle procedure pointer
	components.
	* match.c (gfc_match_pointer_assignment,match_typebound_call): Handle
	procedure pointer components.
	* module.c (mio_expr): Handle EXPR_PPC.
	* parse.c (parse_derived): Handle procedure pointer components.
	* primary.c (gfc_match_varspec): Add new argument 'ppc_arg' and handle
	procedure pointer components.
	(gfc_variable_attr): Handle procedure pointer components.
	(gfc_match_rvalue): Added new argument to gfc_match_varspec and changed
	first argument of gfc_get_default_type.
	(match_variable): Added new argument to gfc_match_varspec.
	* resolve.c (resolve_entries,set_type,resolve_fl_parameter): Changed
	first argument of gfc_get_default_type.
	(resolve_structure_cons,resolve_actual_arglist): Handle procedure
	pointer components.
	(resolve_ppc_call): New function to resolve a call to a procedure
	pointer component (subroutine).
	(resolve_expr_ppc): New function to resolve a call to a procedure
	pointer component (function).
	(gfc_resolve_expr): Handle EXPR_PPC.
	(resolve_code): Handle EXEC_CALL_PPC.
	(resolve_fl_derived): Copy the interface for a procedure pointer
	component.
	(resolve_symbol): Fix overlong line.
	* st.c (gfc_free_statement): Handle EXEC_CALL_PPC.
	* symbol.c (gfc_get_default_type): Changed first argument.
	(gfc_set_default_type): Changed first argument of gfc_get_default_type.
	(gfc_add_component): Initialize ts.type to BT_UNKNOWN.
	* trans.h (gfc_conv_function_call): Renamed.
	* trans.c (gfc_trans_code): Handle EXEC_CALL_PPC.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	(gfc_conv_function_val): Rename to 'conv_function_val', add new
	argument 'expr' and handle procedure pointer components.
	(gfc_conv_operator_assign): Renamed gfc_conv_function_val.
	(gfc_apply_interface_mapping_to_expr): Handle EXPR_PPC.
	(gfc_conv_function_call): Rename to 'gfc_conv_procedure_call', add new
	argument 'expr' and handle procedure pointer components.
	(gfc_get_proc_ptr_comp): New function to get the backend decl for a
	procedure pointer component.
	(gfc_conv_function_expr): Renamed gfc_conv_function_call.
	(gfc_conv_structure): Handle procedure pointer components.
	* trans-intrinsic.c (gfc_conv_intrinsic_funcall,
	conv_generic_with_optional_char_arg): Renamed gfc_conv_function_call.
	* trans-stmt.h (gfc_get_proc_ptr_comp): Add prototype.
	* trans-stmt.c (gfc_trans_call): Renamed gfc_conv_function_call.
	* trans-types.h (gfc_get_ppc_type): Add prototype.
	* trans-types.c (gfc_get_ppc_type): New function to build a tree node
	for a procedure pointer component.
	(gfc_get_derived_type): Handle procedure pointer components.


2009-05-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39630
	* gfortran.dg/proc_decl_1.f90: Modified.
	* gfortran.dg/proc_ptr_comp_1.f90: New.
	* gfortran.dg/proc_ptr_comp_2.f90: New.
	* gfortran.dg/proc_ptr_comp_3.f90: New.
	* gfortran.dg/proc_ptr_comp_4.f90: New.
	* gfortran.dg/proc_ptr_comp_5.f90: New.
	* gfortran.dg/proc_ptr_comp_6.f90: New.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r147206
This commit is contained in:
Janus Weil 2009-05-06 23:17:16 +02:00
parent 641cac0b19
commit 713485cc67
29 changed files with 1110 additions and 162 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
gcc/fortran/ChangeLog
View file

@ -1,3 +1,82 @@
2009-05-06 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/39630
* decl.c (match_procedure_interface): New function to match the
interface for a PROCEDURE statement.
(match_procedure_decl): Call match_procedure_interface.
(match_ppc_decl): New function to match the declaration of a
procedure pointer component.
(gfc_match_procedure): Call match_ppc_decl.
(match_binding_attributes): Add new argument 'ppc' and handle the
POINTER attribute for procedure pointer components.
(match_procedure_in_type,gfc_match_generic): Added new argument to
match_binding_attributes.
* dump-parse-tree.c (show_expr,show_components,show_code_node): Handle
procedure pointer components.
* expr.c (free_expr0,gfc_copy_expr,gfc_simplify_expr): Handle EXPR_PPC.
(gfc_check_pointer_assign): Handle procedure pointer components, but no
full checking yet.
(is_proc_ptr_comp): New function to determine if an expression is a
procedure pointer component.
* gfortran.h (expr_t): Add EXPR_PPC.
(symbol_attribute): Add new member 'proc_pointer_comp'.
(gfc_component): Add new member 'formal'.
(gfc_exec_op): Add EXEC_CALL_PPC.
(gfc_get_default_type): Changed first argument.
(is_proc_ptr_comp): Add prototype.
(gfc_match_varspec): Add new argument.
* interface.c (compare_actual_formal): Handle procedure pointer
components.
* match.c (gfc_match_pointer_assignment,match_typebound_call): Handle
procedure pointer components.
* module.c (mio_expr): Handle EXPR_PPC.
* parse.c (parse_derived): Handle procedure pointer components.
* primary.c (gfc_match_varspec): Add new argument 'ppc_arg' and handle
procedure pointer components.
(gfc_variable_attr): Handle procedure pointer components.
(gfc_match_rvalue): Added new argument to gfc_match_varspec and changed
first argument of gfc_get_default_type.
(match_variable): Added new argument to gfc_match_varspec.
* resolve.c (resolve_entries,set_type,resolve_fl_parameter): Changed
first argument of gfc_get_default_type.
(resolve_structure_cons,resolve_actual_arglist): Handle procedure
pointer components.
(resolve_ppc_call): New function to resolve a call to a procedure
pointer component (subroutine).
(resolve_expr_ppc): New function to resolve a call to a procedure
pointer component (function).
(gfc_resolve_expr): Handle EXPR_PPC.
(resolve_code): Handle EXEC_CALL_PPC.
(resolve_fl_derived): Copy the interface for a procedure pointer
component.
(resolve_symbol): Fix overlong line.
* st.c (gfc_free_statement): Handle EXEC_CALL_PPC.
* symbol.c (gfc_get_default_type): Changed first argument.
(gfc_set_default_type): Changed first argument of gfc_get_default_type.
(gfc_add_component): Initialize ts.type to BT_UNKNOWN.
* trans.h (gfc_conv_function_call): Renamed.
* trans.c (gfc_trans_code): Handle EXEC_CALL_PPC.
* trans-expr.c (gfc_conv_component_ref): Ditto.
(gfc_conv_function_val): Rename to 'conv_function_val', add new
argument 'expr' and handle procedure pointer components.
(gfc_conv_operator_assign): Renamed gfc_conv_function_val.
(gfc_apply_interface_mapping_to_expr): Handle EXPR_PPC.
(gfc_conv_function_call): Rename to 'gfc_conv_procedure_call', add new
argument 'expr' and handle procedure pointer components.
(gfc_get_proc_ptr_comp): New function to get the backend decl for a
procedure pointer component.
(gfc_conv_function_expr): Renamed gfc_conv_function_call.
(gfc_conv_structure): Handle procedure pointer components.
* trans-intrinsic.c (gfc_conv_intrinsic_funcall,
conv_generic_with_optional_char_arg): Renamed gfc_conv_function_call.
* trans-stmt.h (gfc_get_proc_ptr_comp): Add prototype.
* trans-stmt.c (gfc_trans_call): Renamed gfc_conv_function_call.
* trans-types.h (gfc_get_ppc_type): Add prototype.
* trans-types.c (gfc_get_ppc_type): New function to build a tree node
for a procedure pointer component.
(gfc_get_derived_type): Handle procedure pointer components.
2009-05-06 Tobias Burnus <burnus@net-b.de>
PR fortran/40041

307
gcc/fortran/decl.c
View file

@ -4145,17 +4145,14 @@ add_hidden_procptr_result (gfc_symbol *sym)
}
/* Match a PROCEDURE declaration (R1211). */
/* Match the interface for a PROCEDURE declaration,
including brackets (R1212). */
static match
match_procedure_decl (void)
match_procedure_interface (gfc_symbol **proc_if)
{
match m;
locus old_loc, entry_loc;
gfc_symbol *sym, *proc_if = NULL;
int num;
gfc_expr *initializer = NULL;
old_loc = entry_loc = gfc_current_locus;
gfc_clear_ts (&current_ts);
@ -4180,45 +4177,43 @@ match_procedure_decl (void)
/* Get the name of the procedure or abstract interface
to inherit the interface from. */
m = gfc_match_symbol (&proc_if, 1);
if (m == MATCH_NO)
goto syntax;
else if (m == MATCH_ERROR)
m = gfc_match_symbol (proc_if, 1);
if (m != MATCH_YES)
return m;
/* Various interface checks. */
if (proc_if)
if (*proc_if)
{
proc_if->refs++;
(*proc_if)->refs++;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
invalid per C1212. */
while (proc_if->ts.interface)
proc_if = proc_if->ts.interface;
while ((*proc_if)->ts.interface)
*proc_if = (*proc_if)->ts.interface;
if (proc_if->generic)
if ((*proc_if)->generic)
{
gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
gfc_error ("Interface '%s' at %C may not be generic",
(*proc_if)->name);
return MATCH_ERROR;
}
if (proc_if->attr.proc == PROC_ST_FUNCTION)
if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Interface '%s' at %C may not be a statement function",
proc_if->name);
(*proc_if)->name);
return MATCH_ERROR;
}
/* Handle intrinsic procedures. */
if (!(proc_if->attr.external || proc_if->attr.use_assoc
|| proc_if->attr.if_source == IFSRC_IFBODY)
&& (gfc_is_intrinsic (proc_if, 0, gfc_current_locus)
|| gfc_is_intrinsic (proc_if, 1, gfc_current_locus)))
proc_if->attr.intrinsic = 1;
if (proc_if->attr.intrinsic
&& !gfc_intrinsic_actual_ok (proc_if->name, 0))
if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
|| (*proc_if)->attr.if_source == IFSRC_IFBODY)
&& (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
|| gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
(*proc_if)->attr.intrinsic = 1;
if ((*proc_if)->attr.intrinsic
&& !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
{
gfc_error ("Intrinsic procedure '%s' not allowed "
"in PROCEDURE statement at %C", proc_if->name);
"in PROCEDURE statement at %C", (*proc_if)->name);
return MATCH_ERROR;
}
}
@ -4230,7 +4225,26 @@ got_ts:
return MATCH_NO;
}
/* Parse attributes. */
return MATCH_YES;
}
/* Match a PROCEDURE declaration (R1211). */
static match
match_procedure_decl (void)
{
match m;
gfc_symbol *sym, *proc_if = NULL;
int num;
gfc_expr *initializer = NULL;
/* Parse interface (with brackets). */
m = match_procedure_interface (&proc_if);
if (m != MATCH_YES)
return m;
/* Parse attributes (with colons). */
m = match_attr_spec();
if (m == MATCH_ERROR)
return MATCH_ERROR;
@ -4360,6 +4374,138 @@ cleanup:
}
static match
match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
/* Match a procedure pointer component declaration (R445). */
static match
match_ppc_decl (void)
{
match m;
gfc_symbol *proc_if = NULL;
gfc_typespec ts;
int num;
gfc_component *c;
gfc_expr *initializer = NULL;
gfc_typebound_proc* tb;
char name[GFC_MAX_SYMBOL_LEN + 1];
/* Parse interface (with brackets). */
m = match_procedure_interface (&proc_if);
if (m != MATCH_YES)
goto syntax;
/* Parse attributes. */
tb = XCNEW (gfc_typebound_proc);
tb->where = gfc_current_locus;
m = match_binding_attributes (tb, false, true);
if (m == MATCH_ERROR)
return m;
/* TODO: Implement PASS. */
if (!tb->nopass)
{
gfc_error ("Procedure Pointer Component with PASS at %C "
"not yet implemented");
return MATCH_ERROR;
}
gfc_clear_attr (&current_attr);
current_attr.procedure = 1;
current_attr.proc_pointer = 1;
current_attr.access = tb->access;
current_attr.flavor = FL_PROCEDURE;
/* Match the colons (required). */
if (gfc_match (" ::") != MATCH_YES)
{
gfc_error ("Expected '::' after binding-attributes at %C");
return MATCH_ERROR;
}
/* Check for C450. */
if (!tb->nopass && proc_if == NULL)
{
gfc_error("NOPASS or explicit interface required at %C");
return MATCH_ERROR;
}
/* Match PPC names. */
ts = current_ts;
for(num=1;;num++)
{
m = gfc_match_name (name);
if (m == MATCH_NO)
goto syntax;
else if (m == MATCH_ERROR)
return m;
if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
return MATCH_ERROR;
/* Add current_attr to the symbol attributes. */
if (gfc_copy_attr (&c->attr, &current_attr, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_external (&c->attr, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_proc (&c->attr, name, NULL) == FAILURE)
return MATCH_ERROR;
/* Set interface. */
if (proc_if != NULL)
{
c->ts.interface = proc_if;
c->attr.untyped = 1;
c->attr.if_source = IFSRC_IFBODY;
}
else if (ts.type != BT_UNKNOWN)
{
c->ts = ts;
c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
c->ts.interface->ts = ts;
c->ts.interface->attr.function = 1;
c->attr.function = c->ts.interface->attr.function;
c->attr.if_source = IFSRC_UNKNOWN;
}
if (gfc_match (" =>") == MATCH_YES)
{
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)
{
gfc_free_expr (initializer);
return m;
}
c->initializer = initializer;
}
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
syntax:
gfc_error ("Syntax error in procedure pointer component at %C");
return MATCH_ERROR;
}
/* Match a PROCEDURE declaration inside an interface (R1206). */
static match
@ -4425,9 +4571,8 @@ gfc_match_procedure (void)
m = match_procedure_in_interface ();
break;
case COMP_DERIVED:
gfc_error ("Fortran 2003: Procedure components at %C are not yet"
" implemented in gfortran");
return MATCH_ERROR;
m = match_ppc_decl ();
break;
case COMP_DERIVED_CONTAINS:
m = match_procedure_in_type ();
break;
@ -6830,9 +6975,10 @@ cleanup:
/* Match binding attributes. */
static match
match_binding_attributes (gfc_typebound_proc* ba, bool generic)
match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
{
bool found_passing = false;
bool seen_ptr = false;
match m;
/* Intialize to defaults. Do so even before the MATCH_NO check so that in
@ -6907,38 +7053,6 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
continue;
}
/* NON_OVERRIDABLE flag. */
m = gfc_match (" non_overridable");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
if (ba->non_overridable)
{
gfc_error ("Duplicate NON_OVERRIDABLE at %C");
goto error;
}
ba->non_overridable = 1;
continue;
}
/* DEFERRED flag. */
m = gfc_match (" deferred");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
if (ba->deferred)
{
gfc_error ("Duplicate DEFERRED at %C");
goto error;
}
ba->deferred = 1;
continue;
}
/* PASS possibly including argument. */
m = gfc_match (" pass");
if (m == MATCH_ERROR)
@ -6966,6 +7080,60 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
continue;
}
if (ppc)
{
/* POINTER flag. */
m = gfc_match (" pointer");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
if (seen_ptr)
{
gfc_error ("Duplicate POINTER attribute at %C");
goto error;
}
seen_ptr = true;
/*ba->ppc = 1;*/
continue;
}
}
else
{
/* NON_OVERRIDABLE flag. */
m = gfc_match (" non_overridable");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
if (ba->non_overridable)
{
gfc_error ("Duplicate NON_OVERRIDABLE at %C");
goto error;
}
ba->non_overridable = 1;
continue;
}
/* DEFERRED flag. */
m = gfc_match (" deferred");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
if (ba->deferred)
{
gfc_error ("Duplicate DEFERRED at %C");
goto error;
}
ba->deferred = 1;
continue;
}
}
}
/* Nothing matching found. */
@ -6987,6 +7155,13 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
if (ba->access == ACCESS_UNKNOWN)
ba->access = gfc_typebound_default_access;
if (ppc && !seen_ptr)
{
gfc_error ("POINTER attribute is required for procedure pointer component"
" at %C");
goto error;
}
return MATCH_YES;
error:
@ -7043,7 +7218,7 @@ match_procedure_in_type (void)
tb->is_generic = 0;
/* Match binding attributes. */
m = match_binding_attributes (tb, false);
m = match_binding_attributes (tb, false, false);
if (m == MATCH_ERROR)
return m;
seen_attrs = (m == MATCH_YES);
@ -7192,7 +7367,7 @@ gfc_match_generic (void)
gcc_assert (block && ns);
/* See if we get an access-specifier. */
m = match_binding_attributes (&tbattr, true);
m = match_binding_attributes (&tbattr, true, false);
if (m == MATCH_ERROR)
goto error;

19
gcc/fortran/dump-parse-tree.c
View file

@ -541,13 +541,20 @@ show_expr (gfc_expr *p)
case EXPR_FUNCTION:
if (p->value.function.name == NULL)
{
fprintf (dumpfile, "%s[", p->symtree->n.sym->name);
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
if (is_proc_ptr_comp (p, NULL))
show_ref (p->ref);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
fputc (']', dumpfile);
}
else
{
fprintf (dumpfile, "%s[[", p->value.function.name);
fprintf (dumpfile, "%s", p->value.function.name);
if (is_proc_ptr_comp (p, NULL))
show_ref (p->ref);
fputc ('[', dumpfile);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
fputc (']', dumpfile);
fputc (']', dumpfile);
@ -653,6 +660,8 @@ show_components (gfc_symbol *sym)
show_typespec (&c->ts);
if (c->attr.pointer)
fputs (" POINTER", dumpfile);
if (c->attr.proc_pointer)
fputs (" PPC", dumpfile);
if (c->attr.dimension)
fputs (" DIMENSION", dumpfile);
fputc (' ', dumpfile);
@ -1212,6 +1221,12 @@ show_code_node (int level, gfc_code *c)
show_compcall (c->expr);
break;
case EXEC_CALL_PPC:
fputs ("CALL ", dumpfile);
show_expr (c->expr);
show_actual_arglist (c->ext.actual);
break;
case EXEC_RETURN:
fputs ("RETURN ", dumpfile);
if (c->expr)

50
gcc/fortran/expr.c
View file

@ -182,6 +182,7 @@ free_expr0 (gfc_expr *e)
break;
case EXPR_COMPCALL:
case EXPR_PPC:
gfc_free_actual_arglist (e->value.compcall.actual);
break;
@ -507,6 +508,7 @@ gfc_copy_expr (gfc_expr *p)
break;
case EXPR_COMPCALL:
case EXPR_PPC:
q->value.compcall.actual =
gfc_copy_actual_arglist (p->value.compcall.actual);
q->value.compcall.tbp = p->value.compcall.tbp;
@ -1728,6 +1730,7 @@ gfc_simplify_expr (gfc_expr *p, int type)
break;
case EXPR_COMPCALL:
case EXPR_PPC:
gcc_unreachable ();
break;
}
@ -3038,7 +3041,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
symbol_attribute attr;
gfc_ref *ref;
int is_pure;
int pointer, check_intent_in;
int pointer, check_intent_in, proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
&& !lvalue->symtree->n.sym->attr.proc_pointer)
@ -3062,8 +3065,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
| lvalue->symtree->n.sym->attr.proc_pointer;
pointer = lvalue->symtree->n.sym->attr.pointer;
proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
{
@ -3071,7 +3074,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
check_intent_in = 0;
if (ref->type == REF_COMPONENT)
pointer = ref->u.c.component->attr.pointer;
{
pointer = ref->u.c.component->attr.pointer;
proc_pointer = ref->u.c.component->attr.proc_pointer;
}
if (ref->type == REF_ARRAY && ref->next == NULL)
{
@ -3107,7 +3113,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return FAILURE;
}
if (!pointer)
if (!pointer && !proc_pointer)
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
@ -3129,11 +3135,12 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return SUCCESS;
/* Checks on rvalue for procedure pointer assignments. */
if (lvalue->symtree->n.sym->attr.proc_pointer)
if (proc_pointer)
{
attr = gfc_expr_attr (rvalue);
if (!((rvalue->expr_type == EXPR_NULL)
|| (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
|| (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
|| (rvalue->expr_type == EXPR_VARIABLE
&& attr.flavor == FL_PROCEDURE)))
{
@ -3164,6 +3171,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
rvalue->symtree->name, &rvalue->where) == FAILURE)
return FAILURE;
}
/* TODO: Enable interface check for PPCs. */
if (is_proc_ptr_comp (rvalue, NULL))
return SUCCESS;
if (rvalue->expr_type == EXPR_VARIABLE
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
rvalue->symtree->n.sym, 0))
@ -3497,6 +3507,34 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
}
/* Determine if an expression is a procedure pointer component. If yes, the
argument 'comp' will point to the component (provided that 'comp' was
provided). */
bool
is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
{
gfc_ref *ref;
bool ppc = false;
if (!expr || !expr->ref)
return false;
ref = expr->ref;
while (ref->next)
ref = ref->next;
if (ref->type == REF_COMPONENT)
{
ppc = ref->u.c.component->attr.proc_pointer;
if (ppc && comp)
*comp = ref->u.c.component;
}
return ppc;
}
/* Walk an expression tree and check each variable encountered for being typed.
If strict is not set, a top-level variable is tolerated untyped in -std=gnu
mode as is a basic arithmetic expression using those; this is for things in

20
gcc/fortran/gfortran.h
View file

@ -151,7 +151,7 @@ bt;
/* Expression node types. */
typedef enum
{ EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE,
EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL
EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL, EXPR_PPC
}
expr_t;
@ -698,9 +698,11 @@ typedef struct
unsigned cray_pointer:1, cray_pointee:1;
/* The symbol is a derived type with allocatable components, pointer
components or private components, possibly nested. zero_comp
is true if the derived type has no component at all. */
unsigned alloc_comp:1, pointer_comp:1, private_comp:1, zero_comp:1;
components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no
component at all. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1;
/* The namespace where the VOLATILE attribute has been set. */
struct gfc_namespace *volatile_ns;
@ -851,6 +853,8 @@ typedef struct gfc_component
locus loc;
struct gfc_expr *initializer;
struct gfc_component *next;
struct gfc_formal_arglist *formal;
}
gfc_component;
@ -1883,7 +1887,7 @@ typedef enum
EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
EXEC_ALLOCATE, EXEC_DEALLOCATE,
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
@ -2265,7 +2269,7 @@ void gfc_set_implicit_none (void);
void gfc_check_function_type (gfc_namespace *);
bool gfc_is_intrinsic_typename (const char *);
gfc_typespec *gfc_get_default_type (gfc_symbol *, gfc_namespace *);
gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *);
gfc_try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);
void gfc_set_sym_referenced (gfc_symbol *);
@ -2484,6 +2488,8 @@ void gfc_expr_set_symbols_referenced (gfc_expr *);
gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
bool is_proc_ptr_comp (gfc_expr *, gfc_component **);
/* st.c */
extern gfc_code new_st;
@ -2592,7 +2598,7 @@ void gfc_free_use_stmts (gfc_use_list *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int);
/* trans.c */

5
gcc/fortran/interface.c
View file

@ -1864,7 +1864,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* 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)
&& !(a->expr->symtree->n.sym->attr.proc_pointer
|| is_proc_ptr_comp (a->expr, NULL)))
{
if (where)
gfc_error ("Expected a procedure pointer for argument '%s' at %L",
@ -1874,7 +1875,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* 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
if (a->expr->ts.type != BT_PROCEDURE && !is_proc_ptr_comp (a->expr, NULL)
&& a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.flavor == FL_PROCEDURE)
{

16
gcc/fortran/match.c
View file

@ -1336,7 +1336,8 @@ gfc_match_pointer_assignment (void)
goto cleanup;
}
if (lvalue->symtree->n.sym->attr.proc_pointer)
if (lvalue->symtree->n.sym->attr.proc_pointer
|| is_proc_ptr_comp (lvalue, NULL))
gfc_matching_procptr_assignment = 1;
m = gfc_match (" %e%t", &rvalue);
@ -2629,7 +2630,7 @@ match_typebound_call (gfc_symtree* varst)
base->where = gfc_current_locus;
gfc_set_sym_referenced (varst->n.sym);
m = gfc_match_varspec (base, 0, true);
m = gfc_match_varspec (base, 0, true, true);
if (m == MATCH_NO)
gfc_error ("Expected component reference at %C");
if (m != MATCH_YES)
@ -2641,13 +2642,16 @@ match_typebound_call (gfc_symtree* varst)
return MATCH_ERROR;
}
if (base->expr_type != EXPR_COMPCALL)
if (base->expr_type == EXPR_COMPCALL)
new_st.op = EXEC_COMPCALL;
else if (base->expr_type == EXPR_PPC)
new_st.op = EXEC_CALL_PPC;
else
{
gfc_error ("Expected type-bound procedure reference at %C");
gfc_error ("Expected type-bound procedure or procedure pointer component "
"at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_COMPCALL;
new_st.expr = base;
return MATCH_YES;

1
gcc/fortran/module.c
View file

@ -3043,6 +3043,7 @@ mio_expr (gfc_expr **ep)
break;
case EXPR_COMPCALL:
case EXPR_PPC:
gcc_unreachable ();
break;
}

12
gcc/fortran/parse.c
View file

@ -1878,15 +1878,11 @@ parse_derived (void)
unexpected_eof ();
case ST_DATA_DECL:
case ST_PROCEDURE:
accept_statement (st);
seen_component = 1;
break;
case ST_PROCEDURE:
gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
error_flag = 1;
break;
case ST_FINAL:
gfc_error ("FINAL declaration at %C must be inside CONTAINS");
error_flag = 1;
@ -1993,6 +1989,12 @@ endType:
|| (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
sym->attr.pointer_comp = 1;
/* Look for procedure pointer components. */
if (c->attr.proc_pointer
|| (c->ts.type == BT_DERIVED
&& c->ts.derived->attr.proc_pointer_comp))
sym->attr.proc_pointer_comp = 1;
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE

51
gcc/fortran/primary.c
View file

@ -1708,10 +1708,13 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
statement. sub_flag tells whether we expect a type-bound procedure found
to be a subroutine as part of CALL or a FUNCTION. */
to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
components, 'ppc_arg' determines whether the PPC may be called (with an
argument list), or whether it may just be referred to as a pointer. */
match
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
bool ppc_arg)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
@ -1754,7 +1757,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
return MATCH_YES;
if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
&& gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
@ -1826,6 +1829,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
primary->ts = component->ts;
if (component->attr.proc_pointer && ppc_arg
&& !gfc_matching_procptr_assignment)
{
primary->expr_type = EXPR_PPC;
m = gfc_match_actual_arglist (component->attr.subroutine,
&primary->value.compcall.actual);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
primary->value.compcall.actual = NULL;
break;
}
if (component->as != NULL)
{
tail = extend_ref (primary, tail);
@ -1847,7 +1864,7 @@ check_substring:
unknown = false;
if (primary->ts.type == BT_UNKNOWN)
{
if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
{
gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts;
@ -1925,7 +1942,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
allocatable = attr.allocatable;
target = attr.target;
if (pointer)
if (pointer || attr.proc_pointer)
target = 1;
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
@ -1971,7 +1988,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
pointer = ref->u.c.component->attr.pointer;
allocatable = ref->u.c.component->attr.allocatable;
if (pointer)
if (pointer || attr.proc_pointer)
target = 1;
break;
@ -2478,7 +2495,7 @@ gfc_match_rvalue (gfc_expr **result)
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
break;
case FL_PARAMETER:
@ -2495,7 +2512,7 @@ gfc_match_rvalue (gfc_expr **result)
}
e->symtree = symtree;
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
@ -2551,7 +2568,7 @@ gfc_match_rvalue (gfc_expr **result)
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
break;
}
@ -2578,7 +2595,7 @@ gfc_match_rvalue (gfc_expr **result)
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
break;
}
@ -2658,7 +2675,7 @@ gfc_match_rvalue (gfc_expr **result)
if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
&& gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
@ -2676,7 +2693,7 @@ gfc_match_rvalue (gfc_expr **result)
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
break;
}
@ -2701,7 +2718,7 @@ gfc_match_rvalue (gfc_expr **result)
/*FIXME:??? gfc_match_varspec does set this for us: */
e->ts = sym->ts;
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
break;
}
@ -2725,7 +2742,7 @@ gfc_match_rvalue (gfc_expr **result)
implicit_char = false;
if (sym->ts.type == BT_UNKNOWN)
{
ts = gfc_get_default_type (sym,NULL);
ts = gfc_get_default_type (sym->name, NULL);
if (ts->type == BT_CHARACTER)
implicit_char = true;
}
@ -2790,7 +2807,7 @@ gfc_match_rvalue (gfc_expr **result)
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
m = gfc_match_varspec (e, 0, false);
m = gfc_match_varspec (e, 0, false, true);
if (m == MATCH_NO)
m = MATCH_YES;
@ -2963,7 +2980,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
&& gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
&& gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, implicit_ns);
}
@ -2975,7 +2992,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
expr->where = where;
/* Now see if we have to do more. */
m = gfc_match_varspec (expr, equiv_flag, false);
m = gfc_match_varspec (expr, equiv_flag, false, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);

162
gcc/fortran/resolve.c
View file

@ -528,14 +528,14 @@ resolve_entries (gfc_namespace *ns)
fas = fas ? fas : ns->entries->sym->result->as;
fts = &ns->entries->sym->result->ts;
if (fts->type == BT_UNKNOWN)
fts = gfc_get_default_type (ns->entries->sym->result, NULL);
fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
for (el = ns->entries->next; el; el = el->next)
{
ts = &el->sym->result->ts;
as = el->sym->as;
as = as ? as : el->sym->result->as;
if (ts->type == BT_UNKNOWN)
ts = gfc_get_default_type (el->sym->result, NULL);
ts = gfc_get_default_type (el->sym->result->name, NULL);
if (! gfc_compare_types (ts, fts)
|| (el->sym->result->attr.dimension
@ -612,7 +612,7 @@ resolve_entries (gfc_namespace *ns)
{
ts = &sym->ts;
if (ts->type == BT_UNKNOWN)
ts = gfc_get_default_type (sym, NULL);
ts = gfc_get_default_type (sym->name, NULL);
switch (ts->type)
{
case BT_INTEGER:
@ -878,7 +878,8 @@ resolve_structure_cons (gfc_expr *expr)
}
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable))
&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
@ -1215,6 +1216,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
gfc_component *comp;
for (; arg; arg = arg->next)
{
@ -1234,6 +1236,13 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
continue;
}
if (is_proc_ptr_comp (e, &comp))
{
e->ts = comp->ts;
e->expr_type = EXPR_VARIABLE;
goto argument_list;
}
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
@ -1906,7 +1915,7 @@ set_type:
expr->ts = sym->ts;
else
{
ts = gfc_get_default_type (sym, sym->ns);
ts = gfc_get_default_type (sym->name, sym->ns);
if (ts->type == BT_UNKNOWN)
{
@ -4804,6 +4813,61 @@ resolve_compcall (gfc_expr* e)
}
/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
static gfc_try
resolve_ppc_call (gfc_code* c)
{
gfc_component *comp;
gcc_assert (is_proc_ptr_comp (c->expr, &comp));
c->resolved_sym = c->expr->symtree->n.sym;
c->expr->expr_type = EXPR_VARIABLE;
c->ext.actual = c->expr->value.compcall.actual;
if (!comp->attr.subroutine)
gfc_add_subroutine (&comp->attr, comp->name, &c->expr->where);
if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
comp->formal == NULL) == FAILURE)
return FAILURE;
/* TODO: Check actual arguments.
gfc_procedure_use (stree->n.sym, &c->expr->value.compcall.actual,
&c->expr->where);*/
return SUCCESS;
}
/* Resolve a Function Call to a Procedure Pointer Component (Function). */
static gfc_try
resolve_expr_ppc (gfc_expr* e)
{
gfc_component *comp;
gcc_assert (is_proc_ptr_comp (e, &comp));
/* Convert to EXPR_FUNCTION. */
e->expr_type = EXPR_FUNCTION;
e->value.function.isym = NULL;
e->value.function.actual = e->value.compcall.actual;
e->ts = comp->ts;
if (!comp->attr.function)
gfc_add_function (&comp->attr, comp->name, &e->where);
if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
comp->formal == NULL) == FAILURE)
return FAILURE;
/* TODO: Check actual arguments.
gfc_procedure_use (stree->n.sym, &e->value.compcall.actual, &e->where); */
return SUCCESS;
}
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
@ -4853,6 +4917,10 @@ gfc_resolve_expr (gfc_expr *e)
t = SUCCESS;
break;
case EXPR_PPC:
t = resolve_expr_ppc (e);
break;
case EXPR_ARRAY:
t = FAILURE;
if (resolve_ref (e) == FAILURE)
@ -6819,7 +6887,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
}
t = SUCCESS;
if (code->op != EXEC_COMPCALL)
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr);
forall_flag = forall_save;
@ -6931,6 +6999,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
resolve_typebound_call (code);
break;
case EXEC_CALL_PPC:
resolve_ppc_call (code);
break;
case EXEC_SELECT:
/* Select is complicated. Also, a SELECT construct could be
a transformed computed GOTO. */
@ -8906,6 +8978,78 @@ resolve_fl_derived (gfc_symbol *sym)
for (c = sym->components; c != NULL; c = c->next)
{
if (c->attr.proc_pointer && c->ts.interface)
{
if (c->ts.interface->attr.procedure)
gfc_error ("Interface '%s', used by procedure pointer component "
"'%s' at %L, is declared in a later PROCEDURE statement",
c->ts.interface->name, c->name, &c->loc);
/* Get the attributes from the interface (now resolved). */
if (c->ts.interface->attr.if_source
|| c->ts.interface->attr.intrinsic)
{
gfc_symbol *ifc = c->ts.interface;
if (ifc->attr.intrinsic)
resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
c->ts = ifc->result->ts;
else
c->ts = ifc->ts;
c->ts.interface = ifc;
c->attr.function = ifc->attr.function;
c->attr.subroutine = ifc->attr.subroutine;
/* TODO: gfc_copy_formal_args (c, ifc); */
c->attr.allocatable = ifc->attr.allocatable;
c->attr.pointer = ifc->attr.pointer;
c->attr.pure = ifc->attr.pure;
c->attr.elemental = ifc->attr.elemental;
c->attr.dimension = ifc->attr.dimension;
c->attr.recursive = ifc->attr.recursive;
c->attr.always_explicit = ifc->attr.always_explicit;
/* Copy array spec. */
c->as = gfc_copy_array_spec (ifc->as);
/*if (c->as)
{
int i;
for (i = 0; i < c->as->rank; i++)
{
gfc_expr_replace_symbols (c->as->lower[i], c);
gfc_expr_replace_symbols (c->as->upper[i], c);
}
}*/
/* Copy char length. */
if (ifc->ts.cl)
{
c->ts.cl = gfc_get_charlen();
c->ts.cl->resolved = ifc->ts.cl->resolved;
c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
/*gfc_expr_replace_symbols (c->ts.cl->length, c);*/
/* Add charlen to namespace. */
/*if (c->formal_ns)
{
c->ts.cl->next = c->formal_ns->cl_list;
c->formal_ns->cl_list = c->ts.cl;
}*/
}
}
else if (c->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure pointer component "
"'%s' at %L must be explicit", c->ts.interface->name,
c->name, &c->loc);
return FAILURE;
}
}
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
{
c->ts = *gfc_get_default_type (c->name, NULL);
c->attr.implicit_type = 1;
}
/* Check type-spec if this is not the parent-type component. */
if ((!sym->attr.extension || c != sym->components)
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
@ -9157,7 +9301,8 @@ resolve_fl_parameter (gfc_symbol *sym)
matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */
if (sym->attr.implicit_type
&& !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
&& !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
sym->ns)))
{
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at);
@ -9237,7 +9382,8 @@ resolve_symbol (gfc_symbol *sym)
sym->name,&sym->declared_at);
/* Get the attributes from the interface (now resolved). */
if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
if (sym->ts.interface->attr.if_source
|| sym->ts.interface->attr.intrinsic)
{
gfc_symbol *ifc = sym->ts.interface;

1
gcc/fortran/st.c
View file

@ -110,6 +110,7 @@ gfc_free_statement (gfc_code *p)
break;
case EXEC_COMPCALL:
case EXEC_CALL_PPC:
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);

10
gcc/fortran/symbol.c
View file

@ -219,11 +219,11 @@ gfc_merge_new_implicit (gfc_typespec *ts)
/* Given a symbol, return a pointer to the typespec for its default type. */
gfc_typespec *
gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
gfc_get_default_type (const char *name, gfc_namespace *ns)
{
char letter;
letter = sym->name[0];
letter = name[0];
if (gfc_option.flag_allow_leading_underscore && letter == '_')
gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
@ -231,7 +231,7 @@ gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
"implicitly typed variables");
if (letter < 'a' || letter > 'z')
gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name);
gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
if (ns == NULL)
ns = gfc_current_ns;
@ -252,7 +252,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
if (sym->ts.type != BT_UNKNOWN)
gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
ts = gfc_get_default_type (sym, ns);
ts = gfc_get_default_type (sym->name, ns);
if (ts->type == BT_UNKNOWN)
{
@ -1779,6 +1779,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
p->name = gfc_get_string (name);
p->loc = gfc_current_locus;
p->ts.type = BT_UNKNOWN;
*component = p;
return SUCCESS;
@ -4494,3 +4495,4 @@ gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
return result;
}

62
gcc/fortran/trans-expr.c
View file

@ -476,7 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
se->string_length = tmp;
}
if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
&& c->ts.type != BT_CHARACTER)
se->expr = build_fold_indirect_ref (se->expr);
}
@ -1487,11 +1488,13 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
}
static void
gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
if (sym->attr.dummy)
if (is_proc_ptr_comp (expr, NULL))
tmp = gfc_get_proc_ptr_comp (se, expr);
else if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
if (sym->attr.proc_pointer)
@ -1527,7 +1530,7 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
/* Translate the call for an elemental subroutine call used in an operator
assignment. This is a simplified version of gfc_conv_function_call. */
assignment. This is a simplified version of gfc_conv_procedure_call. */
tree
gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
@ -1556,7 +1559,7 @@ gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
/* Build the function call. */
gfc_init_se (&se, NULL);
gfc_conv_function_val (&se, sym);
conv_function_val (&se, sym, NULL);
tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
tmp = build_call_list (tmp, se.expr, args);
gfc_add_expr_to_block (&block, tmp);
@ -2133,6 +2136,7 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
break;
case EXPR_COMPCALL:
case EXPR_PPC:
gcc_unreachable ();
break;
}
@ -2402,11 +2406,13 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers. */
Return nonzero, if the call has alternate specifiers.
'expr' is only needed for procedure pointer components. */
int
gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg, tree append_args)
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg, gfc_expr * expr,
tree append_args)
{
gfc_interface_mapping mapping;
tree arglist;
@ -2496,16 +2502,20 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&se->post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
fptrse.want_pointer = 1;
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| is_proc_ptr_comp (arg->next->expr, NULL))
fptrse.want_pointer = 1;
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));
if (is_proc_ptr_comp (arg->next->expr, NULL))
tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
else
tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
fold_convert (tmp, cptrse.expr));
return 0;
}
@ -2942,7 +2952,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
arglist = chainon (arglist, append_args);
/* Generate the actual call. */
gfc_conv_function_val (se, sym);
conv_function_val (se, sym, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
@ -2969,7 +2979,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
something like
x = f()
where f is pointer valued, we have to dereference the result. */
if (!se->want_pointer && !byref && sym->attr.pointer)
if (!se->want_pointer && !byref && sym->attr.pointer
&& !is_proc_ptr_comp (expr, NULL))
se->expr = build_fold_indirect_ref (se->expr);
/* f2c calling conventions require a scalar default real function to
@ -3346,6 +3357,20 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
}
/* Return the backend_decl for a procedure pointer component. */
tree
gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
{
gfc_se comp_se;
gfc_init_se (&comp_se, NULL);
e->expr_type = EXPR_VARIABLE;
gfc_conv_expr (&comp_se, e);
comp_se.expr = build_fold_addr_expr (comp_se.expr);
return gfc_evaluate_now (comp_se.expr, &se->pre);
}
/* Translate a function expression. */
static void
@ -3372,7 +3397,9 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
sym = expr->value.function.esym;
if (!sym)
sym = expr->symtree->n.sym;
gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
NULL_TREE);
}
@ -3794,7 +3821,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
TREE_TYPE (cm->backend_decl), cm->attr.dimension,
cm->attr.pointer || cm->attr.proc_pointer);
/* Append it to the constructor list. */
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);

6
gcc/fortran/trans-intrinsic.c
View file

@ -1702,7 +1702,8 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
}
}
gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
gfc_free (sym);
}
@ -2877,7 +2878,8 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
/* Build the call itself. */
sym = gfc_get_symbol_for_expr (expr);
gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
gfc_free (sym);
}

8
gcc/fortran/trans-stmt.c
View file

@ -356,8 +356,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check)
/* Translate the call. */
has_alternate_specifier
= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
NULL_TREE);
= gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
code->expr, NULL_TREE);
/* A subroutine without side-effect, by definition, does nothing! */
TREE_SIDE_EFFECTS (se.expr) = 1;
@ -430,8 +430,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check)
gfc_init_block (&block);
/* Add the subroutine call to the block. */
gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
NULL_TREE);
gfc_conv_procedure_call (&loopse, code->resolved_sym, code->ext.actual,
code->expr, NULL_TREE);
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
gfc_add_block_to_block (&block, &loopse.pre);

1
gcc/fortran/trans-stmt.h
View file

@ -29,6 +29,7 @@ tree gfc_trans_code (gfc_code *);
tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
tree gfc_get_proc_ptr_comp (gfc_se *, gfc_expr *);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);

26
gcc/fortran/trans-types.c
View file

@ -1777,6 +1777,21 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
}
/* Build a tree node for a procedure pointer component. */
tree
gfc_get_ppc_type (gfc_component* c)
{
tree t;
if (c->attr.function)
t = gfc_typenode_for_spec (&c->ts);
else
t = void_type_node;
/* TODO: Build argument list. */
return build_pointer_type (build_function_type (t, NULL_TREE));
}
/* Build a tree node for a derived type. If there are equal
derived types, with different local names, these are built
at the same time. If an equal derived type has been built
@ -1823,16 +1838,9 @@ gfc_get_derived_type (gfc_symbol * derived)
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
{
/* Its components' backend_decl have been built. */
if (TYPE_FIELDS (derived->backend_decl))
return derived->backend_decl;
else
typenode = derived->backend_decl;
}
return derived->backend_decl;
else
{
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
@ -1881,6 +1889,8 @@ gfc_get_derived_type (gfc_symbol * derived)
{
if (c->ts.type == BT_DERIVED)
field_type = c->ts.derived->backend_decl;
else if (c->attr.proc_pointer)
field_type = gfc_get_ppc_type (c);
else
{
if (c->ts.type == BT_CHARACTER)

2
gcc/fortran/trans-types.h
View file

@ -89,4 +89,6 @@ int gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
tree gfc_get_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
#endif

4
gcc/fortran/trans.c
View file

@ -1115,6 +1115,10 @@ gfc_trans_code (gfc_code * code)
}
break;
case EXEC_CALL_PPC:
res = gfc_trans_call (code, false);
break;
case EXEC_ASSIGN_CALL:
res = gfc_trans_call (code, true);
break;

9
gcc/fortran/trans.h
View file

@ -71,7 +71,7 @@ typedef struct gfc_se
are NULL. Used by intrinsic size. */
unsigned data_not_needed:1;
/* If set, gfc_conv_function_call does not put byref calls into se->pre. */
/* If set, gfc_conv_procedure_call does not put byref calls into se->pre. */
unsigned no_function_call:1;
/* Scalarization parameters. */
@ -313,9 +313,10 @@ int gfc_is_intrinsic_libcall (gfc_expr *);
/* Used to call the elemental subroutines used in operator assignments. */
tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
/* Also used to CALL subroutines. */
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
/* Used to call ordinary functions/subroutines
and procedure pointer components. */
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
gfc_expr *, tree);
void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);

11
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,14 @@
2009-05-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/39630
* gfortran.dg/proc_decl_1.f90: Modified.
* gfortran.dg/proc_ptr_comp_1.f90: New.
* gfortran.dg/proc_ptr_comp_2.f90: New.
* gfortran.dg/proc_ptr_comp_3.f90: New.
* gfortran.dg/proc_ptr_comp_4.f90: New.
* gfortran.dg/proc_ptr_comp_5.f90: New.
* gfortran.dg/proc_ptr_comp_6.f90: New.
2009-05-06 Dodji Seketeli <dodji@redhat.com>
PR c++/17395

4
gcc/testsuite/gfortran.dg/proc_decl_1.f90
View file

@ -47,10 +47,6 @@ program prog
procedure(dcos) :: my1
procedure(amax0) :: my2 ! { dg-error "not allowed in PROCEDURE statement" }
type t
procedure(),pointer:: p ! { dg-error "not yet implemented" }
end type
real f, x
f(x) = sin(x**2)
external oo

65
gcc/testsuite/gfortran.dg/proc_ptr_comp_1.f90 Normal file
View file

@ -0,0 +1,65 @@
! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Basic test for PPCs with SUBROUTINE interface and NOPASS.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
type t
integer :: i
procedure(sub), pointer, nopass :: ppc
procedure(), pointer, nopass :: proc
end type
type, extends(t) :: t2
procedure(), pointer, nopass :: proc2
end type t2
type(t) :: x
type(t2) :: x2
procedure(sub),pointer :: pp
integer :: sum = 0
x%i = 1
x%ppc => sub
pp => x%ppc
call sub(1)
if (sum/=1) call abort
call pp(2)
if (sum/=3) call abort
call x%ppc(3)
if (sum/=6) call abort
! calling object as argument
x%proc => sub2
call x%proc(x)
if (x%i/=7) call abort
! type extension
x%proc => sub
call x%proc(4)
if (sum/=10) call abort
x2%proc => sub
call x2%proc(5)
if (sum/=15) call abort
x2%proc2 => sub
call x2%proc2(6)
if (sum/=21) call abort
contains
subroutine sub(y)
integer, intent(in) :: y
sum = sum + y
end subroutine
subroutine sub2(arg)
type(t),intent(inout) :: arg
arg%i = arg%i + sum
end subroutine
end

64
gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90 Normal file
View file

@ -0,0 +1,64 @@
! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Basic test for PPCs with FUNCTION interface and NOPASS.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
type t
procedure(fcn), pointer, nopass :: ppc
procedure(abstr), pointer, nopass :: ppc1
procedure(), nopass, pointer:: iptr3
integer :: i
end type
abstract interface
integer function abstr(x)
integer, intent(in) :: x
end function
end interface
type(t) :: obj
procedure(fcn), pointer :: f
integer :: base
intrinsic :: iabs
! Check with interface from contained function
obj%ppc => fcn
base=obj%ppc(2)
if (base/=4) call abort
call foo (obj%ppc,3)
! Check with abstract interface
obj%ppc1 => obj%ppc
base=obj%ppc1(4)
if (base/=8) call abort
call foo (obj%ppc1,5)
! Check compatibility components with non-components
f => obj%ppc
base=f(6)
if (base/=12) call abort
call foo (f,7)
! Check with implicit interface
obj%iptr3 => iabs
base=obj%iptr3(-9)
if (base/=9) call abort
contains
integer function fcn(x)
integer, intent(in) :: x
fcn = 2 * x
end function
subroutine foo (arg, i)
procedure (fcn), pointer :: arg
integer :: i
if (arg(i)/=2*i) call abort
end subroutine
end

46
gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 Normal file
View file

@ -0,0 +1,46 @@
! { dg-do compile }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Probing some error messages.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
implicit none
interface
subroutine sub
end subroutine
end interface
external :: aaargh
type :: t
procedure(sub), pointer :: ptr1 ! { dg-error "not yet implemented" }
procedure(real), pointer, nopass :: ptr2
procedure(sub), pointer, nopass :: ptr3
procedure(), pointer, nopass ptr4 ! { dg-error "Expected '::'" }
procedure(), pointer, nopass, pointer :: ptr5 ! { dg-error "Duplicate" }
procedure, pointer, nopass :: ptr6 ! { dg-error "Syntax error" }
procedure(), pointer, nopass :: ptr7 => ptr2 ! { dg-error "requires a NULL" }
procedure(), nopass :: ptr8 ! { dg-error "POINTER attribute is required" }
procedure(pp), pointer, nopass :: ptr9 ! { dg-error "declared in a later PROCEDURE statement" }
procedure(aaargh), pointer, nopass :: ptr10 ! { dg-error "must be explicit" }
real :: y
end type t
procedure(sub), pointer :: pp
type(t) :: x
x%ptr2 => x ! { dg-error "Invalid procedure pointer assignment" }
x => x%ptr2 ! { dg-error "Pointer assignment to non-POINTER" }
call x%ptr2() ! { dg-error "attribute conflicts with" }
print *,x%ptr3() ! { dg-error "attribute conflicts with" }
call x%y ! { dg-error "Expected type-bound procedure or procedure pointer component" }
end

120
gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 Normal file
View file

@ -0,0 +1,120 @@
! { dg-do compile }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Original code by Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
!
! Adapted by Janus Weil <janus@gcc.gnu.org>
! Test for infinte recursion in trans-types.c when a PPC interface
! refers to the original type.
module expressions
type :: eval_node_t
logical, pointer :: lval => null ()
type(eval_node_t), pointer :: arg1 => null ()
procedure(unary_log), nopass, pointer :: op1_log => null ()
end type eval_node_t
abstract interface
logical function unary_log (arg)
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_log
end interface
contains
subroutine eval_node_set_op1_log (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_log) :: op
en%op1_log => op
end subroutine eval_node_set_op1_log
subroutine eval_node_evaluate (en)
type(eval_node_t), intent(inout) :: en
en%lval = en%op1_log (en%arg1)
end subroutine
end module
! Test for C_F_PROCPOINTER and pointers to derived types
module process_libraries
implicit none
type :: process_library_t
procedure(), nopass, pointer :: write_list
end type process_library_t
contains
subroutine process_library_load (prc_lib)
use iso_c_binding
type(process_library_t) :: prc_lib
type(c_funptr) :: c_fptr
call c_f_procpointer (c_fptr, prc_lib%write_list)
end subroutine process_library_load
subroutine process_libraries_test ()
type(process_library_t), pointer :: prc_lib
call prc_lib%write_list ()
end subroutine process_libraries_test
end module process_libraries
! Test for argument resolution
module hard_interactions
implicit none
type :: hard_interaction_t
procedure(), nopass, pointer :: new_event
end type hard_interaction_t
interface afv
module procedure afv_1
end interface
contains
function afv_1 () result (a)
real, dimension(0:3) :: a
end function
subroutine hard_interaction_evaluate (hi)
type(hard_interaction_t) :: hi
call hi%new_event (afv ())
end subroutine
end module hard_interactions
! Test for derived types with PPC working properly as function result.
implicit none
type :: var_entry_t
procedure(), nopass, pointer :: obs1_int
end type var_entry_t
type(var_entry_t), pointer :: var
var => var_list_get_var_ptr ()
contains
function var_list_get_var_ptr ()
type(var_entry_t), pointer :: var_list_get_var_ptr
end function var_list_get_var_ptr
end
! { dg-final { cleanup-modules "expressions process_libraries hard_interactions" } }

47
gcc/testsuite/gfortran.dg/proc_ptr_comp_5.f90 Normal file
View file

@ -0,0 +1,47 @@
! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Nested types / double component references.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
abstract interface
subroutine as
end subroutine
integer function af()
end function
end interface
type :: t1
procedure(as), pointer, nopass :: s
procedure(af), pointer, nopass :: f
end type
type :: t2
type(t1) :: c
end type
type(t2) :: x
integer :: j = 0
x%c%s => is
call x%c%s
if (j/=5) call abort
x%c%f => if
j=x%c%f()
if (j/=42) call abort
contains
subroutine is
j = 5
end subroutine
integer function if()
if = 42
end function
end

64
gcc/testsuite/gfortran.dg/proc_ptr_comp_6.f90 Normal file
View file

@ -0,0 +1,64 @@
! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! test case taken from:
! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742?#884b9eca6d7e6742
! http://fortranwiki.org/fortran/show/proc_component_example
module proc_component_example
type t
real :: a
procedure(print_int), pointer, &
nopass :: proc
end type t
abstract interface
subroutine print_int (arg, lun)
import
type(t), intent(in) :: arg
integer, intent(in) :: lun
end subroutine print_int
end interface
integer :: calls = 0
contains
subroutine print_me (arg, lun)
type(t), intent(in) :: arg
integer, intent(in) :: lun
write (lun,*) arg%a
calls = calls + 1
end subroutine print_me
subroutine print_my_square (arg, lun)
type(t), intent(in) :: arg
integer, intent(in) :: lun
write (lun,*) arg%a**2
calls = calls + 1
end subroutine print_my_square
end module proc_component_example
program main
use proc_component_example
use iso_fortran_env, only : output_unit
type(t) :: x
x%a = 2.71828
x%proc => print_me
call x%proc(x, output_unit)
x%proc => print_my_square
call x%proc(x, output_unit)
if (calls/=2) call abort
end program main
! { dg-final { cleanup-modules "proc_component_example" } }