Re: [RFC, PATCH, fortran] PR fortran/60255 Deferred character length

[Andre Vehreschild <vehre at gmx dot de>]

Hi all,

please find attached a more elaborate patch for pr60255. I totally agree that
my first attempt was just scratching the surface of the work needed.

This patch also is *not* complete, but because I am really new to gfortran
patching, I don't want to present a final patch only to learn then, that I have
violated design rules, common practice or the like. Therefore please comment
and direct me to any sources/ideas to improve the patch.

Topic: 
The pr 60255 is about assigning a char array to an unlimited polymorphic
entity. In the comments the concern about the lost length information is
raised. The patch adds a _len component to the unlimited polymorphic entity
(after _data and _vtab) and adds an assignment of the string length to _len
when a string is pointer assigned to the unlimited poly entity. Furthermore is
the intrinsic len(unlimited poly pointing to a string) resolved to give the
_len component.

Yet missing:
- assign _len component back to deferred char array length component
- transport length along chains of unlimited poly entities, i.e., a => b; c =>
  a where all objects are unlimited poly and b is a string.
- allocate() in this context

Patch dependencies:
none

Comments, concerns, candy welcome!

Regards,
	Andre

On Sun, 17 Aug 2014 14:32:21 +0200
dominiq@lps.ens.fr (Dominique Dhumieres) wrote:

> > the testcase should check that the code generated is actually working,
> > not just that the ICE disappeared.
> 
> I agree. Note that there is a test in the comment 3 of PR60255 that
> can be used to check the run time behavior (and possibly check the
> vtab issue).
> 
> Dominique


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 0286c9e..29e31e1 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2403,6 +2403,38 @@ yes:
   return true;
 }
 
+/* Add the component _len to the class-type variable in c->expr1.  */
+
+void
+gfc_add_len_component (gfc_code *c)
+{
+  /* Just make sure input is correct. This is already at the calling site,
+     but may be this routine is called from somewhere else in the furure.  */
+  gcc_assert (UNLIMITED_POLY(c->expr1)
+              && c->expr2
+              && c->expr2->ts.type== BT_CHARACTER);
+
+  gfc_component *len;
+  gfc_expr *e;
+  /* Check that _len is not present already.  */
+  if ((len= gfc_find_component (c->expr1->ts.u.derived, "_len", true, true)))
+    return;
+  /* Create the new component.  */
+  if (!gfc_add_component (c->expr1->ts.u.derived, "_len", &len))
+    // Possible errors are already reported in add_component
+    return;
+  len->ts.type = BT_INTEGER;
+  len->ts.kind = 4;
+  len->attr.access = ACCESS_PRIVATE;
+
+  /* Build minimal expression to initialize component with zero. */
+  e = gfc_get_expr();
+  e->ts = c->expr1->ts;
+  e->expr_type = EXPR_VARIABLE;
+  len->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+                                       NULL, 0);
+  gfc_free_expr (e);
+}
 
 /* Find (or generate) the symbol for an intrinsic type's vtab.  This is
    needed to support unlimited polymorphism.  */
@@ -2415,18 +2447,9 @@ find_intrinsic_vtab (gfc_typespec *ts)
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
   int charlen = 0;
 
-  if (ts->type == BT_CHARACTER)
-    {
-      if (ts->deferred)
-	{
-	  gfc_error ("TODO: Deferred character length variable at %C cannot "
-		     "yet be associated with unlimited polymorphic entities");
-	  return NULL;
-	}
-      else if (ts->u.cl && ts->u.cl->length
-	       && ts->u.cl->length->expr_type == EXPR_CONSTANT)
-	charlen = mpz_get_si (ts->u.cl->length->value.integer);
-    }
+  if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length
+      && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+    charlen = mpz_get_si (ts->u.cl->length->value.integer);
 
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -2437,10 +2460,16 @@ find_intrinsic_vtab (gfc_typespec *ts)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 
-      if (ts->type == BT_CHARACTER)
-	sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
-		 charlen, ts->kind);
-      else
+      if (ts->type == BT_CHARACTER) {
+        if (!ts->deferred)
+          sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+                   charlen, ts->kind);
+        else
+          /* The type is deferred here. Ensure that this is easily seen in the 
+             vtable. */
+          sprintf (tname, "%s_DEFERRED_%d", gfc_basic_typename (ts->type),
+                   ts->kind);
+      } else
 	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
 
       sprintf (name, "__vtab_%s", tname);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1058502..f99c3f8 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3192,6 +3192,8 @@ gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+void gfc_add_len_component(gfc_code *);
+void gfc_assign_charlen_to_unlimited_poly(gfc_code *c);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 gfc_symbol *gfc_find_vtab (gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9d7d3c2..6e14e74 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10081,7 +10081,11 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 	    if (!t)
 	      break;
 
-	    gfc_check_pointer_assign (code->expr1, code->expr2);
+	    if (gfc_check_pointer_assign (code->expr1, code->expr2)
+		&& UNLIMITED_POLY(code->expr1)
+		&& code->expr2->ts.type== BT_CHARACTER)
+	      gfc_add_len_component (code);
+
 	    break;
 	  }
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 7ccabc7..88cd8e7 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3687,6 +3687,31 @@ gfc_simplify_leadz (gfc_expr *e)
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
 }
 
+static gfc_expr *
+get__len_component (gfc_expr *e)
+{
+  gfc_expr *len_comp;
+  gfc_ref *ref, **last;
+  len_comp = gfc_copy_expr(e->symtree->n.sym->assoc->target);
+  /* We need to remove the last _data component ref from ptr.  */
+  last = &(len_comp->ref);
+  ref = len_comp->ref;
+  while (ref)
+    {
+      if (!ref->next
+          && ref->type == REF_COMPONENT
+          && strcmp("_data", ref->u.c.component->name)== 0)
+        {
+          gfc_free_ref_list(ref);
+          *last = NULL;
+          break;
+        }
+      last = &(ref->next);
+      ref = ref->next;
+    }
+  gfc_add_component_ref(len_comp, "_len");
+  return len_comp;
+}
 
 gfc_expr *
 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
@@ -3711,6 +3736,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
       return range_check (result, "LEN");
     }
+  else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
+           && e->symtree->n.sym
+           && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
+           && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED)
+    {
+      return get__len_component (e);
+    }
   else
     return NULL;
 }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f8e4df8..9a08bde 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1034,11 +1034,11 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
       gfc_add_vptr_component (lhs);
 
       if (UNLIMITED_POLY (expr1)
-	  && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
-	{
-	  rhs = gfc_get_null_expr (&expr2->where);
- 	  goto assign_vptr;
-	}
+          && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
+        {
+          rhs = gfc_get_null_expr (&expr2->where);
+          goto assign_vptr;
+        }
 
       if (expr2->expr_type == EXPR_NULL)
 	vtab = gfc_find_vtab (&expr1->ts);
@@ -6695,6 +6695,43 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* Create the character length assignment to the _len component.  */
+
+void
+add_assignment_of_string_len_to_len_component (stmtblock_t *block,
+                                               gfc_expr *ptr, gfc_se *ptr_se,
+                                               gfc_se *str)
+{
+  gfc_expr *len_comp;
+  gfc_ref *ref, **last;
+  gfc_se lse;
+  len_comp = gfc_copy_expr(ptr);
+  /* We need to remove the last _data component ref from ptr.  */
+  last = &(len_comp->ref);
+  ref = len_comp->ref;
+  while (ref)
+    {
+      if (!ref->next
+          && ref->type == REF_COMPONENT
+          && strcmp("_data", ref->u.c.component->name)== 0)
+        {
+          gfc_free_ref_list(ref);
+          *last = NULL;
+          break;
+        }
+      last = &(ref->next);
+      ref = ref->next;
+    }
+  gfc_add_component_ref(len_comp, "_len");
+  gfc_init_se (&lse, NULL);
+  gfc_conv_expr (&lse, len_comp);
+
+  /* ptr % _len = len (str)  */
+  gfc_add_modify (block, lse.expr, str->string_length);
+  ptr_se->string_length = lse.expr;
+  gfc_free_expr (len_comp);
+}
+
 tree
 gfc_trans_pointer_assign (gfc_code * code)
 {
@@ -6759,6 +6796,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
+      /* For string assignments to unlimited polymorphic pointers add an
+         assignment of the string_length to the _len component of the pointer.  */
+      if (expr1->ts.type == BT_DERIVED
+          && expr1->ts.u.derived->attr.unlimited_polymorphic
+          && expr2->ts.type == BT_CHARACTER)
+        {
+          add_assignment_of_string_len_to_len_component (&block, expr1, &lse, &rse);
+        }
+
       /* Check character lengths if character expression.  The test is only
 	 really added if -fbounds-check is enabled.  Exclude deferred
 	 character length lefthand sides.  */
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03
new file mode 100644
index 0000000..6042882
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03
@@ -0,0 +1,57 @@
+! { dg-do run }
+! Testing fix for 
+! PR fortran/60255 
+!
+program test
+    implicit none
+    character(LEN=:), allocatable :: S
+    call subP(S)
+    call sub2()
+    call sub1("test")
+
+contains
+
+  subroutine sub1(dcl)
+    character(len=*), target :: dcl
+    class(*), pointer :: ucp
+!    character(len=:), allocatable ::def
+
+    ucp => dcl
+
+    select type (ucp)
+    type is (character(len=*))
+      if (len(ucp) .NE. 4) then
+        call abort()
+!      else
+!        def = ucp
+!        if (len(def) .NE. 4) then
+!          call abort()   ! This abort is expected currently           
+!        end if
+      end if
+    class default
+      call abort()
+    end select
+  end subroutine
+  
+  subroutine sub2 
+    character(len=:), allocatable, target :: dcl
+    class(*), pointer :: ucp
+
+    dcl = "ttt"
+    ucp => dcl
+
+    select type (ucp)
+    type is (character(len=*))
+      if (len(ucp) .NE. 3) then
+        call abort()
+      end if
+    class default
+      call abort()
+    end select
+  end subroutine
+
+  subroutine subP(P)
+        class(*) :: P
+  end subroutine
+ 
+end program
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03
index 8e80386..30e4797 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03
@@ -5,7 +5,7 @@
 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
 !            and Tobias Burnus <burnus@gcc.gnu.org>
 !
-  CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }
+  CHARACTER(:), allocatable, target :: chr 
 ! F2008: C5100
   integer :: i(2)
   logical :: flag