Fortran: Fix some issues with pointers to character.

gcc/fortran/ChangeLog:

	PR fortran/100120
	PR fortran/100816
	PR fortran/100818
	PR fortran/100819
	PR fortran/100821
	* trans-array.c (gfc_get_array_span): rework the way character
	array "span" was calculated.
	(gfc_conv_expr_descriptor): improve handling of character sections
	and unlimited polymorphic objects.
	* trans-expr.c (gfc_get_character_len): new function to calculate
	character string length.
	(gfc_get_character_len_in_bytes): new function to calculate
	character string length in bytes.
	(gfc_conv_scalar_to_descriptor): add call to set the "span".
	(gfc_trans_pointer_assignment): set "_len" and antecipate the
	initialization of the deferred character length hidden argument.
	* trans-intrinsic.c (gfc_conv_associated): set "force_no_tmp" to
	avoid the creation of a temporary.
	* trans-types.c (gfc_get_dtype_rank_type): rework type detection
	so that unlimited polymorphic objects get proper type infomation,
	also important for bind(c).
	(gfc_get_dtype): add argument to pass the rank if necessary.
	(gfc_get_array_type_bounds): cosmetic change to have character
	arrays called character instead of unknown.
	* trans-types.h (gfc_get_dtype): modify prototype.
	* trans.c (get_array_span): rework the way character array "span"
	was calculated.
	* trans.h (gfc_get_character_len): new prototype.
	(gfc_get_character_len_in_bytes): new prototype.
	Add "unlimited_polymorphic" flag to "gfc_se" type to signal when
	expression carries an unlimited polymorphic object.

libgfortran/ChangeLog:

	PR fortran/100120
	* intrinsics/associated.c (associated): have associated verify if
	the "span" matches insted of the "elem_len".
	* libgfortran.h (GFC_DESCRIPTOR_SPAN): add macro to retrive the
	descriptor "span".

gcc/testsuite/ChangeLog:

	PR fortran/100120
	* gfortran.dg/PR100120.f90: New test.
	PR fortran/100816
	PR fortran/100818
	PR fortran/100819
	PR fortran/100821
	* gfortran.dg/character_workout_1.f90: New test.
	* gfortran.dg/character_workout_4.f90: New test.

7 files changed, 154 insertions, 79 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 7eeef55..a6bcd2b 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -860,16 +860,25 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 	 size of the array. Attempt to deal with unbounded character
 	 types if possible. Otherwise, return NULL_TREE.  */
       tmp = gfc_get_element_type (TREE_TYPE (desc));
-      if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
-	  && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
-	      || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
-	{
-	  if (expr->expr_type == EXPR_VARIABLE
-	      && expr->ts.type == BT_CHARACTER)
-	    tmp = fold_convert (gfc_array_index_type,
-				gfc_get_expr_charlen (expr));
-	  else
-	    tmp = NULL_TREE;
+      if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
+	{
+	  gcc_assert (expr->ts.type == BT_CHARACTER);
+	  
+	  tmp = gfc_get_character_len_in_bytes (tmp);
+	  
+	  if (tmp == NULL_TREE || integer_zerop (tmp))
+	    {
+	      tree bs;
+
+	      tmp = gfc_get_expr_charlen (expr);
+	      tmp = fold_convert (gfc_array_index_type, tmp);
+	      bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type, tmp, bs);
+	    }
+	  
+	  tmp = (tmp && !integer_zerop (tmp))
+	    ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
 	}
       else
 	tmp = fold_convert (gfc_array_index_type,
@@ -7328,6 +7337,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       expr = expr->value.function.actual->expr;
     }
 
+  if (!se->direct_byref)
+    se->unlimited_polymorphic = UNLIMITED_POLY (expr);
+  
   /* Special case things we know we can pass easily.  */
   switch (expr->expr_type)
     {
@@ -7351,9 +7363,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  && TREE_CODE (desc) == COMPONENT_REF)
 	deferred_array_component = true;
 
