+2016-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/69834
+ * class.c (gfc_find_derived_vtab): Obtain the gsymbol for the
+ derived type's module. If the gsymbol is present and the top
+ level namespace corresponds to a module, use the gsymbol name
+ space. In the search to see if the vtable exists, try the gsym
+ namespace first.
+ * dump-parse-tree (show_code_node): Modify select case dump to
+ show select type construct.
+ * resolve.c (build_loc_call): New function.
+ (resolve_select_type): Add check for repeated type is cases.
+ Retain selector expression and use it later instead of expr1.
+ Exclude deferred length TYPE IS cases and emit error message.
+ Store the address for the vtable in the 'low' expression and
+ the hash value in the 'high' expression, for each case. Do not
+ call resolve_select.
+ * trans.c(trans_code) : Call gfc_trans_select_type.
+ * trans-stmt.c (gfc_trans_select_type_cases): New function.
+ (gfc_trans_select_type): New function.
+ * trans-stmt.h : Add prototype for gfc_trans_select_type.
+
2016-10-22 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/78021
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+ gfc_gsymbol *gsym = NULL;
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
+ /* Find the gsymbol for the module of use associated derived types. */
+ if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
+ && !derived->attr.vtype && !derived->attr.is_class)
+ gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
+ else
+ gsym = NULL;
+
+ /* Work in the gsymbol namespace if the top-level namespace is a module.
+ This ensures that the vtable is unique, which is required since we use
+ its address in SELECT TYPE. */
+ if (gsym && gsym->ns && ns && ns->proc_name
+ && ns->proc_name->attr.flavor == FL_MODULE)
+ ns = gsym->ns;
+
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
sprintf (name, "__vtab_%s", tname);
/* Look for the vtab symbol in various namespaces. */
- gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
+ if (gsym && gsym->ns)
+ {
+ gfc_find_symbol (name, gsym->ns, 0, &vtab);
+ if (vtab)
+ ns = gsym->ns;
+ }
+ if (vtab == NULL)
+ gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
if (vtab == NULL)
gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
print the start expression which contains the vector, in
the latter case we have to print any of lower and upper
bound and the stride, if they're present. */
-
+
if (ar->start[i] != NULL)
show_expr (ar->start[i]);
break;
case BT_CHARACTER:
- show_char_const (p->value.character.string,
+ show_char_const (p->value.character.string,
p->value.character.length);
break;
fputs (", ", dumpfile);
}
fputc ('\n', dumpfile);
-}
+}
/* Worker function to display the symbol tree. */
for (list = omp_clauses->tile_list; list; list = list->next)
{
show_expr (list->expr);
- if (list->next)
+ if (list->next)
fputs (", ", dumpfile);
}
fputc (')', dumpfile);
for (list = omp_clauses->wait_list; list; list = list->next)
{
show_expr (list->expr);
- if (list->next)
+ if (list->next)
fputs (", ", dumpfile);
}
fputc (')', dumpfile);
break;
case EXEC_SELECT:
+ case EXEC_SELECT_TYPE:
d = c->block;
- fputs ("SELECT CASE ", dumpfile);
+ if (c->op == EXEC_SELECT_TYPE)
+ fputs ("SELECT TYPE", dumpfile);
+ else
+ fputs ("SELECT CASE ", dumpfile);
show_expr (c->expr1);
fputc ('\n', dumpfile);
fputs ("User operators:\n", dumpfile);
gfc_traverse_user_op (ns, show_uop);
}
-
+
for (eq = ns->equiv; eq; eq = eq->next)
show_equiv (eq);
}
+static gfc_expr *
+build_loc_call (gfc_expr *sym_expr)
+{
+ gfc_expr *loc_call;
+ loc_call = gfc_get_expr ();
+ loc_call->expr_type = EXPR_FUNCTION;
+ gfc_get_sym_tree ("loc", gfc_current_ns, &loc_call->symtree, false);
+ loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ loc_call->symtree->n.sym->attr.intrinsic = 1;
+ loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
+ gfc_commit_symbol (loc_call->symtree->n.sym);
+ loc_call->ts.type = BT_INTEGER;
+ loc_call->ts.kind = gfc_index_integer_kind;
+ loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
+ loc_call->value.function.actual = gfc_get_actual_arglist ();
+ loc_call->value.function.actual->expr = sym_expr;
+ return loc_call;
+}
+
/* Resolve a SELECT TYPE statement. */
static void
int charlen = 0;
int rank = 0;
gfc_ref* ref = NULL;
+ gfc_expr *selector_expr = NULL;
ns = code->ext.block.ns;
gfc_resolve (ns);
{
c = body->ext.block.case_list;
+ if (!error)
+ {
+ /* Check for repeated cases. */
+ for (tail = code->block; tail; tail = tail->block)
+ {
+ gfc_case *d = tail->ext.block.case_list;
+ if (tail == body)
+ break;
+
+ if (c->ts.type == d->ts.type
+ && ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived && d->ts.u.derived
+ && !strcmp (c->ts.u.derived->name,
+ d->ts.u.derived->name))
+ || c->ts.type == BT_UNKNOWN
+ || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.kind == d->ts.kind)))
+ {
+ gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
+ &c->where, &d->where);
+ return;
+ }
+ }
+ }
+
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
&& !selector_type->attr.unlimited_polymorphic
}
/* Check F03:C814. */
- if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
+ if (c->ts.type == BT_CHARACTER
+ && (c->ts.u.cl->length != NULL || c->ts.deferred))
{
gfc_error ("The type-spec at %L shall specify that each length "
"type parameter is assumed", &c->where);
else
ns->code->next = new_st;
code = new_st;
- code->op = EXEC_SELECT;
+ code->op = EXEC_SELECT_TYPE;
+ /* Use the intrinsic LOC function to generate an integer expression
+ for the vtable of the selector. Note that the rank of the selector
+ expression has to be set to zero. */
gfc_add_vptr_component (code->expr1);
- gfc_add_hash_component (code->expr1);
+ code->expr1->rank = 0;
+ code->expr1 = build_loc_call (code->expr1);
+ selector_expr = code->expr1->value.function.actual->expr;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
+ gfc_symbol *vtab;
+ gfc_expr *e;
c = body->ext.block.case_list;
- if (c->ts.type == BT_DERIVED)
- c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
- c->ts.u.derived->hash_value);
- else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
+ /* Generate an index integer expression for address of the
+ TYPE/CLASS vtable and store it in c->low. The hash expression
+ is stored in c->high and is used to resolve intrinsic cases. */
+ if (c->ts.type != BT_UNKNOWN)
{
- gfc_symbol *ivtab;
- gfc_expr *e;
+ if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ {
+ vtab = gfc_find_derived_vtab (c->ts.u.derived);
+ gcc_assert (vtab);
+ c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c->ts.u.derived->hash_value);
+ }
+ else
+ {
+ vtab = gfc_find_vtab (&c->ts);
+ gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
+ e = CLASS_DATA (vtab)->initializer;
+ c->high = gfc_copy_expr (e);
+ }
- ivtab = gfc_find_vtab (&c->ts);
- gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
- e = CLASS_DATA (ivtab)->initializer;
- c->low = c->high = gfc_copy_expr (e);
+ e = gfc_lval_expr_from_sym (vtab);
+ c->low = build_loc_call (e);
}
-
- else if (c->ts.type == BT_UNKNOWN)
+ else
continue;
/* Associate temporary to selector. This should only be done
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
- st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
- st->n.sym->assoc->target->where = code->expr1->where;
+ st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
+ st->n.sym->assoc->target->where = selector_expr->where;
if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
{
gfc_add_data_component (st->n.sym->assoc->target);
new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
/* Set up arguments. */
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
- new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
+ new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
new_st->expr1->value.function.actual->expr->where = code->loc;
gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
if (ref)
free (ref);
-
- resolve_select (code, true);
}
}
+/* Return the backend_decl for the vtable of an arbitrary typespec
+ and the vtable symbol. */
+
+tree
+gfc_get_vtable_decl (gfc_typespec *ts, gfc_symbol **vtab)
+{
+ gfc_symbol *vtable = gfc_find_vtab (ts);
+ gcc_assert (vtable != NULL);
+ if (vtab != NULL)
+ *vtab = vtable;
+ if (vtable->backend_decl == NULL_TREE)
+ return gfc_get_symbol_decl (vtable);
+ else
+ return vtable->backend_decl;
+}
+
+
+ /* Translate an assignment to a CLASS object
+ (pointer or ordinary assignment). */
+
+
/* End of prototype trans-class.c */
}
+/* Deal with the particular case of SELECT_TYPE, where the vtable
+ addresses are used for the selection. Since these are not sorted,
+ the selection has to be made by a series of if statements. */
+
+static tree
+gfc_trans_select_type_cases (gfc_code * code)
+{
+ gfc_code *c;
+ gfc_case *cp;
+ tree tmp;
+ tree cond;
+ tree low;
+ tree high;
+ gfc_se se;
+ gfc_se cse;
+ stmtblock_t block;
+ stmtblock_t body;
+ bool def = false;
+ gfc_expr *e;
+ gfc_start_block (&block);
+
+ /* Calculate the switch expression. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, code->expr1);
+ gfc_add_block_to_block (&block, &se.pre);
+
+ /* Generate an expression for the selector hash value, for
+ use to resolve character cases. */
+ e = gfc_copy_expr (code->expr1->value.function.actual->expr);
+ gfc_add_hash_component (e);
+
+ TREE_USED (code->exit_label) = 0;
+
+repeat:
+ for (c = code->block; c; c = c->block)
+ {
+ cp = c->ext.block.case_list;
+
+ /* Assume it's the default case. */
+ low = NULL_TREE;
+ high = NULL_TREE;
+ tmp = NULL_TREE;
+
+ /* Put the default case at the end. */
+ if ((!def && !cp->low) || (def && cp->low))
+ continue;
+
+ if (cp->low && (cp->ts.type == BT_CLASS
+ || cp->ts.type == BT_DERIVED))
+ {
+ gfc_init_se (&cse, NULL);
+ gfc_conv_expr_val (&cse, cp->low);
+ gfc_add_block_to_block (&block, &cse.pre);
+ low = cse.expr;
+ }
+ else if (cp->ts.type != BT_UNKNOWN)
+ {
+ gcc_assert (cp->high);
+ gfc_init_se (&cse, NULL);
+ gfc_conv_expr_val (&cse, cp->high);
+ gfc_add_block_to_block (&block, &cse.pre);
+ high = cse.expr;
+ }
+
+ gfc_init_block (&body);
+
+ /* Add the statements for this case. */
+ tmp = gfc_trans_code (c->next);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Break to the end of the SELECT TYPE construct. The default
+ case just falls through. */
+ if (!def)
+ {
+ TREE_USED (code->exit_label) = 1;
+ tmp = build1_v (GOTO_EXPR, code->exit_label);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ tmp = gfc_finish_block (&body);
+
+ if (low != NULL_TREE)
+ {
+ /* Compare vtable pointers. */
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ TREE_TYPE (se.expr), se.expr, low);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp,
+ build_empty_stmt (input_location));
+ }
+ else if (high != NULL_TREE)
+ {
+ /* Compare hash values for character cases. */
+ gfc_init_se (&cse, NULL);
+ gfc_conv_expr_val (&cse, e);
+ gfc_add_block_to_block (&block, &cse.pre);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ TREE_TYPE (se.expr), high, cse.expr);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp,
+ build_empty_stmt (input_location));
+ }
+
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ if (!def)
+ {
+ def = true;
+ goto repeat;
+ }
+
+ gfc_free_expr (e);
+
+ return gfc_finish_block (&block);
+}
+
+
/* Translate the SELECT CASE construct for INTEGER case expressions,
without killing all potential optimizations. The problem is that
Fortran allows unbounded cases, but the back-end does not, so we
return gfc_finish_block (&block);
}
+tree
+gfc_trans_select_type (gfc_code * code)
+{
+ stmtblock_t block;
+ tree body;
+ tree exit_label;
+
+ gcc_assert (code && code->expr1);
+ gfc_init_block (&block);
+
+ /* Build the exit label and hang it in. */
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ code->exit_label = exit_label;
+
+ /* Empty SELECT constructs are legal. */
+ if (code->block == NULL)
+ body = build_empty_stmt (input_location);
+ else
+ body = gfc_trans_select_type_cases (code);
+
+ /* Build everything together. */
+ gfc_add_expr_to_block (&block, body);
+
+ if (TREE_USED (exit_label))
+ gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
+
+ return gfc_finish_block (&block);
+}
+
/* Traversal function to substitute a replacement symtree if the symbol
in the expression is the same as that passed. f == 2 signals that
tree gfc_trans_do_concurrent (gfc_code *);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
+tree gfc_trans_select_type (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
break;
case EXEC_SELECT_TYPE:
- /* Do nothing. SELECT TYPE statements should be transformed into
- an ordinary SELECT CASE at resolution stage.
- TODO: Add an error message here once this is done. */
- res = NULL_TREE;
+ res = gfc_trans_select_type (code);
break;
case EXEC_FLUSH:
+2016-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/69834
+ * gfortran.dg/select_type_1.f03: Change error for overlapping
+ TYPE IS cases.
+ * gfortran.dg/select_type_36.f03: New test.
+
2016-10-22 Eric Botcazou <ebotcazou@adacore.com>
* gcc.dg/tree-ssa/pr71347.c: Remove XFAIL on SPARC.
label: select type (a)
type is (t1) label
print *,"a is TYPE(t1)"
- type is (t2) ! { dg-error "overlaps with CASE label" }
+ type is (t2) ! { dg-error "overlaps with TYPE IS" }
print *,"a is TYPE(t2)"
- type is (t2) ! { dg-error "overlaps with CASE label" }
+ type is (t2) ! { dg-error "overlaps with TYPE IS" }
print *,"a is still TYPE(t2)"
class is (t1) labe ! { dg-error "Expected block name" }
print *,"a is CLASS(t1)"
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR69834 in which the two derived types below
+! had the same hash value and so generated an error in the resolution
+! of SELECT TYPE.
+!
+! Reported by James van Buskirk on clf:
+! https://groups.google.com/forum/#!topic/comp.lang.fortran/0bm3E5xJpkM
+!
+module types
+ implicit none
+ type CS5SS
+ integer x
+ real y
+ end type CS5SS
+ type SQS3C
+ logical u
+ character(7) v
+ end type SQS3C
+ contains
+ subroutine sub(x, switch)
+ class(*), allocatable :: x
+ integer :: switch
+ select type(x)
+ type is(CS5SS)
+ if (switch .ne. 1) call abort
+ type is(SQS3C)
+ if (switch .ne. 2) call abort
+ class default
+ call abort
+ end select
+ end subroutine sub
+end module types
+
+program test
+ use types
+ implicit none
+ class(*), allocatable :: u1, u2
+
+ allocate(u1,source = CS5SS(2,1.414))
+ allocate(u2,source = SQS3C(.TRUE.,'Message'))
+ call sub(u1, 1)
+ call sub(u2, 2)
+end program test
projects / gcc.git / commitdiff