+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
}
-/* 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);
/* 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;
}
}
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;
}
+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
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;
/* 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
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)
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. */
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:
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);
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;
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);
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);
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)
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gfc_free_actual_arglist (e->value.compcall.actual);
break;
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;
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
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)
/* 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)
{
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)
{
return FAILURE;
}
- if (!pointer)
+ if (!pointer && !proc_pointer)
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
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)))
{
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))
}
+/* 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
/* 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;
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;
locus loc;
struct gfc_expr *initializer;
struct gfc_component *next;
+
+ struct gfc_formal_arglist *formal;
}
gfc_component;
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,
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 *);
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;
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 */
/* 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",
/* 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)
{
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);
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)
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;
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
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;
|| (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
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;
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)
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);
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;
allocatable = attr.allocatable;
target = attr.target;
- if (pointer)
+ if (pointer || attr.proc_pointer)
target = 1;
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
pointer = ref->u.c.component->attr.pointer;
allocatable = ref->u.c.component->attr.allocatable;
- if (pointer)
+ if (pointer || attr.proc_pointer)
target = 1;
break;
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:
}
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;
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;
}
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
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
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;
}
/*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;
}
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;
}
/* 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;
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);
}
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);
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
{
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:
}
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 "
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ gfc_component *comp;
for (; arg; arg = arg->next)
{
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
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)
{
}
+/* 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. */
t = SUCCESS;
break;
+ case EXPR_PPC:
+ t = resolve_expr_ppc (e);
+ break;
+
case EXPR_ARRAY:
t = FAILURE;
if (resolve_ref (e) == FAILURE)
}
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;
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. */
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)
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);
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;
break;
case EXEC_COMPCALL:
+ case EXEC_CALL_PPC:
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);
/* 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 "
"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;
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)
{
p->name = gfc_get_string (name);
p->loc = gfc_current_locus;
+ p->ts.type = BT_UNKNOWN;
*component = p;
return SUCCESS;
return result;
}
+
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);
}
}
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)
/* 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)
/* 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);
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
/* 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;
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;
}
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
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
}
+/* 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
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);
}
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);
}
}
- 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);
}
/* 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);
}
/* 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;
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);
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 *);
}
+/* 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
/* 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);
{
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)
/* Return the DTYPE for an array. */
tree gfc_get_dtype (tree);
+tree gfc_get_ppc_type (gfc_component *);
+
#endif
}
break;
+ case EXEC_CALL_PPC:
+ res = gfc_trans_call (code, false);
+ break;
+
case EXEC_ASSIGN_CALL:
res = gfc_trans_call (code, true);
break;
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. */
/* 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);
+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
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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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\r
+ procedure(fcn), pointer, nopass :: ppc\r
+ procedure(abstr), pointer, nopass :: ppc1
+ procedure(), nopass, pointer:: iptr3\r
+ integer :: i\r
+ end type\r
+\r
+ abstract interface\r
+ integer function abstr(x)\r
+ integer, intent(in) :: x\r
+ end function\r
+ end interface\r
+\r
+ type(t) :: obj\r
+ procedure(fcn), pointer :: f\r
+ integer :: base
+
+ intrinsic :: iabs\r
+\r
+! Check with interface from contained function\r
+ obj%ppc => fcn\r
+ base=obj%ppc(2)
+ if (base/=4) call abort\r
+ call foo (obj%ppc,3)\r
+\r
+! Check with abstract interface\r
+ obj%ppc1 => obj%ppc\r
+ base=obj%ppc1(4)
+ if (base/=8) call abort\r
+ call foo (obj%ppc1,5)\r
+\r
+! Check compatibility components with non-components \r
+ f => obj%ppc\r
+ base=f(6)
+ if (base/=12) call abort\r
+ call foo (f,7)
+
+! Check with implicit interface
+ obj%iptr3 => iabs
+ base=obj%iptr3(-9)
+ if (base/=9) call abort\r
+\r
+contains\r
+\r
+ integer function fcn(x)\r
+ integer, intent(in) :: x\r
+ fcn = 2 * x\r
+ end function\r
+
+ subroutine foo (arg, i)
+ procedure (fcn), pointer :: arg
+ integer :: i
+ if (arg(i)/=2*i) call abort
+ end subroutine
+\r
+end\r
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
+
OSDN Git Service
