aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog18
-rw-r--r--gcc/fortran/trans-array.c31
-rw-r--r--gcc/fortran/trans-decl.c16
-rw-r--r--gcc/fortran/trans.h3
-rw-r--r--gcc/testsuite/ChangeLog14
-rw-r--r--gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f902
-rw-r--r--gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f902
-rw-r--r--gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f9026
-rw-r--r--gcc/testsuite/gfortran.dg/array_constructor_23.f47
9 files changed, 148 insertions, 11 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 763e2f2..abcc336 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2008-04-19 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/35944
+ PR fortran/35946
+ PR fortran/35947
+ * trans_array.c (gfc_trans_array_constructor): Temporarily
+ realign loop, if loop->from is not zero, before creating
+ the temporary array and provide an offset.
+
+ PR fortran/35959
+ * trans-decl.c (gfc_init_default_dt): Add gfc_ prefix to name
+ and allow for NULL body. Change all references from
+ init_default_dt to gfc_init_default_dt.
+ * trans.h : Add prototype for gfc_init_default_dt.
+ * trans-array.c (gfc_trans_deferred_vars): After nullification
+ call gfc_init_default_dt for derived types with allocatable
+ components.
+
2008-04-18 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/35892
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 3de1fb71..7bac68d 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1679,6 +1679,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
tree offsetvar;
tree desc;
tree type;
+ tree loopfrom;
bool dynamic;
if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER)
@@ -1757,9 +1758,34 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
}
}
+ /* Temporarily reset the loop variables, so that the returned temporary
+ has the right size and bounds. This seems only to be necessary for
+ 1D arrays. */
+ if (!integer_zerop (loop->from[0]) && loop->dimen == 1)
+ {
+ loopfrom = loop->from[0];
+ loop->from[0] = gfc_index_zero_node;
+ loop->to[0] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ loop->to[0], loopfrom);
+ }
+ else
+ loopfrom = NULL_TREE;
+
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
type, dynamic, true, false);
+ if (loopfrom != NULL_TREE)
+ {
+ loop->from[0] = loopfrom;
+ loop->to[0] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ loop->to[0], loopfrom);
+ /* In the case of a non-zero from, the temporary needs an offset
+ so that subsequent indexing is correct. */
+ ss->data.info.offset = fold_build1 (NEGATE_EXPR,
+ gfc_array_index_type,
+ loop->from[0]);
+ }
+
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
@@ -5569,6 +5595,11 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
rank = sym->as ? sym->as->rank : 0;
tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
gfc_add_expr_to_block (&fnblock, tmp);
+ if (sym->value)
+ {
+ tmp = gfc_init_default_dt (sym, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
}
else if (!GFC_DESCRIPTOR_TYPE_P (type))
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 6f430cb..e693f72 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -512,9 +512,6 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
SAVE_EXPLICIT. */
if (!sym->attr.use_assoc
&& (sym->attr.save != SAVE_NONE || sym->attr.data
- || (sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp
- && sym->value)
|| (sym->value && sym->ns->proc_name->attr.is_main_program)))
TREE_STATIC (decl) = 1;
@@ -2532,8 +2529,8 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
/* Initialize a derived type by building an lvalue from the symbol
and using trans_assignment to do the work. */
-static tree
-init_default_dt (gfc_symbol * sym, tree body)
+tree
+gfc_init_default_dt (gfc_symbol * sym, tree body)
{
stmtblock_t fnblock;
gfc_expr *e;
@@ -2553,7 +2550,8 @@ init_default_dt (gfc_symbol * sym, tree body)
}
gfc_add_expr_to_block (&fnblock, tmp);
gfc_free_expr (e);
- gfc_add_expr_to_block (&fnblock, body);
+ if (body)
+ gfc_add_expr_to_block (&fnblock, body);
return gfc_finish_block (&fnblock);
}
@@ -2571,7 +2569,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
&& f->sym->ts.type == BT_DERIVED
&& !f->sym->ts.derived->attr.alloc_comp
&& f->sym->value)
- body = init_default_dt (f->sym, body);
+ body = gfc_init_default_dt (f->sym, body);
gfc_add_expr_to_block (&fnblock, body);
return gfc_finish_block (&fnblock);
@@ -2672,7 +2670,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = init_default_dt (sym, fnbody);
+ fnbody = gfc_init_default_dt (sym, fnbody);
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
@@ -2732,7 +2730,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = init_default_dt (sym, fnbody);
+ fnbody = gfc_init_default_dt (sym, fnbody);
else
gcc_unreachable ();
}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4134336..1dfb0a5 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -405,6 +405,9 @@ tree gfc_get_symbol_decl (gfc_symbol *);
/* Build a static initializer. */
tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool);
+/* Assign a default initializer to a derived type. */
+tree gfc_init_default_dt (gfc_symbol *, tree);
+
/* Substitute a temporary variable in place of the real one. */
void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 22da23b..2d3ab19 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,17 @@
+2008-04-19 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/35944
+ PR fortran/35946
+ PR fortran/35947
+ * gfortran.dg/array_constructor_23.f: New test.
+
+ PR fortran/35959
+ * gfortran.dg/alloc_comp_default_init_2.f90: New test.
+ * gfortran.dg/alloc_comp_basics_1.f90: Change occurrences of
+ "builtin_free" to 27.
+ * gfortran.dg/alloc_comp_constructor_1.f90: Change occurrences
+ of "builtin_free" to 21.
+
2008-04-18 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/35892
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
index fc58bf4..11f655e 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
@@ -139,6 +139,6 @@ contains
end subroutine check_alloc2
end program alloc
-! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 27 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "alloc_m" } }
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
index 969e703..91145e7 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
@@ -104,5 +104,5 @@ contains
end function blaha
end program test_constructor
-! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f90
new file mode 100644
index 0000000..db106cc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! Tests the fix for PR35959, in which the structure subpattern was declared static
+! so that this test faied on the second recursive call.
+!
+! Contributed by Michaël Baudin <michael.baudin@gmail.com>
+!
+program testprog
+ type :: t_type
+ integer, dimension(:), allocatable :: chars
+ end type t_type
+ integer, save :: callnb = 0
+ type(t_type) :: this
+ allocate ( this % chars ( 4))
+ if (.not.recursivefunc (this) .or. (callnb .ne. 10)) call abort ()
+contains
+ recursive function recursivefunc ( this ) result ( match )
+ type(t_type), intent(in) :: this
+ type(t_type) :: subpattern
+ logical :: match
+ callnb = callnb + 1
+ match = (callnb == 10)
+ if ((.NOT. allocated (this % chars)) .OR. match) return
+ allocate ( subpattern % chars ( 4 ) )
+ match = recursivefunc ( subpattern )
+ end function recursivefunc
+end program testprog
diff --git a/gcc/testsuite/gfortran.dg/array_constructor_23.f b/gcc/testsuite/gfortran.dg/array_constructor_23.f
new file mode 100644
index 0000000..3eeedba
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_constructor_23.f
@@ -0,0 +1,47 @@
+! { dg-do run }
+! Tests the fix for PR35944/6/7, in which the variable array constructors below
+! were incorrectly translated and wrong code was produced.
+!
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+!
+ program try_fa6013
+ call fa6013 (10, 1, -1)
+ call fa6077 (10, 1, -1, (/1,2,3,4,5,6,7,8,9,10/))
+ call fa2083
+ end program
+
+ subroutine FA6013 (nf10, nf1, mf1)
+ integer, parameter :: kv = 4
+ REAL(KV) DDA1(10)
+ REAL(KV) DDA2(10)
+ REAL(KV) DDA(10), dval
+ dda = (/1,2,3,4,5,6,7,8,9,10/)
+ DDA1 = ATAN2 ((/(REAL(J1,KV),J1=1,10)/),
+ $ REAL((/(J1,J1=nf10,nf1,mf1)/), KV)) !fails
+ DDA2 = ATAN2 (DDA, DDA(10:1:-1))
+ if (any (DDA1 .ne. DDA2)) call abort ()
+ END
+
+ subroutine FA6077 (nf10,nf1,mf1, ida)
+ INTEGER IDA1(10)
+ INTEGER IDA2(10), ida(10)
+ IDA1 = IEOR((/1,2,3,4,5,6,7,8,9,10/),
+ $ (/(IDA(J1),J1=10,1,-1)/) )
+ IDA2 = IEOR ((/1,2,3,4,5,6,7,8,9,10/), (/10,9,8,7,6,5,4,3,2,1/) )
+ if (any (ida1 .ne. ida2)) call abort ()
+ END SUBROUTINE
+
+ subroutine fa2083
+ implicit none
+ integer j1,k
+ parameter (k=10) !failed
+ REAL(k) QDA1(10)
+ REAL(k) QDA(10), qval
+ qda = (/ 1,2,3,4,5,6,7,8,9,10 /)
+ QDA1 = MOD ( 1.1_k*( QDA(1) -5.0_k), P=( QDA -2.5_k))
+ DO J1 = 1,10
+ QVAL = MOD(1.1_k*(QDA(1)-5.0_k),P=(QDA(J1)-2.5_k))
+ if (qval .ne. qda1(j1)) call abort ()
+ ENDDO
+ END
+
generated by cgit v1.1 at 2025-06-03 19:46:05 +0000