diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 24 | ||||
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 100 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 148 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 5 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/select_type_1.f03 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/select_type_36.f03 | 44 |
11 files changed, 360 insertions, 34 deletions
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 <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 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 <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. 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 |