Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

Paul Richard Thomas paul.richard.thomas@gmail.com
Fri Jan 8 23:09:00 GMT 2016


Dear All,

As promised, please find attached the version of this patch for
5-branch. The changes are small enough that I couldn't immediately see
any changes required in the text of the ChangeLog. I will look more
carefully tomorrow, add the "backported from trunk"s and the current
date. I intend to commit on Sunday evening, unless there is any
objection.

Bootstrapped and regtested in 5-branch on FC21/x86_64

Cheers

Paul

On 18 December 2015 at 19:12, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> In running through the PRs assigned to me, I realised that I have not
> closed these PRs because I had promised to see if the patch would
> apply to 4.9 and 5 branch.
>
> I have just applied the patch to 5 branch and have found that, apart
> from two minor tweaks in trans.c, all was well. It bootstrapped
>  and regtested fine, apart from deferred_character_2.f90. In this
> latter, deferred length SOURCE and MOLD do not work because the
> requisite patches in gfc_trans_allocate were not backported.  In
> addition, I had to add explicit array specifications to the allocate
> statements.
>
> Should I get deferred length SOURCE and MOLD to work or apply the
> attached patch as it stands? Alternatively, I could forget about 4.9
> and 5 branches and close the PRs.
>
> I have added the ChangeLogs below.
>
> Cheers
>
> Paul
>
> 2015-12-18  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/50221
>     PR fortran/68216
>     PR fortran/63932
>     PR fortran/66408
>     * trans_array.c (gfc_conv_scalarized_array_ref): Pass the
>     symbol decl for deferred character length array references.
>     * trans-stmt.c (gfc_trans_allocate): Keep the string lengths
>     to update deferred length character string lengths.
>     * trans-types.c (gfc_get_dtype_rank_type); Use the string
>     length of deferred character types for the dtype size.
>     * trans.c (gfc_build_array_ref): For references to deferred
>     character arrays, use the domain max value, if it is a variable
>     to set the 'span' and use pointer arithmetic for acces to the
>     element.
>     (trans_code): Set gfc_current_locus for diagnostic purposes.
>
>     PR fortran/67674
>     * trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
>     string lengths of components.
>
>     PR fortran/49954
>     * resolve.c (deferred_op_assign): New function.
>     (gfc_resolve_code): Call it.
>     * trans-array.c (concat_str_length): New function.
>     (gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
>     realloc blocks for deferred character length arrays because the
>     string length might change, even if the shape is the same. Call
>     concat_str_length to obtain the string length for concatenation
>     since it is needed to compute the lhs string length.
>     Set the descriptor dtype appropriately for the new string
>     length.
>     * trans-expr.c (gfc_trans_assignment_1): Use the rse string
>     length for all characters, other than deferred types. For
>     concatenation operators, push the rse.pre block to the inner
>     most loop so that the temporary pointer and the assignments
>     are properly placed.
>
> 2015-12-18  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/50221
>     * gfortran.dg/deferred_character_1.f90: New test.
>     * gfortran.dg/deferred_character_4.f90: New test for comment
>     #4 of the PR.
>
>     PR fortran/68216
>     * gfortran.dg/deferred_character_2.f90: New test.
>
>     PR fortran/67674
>     * gfortran.dg/deferred_character_3.f90: New test.
>
>     PR fortran/63932
>     * gfortran.dg/deferred_character_5.f90: New test.
>
>     PR fortran/66408
>     * gfortran.dg/deferred_character_6.f90: New test.
>
>     PR fortran/49954
>     * gfortran.dg/deferred_character_7.f90: New test.
>
> On 15 November 2015 at 15:13, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
>> Dear Steve,
>>
>> Thanks for the review.
>>
>> Committed as revision 230396.
>>
>> My diagnosis of the last problem that Dominique found is correct.
>> However, I have not succeeded in fixing it and so the patch was
>> committed as review. I'll just have to return to the problem this
>> evening.
>>
>> Cheers
>>
>> Paul
>>
>> On 14 November 2015 at 21:10, Steve Kargl
>> <sgk@troutmask.apl.washington.edu> wrote:
>>> On Sat, Nov 14, 2015 at 07:25:29PM +0100, Paul Richard Thomas wrote:
>>>>
>>>> Following an email from Dominique to me, I think not. In the course of
>>>> fixing PR49954, I put right the setting of the descriptor dtype. Since
>>>> this gets passed to the IO runtime, I think that this is the reason
>>>> for the difference in behaviour.
>>>>
>>>> I think that another week of effort should put right gfortran's woes
>>>> with deferred characters. As well as concatenation problems that I
>>>> think I have fixed, parentheses cause instant death :-(
>>>>
>>>
>>> Hi Paul,
>>>
>>> I built and tested on both x86_64-*-freebsd and i386-*-freebsd.
>>> All tests passed.
>>>
>>> I read through the patch did not raise any red (or what
>>> the heck is he doing here) flags.
>>>
>>> OK to commit as this is a step in the right direction in
>>> dealing with deferred character issues.
>>>
>>> --
>>> 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
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein
-------------- next part --------------
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 232163)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_transfer (gfc_code *code)
*** 8494,8500 ****
  	  return;
  	}
      }