-      subref_array_target = se->direct_byref && is_subref_array (expr);
-      need_tmp = gfc_ref_needs_temporary_p (expr->ref)
-			&& !subref_array_target;
+      subref_array_target = (is_subref_array (expr)
+			     && (se->direct_byref
+				 || expr->ts.type == BT_CHARACTER));
+      need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
+		  && !subref_array_target);
 
       if (se->force_tmp)
 	need_tmp = 1;
@@ -7390,9 +7404,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 				      subref_array_target, expr);
 
 	      /* ....and set the span field.  */
-	      tmp = gfc_get_array_span (desc, expr);
-	      if (tmp != NULL_TREE && !integer_zerop (tmp))
-		gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
+	      tmp = gfc_conv_descriptor_span_get (desc);
+	      gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
 	    }
 	  else if (se->want_pointer)
 	    {
@@ -7607,6 +7620,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       int dim, ndim, codim;
       tree parm;
       tree parmtype;
+      tree dtype;
       tree stride;
       tree from;
       tree to;
@@ -7689,7 +7703,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       else
 	{
 	  /* Otherwise make a new one.  */
-	  if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
+	  if (expr->ts.type == BT_CHARACTER)
 	    parmtype = gfc_typenode_for_spec (&expr->ts);
 	  else
 	    parmtype = gfc_get_element_type (TREE_TYPE (desc));
@@ -7723,11 +7737,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	}
 
       /* Set the span field.  */
-      if (expr->ts.type == BT_CHARACTER && ss_info->string_length)
-	tmp = ss_info->string_length;
-      else
-	tmp = gfc_get_array_span (desc, expr);
-      if (tmp != NULL_TREE)
+      tmp = gfc_get_array_span (desc, expr);
+      if (tmp)
 	gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
 
       /* The following can be somewhat confusing.  We have two
@@ -7741,7 +7752,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
       /* Set the dtype.  */
       tmp = gfc_conv_descriptor_dtype (parm);
-      gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+      if (se->unlimited_polymorphic)
+	dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
+      else
+	dtype = gfc_get_dtype (parmtype);
+      gfc_add_modify (&loop.pre, tmp, dtype);
 
       /* The 1st element in the section.  */
       base = gfc_index_zero_node;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 00690fe..e3bc886 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -42,6 +42,45 @@ along with GCC; see the file COPYING3.  If not see
 #include "dependency.h"
 #include "gimplify.h"
 
+
+/* Calculate the number of characters in a string.  */
+
+tree
+gfc_get_character_len (tree type)
+{
+  tree len;
+  
+  gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
+	      && TYPE_STRING_FLAG (type));
+  
+  len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  len = (len) ? (len) : (integer_zero_node);
+  return fold_convert (gfc_charlen_type_node, len);
+}
+
+
+
+/* Calculate the number of bytes in a string.  */
+
+tree
+gfc_get_character_len_in_bytes (tree type)
+{
+  tree tmp, len;
+  
+  gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
+	      && TYPE_STRING_FLAG (type));
+  
+  tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
+  tmp = (tmp && !integer_zerop (tmp))
+    ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
+  len = gfc_get_character_len (type);
+  if (tmp && len && !integer_zerop (len))
+    len = fold_build2_loc (input_location, MULT_EXPR,
+			   gfc_charlen_type_node, len, tmp);
+  return len;
+}
+
+
 /* Convert a scalar to an array descriptor. To be used for assumed-rank
    arrays.  */
 
@@ -87,6 +126,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
   gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
 		  gfc_get_dtype_rank_type (0, etype));
   gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
+  gfc_conv_descriptor_span_set (&se->pre, desc,
+				gfc_conv_descriptor_elem_len (desc));
 
   /* Copy pointer address back - but only if it could have changed and
      if the actual argument is a pointer and not, e.g., NULL().  */
@@ -9630,11 +9671,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2);
 	  strlen_rhs = lse.string_length;
+	  gfc_init_se (&rse, NULL);
 
 	  if (expr1->ts.type == BT_CLASS)
 	    {
 	      rse.expr = NULL_TREE;
-	      rse.string_length = NULL_TREE;
+	      rse.string_length = strlen_rhs;
 	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
 					       NULL, NULL);
 	    }
@@ -9694,6 +9736,19 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gfc_add_modify (&lse.pre, desc, tmp);
 	}
 
