[Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216 and 67674
Paul Richard Thomas
paul.richard.thomas@gmail.com
Tue Nov 10 09:48:00 GMT 2015
Dear Steve,
I was charging around like a mad thing yesterday and sent the
submission in something of a hurry. Thanks for pointing out the
omission so quickly.
Please find the patch attached.
Cheers
Paul
On 9 November 2015 at 15:46, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Mon, Nov 09, 2015 at 02:38:15PM +0100, Paul Richard Thomas wrote:
>>
>> Boostraps and regtests on FC21/x86_64 - OK for trunk?
>>
>
> Patch seems to have been left behind.
>
> --
> Steve
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
-------------- next part --------------
Index: /svn/trunk/gcc/fortran/trans-array.c
===================================================================
*** /svn/trunk/gcc/fortran/trans-array.c (revision 229953)
--- /svn/trunk/gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3168,3174 ****
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
! if (expr && is_subref_array (expr))
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
--- 3168,3175 ----
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
! if (expr && (is_subref_array (expr)
! || expr->ts.deferred))
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
Index: /svn/trunk/gcc/fortran/trans-expr.c
===================================================================
*** /svn/trunk/gcc/fortran/trans-expr.c (revision 229953)
--- /svn/trunk/gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5601,5607 ****
else
{
tmp = parmse.string_length;
! if (TREE_CODE (tmp) != VAR_DECL)
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
--- 5601,5608 ----
else
{
tmp = parmse.string_length;
! if (TREE_CODE (tmp) != VAR_DECL
! && TREE_CODE (tmp) != COMPONENT_REF)
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
Index: /svn/trunk/gcc/fortran/trans-stmt.c
===================================================================
*** /svn/trunk/gcc/fortran/trans-stmt.c (revision 229953)
--- /svn/trunk/gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5089,5094 ****
--- 5089,5095 ----
tree label_finish;
tree memsz;
tree al_vptr, al_len;
+ tree def_str_len = NULL_TREE;
/* If an expr3 is present, then store the tree for accessing its
_vptr, and _len components in the variables, respectively. The
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
*************** gfc_trans_allocate (gfc_code * code)
*** 5466,5471 ****
--- 5467,5473 ----
expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (se_sz.expr),
tmp, se_sz.expr);
+ def_str_len = gfc_evaluate_now (se_sz.expr, &block);
}
}
*************** gfc_trans_allocate (gfc_code * code)
*** 5517,5522 ****
--- 5519,5535 ----
se.want_pointer = 1;
se.descriptor_only = 1;
+
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.deferred
+ && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
+ && def_str_len != NULL_TREE)
+ {
+ tmp = expr->ts.u.cl->backend_decl;
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp), def_str_len));
+ }
+
gfc_conv_expr (&se, expr);
if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
/* se.string_length now stores the .string_length variable of expr
Index: /svn/trunk/gcc/fortran/trans-types.c
===================================================================
*** /svn/trunk/gcc/fortran/trans-types.c (revision 229954)
--- /svn/trunk/gcc/fortran/trans-types.c (working copy)
*************** gfc_get_dtype_rank_type (int rank, tree
*** 1455,1460 ****
--- 1455,1468 ----
}
gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
+
+ if (TREE_CODE (etype) == ARRAY_TYPE
+ && TYPE_MAXVAL (TYPE_DOMAIN (etype)) != NULL_TREE
+ && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (etype))) == VAR_DECL
+ && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (etype)))
+ == current_function_decl)
+ size = TYPE_MAXVAL (TYPE_DOMAIN (etype));
+ else
size = TYPE_SIZE_UNIT (etype);
i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
Index: /svn/trunk/gcc/fortran/trans.c
===================================================================
*** /svn/trunk/gcc/fortran/trans.c (revision 229953)
--- /svn/trunk/gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 334,339 ****
--- 334,351 ----
type = TREE_TYPE (type);
+ /* Use pointer arithmetic for deferred character length array
+ references. */
+ if (type && TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+ && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+ && decl
+ && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ == DECL_CONTEXT (decl))
+ span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+ else
+ span = NULL_TREE;
+
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
*************** gfc_build_array_ref (tree base, tree off
*** 348,355 ****
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN (decl)))
! || GFC_DECL_CLASS (decl)))
! || vptr)
{
if (decl)
{
--- 360,368 ----
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN (decl)))
! || GFC_DECL_CLASS (decl)
! || span != NULL_TREE))
! || vptr != NULL_TREE)
{
if (decl)
{
*************** gfc_build_array_ref (tree base, tree off
*** 379,384 ****
--- 392,399 ----
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN (decl);
+ else if (span)
+ span = fold_convert (gfc_array_index_type, span);
else
gcc_unreachable ();
}
*************** trans_code (gfc_code * code, tree cond)
*** 1623,1628 ****
--- 1638,1644 ----
gfc_add_expr_to_block (&block, res);
}
+ gfc_current_locus = code->loc;
gfc_set_backend_locus (&code->loc);
switch (code->op)
Index: /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_1.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_1.f90 (revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_1.f90 (working copy)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR50221
+ !
+ ! Contributed by Clive Page <clivegpage@gmail.com>
+ ! and Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ ! This is from comment #2 by Tobias Burnus.
+ !
+ module m
+ character(len=:), save, allocatable :: str(:)
+ character(len=2), parameter :: const(3) = ["a1", "b2", "c3"]
+ end
+
+ use m
+ call test()
+ if(allocated(str)) deallocate(str)
+ call foo
+ contains
+ subroutine test()
+ call doit()
+ ! print *, 'strlen=',len(str),' / array size =',size(str)
+ ! print '(3a)', '>',str(1),'<'
+ ! print '(3a)', '>',str(2),'<'
+ ! print '(3a)', '>',str(3),'<'
+ if (any (str .ne. const)) call abort
+ end subroutine test
+ subroutine doit()
+ str = const
+ end subroutine doit
+ subroutine foo
+ !
+ ! This is the original PR from Clive Page
+ !
+ character(:), allocatable, dimension(:) :: array
+ array = (/'xx', 'yy', 'zz'/)
+ ! print *, 'array=', array, len(array(1)), size(array)
+ if (any (array .ne. ["xx", "yy", "zz"])) call abort
+ end subroutine
+ end
Index: /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_2.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_2.f90 (revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_2.f90 (working copy)
***************
*** 0 ****
--- 1,58 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR68216
+ !
+ ! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
+ !
+ PROGRAM hello
+ !
+ ! This is the first testcase from Francisco (Ayyy LMAO)
+ !
+ IMPLICIT NONE
+
+ CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
+ character (3), dimension (2) :: src = ["abc","def"]
+ character (100) :: buffer
+ INTEGER :: largo , cant_lineas , i
+
+ write (buffer, "(2a3)") src
+
+ ! WRITE(*,*) ' Escriba un numero para el largo de cada linea'
+ ! READ(*,*) largo
+ largo = LEN (src)
+
+ ! WRITE(*,*) ' Escriba la cantidad de lineas'
+ ! READ(*,*) cant_lineas
+ cant_lineas = size (src, 1)
+
+ ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
+
+ ! WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
+ READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
+
+ ! WRITE(*,*) 'Array guardado: '
+ ! DO i=1,cant_lineas
+ ! WRITE(*,*) array_lineas(i)
+ ! ENDDO
+ if (any (array_lineas .ne. src)) call abort
+ ! READ(*,*)
+ call testdefchar
+ contains
+ subroutine testdefchar
+ !
+ ! This is the testcase in the above thread from Blokbuster
+ !
+ implicit none
+ character(:), allocatable :: test(:)
+
+ allocate(character(3) :: test(2))
+ test(1) = 'abc'
+ test(2) = 'def'
+ if (any (test .ne. ['abc', 'def'])) call abort
+
+ test = ['aa','bb','cc']
+ if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
+
+ end subroutine testdefchar
+
+ END PROGRAM
Index: /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_3.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_3.f90 (revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/deferred_character_3.f90 (working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! {dg_do run }
+ !
+ ! Tests the fix for PR67674
+ !
+ ! Contributed by Kristopher Kuhlman <kristopher.kuhlman@gmail.com>
+ !
+ program test
+ implicit none
+
+ type string_type
+ character(len=:), allocatable :: name
+ end type string_type
+ type(string_type), allocatable :: my_string_type
+
+ allocate(my_string_type)
+ allocate(character(len=0) :: my_string_type%name)
+
+ ! print *, 'length main program before',len(my_string_type%name)
+
+ call inputreadword1(my_string_type%name)
+
+ ! print *, 'length main program after',len(my_string_type%name)
+ ! print *, 'final result:',my_string_type%name
+ if (my_string_type%name .ne. 'here the word is finally set') call abort
+
+ contains
+ subroutine inputreadword1(word_intermediate)
+ character(len=:), allocatable :: word_intermediate
+
+ ! print *, 'length intermediate before',len(word_intermediate)
+ call inputreadword2(word_intermediate)
+ ! print *, 'length intermediate after',len(word_intermediate)
+ ! print *, word_intermediate
+
+ end subroutine inputreadword1
+
+ subroutine inputreadword2(word)
+ character(len=:), allocatable :: word
+
+ ! print *, 'length inner before',len(word)
+ word = 'here the word is finally set' ! want automatic reallocation to happen here
+ ! print *, 'length inner after',len(word)
+ ! print *, word
+
+ end subroutine inputreadword2
+ end program test
More information about the Fortran
mailing list