!    
    if (exp->expr_type == EXPR_STRUCTURE)
      return;
  
--- 8494,8500 ----
  	  return;
  	}
      }
! 
    if (exp->expr_type == EXPR_STRUCTURE)
      return;
  
*************** generate_component_assignments (gfc_code
*** 9993,9998 ****
--- 9993,10042 ----
  }
  
  
+ /* Deferred character length assignments from an operator expression
+    require a temporary because the character length of the lhs can
+    change in the course of the assignment.  */
+ 
+ static bool
+ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
+ {
+   gfc_expr *tmp_expr;
+   gfc_code *this_code;
+ 
+   if (!((*code)->expr1->ts.type == BT_CHARACTER
+ 	 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
+ 	 && (*code)->expr2->expr_type == EXPR_OP))
+     return false;
+ 
+   if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
+     return false;
+ 
+   tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+   tmp_expr->where = (*code)->loc;
+ 
+   /* A new charlen is required to ensure that the variable string
+      length is different to that of the original lhs.  */
+   tmp_expr->ts.u.cl = gfc_get_charlen();
+   tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
+   tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
+   (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
+ 
+   tmp_expr->symtree->n.sym->ts.deferred = 1;
+ 
+   this_code = build_assignment (EXEC_ASSIGN,
+ 				(*code)->expr1,
+ 				gfc_copy_expr (tmp_expr),
+ 				NULL, NULL, (*code)->loc);
+ 
+   (*code)->expr1 = tmp_expr;
+ 
+   this_code->next = (*code)->next;
+   (*code)->next = this_code;
+ 
+   return true;
+ }
+ 
+ 
  /* Given a block of code, recursively resolve everything pointed to by this
     code block.  */
  
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10190,10195 ****
--- 10234,10244 ----
  		goto call;
  	    }
  
+ 	  /* Check for dependencies in deferred character length array
+ 	     assignments and generate a temporary, if necessary.  */
+ 	  if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
+ 	    break;
+ 
  	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
  	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
  	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
*************** gfc_verify_binding_labels (gfc_symbol *s
*** 10562,10568 ****
        sym->binding_label = NULL;
  
      }
!   else if (sym->attr.flavor == FL_VARIABLE && module 
  	   && (strcmp (module, gsym->mod_name) != 0
  	       || strcmp (sym->name, gsym->sym_name) != 0))
      {
--- 10611,10617 ----
        sym->binding_label = NULL;
  
      }
!   else if (sym->attr.flavor == FL_VARIABLE && module
  	   && (strcmp (module, gsym->mod_name) != 0
  	       || strcmp (sym->name, gsym->sym_name) != 0))
      {
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 232163)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3112,3118 ****
      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);
--- 3112,3119 ----
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && (is_subref_array (expr)
! 	       || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 8269,8274 ****
--- 8270,8344 ----
  }
  
  
