------- Comment #3 from paul dot richard dot thomas at cea dot fr 2006-04-10
14:48 -------
A patch (not regtested yet, nor tested on tonto) and testcase for this and
PR25597:
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (révision 112529)
+++ gcc/fortran/trans-decl.c (copie de travail)
@@ -2536,6 +2536,12 @@
{
tree result = TREE_VALUE (current_fake_result_decl);
fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
+
+ /* An automatic character length, pointer array result. */
+ if (proc_sym->ts.type == BT_CHARACTER
+ && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+ fnbody);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (révision 112529)
+++ gcc/fortran/trans-array.c (copie de travail)
@@ -4385,7 +4385,14 @@
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ /* If the backend_decl is not a descriptor, we must have a pointer
+ to one. */
+ descriptor = build_fold_indirect_ref (sym->backend_decl);
+ type = TREE_TYPE (descriptor);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ }
/* NULLIFY the data pointer. */
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
! { dg-do run }
! Tests the fixes for PR25597 and PR27096.
!
! This test combines the PR testcases.
!
character(10), dimension (2) :: implicit_result
character(10), dimension (2) :: explicit_result
character(10), dimension (2) :: source
source = "abcdefghij"
explicit_result = join_1(source)
if (any (explicit_result .ne. source)) call abort ()
implicit_result = reallocate_hnv (source, size(source, 1), LEN (source))
if (any (implicit_result .ne. source)) call abort ()
contains
! This function would cause an ICE in gfc_trans_deferred_array.
function join_1(self) result(res)
character(len=*), dimension(:) :: self
character(len=len(self)), dimension(:), pointer :: res
allocate (res(2))
res = self
end function
! This function originally ICEd and latterly caused a runtime error.
FUNCTION reallocate_hnv(p, n, LEN)
CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv
character(*), dimension(:) :: p
ALLOCATE (reallocate_hnv(n))
reallocate_hnv = p
END FUNCTION reallocate_hnv
end
Paul
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=27096
