From 94747289e95b397d364d5fe39ee871a5ee8b65ae Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Mon, 10 Aug 2009 12:51:46 +0200 Subject: [PATCH] re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators) 2009-08-10 Daniel Kraft PR fortran/37425 * gfortran.dg/typebound_operator_1.f03: New test. * gfortran.dg/typebound_operator_2.f03: New test. 2009-08-10 Daniel Kraft PR fortran/37425 * gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op. (gfc_find_typebound_user_op): New routine. (gfc_find_typebound_intrinsic_op): Ditto. (gfc_check_operator_interface): Now public routine. * decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=). * interface.c (check_operator_interface): Made public, renamed to `gfc_check_operator_interface' accordingly and hand in the interface as gfc_symbol rather than gfc_interface so it is useful for type-bound operators, too. Return boolean result. (gfc_check_interfaces): Adapt call to `check_operator_interface'. * symbol.c (gfc_get_namespace): Initialize new field `tb_op'. (gfc_free_namespace): Free `tb_uop_root'-based tree. (find_typebound_proc_uop): New helper function. (gfc_find_typebound_proc): Use it. (gfc_find_typebound_user_op): New method. (gfc_find_typebound_intrinsic_op): Ditto. * resolve.c (resolve_tb_generic_targets): New helper function. (resolve_typebound_generic): Use it. (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New. (resolve_typebound_procedures): Resolve operators, too. (check_uop_procedure): New, code from gfc_resolve_uops. (gfc_resolve_uops): Moved main code to new `check_uop_procedure'. From-SVN: r150622 --- gcc/fortran/ChangeLog | 26 ++ gcc/fortran/decl.c | 113 +++++-- gcc/fortran/gfortran.h | 9 + gcc/fortran/interface.c | 109 ++++--- gcc/fortran/resolve.c | 339 ++++++++++++++++----- gcc/fortran/symbol.c | 101 +++++- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/typebound_operator_1.f03 | 50 +++ gcc/testsuite/gfortran.dg/typebound_operator_2.f03 | 69 +++++ 9 files changed, 664 insertions(+), 158 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_1.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_2.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6158a72..1e8d739 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,29 @@ +2009-08-10 Daniel Kraft + + PR fortran/37425 + * gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op. + (gfc_find_typebound_user_op): New routine. + (gfc_find_typebound_intrinsic_op): Ditto. + (gfc_check_operator_interface): Now public routine. + * decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=). + * interface.c (check_operator_interface): Made public, renamed to + `gfc_check_operator_interface' accordingly and hand in the interface + as gfc_symbol rather than gfc_interface so it is useful for type-bound + operators, too. Return boolean result. + (gfc_check_interfaces): Adapt call to `check_operator_interface'. + * symbol.c (gfc_get_namespace): Initialize new field `tb_op'. + (gfc_free_namespace): Free `tb_uop_root'-based tree. + (find_typebound_proc_uop): New helper function. + (gfc_find_typebound_proc): Use it. + (gfc_find_typebound_user_op): New method. + (gfc_find_typebound_intrinsic_op): Ditto. + * resolve.c (resolve_tb_generic_targets): New helper function. + (resolve_typebound_generic): Use it. + (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New. + (resolve_typebound_procedures): Resolve operators, too. + (check_uop_procedure): New, code from gfc_resolve_uops. + (gfc_resolve_uops): Moved main code to new `check_uop_procedure'. + 2009-08-10 Janus Weil PR fortran/40940 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 6b6203e..abe2147 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -7406,11 +7406,13 @@ match gfc_match_generic (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; + char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */ gfc_symbol* block; gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */ gfc_typebound_proc* tb; - gfc_symtree* st; gfc_namespace* ns; + interface_type op_type; + gfc_intrinsic_op op; match m; /* Check current state. */ @@ -7437,49 +7439,126 @@ gfc_match_generic (void) goto error; } - /* The binding name and =>. */ - m = gfc_match (" %n =>", name); + /* Match the binding name; depending on type (operator / generic) format + it for future error messages into bind_name. */ + + m = gfc_match_generic_spec (&op_type, name, &op); if (m == MATCH_ERROR) return MATCH_ERROR; if (m == MATCH_NO) { - gfc_error ("Expected generic name at %C"); + gfc_error ("Expected generic name or operator descriptor 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->tb_sym_root, name); - if (st) + switch (op_type) { - gcc_assert (st->n.tb); - tb = st->n.tb; + case INTERFACE_GENERIC: + snprintf (bind_name, sizeof (bind_name), "%s", name); + break; + + case INTERFACE_USER_OP: + snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name); + break; + + case INTERFACE_INTRINSIC_OP: + snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)", + gfc_op2string (op)); + break; + + default: + gcc_unreachable (); + } + /* Match the required =>. */ + if (gfc_match (" =>") != MATCH_YES) + { + gfc_error ("Expected '=>' at %C"); + goto error; + } + + /* Try to find existing GENERIC binding with this name / for this operator; + if there is something, check that it is another GENERIC and then extend + it rather than building a new node. Otherwise, create it and put it + at the right position. */ + + switch (op_type) + { + case INTERFACE_USER_OP: + case INTERFACE_GENERIC: + { + const bool is_op = (op_type == INTERFACE_USER_OP); + gfc_symtree* st; + + st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name); + if (st) + { + tb = st->n.tb; + gcc_assert (tb); + } + else + tb = NULL; + + break; + } + + case INTERFACE_INTRINSIC_OP: + tb = ns->tb_op[op]; + break; + + default: + gcc_unreachable (); + } + + if (tb) + { if (!tb->is_generic) { + gcc_assert (op_type == INTERFACE_GENERIC); gfc_error ("There's already a non-generic procedure with binding name" " '%s' for the derived type '%s' at %C", - name, block->name); + bind_name, block->name); goto error; } if (tb->access != tbattr.access) { gfc_error ("Binding at %C must have the same access as already" - " defined binding '%s'", name); + " defined binding '%s'", bind_name); goto error; } } else { - st = gfc_new_symtree (&ns->tb_sym_root, name); - gcc_assert (st); - - st->n.tb = tb = gfc_get_typebound_proc (); + tb = gfc_get_typebound_proc (); tb->where = gfc_current_locus; tb->access = tbattr.access; tb->is_generic = 1; tb->u.generic = NULL; + + switch (op_type) + { + case INTERFACE_GENERIC: + case INTERFACE_USER_OP: + { + const bool is_op = (op_type == INTERFACE_USER_OP); + gfc_symtree* st; + + st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root, + name); + gcc_assert (st); + st->n.tb = tb; + + break; + } + + case INTERFACE_INTRINSIC_OP: + ns->tb_op[op] = tb; + break; + + default: + gcc_unreachable (); + } } /* Now, match all following names as specific targets. */ @@ -7504,7 +7583,7 @@ gfc_match_generic (void) if (target_st == target->specific_st) { gfc_error ("'%s' already defined as specific binding for the" - " generic '%s' at %C", name, st->name); + " generic '%s' at %C", name, bind_name); goto error; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3d95d217..cb456bc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1287,6 +1287,10 @@ typedef struct gfc_namespace /* Tree containing type-bound procedures. */ gfc_symtree *tb_sym_root; + /* Type-bound user operators. */ + gfc_symtree *tb_uop_root; + /* For derived-types, store type-bound intrinsic operators here. */ + gfc_typebound_proc *tb_op[GFC_INTRINSIC_OPS]; /* Linked list of finalizer procedures. */ struct gfc_finalizer *finalizers; @@ -2448,6 +2452,10 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); gfc_typebound_proc* gfc_get_typebound_proc (void); gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool); +gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, + const char*, bool); +gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*, + gfc_intrinsic_op, bool); gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *); @@ -2636,6 +2644,7 @@ gfc_interface *gfc_current_interface_head (void); void gfc_set_current_interface_head (gfc_interface *); gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); +bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); /* io.c */ extern gfc_st_label format_asterisk; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 982aa29..daa46d8 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -544,17 +544,16 @@ find_keyword_arg (const char *name, gfc_formal_arglist *f) /* Given an operator interface and the operator, make sure that all interfaces for that operator are legal. */ -static void -check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) +bool +gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op, + locus opwhere) { gfc_formal_arglist *formal; sym_intent i1, i2; - gfc_symbol *sym; bt t1, t2; int args, r1, r2, k1, k2; - if (intr == NULL) - return; + gcc_assert (sym); args = 0; t1 = t2 = BT_UNKNOWN; @@ -562,34 +561,32 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) r1 = r2 = -1; k1 = k2 = -1; - for (formal = intr->sym->formal; formal; formal = formal->next) + for (formal = sym->formal; formal; formal = formal->next) { - sym = formal->sym; - if (sym == NULL) + gfc_symbol *fsym = formal->sym; + if (fsym == NULL) { gfc_error ("Alternate return cannot appear in operator " - "interface at %L", &intr->sym->declared_at); - return; + "interface at %L", &sym->declared_at); + return false; } if (args == 0) { - t1 = sym->ts.type; - i1 = sym->attr.intent; - r1 = (sym->as != NULL) ? sym->as->rank : 0; - k1 = sym->ts.kind; + t1 = fsym->ts.type; + i1 = fsym->attr.intent; + r1 = (fsym->as != NULL) ? fsym->as->rank : 0; + k1 = fsym->ts.kind; } if (args == 1) { - t2 = sym->ts.type; - i2 = sym->attr.intent; - r2 = (sym->as != NULL) ? sym->as->rank : 0; - k2 = sym->ts.kind; + t2 = fsym->ts.type; + i2 = fsym->attr.intent; + r2 = (fsym->as != NULL) ? fsym->as->rank : 0; + k2 = fsym->ts.kind; } args++; } - sym = intr->sym; - /* Only +, - and .not. can be unary operators. .not. cannot be a binary operator. */ if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS @@ -598,8 +595,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) || (args == 2 && op == INTRINSIC_NOT)) { gfc_error ("Operator interface at %L has the wrong number of arguments", - &intr->sym->declared_at); - return; + &sym->declared_at); + return false; } /* Check that intrinsics are mapped to functions, except @@ -609,20 +606,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) if (!sym->attr.subroutine) { gfc_error ("Assignment operator interface at %L must be " - "a SUBROUTINE", &intr->sym->declared_at); - return; + "a SUBROUTINE", &sym->declared_at); + return false; } if (args != 2) { gfc_error ("Assignment operator interface at %L must have " - "two arguments", &intr->sym->declared_at); - return; + "two arguments", &sym->declared_at); + return false; } /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments): - - First argument an array with different rank than second, - - Types and kinds do not conform, and - - First argument is of derived type. */ + - First argument an array with different rank than second, + - Types and kinds do not conform, and + - First argument is of derived type. */ if (sym->formal->sym->ts.type != BT_DERIVED && (r1 == 0 || r1 == r2) && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type @@ -630,8 +627,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) && gfc_numeric_ts (&sym->formal->next->sym->ts)))) { gfc_error ("Assignment operator interface at %L must not redefine " - "an INTRINSIC type assignment", &intr->sym->declared_at); - return; + "an INTRINSIC type assignment", &sym->declared_at); + return false; } } else @@ -639,8 +636,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) if (!sym->attr.function) { gfc_error ("Intrinsic operator interface at %L must be a FUNCTION", - &intr->sym->declared_at); - return; + &sym->declared_at); + return false; } } @@ -648,22 +645,34 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) if (op == INTRINSIC_ASSIGN) { if (i1 != INTENT_OUT && i1 != INTENT_INOUT) - gfc_error ("First argument of defined assignment at %L must be " - "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at); + { + gfc_error ("First argument of defined assignment at %L must be " + "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at); + return false; + } if (i2 != INTENT_IN) - gfc_error ("Second argument of defined assignment at %L must be " - "INTENT(IN)", &intr->sym->declared_at); + { + gfc_error ("Second argument of defined assignment at %L must be " + "INTENT(IN)", &sym->declared_at); + return false; + } } else { if (i1 != INTENT_IN) - gfc_error ("First argument of operator interface at %L must be " - "INTENT(IN)", &intr->sym->declared_at); + { + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &sym->declared_at); + return false; + } if (args == 2 && i2 != INTENT_IN) - gfc_error ("Second argument of operator interface at %L must be " - "INTENT(IN)", &intr->sym->declared_at); + { + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &sym->declared_at); + return false; + } } /* From now on, all we have to do is check that the operator definition @@ -686,7 +695,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) if (t1 == BT_LOGICAL) goto bad_repl; else - return; + return true; } if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS)) @@ -694,20 +703,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) if (IS_NUMERIC_TYPE (t1)) goto bad_repl; else - return; + return true; } /* Character intrinsic operators have same character kind, thus operator definitions with operands of different character kinds are always safe. */ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2) - return; + return true; /* Intrinsic operators always perform on arguments of same rank, so different ranks is also always safe. (rank == 0) is an exception to that, because all intrinsic operators are elemental. */ if (r1 != r2 && r1 != 0 && r2 != 0) - return; + return true; switch (op) { @@ -760,14 +769,14 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op) break; } - return; + return true; #undef IS_NUMERIC_TYPE bad_repl: gfc_error ("Operator interface at %L conflicts with intrinsic interface", - &intr->where); - return; + &opwhere); + return false; } @@ -1229,7 +1238,9 @@ gfc_check_interfaces (gfc_namespace *ns) if (check_interface0 (ns->op[i], interface_name)) continue; - check_operator_interface (ns->op[i], (gfc_intrinsic_op) i); + if (ns->op[i]) + gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i, + ns->op[i]->where); for (ns2 = ns; ns2; ns2 = ns2->parent) { diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 81c8ccd..5c43704 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8793,37 +8793,27 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } -/* Resolve a GENERIC procedure binding for a derived type. */ +/* Worker function for resolving a generic procedure binding; this is used to + resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures. + + The difference between those cases is finding possible inherited bindings + that are overridden, as one has to look for them in tb_sym_root, + tb_uop_root or tb_op, respectively. Thus the caller must already find + the super-type and set p->overridden correctly. */ static gfc_try -resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) +resolve_tb_generic_targets (gfc_symbol* super_type, + gfc_typebound_proc* p, const char* name) { gfc_tbp_generic* target; gfc_symtree* first_target; - gfc_symbol* super_type; gfc_symtree* inherited; - locus where; - - gcc_assert (st->n.tb); - gcc_assert (st->n.tb->is_generic); - - where = st->n.tb->where; - super_type = gfc_get_derived_super_type (derived); - - /* Find the overridden binding if any. */ - st->n.tb->overridden = NULL; - if (super_type) - { - gfc_symtree* overridden; - overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true); - if (overridden && overridden->n.tb) - st->n.tb->overridden = overridden->n.tb; - } + gcc_assert (p && p->is_generic); /* Try to find the specific bindings for the symtrees in our target-list. */ - gcc_assert (st->n.tb->u.generic); - for (target = st->n.tb->u.generic; target; target = target->next) + gcc_assert (p->u.generic); + for (target = p->u.generic; target; target = target->next) if (!target->specific) { gfc_typebound_proc* overridden_tbp; @@ -8854,7 +8844,7 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) } gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'" - " at %L", target_name, st->name, &where); + " at %L", target_name, name, &p->where); return FAILURE; /* Once we've found the specific binding, check it is not ambiguous with @@ -8866,19 +8856,19 @@ specific_found: 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); + " '%s' is GENERIC, too", name, &p->where, target_name); return FAILURE; } /* Check those already resolved on this type directly. */ - for (g = st->n.tb->u.generic; g; g = g->next) + for (g = p->u.generic; g; g = g->next) if (g != target && g->specific - && check_generic_tbp_ambiguity (target, g, st->name, where) + && check_generic_tbp_ambiguity (target, g, name, p->where) == FAILURE) return FAILURE; /* Check for ambiguity with inherited specific targets. */ - for (overridden_tbp = st->n.tb->overridden; overridden_tbp; + for (overridden_tbp = p->overridden; overridden_tbp; overridden_tbp = overridden_tbp->overridden) if (overridden_tbp->is_generic) { @@ -8886,36 +8876,167 @@ specific_found: { gcc_assert (g->specific); if (check_generic_tbp_ambiguity (target, g, - st->name, where) == FAILURE) + name, p->where) == FAILURE) return FAILURE; } } } /* If we attempt to "overwrite" a specific binding, this is an error. */ - if (st->n.tb->overridden && !st->n.tb->overridden->is_generic) + if (p->overridden && !p->overridden->is_generic) { gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with" - " the same name", st->name, &where); + " the same name", name, &p->where); return FAILURE; } /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as all must have the same attributes here. */ - first_target = st->n.tb->u.generic->specific->u.specific; + first_target = p->u.generic->specific->u.specific; gcc_assert (first_target); - st->n.tb->subroutine = first_target->n.sym->attr.subroutine; - st->n.tb->function = first_target->n.sym->attr.function; + p->subroutine = first_target->n.sym->attr.subroutine; + p->function = first_target->n.sym->attr.function; return SUCCESS; } -/* Resolve the type-bound procedures for a derived type. */ +/* Resolve a GENERIC procedure binding for a derived type. */ + +static gfc_try +resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) +{ + gfc_symbol* super_type; + + /* Find the overridden binding if any. */ + st->n.tb->overridden = NULL; + super_type = gfc_get_derived_super_type (derived); + if (super_type) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true); + + if (overridden && overridden->n.tb) + st->n.tb->overridden = overridden->n.tb; + } + + /* Resolve using worker function. */ + return resolve_tb_generic_targets (super_type, st->n.tb, st->name); +} + + +/* Resolve a type-bound intrinsic operator. */ + +static gfc_try +resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, + gfc_typebound_proc* p) +{ + gfc_symbol* super_type; + gfc_tbp_generic* target; + + /* If there's already an error here, do nothing (but don't fail again). */ + if (p->error) + return SUCCESS; + + /* Operators should always be GENERIC bindings. */ + gcc_assert (p->is_generic); + + /* Look for an overridden binding. */ + super_type = gfc_get_derived_super_type (derived); + if (super_type && super_type->f2k_derived) + p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL, + op, true); + else + p->overridden = NULL; + + /* Resolve general GENERIC properties using worker function. */ + if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE) + goto error; + + /* Check the targets to be procedures of correct interface. */ + for (target = p->u.generic; target; target = target->next) + { + gfc_symbol* target_proc; + + gcc_assert (target->specific && !target->specific->is_generic); + target_proc = target->specific->u.specific->n.sym; + gcc_assert (target_proc); + + if (!gfc_check_operator_interface (target_proc, op, p->where)) + return FAILURE; + } + + return SUCCESS; + +error: + p->error = 1; + return FAILURE; +} + + +/* Resolve a type-bound user operator (tree-walker callback). */ static gfc_symbol* resolve_bindings_derived; static gfc_try resolve_bindings_result; +static gfc_try check_uop_procedure (gfc_symbol* sym, locus where); + +static void +resolve_typebound_user_op (gfc_symtree* stree) +{ + gfc_symbol* super_type; + gfc_tbp_generic* target; + + gcc_assert (stree && stree->n.tb); + + if (stree->n.tb->error) + return; + + /* Operators should always be GENERIC bindings. */ + gcc_assert (stree->n.tb->is_generic); + + /* Find overridden procedure, if any. */ + super_type = gfc_get_derived_super_type (resolve_bindings_derived); + if (super_type && super_type->f2k_derived) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_user_op (super_type, NULL, + stree->name, true); + + if (overridden && overridden->n.tb) + stree->n.tb->overridden = overridden->n.tb; + } + else + stree->n.tb->overridden = NULL; + + /* Resolve basically using worker function. */ + if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name) + == FAILURE) + goto error; + + /* Check the targets to be functions of correct interface. */ + for (target = stree->n.tb->u.generic; target; target = target->next) + { + gfc_symbol* target_proc; + + gcc_assert (target->specific && !target->specific->is_generic); + target_proc = target->specific->u.specific->n.sym; + gcc_assert (target_proc); + + if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE) + goto error; + } + + return; + +error: + resolve_bindings_result = FAILURE; + stree->n.tb->error = 1; +} + + +/* Resolve the type-bound procedures for a derived type. */ + static void resolve_typebound_procedure (gfc_symtree* stree) { @@ -9082,13 +9203,42 @@ error: static gfc_try resolve_typebound_procedures (gfc_symbol* derived) { + int op; + bool found_op; + if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) return SUCCESS; resolve_bindings_derived = derived; resolve_bindings_result = SUCCESS; - gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, - &resolve_typebound_procedure); + + if (derived->f2k_derived->tb_sym_root) + gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, + &resolve_typebound_procedure); + + found_op = (derived->f2k_derived->tb_uop_root != NULL); + if (derived->f2k_derived->tb_uop_root) + gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, + &resolve_typebound_user_op); + + for (op = 0; op != GFC_INTRINSIC_OPS; ++op) + { + gfc_typebound_proc* p = derived->f2k_derived->tb_op[op]; + if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op, + p) == FAILURE) + resolve_bindings_result = FAILURE; + if (p) + found_op = true; + } + + /* FIXME: Remove this (and found_op) once calls are fully implemented. */ + if (found_op) + { + gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's," + " they are not yet implemented.", + derived->name, &derived->declared_at); + resolve_bindings_result = FAILURE; + } return resolve_bindings_result; } @@ -11063,67 +11213,94 @@ resolve_fntype (gfc_namespace *ns) } } + /* 12.3.2.1.1 Defined operators. */ -static void -gfc_resolve_uops (gfc_symtree *symtree) +static gfc_try +check_uop_procedure (gfc_symbol *sym, locus where) { - gfc_interface *itr; - gfc_symbol *sym; gfc_formal_arglist *formal; - if (symtree == NULL) - return; + if (!sym->attr.function) + { + gfc_error ("User operator procedure '%s' at %L must be a FUNCTION", + sym->name, &where); + return FAILURE; + } - gfc_resolve_uops (symtree->left); - gfc_resolve_uops (symtree->right); + if (sym->ts.type == BT_CHARACTER + && !(sym->ts.cl && sym->ts.cl->length) + && !(sym->result && sym->result->ts.cl + && sym->result->ts.cl->length)) + { + gfc_error ("User operator procedure '%s' at %L cannot be assumed " + "character length", sym->name, &where); + return FAILURE; + } - for (itr = symtree->n.uop->op; itr; itr = itr->next) + formal = sym->formal; + if (!formal || !formal->sym) { - sym = itr->sym; - if (!sym->attr.function) - gfc_error ("User operator procedure '%s' at %L must be a FUNCTION", - sym->name, &sym->declared_at); + gfc_error ("User operator procedure '%s' at %L must have at least " + "one argument", sym->name, &where); + return FAILURE; + } - if (sym->ts.type == BT_CHARACTER - && !(sym->ts.cl && sym->ts.cl->length) - && !(sym->result && sym->result->ts.cl - && sym->result->ts.cl->length)) - gfc_error ("User operator procedure '%s' at %L cannot be assumed " - "character length", sym->name, &sym->declared_at); + if (formal->sym->attr.intent != INTENT_IN) + { + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &where); + return FAILURE; + } - formal = sym->formal; - if (!formal || !formal->sym) - { - gfc_error ("User operator procedure '%s' at %L must have at least " - "one argument", sym->name, &sym->declared_at); - continue; - } + if (formal->sym->attr.optional) + { + gfc_error ("First argument of operator interface at %L cannot be " + "optional", &where); + return FAILURE; + } - if (formal->sym->attr.intent != INTENT_IN) - gfc_error ("First argument of operator interface at %L must be " - "INTENT(IN)", &sym->declared_at); + formal = formal->next; + if (!formal || !formal->sym) + return SUCCESS; - if (formal->sym->attr.optional) - gfc_error ("First argument of operator interface at %L cannot be " - "optional", &sym->declared_at); + if (formal->sym->attr.intent != INTENT_IN) + { + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &where); + return FAILURE; + } - formal = formal->next; - if (!formal || !formal->sym) - continue; + if (formal->sym->attr.optional) + { + gfc_error ("Second argument of operator interface at %L cannot be " + "optional", &where); + return FAILURE; + } - if (formal->sym->attr.intent != INTENT_IN) - gfc_error ("Second argument of operator interface at %L must be " - "INTENT(IN)", &sym->declared_at); + if (formal->next) + { + gfc_error ("Operator interface at %L must have, at most, two " + "arguments", &where); + return FAILURE; + } - if (formal->sym->attr.optional) - gfc_error ("Second argument of operator interface at %L cannot be " - "optional", &sym->declared_at); + return SUCCESS; +} - if (formal->next) - gfc_error ("Operator interface at %L must have, at most, two " - "arguments", &sym->declared_at); - } +static void +gfc_resolve_uops (gfc_symtree *symtree) +{ + gfc_interface *itr; + + if (symtree == NULL) + return; + + gfc_resolve_uops (symtree->left); + gfc_resolve_uops (symtree->right); + + for (itr = symtree->n.uop->op; itr; itr = itr->next) + check_uop_procedure (itr->sym, itr->sym->declared_at); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b86afc0..c2666ae 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2220,7 +2220,10 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types) ns->parent = parent; for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) - ns->operator_access[in] = ACCESS_UNKNOWN; + { + ns->operator_access[in] = ACCESS_UNKNOWN; + ns->tb_op[in] = NULL; + } /* Initialize default implicit types. */ for (i = 'a'; i <= 'z'; i++) @@ -2948,7 +2951,6 @@ free_common_tree (gfc_symtree * common_tree) static void free_uop_tree (gfc_symtree *uop_tree) { - if (uop_tree == NULL) return; @@ -2956,7 +2958,6 @@ free_uop_tree (gfc_symtree *uop_tree) free_uop_tree (uop_tree->right); gfc_free_interface (uop_tree->n.uop->op); - gfc_free (uop_tree->n.uop); gfc_free (uop_tree); } @@ -3128,6 +3129,7 @@ gfc_free_namespace (gfc_namespace *ns) free_uop_tree (ns->uop_root); free_common_tree (ns->common_root); free_tb_tree (ns->tb_sym_root); + free_tb_tree (ns->tb_uop_root); gfc_free_finalizer_list (ns->finalizers); gfc_free_charlen (ns->cl_list, NULL); free_st_labels (ns->st_labels); @@ -4519,22 +4521,27 @@ gfc_get_derived_super_type (gfc_symbol* derived) } -/* Find a type-bound procedure by name for a derived-type (looking recursively - through the super-types). */ +/* General worker function to find either a type-bound procedure or a + type-bound user operator. */ -gfc_symtree* -gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess) +static gfc_symtree* +find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess, bool uop) { gfc_symtree* res; + gfc_symtree* root; + + /* Set correct symbol-root. */ + gcc_assert (derived->f2k_derived); + root = (uop ? derived->f2k_derived->tb_uop_root + : derived->f2k_derived->tb_sym_root); /* Set default to failure. */ if (t) *t = FAILURE; /* Try to find it in the current type's namespace. */ - gcc_assert (derived->f2k_derived); - res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name); + res = gfc_find_symtree (root, name); if (res && res->n.tb) { /* We found one. */ @@ -4558,7 +4565,79 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, gfc_symbol* super_type; super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); - return gfc_find_typebound_proc (super_type, t, name, noaccess); + + return find_typebound_proc_uop (super_type, t, name, noaccess, uop); + } + + /* Nothing found. */ + return NULL; +} + + +/* Find a type-bound procedure or user operator by name for a derived-type + (looking recursively through the super-types). */ + +gfc_symtree* +gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, false); +} + +gfc_symtree* +gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, true); +} + + +/* Find a type-bound intrinsic operator looking recursively through the + super-type hierarchy. */ + +gfc_typebound_proc* +gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, + gfc_intrinsic_op op, bool noaccess) +{ + gfc_typebound_proc* res; + + /* Set default to failure. */ + if (t) + *t = FAILURE; + + /* Try to find it in the current type's namespace. */ + if (derived->f2k_derived) + res = derived->f2k_derived->tb_op[op]; + else + res = NULL; + + /* Check access. */ + if (res) + { + /* We found one. */ + if (t) + *t = SUCCESS; + + if (!noaccess && derived->attr.use_assoc + && res->access == ACCESS_PRIVATE) + { + gfc_error ("'%s' of '%s' is PRIVATE at %C", + gfc_op2string (op), derived->name); + if (t) + *t = FAILURE; + } + + return res; + } + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + + return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess); } /* Nothing found. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c4be548..211381f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-08-10 Daniel Kraft + + PR fortran/37425 + * gfortran.dg/typebound_operator_1.f03: New test. + * gfortran.dg/typebound_operator_2.f03: New test. + 2009-08-10 Richard Guenther PR middle-end/41006 diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 new file mode 100644 index 0000000..fd74d9b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-w" } +! FIXME: Remove -w once CLASS is fully supported. + +! Type-bound procedures +! Check correct type-bound operator definitions. + +MODULE m + IMPLICIT NONE + + TYPE t ! { dg-error "not yet implemented" } + CONTAINS + PROCEDURE, PASS :: onearg + PROCEDURE, PASS :: twoarg1 + PROCEDURE, PASS :: twoarg2 + PROCEDURE, PASS(me) :: assign_proc + + GENERIC :: OPERATOR(.BINARY.) => twoarg1, twoarg2 + GENERIC :: OPERATOR(.UNARY.) => onearg + GENERIC :: ASSIGNMENT(=) => assign_proc + END TYPE t + +CONTAINS + + INTEGER FUNCTION onearg (me) + CLASS(t), INTENT(IN) :: me + onearg = 5 + END FUNCTION onearg + + INTEGER FUNCTION twoarg1 (me, a) + CLASS(t), INTENT(IN) :: me + INTEGER, INTENT(IN) :: a + twoarg1 = 42 + END FUNCTION twoarg1 + + INTEGER FUNCTION twoarg2 (me, a) + CLASS(t), INTENT(IN) :: me + REAL, INTENT(IN) :: a + twoarg2 = 123 + END FUNCTION twoarg2 + + SUBROUTINE assign_proc (me, b) + CLASS(t), INTENT(OUT) :: me + CLASS(t), INTENT(IN) :: b + me = t () + END SUBROUTINE assign_proc + +END MODULE m + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 new file mode 100644 index 0000000..ccce3b5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 @@ -0,0 +1,69 @@ +! { dg-do compile } +! { dg-options "-w" } +! FIXME: Remove -w once CLASS is fully supported. + +! Type-bound procedures +! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage. + +MODULE m + IMPLICIT NONE + + TYPE t ! { dg-error "not yet implemented" } + CONTAINS + PROCEDURE, PASS :: onearg + PROCEDURE, PASS :: onearg_alt => onearg + PROCEDURE, PASS :: onearg_alt2 => onearg + PROCEDURE, PASS :: threearg + PROCEDURE, NOPASS :: noarg + PROCEDURE, PASS :: sub + PROCEDURE, PASS :: sub2 ! { dg-error "must be a FUNCTION" } + PROCEDURE, PASS :: func + + ! These give errors at the targets' definitions. + GENERIC :: OPERATOR(.AND.) => sub2 + GENERIC :: OPERATOR(*) => onearg + GENERIC :: ASSIGNMENT(=) => func + + GENERIC :: OPERATOR(.UOPA.) => sub ! { dg-error "must be a FUNCTION" } + GENERIC :: OPERATOR(.UOPB.) => threearg ! { dg-error "at most, two arguments" } + GENERIC :: OPERATOR(.UOPC.) => noarg ! { dg-error "at least one argument" } + + GENERIC :: OPERATOR(.UNARY.) => onearg_alt + GENERIC, PRIVATE :: OPERATOR(.UNARY.) => onearg_alt2 ! { dg-error "must have the same access" } + END TYPE t + +CONTAINS + + INTEGER FUNCTION onearg (me) ! { dg-error "wrong number of arguments" } + CLASS(t), INTENT(IN) :: me + onearg = 5 + END FUNCTION onearg + + INTEGER FUNCTION threearg (a, b, c) + CLASS(t), INTENT(IN) :: a, b, c + threearg = 42 + END FUNCTION threearg + + INTEGER FUNCTION noarg () + noarg = 42 + END FUNCTION noarg + + LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" } + CLASS(t), INTENT(OUT) :: me + CLASS(t), INTENT(IN) :: b + me = t () + func = .TRUE. + END FUNCTION func + + SUBROUTINE sub (a) + CLASS(t), INTENT(IN) :: a + END SUBROUTINE sub + + SUBROUTINE sub2 (a, x) + CLASS(t), INTENT(IN) :: a + INTEGER, INTENT(IN) :: x + END SUBROUTINE sub2 + +END MODULE m + +! { dg-final { cleanup-modules "m" } } -- 2.7.4