+ static tree
+ concat_str_length (gfc_expr* expr)
+ {
+   tree type;
+   tree len1;
+   tree len2;
+   gfc_se se;
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+   len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len1 == NULL_TREE)
+     {
+       if (expr->value.op.op1->expr_type == EXPR_OP)
+ 	len1 = concat_str_length (expr->value.op.op1);
+       else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+ 	len1 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op1->value.character.length);
+       else if (expr->value.op.op1->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+ 	  len1 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op1);
+ 	  len1 = se.string_length;
+ 	}
+     }
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+   len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len2 == NULL_TREE)
+     {
+       if (expr->value.op.op2->expr_type == EXPR_OP)
+ 	len2 = concat_str_length (expr->value.op.op2);
+       else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ 	len2 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op2->value.character.length);
+       else if (expr->value.op.op2->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+ 	  len2 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op2);
+ 	  len2 = se.string_length;
+ 	}
+     }
+ 
+   gcc_assert(len1 && len2);
+   len1 = fold_convert (gfc_charlen_type_node, len1);
+   len2 = fold_convert (gfc_charlen_type_node, len2);
+ 
+   return fold_build2_loc (input_location, PLUS_EXPR,
+ 			  gfc_charlen_type_node, len1, len2);
+ }
+ 
+ 
  /* Allocate the lhs of an assignment to an allocatable array, otherwise
     reallocate it.  */
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8366,8371 ****
--- 8436,8447 ----
    /* Allocate if data is NULL.  */
    cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));
+ 
+   if (expr1->ts.deferred)
+     cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+   else
+     cond_null= gfc_evaluate_now (cond_null, &fblock);
+ 
    tmp = build3_v (COND_EXPR, cond_null,
  		  build1_v (GOTO_EXPR, jump_label1),
  		  build_empty_stmt (input_location));
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8454,8460 ****
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
!   neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
       reallocation.  Fix the old descriptor now.  */
--- 8530,8542 ----
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
! 
!   /* If the lhs is deferred length, assume that the element size
!      changes and force a reallocation.  */
!   if (expr1->ts.deferred)
!     neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
!   else
!     neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
       reallocation.  Fix the old descriptor now.  */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8559,8564 ****
--- 8641,8652 ----
        else
  	{
  	  tmp = expr2->ts.u.cl->backend_decl;
+ 	  if (!tmp && expr2->expr_type == EXPR_OP
+ 	      && expr2->value.op.op == INTRINSIC_CONCAT)
+ 	    {
+ 	      tmp = concat_str_length (expr2);
+ 	      expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ 	    }
  	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
  	}
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8586,8591 ****
--- 8674,8695 ----
  			   size2, size_one_node);
    size2 = gfc_evaluate_now (size2, &fblock);
  
+   /* For deferred character length, the 'size' field of the dtype might
+      have changed so set the dtype.  */
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+       && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+     {
+       tree type;
+       tmp = gfc_conv_descriptor_dtype (desc);
+       if (expr2->ts.u.cl->backend_decl)
+ 	type = gfc_typenode_for_spec (&expr2->ts);
+       else
+ 	type = gfc_typenode_for_spec (&expr1->ts);
+ 
+       gfc_add_modify (&fblock, tmp,
+ 		      gfc_get_dtype_rank_type (expr1->rank,type));
+     }
+ 
    /* Realloc expression.  Note that the scalarizer uses desc.data
       in the array reference - (*desc.data)[<element>].  */
    gfc_init_block (&realloc_block);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8628,8635 ****
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
!   tmp = gfc_conv_descriptor_dtype (desc);
!   gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
--- 8732,8747 ----
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
! 
!   /* We already set the dtype in the case of deferred character
!      length arrays.  */
!   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
!         && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
!     {
!       tmp = gfc_conv_descriptor_dtype (desc);
!       gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
!     }
! 
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 232163)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5343,5349 ****
  	  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);
  	    }
--- 5343,5350 ----
  	  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);
  	    }
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 8998,9005 ****
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
    else
      string_length = NULL_TREE;
  
--- 8999,9008 ----
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+   else if (expr2->ts.type == BT_CHARACTER)
+     string_length = rse.string_length;
    else
      string_length = NULL_TREE;
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9033,9040 ****
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.  */
!   if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
--- 9036,9049 ----
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.
!      NOTE ALSO: The concatenation operation generates a temporary pointer,
!      whose allocation must go to the innermost loop.  */
!   if (flag_realloc_lhs
!       && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
!       && !(lss != gfc_ss_terminator
! 	   && expr2->expr_type == EXPR_OP
! 	   && expr2->value.op.op == INTRINSIC_CONCAT))
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 232163)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5119,5124 ****
--- 5119,5125 ----
    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)