+      if (expr1->ts.type == BT_CHARACTER
+	  && expr1->symtree->n.sym->ts.deferred
+	  && expr1->symtree->n.sym->ts.u.cl->backend_decl
+	  && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
+	{
+	  tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
+	  if (expr2->expr_type != EXPR_NULL)
+	    gfc_add_modify (&block, tmp,
+			    fold_convert (TREE_TYPE (tmp), strlen_rhs));
+	  else
+	    gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
+	}
+
       gfc_add_block_to_block (&block, &lse.pre);
       if (rank_remap)
 	gfc_add_block_to_block (&block, &rse.pre);
@@ -9856,19 +9911,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 				   msg, rsize, lsize);
 	}
 
-      if (expr1->ts.type == BT_CHARACTER
-	  && expr1->symtree->n.sym->ts.deferred
-	  && expr1->symtree->n.sym->ts.u.cl->backend_decl
-	  && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
-	{
-	  tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
-	  if (expr2->expr_type != EXPR_NULL)
-	    gfc_add_modify (&block, tmp,
-			    fold_convert (TREE_TYPE (tmp), strlen_rhs));
-	  else
-	    gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
-	}
-
       /* Check string lengths if applicable.  The check is only really added
 	 to the output code if -fbounds-check is enabled.  */
       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 98fa28d..73b0bcc 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -9080,6 +9080,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 	  gfc_add_block_to_block (&se->post, &arg1se.post);
 
 	  arg2se.want_pointer = 1;
+	  arg2se.force_no_tmp = 1;
 	  gfc_conv_expr_descriptor (&arg2se, arg2->expr);
 	  gfc_add_block_to_block (&se->pre, &arg2se.pre);
 	  gfc_add_block_to_block (&se->post, &arg2se.post);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 9f21b3e..5582e40 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1482,6 +1482,7 @@ gfc_get_desc_dim_type (void)
 tree
 gfc_get_dtype_rank_type (int rank, tree etype)
 {
+  tree ptype;
   tree size;
   int n;
   tree tmp;
@@ -1489,12 +1490,24 @@ gfc_get_dtype_rank_type (int rank, tree etype)
   tree field;
   vec<constructor_elt, va_gc> *v = NULL;
 
-  size = TYPE_SIZE_UNIT (etype);
+  ptype = etype;
+  while (TREE_CODE (etype) == POINTER_TYPE
+	 || TREE_CODE (etype) == ARRAY_TYPE)
+    {
+      ptype = etype;
+      etype = TREE_TYPE (etype);
+    }
+
+  gcc_assert (etype);
 
   switch (TREE_CODE (etype))
     {
     case INTEGER_TYPE:
-      n = BT_INTEGER;
+      if (TREE_CODE (ptype) == ARRAY_TYPE
+	  && TYPE_STRING_FLAG (ptype))
+	n = BT_CHARACTER;
+      else
+	n = BT_INTEGER;
       break;
 
     case BOOLEAN_TYPE:
@@ -1516,27 +1529,36 @@ gfc_get_dtype_rank_type (int rank, tree etype)
 	n = BT_DERIVED;
       break;
 
-    /* We will never have arrays of arrays.  */
-    case ARRAY_TYPE:
-      n = BT_CHARACTER;
-      if (size == NULL_TREE)
-	size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
+    case FUNCTION_TYPE:
+    case VOID_TYPE:
+      n = BT_VOID;
       break;
 
-    case POINTER_TYPE:
-      n = BT_ASSUMED;
-      if (TREE_CODE (TREE_TYPE (etype)) != VOID_TYPE)
-	size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
-      else
-	size = build_int_cst (size_type_node, 0);
-    break;
-
     default:
       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
       /* We can encounter strange array types for temporary arrays.  */
-      return gfc_index_zero_node;
+      gcc_unreachable ();
     }
 
+  switch (n)
+    {
+    case BT_CHARACTER:
+      gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE);
+      size = gfc_get_character_len_in_bytes (ptype);
+      break;
+    case BT_VOID:
+      gcc_assert (TREE_CODE (ptype) == POINTER_TYPE);
+      size = size_in_bytes (ptype);
+      break;
+    default:
+      size = size_in_bytes (etype);
+      break;
+    }
+      
+  gcc_assert (size);
+
+  STRIP_NOPS (size);
+  size = fold_convert (size_type_node, size);
   tmp = get_dtype_type_node ();
   field = gfc_advance_chain (TYPE_FIELDS (tmp),
 			     GFC_DTYPE_ELEM_LEN);
@@ -1560,17 +1582,17 @@ gfc_get_dtype_rank_type (int rank, tree etype)
 
 
 tree
-gfc_get_dtype (tree type)
+gfc_get_dtype (tree type, int * rank)
 {
   tree dtype;
   tree etype;
-  int rank;
+  int irnk;
 
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
 
-  rank = GFC_TYPE_ARRAY_RANK (type);
+  irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type));
   etype = gfc_get_element_type (type);
