From 7114edca021e3251ec74acf93e9ebe18b128c87a Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 9 Nov 2006 18:42:28 +0000 Subject: [PATCH] re PR fortran/29699 (ICE in trans-decl.c) 2006-11-09 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. 2006-11-09 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. From-SVN: r118624 --- gcc/fortran/ChangeLog | 25 ++++++++ gcc/fortran/decl.c | 2 +- gcc/fortran/gfortran.h | 2 +- gcc/fortran/resolve.c | 15 +++-- gcc/fortran/symbol.c | 63 +++++-------------- gcc/fortran/trans-array.c | 3 + gcc/fortran/trans-decl.c | 18 ++++-- gcc/testsuite/ChangeLog | 8 +++ .../gfortran.dg/alloc_comp_auto_array_1.f90 | 42 +++++++++++++ .../change_symbol_attributes_1.f90 | 17 +++++ 10 files changed, 139 insertions(+), 56 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 876663410383..fcd1c4ea7e30 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,28 @@ +2006-11-09 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. + 2006-11-08 Brooks Moses * invoke.texi: Added documentation for -fmax-errors option. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index ec3ce2ee8923..6c5cfcc411ea 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3330,7 +3330,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 40dbbe1ad276..05292375c2e4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1838,7 +1838,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 8cf967808c60..872713f6fe54 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 07bf2650ad29..fce6db46a87d 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -601,28 +601,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 @@ -638,12 +616,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); @@ -653,7 +628,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) @@ -671,7 +646,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) @@ -689,7 +664,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) @@ -708,7 +683,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) @@ -727,7 +702,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) @@ -745,7 +720,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; @@ -757,7 +732,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; @@ -769,7 +744,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) @@ -788,7 +763,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; @@ -866,7 +841,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) @@ -897,7 +872,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. */ @@ -965,7 +940,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; @@ -977,7 +952,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; @@ -989,7 +964,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; @@ -1093,7 +1068,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 @@ -1202,10 +1177,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..75f34198a0ff 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4744,6 +4744,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 262c1a03e42a..1a916ccf93d1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2591,6 +2591,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. */ @@ -2647,10 +2648,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, @@ -2676,14 +2686,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/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7980bf9e258e..d2dd8722a5ce 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2006-11-09 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. + 2006-11-09 Andreas Krebbel * gcc.dg/20061109-1.c: New testcase. 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/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 -- 2.43.5