From b0cb70c025ac91a7399318963114adb1848a50a6 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 23 Oct 2016 18:09:14 +0000 Subject: [PATCH] 2016-10-23 Paul Thomas 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-23 Paul Thomas PR fortran/69834 * gfortran.dg/select_type_1.f03: Change error for overlapping TYPE IS cases. * gfortran.dg/select_type_36.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@241450 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 22 ++++ gcc/fortran/class.c | 24 ++++- gcc/fortran/dump-parse-tree.c | 18 ++-- gcc/fortran/resolve.c | 100 ++++++++++++++---- gcc/fortran/trans-expr.c | 21 ++++ gcc/fortran/trans-stmt.c | 148 +++++++++++++++++++++++++++ gcc/fortran/trans-stmt.h | 1 + gcc/fortran/trans.c | 5 +- gcc/testsuite/ChangeLog | 7 ++ gcc/testsuite/gfortran.dg/select_type_1.f03 | 4 +- gcc/testsuite/gfortran.dg/select_type_36.f03 | 44 ++++++++ 11 files changed, 360 insertions(+), 34 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/select_type_36.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f5843bf7258..d057d0fade0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2016-10-23 Paul Thomas + + 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 PR fortran/78021 diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index e110f2cf9f4..6ac543cbd61 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2190,6 +2190,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) 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) @@ -2200,6 +2201,20 @@ gfc_find_derived_vtab (gfc_symbol *derived) 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]; @@ -2208,7 +2223,14 @@ gfc_find_derived_vtab (gfc_symbol *derived) 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) diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 8c240742150..33a28424244 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -227,7 +227,7 @@ show_array_ref (gfc_array_ref * ar) 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]); @@ -429,7 +429,7 @@ show_expr (gfc_expr *p) break; case BT_CHARACTER: - show_char_const (p->value.character.string, + show_char_const (p->value.character.string, p->value.character.length); break; @@ -982,7 +982,7 @@ show_common (gfc_symtree *st) fputs (", ", dumpfile); } fputc ('\n', dumpfile); -} +} /* Worker function to display the symbol tree. */ @@ -1238,7 +1238,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) for (list = omp_clauses->tile_list; list; list = list->next) { show_expr (list->expr); - if (list->next) + if (list->next) fputs (", ", dumpfile); } fputc (')', dumpfile); @@ -1250,7 +1250,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) for (list = omp_clauses->wait_list; list; list = list->next) { show_expr (list->expr); - if (list->next) + if (list->next) fputs (", ", dumpfile); } fputc (')', dumpfile); @@ -1815,8 +1815,12 @@ show_code_node (int level, gfc_code *c) 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); @@ -2628,7 +2632,7 @@ show_namespace (gfc_namespace *ns) fputs ("User operators:\n", dumpfile); gfc_traverse_user_op (ns, show_uop); } - + for (eq = ns->equiv; eq; eq = eq->next) show_equiv (eq); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6dae6fbb771..2a64ab7adf1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8369,6 +8369,25 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, } +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 @@ -8385,6 +8404,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) int charlen = 0; int rank = 0; gfc_ref* ref = NULL; + gfc_expr *selector_expr = NULL; ns = code->ext.block.ns; gfc_resolve (ns); @@ -8433,6 +8453,31 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_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 @@ -8460,7 +8505,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) } /* 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); @@ -8549,31 +8595,47 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 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 @@ -8599,8 +8661,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 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); @@ -8720,7 +8782,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 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); @@ -8748,8 +8810,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) if (ref) free (ref); - - resolve_select (code, true); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index fc03a23d9ed..f1849f5e091 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1508,6 +1508,27 @@ gfc_trans_class_init_assign (gfc_code *code) } +/* 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 */ diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 2cf41b98577..c52066ffd20 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -2331,6 +2331,125 @@ gfc_trans_do_while (gfc_code * code) } +/* 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 @@ -2972,6 +3091,35 @@ gfc_trans_select (gfc_code * code) 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 diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index e4d4a67aa5d..0b4f71357f6 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -52,6 +52,7 @@ tree gfc_trans_do (gfc_code *, tree); 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); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index fba0d9a5d49..df77fc9b540 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1820,10 +1820,7 @@ trans_code (gfc_code * code, tree cond) 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: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ca08945d2eb..8178f8dc727 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2016-10-23 Paul Thomas + + 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 * gcc.dg/tree-ssa/pr71347.c: Remove XFAIL on SPARC. diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03 index af0db3c84e3..b92366db704 100644 --- a/gcc/testsuite/gfortran.dg/select_type_1.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_1.f03 @@ -60,9 +60,9 @@ 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)" diff --git a/gcc/testsuite/gfortran.dg/select_type_36.f03 b/gcc/testsuite/gfortran.dg/select_type_36.f03 new file mode 100644 index 00000000000..a667ece3326 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_36.f03 @@ -0,0 +1,44 @@ +! { 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 -- 2.11.4.GIT