This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Fortran, Patch] Proposed type-bound procedures patch, part 1
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Fri, 01 Aug 2008 17:08:25 +0200
- Subject: [Fortran, Patch] Proposed type-bound procedures patch, part 1
Hi,
attached is a proposed draft-patch for type-bound procedures; it is
meant to parse and resolve (that is, check the binding, PASS/NOPASS and
such is correct) specific bindings, that is ones of the form
PROCEDURE, attributes :: name => target
The found procedures are stored as symtrees in the derived-type's
f2k_derived namespace; additional attributes specific to type-bound
procedures are added as new pointer member to gfc_symtree.
Awaiting your comments on this way to store the information and the
various XXX marks still in the patch... However, the patch introduces
no regressions on i686-pc-linux-gnu and all my own tests succeed.
I'd like to get this patch in the current scope (parsing and resolving)
reviewed and checked-in (with a not-yet-implemented message to be added)
as to keep patches small before continuing with actually calling those
procedures.
Yours,
Daniel
--
Done: Arc-Bar-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
Underway: Cav-Dwa-Law-Fem
To go: Cav-Hea-Kni-Mon-Pri-Ran-Rog-Tou
2008-07-31 Daniel Kraft <d@domob.eu>
* gfortran.h (gfc_typebound_proc): New struct.
(gfc_symtree): New member typebound.
(gfc_find_typebound_proc): Prototype for new method.
* parse.h (gfc_compile_state): New state COMP_DERIVED_CONTAINS.
* decl.c (gfc_match_procedure): Handle PROCEDURE inside derived-type
CONTAINS section.
(gfc_match_end): Handle new context COMP_DERIVED_CONTAINS.
(gfc_match_private): Ditto.
(match_binding_attributes), (match_procedure_in_type): New methods.
(gfc_match_final_decl): Rewrote to make use of new
COMP_DERIVED_CONTAINS parser state.
* parse.c (typebound_default_access): New global helper variable.
(set_typebound_default_access): New callback method.
(parse_derived_contains): New method.
(parse_derived): Extracted handling of CONTAINS to new parser state
and parse_derived_contains.
* resolve.c (get_derived_super_type): New method.
(gfc_find_typebound_proc): New method.
(resolve_bindings_derived), (resolve_bindings_result): New globals.
(resolve_typebound_procedure): New method.
(resolve_typebound_procedures): New method.
(resolve_fl_derived): Call new resolving method for typebound procs.
* symbol.c (gfc_new_symtree): Initialize new member typebound to NULL.
2008-07-31 Daniel Kraft <d@domob.eu>
* gfortran.dg/finalize_5.f03: Adapted expected error message to changes
to handling of CONTAINS in derived-type declarations.
* gfortran.dg/typebound_proc_1.f08: New test.
* gfortran.dg/typebound_proc_2.f90: New test.
* gfortran.dg/typebound_proc_3.f03: New test.
* gfortran.dg/typebound_proc_4.f03: New test.
* gfortran.dg/typebound_proc_5.f03: New test.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 138294)
+++ gcc/fortran/symbol.c (working copy)
@@ -2233,6 +2233,7 @@ gfc_new_symtree (gfc_symtree **root, con
st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
+ st->typebound = NULL;
gfc_insert_bbt (root, st, compare_symtree);
return st;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 138294)
+++ gcc/fortran/decl.c (working copy)
@@ -4300,6 +4300,8 @@ syntax:
/* General matcher for PROCEDURE declarations. */
+static match match_procedure_in_type (void);
+
match
gfc_match_procedure (void)
{
@@ -4318,9 +4320,12 @@ 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");
+ gfc_error ("Fortran 2003: Procedure components at %C are not yet"
+ " implemented in gfortran");
return MATCH_ERROR;
+ case COMP_DERIVED_CONTAINS:
+ m = match_procedure_in_type ();
+ break;
default:
return MATCH_NO;
}
@@ -5079,7 +5084,7 @@ gfc_match_end (gfc_statement *st)
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
- if (state == COMP_CONTAINS)
+ if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
{
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL
@@ -5126,6 +5131,7 @@ gfc_match_end (gfc_statement *st)
break;
case COMP_DERIVED:
+ case COMP_DERIVED_CONTAINS:
*st = ST_END_TYPE;
target = " type";
eos_ok = 0;
@@ -5803,9 +5809,12 @@ gfc_match_private (gfc_statement *st)
return MATCH_NO;
if (gfc_current_state () != COMP_MODULE
- && (gfc_current_state () != COMP_DERIVED
- || !gfc_state_stack->previous
- || gfc_state_stack->previous->state != COMP_MODULE))
+ && !(gfc_current_state () == COMP_DERIVED
+ && gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_MODULE)
+ && !(gfc_current_state () == COMP_DERIVED_CONTAINS
+ && gfc_state_stack->previous && gfc_state_stack->previous->previous
+ && gfc_state_stack->previous->previous->state == COMP_MODULE))
{
gfc_error ("PRIVATE statement at %C is only allowed in the "
"specification part of a module");
@@ -6682,6 +6691,262 @@ cleanup:
}
+
+/* Match binding attributes. */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba)
+{
+ bool found_passing = false;
+ match m;
+
+ /* Intialize to defaults. Do so even before the MATCH_NO check so that in
+ this case the defaults are in there. */
+ ba->access = ACCESS_UNKNOWN;
+ ba->pass_arg = NULL;
+ ba->pass_arg_num = 0;
+ ba->nopass = 0;
+ ba->non_overridable = 0;
+
+ /* If we find a comma, we believe there are binding attributes. */
+ if (gfc_match_char (',') == MATCH_NO)
+ return MATCH_NO;
+
+ /* XXX: Below is quite a lot of ugly code duplication... I could rewrite this
+ using macros, but that might be even uglier... What do you think? Any
+ completely other suggestions maybe? */
+
+ do
+ {
+ /* NOPASS flag. */
+ m = gfc_match (" nopass");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (found_passing)
+ {
+ gfc_error ("Binding attributes already specify passing, illegal"
+ " NOPASS at %C");
+ goto error;
+ }
+
+ found_passing = true;
+ ba->nopass = 1;
+ 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;
+ }
+
+ /* PASS possibly including argument. */
+ m = gfc_match (" pass");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (found_passing)
+ {
+ gfc_error ("Binding attributes already specify passing, illegal"
+ " PASS at %C");
+ goto error;
+ }
+
+ m = gfc_match (" ( %n )", arg);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ ba->pass_arg = xstrdup (arg);
+ gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+ found_passing = true;
+ ba->nopass = 0;
+ continue;
+ }
+
+ /* Access specifier. */
+ /* XXX: Seems there's no code around that can be reused for this? */
+
+ m = gfc_match (" public");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Duplicate access-specifier at %C");
+ goto error;
+ }
+
+ ba->access = ACCESS_PUBLIC;
+ continue;
+ }
+
+ m = gfc_match (" private");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Duplicate access-specifier at %C");
+ goto error;
+ }
+
+ ba->access = ACCESS_PRIVATE;
+ continue;
+ }
+
+ /* Nothing matching found. */
+ gfc_error ("Expected binding attribute at %C");
+ goto error;
+ }
+ while (gfc_match_char (',') == MATCH_YES);
+
+ return MATCH_YES;
+
+error:
+ gfc_free (ba->pass_arg);
+ return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE specific binding inside a derived type. */
+
+static match
+match_procedure_in_type (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char target_buf[GFC_MAX_SYMBOL_LEN + 1];
+ char* target;
+ gfc_typebound_proc* tb;
+ bool seen_colons;
+ bool seen_attrs;
+ match m;
+ gfc_symtree* stree;
+ gfc_namespace* ns;
+ gfc_symbol* block;
+
+ /* Check current state. */
+ gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+ block = gfc_state_stack->previous->sym;
+ gcc_assert (block);
+ /* XXX: Here's nothing about the need to be inside the specification part of
+ a module! */
+
+ /* TODO: Implement PROCEDURE(interface). */
+
+ /* Construct the data structure. */
+ tb = XCNEW (gfc_typebound_proc);
+ tb->where = gfc_current_locus;
+
+ /* Match binding attributes. */
+ m = match_binding_attributes (tb);
+ if (m == MATCH_ERROR)
+ return m;
+ seen_attrs = (m == MATCH_YES);
+
+ /* Match the colons. */
+ m = gfc_match (" ::");
+ if (m == MATCH_ERROR)
+ return m;
+ seen_colons = (m == MATCH_YES);
+ if (seen_attrs && !seen_colons)
+ {
+ gfc_error ("Expected '::' after binding-attributes at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match the binding name. */
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding name at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Try to match the '=> target', if it's there. */
+ target = NULL;
+ m = gfc_match (" =>");
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_YES)
+ {
+ if (!seen_colons)
+ {
+ gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+ " at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding target after '=>' at %C");
+ return MATCH_ERROR;
+ }
+ target = target_buf;
+ }
+
+ /* Now we should have the end. */
+ m = gfc_match_eos ();
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Junk after PROCEDURE declaration at %C");
+ return MATCH_ERROR;
+ }
+
+ /* If no target was found, it has the same name as the binding. */
+ if (!target)
+ target = name;
+
+ /* Get the namespace to insert the symbols into. */
+ ns = block->f2k_derived;
+ gcc_assert (ns);
+
+ /* See if we already have a binding with this name in the symtree which would
+ be an error. */
+ /* XXX: It should be one, right? */
+ stree = gfc_find_symtree (ns->sym_root, name);
+ if (stree)
+ {
+ gfc_error ("There's already a procedure with binding name '%s' for the"
+ " derived type '%s' at %C", name, block->name);
+ return MATCH_ERROR;
+ }
+
+ /* Insert it and set attributes. */
+ if (gfc_get_sym_tree (name, ns, &stree))
+ return MATCH_ERROR;
+ if (gfc_get_sym_tree (target, gfc_current_ns, &tb->target))
+ return MATCH_ERROR;
+ stree->typebound = tb;
+
+ return MATCH_YES;
+}
+
+
/* Match a FINAL declaration inside a derived type. */
match
@@ -6692,18 +6957,20 @@ gfc_match_final_decl (void)
match m;
gfc_namespace* module_ns;
bool first, last;
+ gfc_symbol* block;
- if (gfc_state_stack->state != COMP_DERIVED)
+ if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{
gfc_error ("FINAL declaration at %C must be inside a derived type "
- "definition!");
+ "CONTAINS section");
return MATCH_ERROR;
}
- gcc_assert (gfc_current_block ());
+ block = gfc_state_stack->previous->sym;
+ gcc_assert (block);
- if (!gfc_state_stack->previous
- || gfc_state_stack->previous->state != COMP_MODULE)
+ if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
+ || gfc_state_stack->previous->previous->state != COMP_MODULE)
{
gfc_error ("Derived type declaration with FINAL at %C must be in the"
" specification part of a MODULE");
@@ -6761,7 +7028,7 @@ gfc_match_final_decl (void)
return MATCH_ERROR;
/* Check if we already have this symbol in the list, this is an error. */
- for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
+ for (f = block->f2k_derived->finalizers; f; f = f->next)
if (f->procedure == sym)
{
gfc_error ("'%s' at %C is already defined as FINAL procedure!",
@@ -6770,13 +7037,13 @@ gfc_match_final_decl (void)
}
/* Add this symbol to the list of finalizers. */
- gcc_assert (gfc_current_block ()->f2k_derived);
+ gcc_assert (block->f2k_derived);
++sym->refs;
f = XCNEW (gfc_finalizer);
f->procedure = sym;
f->where = gfc_current_locus;
- f->next = gfc_current_block ()->f2k_derived->finalizers;
- gfc_current_block ()->f2k_derived->finalizers = f;
+ f->next = block->f2k_derived->finalizers;
+ block->f2k_derived->finalizers = f;
first = false;
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 138294)
+++ gcc/fortran/gfortran.h (working copy)
@@ -992,6 +992,30 @@ typedef struct
}
gfc_user_op;
+
+/* Data needed for type-bound procedures. */
+typedef struct
+{
+ struct gfc_symtree* target;
+ locus where; /* Where the PROCEDURE definition was. */
+
+ gfc_access access;
+ char* pass_arg; /* Argument-name for PASS. NULL if not specified. */
+ /* XXX: Should we use static array of GFC_MAX_SYMBOL_LENGTH+1 characters?
+ This makes life easier to avoid leaking but may cost a lot of memory if
+ there are lots of these structs around. */
+
+ /* Once resolved, we use the position of pass_arg in the formal arglist of
+ the binding-target procedure to identify it. The first argument has
+ number 0 here, the second 1, and so on. */
+ unsigned pass_arg_num;
+
+ unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
+ unsigned non_overridable:1;
+}
+gfc_typebound_proc;
+
+
/* Symbol nodes. These are important things. They are what the
standard refers to as "entities". The possibly multiple names that
refer to the same entity are accomplished by a binary tree of
@@ -1128,6 +1152,8 @@ typedef struct gfc_symtree
}
n;
+ /* Data for type-bound procedures; NULL if no type-bound procedure. */
+ gfc_typebound_proc* typebound;
}
gfc_symtree;
@@ -2348,6 +2374,8 @@ gfc_try gfc_resolve_dim_arg (gfc_expr *)
int gfc_is_formal_arg (void);
void gfc_resolve_substring_charlen (gfc_expr *);
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
+/* XXX: Which file to put this best in? */
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
/* array.c */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 138294)
+++ gcc/fortran/resolve.c (working copy)
@@ -7587,6 +7587,181 @@ error:
}
+/* Get the super-type of a given derived type. */
+
+static gfc_symbol*
+get_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ gcc_assert (derived->components);
+ gcc_assert (derived->components->ts.type == BT_DERIVED);
+ gcc_assert (derived->components->ts.derived);
+
+ return derived->components->ts.derived;
+}
+
+
+/* Find a type-bound procedure by name for a derived-type (looking recursively
+ through the super-types). */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
+{
+ gfc_symtree* res;
+
+ /* Try to find it in the current type's namespace. */
+ gcc_assert (derived->f2k_derived);
+ res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+ if (res)
+ return res->typebound ? res : NULL;
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = get_derived_super_type (derived);
+ gcc_assert (super_type);
+ return gfc_find_typebound_proc (super_type, name);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Resolve the type-bound procedures for a derived type. */
+
+static gfc_symbol* resolve_bindings_derived;
+static gfc_try resolve_bindings_result;
+
+static void
+resolve_typebound_procedure (gfc_symtree* stree)
+{
+ gfc_symbol* proc;
+ locus where;
+ gfc_symbol* me_arg;
+ gfc_symbol* super_type;
+
+ /* If this is no type-bound procedure, just return. */
+ if (!stree->typebound)
+ return;
+
+ /* Get the target-procedure to check it. */
+ gcc_assert (stree->typebound->target);
+ proc = stree->typebound->target->n.sym;
+ where = stree->typebound->where;
+
+ /* Default access should already be resolved from the parser. */
+ gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
+
+ /* It should be a procedure. */
+ if (!proc->attr.subroutine && !proc->attr.function)
+ {
+ gfc_error ("Binding-target '%s' must be a procedure at %L",
+ proc->name, &where);
+ goto error;
+ }
+
+ /* Find the super-type of the current derived type. */
+ /* XXX: Should we do this one time and make super_type a global, too? */
+ super_type = get_derived_super_type (resolve_bindings_derived);
+
+ /* If we are extending some type, check that we don't override a procedure
+ flagged NON_OVERRIDABLE. */
+ if (super_type)
+ {
+ gfc_symtree* overridden;
+ overridden = gfc_find_typebound_proc (super_type, stree->name);
+
+ if (overridden && overridden->typebound->non_overridable)
+ {
+ gfc_error ("'%s' at %L overrides a procedure binding declared"
+ " NON_OVERRIDABLE", stree->name, &where);
+ goto error;
+ }
+ }
+
+ /* If PASS, resolve and check arguments. */
+ if (!stree->typebound->nopass)
+ {
+ if (stree->typebound->pass_arg)
+ {
+ gfc_formal_arglist* i;
+
+ /* If an explicit passing argument name is given, walk the arg-list
+ and look for it. */
+
+ me_arg = NULL;
+ stree->typebound->pass_arg_num = 0;
+ for (i = proc->formal; i; i = i->next)
+ {
+ if (!strcmp (i->sym->name, stree->typebound->pass_arg))
+ {
+ me_arg = i->sym;
+ break;
+ }
+ ++stree->typebound->pass_arg_num;
+ }
+
+ if (!me_arg)
+ {
+ gfc_error ("Binding-target '%s' with PASS(%s) at %L has no"
+ " argument '%s'",
+ proc->name, stree->typebound->pass_arg, &where,
+ stree->typebound->pass_arg);
+ goto error;
+ }
+ }
+ else
+ {
+ /* Otherwise, take the first one; there should in fact be at least
+ one. */
+ stree->typebound->pass_arg_num = 0;
+ if (!proc->formal)
+ {
+ gfc_error ("Binding-target '%s' with PASS at %L must have at"
+ " least one argument", proc->name, &where);
+ goto error;
+ }
+ me_arg = proc->formal->sym;
+ }
+
+ /* Now check that the argument-type matches. */
+ gcc_assert (me_arg);
+ if (me_arg->ts.type != BT_DERIVED
+ || me_arg->ts.derived != resolve_bindings_derived)
+ {
+ gfc_error ("Argument '%s' of the binding target '%s' with PASS(%s)"
+ " at %L must be of the derived-type '%s'",
+ me_arg->name, proc->name, me_arg->name, &where,
+ resolve_bindings_derived->name);
+ goto error;
+ }
+ }
+
+ return;
+
+error:
+ resolve_bindings_result = FAILURE;
+}
+
+static gfc_try
+resolve_typebound_procedures (gfc_symbol* derived)
+{
+ if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
+ return SUCCESS;
+
+ resolve_bindings_derived = derived;
+ resolve_bindings_result = SUCCESS;
+ gfc_traverse_symtree (derived->f2k_derived->sym_root,
+ &resolve_typebound_procedure);
+
+ return resolve_bindings_result;
+}
+
+
/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
to give all identical derived types the same backend_decl. */
static void
@@ -7696,6 +7871,10 @@ resolve_fl_derived (gfc_symbol *sym)
}
}
+ /* Resolve the type-bound procedures. */
+ if (resolve_typebound_procedures (sym) == FAILURE)
+ return FAILURE;
+
/* Resolve the finalizer procedures. */
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 138294)
+++ gcc/fortran/parse.c (working copy)
@@ -1690,13 +1690,145 @@ unexpected_eof (void)
}
+/* Set the default access attribute for a typebound procedure; this is used
+ as callback for gfc_traverse_symtree. */
+
+static gfc_access typebound_default_access;
+
+static void
+set_typebound_default_access (gfc_symtree* stree)
+{
+ if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN)
+ stree->typebound->access = typebound_default_access;
+}
+
+
+/* Parse the CONTAINS section of a derived type definition. */
+
+static bool
+parse_derived_contains (void)
+{
+ gfc_state_data s;
+ bool seen_private = false;
+ bool seen_comps = false;
+ bool error_flag = false;
+ bool to_finish;
+
+ accept_statement (ST_CONTAINS);
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+ push_state (&s, COMP_DERIVED_CONTAINS, NULL);
+
+ to_finish = false;
+ while (!to_finish)
+ {
+ gfc_statement st;
+ st = next_statement ();
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ /* XXX: unexpected_eof longjmp's away, but for clarity I'd like to
+ have this break here; or remove it? */
+ break;
+
+ case ST_DATA_DECL:
+ gfc_error ("Components in TYPE at %C must precede CONTAINS");
+ error_flag = true;
+ break;
+
+ case ST_PROCEDURE:
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
+ " procedure at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_PROCEDURE);
+ seen_comps = true;
+ break;
+
+ case ST_FINAL:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: FINAL procedure declaration"
+ " at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_FINAL);
+ seen_comps = true;
+ break;
+
+ case ST_END_TYPE:
+ to_finish = true;
+
+ if (!seen_comps
+ && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+ "definition at %C with empty CONTAINS "
+ "section") == FAILURE))
+ error_flag = true;
+
+ /* ST_END_TYPE is accepted by parse_derived after return. */
+ break;
+
+ case ST_PRIVATE:
+ if (gfc_find_state (COMP_MODULE) == FAILURE)
+ {
+ gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+ "a MODULE");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_comps)
+ {
+ gfc_error ("PRIVATE statement at %C must precede procedure"
+ " bindings");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_private)
+ {
+ gfc_error ("Duplicate PRIVATE statement at %C");
+ error_flag = true;
+ }
+
+ accept_statement (ST_PRIVATE);
+ seen_private = true;
+ break;
+
+ case ST_SEQUENCE:
+ gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+ error_flag = true;
+ break;
+
+ case ST_CONTAINS:
+ gfc_error ("Already inside a CONTAINS block at %C");
+ error_flag = true;
+ break;
+
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+
+ pop_state ();
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+
+ /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
+ to PUBLIC or PRIVATE depending on seen_private. */
+ typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
+ gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
+ &set_typebound_default_access);
+
+ return error_flag;
+}
+
+
/* Parse a derived type. */
static void
parse_derived (void)
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
- int seen_contains, seen_contains_comp;
gfc_statement st;
gfc_state_data s;
gfc_symbol *derived_sym = NULL;
@@ -1712,8 +1844,6 @@ parse_derived (void)
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
- seen_contains = 0;
- seen_contains_comp = 0;
compiling_type = 1;
@@ -1726,34 +1856,22 @@ parse_derived (void)
unexpected_eof ();
case ST_DATA_DECL:
- case ST_PROCEDURE:
- if (seen_contains)
- {
- gfc_error ("Components in TYPE at %C must precede CONTAINS");
- error_flag = 1;
- }
-
accept_statement (st);
seen_component = 1;
break;
- case ST_FINAL:
- if (!seen_contains)
- {
- gfc_error ("FINAL declaration at %C must be inside CONTAINS");
- error_flag = 1;
- }
-
- if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: FINAL procedure declaration"
- " at %C") == FAILURE)
- error_flag = 1;
+ case ST_PROCEDURE:
+ gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
+ error_flag = 1;
+ break;
- accept_statement (ST_FINAL);
- seen_contains_comp = 1;
+ case ST_FINAL:
+ gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+ error_flag = 1;
break;
case ST_END_TYPE:
+endType:
compiling_type = 0;
if (!seen_component
@@ -1762,22 +1880,10 @@ parse_derived (void)
== FAILURE))
error_flag = 1;
- if (seen_contains && !seen_contains_comp
- && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
- "definition at %C with empty CONTAINS "
- "section") == FAILURE))
- error_flag = 1;
-
accept_statement (ST_END_TYPE);
break;
case ST_PRIVATE:
- if (seen_contains)
- {
- gfc_error ("PRIVATE statement at %C must precede CONTAINS");
- error_flag = 1;
- }
-
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
@@ -1801,17 +1907,12 @@ parse_derived (void)
}
s.sym->component_access = ACCESS_PRIVATE;
+
accept_statement (ST_PRIVATE);
seen_private = 1;
break;
case ST_SEQUENCE:
- if (seen_contains)
- {
- gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
- error_flag = 1;
- }
-
if (seen_component)
{
gfc_error ("SEQUENCE statement at %C must precede "
@@ -1841,15 +1942,10 @@ parse_derived (void)
" definition at %C") == FAILURE)
error_flag = 1;
- if (seen_contains)
- {
- gfc_error ("Already inside a CONTAINS block at %C");
- error_flag = 1;
- }
-
- seen_contains = 1;
accept_statement (ST_CONTAINS);
- break;
+ if (parse_derived_contains ())
+ error_flag = 1;
+ goto endType;
default:
unexpected_statement (st);
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h (revision 138294)
+++ gcc/fortran/parse.h (working copy)
@@ -29,8 +29,8 @@ along with GCC; see the file COPYING3.
typedef enum
{
COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
- COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO,
- COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
+ COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF,
+ COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_OMP_STRUCTURED_BLOCK
}
gfc_compile_state;
Index: gcc/testsuite/gfortran.dg/finalize_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_5.f03 (revision 138294)
+++ gcc/testsuite/gfortran.dg/finalize_5.f03 (working copy)
@@ -9,7 +9,7 @@ MODULE final_type
TYPE :: mytype
INTEGER, ALLOCATABLE :: fooarr(:)
REAL :: foobar
- FINAL :: finalize_matrix ! { dg-error "must be inside CONTAINS" }
+ FINAL :: finalize_matrix ! { dg-error "must be inside a derived type" }
CONTAINS
FINAL :: ! { dg-error "Empty FINAL" }
FINAL ! { dg-error "Empty FINAL" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 0)
@@ -0,0 +1,69 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Test that the basic syntax for specific bindings is parsed and resolved.
+
+MODULE othermod
+ IMPLICIT NONE
+
+CONTAINS
+
+ SUBROUTINE othersub ()
+ IMPLICIT NONE
+ END SUBROUTINE othersub
+
+END MODULE othermod
+
+MODULE testmod
+ USE othermod
+ IMPLICIT NONE
+
+ TYPE t1
+ ! Might be empty
+ CONTAINS
+ PROCEDURE proc1
+ PROCEDURE, PASS(me) :: p2 => proc2
+ END TYPE t1
+
+ TYPE t2
+ INTEGER :: x
+ CONTAINS
+ PRIVATE
+ PROCEDURE, NOPASS, PRIVATE :: othersub
+ PROCEDURE,NON_OVERRIDABLE,PUBLIC,PASS :: proc3
+ END TYPE t2
+
+ TYPE t3
+ CONTAINS
+ ! This might be empty for Fortran 2008
+ END TYPE t3
+
+ TYPE t4
+ CONTAINS
+ PRIVATE
+ ! Empty, too
+ END TYPE t4
+
+CONTAINS
+
+ SUBROUTINE proc1 (me)
+ IMPLICIT NONE
+ TYPE(t1) :: me
+ END SUBROUTINE proc1
+
+ REAL FUNCTION proc2 (x, me)
+ IMPLICIT NONE
+ REAL :: x
+ TYPE(t1) :: me
+ proc2 = x / 2
+ END FUNCTION proc2
+
+ INTEGER FUNCTION proc3 (me)
+ IMPLICIT NONE
+ TYPE(t2) :: me
+ proc3 = 42
+ END FUNCTION proc3
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_3.f03 (revision 0)
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! Type-bound procedures
+! Test that F2003 does not allow empty CONTAINS sections.
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE t
+ INTEGER :: x
+ CONTAINS
+ END TYPE t ! { dg-error "Fortran 2008" }
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_4.f03 (revision 0)
@@ -0,0 +1,39 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for errors in specific bindings, during parsing (not resolution).
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE t
+ REAL :: a
+ CONTAINS
+ PROCEDURE p0 ! { dg-error "no IMPLICIT|a procedure" }
+ PRIVATE ! { dg-error "must precede" }
+ PROCEDURE p1 => proc1 ! { dg-error "::" }
+ PROCEDURE :: ! { dg-error "Expected binding name" }
+ PROCEDURE ! { dg-error "Expected binding name" }
+ PROCEDURE ? ! { dg-error "Expected binding name" }
+ PROCEDURE :: p2 => ! { dg-error "Expected binding target" }
+ PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" }
+ PROCEDURE p4, ! { dg-error "Junk after" }
+ PROCEDURE :: p5 => proc2, ! { dg-error "Junk after" }
+ PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" }
+ PROCEDURE, PASS p6 ! { dg-error "::" }
+ PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" }
+ PROCEDURE PASS :: ! { dg-error "Junk after" }
+ PROCEDURE, PASS (x ! { dg-error "Expected" }
+ PROCEDURE, PASS () ! { dg-error "Expected" }
+ PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" }
+ PROCEDURE, PASS, NON_OVERRIDABLE, PASS(x) ! { dg-error "illegal PASS" }
+ PROCEDURE, PUBLIC, PRIVATE ! { dg-error "Duplicate" }
+ PROCEDURE, NON_OVERRIDABLE, NON_OVERRIDABLE ! { dg-error "Duplicate" }
+ PROCEDURE, NOPASS, NOPASS ! { dg-error "illegal NOPASS" }
+ END TYPE t
+
+CONTAINS
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_2.f90 (revision 0)
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! Type-bound procedures
+! Test that F95 does not allow type-bound procedures
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE t
+ INTEGER :: x
+ CONTAINS ! { dg-error "Fortran 2003" }
+ PROCEDURE proc1 ! { dg-error "Fortran 2003" }
+ PROCEDURE :: proc2 => p2 ! { dg-error "Fortran 2003" }
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc1 (me)
+ IMPLICIT NONE
+ TYPE(t1) :: me
+ END SUBROUTINE proc1
+
+ REAL FUNCTION proc2 (me, x)
+ IMPLICIT NONE
+ TYPE(t1) :: me
+ REAL :: x
+ proc2 = x / 2
+ END FUNCTION proc2
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
+! { dg-excess-errors "no IMPLICIT type" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (revision 0)
@@ -0,0 +1,90 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for errors in specific bindings, during resolution.
+
+! XXX: Do overriding bindings have to have the same or some "matching" signature
+! as their overridden binding?
+
+MODULE othermod
+ IMPLICIT NONE
+CONTAINS
+
+ REAL FUNCTION proc_noarg ()
+ IMPLICIT NONE
+ END FUNCTION proc_noarg
+
+END MODULE othermod
+
+MODULE testmod
+ USE othermod
+ IMPLICIT NONE
+
+ INTEGER :: noproc
+
+ TYPE supert
+ CONTAINS
+ PROCEDURE, NOPASS :: super_overrid => proc_noarg
+ PROCEDURE, NOPASS, NON_OVERRIDABLE :: super_nonoverrid => proc_noarg
+ END TYPE supert
+
+ TYPE, EXTENDS(supert) :: t
+ CONTAINS
+
+ ! Bindings that should succeed
+ PROCEDURE, NOPASS :: p0 => proc_noarg
+ PROCEDURE, PASS :: p1 => proc_arg_first
+ PROCEDURE proc_arg_first
+ PROCEDURE, PASS(me) :: p2 => proc_arg_middle
+ PROCEDURE, PASS(me), NON_OVERRIDABLE :: p3 => proc_arg_last
+ PROCEDURE, NOPASS :: p4 => proc_nome
+ PROCEDURE :: super_overrid => proc_arg_first
+
+ ! Bindings that should not succeed
+ PROCEDURE :: e0 => undefined ! { dg-error "has no IMPLICIT|a procedure" }
+ PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" }
+ PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" }
+ PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" }
+ PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "of the derived" }
+ PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "of the derived" }
+ PROCEDURE :: e6 => noproc ! { dg-error "must be a procedure" }
+ PROCEDURE :: super_nonoverrid => proc_arg_first ! { dg-error "NON_OVERRIDABLE" }
+
+ ! XXX: How to do a PRIVATE subroutine for access checking?
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc_arg_first (me, x)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ REAL :: x
+ END SUBROUTINE proc_arg_first
+
+ INTEGER FUNCTION proc_arg_middle (x, me, y)
+ IMPLICIT NONE
+ REAL :: x, y
+ TYPE(t) :: me
+ END FUNCTION proc_arg_middle
+
+ SUBROUTINE proc_arg_last (x, me)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ REAL :: x
+ END SUBROUTINE proc_arg_last
+
+ SUBROUTINE proc_nome (arg, x, y)
+ IMPLICIT NONE
+ TYPE(t) :: arg
+ REAL :: x, y
+ END SUBROUTINE proc_nome
+
+ SUBROUTINE proc_mewrong (me, x)
+ IMPLICIT NONE
+ REAL :: x
+ INTEGER :: me
+ END SUBROUTINE proc_mewrong
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "othermod testmod" } }