From: domob Date: Thu, 27 Aug 2009 11:42:56 +0000 (+0000) Subject: 2009-08-27 Daniel Kraft X-Git-Tag: upstream/4.9.2~34082 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=7d034542867cddd55dc133813dae02338fdb9cf2;p=platform%2Fupstream%2Flinaro-gcc.git 2009-08-27 Daniel Kraft PR fortran/37425 * gfortran.h (gfc_expr): Optionally store base-object in compcall value and add a new flag to distinguish assign-calls generated. (gfc_find_typebound_proc): Add locus argument. (gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto. (gfc_extend_expr): Return if failure was by a real error. * interface.c (matching_typebound_op): New routine. (build_compcall_for_operator): New routine. (gfc_extend_expr): Handle type-bound operators, some clean-up and return if failure was by a real error or just by not finding an appropriate operator definition. (gfc_extend_assign): Handle type-bound assignments. * module.c (MOD_VERSION): Incremented. (mio_intrinsic_op): New routine. (mio_full_typebound_tree): New routine to make typebound-procedures IO code reusable for type-bound user operators. (mio_f2k_derived): IO of type-bound operators. * primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and pass locus to gfc_find_typebound_proc. * resolve.c (resolve_operator): Only output error about no matching interface if gfc_extend_expr did not already fail with an error. (extract_compcall_passed_object): Use specified base-object if present. (update_compcall_arglist): Handle ignore_pass field. (resolve_ordinary_assign): Update to handle extended code for type-bound assignments, too. (resolve_code): Handle EXEC_ASSIGN_CALL statement code. (resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc. (resolve_typebound_generic), (resolve_typebound_procedure): Ditto. (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto. (ensure_not_abstract_walker), (resolve_fl_derived): Ditto. (resolve_typebound_procedures): Remove not-implemented error. (resolve_typebound_call): Handle assign-call flag. * symbol.c (find_typebound_proc_uop): New argument to pass locus for error message about PRIVATE, verify that a found procedure is not marked as erraneous. (gfc_find_typebound_intrinsic_op): Ditto. (gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg. 2009-08-27 Daniel Kraft PR fortran/37425 * gfortran.dg/impure_assignment_1.f90: Change expected error message. * gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented error and fix problem with recursive assignment. * gfortran.dg/typebound_operator_2.f03: No not-implemented check. * gfortran.dg/typebound_operator_3.f03: New test. * gfortran.dg/typebound_operator_4.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151140 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 43c4081..23dce57 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,43 @@ +2009-08-27 Daniel Kraft + + PR fortran/37425 + * gfortran.h (gfc_expr): Optionally store base-object in compcall value + and add a new flag to distinguish assign-calls generated. + (gfc_find_typebound_proc): Add locus argument. + (gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto. + (gfc_extend_expr): Return if failure was by a real error. + * interface.c (matching_typebound_op): New routine. + (build_compcall_for_operator): New routine. + (gfc_extend_expr): Handle type-bound operators, some clean-up and + return if failure was by a real error or just by not finding an + appropriate operator definition. + (gfc_extend_assign): Handle type-bound assignments. + * module.c (MOD_VERSION): Incremented. + (mio_intrinsic_op): New routine. + (mio_full_typebound_tree): New routine to make typebound-procedures IO + code reusable for type-bound user operators. + (mio_f2k_derived): IO of type-bound operators. + * primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and + pass locus to gfc_find_typebound_proc. + * resolve.c (resolve_operator): Only output error about no matching + interface if gfc_extend_expr did not already fail with an error. + (extract_compcall_passed_object): Use specified base-object if present. + (update_compcall_arglist): Handle ignore_pass field. + (resolve_ordinary_assign): Update to handle extended code for + type-bound assignments, too. + (resolve_code): Handle EXEC_ASSIGN_CALL statement code. + (resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc. + (resolve_typebound_generic), (resolve_typebound_procedure): Ditto. + (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto. + (ensure_not_abstract_walker), (resolve_fl_derived): Ditto. + (resolve_typebound_procedures): Remove not-implemented error. + (resolve_typebound_call): Handle assign-call flag. + * symbol.c (find_typebound_proc_uop): New argument to pass locus for + error message about PRIVATE, verify that a found procedure is not marked + as erraneous. + (gfc_find_typebound_intrinsic_op): Ditto. + (gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg. + 2009-08-22 Bud Davis PR fortran/28093 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cbab000..16c596b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1622,8 +1622,8 @@ typedef struct gfc_expr int rank; mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ - /* Nonnull for functions and structure constructors, the base object for - component-calls. */ + /* Nonnull for functions and structure constructors, may also used to hold the + base-object for component calls. */ gfc_symtree *symtree; gfc_ref *ref; @@ -1699,8 +1699,19 @@ typedef struct gfc_expr { gfc_actual_arglist* actual; const char* name; - void* padding; /* Overlap gfc_typebound_proc with esym. */ - gfc_typebound_proc* tbp; + /* Base-object, whose component was called. NULL means that it should + be taken from symtree/ref. */ + struct gfc_expr* base_object; + gfc_typebound_proc* tbp; /* Should overlap with esym. */ + + /* For type-bound operators, we want to call PASS procedures but already + have the full arglist; mark this, so that it is not extended by the + PASS argument. */ + unsigned ignore_pass:1; + + /* Do assign-calls rather than calls, that is appropriate dependency + checking. */ + unsigned assign:1; } compcall; @@ -2458,11 +2469,13 @@ 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_proc (gfc_symbol*, gfc_try*, + const char*, bool, locus*); gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, - const char*, bool); + const char*, bool, locus*); gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*, - gfc_intrinsic_op, bool); + gfc_intrinsic_op, bool, + locus*); gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *); @@ -2643,7 +2656,7 @@ void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *); gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_actual_arglist **); -gfc_try gfc_extend_expr (gfc_expr *); +gfc_try gfc_extend_expr (gfc_expr *, bool *); void gfc_free_formal_arglist (gfc_formal_arglist *); gfc_try gfc_extend_assign (gfc_code *, gfc_namespace *); gfc_try gfc_add_interface (gfc_symbol *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 60096e2..6d16fe1 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2554,16 +2554,119 @@ gfc_find_sym_in_symtree (gfc_symbol *sym) } +/* See if the arglist to an operator-call contains a derived-type argument + with a matching type-bound operator. If so, return the matching specific + procedure defined as operator-target as well as the base-object to use + (which is the found derived-type argument with operator). */ + +static gfc_typebound_proc* +matching_typebound_op (gfc_expr** tb_base, + gfc_actual_arglist* args, + gfc_intrinsic_op op, const char* uop) +{ + gfc_actual_arglist* base; + + for (base = args; base; base = base->next) + if (base->expr->ts.type == BT_DERIVED) + { + gfc_typebound_proc* tb; + gfc_symbol* derived; + gfc_try result; + + derived = base->expr->ts.u.derived; + + if (op == INTRINSIC_USER) + { + gfc_symtree* tb_uop; + + gcc_assert (uop); + tb_uop = gfc_find_typebound_user_op (derived, &result, uop, + false, NULL); + + if (tb_uop) + tb = tb_uop->n.tb; + else + tb = NULL; + } + else + tb = gfc_find_typebound_intrinsic_op (derived, &result, op, + false, NULL); + + /* This means we hit a PRIVATE operator which is use-associated and + should thus not be seen. */ + if (result == FAILURE) + tb = NULL; + + /* Look through the super-type hierarchy for a matching specific + binding. */ + for (; tb; tb = tb->overridden) + { + gfc_tbp_generic* g; + + gcc_assert (tb->is_generic); + for (g = tb->u.generic; g; g = g->next) + { + gfc_symbol* target; + gfc_actual_arglist* argcopy; + bool matches; + + gcc_assert (g->specific); + if (g->specific->error) + continue; + + target = g->specific->u.specific->n.sym; + + /* Check if this arglist matches the formal. */ + argcopy = gfc_copy_actual_arglist (args); + matches = gfc_arglist_matches_symbol (&argcopy, target); + gfc_free_actual_arglist (argcopy); + + /* Return if we found a match. */ + if (matches) + { + *tb_base = base->expr; + return g->specific; + } + } + } + } + + return NULL; +} + + +/* For the 'actual arglist' of an operator call and a specific typebound + procedure that has been found the target of a type-bound operator, build the + appropriate EXPR_COMPCALL and resolve it. We take this indirection over + type-bound procedures rather than resolving type-bound operators 'directly' + so that we can reuse the existing logic. */ + +static void +build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, + gfc_expr* base, gfc_typebound_proc* target) +{ + e->expr_type = EXPR_COMPCALL; + e->value.compcall.tbp = target; + e->value.compcall.name = "operator"; /* Should not matter. */ + e->value.compcall.actual = actual; + e->value.compcall.base_object = base; + e->value.compcall.ignore_pass = 1; + e->value.compcall.assign = 0; +} + + /* This subroutine is called when an expression is being resolved. The expression node in question is either a user defined operator or an intrinsic operator with arguments that aren't compatible with the operator. This subroutine builds an actual argument list corresponding to the operands, then searches for a compatible interface. If one is found, the expression node is replaced with - the appropriate function call. */ + the appropriate function call. + real_error is an additional output argument that specifies if FAILURE + is because of some real error and not because no match was found. */ gfc_try -gfc_extend_expr (gfc_expr *e) +gfc_extend_expr (gfc_expr *e, bool *real_error) { gfc_actual_arglist *actual; gfc_symbol *sym; @@ -2576,6 +2679,8 @@ gfc_extend_expr (gfc_expr *e) actual = gfc_get_actual_arglist (); actual->expr = e->value.op.op1; + *real_error = false; + if (e->value.op.op2 != NULL) { actual->next = gfc_get_actual_arglist (); @@ -2605,47 +2710,20 @@ gfc_extend_expr (gfc_expr *e) to check if either is defined. */ switch (i) { - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - sym = gfc_search_interface (ns->op[INTRINSIC_EQ], 0, &actual); - if (sym == NULL) - sym = gfc_search_interface (ns->op[INTRINSIC_EQ_OS], 0, &actual); - break; - - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - sym = gfc_search_interface (ns->op[INTRINSIC_NE], 0, &actual); - if (sym == NULL) - sym = gfc_search_interface (ns->op[INTRINSIC_NE_OS], 0, &actual); - break; - - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - sym = gfc_search_interface (ns->op[INTRINSIC_GT], 0, &actual); - if (sym == NULL) - sym = gfc_search_interface (ns->op[INTRINSIC_GT_OS], 0, &actual); - break; - - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - sym = gfc_search_interface (ns->op[INTRINSIC_GE], 0, &actual); - if (sym == NULL) - sym = gfc_search_interface (ns->op[INTRINSIC_GE_OS], 0, &actual); - break; - - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - sym = gfc_search_interface (ns->op[INTRINSIC_LT], 0, &actual); - if (sym == NULL) - sym = gfc_search_interface (ns->op[INTRINSIC_LT_OS], 0, &actual); - break; - - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - sym = gfc_search_interface (ns->op[INTRINSIC_LE], 0, &actual); - if (sym == NULL) - sym = gfc_search_interface (ns->op[INTRINSIC_LE_OS], 0, &actual); - break; +#define CHECK_OS_COMPARISON(comp) \ + case INTRINSIC_##comp: \ + case INTRINSIC_##comp##_OS: \ + sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \ + if (!sym) \ + sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \ + break; + CHECK_OS_COMPARISON(EQ) + CHECK_OS_COMPARISON(NE) + CHECK_OS_COMPARISON(GT) + CHECK_OS_COMPARISON(GE) + CHECK_OS_COMPARISON(LT) + CHECK_OS_COMPARISON(LE) +#undef CHECK_OS_COMPARISON default: sym = gfc_search_interface (ns->op[i], 0, &actual); @@ -2656,8 +2734,59 @@ gfc_extend_expr (gfc_expr *e) } } + /* TODO: Do an ambiguity-check and error if multiple matching interfaces are + found rather than just taking the first one and not checking further. */ + if (sym == NULL) { + gfc_typebound_proc* tbo; + gfc_expr* tb_base; + + /* See if we find a matching type-bound operator. */ + if (i == INTRINSIC_USER) + tbo = matching_typebound_op (&tb_base, actual, + i, e->value.op.uop->name); + else + switch (i) + { +#define CHECK_OS_COMPARISON(comp) \ + case INTRINSIC_##comp: \ + case INTRINSIC_##comp##_OS: \ + tbo = matching_typebound_op (&tb_base, actual, \ + INTRINSIC_##comp, NULL); \ + if (!tbo) \ + tbo = matching_typebound_op (&tb_base, actual, \ + INTRINSIC_##comp##_OS, NULL); \ + break; + CHECK_OS_COMPARISON(EQ) + CHECK_OS_COMPARISON(NE) + CHECK_OS_COMPARISON(GT) + CHECK_OS_COMPARISON(GE) + CHECK_OS_COMPARISON(LT) + CHECK_OS_COMPARISON(LE) +#undef CHECK_OS_COMPARISON + + default: + tbo = matching_typebound_op (&tb_base, actual, i, NULL); + break; + } + + /* If there is a matching typebound-operator, replace the expression with + a call to it and succeed. */ + if (tbo) + { + gfc_try result; + + gcc_assert (tb_base); + build_compcall_for_operator (e, actual, tb_base, tbo); + + result = gfc_resolve_expr (e); + if (result == FAILURE) + *real_error = true; + + return result; + } + /* Don't use gfc_free_actual_arglist(). */ if (actual->next != NULL) gfc_free (actual->next); @@ -2675,16 +2804,12 @@ gfc_extend_expr (gfc_expr *e) e->value.function.name = NULL; e->user_operator = 1; - if (gfc_pure (NULL) && !gfc_pure (sym)) + if (gfc_resolve_expr (e) == FAILURE) { - gfc_error ("Function '%s' called in lieu of an operator at %L must " - "be PURE", sym->name, &e->where); + *real_error = true; return FAILURE; } - if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; - return SUCCESS; } @@ -2726,8 +2851,33 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) break; } + /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ + if (sym == NULL) { + gfc_typebound_proc* tbo; + gfc_expr* tb_base; + + /* See if we find a matching type-bound assignment. */ + tbo = matching_typebound_op (&tb_base, actual, + INTRINSIC_ASSIGN, NULL); + + /* If there is one, replace the expression with a call to it and + succeed. */ + if (tbo) + { + gcc_assert (tb_base); + c->expr1 = gfc_get_expr (); + build_compcall_for_operator (c->expr1, actual, tb_base, tbo); + c->expr1->value.compcall.assign = 1; + c->expr2 = NULL; + c->op = EXEC_COMPCALL; + + /* c is resolved from the caller, so no need to do it here. */ + + return SUCCESS; + } + gfc_free (actual->next); gfc_free (actual); return FAILURE; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index c791797..ec15d3f 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "2" +#define MOD_VERSION "3" /* Structure that describes a position within a module file. */ @@ -1461,6 +1461,25 @@ mio_integer (int *ip) } +/* Read or write a gfc_intrinsic_op value. */ + +static void +mio_intrinsic_op (gfc_intrinsic_op* op) +{ + /* FIXME: Would be nicer to do this via the operators symbolic name. */ + if (iomode == IO_OUTPUT) + { + int converted = (int) *op; + write_atom (ATOM_INTEGER, &converted); + } + else + { + require_atom (ATOM_INTEGER); + *op = (gfc_intrinsic_op) atom_int; + } +} + + /* Read or write a character pointer that points to a string on the heap. */ static const char * @@ -3324,6 +3343,7 @@ mio_typebound_proc (gfc_typebound_proc** proc) mio_rparen (); } +/* Walker-callback function for this purpose. */ static void mio_typebound_symtree (gfc_symtree* st) { @@ -3341,6 +3361,33 @@ mio_typebound_symtree (gfc_symtree* st) mio_rparen (); } +/* IO a full symtree (in all depth). */ +static void +mio_full_typebound_tree (gfc_symtree** root) +{ + mio_lparen (); + + if (iomode == IO_OUTPUT) + gfc_traverse_symtree (*root, &mio_typebound_symtree); + else + { + while (peek_atom () == ATOM_LPAREN) + { + gfc_symtree* st; + + mio_lparen (); + + require_atom (ATOM_STRING); + st = gfc_get_tbp_symtree (root, atom_string); + gfc_free (atom_string); + + mio_typebound_symtree (st); + } + } + + mio_rparen (); +} + static void mio_finalizer (gfc_finalizer **f) { @@ -3388,24 +3435,40 @@ mio_f2k_derived (gfc_namespace *f2k) mio_rparen (); /* Handle type-bound procedures. */ + mio_full_typebound_tree (&f2k->tb_sym_root); + + /* Type-bound user operators. */ + mio_full_typebound_tree (&f2k->tb_uop_root); + + /* Type-bound intrinsic operators. */ mio_lparen (); if (iomode == IO_OUTPUT) - gfc_traverse_symtree (f2k->tb_sym_root, &mio_typebound_symtree); - else { - while (peek_atom () == ATOM_LPAREN) + int op; + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) { - gfc_symtree* st; - - mio_lparen (); + gfc_intrinsic_op realop; - require_atom (ATOM_STRING); - st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string); - gfc_free (atom_string); + if (op == INTRINSIC_USER || !f2k->tb_op[op]) + continue; - mio_typebound_symtree (st); + mio_lparen (); + realop = (gfc_intrinsic_op) op; + mio_intrinsic_op (&realop); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); } } + else + while (peek_atom () != ATOM_RPAREN) + { + gfc_intrinsic_op op; + + mio_lparen (); + mio_intrinsic_op (&op); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); + } mio_rparen (); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 79db195..267819c 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1783,7 +1783,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m != MATCH_YES) return MATCH_ERROR; - tbp = gfc_find_typebound_proc (sym, &t, name, false); + tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus); if (tbp) { gfc_symbol* tbp_sym; @@ -1802,6 +1802,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, primary->expr_type = EXPR_COMPCALL; primary->value.compcall.tbp = tbp->n.tb; primary->value.compcall.name = tbp->name; + primary->value.compcall.ignore_pass = 0; + primary->value.compcall.assign = 0; + primary->value.compcall.base_object = NULL; gcc_assert (primary->symtree->n.sym->attr.referenced); if (tbp_sym) primary->ts = tbp_sym->ts; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3bc4c58..e1c931b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3508,8 +3508,14 @@ resolve_operator (gfc_expr *e) bad_op: - if (gfc_extend_expr (e) == SUCCESS) - return SUCCESS; + { + bool real_error; + if (gfc_extend_expr (e, &real_error) == SUCCESS) + return SUCCESS; + + if (real_error) + return FAILURE; + } if (dual_locus_error) gfc_error (msg, &op1->where, &op2->where); @@ -4685,10 +4691,15 @@ extract_compcall_passed_object (gfc_expr* e) gcc_assert (e->expr_type == EXPR_COMPCALL); - po = gfc_get_expr (); - po->expr_type = EXPR_VARIABLE; - po->symtree = e->symtree; - po->ref = gfc_copy_ref (e->ref); + if (e->value.compcall.base_object) + po = gfc_copy_expr (e->value.compcall.base_object); + else + { + po = gfc_get_expr (); + po->expr_type = EXPR_VARIABLE; + po->symtree = e->symtree; + po->ref = gfc_copy_ref (e->ref); + } if (gfc_resolve_expr (po) == FAILURE) return NULL; @@ -4721,7 +4732,7 @@ update_compcall_arglist (gfc_expr* e) return FAILURE; } - if (tbp->nopass) + if (tbp->nopass || e->value.compcall.ignore_pass) { gfc_free_expr (po); return SUCCESS; @@ -4957,7 +4968,7 @@ resolve_typebound_call (gfc_code* c) c->ext.actual = newactual; c->symtree = target; - c->op = EXEC_CALL; + c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); gfc_free_expr (c->expr1); @@ -4983,6 +4994,9 @@ resolve_compcall (gfc_expr* e) return FAILURE; } + /* These must not be assign-calls! */ + gcc_assert (!e->value.compcall.assign); + if (check_typebound_baseobject (e) == FAILURE) return FAILURE; @@ -6909,24 +6923,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (gfc_extend_assign (code, ns) == SUCCESS) { - lhs = code->ext.actual->expr; - rhs = code->ext.actual->next->expr; - if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym)) + gfc_symbol* assign_proc; + gfc_expr** rhsptr; + + if (code->op == EXEC_ASSIGN_CALL) { - gfc_error ("Subroutine '%s' called instead of assignment at " - "%L must be PURE", code->symtree->n.sym->name, - &code->loc); - return rval; + lhs = code->ext.actual->expr; + rhsptr = &code->ext.actual->next->expr; + assign_proc = code->symtree->n.sym; + } + else + { + gfc_actual_arglist* args; + gfc_typebound_proc* tbp; + + gcc_assert (code->op == EXEC_COMPCALL); + + args = code->expr1->value.compcall.actual; + lhs = args->expr; + rhsptr = &args->next->expr; + + tbp = code->expr1->value.compcall.tbp; + gcc_assert (!tbp->is_generic); + assign_proc = tbp->u.specific->n.sym; } /* Make a temporary rhs when there is a default initializer and rhs is the same symbol as the lhs. */ - if (rhs->expr_type == EXPR_VARIABLE - && rhs->symtree->n.sym->ts.type == BT_DERIVED - && has_default_initializer (rhs->symtree->n.sym->ts.u.derived) - && (lhs->symtree->n.sym == rhs->symtree->n.sym)) - code->ext.actual->next->expr = gfc_get_parentheses (rhs); + if ((*rhsptr)->expr_type == EXPR_VARIABLE + && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED + && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) + && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) + *rhsptr = gfc_get_parentheses (*rhsptr); + resolve_code (code, ns); return true; } @@ -6935,8 +6965,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (rhs->is_boz && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside " - "a DATA statement and outside INT/REAL/DBLE/CMPLX", - &code->loc) == FAILURE) + "a DATA statement and outside INT/REAL/DBLE/CMPLX", + &code->loc) == FAILURE) return false; /* Handle the case of a BOZ literal on the RHS. */ @@ -6981,7 +7011,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) rlen = rhs->value.character.length; else if (rhs->ts.u.cl != NULL - && rhs->ts.u.cl->length != NULL + && rhs->ts.u.cl->length != NULL && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer); @@ -7115,6 +7145,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: + case EXEC_ASSIGN_CALL: break; case EXEC_ENTRY: @@ -8870,8 +8901,8 @@ resolve_tb_generic_targets (gfc_symbol* super_type, /* Look for an inherited specific binding. */ if (super_type) { - inherited = gfc_find_typebound_proc (super_type, NULL, - target_name, true); + inherited = gfc_find_typebound_proc (super_type, NULL, target_name, + true, NULL); if (inherited) { @@ -8952,7 +8983,8 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) if (super_type) { gfc_symtree* overridden; - overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true); + overridden = gfc_find_typebound_proc (super_type, NULL, st->name, + true, NULL); if (overridden && overridden->n.tb) st->n.tb->overridden = overridden->n.tb; @@ -9006,7 +9038,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, 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); + op, true, NULL); else p->overridden = NULL; @@ -9021,10 +9053,10 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, target_proc = get_checked_tb_operator_target (target, p->where); if (!target_proc) - return FAILURE; + goto error; if (!gfc_check_operator_interface (target_proc, op, p->where)) - return FAILURE; + goto error; } return SUCCESS; @@ -9062,7 +9094,7 @@ resolve_typebound_user_op (gfc_symtree* stree) { gfc_symtree* overridden; overridden = gfc_find_typebound_user_op (super_type, NULL, - stree->name, true); + stree->name, true, NULL); if (overridden && overridden->n.tb) stree->n.tb->overridden = overridden->n.tb; @@ -9225,7 +9257,7 @@ resolve_typebound_procedure (gfc_symtree* stree) { gfc_symtree* overridden; overridden = gfc_find_typebound_proc (super_type, NULL, - stree->name, true); + stree->name, true, NULL); if (overridden && overridden->n.tb) stree->n.tb->overridden = overridden->n.tb; @@ -9265,7 +9297,6 @@ 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; @@ -9277,7 +9308,6 @@ resolve_typebound_procedures (gfc_symbol* derived) 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); @@ -9288,17 +9318,6 @@ resolve_typebound_procedures (gfc_symbol* derived) 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; @@ -9343,7 +9362,7 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) if (st->n.tb && st->n.tb->deferred) { gfc_symtree* overriding; - overriding = gfc_find_typebound_proc (sub, NULL, st->name, true); + overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); gcc_assert (overriding && overriding->n.tb); if (overriding->n.tb->deferred) { @@ -9594,7 +9613,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ if (super_type - && gfc_find_typebound_proc (super_type, NULL, c->name, true)) + && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component '%s' of '%s' at %L has the same name as an" " inherited type-bound procedure", diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8e4f6e9..150d149 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4539,7 +4539,8 @@ gfc_get_derived_super_type (gfc_symbol* derived) static gfc_symtree* find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, bool uop) + const char* name, bool noaccess, bool uop, + locus* where) { gfc_symtree* res; gfc_symtree* root; @@ -4555,7 +4556,7 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, /* Try to find it in the current type's namespace. */ res = gfc_find_symtree (root, name); - if (res && res->n.tb) + if (res && res->n.tb && !res->n.tb->error) { /* We found one. */ if (t) @@ -4564,7 +4565,9 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, if (!noaccess && derived->attr.use_assoc && res->n.tb->access == ACCESS_PRIVATE) { - gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name); + if (where) + gfc_error ("'%s' of '%s' is PRIVATE at %L", + name, derived->name, where); if (t) *t = FAILURE; } @@ -4579,7 +4582,8 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); - return find_typebound_proc_uop (super_type, t, name, noaccess, uop); + return find_typebound_proc_uop (super_type, t, name, + noaccess, uop, where); } /* Nothing found. */ @@ -4592,16 +4596,16 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, gfc_symtree* gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess) + const char* name, bool noaccess, locus* where) { - return find_typebound_proc_uop (derived, t, name, noaccess, false); + return find_typebound_proc_uop (derived, t, name, noaccess, false, where); } gfc_symtree* gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess) + const char* name, bool noaccess, locus* where) { - return find_typebound_proc_uop (derived, t, name, noaccess, true); + return find_typebound_proc_uop (derived, t, name, noaccess, true, where); } @@ -4610,7 +4614,8 @@ gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, - gfc_intrinsic_op op, bool noaccess) + gfc_intrinsic_op op, bool noaccess, + locus* where) { gfc_typebound_proc* res; @@ -4625,7 +4630,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, res = NULL; /* Check access. */ - if (res) + if (res && !res->error) { /* We found one. */ if (t) @@ -4634,8 +4639,9 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, 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 (where) + gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_op2string (op), derived->name, where); if (t) *t = FAILURE; } @@ -4650,7 +4656,8 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); - return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess); + return gfc_find_typebound_intrinsic_op (super_type, t, op, + noaccess, where); } /* Nothing found. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8448541..ad8b144 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2009-08-27 Daniel Kraft + + PR fortran/37425 + * gfortran.dg/impure_assignment_1.f90: Change expected error message. + * gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented + error and fix problem with recursive assignment. + * gfortran.dg/typebound_operator_2.f03: No not-implemented check. + * gfortran.dg/typebound_operator_3.f03: New test. + * gfortran.dg/typebound_operator_4.f03: New test. + 2009-08-27 Dodji Seketeli PR debug/41770 diff --git a/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 b/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 index f7362af..6a1660c 100644 --- a/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 +++ b/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 @@ -21,7 +21,7 @@ CONTAINS PURE SUBROUTINE S2(I,J) TYPE(T1), INTENT(OUT):: I TYPE(T1), INTENT(IN) :: J - I=J ! { dg-error "must be PURE" } + I=J ! { dg-error "is not PURE" } END SUBROUTINE S2 END ! { dg-final { cleanup-modules "M1" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 index fd74d9b..2556590 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 @@ -8,7 +8,8 @@ MODULE m IMPLICIT NONE - TYPE t ! { dg-error "not yet implemented" } + TYPE t + LOGICAL :: x CONTAINS PROCEDURE, PASS :: onearg PROCEDURE, PASS :: twoarg1 @@ -41,8 +42,8 @@ CONTAINS SUBROUTINE assign_proc (me, b) CLASS(t), INTENT(OUT) :: me - CLASS(t), INTENT(IN) :: b - me = t () + LOGICAL, INTENT(IN) :: b + me%x = .NOT. b END SUBROUTINE assign_proc END MODULE m diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 index 67f467c..71e8e4f 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 @@ -8,7 +8,7 @@ MODULE m IMPLICIT NONE - TYPE t ! { dg-error "not yet implemented" } + TYPE t CONTAINS PROCEDURE, PASS :: onearg PROCEDURE, PASS :: onearg_alt => onearg diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 new file mode 100644 index 0000000..9f2369a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 @@ -0,0 +1,127 @@ +! { dg-do run } +! { dg-options "-w" } +! FIXME: Remove -w when CLASS is fully implemented. + +! Type-bound procedures +! Check they can actually be called and run correctly. +! This also checks for correct module save/restore. + +! FIXME: Check that calls to inherited bindings work once CLASS allows that. + +MODULE m + IMPLICIT NONE + + TYPE mynum + REAL :: num_real + INTEGER :: num_int + CONTAINS + PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE. + PROCEDURE, PASS :: add_int + PROCEDURE, PASS :: add_real + PROCEDURE, PASS :: assign_int + PROCEDURE, PASS :: assign_real + PROCEDURE, PASS(from) :: assign_to_int + PROCEDURE, PASS(from) :: assign_to_real + PROCEDURE, PASS :: get_all + + GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real + GENERIC :: OPERATOR(.GET.) => get_all + GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, & + assign_to_int, assign_to_real + END TYPE mynum + +CONTAINS + + TYPE(mynum) FUNCTION add_mynum (a, b) + CLASS(mynum), INTENT(IN) :: a, b + add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int) + END FUNCTION add_mynum + + TYPE(mynum) FUNCTION add_int (a, b) + CLASS(mynum), INTENT(IN) :: a + INTEGER, INTENT(IN) :: b + add_int = mynum (a%num_real, a%num_int + b) + END FUNCTION add_int + + TYPE(mynum) FUNCTION add_real (a, b) + CLASS(mynum), INTENT(IN) :: a + REAL, INTENT(IN) :: b + add_real = mynum (a%num_real + b, a%num_int) + END FUNCTION add_real + + REAL FUNCTION get_all (me) + CLASS(mynum), INTENT(IN) :: me + get_all = me%num_real + me%num_int + END FUNCTION get_all + + SUBROUTINE assign_real (dest, from) + CLASS(mynum), INTENT(INOUT) :: dest + REAL, INTENT(IN) :: from + dest%num_real = from + END SUBROUTINE assign_real + + SUBROUTINE assign_int (dest, from) + CLASS(mynum), INTENT(INOUT) :: dest + INTEGER, INTENT(IN) :: from + dest%num_int = from + END SUBROUTINE assign_int + + SUBROUTINE assign_to_real (dest, from) + REAL, INTENT(OUT) :: dest + CLASS(mynum), INTENT(IN) :: from + dest = from%num_real + END SUBROUTINE assign_to_real + + SUBROUTINE assign_to_int (dest, from) + INTEGER, INTENT(OUT) :: dest + CLASS(mynum), INTENT(IN) :: from + dest = from%num_int + END SUBROUTINE assign_to_int + + ! Test it works basically within the module. + SUBROUTINE check_in_module () + IMPLICIT NONE + TYPE(mynum) :: num + + num = mynum (1.0, 2) + num = num + 7 + IF (num%num_real /= 1.0 .OR. num%num_int /= 9) CALL abort () + END SUBROUTINE check_in_module + +END MODULE m + +! Here we see it also works for use-associated operators loaded from a module. +PROGRAM main + USE m, ONLY: mynum, check_in_module + IMPLICIT NONE + + TYPE(mynum) :: num1, num2, num3 + REAL :: real_var + INTEGER :: int_var + + CALL check_in_module () + + num1 = mynum (1.0, 2) + num2 = mynum (2.0, 3) + + num3 = num1 + num2 + IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) CALL abort () + + num3 = num1 + 5 + IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) CALL abort () + + num3 = num1 + (-100.5) + IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) CALL abort () + + num3 = 42 + num3 = -1.2 + IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) CALL abort () + + real_var = num3 + int_var = num3 + IF (real_var /= -1.2 .OR. int_var /= 42) CALL abort () + + IF (.GET. num1 /= 3.0) CALL abort () +END PROGRAM main + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 new file mode 100644 index 0000000..ee7c298 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 @@ -0,0 +1,94 @@ +! { dg-do compile } +! { dg-options "-w" } +! FIXME: Remove -w when CLASS is fully implemented. + +! Type-bound procedures +! Check for errors with operator calls. + +MODULE m + IMPLICIT NONE + + TYPE myint + INTEGER :: value + CONTAINS + PROCEDURE, PASS :: add_int + PROCEDURE, PASS :: assign_int + GENERIC, PRIVATE :: OPERATOR(.PLUS.) => add_int + GENERIC, PRIVATE :: OPERATOR(+) => add_int + GENERIC, PRIVATE :: ASSIGNMENT(=) => assign_int + END TYPE myint + + TYPE myreal + REAL :: value + CONTAINS + PROCEDURE, PASS :: add_real + PROCEDURE, PASS :: assign_real + GENERIC :: OPERATOR(.PLUS.) => add_real + GENERIC :: OPERATOR(+) => add_real + GENERIC :: ASSIGNMENT(=) => assign_real + END TYPE myreal + +CONTAINS + + PURE TYPE(myint) FUNCTION add_int (a, b) + CLASS(myint), INTENT(IN) :: a + INTEGER, INTENT(IN) :: b + add_int = myint (a%value + b) + END FUNCTION add_int + + PURE SUBROUTINE assign_int (dest, from) + CLASS(myint), INTENT(OUT) :: dest + INTEGER, INTENT(IN) :: from + dest = myint (from) + END SUBROUTINE assign_int + + TYPE(myreal) FUNCTION add_real (a, b) + CLASS(myreal), INTENT(IN) :: a + REAL, INTENT(IN) :: b + add_real = myreal (a%value + b) + END FUNCTION add_real + + SUBROUTINE assign_real (dest, from) + CLASS(myreal), INTENT(OUT) :: dest + REAL, INTENT(IN) :: from + dest = myreal (from) + END SUBROUTINE assign_real + + SUBROUTINE in_module () + TYPE(myint) :: x + x = 0 ! { dg-bogus "Can't convert" } + x = x + 42 ! { dg-bogus "Operands of" } + x = x .PLUS. 5 ! { dg-bogus "Unknown operator" } + END SUBROUTINE in_module + + PURE SUBROUTINE iampure () + TYPE(myint) :: x + + x = 0 ! { dg-bogus "is not PURE" } + x = x + 42 ! { dg-bogus "to a non-PURE procedure" } + x = x .PLUS. 5 ! { dg-bogus "to a non-PURE procedure" } + END SUBROUTINE iampure + +END MODULE m + +PURE SUBROUTINE iampure2 () + USE m + IMPLICIT NONE + TYPE(myreal) :: x + + x = 0.0 ! { dg-error "is not PURE" } + x = x + 42.0 ! { dg-error "to a non-PURE procedure" } + x = x .PLUS. 5.0 ! { dg-error "to a non-PURE procedure" } +END SUBROUTINE iampure2 + +PROGRAM main + USE m + IMPLICIT NONE + TYPE(myint) :: x + + x = 0 ! { dg-error "Can't convert" } + x = x + 42 ! { dg-error "Operands of" } + x = x .PLUS. 5 ! { dg-error "Unknown operator" } +END PROGRAM main + +! { dg-final { cleanup-modules "m" } }