This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] PR fortran/37193: USE m, ONLY: i, j => i
- From: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>
- To: "Daniel Kraft" <d at domob dot eu>
- Cc: "Fortran List" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 30 Aug 2008 18:05:24 +0200
- Subject: Re: [Patch, Fortran] PR fortran/37193: USE m, ONLY: i, j => i
- References: <48B961CD.8060606@domob.eu>
Daniel,
It's a lovely patch but I think it's the wrong one:-)
Cheers
Paul
On Sat, Aug 30, 2008 at 5:05 PM, Daniel Kraft <d@domob.eu> wrote:
> Hi,
>
> this is a fix for PR fortran/37193 where a statement as
>
> USE m, ONLY: i, j => i
>
> would only allow j as use-associated name and not i because the
> gfc_delete_symtree in module.c:4062 had removed it when j was bound to
> i. The attached patch initializes sym->attr.use_only directly in the
> loop there and thus avoids the removal.
>
> No regressions on GNU/Linux-x86-32. Is this fix ok? I have to admit I
> don't know that part of the code very well so I might well have
> overlooked something.
>
> Cheers,
> Daniel
>
> --
> Done: Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
> To go: Hea-Kni-Mon-Pri-Ran-Rog-Tou
>
>
> 2008-08-30 Daniel Kraft <d@domob.eu>
>
> * gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
> (struct gfc_tbp_generic): New type.
> (struct gfc_typebound_proc): Removed `target' and added union with
> `specific' and `generic' members; new members `overridden',
> `subroutine', `function' and `is_generic'.
> (struct gfc_expr): New members `derived' and `name' in compcall union
> member and changed type of `tbp' to gfc_typebound_proc.
> (gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
> * match.h (gfc_typebound_default_access): New global.
> (gfc_match_generic): New method.
> * decl.c (gfc_match_generic): New method.
> (match_binding_attributes): New argument `generic' and handle it.
> (match_procedure_in_type): Mark matched binding as non-generic.
> (match_generic_in_type): New method.
> * interface.c (gfc_compare_interfaces): Made public.
> (gfc_compare_actual_formal): Ditto.
> (check_interface_1), (compare_parameter): Use new public names.
> (gfc_procedure_use), (gfc_search_interface): Ditto.
> * match.c (match_typebound_call): Set base-symbol referenced.
> * module.c (binding_generic): New global array.
> (current_f2k_derived): New global.
> (mio_typebound_proc): Handle IO of GENERIC bindings.
> (mio_f2k_derived): Record current f2k-namespace in
> current_f2k_derived.
> * parse.c (decode_statement): Handle GENERIC statement.
> (gfc_ascii_statement): Ditto.
> (typebound_default_access), (set_typebound_default_access): Removed.
> (gfc_typebound_default_access): New global.
> (parse_derived_contains): New default-access implementation and
> handle
> GENERIC statements encountered.
> (parse_derived): Handle ST_GENERIC with an error.
> * primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
> structure and removed check for SUBROUTINE/FUNCTION from here.
> * resolve.c (extract_compcall_passed_object): New method.
> (update_compcall_arglist): Use it.
> (resolve_typebound_static): Adapted to new gfc_typebound_proc
> structure.
> (resolve_typebound_generic_call): New method.
> (resolve_typebound_call): Check target is a SUBROUTINE and handle
> calls
> to GENERIC bindings.
> (resolve_compcall): Ditto (check for target being FUNCTION).
> (check_typebound_override): Handle GENERIC bindings.
> (check_generic_tbp_ambiguity), (resolve_typebound_generic): New
> methods.
> (resolve_typebound_procedure): Handle GENERIC bindings and set new
> attributes subroutine, function and overridden in gfc_typebound_proc.
> (resolve_fl_derived): Ensure extended type is resolved before the
> extending one is.
> * st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
> * symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.
>
> 2008-08-30 Daniel Kraft <d@domob.eu>
>
> * gfortran.dg/typebound_generic_1.f03: New test.
> * gfortran.dg/typebound_generic_2.f03: New test.
> * gfortran.dg/typebound_generic_3.f03: New test.
>
>
> Index: gcc/fortran/interface.c
> ===================================================================
> --- gcc/fortran/interface.c (revision 139725)
> +++ gcc/fortran/interface.c (working copy)
> @@ -479,7 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_s
> }
>
>
> -static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
> static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
>
> /* Given two symbols that are formal arguments, compare their types
> @@ -954,8 +953,8 @@ generic_correspondence (gfc_formal_argli
> We return nonzero if there exists an actual argument list that
> would be ambiguous between the two interfaces, zero otherwise. */
>
> -static int
> -compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
> +int
> +gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
> {
> gfc_formal_arglist *f1, *f2;
>
> @@ -1173,7 +1172,7 @@ check_interface1 (gfc_interface *p, gfc_
> if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
> continue;
>
> - if (compare_interfaces (p->sym, q->sym, generic_flag))
> + if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
> {
> if (referenced)
> {
> @@ -1460,7 +1459,7 @@ compare_parameter (gfc_symbol *formal, g
> if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
> goto proc_fail;
> }
> - else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
> + else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
> goto proc_fail;
>
> return 1;
> @@ -1819,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
> errors when things don't match instead of just returning the status
> code. */
>
> -static int
> -compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
> - int ranks_must_agree, int is_elemental, locus *where)
> +int
> +gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist
> *formal,
> + int ranks_must_agree, int is_elemental, locus
> *where)
> {
> gfc_actual_arglist **new_arg, *a, *actual, temp;
> gfc_formal_arglist *f;
> @@ -2449,8 +2448,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
> return;
> }
>
> - if (!compare_actual_formal (ap, sym->formal, 0,
> - sym->attr.elemental, where))
> + if (!gfc_compare_actual_formal (ap, sym->formal, 0,
> + sym->attr.elemental, where))
> return;
>
> check_intents (sym->formal, *ap);
> @@ -2479,7 +2478,7 @@ gfc_search_interface (gfc_interface *int
>
> r = !intr->sym->attr.elemental;
>
> - if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
> + if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
> {
> check_intents (intr->sym->formal, *ap);
> if (gfc_option.warn_aliasing)
> Index: gcc/fortran/symbol.c
> ===================================================================
> --- gcc/fortran/symbol.c (revision 139725)
> +++ gcc/fortran/symbol.c (working copy)
> @@ -4278,11 +4278,8 @@ gfc_find_typebound_proc (gfc_symbol* der
> /* 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)
> + if (res && res->typebound)
> {
> - if (!res->typebound)
> - return NULL;
> -
> /* We found one. */
> if (t)
> *t = SUCCESS;
> Index: gcc/fortran/decl.c
> ===================================================================
> --- gcc/fortran/decl.c (revision 139725)
> +++ gcc/fortran/decl.c (working copy)
> @@ -4366,6 +4366,37 @@ gfc_match_procedure (void)
> }
>
>
> +/* Delegating matcher for GENERIC. */
> +
> +static match match_generic_in_type (void);
> +
> +/* XXX: Should I incorporate this and match_generic_in_type? */
> +
> +match
> +gfc_match_generic (void)
> +{
> + match m;
> +
> + switch (gfc_current_state ())
> + {
> + case COMP_DERIVED_CONTAINS:
> + m = match_generic_in_type ();
> + break;
> + default:
> + return MATCH_NO;
> + }
> +
> + if (m != MATCH_YES)
> + return m;
> +
> + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding at %C")
> + == FAILURE)
> + return MATCH_ERROR;
> +
> + return m;
> +}
> +
> +
> /* Warn if a matched procedure has the same name as an intrinsic; this is
> simply a wrapper around gfc_warn_intrinsic_shadow that interprets the
> current
> parser-state-stack to find out whether we're in a module. */
> @@ -6721,7 +6752,7 @@ cleanup:
> /* Match binding attributes. */
>
> static match
> -match_binding_attributes (gfc_typebound_proc* ba)
> +match_binding_attributes (gfc_typebound_proc* ba, bool generic)
> {
> bool found_passing = false;
> match m;
> @@ -6736,120 +6767,135 @@ match_binding_attributes (gfc_typebound_
>
> /* If we find a comma, we believe there are binding attributes. */
> if (gfc_match_char (',') == MATCH_NO)
> - return MATCH_NO;
> + {
> + ba->access = gfc_typebound_default_access;
> + return MATCH_NO;
> + }
>
> do
> {
> - /* NOPASS flag. */
> - m = gfc_match (" nopass");
> + /* Access specifier. */
> +
> + m = gfc_match (" public");
> if (m == MATCH_ERROR)
> goto error;
> if (m == MATCH_YES)
> {
> - if (found_passing)
> + if (ba->access != ACCESS_UNKNOWN)
> {
> - gfc_error ("Binding attributes already specify passing,
> illegal"
> - " NOPASS at %C");
> + gfc_error ("Duplicate access-specifier at %C");
> goto error;
> }
>
> - found_passing = true;
> - ba->nopass = 1;
> + ba->access = ACCESS_PUBLIC;
> continue;
> }
>
> - /* NON_OVERRIDABLE flag. */
> - m = gfc_match (" non_overridable");
> + m = gfc_match (" private");
> if (m == MATCH_ERROR)
> goto error;
> if (m == MATCH_YES)
> {
> - if (ba->non_overridable)
> + if (ba->access != ACCESS_UNKNOWN)
> {
> - gfc_error ("Duplicate NON_OVERRIDABLE at %C");
> + gfc_error ("Duplicate access-specifier at %C");
> goto error;
> }
>
> - ba->non_overridable = 1;
> + ba->access = ACCESS_PRIVATE;
> continue;
> }
>
> - /* DEFERRED flag. */
> - /* TODO: Handle really once implemented. */
> - m = gfc_match (" deferred");
> - if (m == MATCH_ERROR)
> - goto error;
> - if (m == MATCH_YES)
> - {
> - gfc_error ("DEFERRED not yet implemented at %C");
> - goto error;
> - }
> -
> - /* PASS possibly including argument. */
> - m = gfc_match (" pass");
> - if (m == MATCH_ERROR)
> - goto error;
> - if (m == MATCH_YES)
> + /* If inside GENERIC, the following is not allowed. */
> + if (!generic)
> {
> - char arg[GFC_MAX_SYMBOL_LEN + 1];
>
> - if (found_passing)
> + /* NOPASS flag. */
> + m = gfc_match (" nopass");
> + if (m == MATCH_ERROR)
> + goto error;
> + if (m == MATCH_YES)
> {
> - gfc_error ("Binding attributes already specify passing,
> illegal"
> - " PASS at %C");
> - goto error;
> + if (found_passing)
> + {
> + gfc_error ("Binding attributes already specify passing,"
> + " illegal NOPASS at %C");
> + goto error;
> + }
> +
> + found_passing = true;
> + ba->nopass = 1;
> + continue;
> }
>
> - m = gfc_match (" ( %n )", arg);
> + /* NON_OVERRIDABLE flag. */
> + m = gfc_match (" non_overridable");
> 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;
> - }
> + {
> + if (ba->non_overridable)
> + {
> + gfc_error ("Duplicate NON_OVERRIDABLE at %C");
> + goto error;
> + }
>
> - /* Access specifier. */
> + ba->non_overridable = 1;
> + continue;
> + }
>
> - m = gfc_match (" public");
> - if (m == MATCH_ERROR)
> - goto error;
> - if (m == MATCH_YES)
> - {
> - if (ba->access != ACCESS_UNKNOWN)
> + /* DEFERRED flag. */
> + /* TODO: Handle really once implemented. */
> + m = gfc_match (" deferred");
> + if (m == MATCH_ERROR)
> + goto error;
> + if (m == MATCH_YES)
> {
> - gfc_error ("Duplicate access-specifier at %C");
> + gfc_error ("DEFERRED not yet implemented 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)
> + /* PASS possibly including argument. */
> + m = gfc_match (" pass");
> + if (m == MATCH_ERROR)
> + goto error;
> + if (m == MATCH_YES)
> {
> - gfc_error ("Duplicate access-specifier at %C");
> - goto error;
> + 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;
> }
>
> - ba->access = ACCESS_PRIVATE;
> - continue;
> }
>
> /* Nothing matching found. */
> - gfc_error ("Expected binding attribute at %C");
> + if (generic)
> + gfc_error ("Expected access-specifier at %C");
> + else
> + gfc_error ("Expected binding attribute at %C");
> goto error;
> }
> while (gfc_match_char (',') == MATCH_YES);
>
> + if (ba->access == ACCESS_UNKNOWN)
> + ba->access = gfc_typebound_default_access;
> +
> return MATCH_YES;
>
> error:
> @@ -6890,9 +6936,10 @@ match_procedure_in_type (void)
> /* Construct the data structure. */
> tb = gfc_get_typebound_proc ();
> tb->where = gfc_current_locus;
> + tb->is_generic = 0;
>
> /* Match binding attributes. */
> - m = match_binding_attributes (tb);
> + m = match_binding_attributes (tb, false);
> if (m == MATCH_ERROR)
> return m;
> seen_attrs = (m == MATCH_YES);
> @@ -6962,9 +7009,10 @@ match_procedure_in_type (void)
> gcc_assert (ns);
>
> /* See if we already have a binding with this name in the symtree which
> would
> - be an error. */
> + be an error. If a GENERIC already targetted this binding, it may be
> + already there but then typebound is still NULL. */
> stree = gfc_find_symtree (ns->sym_root, name);
> - if (stree)
> + if (stree && stree->typebound)
> {
> gfc_error ("There's already a procedure with binding name '%s' for
> the"
> " derived type '%s' at %C", name, block->name);
> @@ -6974,14 +7022,140 @@ match_procedure_in_type (void)
> /* 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))
> + if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific))
> return MATCH_ERROR;
> + gfc_set_sym_referenced (tb->u.specific->n.sym);
> stree->typebound = tb;
>
> return MATCH_YES;
> }
>
>
> +/* Match a GENERIC procedure binding inside a derived type. */
> +
> +static match
> +match_generic_in_type (void)
> +{
> + char name[GFC_MAX_SYMBOL_LEN + 1];
> + gfc_symbol* block;
> + gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
> + gfc_typebound_proc* tb;
> + gfc_symtree* st;
> + gfc_namespace* ns;
> + match m;
> +
> + /* Check current state. */
> + gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
> + block = gfc_state_stack->previous->sym;
> + ns = block->f2k_derived;
> + gcc_assert (block && ns);
> +
> + /* See if we get an access-specifier. */
> + m = match_binding_attributes (&tbattr, true);
> + if (m == MATCH_ERROR)
> + goto error;
> +
> + /* Now the colons, those are required. */
> + if (gfc_match (" ::") != MATCH_YES)
> + {
> + gfc_error ("Expected '::' at %C");
> + goto error;
> + }
> +
> + /* The binding name and =>. */
> + m = gfc_match (" %n =>", name);
> + if (m == MATCH_ERROR)
> + return MATCH_ERROR;
> + if (m == MATCH_NO)
> + {
> + gfc_error ("Expected generic name at %C");
> + goto error;
> + }
> +
> + /* If there's already something with this name, check that it is another
> + GENERIC and then extend that rather than build a new node. */
> + st = gfc_find_symtree (ns->sym_root, name);
> + if (st)
> + {
> + if (!st->typebound || !st->typebound->is_generic)
> + {
> + gfc_error ("There's already a non-generic procedure with binding
> name"
> + " '%s' for the derived type '%s' at %C",
> + name, block->name);
> + goto error;
> + }
> +
> + tb = st->typebound;
> + if (tb->access != tbattr.access)
> + {
> + gfc_error ("Binding at %C must have the same access as already"
> + " defined binding '%s'", name);
> + goto error;
> + }
> + }
> + else
> + {
> + if (gfc_get_sym_tree (name, ns, &st))
> + return MATCH_ERROR;
> +
> + st->typebound = tb = gfc_get_typebound_proc ();
> + tb->where = gfc_current_locus;
> + tb->access = tbattr.access;
> + tb->is_generic = 1;
> + tb->u.generic = NULL;
> + }
> +
> + /* Now, match all following names as specific targets. */
> + do
> + {
> + gfc_symtree* target_st;
> + gfc_tbp_generic* target;
> +
> + m = gfc_match_name (name);
> + if (m == MATCH_ERROR)
> + goto error;
> + if (m == MATCH_NO)
> + {
> + gfc_error ("Expected specific binding name at %C");
> + goto error;
> + }
> +
> + if (gfc_get_sym_tree (name, ns, &target_st))
> + goto error;
> +
> + /* See if this is a duplicate specification. */
> + for (target = tb->u.generic; target; target = target->next)
> + if (target_st == target->specific_st)
> + {
> + gfc_error ("'%s' already defined as specific binding for the"
> + " generic '%s' at %C", name, st->n.sym->name);
> + goto error;
> + }
> +
> + gfc_set_sym_referenced (target_st->n.sym);
> +
> + target = gfc_get_tbp_generic ();
> + target->specific_st = target_st;
> + target->specific = NULL;
> + target->next = tb->u.generic;
> + tb->u.generic = target;
> + }
> + while (gfc_match (" ,") == MATCH_YES);
> +
> + /* Here should be the end. */
> + if (gfc_match_eos () != MATCH_YES)
> + {
> + gfc_error ("Junk after GENERIC binding at %C");
> + goto error;
> + }
> +
> + return MATCH_YES;
> +
> +error:
> + return MATCH_ERROR;
> +}
> +
> +
> /* Match a FINAL declaration inside a derived type. */
>
> match
> Index: gcc/fortran/gfortran.h
> ===================================================================
> --- gcc/fortran/gfortran.h (revision 139725)
> +++ gcc/fortran/gfortran.h (working copy)
> @@ -229,7 +229,7 @@ typedef enum
> ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
> ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
> ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
> - ST_OMP_TASKWAIT, ST_PROCEDURE,
> + ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC,
> ST_GET_FCN_CHARACTERISTICS, ST_NONE
> }
> gfc_statement;
> @@ -992,15 +992,40 @@ typedef struct
> gfc_user_op;
>
>
> +/* A list of specific bindings that are associated with a generic spec. */
> +typedef struct gfc_tbp_generic
> +{
> + /* The parser sets specific_st, upon resolution we look for the
> corresponding
> + gfc_typebound_proc and set specific for further use. */
> + struct gfc_symtree* specific_st;
> + struct gfc_typebound_proc* specific;
> +
> + struct gfc_tbp_generic* next;
> +}
> +gfc_tbp_generic;
> +
> +#define gfc_get_tbp_generic() XCNEW (gfc_tbp_generic)
> +
> +
> /* Data needed for type-bound procedures. */
> -typedef struct
> +typedef struct gfc_typebound_proc
> {
> - struct gfc_symtree* target;
> - locus where; /* Where the PROCEDURE definition was. */
> + locus where; /* Where the PROCEDURE/GENERIC definition was. */
> +
> + union
> + {
> + struct gfc_symtree* specific;
> + gfc_tbp_generic* generic;
> + }
> + u;
>
> gfc_access access;
> char* pass_arg; /* Argument-name for PASS. NULL if not specified. */
>
> + /* The overridden type-bound proc (or GENERIC with this name in the
> + parent-type) or NULL if non. */
> + struct gfc_typebound_proc* overridden;
> +
> /* 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 1 here, the second 2, and so on. */
> @@ -1008,6 +1033,8 @@ typedef struct
>
> unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
> unsigned non_overridable:1;
> + unsigned is_generic:1;
> + unsigned function:1, subroutine:1;
> }
> gfc_typebound_proc;
>
> @@ -1532,7 +1559,9 @@ typedef struct gfc_expr
> struct
> {
> gfc_actual_arglist* actual;
> - gfc_symtree* tbp;
> + gfc_typebound_proc* tbp;
> + gfc_symbol* derived;
> + const char* name;
> }
> compcall;
>
> @@ -2439,6 +2468,7 @@ int gfc_is_compile_time_shape (gfc_array
> void gfc_free_interface (gfc_interface *);
> int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
> int gfc_compare_types (gfc_typespec *, gfc_typespec *);
> +int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
> void gfc_check_interfaces (gfc_namespace *);
> void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
> gfc_symbol *gfc_search_interface (gfc_interface *, int,
> @@ -2450,6 +2480,8 @@ gfc_try gfc_add_interface (gfc_symbol *)
> gfc_interface *gfc_current_interface_head (void);
> void gfc_set_current_interface_head (gfc_interface *);
> gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
> +int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*,
> + int, int, locus*);
>
> /* io.c */
> extern gfc_st_label format_asterisk;
> Index: gcc/fortran/module.c
> ===================================================================
> --- gcc/fortran/module.c (revision 139725)
> +++ gcc/fortran/module.c (working copy)
> @@ -1708,6 +1708,12 @@ static const mstring binding_overriding[
> minit ("NON_OVERRIDABLE", 1),
> minit (NULL, -1)
> };
> +static const mstring binding_generic[] =
> +{
> + minit ("SPECIFIC", 0),
> + minit ("GENERIC", 1),
> + minit (NULL, -1)
> +};
>
>
> /* Specialization of mio_name. */
> @@ -3199,6 +3205,8 @@ mio_namespace_ref (gfc_namespace **nsp)
>
> /* Save/restore the f2k_derived namespace of a derived-type symbol. */
>
> +static gfc_namespace* current_f2k_derived;
> +
> static void
> mio_typebound_proc (gfc_typebound_proc** proc)
> {
> @@ -3212,13 +3220,13 @@ mio_typebound_proc (gfc_typebound_proc**
> gcc_assert (*proc);
>
> mio_lparen ();
> - mio_symtree_ref (&(*proc)->target);
>
> (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
>
> (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
> (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
> binding_overriding);
> + (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
>
> if (iomode == IO_INPUT)
> (*proc)->pass_arg = NULL;
> @@ -3227,6 +3235,38 @@ mio_typebound_proc (gfc_typebound_proc**
> mio_integer (&flag);
> (*proc)->pass_arg_num = (unsigned) flag;
>
> + if ((*proc)->is_generic)
> + {
> + gfc_tbp_generic* g;
> +
> + mio_lparen ();
> +
> + if (iomode == IO_OUTPUT)
> + for (g = (*proc)->u.generic; g; g = g->next)
> + mio_allocated_string (g->specific_st->name);
> + else
> + {
> + (*proc)->u.generic = NULL;
> + while (peek_atom () != ATOM_RPAREN)
> + {
> + g = gfc_get_tbp_generic ();
> + g->specific = NULL;
> +
> + require_atom (ATOM_STRING);
> + gfc_get_sym_tree (atom_string, current_f2k_derived,
> + &g->specific_st);
> + gfc_free (atom_string);
> +
> + g->next = (*proc)->u.generic;
> + (*proc)->u.generic = g;
> + }
> + }
> +
> + mio_rparen ();
> + }
> + else
> + mio_symtree_ref (&(*proc)->u.specific);
> +
> mio_rparen ();
> }
>
> @@ -3270,6 +3310,8 @@ mio_finalizer (gfc_finalizer **f)
> static void
> mio_f2k_derived (gfc_namespace *f2k)
> {
> + current_f2k_derived = f2k;
> +
> /* Handle the list of finalizer procedures. */
> mio_lparen ();
> if (iomode == IO_OUTPUT)
> Index: gcc/fortran/resolve.c
> ===================================================================
> --- gcc/fortran/resolve.c (revision 139725)
> +++ gcc/fortran/resolve.c (working copy)
> @@ -4306,16 +4306,14 @@ update_arglist_pass (gfc_actual_arglist*
> }
>
>
> -/* Update the arglist of an EXPR_COMPCALL expression to include the
> - passed-object. */
> +/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
>
> -static gfc_try
> -update_compcall_arglist (gfc_expr* e)
> +static gfc_expr*
> +extract_compcall_passed_object (gfc_expr* e)
> {
> gfc_expr* po;
> - gfc_typebound_proc* tbp;
>
> - tbp = e->value.compcall.tbp->typebound;
> + gcc_assert (e->expr_type == EXPR_COMPCALL);
>
> po = gfc_get_expr ();
> po->expr_type = EXPR_VARIABLE;
> @@ -4323,7 +4321,27 @@ update_compcall_arglist (gfc_expr* e)
> po->ref = gfc_copy_ref (e->ref);
>
> if (gfc_resolve_expr (po) == FAILURE)
> + return NULL;
> +
> + return po;
> +}
> +
> +
> +/* Update the arglist of an EXPR_COMPCALL expression to include the
> + passed-object. */
> +
> +static gfc_try
> +update_compcall_arglist (gfc_expr* e)
> +{
> + gfc_expr* po;
> + gfc_typebound_proc* tbp;
> +
> + tbp = e->value.compcall.tbp;
> +
> + po = extract_compcall_passed_object (e);
> + if (!po)
> return FAILURE;
> +
> if (po->rank > 0)
> {
> gfc_error ("Passed-object at %L must be scalar", &e->where);
> @@ -4353,13 +4371,14 @@ resolve_typebound_static (gfc_expr* e, g
> gfc_actual_arglist** actual)
> {
> gcc_assert (e->expr_type == EXPR_COMPCALL);
> + gcc_assert (!e->value.compcall.tbp->is_generic);
>
> /* Update the actual arglist for PASS. */
> if (update_compcall_arglist (e) == FAILURE)
> return FAILURE;
>
> *actual = e->value.compcall.actual;
> - *target = e->value.compcall.tbp->typebound->target;
> + *target = e->value.compcall.tbp->u.specific;
>
> gfc_free_ref_list (e->ref);
> e->ref = NULL;
> @@ -4369,6 +4388,74 @@ resolve_typebound_static (gfc_expr* e, g
> }
>
>
> +/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
> + which of the specific bindings (if any) matches the arglist and
> transform
> + the expression into a call of that binding. */
> +
> +static gfc_try
> +resolve_typebound_generic_call (gfc_expr* e)
> +{
> + gfc_typebound_proc* genproc;
> + const char* genname;
> +
> + gcc_assert (e->expr_type == EXPR_COMPCALL);
> + genname = e->value.compcall.name;
> + genproc = e->value.compcall.tbp;
> +
> + if (!genproc->is_generic)
> + return SUCCESS;
> +
> + /* Try the bindings on this type and in the inheritance hierarchie. */
> + for (; genproc; genproc = genproc->overridden)
> + {
> + gfc_tbp_generic* g;
> +
> + gcc_assert (genproc->is_generic);
> + for (g = genproc->u.generic; g; g = g->next)
> + {
> + gfc_symbol* target;
> + gfc_actual_arglist* args;
> + bool matches;
> +
> + gcc_assert (g->specific);
> + target = g->specific->u.specific->n.sym;
> +
> + /* Get the right arglist by handling PASS/NOPASS. */
> + args = gfc_copy_actual_arglist (e->value.compcall.actual);
> + if (!g->specific->nopass)
> + {
> + gfc_expr* po;
> + po = extract_compcall_passed_object (e);
> + if (!po)
> + return FAILURE;
> +
> + args = update_arglist_pass (args, po,
> g->specific->pass_arg_num);
> + }
> +
> + /* Check if this arglist matches the formal. */
> + matches = gfc_compare_actual_formal (&args, target->formal, 1,
> + target->attr.elemental,
> NULL);
> +
> + /* Clean up and break out of the loop if we've found it. */
> + gfc_free_actual_arglist (args);
> + if (matches)
> + {
> + e->value.compcall.tbp = g->specific;
> + goto success;
> + }
> + }
> + }
> +
> + /* Nothing matching found! */
> + gfc_error ("Found no matching specific binding for the call to the
> GENERIC"
> + " '%s' at %L", genname, &e->where);
> + return FAILURE;
> +
> +success:
> + return SUCCESS;
> +}
> +
> +
> /* Resolve a call to a type-bound subroutine. */
>
> static gfc_try
> @@ -4377,6 +4464,17 @@ resolve_typebound_call (gfc_code* c)
> gfc_actual_arglist* newactual;
> gfc_symtree* target;
>
> + /* Check that's really a SUBROUTINE. */
> + if (!c->expr->value.compcall.tbp->subroutine)
> + {
> + gfc_error ("'%s' at %L should be a SUBROUTINE",
> + c->expr->value.compcall.name, &c->loc);
> + return FAILURE;
> + }
> +
> + if (resolve_typebound_generic_call (c->expr) == FAILURE)
> + return FAILURE;
> +
> /* Transform into an ordinary EXEC_CALL for now. */
>
> if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
> @@ -4402,13 +4500,27 @@ resolve_compcall (gfc_expr* e)
> gfc_actual_arglist* newactual;
> gfc_symtree* target;
>
> - /* For now, we simply transform it into a EXPR_FUNCTION call with the
> same
> + /* Check that's really a FUNCTION. */
> + if (!e->value.compcall.tbp->function)
> + {
> + gfc_error ("'%s' at %L should be a FUNCTION",
> + e->value.compcall.name, &e->where);
> + return FAILURE;
> + }
> +
> + if (resolve_typebound_generic_call (e) == FAILURE)
> + return FAILURE;
> +
> + /* For now, we simply transform it into an EXPR_FUNCTION call with the
> same
> arglist to the TBP's binding target. */
>
> if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
> return FAILURE;
>
> e->value.function.actual = newactual;
> + e->value.function.name = e->value.compcall.name;
> + e->value.function.isym = NULL;
> + e->value.function.esym = NULL;
> e->symtree = target;
> e->expr_type = EXPR_FUNCTION;
>
> @@ -7771,9 +7883,20 @@ check_typebound_override (gfc_symtree* p
> gfc_formal_arglist* proc_formal;
> gfc_formal_arglist* old_formal;
>
> + /* This procedure should only be called for non-GENERIC proc. */
> + gcc_assert (!proc->typebound->is_generic);
> +
> + /* If the overwritten procedure is GENERIC, this is an error. */
> + if (old->typebound->is_generic)
> + {
> + gfc_error ("Can't overwrite GENERIC '%s' at %L",
> + old->name, &proc->typebound->where);
> + return FAILURE;
> + }
> +
> where = proc->typebound->where;
> - proc_target = proc->typebound->target->n.sym;
> - old_target = old->typebound->target->n.sym;
> + proc_target = proc->typebound->u.specific->n.sym;
> + old_target = old->typebound->u.specific->n.sym;
>
> /* Check that overridden binding is not NON_OVERRIDABLE. */
> if (old->typebound->non_overridable)
> @@ -7933,6 +8056,178 @@ check_typebound_override (gfc_symtree* p
> }
>
>
> +/* Check if two GENERIC targets are ambiguous and emit an error is they
> are. */
> +
> +static gfc_try
> +check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
> + const char* generic_name, locus where)
> +{
> + gfc_symbol* sym1;
> + gfc_symbol* sym2;
> +
> + gcc_assert (t1->specific && t2->specific);
> + gcc_assert (!t1->specific->is_generic);
> + gcc_assert (!t2->specific->is_generic);
> +
> + sym1 = t1->specific->u.specific->n.sym;
> + sym2 = t2->specific->u.specific->n.sym;
> +
> + /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
> + if (sym1->attr.subroutine != sym2->attr.subroutine
> + || sym1->attr.function != sym2->attr.function)
> + {
> + gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
> + " GENERIC '%s' at %L",
> + sym1->name, sym2->name, generic_name, &where);
> + return FAILURE;
> + }
> +
> + /* Compare the interfaces. */
> + if (gfc_compare_interfaces (sym1, sym2, 1))
> + {
> + gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
> + sym1->name, sym2->name, generic_name, &where);
> + return FAILURE;
> + }
> +
> + return SUCCESS;
> +}
> +
> +
> +/* Resolve a GENERIC procedure binding for a derived type. */
> +
> +static gfc_try
> +resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
> +{
> + gfc_tbp_generic* target;
> + gfc_symtree* first_target;
> + gfc_symbol* super_type;
> + gfc_symtree* inherited;
> + locus where;
> +
> + gcc_assert (st->typebound);
> + gcc_assert (st->typebound->is_generic);
> +
> + where = st->typebound->where;
> + super_type = gfc_get_derived_super_type (derived);
> +
> + /* Find the overridden binding if any. */
> + st->typebound->overridden = NULL;
> + if (super_type)
> + {
> + gfc_symtree* overridden;
> + overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
> true);
> +
> + if (overridden && overridden->typebound)
> + st->typebound->overridden = overridden->typebound;
> + }
> +
> + /* Try to find the specific bindings for the symtrees in our target-list.
> */
> + gcc_assert (st->typebound->u.generic);
> + for (target = st->typebound->u.generic; target; target = target->next)
> + if (!target->specific)
> + {
> + gfc_typebound_proc* overridden_tbp;
> + gfc_tbp_generic* g;
> + const char* target_name;
> +
> + target_name = target->specific_st->name;
> +
> + /* Defined for this type directly. */
> + if (target->specific_st->typebound)
> + {
> + target->specific = target->specific_st->typebound;
> + goto specific_found;
> + }
> +
> + /* Look for an inherited specific binding. */
> + /* XXX: Do we have to do access checking here? What's about this
> code:
> +
> + MODULE m1
> + TYPE t1
> + CONTAINS
> + PROCEDURE, PRIVATE :: proc
> + END TYPE t1
> + END MODULE m1
> +
> + MODULE m2
> + TYPE t2
> + CONTAINS
> + GENERIC :: gen => proc
> + END TYPE t2
> + END MODULE m2
> +
> + Is this valid or invalid? */
> + if (super_type)
> + {
> + inherited = gfc_find_typebound_proc (super_type, NULL,
> + target_name, true);
> +
> + if (inherited)
> + {
> + gcc_assert (inherited->typebound);
> + target->specific = inherited->typebound;
> + goto specific_found;
> + }
> + }
> +
> + gfc_error ("Undefined specific binding '%s' as target of GENERIC
> '%s'"
> + " at %L", target_name, st->name, &where);
> + return FAILURE;
> +
> + /* Once we've found the specific binding, check it is not ambiguous
> with
> + other specifics already found or inherited for the same GENERIC.
> */
> +specific_found:
> + gcc_assert (target->specific);
> +
> + /* This must really be a specific binding! */
> + if (target->specific->is_generic)
> + {
> + gfc_error ("GENERIC '%s' at %L must target a specific binding,"
> + " '%s' is GENERIC, too", st->name, &where,
> target_name);
> + return FAILURE;
> + }
> +
> + /* Check those already resolved on this type directly. */
> + for (g = st->typebound->u.generic; g; g = g->next)
> + if (g != target && g->specific
> + && check_generic_tbp_ambiguity (target, g, st->name, where)
> + == FAILURE)
> + return FAILURE;
> +
> + /* Check for ambiguity with inherited specific targets. */
> + for (overridden_tbp = st->typebound->overridden; overridden_tbp;
> + overridden_tbp = overridden_tbp->overridden)
> + if (overridden_tbp->is_generic)
> + {
> + for (g = overridden_tbp->u.generic; g; g = g->next)
> + {
> + gcc_assert (g->specific);
> + if (check_generic_tbp_ambiguity (target, g,
> + st->name, where) ==
> FAILURE)
> + return FAILURE;
> + }
> + }
> + }
> +
> + /* If we attempt to "overwrite" a specific binding, this is an error. */
> + if (st->typebound->overridden && !st->typebound->overridden->is_generic)
> + {
> + gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
> + " the same name", st->name, &where);
> + return FAILURE;
> + }
> +
> + /* Take the SUBROUTINE/FUNCTION attributes of the first specific target,
> as
> + all must have the same attributes here. */
> + first_target = st->typebound->u.generic->specific->u.specific;
> + st->typebound->subroutine = first_target->n.sym->attr.subroutine;
> + st->typebound->function = first_target->n.sym->attr.function;
> +
> + return SUCCESS;
> +}
> +
> +
> /* Resolve the type-bound procedures for a derived type. */
>
> static gfc_symbol* resolve_bindings_derived;
> @@ -7951,9 +8246,19 @@ resolve_typebound_procedure (gfc_symtree
> if (!stree->typebound)
> return;
>
> + /* If this is a GENERIC binding, use that routine. */
> + if (stree->typebound->is_generic)
> + {
> + if (resolve_typebound_generic (resolve_bindings_derived, stree)
> + == FAILURE)
> + goto error;
> + return;
> + }
> +
> /* Get the target-procedure to check it. */
> - gcc_assert (stree->typebound->target);
> - proc = stree->typebound->target->n.sym;
> + gcc_assert (!stree->typebound->is_generic);
> + gcc_assert (stree->typebound->u.specific);
> + proc = stree->typebound->u.specific->n.sym;
> where = stree->typebound->where;
>
> /* Default access should already be resolved from the parser. */
> @@ -7970,14 +8275,17 @@ resolve_typebound_procedure (gfc_symtree
> " an explicit interface at %L", proc->name, &where);
> goto error;
> }
> + stree->typebound->subroutine = proc->attr.subroutine;
> + stree->typebound->function = proc->attr.function;
>
> /* Find the super-type of the current derived type. We could do this once
> and
> store in a global if speed is needed, but as long as not I believe this
> is
> more readable and clearer. */
> super_type = gfc_get_derived_super_type (resolve_bindings_derived);
>
> - /* If PASS, resolve and check arguments. */
> - if (!stree->typebound->nopass)
> + /* If PASS, resolve and check arguments if not already resolved / loaded
> + from a .mod file. */
> + if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
> {
> if (stree->typebound->pass_arg)
> {
> @@ -8039,12 +8347,16 @@ resolve_typebound_procedure (gfc_symtree
>
> /* If we are extending some type, check that we don't override a procedure
> flagged NON_OVERRIDABLE. */
> + stree->typebound->overridden = NULL;
> if (super_type)
> {
> gfc_symtree* overridden;
> overridden = gfc_find_typebound_proc (super_type, NULL,
> stree->name, true);
>
> + if (overridden && overridden->typebound)
> + stree->typebound->overridden = overridden->typebound;
> +
> if (overridden && check_typebound_override (stree, overridden) ==
> FAILURE)
> goto error;
> }
> @@ -8121,6 +8433,10 @@ resolve_fl_derived (gfc_symbol *sym)
>
> super_type = gfc_get_derived_super_type (sym);
>
> + /* Ensure the extended type gets resolved before we do. */
> + if (super_type && resolve_fl_derived (super_type) == FAILURE)
> + return FAILURE;
> +
> for (c = sym->components; c != NULL; c = c->next)
> {
> /* If this type is an extension, see if this component has the same
> name
> Index: gcc/fortran/st.c
> ===================================================================
> --- gcc/fortran/st.c (revision 139725)
> +++ gcc/fortran/st.c (working copy)
> @@ -109,7 +109,6 @@ gfc_free_statement (gfc_code *p)
> break;
>
> case EXEC_COMPCALL:
> - gfc_free_expr (p->expr);
> case EXEC_CALL:
> case EXEC_ASSIGN_CALL:
> gfc_free_actual_arglist (p->ext.actual);
> Index: gcc/fortran/match.c
> ===================================================================
> --- gcc/fortran/match.c (revision 139725)
> +++ gcc/fortran/match.c (working copy)
> @@ -2525,6 +2525,7 @@ match_typebound_call (gfc_symtree* varst
> base->expr_type = EXPR_VARIABLE;
> base->symtree = varst;
> base->where = gfc_current_locus;
> + gfc_set_sym_referenced (varst->n.sym);
>
> m = gfc_match_varspec (base, 0, true);
> if (m == MATCH_NO)
> Index: gcc/fortran/match.h
> ===================================================================
> --- gcc/fortran/match.h (revision 139725)
> +++ gcc/fortran/match.h (working copy)
> @@ -36,6 +36,9 @@ extern gfc_st_label *gfc_statement_label
> extern int gfc_matching_procptr_assignment;
> extern bool gfc_matching_prefix;
>
> +/* Default access specifier while matching procedure bindings. */
> +extern gfc_access gfc_typebound_default_access;
> +
> /****************** All gfc_match* routines *****************/
>
> /* match.c. */
> @@ -141,6 +144,7 @@ match gfc_match_end (gfc_statement *);
> match gfc_match_data_decl (void);
> match gfc_match_formal_arglist (gfc_symbol *, int, int);
> match gfc_match_procedure (void);
> +match gfc_match_generic (void);
> match gfc_match_function_decl (void);
> match gfc_match_entry (void);
> match gfc_match_subroutine (void);
> Index: gcc/fortran/parse.c
> ===================================================================
> --- gcc/fortran/parse.c (revision 139725)
> +++ gcc/fortran/parse.c (working copy)
> @@ -372,6 +372,7 @@ decode_statement (void)
> break;
>
> case 'g':
> + match ("generic", gfc_match_generic, ST_GENERIC);
> match ("go to", gfc_match_goto, ST_GOTO);
> break;
>
> @@ -1195,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st)
> case ST_FUNCTION:
> p = "FUNCTION";
> break;
> + case ST_GENERIC:
> + p = "GENERIC";
> + break;
> case ST_GOTO:
> p = "GOTO";
> break;
> @@ -1691,21 +1695,10 @@ 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. */
>
> +gfc_access gfc_typebound_default_access;
> +
> static bool
> parse_derived_contains (void)
> {
> @@ -1730,6 +1723,8 @@ parse_derived_contains (void)
> accept_statement (ST_CONTAINS);
> push_state (&s, COMP_DERIVED_CONTAINS, NULL);
>
> + gfc_typebound_default_access = ACCESS_PUBLIC;
> +
> to_finish = false;
> while (!to_finish)
> {
> @@ -1755,6 +1750,15 @@ parse_derived_contains (void)
> seen_comps = true;
> break;
>
> + case ST_GENERIC:
> + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC
> binding"
> + " at %C") == FAILURE)
> + error_flag = true;
> +
> + accept_statement (ST_GENERIC);
> + seen_comps = true;
> + break;
> +
> case ST_FINAL:
> if (gfc_notify_std (GFC_STD_F2003,
> "Fortran 2003: FINAL procedure declaration"
> @@ -1801,6 +1805,7 @@ parse_derived_contains (void)
> }
>
> accept_statement (ST_PRIVATE);
> + gfc_typebound_default_access = ACCESS_PRIVATE;
> seen_private = true;
> break;
>
> @@ -1823,12 +1828,6 @@ parse_derived_contains (void)
> 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;
> }
>
> @@ -1875,6 +1874,11 @@ parse_derived (void)
> error_flag = 1;
> break;
>
> + case ST_GENERIC:
> + gfc_error ("GENERIC 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;
> Index: gcc/fortran/primary.c
> ===================================================================
> --- gcc/fortran/primary.c (revision 139725)
> +++ gcc/fortran/primary.c (working copy)
> @@ -1709,7 +1709,6 @@ gfc_match_varspec (gfc_expr *primary, in
> gfc_ref *substring, *tail;
> gfc_component *component;
> gfc_symbol *sym = primary->symtree->n.sym;
> - gfc_symtree *tbp;
> match m;
> bool unknown;
>
> @@ -1754,6 +1753,7 @@ gfc_match_varspec (gfc_expr *primary, in
> for (;;)
> {
> gfc_try t;
> + gfc_symtree *tbp;
>
> m = gfc_match_name (name);
> if (m == MATCH_NO)
> @@ -1772,13 +1772,20 @@ gfc_match_varspec (gfc_expr *primary, in
> gcc_assert (!tail || !tail->next);
> gcc_assert (primary->expr_type == EXPR_VARIABLE);
>
> - tbp_sym = tbp->typebound->target->n.sym;
> + if (tbp->typebound->is_generic)
> + tbp_sym = NULL;
> + else
> + tbp_sym = tbp->typebound->u.specific->n.sym;
>
> primary->expr_type = EXPR_COMPCALL;
> - primary->value.compcall.tbp = tbp;
> - primary->ts = tbp_sym->ts;
> + primary->value.compcall.tbp = tbp->typebound;
> + primary->value.compcall.derived = sym;
> + primary->value.compcall.name = tbp->name;
> + gcc_assert (primary->symtree->n.sym->attr.referenced);
> + if (tbp_sym)
> + primary->ts = tbp_sym->ts;
>
> - m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
> + m = gfc_match_actual_arglist (tbp->typebound->subroutine,
> &primary->value.compcall.actual);
> if (m == MATCH_ERROR)
> return MATCH_ERROR;
> @@ -1793,16 +1800,7 @@ gfc_match_varspec (gfc_expr *primary, in
> }
> }
>
> - if (sub_flag && !tbp_sym->attr.subroutine)
> - {
> - gfc_error ("'%s' at %C should be a SUBROUTINE", name);
> - return MATCH_ERROR;
> - }
> - if (!sub_flag && !tbp_sym->attr.function)
> - {
> - gfc_error ("'%s' at %C should be a FUNCTION", name);
> - return MATCH_ERROR;
> - }
> + gfc_set_sym_referenced (tbp->n.sym);
>
> break;
> }
> Index: gcc/testsuite/gfortran.dg/typebound_generic_1.f03
> ===================================================================
> --- gcc/testsuite/gfortran.dg/typebound_generic_1.f03 (revision 0)
> +++ gcc/testsuite/gfortran.dg/typebound_generic_1.f03 (revision 0)
> @@ -0,0 +1,95 @@
> +! { dg-do compile }
> +
> +! Type-bound procedures
> +! Compiling and errors with GENERIC binding declarations.
> +! Bindings with NOPASS.
> +
> +MODULE m
> + IMPLICIT NONE
> +
> + TYPE somet
> + CONTAINS
> + PROCEDURE, NOPASS :: p1 => intf1
> + PROCEDURE, NOPASS :: p1a => intf1a
> + PROCEDURE, NOPASS :: p2 => intf2
> + PROCEDURE, NOPASS :: p3 => intf3
> + PROCEDURE, NOPASS :: subr
> +
> + GENERIC :: gen1 => p1a ! { dg-error "are ambiguous" }
> +
> + GENERIC, PUBLIC :: gen1 => p1, p2
> + GENERIC :: gen1 => p3 ! Implicitelly PUBLIC.
> + GENERIC, PRIVATE :: gen2 => p1
> +
> + GENERIC :: gen2 => p2 ! { dg-error "same access" }
> + GENERIC :: gen1 => p1 ! { dg-error "already defined as specific
> binding" }
> + GENERIC, PASS :: gen3 => p1 ! { dg-error "Expected access-specifier" }
> + GENERIC :: p1 => p1 ! { dg-error "already a non-generic procedure" }
> + PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "already a procedure" }
> + GENERIC :: gen3 => ! { dg-error "specific binding" }
> + GENERIC :: gen4 => p1 x ! { dg-error "Junk after" }
> + GENERIC :: gen4 => p_notthere ! { dg-error "Undefined specific binding"
> }
> + GENERIC :: gen5 => gen1 ! { dg-error "must target a specific binding" }
> +
> + GENERIC :: gensubr => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
> + GENERIC :: gensubr => subr
> +
> + END TYPE somet
> +
> + TYPE supert
> + CONTAINS
> + PROCEDURE, NOPASS :: p1 => intf1
> + PROCEDURE, NOPASS :: p1a => intf1a
> + PROCEDURE, NOPASS :: p2 => intf2
> + PROCEDURE, NOPASS :: p3 => intf3
> + PROCEDURE, NOPASS :: sub1 => subr
> +
> + GENERIC :: gen1 => p1, p2
> + GENERIC :: gen1 => p3
> + GENERIC :: gen2 => p1
> + GENERIC :: gensub => sub1
> + END TYPE supert
> +
> + TYPE, EXTENDS(supert) :: t
> + CONTAINS
> + GENERIC :: gen2 => p1a ! { dg-error "are ambiguous" }
> + GENERIC :: gen2 => p3
> + GENERIC :: p1 => p2 ! { dg-error "can't overwrite specific" }
> + GENERIC :: gensub => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
> +
> + PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "Can't overwrite
> GENERIC" }
> + END TYPE t
> +
> +CONTAINS
> +
> + INTEGER FUNCTION intf1 (a, b)
> + IMPLICIT NONE
> + INTEGER :: a, b
> + intf1 = 42
> + END FUNCTION intf1
> +
> + INTEGER FUNCTION intf1a (a, b)
> + IMPLICIT NONE
> + INTEGER :: a, b
> + intf1a = 42
> + END FUNCTION intf1a
> +
> + INTEGER FUNCTION intf2 (a, b)
> + IMPLICIT NONE
> + REAL :: a, b
> + intf2 = 42.0
> + END FUNCTION intf2
> +
> + LOGICAL FUNCTION intf3 ()
> + IMPLICIT NONE
> + intf3 = .TRUE.
> + END FUNCTION intf3
> +
> + SUBROUTINE subr (x)
> + IMPLICIT NONE
> + INTEGER :: x
> + END SUBROUTINE subr
> +
> +END MODULE m
> +
> +! { dg-final { cleanup-modules "m" } }
> Index: gcc/testsuite/gfortran.dg/typebound_generic_2.f03
> ===================================================================
> --- gcc/testsuite/gfortran.dg/typebound_generic_2.f03 (revision 0)
> +++ gcc/testsuite/gfortran.dg/typebound_generic_2.f03 (revision 0)
> @@ -0,0 +1,64 @@
> +! { dg-do compile }
> +
> +! Type-bound procedures
> +! Check for errors with calls to GENERIC bindings and their module IO.
> +! Calls with NOPASS.
> +
> +MODULE m
> + IMPLICIT NONE
> +
> + TYPE supert
> + CONTAINS
> + PROCEDURE, NOPASS :: func_int
> + PROCEDURE, NOPASS :: sub_int
> + GENERIC :: func => func_int
> + GENERIC :: sub => sub_int
> + END TYPE supert
> +
> + TYPE, EXTENDS(supert) :: t
> + CONTAINS
> + PROCEDURE, NOPASS :: func_real
> + GENERIC :: func => func_real
> + END TYPE t
> +
> +CONTAINS
> +
> + INTEGER FUNCTION func_int (x)
> + IMPLICIT NONE
> + INTEGER :: x
> + func_int = x
> + END FUNCTION func_int
> +
> + INTEGER FUNCTION func_real (x)
> + IMPLICIT NONE
> + REAL :: x
> + func_real = INT(x * 4.2)
> + END FUNCTION func_real
> +
> + SUBROUTINE sub_int (x)
> + IMPLICIT NONE
> + INTEGER :: x
> + END SUBROUTINE sub_int
> +
> +END MODULE m
> +
> +PROGRAM main
> + USE m
> + IMPLICIT NONE
> +
> + TYPE(t) :: myobj
> +
> + ! These are ok.
> + CALL myobj%sub (1)
> + WRITE (*,*) myobj%func (1)
> + WRITE (*,*) myobj%func (2.5)
> +
> + ! These are not.
> + CALL myobj%sub (2.5) ! { dg-error "no matching specific binding" }
> + WRITE (*,*) myobj%func ("hello") ! { dg-error "no matching specific
> binding" }
> + CALL myobj%func (2.5) ! { dg-error "SUBROUTINE" }
> + WRITE (*,*) myobj%sub (1) ! { dg-error "FUNCTION" }
> +
> +END PROGRAM main
> +
> +! { dg-final { cleanup-modules "m" } }
> Index: gcc/testsuite/gfortran.dg/typebound_generic_3.f03
> ===================================================================
> --- gcc/testsuite/gfortran.dg/typebound_generic_3.f03 (revision 0)
> +++ gcc/testsuite/gfortran.dg/typebound_generic_3.f03 (revision 0)
> @@ -0,0 +1,65 @@
> +! { dg-do run }
> +
> +! FIXME: Remove -w once switched to polymorphic passed-object dummy
> arguments.
> +! { dg-options "-w" }
> +
> +! Type-bound procedures
> +! Check calls with GENERIC bindings.
> +
> +MODULE m
> + IMPLICIT NONE
> +
> + TYPE t
> + CONTAINS
> + PROCEDURE, NOPASS :: plain_int
> + PROCEDURE, NOPASS :: plain_real
> + PROCEDURE, PASS(me) :: passed_intint
> + PROCEDURE, PASS(me) :: passed_realreal
> +
> + GENERIC :: gensub => plain_int, plain_real, passed_intint,
> passed_realreal
> + END TYPE t
> +
> +CONTAINS
> +
> + SUBROUTINE plain_int (x)
> + IMPLICIT NONE
> + INTEGER :: x
> + WRITE (*,*) "Plain Integer"
> + END SUBROUTINE plain_int
> +
> + SUBROUTINE plain_real (x)
> + IMPLICIT NONE
> + REAL :: x
> + WRITE (*,*) "Plain Real"
> + END SUBROUTINE plain_real
> +
> + SUBROUTINE passed_intint (me, x, y)
> + IMPLICIT NONE
> + TYPE(t) :: me
> + INTEGER :: x, y
> + WRITE (*,*) "Passed Integer"
> + END SUBROUTINE passed_intint
> +
> + SUBROUTINE passed_realreal (x, me, y)
> + IMPLICIT NONE
> + REAL :: x, y
> + TYPE(t) :: me
> + WRITE (*,*) "Passed Real"
> + END SUBROUTINE passed_realreal
> +
> +END MODULE m
> +
> +PROGRAM main
> + USE m
> + IMPLICIT NONE
> +
> + TYPE(t) :: myobj
> +
> + CALL myobj%gensub (5)
> + CALL myobj%gensub (2.5)
> + CALL myobj%gensub (5, 5)
> + CALL myobj%gensub (2.5, 2.5)
> +END PROGRAM main
> +
> +! { dg-output "Plain Integer(\n|\r\n|\r).*Plain Real(\n|\r\n|\r).*Passed
> Integer(\n|\r\n|\r).*Passed Real" }
> +! { dg-final { cleanup-modules "m" } }
>
>
>
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy