2006-11-09 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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
+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <brooks.moses@codesourcery.com>
* invoke.texi: Added documentation for -fmax-errors option.
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;
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 *);
}
/* 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;
/* 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;
}
-/* 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
/* 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);
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)
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)
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)
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)
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)
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;
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;
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)
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;
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)
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. */
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;
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;
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;
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
{
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;
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
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. */
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,
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)
+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <krebbel1@de.ibm.com>
* gcc.dg/20061109-1.c: New testcase.
--- /dev/null
+! { dg-do run }
+! Fix for PR29699 - see below for details.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+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
--- /dev/null
+! { 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 <anlauf@gmx.de>
+!
+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
projects / thirdparty / gcc.git / commitdiff
