diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1bf51fd434cd..3d32b1cec2e3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,41 @@ +2006-11-12 Paul Thomas + + PR fortran/29699 + * trans-array.c (structure_alloc_comps): Detect pointers to + arrays and use indirect reference to declaration. + * resolve.c (resolve_fl_variable): Tidy up condition. + (resolve_symbol): The same and only add initialization code if + the symbol is referenced. + * trans-decl.c (gfc_trans_deferred_vars): Call gfc_trans_ + deferred_array before gfc_trans_auto_array_allocation. + + PR fortran/21730 + * symbol.c (check_done): Remove. + (gfc_add_attribute): Remove reference to check_done and remove + the argument attr_intent. + (gfc_add_allocatable, gfc_add_dimension, gfc_add_external, + gfc_add_intrinsic, gfc_add_optional, gfc_add_pointer, + gfc_add_cray_pointer, gfc_add_cray_pointee, gfc_add_result, + gfc_add_target, gfc_add_in_common, gfc_add_elemental, + gfc_add_pure, gfc_add_recursive, gfc_add_procedure, + gfc_add_type): Remove references to check_done. + * decl.c (attr_decl1): Eliminate third argument in call to + gfc_add_attribute. + * gfortran.h : Change prototype for gfc_add_attribute. + + PR fortran/29431 + * trans-array.c (get_array_ctor_strlen): If we fall through to + default, use a constant character length if it is available. + + PR fortran/29758 + * check.c (gfc_check_reshape): Check that there are enough + elements in the source array as to be able to fill an array + defined by shape, when pad is absent. + + PR fortran/29315 + * trans-expr.c (is_aliased_array): Treat correctly the case where the + component is itself and array or array reference. + 2006-11-10 Tobias Burnus PR fortran/29454 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index fdbd0038835a..8fc59dc6ab7e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2110,6 +2110,7 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape, gfc_expr * pad, gfc_expr * order) { mpz_t size; + mpz_t nelems; int m; if (array_check (source, 0) == FAILURE) @@ -2149,6 +2150,38 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape, if (order != NULL && array_check (order, 3) == FAILURE) return FAILURE; + if (pad == NULL + && shape->expr_type == EXPR_ARRAY + && gfc_is_constant_expr (shape) + && !(source->expr_type == EXPR_VARIABLE + && source->symtree->n.sym->as + && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE)) + { + /* Check the match in size between source and destination. */ + if (gfc_array_size (source, &nelems) == SUCCESS) + { + gfc_constructor *c; + bool test; + + c = shape->value.constructor; + mpz_init_set_ui (size, 1); + for (; c; c = c->next) + mpz_mul (size, size, c->expr->value.integer); + + test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0; + mpz_clear (nelems); + mpz_clear (size); + + if (test) + { + gfc_error ("Without padding, there are not enough elements in the " + "intrinsic RESHAPE source at %L to match the shape", + &source->where); + return FAILURE; + } + } + } + return SUCCESS; } diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 85e5d3d8478d..623ea177cb7c 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3297,7 +3297,7 @@ attr_decl1 (void) goto cleanup; } - if (gfc_add_attribute (&sym->attr, &var_locus, current_attr.intent) == FAILURE) + if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 80d70199d29d..4ceb0b152f40 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1839,7 +1839,7 @@ void gfc_get_component_attr (symbol_attribute *, gfc_component *); void gfc_set_sym_referenced (gfc_symbol * sym); -try gfc_add_attribute (symbol_attribute *, locus *, unsigned int); +try gfc_add_attribute (symbol_attribute *, locus *); try gfc_add_allocatable (symbol_attribute *, locus *); try gfc_add_dimension (symbol_attribute *, const char *, locus *); try gfc_add_external (symbol_attribute *, locus *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b1ea68c118c9..eb1200c94c2e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5497,8 +5497,11 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) } /* Assign default initializer. */ - if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer - && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT)) + if (sym->ts.type == BT_DERIVED + && !sym->value + && !sym->attr.pointer + && !sym->attr.allocatable + && (!flag || sym->attr.intent == INTENT_OUT)) sym->value = gfc_default_initializer (&sym->ts); return SUCCESS; @@ -6036,8 +6039,12 @@ resolve_symbol (gfc_symbol * sym) /* If we have come this far we can apply default-initializers, as described in 14.7.5, to those variables that have not already been assigned one. */ - if (sym->ts.type == BT_DERIVED && sym->ns == gfc_current_ns && !sym->value - && !sym->attr.allocatable && !sym->attr.alloc_comp) + if (sym->ts.type == BT_DERIVED + && sym->attr.referenced + && sym->ns == gfc_current_ns + && !sym->value + && !sym->attr.allocatable + && !sym->attr.alloc_comp) { symbol_attribute *a = &sym->attr; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index cd38ef8dae49..c93be4296b61 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -589,28 +589,6 @@ check_used (symbol_attribute * attr, const char * name, locus * where) } -/* Used to prevent changing the attributes of a symbol after it has been - used. This check is only done for dummy variables as only these can be - used in specification expressions. Applying this to all symbols causes - an error when we reach the body of a contained function. */ - -static int -check_done (symbol_attribute * attr, locus * where) -{ - - if (!(attr->dummy && attr->referenced)) - return 0; - - if (where == NULL) - where = &gfc_current_locus; - - gfc_error ("Cannot change attributes of symbol at %L" - " after it has been used", where); - - return 1; -} - - /* Generate an error because of a duplicate attribute. */ static void @@ -626,12 +604,9 @@ duplicate_attr (const char *attr, locus * where) /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */ try -gfc_add_attribute (symbol_attribute * attr, locus * where, - unsigned int attr_intent) +gfc_add_attribute (symbol_attribute * attr, locus * where) { - - if (check_used (attr, NULL, where) - || (attr_intent == 0 && check_done (attr, where))) + if (check_used (attr, NULL, where)) return FAILURE; return check_conflict (attr, NULL, where); @@ -641,7 +616,7 @@ try gfc_add_allocatable (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->allocatable) @@ -659,7 +634,7 @@ try gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, name, where) || check_done (attr, where)) + if (check_used (attr, name, where)) return FAILURE; if (attr->dimension) @@ -677,7 +652,7 @@ try gfc_add_external (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->external) @@ -696,7 +671,7 @@ try gfc_add_intrinsic (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->intrinsic) @@ -715,7 +690,7 @@ try gfc_add_optional (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->optional) @@ -733,7 +708,7 @@ try gfc_add_pointer (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; attr->pointer = 1; @@ -745,7 +720,7 @@ try gfc_add_cray_pointer (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; attr->cray_pointer = 1; @@ -757,7 +732,7 @@ try gfc_add_cray_pointee (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->cray_pointee) @@ -776,7 +751,7 @@ try gfc_add_result (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, name, where) || check_done (attr, where)) + if (check_used (attr, name, where)) return FAILURE; attr->result = 1; @@ -834,7 +809,7 @@ try gfc_add_target (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->target) @@ -865,7 +840,7 @@ try gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, name, where) || check_done (attr, where)) + if (check_used (attr, name, where)) return FAILURE; /* Duplicate attribute already checked for. */ @@ -933,7 +908,7 @@ try gfc_add_elemental (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; attr->elemental = 1; @@ -945,7 +920,7 @@ try gfc_add_pure (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; attr->pure = 1; @@ -957,7 +932,7 @@ try gfc_add_recursive (symbol_attribute * attr, locus * where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; attr->recursive = 1; @@ -1061,7 +1036,7 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t, const char *name, locus * where) { - if (check_used (attr, name, where) || check_done (attr, where)) + if (check_used (attr, name, where)) return FAILURE; if (attr->flavor != FL_PROCEDURE @@ -1170,10 +1145,6 @@ gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where) { sym_flavor flavor; -/* TODO: This is legal if it is reaffirming an implicit type. - if (check_done (&sym->attr, where)) - return FAILURE;*/ - if (where == NULL) where = &gfc_current_locus; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6fd93dd37457..2a5b3b72e139 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1416,7 +1416,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len) case EXPR_ARRAY: if (!get_array_ctor_strlen (c->expr->value.constructor, len)) - is_const = FALSE; + is_const = false; break; case EXPR_VARIABLE: @@ -1425,7 +1425,15 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len) break; default: - is_const = FALSE; + is_const = false; + + /* Hope that whatever we have possesses a constant character + length! */ + if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl) + { + gfc_conv_const_charlen (c->expr->ts.cl); + *len = c->expr->ts.cl->backend_decl; + } /* TODO: For now we just ignore anything we don't know how to handle, and hope we can figure it out a different way. */ break; @@ -4744,6 +4752,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); + /* If this an array of derived types with allocatable components build a loop and recursively call this function. */ if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d12b953cf9e5..b7c93010a1ed 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2534,6 +2534,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) gfc_symbol *sym; gfc_formal_arglist *f; stmtblock_t body; + bool seen_trans_deferred_array = false; /* Deal with implicit return variables. Explicit return variables will already have been added. */ @@ -2590,10 +2591,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) if (TREE_STATIC (sym->backend_decl)) gfc_trans_static_array_pointer (sym); else - fnbody = gfc_trans_deferred_array (sym, fnbody); + { + seen_trans_deferred_array = true; + fnbody = gfc_trans_deferred_array (sym, fnbody); + } } else { + if (sym_has_alloc_comp) + { + seen_trans_deferred_array = true; + fnbody = gfc_trans_deferred_array (sym, fnbody); + } + gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); fnbody = gfc_trans_auto_array_allocation (sym->backend_decl, @@ -2619,14 +2629,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) break; case AS_DEFERRED: - if (!sym_has_alloc_comp) - fnbody = gfc_trans_deferred_array (sym, fnbody); + seen_trans_deferred_array = true; + fnbody = gfc_trans_deferred_array (sym, fnbody); break; default: gcc_unreachable (); } - if (sym_has_alloc_comp) + if (sym_has_alloc_comp && !seen_trans_deferred_array) fnbody = gfc_trans_deferred_array (sym, fnbody); } else if (sym_has_alloc_comp) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b1f50ef43e1d..f9aeb6522ae3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1838,7 +1838,8 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, return; } -/* Is true if the last array reference is followed by a component reference. */ +/* Is true if an array reference is followed by a component or substring + reference. */ static bool is_aliased_array (gfc_expr * e) @@ -1849,10 +1850,11 @@ is_aliased_array (gfc_expr * e) seen_array = false; for (ref = e->ref; ref; ref = ref->next) { - if (ref->type == REF_ARRAY) + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT) seen_array = true; - if (ref->next == NULL + if (seen_array && ref->type != REF_ARRAY) return seen_array; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ac8080706c91..4fd08b73fda3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,20 @@ +2006-11-12 Paul Thomas + + PR fortran/29699 + * gfortran.dg/alloc_comp_auto_array_1.f90: New test. + + PR fortran/21730 + * gfortran.dg/change_symbol_attributes_1.f90: New test. + + PR fortran/29431 + * gfortran.dg/array_constructor_13.f90: New test. + + PR fortran/29758 + * gfortran.dg/reshape_source_size_1.f90: New test. + + PR fortran/29315 + * gfortran.dg/aliasing_dummy_4.f90: New test. + 2006-11-11 Richard Sandiford PR middle-end/27528 diff --git a/gcc/testsuite/gfortran.dg/aliasing_dummy_4.f90 b/gcc/testsuite/gfortran.dg/aliasing_dummy_4.f90 new file mode 100644 index 000000000000..826ada162775 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/aliasing_dummy_4.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! This tests the fix for PR29315, in which array components of derived type arrays were +! not correctly passed to procedures because of a fault in the function that detects +! these references that do not have the span of a natural type. +! +! Contributed by Stephen Jeffrey +! +program test_f90 + + integer, parameter :: N = 2 + + type test_type + integer a(N, N) + end type + + type (test_type) s(N, N) + + forall (l = 1:N, m = 1:N) & + s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N]) + + call test_sub(s%a(1, 1), 1000) ! Test the original problem. + + if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) call abort () + if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort () + if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort () + if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort () + + call test_sub(s(1, 1)%a(:, :), 1000) ! Check "normal" references. + + if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) call abort () + if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort () + if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort () + if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort () +contains + subroutine test_sub(array, offset) + integer array(:, :), offset + + forall (i = 1:N, j = 1:N) & + array(i, j) = array(i, j) + offset + end subroutine +end program + diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90 new file mode 100644 index 000000000000..915b2108f46b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! Fix for PR29699 - see below for details. +! +! Contributed by Tobias Burnus +! +PROGRAM vocabulary_word_count + + IMPLICIT NONE + TYPE VARYING_STRING + CHARACTER,DIMENSION(:),ALLOCATABLE :: chars + ENDTYPE VARYING_STRING + + INTEGER :: list_size=200 + + call extend_lists2 + +CONTAINS + +! First the original problem: vocab_swap not being referenced caused +! an ICE because default initialization is used, which results in a +! call to gfc_conv_variable, which calls gfc_get_symbol_decl. + + SUBROUTINE extend_lists1 + type(VARYING_STRING),DIMENSION(list_size) :: vocab_swap + ENDSUBROUTINE extend_lists1 + +! Curing this then uncovered two more problems: If vocab_swap were +! actually referenced, an ICE occurred in the gimplifier because +! the declaration for this automatic array is presented as a +! pointer to the array, rather than the array. Curing this allows +! the code to compile but it bombed out at run time because the +! malloc/free occurred in the wrong order with respect to the +! nullify/deallocate of the allocatable components. + + SUBROUTINE extend_lists2 + type(VARYING_STRING),DIMENSION(list_size) :: vocab_swap + allocate (vocab_swap(1)%chars(10)) + if (.not.allocated(vocab_swap(1)%chars)) call abort () + if (allocated(vocab_swap(10)%chars)) call abort () + ENDSUBROUTINE extend_lists2 + +ENDPROGRAM vocabulary_word_count diff --git a/gcc/testsuite/gfortran.dg/array_constructor_13.f90 b/gcc/testsuite/gfortran.dg/array_constructor_13.f90 new file mode 100644 index 000000000000..bacc6fffc38f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_constructor_13.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! Tests patch for PR29431, which arose from PR29373. +! +! Contributed by Tobias Schlueter +! + implicit none + CHARACTER(len=6), DIMENSION(2,2) :: a + +! Reporters original triggered another error: +! gfc_todo: Not Implemented: complex character array +! constructors. + + a = reshape([to_string(1.0), trim("abcdef"), & + to_string(7.0), trim("hijklm")], & + [2, 2]) + print *, a + + CONTAINS + FUNCTION to_string(x) + character*6 to_string + REAL, INTENT(in) :: x + WRITE(to_string, FMT="(F6.3)") x + END FUNCTION +end diff --git a/gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90 b/gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90 new file mode 100644 index 000000000000..9b6ed37693be --- /dev/null +++ b/gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Fix for PR21730 - declarations used to produce the error: +! target :: x ! these 2 lines interchanged +! 1 +! Error: Cannot change attributes of symbol at (1) after it has been used. +! +! Contributed by Harald Anlauf +! +subroutine gfcbug27 (x) + real, intent(inout) :: x(:) + + real :: tmp(size (x,1)) ! gfc produces an error unless + target :: x ! these 2 lines interchanged + real, pointer :: p(:) + + p => x(:) +end subroutine gfcbug27 diff --git a/gcc/testsuite/gfortran.dg/reshape_source_size_1.f90 b/gcc/testsuite/gfortran.dg/reshape_source_size_1.f90 new file mode 100644 index 000000000000..8290f6135773 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reshape_source_size_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests patch for PR29758, which arose from PR29431. There was no check that there +! were enough elements in the source to match the shape. +! +! Contributed by Paul Thomas +! + real :: a(2,2), b = 1.0, c(3), d(4) + a = reshape ([b], [2,2]) ! { dg-error "not enough elements" } + a = reshape (c, [2,2]) ! { dg-error "not enough elements" } + a = reshape (d, [2,2]) +end