This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR39630: Procedure Pointer Components, Part 1 (NOPASS only)
- From: Janus Weil <janus at gcc dot gnu dot org>
- To: gfortran <fortran at gcc dot gnu dot org>, gcc patches <gcc-patches at gcc dot gnu dot org>, Juergen Reuter <juergen dot reuter at physik dot uni-freiburg dot de>, Wolfgang Kilian <kilian at hep dot physik dot uni-siegen dot de>
- Date: Tue, 5 May 2009 00:31:04 +0200
- Subject: [Patch, Fortran] PR39630: Procedure Pointer Components, Part 1 (NOPASS only)
Hi all,
my patch for PPCs has been in the making for some time now, and it's
finally getting close to being committable. The most notable omission
in the patch is the PASS feature, which I decided to leave out for a
start. But there are also some other things missing (which have been
marked with TODOs in the patch):
1) PASS
2) PPC assignment checking (-> gfc_check_pointer assign)
3) copying formal args from the interface (-> resolve_fl_derived)
4) check actual args (-> resolve_ppc_call, resolve_expr_ppc)
5) include formal args in backend_decl (->gfc_get_ppc_type)
My plan would be to add these in a follow-up patch, but if someone
thinks it would be important to include any of them in this first
patch, please let me know.
In general my design goal for this patch was to have a solid
implementation of NOPASS PPCs, which makes all (basic) usage-cases
work (minus some checking). Another minimal goal was to make the
WHIZARD-2.0 code work (http://whizard.event-generator.org/), which
makes heavy use of PPCs. I think this is accomplished with the present
version of the patch (maybe someone of the WHIZARD people can confirm
this?).
Before I forget it, props go to Paul for constructing a good portion
of this patch, to Tobias for lots of testing and good advice, and to
Juergen Reuter for providing the WHIZARD 2.0 alpha source code, which
proved to be a valuable source of PPC test cases.
I hope the patch can be committed soon, unless anyone finds any
further issues. Regression-test on x86_64-unknown-linux-gnu succeeded
without any failures. Ok for trunk?
Cheers,
Janus
2009-05-04 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.
* 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-04 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.
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90 (revision 147105)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90 (working copy)
@@ -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
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 147105)
+++ gcc/fortran/interface.c (working copy)
@@ -1864,7 +1864,8 @@ compare_actual_formal (gfc_actual_arglis
/* 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_arglis
/* 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)
{
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 147105)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -476,7 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc
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, tre
}
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_
/* 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, g
/* 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
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
@@ -2402,11 +2406,13 @@ conv_arglist_function (gfc_se *se, gfc_e
/* 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
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
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
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,19 @@ gfc_conv_statement_function (gfc_se * se
}
+/* 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 +3396,9 @@ gfc_conv_function_expr (gfc_se * se, gfc
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 +3820,8 @@ gfc_conv_structure (gfc_se * se, gfc_exp
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);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 147105)
+++ gcc/fortran/symbol.c (working copy)
@@ -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, g
"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, i
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, cons
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,
return result;
}
+
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 147105)
+++ gcc/fortran/decl.c (working copy)
@@ -4145,17 +4145,14 @@ add_hidden_procptr_result (gfc_symbol *s
}
-/* 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 (¤t_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 (¤t_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, ¤t_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_
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_
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_
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;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 147105)
+++ gcc/fortran/gfortran.h (working copy)
@@ -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 (gf
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 */
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 147105)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -356,8 +356,8 @@ gfc_trans_call (gfc_code * code, bool de
/* 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 de
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);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 147105)
+++ gcc/fortran/expr.c (working copy)
@@ -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 *lval
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 *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
- | 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 *lval
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 *lval
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 *lval
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)))
{
@@ -3148,6 +3155,9 @@ gfc_check_pointer_assign (gfc_expr *lval
rvalue->symtree->name, &rvalue->where);
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))
@@ -3481,6 +3491,34 @@ gfc_expr_set_symbols_referenced (gfc_exp
}
+/* 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
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h (revision 147105)
+++ gcc/fortran/trans-stmt.h (working copy)
@@ -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 *);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 147105)
+++ gcc/fortran/module.c (working copy)
@@ -3043,6 +3043,7 @@ mio_expr (gfc_expr **ep)
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 147105)
+++ gcc/fortran/trans.c (working copy)
@@ -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;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (revision 147105)
+++ gcc/fortran/trans-types.c (working copy)
@@ -1777,6 +1777,21 @@ copy_dt_decls_ifequal (gfc_symbol *from,
}
+/* 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 * deriv
/* 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 * deriv
{
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)
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 147105)
+++ gcc/fortran/trans.h (working copy)
@@ -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);
Index: gcc/fortran/trans-types.h
===================================================================
--- gcc/fortran/trans-types.h (revision 147105)
+++ gcc/fortran/trans-types.h (working copy)
@@ -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
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 147105)
+++ gcc/fortran/resolve.c (working copy)
@@ -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_argli
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_argli
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_namesp
}
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_namesp
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;
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 147105)
+++ gcc/fortran/st.c (working copy)
@@ -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);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 147105)
+++ gcc/fortran/match.c (working copy)
@@ -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;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 147105)
+++ gcc/fortran/parse.c (working copy)
@@ -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
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 147105)
+++ gcc/fortran/primary.c (working copy)
@@ -1708,10 +1708,13 @@ extend_ref (gfc_expr *primary, gfc_ref *
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, in
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, in
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_t
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_t
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 e
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 e
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);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 147105)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -1702,7 +1702,8 @@ gfc_conv_intrinsic_funcall (gfc_se * se,
}
}
- 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
/* 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);
}
! { 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
x%i = 1
x%ppc => sub
pp => x%ppc
call sub(1.5)
call pp(2.2)
call x%ppc(3.0)
! calling object as argument
x%proc => print_me
call x%proc(x)
! type extension
x%proc => hello
call x%proc
x2%proc => hello
call x2%proc()
x2%proc2 => hello
call x2%proc2
contains
subroutine sub(y)
real, intent(in) :: y
print *,"sub:",y
end subroutine
subroutine print_me(arg)
type(t),intent(in) :: arg
print *,arg%i
end subroutine
subroutine hello
print *, "Hello World"
end subroutine
end
! { 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:: ptr3
integer :: i
end type
abstract interface
real function abstr(x)
import
real, intent(in) :: x
end function
end interface
type(t) :: obj
procedure(fcn), pointer :: f
real :: base = 1.0
intrinsic :: sin
! Check with interface from contained function
obj%ppc => fcn
print *, obj%ppc(3.0)
call foo (obj%ppc)
! Check with abstract interface
obj%ppc1 => obj%ppc
print *, obj%ppc1(3.0)
call foo (obj%ppc1)
! Check compatibility components with non-components
f => obj%ppc
print *, f(3.0)
call foo (f)
! Check with implicit interface
obj%ptr3 => sin
print *,obj%ptr3(3.0)
contains
real function fcn(x)
real, intent(in) :: x
fcn = base * 2.0 * x
base = fcn
end function
subroutine foo (arg)
procedure (fcn), pointer :: arg
print *, arg (6.0)
end subroutine
end
! { 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
! { 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" } }
! { 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
real 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
x%c%s => is
call x%c%s
x%c%f => if
print *,x%c%f()
contains
subroutine is
print *,"is is"
end subroutine
real function if()
if = 42
end function
end
! { 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
contains
subroutine print_me (arg, lun)
type(t), intent(in) :: arg
integer, intent(in) :: lun
write (lun,*) arg%a
end subroutine print_me
subroutine print_my_square (arg, lun)
type(t), intent(in) :: arg
integer, intent(in) :: lun
write (lun,*) arg%a**2
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)
end program main
! { dg-final { cleanup-modules "proc_component_example" } }