+2009-08-27 Daniel Kraft <d@domob.eu>
+
+ 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 <bdavis9659@sbcglobal.net>
PR fortran/28093
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;
{
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;
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 *);
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 *);
}
+/* 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;
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 ();
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);
}
}
+ /* 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);
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;
}
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;
/* 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. */
}
+/* 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 *
mio_rparen ();
}
+/* Walker-callback function for this purpose. */
static void
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)
{
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 ();
}
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;
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;
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);
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;
return FAILURE;
}
- if (tbp->nopass)
+ if (tbp->nopass || e->value.compcall.ignore_pass)
{
gfc_free_expr (po);
return SUCCESS;
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);
return FAILURE;
}
+ /* These must not be assign-calls! */
+ gcc_assert (!e->value.compcall.assign);
+
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
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;
}
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. */
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);
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
+ case EXEC_ASSIGN_CALL:
break;
case EXEC_ENTRY:
/* 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)
{
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;
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;
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;
{
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;
{
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;
resolve_typebound_procedures (gfc_symbol* derived)
{
int op;
- bool found_op;
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
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);
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;
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)
{
/* 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",
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;
/* 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)
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;
}
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. */
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);
}
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;
res = NULL;
/* Check access. */
- if (res)
+ if (res && !res->error)
{
/* We found one. */
if (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;
}
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. */
+2009-08-27 Daniel Kraft <d@domob.eu>
+
+ 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 <dodji@redhat.com>
PR debug/41770
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" } }
MODULE m
IMPLICIT NONE
- TYPE t ! { dg-error "not yet implemented" }
+ TYPE t
+ LOGICAL :: x
CONTAINS
PROCEDURE, PASS :: onearg
PROCEDURE, PASS :: twoarg1
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
MODULE m
IMPLICIT NONE
- TYPE t ! { dg-error "not yet implemented" }
+ TYPE t
CONTAINS
PROCEDURE, PASS :: onearg
PROCEDURE, PASS :: onearg_alt => onearg
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
OSDN Git Service