*** 5381,5386 ****
--- 5382,5388 ----
  	  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)
*** 5432,5437 ****
--- 5434,5450 ----
  
        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: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 232163)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 344,349 ****
--- 344,361 ----
  
    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
*** 358,364 ****
  		 || TREE_CODE (decl) == PARM_DECL)
  	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	      && !integer_zerop (GFC_DECL_SPAN(decl)))
! 	   || GFC_DECL_CLASS (decl)))
      {
        if (GFC_DECL_CLASS (decl))
  	{
--- 370,377 ----
  		 || TREE_CODE (decl) == PARM_DECL)
  	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	      && !integer_zerop (GFC_DECL_SPAN(decl)))
! 	   || GFC_DECL_CLASS (decl)
! 	   || span != NULL_TREE))
      {
        if (GFC_DECL_CLASS (decl))
  	{
*************** gfc_build_array_ref (tree base, tree off
*** 377,382 ****
--- 390,397 ----
  	}
        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)
*** 1667,1672 ****
--- 1682,1688 ----
  	  gfc_add_expr_to_block (&block, res);
  	}
  
+       gfc_current_locus = code->loc;
        gfc_set_backend_locus (&code->loc);
  
        switch (code->op)
Index: gcc/testsuite/gfortran.dg/deferred_character_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_1.f90	(revision 0)
--- 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: gcc/testsuite/gfortran.dg/deferred_character_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_2.f90	(working copy)
***************
*** 0 ****
--- 1,89 ----
+ ! { 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 based on the first testcase, from Francisco (Ayyy LMAO). Original
+ ! lines are commented out. The second testcase from this thread is acalled
+ ! at the end of the program.
+ !
+     IMPLICIT NONE
+ 
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
+     character (3), dimension (2) :: array_fijo = ["abc","def"]
+     character (100) :: buffer
+     INTEGER :: largo , cant_lineas , i
+ 
+     write (buffer, "(2a3)") array_fijo
+ 
+ !    WRITE(*,*) ' Escriba un numero para el largo de cada linea'
+ !    READ(*,*) largo
+     largo = LEN (array_fijo)
+ 
+ !    WRITE(*,*) ' Escriba la cantidad de lineas'
+ !    READ(*,*) cant_lineas
+     cant_lineas = size (array_fijo, 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. array_fijo)) call abort
+ 
+ ! The following are additional tests beyond that of the original.
+ ! NOTE: These tests all work in 6 branch but those involving deferred length
+ ! SOURCE or MOLD do not work correctly in 5 branch because the requisite
+ ! patches to gfc_trans_allocate have not been backported.
+ !
+ ! Check that allocation with source = another deferred length is OK
+ !     allocate (array_copia(size (array_lineas, 1)), source = array_lineas)
+ !     if (any (array_copia .ne. array_fijo)) call abort
+ !     deallocate (array_lineas, array_copia)
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with source = a non-deferred length is OK
+      allocate (array_lineas(size (array_fijo, 1)), source = array_fijo)
+      if (any (array_lineas .ne. array_fijo)) call abort
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with MOLD = a non-deferred length is OK
+      allocate (array_copia(4), mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
+      if (size (array_copia, 1) .ne. 4) call abort
+      if (LEN (array_copia) .ne. 2) call abort
+ 
+ ! Check that allocation with MOLD = another deferred length is OK
+ !     allocate (array_lineas(4), mold = array_copia)
+ !     if (size (array_lineas, 1) .ne. 4) call abort
+ !     if (LEN (array_lineas) .ne. 2) call abort
+ !     deallocate (array_lineas, array_copia)
+ 
+ !    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: gcc/testsuite/gfortran.dg/deferred_character_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_3.f90	(revision 0)
--- 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
Index: gcc/testsuite/gfortran.dg/deferred_character_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_4.f90	(working copy)
***************
*** 0 ****
--- 1,30 ----
+ ! { dg-do run }
+ !
+ ! Check that PR50221 comment #4 is fixed.
+ !
+ ! Contributed by Arjen Makus  <arjen.markus895@gmail.com>
+ !
+ program chk_alloc_string
+     implicit none
+ 
+     character(len=:), dimension(:), allocatable :: strings
+     character(20) :: buffer
+     integer :: i
+ 
+     allocate( character(10):: strings(1:3) )
+ 
+     strings = [ "A   ", "C   ", "ABCD", "V   " ]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 4) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) call abort
+ 
+     strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 5) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort
+ 
+     write (buffer, "(5a4)") strings
+     if (buffer .ne. "A   C   ABCDV   zzzz") call abort
+ end program chk_alloc_string
Index: gcc/testsuite/gfortran.dg/deferred_character_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_5.f90	(working copy)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR63932 stays fixed.
+ !
+ ! Contributed by Valery Weber  <valeryweber@hotmail.com>
+ !
+ module mod
+   type :: t
+      character(:), allocatable :: c
+      integer :: i
+    contains
+      procedure, pass :: get
+   end type t
+   type :: u
+      character(:), allocatable :: c
+   end type u
+ contains
+   subroutine get(this, a)
+     class(t), intent(in) :: this
+     character(:), allocatable, intent(out), optional :: a
+     if (present (a)) a = this%c
+   end subroutine get
+ end module mod
+ 
+ program test
+   use mod
+   type(t) :: a
+   type(u) :: b
+   a%c = 'something'
+   call a%get (a = b%c)
+   if (b%c .ne. 'something') call abort
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_6.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_6.f90	(working copy)
***************
*** 0 ****
--- 1,54 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR66408 stays fixed.
+ !
+ ! Contributed by <werner.blokbuster@gmail.com>
+ !
+ module mytest
+ 
+     implicit none
+ 
+     type vary
+         character(:), allocatable :: string
+     end type vary
+ 
+     interface assignment(=)
+         module procedure char_eq_vary
+     end interface assignment(=)
+ 
+ contains
+ 
+     subroutine char_eq_vary(my_char,my_vary)
+         character(:), allocatable, intent(out) :: my_char
+         type(vary), intent(in) :: my_vary
+         my_char = my_vary%string
+     end subroutine char_eq_vary
+ 
+ end module mytest
+ 
+ 
+ program thistest
+ 
+     use mytest, only: vary, assignment(=)
+     implicit none
+ 
+     character(:), allocatable :: test_char
+     character(14), parameter :: str = 'example string'
+     type(vary) :: test_vary
+     type(vary) :: my_stuff
+ 
+ 
+     test_vary%string = str
+     if (test_vary%string .ne. str) call abort
+ 
+ ! This previously gave a blank string.
+     my_stuff%string = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+     test_char = test_vary
+     if (test_char .ne. str) call abort
+ 
+     my_stuff = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+ end program thistest
Index: gcc/testsuite/gfortran.dg/deferred_character_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_7.f90	(working copy)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for pr49954, in which concatenation to deferred length character
+ ! arrays, at best, did not work correctly.
+ !
+ !
+ !
+ implicit none
+   character(len=:), allocatable :: a1(:)
+   character(len=:), allocatable :: a2(:), a3(:)
+   character(len=:), allocatable :: b1
+   character(len=:), allocatable :: b2
+   character(8) :: chr = "IJKLMNOP"
+   character(48) :: buffer
+ 
+   a1 = ["ABCDEFGH","abcdefgh"]
+   a2 = "_"//a1//chr//"_"
+   if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) call abort
+ 
+ ! Check that the descriptor dtype is OK - the array write needs it.
+   write (buffer, "(2a18)") a2
+   if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") call abort
+ 
+ ! Make sure scalars survived the fix!
+   b1 = "ABCDEFGH"
+   b2 = "_"//b1//chr//"_"
+   if (b2 .ne. "_ABCDEFGHIJKLMNOP_") call abort
+ 
+ ! Check the dependency is detected and dealt with by generation of a temporary.
+   a1 = "?"//a1//"?"
+   if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) call abort
+ ! With an array reference...
+   a1 = "?"//a1(1:2)//"?"
+   if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) call abort
+ !... together with a substring.
+   a1 = "?"//a1(1:1)(2:4)//"?"
+   if (any (a1 .ne. ["??AB?"])) call abort
+ contains
+ end


More information about the Gcc-patches mailing list