diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 359 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 62 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 40 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/data.c | 24 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 163 | ||||
| -rw-r--r-- | gcc/fortran/error.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 54 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.info | 2 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 148 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 39 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 11 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 16 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 52 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 132 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 128 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 31 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 14 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 14 |
24 files changed, 1113 insertions, 210 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e93be2cb8c..c61d9f03be 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,358 @@ +2015-12-04 Release Manager + + * GCC 5.3.0 released. + +2015-11-27 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/68218 + * trans-array.c (gfc_array_init_size): Add gfc_evaluate_now() when + array spec in allocate is a function call. + +2015-11-24 Paul Thomas <pault@gcc.gnu.org> + + Backport from trunk. + PR fortran/68196 + * class.c (has_finalizer_component): Prevent infinite recursion + through this function if the derived type and that of its + component are the same. + * trans-types.c (gfc_get_derived_type): Do the same for proc + pointers by ignoring the explicit interface for the component. + + PR fortran/66465 + * check.c (same_type_check): If either of the expressions is + BT_PROCEDURE, use the typespec from the symbol, rather than the + expression. + +2015-11-18 Dominique d'Humieres <dominiq@lps.ens.fr> + + PR fortran/65751 + * expr.c (gfc_check_pointer_assign): Fix error message. + +2015-11-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/58027 + PR fortran/60993 + * expr.c (gfc_check_init_expr): Prevent a redundant check when a + __convert_* function was inserted into an array constructor. + (gfc_check_assign_symbol): Check for an initialization expression + when a __convert_* was inserted. + +2015-11-14 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67803 + * array.c (gfc_match_array_constructor): If array constructor included + a CHARACTER typespec, check array elements for compatible type. + +2015-11-13 Steven G. Kargl <kargl@gccc.gnu.org> + + PR fortran/68319 + * decl.c (gfc_match_data, gfc_match_entry): Enforce F2008:C1206. + * io.c (gfc_match_format): Ditto. + * match.c (gfc_match_st_function): Ditto. + +2015-11-12 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68318 + * decl.c (get_proc_name): Increment reference count for ENTRY. + While here, fix comment and use postfix ++ for consistency. + +2015-11-08 Steven g. Kargl <kargl@gcc.gnu.org> + + PR fortran/68053 + * decl.c (add_init_expr_to_sym): Try to reduce initialization expression + before testing for a constant value. + +2015-11-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68224 + * array.c (match_array_element_spec): Check of invalid NULL(). + While here, fix nearby comments. + +2015-11-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68153 + * check.c (gfc_check_reshape): Improve check for valid SHAPE argument. + +2015-11-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68151 + * match.c (match_case_selector): Check for invalid type. + +2015-01-25 Paul Thomas <pault@gcc.gnu.org> + + Backported from trunk. + PR fortran/67171 + * trans-array.c (structure_alloc_comps): On deallocation of + class components, reset the vptr to the declared type vtable + and reset the _len field of unlimited polymorphic components. + *trans-expr.c (gfc_find_and_cut_at_last_class_ref): Bail out on + allocatable component references to the right of part reference + with non-zero rank and return NULL. + (gfc_reset_vptr): Simplify this function by using the function + gfc_get_vptr_from_expr. Return if the vptr is NULL_TREE. + (gfc_reset_len): If gfc_find_and_cut_at_last_class_ref returns + NULL return. + +2015-10-30 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/51993 + * decl.c (gfc_set_constant_character_len): Convert gcc_assert into an + if-statement causing an early return leads to valid error message. + +2015-10-30 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68154 + * decl.c (add_init_expr_to_sym): if the char length in the typespec + is NULL, check for and use a constructor. + +2015-10-30 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/36192 + * interface.c (get_expr_storage_size): Check for INTEGER type before + calling gmp routines. + +2015-10-29 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68055 + * decl.c (gfc_match_decl_type_spec): Check for valid kind in old-style + declarations. + +2015-10-29 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68054 + * decl.c (match_attr_spec): PROTECTED can only be a module. + +2015-10-29 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67939 + * data.c (create_character_initializer): Deal with zero length string. + +2015-10-29 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67885 + * trans-decl.c (generate_local_decl): Mark PARAMETER entities in + BLOCK construct. + +2015-10-29 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67805 + PR fortran/68108 + * array.c (gfc_match_array_constructor): Check for error from type + spec matching. + * decl.c (char_len_param_value): Check for valid of charlen parameter. + Check for REF_ARRAY. Reap dead code dating to 2008. + match.c (gfc_match_type_spec): Special case the keyword use in REAL. + +2015-10-26 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/67177 + PR fortran/67977 + Backport from mainline r228940: + * primary.c (match_substring): Add an argument 'deferred' to + flag that a substring reference with null start and end should + not be optimized away for deferred length strings. + (match_string_constant, gfc_match_rvalue): Set the argument. + * trans-expr.c (alloc_scalar_allocatable_for_assignment): If + there is a substring reference return. + * trans-intrinsic.c (conv_intrinsic_move_alloc): For deferred + characters, assign the 'from' string length to the 'to' string + length. If the 'from' expression is deferred, set its string + length to zero. If the 'to' expression has allocatable + components, deallocate them. + +2015-10-22 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/58754 + * trans-stmt.c (gfc_trans_allocate): Do not use the scalar + character assignment if the allocate expression is an array + descriptor. + +2015-10-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67900 + * resolve.c (gfc_verify_binding_labels): Check for NULL pointer. + +2015-10-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/68019 + * decl.c (add_init_expr_to_sym): Remove an assert() to allow an error + message to be issued. + +2015-10-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67987 + * decl.c (char_len_param_value): Unwrap unlong line. If LEN < 0, + force it to zero per the Fortran 90, 95, 2003, and 2008 Standards. + * resolve.c (gfc_resolve_substring_charlen): Unwrap unlong line. + If 'start' is larger than 'end', length of substring is negative, + so explicitly set it to zero. + (resolve_charlen): Remove -Wsurprising warning. Update comment to + reflect that the text is from the F2008 standard. + +2015-10-18 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/66079 + Backport from mainline r224383: + + * trans-expr.c (gfc_conv_procedure_call): Allocatable scalar + function results must be freed and nullified after use. Create + a temporary to hold the result to prevent duplicate calls. + * trans-stmt.c (gfc_trans_allocate): Rename temporary variable + as 'source'. Deallocate allocatable components of non-variable + 'source's. + +2015-10-18 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/67721 + PR fortran/67818 + Backport from mainline r222477: + + 2015-04-27 Andre Vehreschild <vehre@gmx.de> + + PR fortran/59678 + PR fortran/65841 + * trans-array.c (duplicate_allocatable): Fixed deep copy of + allocatable components, which are liable for copy only, when + they are allocated. + (gfc_duplicate_allocatable): Add deep-copy code into if + component allocated block. Needed interface change for that. + (gfc_copy_allocatable_data): Supplying NULL_TREE for code to + add into if-block for checking whether a component was + allocated. + (gfc_duplicate_allocatable_nocopy): Likewise. + (structure_alloc_comps): Likewise. + * trans-array.h: Likewise. + * trans-expr.c (gfc_trans_alloc_subarray_assign): Likewise. + * trans-openmp.c (gfc_walk_alloc_comps): Likewise. + +2015-10-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67802 + * decl.c (add_init_expr_to_sym): Numeric constant for character + length must be an INTEGER. + +2015-10-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67616 + * primary.c (gfc_match_structure_constructor): Use a possibly + host-associated symtree to prevent ICE. + +2015-10-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66979 + * io.c (gfc_resolve_filepos): Check for a UNIT number. Add a nearby + missing 'return false'. + +2015-10-01 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/67721 + * trans-expr.c (gfc_trans_assignment_1): Remove the non-constantness + condition guarding deep copy. + +2015-09-25 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67614 + * resolve.c (gfc_resolve_code): Prevent ICE for invalid EXPR_NULL. + +2015-09-25 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67525 + * parse.c (match_deferred_characteristics): Remove an assert, which + allows an invalid SELECT TYPE selector to be detected. + +2015-09-21 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67615 + * resolve.c (gfc_resolve_code): Check for scalar expression in + arithmetic-if. + +2015-09-10 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/67526 + * expr.c (gfc_check_init_expr): Do not dereference a NULL pointer. + +2015-09-04 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR fortran/67429 + * error.c (gfc_clear_pp_buffer): Reset last_location, otherwise + caret lines might be skipped when actually giving a diagnostic. + +2015-08-07 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/66929 + * trans-array.c (gfc_get_proc_ifc_for_expr): Use esym as procedure + symbol if available. + +2015-08-05 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/64921 + * class.c (generate_finalization_wrapper): Set finalization + procedure symbol's always_explicit attribute. + +2015-08-03 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66942 + * trans-expr.c (gfc_conv_procedure_call): Avoid NULL pointer reference + +2015-07-25 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/64986 + * trans-expr.c (gfc_trans_assignment_1): Put component deallocation + code at the beginning of the block. + +2015-07-21 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/66035 + * trans-expr.c (alloc_scalar_allocatable_for_subcomponent_assignment): + Compute the size to allocate for class and derived type objects + correclty. + (gfc_trans_subcomponent_assign): Only allocate memory for a + component when the object to assign is not an allocatable class + object (the memory is already present for allocatable class objects). + Furthermore use copy_class_to_class for assigning the rhs to the + component (may happen for dummy class objects on the rhs). + +2015-07-17 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com> + + * trans-intrinsic.c (conv_co_collective): Remove redundant address + operator in the generated code. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66724 + PR fortran/66724 + * io.c (is_char_type): Call gfc_resolve_expr (). + (match_open_element, match_dt_element, match_inquire_element): Fix + ASYNCHRONOUS case. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66864 + * simplify.c (gfc_simplify_floor): Set precision of temporary to + that of arg. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66545 + * primary.c (match_sym_complex_part): Do not dereference NULL pointer. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/56520 + * match.c (gfc_match_name): Special case unary minus and plus. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + * io.c (check_char_variable): New function. + (match_open_element, match_close_element, match_file_element, + match_dt_element, match_inquire_element, match_wait_element): Use it. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66725 + * io.c (is_char_type): New function to test for BT_CHARACTER + (gfc_match_open, gfc_match_close, match_dt_element): Use it. + 2015-07-16 Release Manager * GCC 5.2.0 released. @@ -94,7 +449,7 @@ 2015-05-19 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/66052 - * decl.c(gfc_match_protected): Prevent dereference of NULL pointer. + * decl.c(gfc_match_protected): Prevent dereference of NULL pointer. 2015-05-19 Steven G. Kargl <kargl@gcc.gnu.org> @@ -106,7 +461,7 @@ PR fortran/66044 * decl.c(gfc_match_entry): Change a gfc_internal_error() into - a gfc_error() + a gfc_error() 2015-05-19 Steven G. Kargl <kargl@gcc.gnu.org> diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 64d0abf8fa..b672bc37a0 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -146,9 +146,9 @@ matched: } -/* Match an array reference, whether it is the whole array or a - particular elements or a section. If init is set, the reference has - to consist of init expressions. */ +/* Match an array reference, whether it is the whole array or particular + elements or a section. If init is set, the reference has to consist + of init expressions. */ match gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, @@ -416,6 +416,13 @@ match_array_element_spec (gfc_array_spec *as) if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) return AS_UNKNOWN; + if ((*upper)->expr_type == EXPR_FUNCTION && (*upper)->ts.type == BT_UNKNOWN + && (*upper)->symtree && strcmp ((*upper)->symtree->name, "null") == 0) + { + gfc_error ("Expecting a scalar INTEGER expression at %C"); + return AS_UNKNOWN; + } + if (gfc_match_char (':') == MATCH_NO) { *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); @@ -436,13 +443,20 @@ match_array_element_spec (gfc_array_spec *as) if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) return AS_UNKNOWN; + if ((*upper)->expr_type == EXPR_FUNCTION && (*upper)->ts.type == BT_UNKNOWN + && (*upper)->symtree && strcmp ((*upper)->symtree->name, "null") == 0) + { + gfc_error ("Expecting a scalar INTEGER expression at %C"); + return AS_UNKNOWN; + } + return AS_EXPLICIT; } /* Matches an array specification, incidentally figuring out what sort - it is. Match either a normal array specification, or a coarray spec - or both. Optionally allow [:] for coarrays. */ + it is. Match either a normal array specification, or a coarray spec + or both. Optionally allow [:] for coarrays. */ match gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) @@ -1074,7 +1088,8 @@ gfc_match_array_constructor (gfc_expr **result) /* Try to match an optional "type-spec ::" */ gfc_clear_ts (&ts); gfc_new_undo_checkpoint (changed_syms); - if (gfc_match_type_spec (&ts) == MATCH_YES) + m = gfc_match_type_spec (&ts); + if (m == MATCH_YES) { seen_ts = (gfc_match (" ::") == MATCH_YES); @@ -1096,6 +1111,11 @@ gfc_match_array_constructor (gfc_expr **result) } } } + else if (m == MATCH_ERROR) + { + gfc_restore_last_undo_checkpoint (); + goto cleanup; + } if (seen_ts) gfc_drop_last_undo_checkpoint (); @@ -1137,6 +1157,35 @@ done: { expr = gfc_get_array_expr (ts.type, ts.kind, &where); expr->ts = ts; + + /* If the typespec is CHARACTER, check that array elements can + 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)) + { + if (gfc_numeric_ts (&c->expr->ts) + || c->expr->ts.type == BT_LOGICAL) + { + gfc_error ("Incompatiable typespec for array element at %L", + &c->expr->where); + return MATCH_ERROR; + } + + /* Special case null(). */ + if (c->expr->expr_type == EXPR_FUNCTION + && c->expr->ts.type == BT_UNKNOWN + && strcmp (c->expr->symtree->name, "null") == 0) + { + gfc_error ("Incompatiable typespec for array element at %L", + &c->expr->where); + return MATCH_ERROR; + } + } + } } else expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); @@ -1146,6 +1195,7 @@ done: expr->ts.u.cl->length_from_typespec = seen_ts; *result = expr; + return MATCH_YES; syntax: diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index dec431bc2e..3196420b45 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -399,7 +399,15 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, static bool same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) { - if (gfc_compare_types (&e->ts, &f->ts)) + gfc_typespec *ets = &e->ts; + gfc_typespec *fts = &f->ts; + + if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) + ets = &e->symtree->n.sym->ts; + if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) + fts = &f->symtree->n.sym->ts; + + if (gfc_compare_types (ets, fts)) return true; gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " @@ -3711,6 +3719,36 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, } } } + else if (shape->expr_type == EXPR_VARIABLE && shape->ref + && shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1 + && shape->ref->u.ar.as + && shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT + && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER + && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT + && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER + && shape->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + int i, extent; + gfc_expr *e, *v; + + v = shape->symtree->n.sym->value; + + for (i = 0; i < shape_size; i++) + { + e = gfc_constructor_lookup_expr (v->value.constructor, i); + if (e == NULL) + break; + + gfc_extract_int (e, &extent); + + if (extent < 0) + { + gfc_error ("Element %d of actual argument of RESHAPE at %L " + "cannot be negative", i + 1, &shape->where); + return false; + } + } + } if (pad != NULL) { diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 799039999d..7f9256c3ba 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -843,7 +843,11 @@ has_finalizer_component (gfc_symbol *derived) && c->ts.u.derived->f2k_derived->finalizers) return true; + /* Stop infinite recursion through this function by inhibiting + calls when the derived type and that of the component are + the same. */ if (c->ts.type == BT_DERIVED + && !gfc_compare_derived_types (derived, c->ts.u.derived) && !c->attr.pointer && !c->attr.allocatable && has_finalizer_component (c->ts.u.derived)) return true; @@ -1599,6 +1603,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->ts.type = BT_INTEGER; final->ts.kind = 4; final->attr.artificial = 1; + final->attr.always_explicit = 1; final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 4fd84e4b41..98a29999ed 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -104,7 +104,7 @@ static gfc_expr * create_character_initializer (gfc_expr *init, gfc_typespec *ts, gfc_ref *ref, gfc_expr *rvalue) { - int len, start, end; + int len, start, end, tlen; gfc_char_t *dest; bool alloced_init = false; @@ -162,12 +162,22 @@ create_character_initializer (gfc_expr *init, gfc_typespec *ts, else len = rvalue->value.character.length; - if (len > end - start) + tlen = end - start; + if (len > tlen) { - gfc_warning_now (0, "Initialization string starting at %L was " - "truncated to fit the variable (%d/%d)", - &rvalue->where, end - start, len); - len = end - start; + if (tlen < 0) + { + gfc_warning_now (0, "Unused initialization string at %L because " + "variable has zero length", &rvalue->where); + len = 0; + } + else + { + gfc_warning_now (0, "Initialization string at %L was truncated to " + "fit the variable (%d/%d)", &rvalue->where, + tlen, len); + len = tlen; + } } if (rvalue->ts.type == BT_HOLLERITH) @@ -181,7 +191,7 @@ create_character_initializer (gfc_expr *init, gfc_typespec *ts, len * sizeof (gfc_char_t)); /* Pad with spaces. Substrings will already be blanked. */ - if (len < end - start && ref == NULL) + if (len < tlen && ref == NULL) gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index c31180d3ef..2708413a11 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -561,6 +561,15 @@ gfc_match_data (void) gfc_data *new_data; match m; + /* Before parsing the rest of a DATA statement, check F2008:c1206. */ + if ((gfc_current_state () == COMP_FUNCTION + || gfc_current_state () == COMP_SUBROUTINE) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("DATA statement at %C cannot appear within an INTERFACE"); + return MATCH_ERROR; + } + set_in_match_data (true); for (;;) @@ -705,8 +714,7 @@ char_len_param_value (gfc_expr **expr, bool *deferred) if (gfc_match_char (':') == MATCH_YES) { - if (!gfc_notify_std (GFC_STD_F2003, "deferred type " - "parameter at %C")) + if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C")) return MATCH_ERROR; *deferred = true; @@ -716,33 +724,69 @@ char_len_param_value (gfc_expr **expr, bool *deferred) m = gfc_match_expr (expr); - if (m == MATCH_YES - && !gfc_expr_check_typed (*expr, gfc_current_ns, false)) + if (m == MATCH_NO || m == MATCH_ERROR) + return m; + + if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) return MATCH_ERROR; - if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION) + if ((*expr)->expr_type == EXPR_FUNCTION) + { + if ((*expr)->ts.type == BT_INTEGER + || ((*expr)->ts.type == BT_UNKNOWN + && strcmp((*expr)->symtree->name, "null") != 0)) + return MATCH_YES; + + goto syntax; + } + else if ((*expr)->expr_type == EXPR_CONSTANT) { - if ((*expr)->value.function.actual - && (*expr)->value.function.actual->expr->symtree) + /* F2008, 4.4.3.1: The length is a type parameter; its kind is + processor dependent and its value is greater than or equal to zero. + F2008, 4.4.3.2: If the character length parameter value evaluates + to a negative value, the length of character entities declared + is zero. */ + + if ((*expr)->ts.type == BT_INTEGER) { - gfc_expr *e; - e = (*expr)->value.function.actual->expr; - if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE - && e->expr_type == EXPR_VARIABLE) - { - if (e->symtree->n.sym->ts.type == BT_UNKNOWN) - goto syntax; - if (e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.u.cl - && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN) - goto syntax; - } + if (mpz_cmp_si ((*expr)->value.integer, 0) < 0) + mpz_set_si ((*expr)->value.integer, 0); } + else + goto syntax; } + else if ((*expr)->expr_type == EXPR_ARRAY) + goto syntax; + else if ((*expr)->expr_type == EXPR_VARIABLE) + { + gfc_expr *e; + + e = gfc_copy_expr (*expr); + + /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", + which causes an ICE if gfc_reduce_init_expr() is called. */ + if (e->ref && e->ref->type == REF_ARRAY + && e->ref->u.ar.type == AR_UNKNOWN + && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) + goto syntax; + + gfc_reduce_init_expr (e); + + if ((e->ref && e->ref->type == REF_ARRAY + && e->ref->u.ar.type != AR_ELEMENT) + || (!e->ref && e->expr_type == EXPR_ARRAY)) + { + gfc_free_expr (e); + goto syntax; + } + + gfc_free_expr (e); + } + return m; syntax: - gfc_error ("Conflict in attributes of function argument at %C"); + gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); return MATCH_ERROR; } @@ -899,6 +943,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) gfc_find_sym_tree (name, gfc_current_ns, 0, &st); st->n.sym = *result; st = gfc_get_unique_symtree (gfc_current_ns); + sym->refs++; st->n.sym = sym; } } @@ -915,7 +960,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) /* Trap another encompassed procedure with the same name. All these conditions are necessary to avoid picking up an entry whose name clashes with that of the encompassing procedure; - this is handled using gsymbols to register unique,globally + this is handled using gsymbols to register unique, globally accessible names. */ if (sym->attr.flavor != 0 && sym->attr.proc != 0 @@ -1236,7 +1281,9 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len) int slen; gcc_assert (expr->expr_type == EXPR_CONSTANT); - gcc_assert (expr->ts.type == BT_CHARACTER); + + if (expr->ts.type != BT_CHARACTER) + return; slen = expr->value.character.length; if (len != slen) @@ -1404,7 +1451,16 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } else if (init->expr_type == EXPR_ARRAY) { - clen = mpz_get_si (init->ts.u.cl->length->value.integer); + if (init->ts.u.cl) + clen = mpz_get_si (init->ts.u.cl->length->value.integer); + else if (init->value.constructor) + { + gfc_constructor *c; + c = gfc_constructor_first (init->value.constructor); + clen = c->expr->value.character.length; + } + else + gcc_unreachable (); sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, clen); @@ -1417,7 +1473,12 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) /* Update initializer character length according symbol. */ else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - int len = mpz_get_si (sym->ts.u.cl->length->value.integer); + int len; + + if (!gfc_specification_expr (sym->ts.u.cl->length)) + return false; + + len = mpz_get_si (sym->ts.u.cl->length->value.integer); if (init->expr_type == EXPR_CONSTANT) gfc_set_constant_character_len (len, init, -1); @@ -1449,7 +1510,6 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) " with scalar", &sym->declared_at); return false; } - gcc_assert (sym->as->rank == init->rank); /* Shape should be present, we get an initialization expression. */ gcc_assert (init->shape); @@ -1457,26 +1517,34 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) for (dim = 0; dim < sym->as->rank; ++dim) { int k; - gfc_expr* lower; - gfc_expr* e; + gfc_expr *e, *lower; lower = sym->as->lower[dim]; - if (lower->expr_type != EXPR_CONSTANT) + + /* If the lower bound is an array element from another + parameterized array, then it is marked with EXPR_VARIABLE and + is an initialization expression. Try to reduce it. */ + if (lower->expr_type == EXPR_VARIABLE) + gfc_reduce_init_expr (lower); + + if (lower->expr_type == EXPR_CONSTANT) + { + /* All dimensions must be without upper bound. */ + gcc_assert (!sym->as->upper[dim]); + + k = lower->ts.kind; + e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); + mpz_add (e->value.integer, lower->value.integer, + init->shape[dim]); + mpz_sub_ui (e->value.integer, e->value.integer, 1); + sym->as->upper[dim] = e; + } + else { gfc_error ("Non-constant lower bound in implied-shape" " declaration at %L", &lower->where); return false; } - - /* All dimensions must be without upper bound. */ - gcc_assert (!sym->as->upper[dim]); - - k = lower->ts.kind; - e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); - mpz_add (e->value.integer, - lower->value.integer, init->shape[dim]); - mpz_sub_ui (e->value.integer, e->value.integer, 1); - sym->as->upper[dim] = e; } sym->as->type = AS_EXPLICIT; @@ -2945,7 +3013,11 @@ get_kind: m = gfc_match_kind_spec (ts, false); if (m == MATCH_NO && ts->type != BT_CHARACTER) - m = gfc_match_old_kind_spec (ts); + { + m = gfc_match_old_kind_spec (ts); + if (gfc_validate_kind (ts->type, ts->kind, true) == -1) + return MATCH_ERROR; + } if (matched_type && gfc_match_char (')') != MATCH_YES) return MATCH_ERROR; @@ -3870,7 +3942,9 @@ match_attr_spec (void) break; case DECL_PROTECTED: - if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + if (gfc_current_state () != COMP_MODULE + || (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) { gfc_error ("PROTECTED at %C only allowed in specification " "part of a module"); @@ -5597,6 +5671,13 @@ gfc_match_entry (void) return MATCH_ERROR; } + if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE"); + return MATCH_ERROR; + } + module_procedure = gfc_current_ns->parent != NULL && gfc_current_ns->parent->proc_name && gfc_current_ns->parent->proc_name->attr.flavor @@ -8761,7 +8842,7 @@ gfc_match_final_decl (void) /* Add this symbol to the list of finalizers. */ gcc_assert (block->f2k_derived); - ++sym->refs; + sym->refs++; f = XCNEW (gfc_finalizer); f->proc_sym = sym; f->proc_tree = NULL; diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index da0eb8f664..683aa5964f 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -804,6 +804,9 @@ gfc_clear_pp_buffer (output_buffer *this_buffer) pp->buffer = this_buffer; pp_clear_output_area (pp); pp->buffer = tmp_buffer; + /* We need to reset last_location, otherwise we may skip caret lines + when we actually give a diagnostic. */ + global_dc->last_location = UNKNOWN_LOCATION; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index cc382d3424..c90e82348f 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2471,7 +2471,8 @@ gfc_check_init_expr (gfc_expr *e) t = false; { - gfc_intrinsic_sym* isym; + bool conversion; + gfc_intrinsic_sym* isym = NULL; gfc_symbol* sym = e->symtree->n.sym; /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic @@ -2489,8 +2490,14 @@ gfc_check_init_expr (gfc_expr *e) } } - if (!gfc_is_intrinsic (sym, 0, e->where) - || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) + /* If a conversion function, e.g., __convert_i8_i4, was inserted + into an array constructor, we need to skip the error check here. + Conversion errors are caught below in scalarize_intrinsic_call. */ + conversion = e->value.function.isym + && (e->value.function.isym->conversion == 1); + + if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) + || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)) { gfc_error ("Function %qs in initialization expression at %L " "must be an intrinsic function", @@ -2517,7 +2524,7 @@ gfc_check_init_expr (gfc_expr *e) array argument. */ isym = gfc_find_function (e->symtree->n.sym->name); if (isym && isym->elemental - && (t = scalarize_intrinsic_call(e))) + && (t = scalarize_intrinsic_call (e))) break; } @@ -2599,14 +2606,18 @@ gfc_check_init_expr (gfc_expr *e) break; case EXPR_SUBSTRING: - t = gfc_check_init_expr (e->ref->u.ss.start); - if (!t) - break; - - t = gfc_check_init_expr (e->ref->u.ss.end); - if (t) - t = gfc_simplify_expr (e, 0); + if (e->ref) + { + t = gfc_check_init_expr (e->ref->u.ss.start); + if (!t) + break; + t = gfc_check_init_expr (e->ref->u.ss.end); + if (t) + t = gfc_simplify_expr (e, 0); + } + else + t = false; break; case EXPR_STRUCTURE: @@ -3635,11 +3646,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) || (lvalue->ts.type == BT_DERIVED && (lvalue->ts.u.derived->attr.is_bind_c || lvalue->ts.u.derived->attr.sequence)))) - gfc_error ("Data-pointer-object &L must be unlimited " - "polymorphic, a sequence derived type or of a " - "type with the BIND attribute assignment at %L " - "to be compatible with an unlimited polymorphic " - "target", &lvalue->where); + gfc_error ("Data-pointer-object at %L must be unlimited " + "polymorphic, or of a type with the BIND or SEQUENCE " + "attribute, to be compatible with an unlimited " + "polymorphic target", &lvalue->where); else gfc_error ("Different types in pointer assignment at %L; " "attempted assignment of %s to %s", &lvalue->where, @@ -3854,7 +3864,17 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) if (pointer || proc_pointer) r = gfc_check_pointer_assign (&lvalue, rvalue); else - r = gfc_check_assign (&lvalue, rvalue, 1); + { + /* If a conversion function, e.g., __convert_i8_i4, was inserted + into an array constructor, we should check if it can be reduced + as an initialization expression. */ + if (rvalue->expr_type == EXPR_FUNCTION + && rvalue->value.function.isym + && (rvalue->value.function.isym->conversion == 1)) + gfc_check_init_expr (rvalue); + + r = gfc_check_assign (&lvalue, rvalue, 1); + } free (lvalue.symtree); free (lvalue.ref); diff --git a/gcc/fortran/gfortran.info b/gcc/fortran/gfortran.info index bc1d1c6ec2..dc49219644 100644 --- a/gcc/fortran/gfortran.info +++ b/gcc/fortran/gfortran.info @@ -1,5 +1,5 @@ This is doc/gfortran.info, produced by makeinfo version 4.12 from -/space/rguenther/gcc-5.2.0/gcc-5.2.0/gcc/fortran/gfortran.texi. +/space/rguenther/gcc-5.3.0/gcc-5.3.0/gcc/fortran/gfortran.texi. Copyright (C) 1999-2015 Free Software Foundation, Inc. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 745dd30a6b..5cbe96afe2 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2442,7 +2442,9 @@ get_expr_storage_size (gfc_expr *e) { if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i] && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT - && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT) + && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER + && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT + && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer) - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) + 1L; diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 0ac4f4a03a..de91ea9f3d 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1181,7 +1181,7 @@ check_format_string (gfc_expr *e, bool is_input) } -/************ Fortran 95 I/O statement matchers *************/ +/************ Fortran I/O statement matchers *************/ /* Match a FORMAT statement. This amounts to actually parsing the format descriptors in order to correctly locate the end of the @@ -1200,6 +1200,15 @@ gfc_match_format (void) return MATCH_ERROR; } + /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */ + if ((gfc_current_state () == COMP_FUNCTION + || gfc_current_state () == COMP_SUBROUTINE) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE"); + return MATCH_ERROR; + } + if (gfc_statement_label == NULL) { gfc_error ("Missing format label at %C"); @@ -1242,6 +1251,36 @@ gfc_match_format (void) } +/* Check for a CHARACTER variable. The check for scalar is done in + resolve_tag. */ + +static bool +check_char_variable (gfc_expr *e) +{ + if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER) + { + gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where); + return false; + } + return true; +} + + +static bool +is_char_type (const char *name, gfc_expr *e) +{ + gfc_resolve_expr (e); + + if (e->ts.type != BT_CHARACTER) + { + gfc_error ("%s requires a scalar-default-char-expr at %L", + name, &e->where); + return false; + } + return true; +} + + /* Match an expression I/O tag of some sort. */ static match @@ -1552,12 +1591,16 @@ match_open_element (gfc_open *open) match m; m = match_etag (&tag_e_async, &open->asynchronous); + if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &open->iomsg); + m = match_etag (&tag_iomsg, &open->iomsg); + if (m == MATCH_YES && !check_char_variable (open->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &open->iostat); @@ -1870,6 +1913,9 @@ gfc_match_open (void) static const char *access_f2003[] = { "STREAM", NULL }; static const char *access_gnu[] = { "APPEND", NULL }; + if (!is_char_type ("ACCESS", open->access)) + goto cleanup; + if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, access_gnu, open->access->value.character.string, @@ -1882,6 +1928,9 @@ gfc_match_open (void) { static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; + if (!is_char_type ("ACTION", open->action)) + goto cleanup; + if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, open->action->value.character.string, "OPEN", warn)) @@ -1895,6 +1944,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("ASYNCHRONOUS", open->asynchronous)) + goto cleanup; + if (open->asynchronous->expr_type == EXPR_CONSTANT) { static const char * asynchronous[] = { "YES", "NO", NULL }; @@ -1913,6 +1965,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("BLANK", open->blank)) + goto cleanup; + if (open->blank->expr_type == EXPR_CONSTANT) { static const char *blank[] = { "ZERO", "NULL", NULL }; @@ -1931,6 +1986,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("DECIMAL", open->decimal)) + goto cleanup; + if (open->decimal->expr_type == EXPR_CONSTANT) { static const char * decimal[] = { "COMMA", "POINT", NULL }; @@ -1949,6 +2007,9 @@ gfc_match_open (void) { static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; + if (!is_char_type ("DELIM", open->delim)) + goto cleanup; + if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, open->delim->value.character.string, "OPEN", warn)) @@ -1962,7 +2023,10 @@ gfc_match_open (void) if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " "not allowed in Fortran 95")) goto cleanup; - + + if (!is_char_type ("ENCODING", open->encoding)) + goto cleanup; + if (open->encoding->expr_type == EXPR_CONSTANT) { static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; @@ -1979,6 +2043,9 @@ gfc_match_open (void) { static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; + if (!is_char_type ("FORM", open->form)) + goto cleanup; + if (!compare_to_allowed_values ("FORM", form, NULL, NULL, open->form->value.character.string, "OPEN", warn)) @@ -1990,6 +2057,9 @@ gfc_match_open (void) { static const char *pad[] = { "YES", "NO", NULL }; + if (!is_char_type ("PAD", open->pad)) + goto cleanup; + if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, open->pad->value.character.string, "OPEN", warn)) @@ -2001,6 +2071,9 @@ gfc_match_open (void) { static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; + if (!is_char_type ("POSITION", open->position)) + goto cleanup; + if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, open->position->value.character.string, "OPEN", warn)) @@ -2014,6 +2087,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("ROUND", open->round)) + goto cleanup; + if (open->round->expr_type == EXPR_CONSTANT) { static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", @@ -2034,6 +2110,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("SIGN", open->sign)) + goto cleanup; + if (open->sign->expr_type == EXPR_CONSTANT) { static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", @@ -2071,6 +2150,9 @@ gfc_match_open (void) static const char *status[] = { "OLD", "NEW", "SCRATCH", "REPLACE", "UNKNOWN", NULL }; + if (!is_char_type ("STATUS", open->status)) + goto cleanup; + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, open->status->value.character.string, "OPEN", warn)) @@ -2182,7 +2264,9 @@ match_close_element (gfc_close *close) m = match_etag (&tag_status, &close->status); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &close->iomsg); + m = match_etag (&tag_iomsg, &close->iomsg); + if (m == MATCH_YES && !check_char_variable (close->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &close->iostat); @@ -2256,6 +2340,9 @@ gfc_match_close (void) { static const char *status[] = { "KEEP", "DELETE", NULL }; + if (!is_char_type ("STATUS", close->status)) + goto cleanup; + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, close->status->value.character.string, "CLOSE", warn)) @@ -2340,7 +2427,9 @@ match_file_element (gfc_filepos *fp) m = match_etag (&tag_unit, &fp->unit); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &fp->iomsg); + m = match_etag (&tag_iomsg, &fp->iomsg); + if (m == MATCH_YES && !check_char_variable (fp->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &fp->iostat); @@ -2436,12 +2525,21 @@ gfc_resolve_filepos (gfc_filepos *fp) if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) return false; + if (!fp->unit && (fp->iostat || fp->iomsg)) + { + locus where; + where = fp->iostat ? fp->iostat->where : fp->iomsg->where; + gfc_error ("UNIT number missing in statement at %L", &where); + return false; + } + if (fp->unit->expr_type == EXPR_CONSTANT && fp->unit->ts.type == BT_INTEGER && mpz_sgn (fp->unit->value.integer) < 0) { gfc_error ("UNIT number in statement at %L must be non-negative", &fp->unit->where); + return false; } return true; @@ -2676,6 +2774,8 @@ match_dt_element (io_kind k, gfc_dt *dt) } m = match_etag (&tag_e_async, &dt->asynchronous); + if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_etag (&tag_e_blank, &dt->blank); @@ -2705,9 +2805,12 @@ match_dt_element (io_kind k, gfc_dt *dt) m = match_etag (&tag_spos, &dt->pos); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &dt->iomsg); + m = match_etag (&tag_iomsg, &dt->iomsg); + if (m == MATCH_YES && !check_char_variable (dt->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; + m = match_out_tag (&tag_iostat, &dt->iostat); if (m != MATCH_NO) return m; @@ -3305,6 +3408,9 @@ if (condition) \ return MATCH_ERROR; } + if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous)) + return MATCH_ERROR; + if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, NULL, NULL, dt->asynchronous->value.character.string, @@ -3334,6 +3440,9 @@ if (condition) \ { static const char * decimal[] = { "COMMA", "POINT", NULL }; + if (!is_char_type ("DECIMAL", dt->decimal)) + return MATCH_ERROR; + if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, dt->decimal->value.character.string, io_kind_name (k), warn)) @@ -3351,10 +3460,14 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("BLANK", dt->blank)) + return MATCH_ERROR; + if (dt->blank->expr_type == EXPR_CONSTANT) { static const char * blank[] = { "NULL", "ZERO", NULL }; + if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, dt->blank->value.character.string, io_kind_name (k), warn)) @@ -3372,6 +3485,9 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("PAD", dt->pad)) + return MATCH_ERROR; + if (dt->pad->expr_type == EXPR_CONSTANT) { static const char * pad[] = { "YES", "NO", NULL }; @@ -3393,6 +3509,9 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("ROUND", dt->round)) + return MATCH_ERROR; + if (dt->round->expr_type == EXPR_CONSTANT) { static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", @@ -3412,6 +3531,10 @@ if (condition) \ if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " "not allowed in Fortran 95") == false) return MATCH_ERROR; */ + + if (!is_char_type ("SIGN", dt->sign)) + return MATCH_ERROR; + if (dt->sign->expr_type == EXPR_CONSTANT) { static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", @@ -3438,6 +3561,9 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("DELIM", dt->delim)) + return MATCH_ERROR; + if (dt->delim->expr_type == EXPR_CONSTANT) { static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; @@ -3860,7 +3986,9 @@ match_inquire_element (gfc_inquire *inquire) m = match_etag (&tag_unit, &inquire->unit); RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_ltag (&tag_err, &inquire->err); - RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg); + RETM m = match_etag (&tag_iomsg, &inquire->iomsg); + if (m == MATCH_YES && !check_char_variable (inquire->iomsg)) + return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &inquire->iostat); RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_opened, &inquire->opened); @@ -3882,6 +4010,8 @@ match_inquire_element (gfc_inquire *inquire) RETM m = match_vtag (&tag_write, &inquire->write); RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); + if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous)) + return MATCH_ERROR; RETM m = match_vtag (&tag_s_delim, &inquire->delim); RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); RETM m = match_out_tag (&tag_size, &inquire->size); @@ -4143,7 +4273,9 @@ match_wait_element (gfc_wait *wait) RETM m = match_ltag (&tag_err, &wait->err); RETM m = match_ltag (&tag_end, &wait->eor); RETM m = match_ltag (&tag_eor, &wait->end); - RETM m = match_out_tag (&tag_iomsg, &wait->iomsg); + RETM m = match_etag (&tag_iomsg, &wait->iomsg); + if (m == MATCH_YES && !check_char_variable (wait->iomsg)) + return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &wait->iostat); RETM m = match_etag (&tag_id, &wait->id); RETM return MATCH_NO; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index fd3bd4c1b2..60c6e656d0 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -544,7 +544,10 @@ gfc_match_name (char *buffer) c = gfc_next_ascii_char (); if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) { - if (!gfc_error_flag_test () && c != '(') + /* Special cases for unary minus and plus, which allows for a sensible + error message for code of the form 'c = exp(-a*b) )' where an + extra ')' appears at the end of statement. */ + if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') gfc_error ("Invalid character in name at %C"); gfc_current_locus = old_loc; return MATCH_NO; @@ -1943,6 +1946,11 @@ kind_selector: if (m == MATCH_NO) m = MATCH_YES; /* No kind specifier found. */ + /* gfortran may have matched REAL(a=1), which is the keyword form of the + intrinsic procedure. */ + if (ts->type == BT_REAL && m == MATCH_ERROR) + m = MATCH_NO; + return m; } @@ -4925,6 +4933,15 @@ gfc_match_st_function (void) sym->value = expr; + if ((gfc_current_state () == COMP_FUNCTION + || gfc_current_state () == COMP_SUBROUTINE) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("Statement function at %L cannot appear within an INTERFACE", + &expr->where); + return MATCH_ERROR; + } + if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C")) return MATCH_ERROR; @@ -4966,7 +4983,9 @@ gfc_free_case_list (gfc_case *p) } -/* Match a single case selector. */ +/* Match a single case selector. Combining the requirements of F08:C830 + and F08:C832 (R838) means that the case-value must have either CHARACTER, + INTEGER, or LOGICAL type. */ static match match_case_selector (gfc_case **cp) @@ -4984,6 +5003,14 @@ match_case_selector (gfc_case **cp) goto need_expr; if (m == MATCH_ERROR) goto cleanup; + + if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER + && c->high->ts.type != BT_CHARACTER) + { + gfc_error ("Expression in CASE selector at %L cannot be %s", + &c->high->where, gfc_typename (&c->high->ts)); + goto cleanup; + } } else { @@ -4993,6 +5020,14 @@ match_case_selector (gfc_case **cp) if (m == MATCH_NO) goto need_expr; + if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER + && c->low->ts.type != BT_CHARACTER) + { + gfc_error ("Expression in CASE selector at %L cannot be %s", + &c->low->where, gfc_typename (&c->low->ts)); + goto cleanup; + } + /* If we're not looking at a ':' now, make a range out of a single target. Else get the upper bound for the case range. */ if (gfc_match_char (':') != MATCH_YES) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index f22b191ba7..27ead210b5 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3092,15 +3092,18 @@ match_deferred_characteristics (gfc_typespec * ts) static void check_function_result_typed (void) { - gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts; + gfc_typespec ts; gcc_assert (gfc_current_state () == COMP_FUNCTION); - gcc_assert (ts->type != BT_UNKNOWN); + + if (!gfc_current_ns->proc_name->result) return; + + ts = gfc_current_ns->proc_name->result->ts; /* Check type-parameters, at the moment only CHARACTER lengths possible. */ /* TODO: Extend when KIND type parameters are implemented. */ - if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length) - gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true); + if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length) + gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e9ced7e6f7..f845917393 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -748,7 +748,7 @@ cleanup: /* Match a substring reference. */ static match -match_substring (gfc_charlen *cl, int init, gfc_ref **result) +match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred) { gfc_expr *start, *end; locus old_loc; @@ -800,7 +800,7 @@ match_substring (gfc_charlen *cl, int init, gfc_ref **result) } /* Optimize away the (:) reference. */ - if (start == NULL && end == NULL) + if (start == NULL && end == NULL && !deferred) ref = NULL; else { @@ -1098,7 +1098,7 @@ got_delim: if (ret != -1) gfc_internal_error ("match_string_constant(): Delimiter not found"); - if (match_substring (NULL, 0, &e->ref) != MATCH_NO) + if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO) e->expr_type = EXPR_SUBSTRING; *result = e; @@ -1202,6 +1202,9 @@ match_sym_complex_part (gfc_expr **result) return MATCH_ERROR; } + if (!sym->value) + goto error; + if (!gfc_numeric_ts (&sym->value->ts)) { gfc_error ("Numeric PARAMETER required in complex constant at %C"); @@ -2078,7 +2081,8 @@ check_substring: if (primary->ts.type == BT_CHARACTER) { - switch (match_substring (primary->ts.u.cl, equiv_flag, &substring)) + bool def = primary->ts.deferred == 1; + switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def)) { case MATCH_YES: if (tail == NULL) @@ -2642,7 +2646,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) gfc_expr *e; gfc_symtree *symtree; - gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */ + gfc_get_ha_sym_tree (sym->name, &symtree); e = gfc_get_expr (); e->symtree = symtree; @@ -3091,7 +3095,7 @@ gfc_match_rvalue (gfc_expr **result) that we're not sure is a variable yet. */ if ((implicit_char || sym->ts.type == BT_CHARACTER) - && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES) + && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES) { e->expr_type = EXPR_VARIABLE; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index da9d825d86..00a9f943fe 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4554,8 +4554,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) { if (e->ts.u.cl->length) gfc_free_expr (e->ts.u.cl->length); - else if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.dummy) + else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) return; } @@ -4584,12 +4583,19 @@ gfc_resolve_substring_charlen (gfc_expr *e) return; } - /* Length = (end - start +1). */ + /* Length = (end - start + 1). */ e->ts.u.cl->length = gfc_subtract (end, start); e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_get_int_expr (gfc_default_integer_kind, NULL, 1)); + /* F2008, 6.4.1: Both the starting point and the ending point shall + be within the range 1, 2, ..., n unless the starting point exceeds + the ending point, in which case the substring has length zero. */ + + if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0) + mpz_set_si (e->ts.u.cl->length->value.integer, 0); + e->ts.u.cl->length->ts.type = BT_INTEGER; e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; @@ -10230,15 +10236,22 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) } case EXEC_ARITHMETIC_IF: - if (t - && code->expr1->ts.type != BT_INTEGER - && code->expr1->ts.type != BT_REAL) - gfc_error ("Arithmetic IF statement at %L requires a numeric " - "expression", &code->expr1->where); + { + gfc_expr *e = code->expr1; + + gfc_resolve_expr (e); + if (e->expr_type == EXPR_NULL) + gfc_error ("Invalid NULL at %L", &e->where); - resolve_branch (code->label1, code); - resolve_branch (code->label2, code); - resolve_branch (code->label3, code); + if (t && (e->rank > 0 + || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER))) + gfc_error ("Arithmetic IF statement at %L requires a scalar " + "REAL or INTEGER expression", &e->where); + + resolve_branch (code->label1, code); + resolve_branch (code->label2, code); + resolve_branch (code->label3, code); + } break; case EXEC_IF: @@ -10548,7 +10561,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) sym->binding_label = NULL; } - else if (sym->attr.flavor == FL_VARIABLE + else if (sym->attr.flavor == FL_VARIABLE && module && (strcmp (module, gsym->mod_name) != 0 || strcmp (sym->name, gsym->sym_name) != 0)) { @@ -10636,18 +10649,11 @@ resolve_charlen (gfc_charlen *cl) } } - /* "If the character length parameter value evaluates to a negative - value, the length of character entities declared is zero." */ + /* F2008, 4.4.3.2: If the character length parameter value evaluates to + a negative value, the length of character entities declared is zero. */ if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0) - { - if (warn_surprising) - gfc_warning_now (OPT_Wsurprising, - "CHARACTER variable at %L has negative length %d," - " the length has been set to zero", - &cl->length->where, i); - gfc_replace_expr (cl->length, - gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); - } + gfc_replace_expr (cl->length, + gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); /* Check that the character length is not too large. */ k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 20d50d2fdf..e4df72c14c 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2352,9 +2352,7 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - gfc_set_model_kind (kind); - - mpfr_init (floor); + mpfr_init2 (floor, mpfr_get_prec (e->value.real)); mpfr_floor (floor, e->value.real); result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 17689748ea..3c2c64046e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5030,6 +5030,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gcc_assert (ubound); gfc_conv_expr_type (&se, ubound, gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); + if (ubound->expr_type == EXPR_FUNCTION) + se.expr = gfc_evaluate_now (se.expr, pblock); gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); @@ -7468,7 +7470,8 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank) static tree duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc, bool no_memcpy, tree str_sz) + bool no_malloc, bool no_memcpy, tree str_sz, + tree add_when_allocated) { tree tmp; tree size; @@ -7548,6 +7551,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, } } + gfc_add_expr_to_block (&block, add_when_allocated); tmp = gfc_finish_block (&block); /* Null the destination if the source is null; otherwise do @@ -7567,10 +7571,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, /* Allocate dest to the same size as src, and copy data src -> dest. */ tree -gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) +gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank, + tree add_when_allocated) { return duplicate_allocatable (dest, src, type, rank, false, false, - NULL_TREE); + NULL_TREE, add_when_allocated); } @@ -7580,7 +7585,7 @@ tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) { return duplicate_allocatable (dest, src, type, rank, true, false, - NULL_TREE); + NULL_TREE, NULL_TREE); } /* Allocate dest to the same size as src, but don't copy anything. */ @@ -7588,7 +7593,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) tree gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) { - return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE); + return duplicate_allocatable (dest, src, type, rank, false, true, + NULL_TREE, NULL_TREE); } @@ -7620,27 +7626,32 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree ctype; tree vref, dref; tree null_cond = NULL_TREE; + tree add_when_allocated; bool called_dealloc_with_status; gfc_init_block (&fnblock); decl_type = TREE_TYPE (decl); - if ((POINTER_TYPE_P (decl_type) && rank != 0) + if ((POINTER_TYPE_P (decl_type)) || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) - decl = build_fold_indirect_ref_loc (input_location, decl); + { + decl = build_fold_indirect_ref_loc (input_location, decl); + /* Deref dest in sync with decl, but only when it is not NULL. */ + if (dest) + dest = build_fold_indirect_ref_loc (input_location, dest); + } - /* Just in case in gets dereferenced. */ + /* Just in case it gets dereferenced. */ decl_type = TREE_TYPE (decl); - /* If this an array of derived types with allocatable components + /* If this is an array of derived types with allocatable components build a loop and recursively call this function. */ if (TREE_CODE (decl_type) == ARRAY_TYPE || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) { tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref_loc (input_location, - tmp); + var = build_fold_indirect_ref_loc (input_location, tmp); /* Get the number of elements - 1 and set the counter. */ if (GFC_DESCRIPTOR_TYPE_P (decl_type)) @@ -7661,7 +7672,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else { /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (decl_type); + tmp = array_type_nelts (decl_type); tmp = fold_convert (gfc_array_index_type, tmp); } @@ -7674,19 +7685,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, vref = gfc_build_array_ref (var, index, NULL); - if (purpose == COPY_ALLOC_COMP) - { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank); - gfc_add_expr_to_block (&fnblock, tmp); - } - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); - tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); - } - else if (purpose == COPY_ONLY_ALLOC_COMP) + if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) { tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_array_data (dest)); @@ -7709,7 +7708,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_block_to_block (&fnblock, &loop.pre); tmp = gfc_finish_block (&fnblock); - if (null_cond != NULL_TREE) + /* When copying allocateable components, the above implements the + deep copy. Nevertheless is a deep copy only allowed, when the current + component is allocated, for which code will be generated in + gfc_duplicate_allocatable (), where the deep copy code is just added + into the if's body, by adding tmp (the deep copy code) as last + argument to gfc_duplicate_allocatable (). */ + if (purpose == COPY_ALLOC_COMP + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) + tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank, + tmp); + else if (null_cond != NULL_TREE) tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt (input_location)); @@ -7805,6 +7814,32 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); } gfc_add_expr_to_block (&tmpblock, tmp); + + /* Finally, reset the vptr to the declared type vtable and, if + necessary reset the _len field. */ + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + tmp = gfc_class_vptr_get (comp); + if (UNLIMITED_POLY (c)) + { + gfc_add_modify (&tmpblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + tmp = gfc_class_len_get (comp); + gfc_add_modify (&tmpblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + } + else + { + tree vtab; + gfc_symbol *vtable; + vtable = gfc_find_derived_vtab (c->ts.u.derived); + vtab = vtable->backend_decl; + if (vtab == NULL_TREE) + vtab = gfc_get_symbol_decl(vtable); + vtab = gfc_build_addr_expr (NULL, vtab); + vtab = fold_convert (TREE_TYPE (tmp), vtab); + gfc_add_modify (&tmpblock, tmp, vtab); + } } if (cmp_has_alloc_comps @@ -7994,6 +8029,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } + /* To implement guarded deep copy, i.e., deep copy only allocatable + components that are really allocated, the deep copy code has to + be generated first and then added to the if-block in + gfc_duplicate_allocatable (). */ + if (cmp_has_alloc_comps) + { + rank = c->as ? c->as->rank : 0; + tmp = fold_convert (TREE_TYPE (dcmp), comp); + gfc_add_modify (&fnblock, dcmp, tmp); + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, dcmp, + rank, purpose); + } + else + add_when_allocated = NULL_TREE; + if (gfc_deferred_strlen (c, &tmp)) { tree len, size; @@ -8008,30 +8059,29 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, TREE_TYPE (len), len, tmp); gfc_add_expr_to_block (&fnblock, tmp); size = size_of_string_in_bytes (c->ts.kind, len); + /* This component can not have allocatable components, + therefore add_when_allocated of duplicate_allocatable () + is always NULL. */ tmp = duplicate_allocatable (dcmp, comp, ctype, rank, - false, false, size); + false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } else if (c->attr.allocatable && !c->attr.proc_pointer - && !cmp_has_alloc_comps) + && (!(cmp_has_alloc_comps && c->as) + || c->attr.codimension)) { rank = c->as ? c->as->rank : 0; if (c->attr.codimension) tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); else - tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank); + tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, + add_when_allocated); gfc_add_expr_to_block (&fnblock, tmp); } + else + if (cmp_has_alloc_comps) + gfc_add_expr_to_block (&fnblock, add_when_allocated); - if (cmp_has_alloc_comps) - { - rank = c->as ? c->as->rank : 0; - tmp = fold_convert (TREE_TYPE (dcmp), comp); - gfc_add_modify (&fnblock, dcmp, tmp); - tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - } break; default: @@ -8972,7 +9022,11 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) return NULL; /* Normal procedure case. */ - sym = procedure_ref->symtree->n.sym; + if (procedure_ref->expr_type == EXPR_FUNCTION + && procedure_ref->value.function.esym) + sym = procedure_ref->value.function.esym; + else + sym = procedure_ref->symtree->n.sym; /* Typebound procedure case. */ for (ref = procedure_ref->ref; ref; ref = ref->next) diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 854453490a..76bad2a199 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -46,7 +46,7 @@ tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); tree gfc_full_array_size (stmtblock_t *, tree, int); -tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); +tree gfc_duplicate_allocatable (tree, tree, tree, int, tree); tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 769d487c7d..900015dc6f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -5158,6 +5158,16 @@ generate_local_decl (gfc_symbol * sym) "Unused parameter %qs which has been explicitly " "imported at %L", sym->name, &sym->declared_at); } + + if (sym->ns + && sym->ns->parent + && sym->ns->parent->code + && sym->ns->parent->code->op == EXEC_BLOCK) + { + if (sym->attr.referenced) + gfc_get_symbol_decl (sym); + sym->mark = 1; + } } else if (sym->attr.flavor == FL_PROCEDURE) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 88f1af80e0..2b1cbc7390 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -269,15 +269,27 @@ gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *e) { gfc_expr *base_expr; - gfc_ref *ref, *class_ref, *tail; + gfc_ref *ref, *class_ref, *tail, *array_ref; /* Find the last class reference. */ class_ref = NULL; + array_ref = NULL; for (ref = e->ref; ref; ref = ref->next) { + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT) + array_ref = ref; + if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS) + { + /* Component to the right of a part reference with nonzero rank + must not have the ALLOCATABLE attribute. */ + if (array_ref + && CLASS_DATA (ref->u.c.component)->attr.allocatable) + return NULL; class_ref = ref; + } if (ref->next == NULL) break; @@ -318,47 +330,33 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) void gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) { - gfc_expr *rhs, *lhs = gfc_copy_expr (e); gfc_symbol *vtab; - tree tmp; - gfc_ref *ref; + tree vptr; + tree vtable; + gfc_se se; - /* If we have a class array, we need go back to the class - container. */ - if (lhs->ref && lhs->ref->next && !lhs->ref->next->next - && lhs->ref->next->type == REF_ARRAY - && lhs->ref->next->u.ar.type == AR_FULL - && lhs->ref->type == REF_COMPONENT - && strcmp (lhs->ref->u.c.component->name, "_data") == 0) - { - gfc_free_ref_list (lhs->ref); - lhs->ref = NULL; - } + gfc_init_se (&se, NULL); + if (e->rank) + gfc_conv_expr_descriptor (&se, e); else - for (ref = lhs->ref; ref; ref = ref->next) - if (ref->next && ref->next->next && !ref->next->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->next->u.ar.type == AR_FULL - && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0) - { - gfc_free_ref_list (ref->next); - ref->next = NULL; - } - - gfc_add_vptr_component (lhs); + gfc_conv_expr (&se, e); + gfc_add_block_to_block (block, &se.pre); + vptr = gfc_get_vptr_from_expr (se.expr); + if (vptr == NULL_TREE) + return; if (UNLIMITED_POLY (e)) - rhs = gfc_get_null_expr (NULL); + gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); else { vtab = gfc_find_derived_vtab (e->ts.u.derived); - rhs = gfc_lval_expr_from_sym (vtab); + vtable = vtab->backend_decl; + if (vtable == NULL_TREE) + vtable = gfc_get_symbol_decl (vtab); + vtable = gfc_build_addr_expr (NULL, vtable); + vtable = fold_convert (TREE_TYPE (vptr), vtable); + gfc_add_modify (block, vptr, vtable); } - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (block, tmp); - gfc_free_expr (lhs); - gfc_free_expr (rhs); } @@ -370,6 +368,8 @@ gfc_reset_len (stmtblock_t *block, gfc_expr *expr) gfc_expr *e; gfc_se se_len; e = gfc_find_and_cut_at_last_class_ref (expr); + if (e == NULL) + return; gfc_add_len_component (e); gfc_init_se (&se_len, NULL); gfc_conv_expr (&se_len, e); @@ -5698,18 +5698,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, vec_safe_reserve (retargs, arglen); /* Add the return arguments. */ - retargs->splice (arglist); + vec_safe_splice (retargs, arglist); /* Add the hidden present status for optional+value to the arguments. */ - retargs->splice (optionalargs); + vec_safe_splice (retargs, optionalargs); /* Add the hidden string length parameters to the arguments. */ - retargs->splice (stringargs); + vec_safe_splice (retargs, stringargs); /* We may want to append extra arguments here. This is used e.g. for calls to libgfortran_matmul_??, which need extra information. */ - if (!vec_safe_is_empty (append_args)) - retargs->splice (append_args); + vec_safe_splice (retargs, append_args); + arglist = retargs; /* Generate the actual call. */ @@ -5739,6 +5739,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fntype = TREE_TYPE (TREE_TYPE (se->expr)); se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist); + /* Allocatable scalar function results must be freed and nullified + after use. This necessitates the creation of a temporary to + hold the result to prevent duplicate calls. */ + if (!byref && sym->ts.type != BT_CHARACTER + && sym->attr.allocatable && !sym->attr.dimension) + { + tmp = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify (&se->pre, tmp, se->expr); + se->expr = tmp; + tmp = gfc_call_free (tmp); + gfc_add_expr_to_block (&post, tmp); + gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); + } + /* If we have a pointer function, but we don't want a pointer, e.g. something like x = f() @@ -6563,13 +6577,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, { tmp = TREE_TYPE (dest); tmp = gfc_duplicate_allocatable (dest, se.expr, - tmp, expr->rank); + tmp, expr->rank, NULL_TREE); } } else tmp = gfc_duplicate_allocatable (dest, se.expr, TREE_TYPE(cm->backend_decl), - cm->as->rank); + cm->as->rank, NULL_TREE); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &se.post); @@ -6732,6 +6746,29 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, TREE_TYPE (tmp), tmp, fold_convert (TREE_TYPE (tmp), size)); } + else if (cm->ts.type == BT_CLASS) + { + gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED); + if (expr2->ts.type == BT_DERIVED) + { + tmp = gfc_get_symbol_decl (expr2->ts.u.derived); + size = TYPE_SIZE_UNIT (tmp); + } + else + { + gfc_expr *e2vtab; + gfc_se se; + e2vtab = gfc_find_and_cut_at_last_class_ref (expr2); + gfc_add_vptr_component (e2vtab); + gfc_add_size_component (e2vtab); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e2vtab); + gfc_add_block_to_block (block, &se.pre); + size = fold_convert (size_type_node, se.expr); + gfc_free_expr (e2vtab); + } + size_in_bytes = size; + } else { /* Otherwise use the length in bytes of the rhs. */ @@ -6859,7 +6896,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, gfc_add_expr_to_block (&block, tmp); } else if (init && (cm->attr.allocatable - || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable))) + || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable + && expr->ts.type != BT_CLASS))) { /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ @@ -8634,6 +8672,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, tree jump_label1; tree jump_label2; gfc_se lse; + gfc_ref *ref; if (!expr1 || expr1->rank) return; @@ -8641,6 +8680,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, if (!expr2 || expr2->rank) return; + for (ref = expr1->ref; ref; ref = ref->next) + if (ref->type == REF_SUBSTRING) + return; + realloc_lhs_warning (expr2->ts.type, false, &expr2->where); /* Since this is a scalar lhs, we can afford to do this. That is, @@ -8975,7 +9018,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, scalar_to_array = (expr2->ts.type == BT_DERIVED && expr2->ts.u.derived->attr.alloc_comp && !expr_is_variable (expr2) - && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); scalar_to_array |= (expr1->ts.type == BT_DERIVED && expr1->rank @@ -8984,7 +9026,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (scalar_to_array && dealloc) { tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0); - gfc_add_expr_to_block (&loop.post, tmp); + gfc_prepend_expr_to_block (&loop.post, tmp); } /* When assigning a character function result to a deferred-length variable, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c4ccb7b77c..9b06259868 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8801,7 +8801,7 @@ conv_co_collective (gfc_code *code) } opr_flags = build_int_cst (integer_type_node, opr_flag_int); gfc_conv_expr (&argse, opr_expr); - opr = gfc_build_addr_expr (NULL_TREE, argse.expr); + opr = argse.expr; fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags, image_index, stat, errmsg, strlen, errmsg_len); } @@ -9360,6 +9360,16 @@ conv_intrinsic_move_alloc (gfc_code *code) } } + if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) + { + gfc_add_modify_loc (input_location, &block, to_se.string_length, + fold_convert (TREE_TYPE (to_se.string_length), + from_se.string_length)); + if (from_expr->ts.deferred) + gfc_add_modify_loc (input_location, &block, from_se.string_length, + build_int_cst (TREE_TYPE (from_se.string_length), 0)); + } + return gfc_finish_block (&block); } @@ -9459,6 +9469,14 @@ conv_intrinsic_move_alloc (gfc_code *code) } else { + if (to_expr->ts.type == BT_DERIVED + && to_expr->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived, + to_se.expr, to_expr->rank); + gfc_add_expr_to_block (&block, tmp); + } + tmp = gfc_conv_descriptor_data_get (to_se.expr); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, to_expr, false); @@ -9473,6 +9491,17 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); + + if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) + { + gfc_add_modify_loc (input_location, &block, to_se.string_length, + fold_convert (TREE_TYPE (to_se.string_length), + from_se.string_length)); + if (from_expr->ts.deferred) + gfc_add_modify_loc (input_location, &block, from_se.string_length, + build_int_cst (TREE_TYPE (from_se.string_length), 0)); + } + return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 98aeaadd8c..9d95e86aa2 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -391,9 +391,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) tem = gfc_duplicate_allocatable (destf, declf, ftype, - GFC_TYPE_ARRAY_RANK (ftype)); + GFC_TYPE_ARRAY_RANK (ftype), + NULL_TREE); else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - tem = gfc_duplicate_allocatable (destf, declf, ftype, 0); + tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, + NULL_TREE); break; } if (tem) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 91d2a85db6..776f78fd9d 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5210,6 +5210,17 @@ gfc_trans_allocate (gfc_code * code) here, fix it for future use. */ if (se.string_length) expr3_len = gfc_evaluate_now (se.string_length, &block); + + /* Deallocate any allocatable components after all the allocations + and assignments of expr3 have been completed. */ + if (expr3 && code->expr3->ts.type == BT_DERIVED + && code->expr3->rank == 0 + && code->expr3->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, + expr3, 0); + gfc_add_expr_to_block (&post, tmp); + } } } @@ -5618,7 +5629,8 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr); } - else if (code->expr3->ts.type == BT_CHARACTER) + else if (code->expr3->ts.type == BT_CHARACTER + && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) { tmp = INDIRECT_REF_P (se.expr) ? se.expr : diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 0ad8ac2075..a267040aab 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2375,6 +2375,7 @@ gfc_get_derived_type (gfc_symbol * derived) gfc_component *c; gfc_dt_list *dt; gfc_namespace *ns; + tree tmp; if (derived->attr.unlimited_polymorphic || (flag_coarray == GFC_FCOARRAY_LIB @@ -2526,8 +2527,19 @@ gfc_get_derived_type (gfc_symbol * derived) node as DECL_CONTEXT of each FIELD_DECL. */ for (c = derived->components; c; c = c->next) { - if (c->attr.proc_pointer) + /* Prevent infinite recursion, when the procedure pointer type is + the same as derived, by forcing the procedure pointer component to + be built as if the explicit interface does not exist. */ + if (c->attr.proc_pointer + && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) + || (c->ts.u.derived + && !gfc_compare_derived_types (derived, c->ts.u.derived)))) field_type = gfc_get_ppc_type (c); + else if (c->attr.proc_pointer && derived->backend_decl) + { + tmp = build_function_type_list (derived->backend_decl, NULL_TREE); + field_type = build_pointer_type (tmp); + } else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) field_type = c->ts.u.derived->backend_decl; else |