-  dtype = gfc_get_dtype_rank_type (rank, etype);
+  dtype = gfc_get_dtype_rank_type (irnk, etype);
 
   GFC_TYPE_ARRAY_DTYPE (type) = dtype;
   return dtype;
@@ -1912,7 +1934,11 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
   TYPE_TYPELESS_STORAGE (fat_type) = 1;
   gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type));
 
-  tmp = TYPE_NAME (etype);
+  tmp = etype;
+  if (TREE_CODE (tmp) == ARRAY_TYPE
+      && TYPE_STRING_FLAG (tmp))
+    tmp = TREE_TYPE (etype);
+  tmp = TYPE_NAME (tmp);
   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
     tmp = DECL_NAME (tmp);
   if (tmp)
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index ff01226..3b45ce2 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -114,7 +114,7 @@ int gfc_is_nodesc_array (gfc_symbol *);
 
 /* Return the DTYPE for an array.  */
 tree gfc_get_dtype_rank_type (int, tree);
-tree gfc_get_dtype (tree);
+tree gfc_get_dtype (tree, int *rank = NULL);
 
 tree gfc_get_ppc_type (gfc_component *);
 tree gfc_get_caf_vector_type (int dim);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 3ffa394..f26e91b 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -371,30 +371,16 @@ get_array_span (tree type, tree decl)
     return gfc_conv_descriptor_span_get (decl);
 
   /* Return the span for deferred character length array references.  */
-  if (type && TREE_CODE (type) == ARRAY_TYPE
-      && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
-      && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
-	  || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
-      && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
-	  || TREE_CODE (decl) == FUNCTION_DECL
-	  || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
-					== DECL_CONTEXT (decl)))
-    {
-      span = fold_convert (gfc_array_index_type,
-			   TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
-      span = fold_build2 (MULT_EXPR, gfc_array_index_type,
-			  fold_convert (gfc_array_index_type,
-					TYPE_SIZE_UNIT (TREE_TYPE (type))),
-			  span);
-    }
-  else if (type && TREE_CODE (type) == ARRAY_TYPE
-	   && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
-	   && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
+  if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type))
     {
+      if (TREE_CODE (decl) == PARM_DECL)
+	decl = build_fold_indirect_ref_loc (input_location, decl);
       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
 	span = gfc_conv_descriptor_span_get (decl);
       else
-	span = NULL_TREE;
+	span = gfc_get_character_len_in_bytes (type);
+      span = (span && !integer_zerop (span))
+	? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE);
     }
   /* Likewise for class array or pointer array references.  */
   else if (TREE_CODE (decl) == FIELD_DECL
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 69d3fdc..d1d4a1d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -53,6 +53,9 @@ typedef struct gfc_se
      here.  */
   tree class_vptr;
 
+  /* Whether expr is a reference to an unlimited polymorphic object.  */
+  unsigned unlimited_polymorphic:1;
+  
   /* If set gfc_conv_variable will return an expression for the array
      descriptor. When set, want_pointer should also be set.
      If not set scalarizing variables will be substituted.  */
@@ -506,6 +509,8 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
 
 
 /* trans-expr.c */
+tree gfc_get_character_len (tree);
+tree gfc_get_character_len_in_bytes (tree);
 tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
 tree gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *, gfc_expr *);
 void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);