diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 98 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 20 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 72 | ||||
| -rw-r--r-- | gcc/fortran/frontend-passes.c | 19 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 25 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 76 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 10 |
10 files changed, 276 insertions, 73 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9913c97de04..973f615b6b4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,89 @@ +2016-09-19 Fritz Reese <fritzoreese@gmail.com> + + PR fortran/77584 + * decl.c (match_record_decl, gfc_match_decl_type_spec): Fixes to + handling of structure/record from declaration-type-spec. + +2016_09_17 Louis Krupp <louis.krupp@zoho.com> + + PR fortran/68078 + * resolve.c (resolve_allocate_expr): Check that derived type + pointer, object or array has been successfully allocated before + initializing. + +2016-09-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77612 + * decl.c (char_len_param_value): Check parent namespace for + seen_implicit_none. + +2016-09-15 Louis Krupp <louis.krupp@zoho.com> + + PR fortran/69963 + * parse.c (reject_statement): Clear charlen pointers in implicit + character typespecs before those charlen structures are freed. + +2016-09-14 Bernd Edlinger <bernd.edlinger@hotmail.de> + + * simplify.c (gfc_simplify_repeat): Fix a misplaced closing ')'. + +2016-09-13 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77420 + * module.c (load_equiv): Revert revision 240063. + +2016-09-10 Paul Thomas <pault@gcc.gnu.org> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77532 + * interface.c (check_dtio_arg_TKR_intent): Return after error. + (check_dtio_interface1): Remove asserts, test for NULL and return + if found. + +2016-09-09 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77420 + * module.c (load_equiv): If the current namespace has a list of + equivalence statements, initialize duplicate to false and then + look for duplicates; otherwise, initialize it to true. + +2016-09-09 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77506 + * array.c (gfc_match_array_constructor): CHARACTER(len=*) cannot + appear in an array constructor. + +2016-09-09 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77507 + * intrinsic.c (add_functions): Use correct keyword. + +2016-09-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/69514 + * array.c (gfc_match_array_constructor): If type-spec is present, + walk the array constructor performing possible conversions for + numeric types. + +2016-09-08 Jakub Jelinek <jakub@redhat.com> + + PR fortran/77500 + * trans-openmp.c (gfc_trans_omp_atomic): For atomic write or + swap, don't try to look through GFC_ISYM_CONVERSION. In other cases, + check that value.function.isym is non-NULL before dereferencing it. + +2016-09-04 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77391 + * resolve.c (deferred_requirements): New function to check F2008:C402. + (resolve_fl_variable,resolve_fl_parameter): Use it. + +2016-09-04 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/77460 + * simplify.c (simplify_transformation_to_scalar): On error, result + may be NULL, simply return. + 2016-08-31 Jakub Jelinek <jakub@redhat.com> PR fortran/77352 @@ -83,13 +169,13 @@ * interface.c (compare_components, gfc_compare_derived_types): Use new functions. -2016-08-27 Steven G. Kargl <kargl@gcc.gnu.org> +2016-08-27 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/77380 * dependency.c (gfc_check_dependency): Do not assert with -fcoarray=lib. -2016-08-27 Steven G. Kargl <kargl@gcc.gnu.org> +2016-08-27 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/77372 simplify.c (simplify_ieee_selected_real_kind): Check for NULL pointers. @@ -259,7 +345,7 @@ * intrinsic.c (add_function, add_subroutine): New B/I/J/K intrinsic variants. -2016-07-30 Steven G. Kargl <kargl@gcc.gnu.org> +2016-07-30 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/41922 * target-memory.c (expr_to_char): Pass in locus and use it in error @@ -383,7 +469,7 @@ a static one. 2016-07-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> - Marco Restelli <mrestelli@gmail.com> + Marco Restelli <mrestelli@gmail.com> PR fortran/62125 * symbol.c (select_type_insert_tmp): Recursively call self to take care @@ -938,7 +1024,7 @@ * dump-parse-tree.c (show_code_node): Print association list of a block if present. Handle EXEC_END_BLOCK. -2016-02-28 Harald Anlauf <anlauf@gmx.de> +2016-02-28 Harald Anlauf <anlauf@gmx.de> Jerry DeLisle <jvdelisle@gcc.gnu.org> PR fortran/56007 @@ -1124,7 +1210,7 @@ * frontend-passes.c (matmul_lhs_realloc): Add forgotten break statement. -2016-01-24 Dominique d'Humieres <dominiq@lps.ens.fr> +2016-01-24 Dominique d'Humieres <dominiq@lps.ens.fr> PR fortran/68283 * primary.c (gfc_variable_attr): revert revision r221955, diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 03c8b17178c..14e20a36de5 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1089,6 +1089,7 @@ match_array_cons_element (gfc_constructor_base *result) match gfc_match_array_constructor (gfc_expr **result) { + gfc_constructor *c; gfc_constructor_base head, new_cons; gfc_undo_change_set changed_syms; gfc_expr *expr; @@ -1141,6 +1142,15 @@ gfc_match_array_constructor (gfc_expr **result) gfc_restore_last_undo_checkpoint (); goto cleanup; } + + if (ts.type == BT_CHARACTER + && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec) + { + gfc_error ("Type-spec at %L cannot contain an asterisk for a " + "type parameter", &where); + gfc_restore_last_undo_checkpoint (); + goto cleanup; + } } } else if (m == MATCH_ERROR) @@ -1194,8 +1204,6 @@ done: be converted. See PR fortran/67803. */ if (ts.type == BT_CHARACTER) { - gfc_constructor *c; - c = gfc_constructor_first (head); for (; c; c = gfc_constructor_next (c)) { @@ -1218,6 +1226,14 @@ done: } } } + + /* Walk the constructor and ensure type conversion for numeric types. */ + if (gfc_numeric_ts (&ts)) + { + c = gfc_constructor_first (head); + for (; c; c = gfc_constructor_next (c)) + gfc_convert_type (c->expr, &ts, 1); + } } else expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index b5242394cef..d9fae5753d0 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -920,9 +920,10 @@ char_len_param_value (gfc_expr **expr, bool *deferred) t = gfc_reduce_init_expr (e); - if (!t && (e->ts.type == BT_UNKNOWN - && e->symtree->n.sym->attr.untyped == 1 - && e->symtree->n.sym->ns->seen_implicit_none == 1)) + if (!t && e->ts.type == BT_UNKNOWN + && e->symtree->n.sym->attr.untyped == 1 + && (e->symtree->n.sym->ns->seen_implicit_none == 1 + || e->symtree->n.sym->ns->parent->seen_implicit_none == 1)) { gfc_free_expr (e); goto syntax; @@ -2908,12 +2909,14 @@ done: /* Matches a RECORD declaration. */ static match -match_record_decl (const char *name) +match_record_decl (char *name) { locus old_loc; old_loc = gfc_current_locus; + match m; - if (gfc_match (" record") == MATCH_YES) + m = gfc_match (" record /"); + if (m == MATCH_YES) { if (!gfc_option.flag_dec_structure) { @@ -2922,17 +2925,20 @@ match_record_decl (const char *name) "-fdec-structure"); return MATCH_ERROR; } - if (gfc_match (" /%n/", name) != MATCH_YES) - { - gfc_error ("Structure name expected after RECORD at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - return MATCH_YES; + m = gfc_match (" %n/", name); + if (m == MATCH_YES) + return MATCH_YES; } - gfc_current_locus = old_loc; + gfc_current_locus = old_loc; + if (gfc_option.flag_dec_structure + && (gfc_match (" record% ") == MATCH_YES + || gfc_match (" record%t") == MATCH_YES)) + gfc_error ("Structure name expected after RECORD at %C"); + if (m == MATCH_NO) return MATCH_NO; + + return MATCH_ERROR; } /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts @@ -3127,26 +3133,26 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) else { /* Match nested STRUCTURE declarations; only valid within another - structure declaration. */ - m = gfc_match (" structure"); - if (m == MATCH_ERROR) - return MATCH_ERROR; - else if (m == MATCH_YES) - { - if ( gfc_current_state () != COMP_STRUCTURE - && gfc_current_state () != COMP_MAP) - return MATCH_ERROR; - - m = gfc_match_structure_decl (); - if (m == MATCH_YES) - { - /* gfc_new_block is updated by match_structure_decl. */ - ts->type = BT_DERIVED; - ts->u.derived = gfc_new_block; - return MATCH_YES; - } - return MATCH_ERROR; - } + structure declaration. */ + if (gfc_option.flag_dec_structure + && (gfc_current_state () == COMP_STRUCTURE + || gfc_current_state () == COMP_MAP)) + { + m = gfc_match (" structure"); + if (m == MATCH_YES) + { + m = gfc_match_structure_decl (); + if (m == MATCH_YES) + { + /* gfc_new_block is updated by match_structure_decl. */ + ts->type = BT_DERIVED; + ts->u.derived = gfc_new_block; + return MATCH_YES; + } + } + if (m == MATCH_ERROR) + return MATCH_ERROR; + } /* Match CLASS declarations. */ m = gfc_match (" class ( * )"); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index c138f4d7c77..cd109791075 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -164,19 +164,34 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, gfc_expr *expr1, *expr2; gfc_code *co = *c; gfc_expr *n; + gfc_ref *ref; + bool found_substr; if (co->op != EXEC_ASSIGN) return 0; expr1 = co->expr1; if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0 - || !expr1->symtree->n.sym->attr.allocatable) + || !gfc_expr_attr(expr1).allocatable + || !expr1->ts.deferred) return 0; expr2 = gfc_discard_nops (co->expr2); if (expr2->expr_type != EXPR_VARIABLE) return 0; + found_substr = false; + for (ref = expr2->ref; ref; ref = ref->next) + { + if (ref->type == REF_SUBSTRING) + { + found_substr = true; + break; + } + } + if (!found_substr) + return 0; + if (!gfc_check_dependency (expr1, expr2, true)) return 0; @@ -190,7 +205,7 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, current_code = c; inserted_block = NULL; changed_statement = NULL; - n = create_var (expr2, "trim"); + n = create_var (expr2, "realloc_string"); co->expr2 = n; return 0; } diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index fece3168dc7..45a9afe5685 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -4559,8 +4559,11 @@ check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, int kind, int rank, sym_intent intent) { if (fsym->ts.type != type) - gfc_error ("DTIO dummy argument at %L must be of type %s", - &fsym->declared_at, gfc_basic_typename (type)); + { + gfc_error ("DTIO dummy argument at %L must be of type %s", + &fsym->declared_at, gfc_basic_typename (type)); + return; + } if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED && fsym->ts.kind != kind) @@ -4606,20 +4609,23 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, { /* Typebound DTIO binding. */ tb_io_proc = tb_io_st->n.tb; - gcc_assert (tb_io_proc != NULL); + if (tb_io_proc == NULL) + return; + gcc_assert (tb_io_proc->is_generic); gcc_assert (tb_io_proc->u.generic->next == NULL); specific_proc = tb_io_proc->u.generic->specific; - gcc_assert (!specific_proc->is_generic); + if (specific_proc == NULL || specific_proc->is_generic) + return; dtio_sub = specific_proc->u.specific->n.sym; } else { generic_proc = tb_io_st->n.sym; - gcc_assert (generic_proc); - gcc_assert (generic_proc->generic); + if (generic_proc == NULL || generic_proc->generic == NULL) + return; for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next) { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index ca28eac8cf7..cad54b8100b 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1239,7 +1239,8 @@ add_functions (void) *z = "z", *ln = "len", *ut = "unit", *han = "handler", *num = "number", *tm = "time", *nm = "name", *md = "mode", *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command", - *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed"; + *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed", + *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2"; int di, dr, dd, dl, dc, dz, ii; @@ -2914,8 +2915,8 @@ add_functions (void) /* The following functions are part of ISO_C_BINDING. */ add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL, - "C_PTR_1", BT_VOID, 0, REQUIRED, - "C_PTR_2", BT_VOID, 0, OPTIONAL); + c_ptr_1, BT_VOID, 0, REQUIRED, + c_ptr_2, BT_VOID, 0, OPTIONAL); make_from_module(); add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO, diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 86f2c427368..d78a2c07eec 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2399,6 +2399,29 @@ accept_statement (gfc_statement st) } +/* Clear default character types with charlen pointers that are about + to become invalid. */ + +static void +clear_default_charlen (gfc_namespace *ns, const gfc_charlen *cl, + const gfc_charlen *end) +{ + gfc_typespec *ts; + + for (ts = &ns->default_type[0]; ts < &ns->default_type[GFC_LETTERS]; ts++) + if (ts->type == BT_CHARACTER) + { + const gfc_charlen *cl2; + for (cl2 = cl; cl2 != end; cl2 = cl2->next) + if (ts->u.cl == cl2) + { + ts->u.cl = NULL; + ts->type = BT_UNKNOWN; + break; + } + } +} + /* Undo anything tentative that has been built for the current statement. */ @@ -2406,6 +2429,8 @@ static void reject_statement (void) { /* Revert to the previous charlen chain. */ + clear_default_charlen (gfc_current_ns, + gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); gfc_current_ns->cl_list = gfc_current_ns->old_cl_list; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 39c1330c455..037c2fe74e0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6928,6 +6928,35 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) return true; } +static void +cond_init (gfc_code *code, gfc_expr *e, int pointer, gfc_expr *init_e) +{ + gfc_code *block; + gfc_expr *cond; + gfc_code *init_st; + gfc_expr *e_to_init = gfc_expr_to_initialize (e); + + cond = pointer + ? gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ASSOCIATED, + "associated", code->loc, 2, gfc_copy_expr (e_to_init), NULL) + : gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ALLOCATED, + "allocated", code->loc, 1, gfc_copy_expr (e_to_init)); + + init_st = gfc_get_code (EXEC_INIT_ASSIGN); + init_st->loc = code->loc; + init_st->expr1 = e_to_init; + init_st->expr2 = init_e; + + block = gfc_get_code (EXEC_IF); + block->loc = code->loc; + block->block = gfc_get_code (EXEC_IF); + block->block->loc = code->loc; + block->block->expr1 = cond; + block->block->next = init_st; + block->next = code->next; + + code->next = block; +} /* Resolve the expression in an ALLOCATE statement, doing the additional checks to see whether the expression is OK or not. The expression must @@ -7193,14 +7222,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) ts = ts.u.derived->components->ts; if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts))) - { - gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN); - init_st->loc = code->loc; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } + cond_init (code, e, pointer, init_e); } else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED) { @@ -11488,6 +11510,27 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) } +/* F2008, C402 (R401): A colon shall not be used as a type-param-value + except in the declaration of an entity or component that has the POINTER + or ALLOCATABLE attribute. */ + +static bool +deferred_requirements (gfc_symbol *sym) +{ + if (sym->ts.deferred + && !(sym->attr.pointer + || sym->attr.allocatable + || sym->attr.omp_udr_artificial_var)) + { + gfc_error ("Entity %qs at %L has a deferred type parameter and " + "requires either the POINTER or ALLOCATABLE attribute", + sym->name, &sym->declared_at); + return false; + } + return true; +} + + /* Resolve symbols with flavor variable. */ static bool @@ -11527,17 +11570,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) } /* Constraints on deferred type parameter. */ - if (sym->ts.deferred - && !(sym->attr.pointer - || sym->attr.allocatable - || sym->attr.omp_udr_artificial_var)) - { - gfc_error ("Entity %qs at %L has a deferred type parameter and " - "requires either the pointer or allocatable attribute", - sym->name, &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } + if (!deferred_requirements (sym)) + return false; if (sym->ts.type == BT_CHARACTER) { @@ -13682,6 +13716,10 @@ resolve_fl_parameter (gfc_symbol *sym) return false; } + /* Constraints on deferred type parameter. */ + if (!deferred_requirements (sym)) + return false; + /* Make sure a parameter that has been implicitly typed still matches the implicit type, since PARAMETER statements can precede IMPLICIT statements. */ diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 6e6566d9245..ad547a15e47 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -489,6 +489,8 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * } result = op (result, gfc_copy_expr (a)); + if (!result) + return result; } return result; @@ -5125,7 +5127,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (len || (e->ts.u.cl->length && - mpz_sgn (e->ts.u.cl->length->value.integer)) != 0) + mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) { const char *res = gfc_extract_int (n, &ncop); gcc_assert (res == NULL); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 2d720c80a2a..4f1a1beb8cc 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -2803,7 +2803,11 @@ gfc_trans_omp_atomic (gfc_code *code) gfc_start_block (&block); expr2 = code->expr2; - if (expr2->expr_type == EXPR_FUNCTION + if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) + != GFC_OMP_ATOMIC_WRITE) + && (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP) == 0 + && expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; @@ -2842,6 +2846,7 @@ gfc_trans_omp_atomic (gfc_code *code) var = code->expr1->symtree->n.sym; expr2 = code->expr2; if (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; } @@ -2899,6 +2904,7 @@ gfc_trans_omp_atomic (gfc_code *code) } e = expr2->value.op.op1; if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym && e->value.function.isym->id == GFC_ISYM_CONVERSION) e = e->value.function.actual->expr; if (e->expr_type == EXPR_VARIABLE @@ -2912,6 +2918,7 @@ gfc_trans_omp_atomic (gfc_code *code) { e = expr2->value.op.op2; if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym && e->value.function.isym->id == GFC_ISYM_CONVERSION) e = e->value.function.actual->expr; gcc_assert (e->expr_type == EXPR_VARIABLE @@ -3026,6 +3033,7 @@ gfc_trans_omp_atomic (gfc_code *code) code = code->next; expr2 = code->expr2; if (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; |