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

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

[Dominique Dhumieres]

> 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

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

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 1679 bytes --]

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 

[-- Attachment #2: pr60255_3.patch --]
[-- Type: text/x-patch, Size: 10481 bytes --]

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

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

[Dominique d'Humières]

Dear Paul,

The problem for oo.f90 is pr 55901.

I am updating my working tree with Andre’s patch.

Cheers,

Dominique

> Le 8 déc. 2014 à 21:20, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
> 
> Dear Andre,
> 
> s/furure/future/ :-)
> 
> Why are you using a double underscore in get__len_component?
> 
> More seriously, I think that the len field should be added unconditionally to unlimited polymorphic variables. Otherwise, you might find unlimited polymorphic variables that are created in an already compiled module/subprogramme arriving without the requisite field.
> 
> Michael Metcalf has posted an example that makes use of unlimited polymorphism at ftp://ftp.numerical.rl.ac.uk/pub/MRandC/oo.f90 . gfortran does not work correctly with it at the moment because of the lack of a len field. Removing all the string input allows it to run correctly. I think that you should ensure that your patch fixes the problem.
> 
> A slight obstacle is that the substring at line 216 causes the emission of:
>     type is (character(*))
>                           1
> Error: Associate-name '__tmp_CHARACTER_0_1' at (1) is used as array
> 
> Just retaining print *, 'character = "', v, '"' allows the example to compile
> 
> ifort compiles and runs it successfully and so I think that it would be nice if gfortran catches up on this one.
> 
> Parenthetically, I wonder if this is not the time to implement PR53971... including responding to Mikael's comment?
> 
> Anyway, this is a good start in the right direction. Please persist!
> 
> Thanks
> 
> Paul
> 
> 
> On 8 December 2014 at 18:38, Andre Vehreschild <vehre@gmx.de> wrote:
> 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
> 
> 
> 
> -- 
> The knack of flying is learning how to throw yourself at the ground and miss.
>        --Hitchhikers Guide to the Galaxy

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

[Andre Vehreschild]

Hi Paul,

> s/furure/future/ :-)

Hups, fixed.

> Why are you using a double underscore in get__len_component?

Because the component is called _len. The routine should be called "get _len
component", but spaces aren't allowed :-) Anyways, does this violate some style
guide? Should I remove one of underscores?

> More seriously, I think that the len field should be added unconditionally
> to unlimited polymorphic variables. Otherwise, you might find unlimited
> polymorphic variables that are created in an already compiled
> module/subprogramme arriving without the requisite field.

I was thinking about that, too. For a start I just wanted to give an idea of
where this is going. When more gfortran gurus vote for the unconditional add to
u-poly variables, then I will change it. 

> Michael Metcalf has posted an example that makes use of unlimited
> polymorphism at ftp://ftp.numerical.rl.ac.uk/pub/MRandC/oo.f90 . gfortran
> does not work correctly with it at the moment because of the lack of a len
> field. Removing all the string input allows it to run correctly. I think
> that you should ensure that your patch fixes the problem.
> 
> A slight obstacle is that the substring at line 216 causes the emission of:
>     type is (character(*))
>                           1
> Error: Associate-name '__tmp_CHARACTER_0_1' at (1) is used as array
> 
> Just retaining print *, 'character = "', v, '"' allows the example to
> compile

Ok, I take a look at it. As I am paid to fix certain bugs that prevent
compiling another software, I will not prioritize working on 55901 as long as
it is not needed in the software I focus on. Sorry for not being more
enthusiastic, but there are more than 8 prs (and only one down yet) I have to
fix and time is limited.

What I did not mention in the previous mail is that I also plan to implement
this fixes in the fortran-dev branch with the new array descriptor. Given that
there is no other volunteer. :-)

Please continue commenting.

Regards,
	Andre

> ifort compiles and runs it successfully and so I think that it would be
> nice if gfortran catches up on this one.
> 
> Parenthetically, I wonder if this is not the time to implement PR53971...
> including responding to Mikael's comment?
> 
> Anyway, this is a good start in the right direction. Please persist!
> 
> Thanks
> 
> Paul
> 
> 
> On 8 December 2014 at 18:38, Andre Vehreschild <vehre@gmx.de> wrote:
> 
> > 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
> >
> 
> 
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

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

[Dominique d'Humières]

Dear Andre,

The patch causes an ICE for the test gfortran.dg/unlimited_polymorphic_1.f03:

f951: internal compiler error: in gfc_add_component_ref, at fortran/class.c:236

f951: internal compiler error: Abort trap: 6
gfc: internal compiler error: Abort trap: 6 (program f951)
Abort

Reduced test for which the ICE is triggered by ‘len(w)'

MODULE m

contains
  subroutine bar (arg, res)
    class(*) :: arg
    character(100) :: res
    select type (w => arg)
      type is (character(*))
        write (res, '(I2)') len(w)
    end select
  end subroutine

END MODULE

Note that with your patch at https://gcc.gnu.org/ml/fortran/2014-08/msg00022.html, I get the same ICE for the Mikael’s test at https://gcc.gnu.org/ml/fortran/2014-08/msg00055.html (before your patch for pr60255, it used to give a wrong length: 80 instead of 20 AFAICR).

Note that the assert at fortran/class.c:236 is also triggered for pr61115.

Thanks for working on these issues,

Dominique

>> On 8 December 2014 at 18:38, Andre Vehreschild <vehre@gmx.de> wrote:
>> 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

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

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 4221 bytes --]

Hi all,

here is my next try on proposing a patch for the issue in pr60255. It took me
quite some time to understand the intricacies with handling variables
associated in a select type. I think I got most of the issues fixed now:

- Added generation of _len component for each unlimited polymorphic pointer.
- Removed (my own) _len component creation routine.
- Removed the double underscore in get_len_component().
- Associating an unlimited polymorphic entity to a deferred char array now lets
  the deferred char array use the actual string length from the '_len'
  component of the unlimited polymorphic entity for the charlen instead of the
  size component of the vptr.
- Removed: Generating a special vtab name for deferred strings. A deferred
  string assigned to the unlimited polymorphic entity is now stored as having 
  charlen zero again.
- Basic support for char array arrays (No stuttering here) in u-poly variables.

Bootstraps ok on x86_64-linux-gnu. Comparing regtests I get a difference in
unlimited_polymorphic_2.f90 that I don't understand yet. May be that is only,
because one error message disappeared.

Attached is the full patch for trunk and a delta patch for those of you who
already have my pr60255_3 added.

I don't provide a changelog entry yet, because I think review will find some
issues still to fix. So, comments welcome!

Regards,
	Andre

On Tue, 9 Dec 2014 14:16:05 +0100
Dominique d'Humières <dominiq@lps.ens.fr> wrote:

> Dear Andre,
> 
> The patch causes an ICE for the test gfortran.dg/unlimited_polymorphic_1.f03:
> 
> f951: internal compiler error: in gfc_add_component_ref, at
> fortran/class.c:236
> 
> f951: internal compiler error: Abort trap: 6
> gfc: internal compiler error: Abort trap: 6 (program f951)
> Abort
> 
> Reduced test for which the ICE is triggered by ‘len(w)'
> 
> MODULE m
> 
> contains
>   subroutine bar (arg, res)
>     class(*) :: arg
>     character(100) :: res
>     select type (w => arg)
>       type is (character(*))
>         write (res, '(I2)') len(w)
>     end select
>   end subroutine
> 
> END MODULE
> 
> Note that with your patch at
> https://gcc.gnu.org/ml/fortran/2014-08/msg00022.html, I get the same ICE for
> the Mikael’s test at https://gcc.gnu.org/ml/fortran/2014-08/msg00055.html
> (before your patch for pr60255, it used to give a wrong length: 80 instead of
> 20 AFAICR).
> 
> Note that the assert at fortran/class.c:236 is also triggered for pr61115.
> 
> Thanks for working on these issues,
> 
> Dominique
> 
> >> On 8 December 2014 at 18:38, Andre Vehreschild <vehre@gmx.de> wrote:
> >> 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
> 
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

[-- Attachment #2: delta_pr60255_3_4.patch --]
[-- Type: text/x-patch, Size: 20721 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 29e31e1..f5a815c 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -34,6 +34,12 @@ along with GCC; see the file COPYING3.  If not see
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
 
+    Only for unlimited polymorphic classes:
+    * _len:  An integer(4) to store the string length when the unlimited
+             polymorphic pointer is used to point to a char array. The '_len'
+             component will be zero when no character array is stored in
+             '_data'.
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -544,10 +550,41 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.  */
+
+gfc_expr *
+gfc_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;
+}
+
 /* Build a polymorphic CLASS entity, using the symbol that comes from
    build_sym. A CLASS entity is represented by an encapsulating type,
    which contains the declared type as '_data' component, plus a pointer
-   component '_vptr' which determines the dynamic type.  */
+   component '_vptr' which determines the dynamic type. When this CLASS
+   entity is unlimited polymorphic, then also add a component '_len' to
+   store the length of string when that is stored in it.  */
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,19 +682,36 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!gfc_add_component (fclass, "_vptr", &c))
 	return false;
       c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
 	  vtab = gfc_find_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
+
+	  /* Add component '_len'.  Only unlimited polymorphic pointers may
+             have a string assigned to them, i.e., only those need the _len
+             component.  */
+	  if (!gfc_add_component (fclass, "_len", &c))
+	    return false;
+	  c->ts.type = BT_INTEGER;
+	  c->ts.kind = 4;
+	  c->attr.access = ACCESS_PRIVATE;
+	  c->attr.artificial = 1;
+
+	  /* Build minimal expression to initialize component with zero.
+	     TODO: When doing this, one goes to hell in the select type
+		   id association something in generating the constructor
+		   code really goes wrong.  Not using an initializer here
+		   needs extra code in the alloc statements.  */
+//	  c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+//					     NULL, 0);
 	}
       else
 	/* Build vtab later.  */
 	c->ts.u.derived = NULL;
-
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.pointer = 1;
     }
 
   if (!ts->u.derived->attr.unlimited_polymorphic)
@@ -2403,38 +2457,6 @@ 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.  */
@@ -2460,16 +2482,10 @@ find_intrinsic_vtab (gfc_typespec *ts)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 
-      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
+      if (ts->type == BT_CHARACTER)
+        sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+                 charlen, 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 f99c3f8..07de61b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3190,9 +3190,9 @@ bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
 gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
+gfc_expr *gfc_get_len_component (gfc_expr *);
 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 *);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6e14e74..9d7d3c2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10081,11 +10081,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 	    if (!t)
 	      break;
 
-	    if (gfc_check_pointer_assign (code->expr1, code->expr2)
-		&& UNLIMITED_POLY(code->expr1)
-		&& code->expr2->ts.type== BT_CHARACTER)
-	      gfc_add_len_component (code);
-
+	    gfc_check_pointer_assign (code->expr1, code->expr2);
 	    break;
 	  }
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 88cd8e7..ed6c057 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3687,32 +3687,6 @@ 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)
 {
@@ -3741,7 +3715,7 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
            && 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);
+      return gfc_get_len_component (e);
     }
   else
     return NULL;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 713f969..cb2c656 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -550,15 +550,15 @@ static void
 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 {
   tree new_type;
-  /* TREE_ADDRESSABLE means the address of this variable is actually needed.
-     This is the equivalent of the TARGET variables.
-     We also need to set this if the variable is passed by reference in a
-     CALL statement.  */
 
   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
   if (sym->attr.cray_pointee)
     gfc_finish_cray_pointee (decl, sym);
 
+  /* TREE_ADDRESSABLE means the address of this variable is actually needed.
+     This is the equivalent of the TARGET variables.
+     We also need to set this if the variable is passed by reference in a
+     CALL statement.  */
   if (sym->attr.target)
     TREE_ADDRESSABLE (decl) = 1;
   /* If it wasn't used we wouldn't be getting it.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9a08bde..d52f3cc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -94,6 +94,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
    in future implementations.  Use the corresponding APIs.  */
 #define CLASS_DATA_FIELD 0
 #define CLASS_VPTR_FIELD 1
+#define CLASS_LEN_FIELD 2
 #define VTABLE_HASH_FIELD 0
 #define VTABLE_SIZE_FIELD 1
 #define VTABLE_EXTENDS_FIELD 2
@@ -148,6 +149,20 @@ gfc_class_vptr_get (tree decl)
 }
 
 
+tree
+gfc_class_len_get (tree decl)
+{
+  tree len;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_LEN_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (len), decl, len,
+			  NULL_TREE);
+}
+
+
 static tree
 gfc_vtable_field_get (tree decl, int field)
 {
@@ -617,6 +632,40 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
+  /* When the actual arg is a char array, then set the _len component of the
+     unlimited polymorphic entity, too.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      ctree = gfc_class_len_get (var);
+      if (e->ts.u.cl->backend_decl)
+        {
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+        }
+      else if (parmse->string_length)
+        {
+          gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+        }
+      else
+        {
+          /* Try to simplify the expression.  */
+          gfc_simplify_expr (e, 0);
+          if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+            {
+              /* Amazingly all data is present to compute the length of a constant
+                 string, but the expression is not yet there.  */
+              e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1, &e->where);
+              mpz_set_ui (e->ts.u.cl->length->value.integer, e->value.character.length);
+              gfc_conv_const_charlen (e->ts.u.cl);
+              e->ts.u.cl->resolved = 1;
+              gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+            }
+          else
+            {
+              gfc_error ("Can't compute the length of the char array at %L.",
+                         &e->where);
+            }
+        }
+    }
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 }
@@ -6415,6 +6464,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 				  fold_convert (TREE_TYPE (cm->backend_decl),
 						val));
 	}
+      else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+        {
+          gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+          val = gfc_conv_constant_to_tree (e);
+          CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+                                  fold_convert (TREE_TYPE (cm->backend_decl),
+                                                val));
+        }
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6491,7 +6548,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
+      /* TODO: Need to check, if this is correctly working for all cases. */
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -6798,9 +6857,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
       /* 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
+      if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
           && expr1->ts.u.derived->attr.unlimited_polymorphic
-          && expr2->ts.type == BT_CHARACTER)
+          && (expr2->ts.type == BT_CHARACTER ||
+              ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
+              && expr2->ts.u.derived->attr.unlimited_polymorphic))
+          )
         {
           add_assignment_of_string_len_to_len_component (&block, expr1, &lse, &rse);
         }
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index d17b075..7c8974e 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1143,6 +1143,21 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Return true, when the class has a _len component.  */
+
+static bool
+class_has_len_component (gfc_symbol *sym)
+{
+  gfc_component *comp = sym->ts.u.derived->components;
+  while (comp)
+    {
+      if (strcmp (comp->name, "_len") == 0)
+        return true;
+      comp = comp->next;
+    }
+  return false;
+}
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1156,6 +1171,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   tree offset;
   tree dim;
   int n;
+  tree charlen;
+  bool need_len_assign;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1166,6 +1183,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  /* Assignments to the string length need to be generated, when
+     ( sym is a char array or
+       sym has a _len component
+     ) and the associated expression is unlimited polymorphic, which is
+     not (yet) correctly in 'unlimited', because for an already associated
+     BT_DERIVED the u-poly flag is not set, i.e.,
+      __tmp_CHARACTER_0_1 => w => arg
+       ^ generated temp      ^ from code, the w does not have the u-poly
+     flag set, where UNLIMITED_POLY(e) expects it.  */
+  need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
+                     && e->ts.u.derived->attr.unlimited_polymorphic))
+      && (sym->ts.type == BT_CHARACTER
+          || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
+              && class_has_len_component (sym))
+          )
+      );
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
@@ -1217,7 +1250,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
 	}
-
       /* Done, register stuff as init / cleanup code.  */
       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
 			    gfc_finish_block (&se.post));
@@ -1247,7 +1279,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_add_modify (&se.pre, tmp,
 			  gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
 	}
-
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -1286,6 +1317,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 				        gfc_array_index_type,
 				        offset, tmp);
 	    }
+	  if (need_len_assign)
+	    {
+	      /* Get the _len comp from the target expr.  */
+	      tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
+	      /* Get the component-ref for the temp structure's _len comp.  */
+	      charlen = gfc_class_len_get (se.expr);
+	      /* Add the assign to the beginning of the the block...  */
+	      gfc_add_modify (&se.pre, charlen,
+			      fold_convert (TREE_TYPE (charlen), tmp));
+	      /* and the oposite way at the end of the block, to hand changes
+	         on the string length back.  */
+	      gfc_add_modify (&se.post, tmp,
+			      fold_convert (TREE_TYPE (tmp), charlen));
+	      /* Length assignment done, prevent adding it again below.  */
+	      need_len_assign = false;
+	    }
 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
 	}
       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
@@ -1300,7 +1347,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
-	gfc_conv_expr (&se, e);
+        {
+          /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
+             which has the string length included.  For CHARACTERS it is still
+             needed and will be done at the end of this routine.  */
+          gfc_conv_expr (&se, e);
+          need_len_assign = sym->ts.type == BT_CHARACTER;
+        }
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,19 +1374,17 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_add_init_cleanup (block, tmp, NULL_TREE);
     }
 
-  /* Set the stringlength from the vtable size.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+  /* Set the stringlength, when needed.  */
+  if (need_len_assign)
     {
-      tree charlen;
       gfc_se se;
       gfc_init_se (&se, NULL);
-      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
-      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
-      tmp = gfc_vtable_size_get (tmp);
+      tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);
-      charlen = sym->ts.u.cl->backend_decl;
+      charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+                                             : gfc_class_len_get (sym->backend_decl);
       gfc_add_modify (&se.pre, charlen,
-		      fold_convert (TREE_TYPE (charlen), tmp));
+                      fold_convert (TREE_TYPE (charlen), tmp));
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -5048,12 +5099,21 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_modify (&se.pre, se.string_length,
 				fold_convert (TREE_TYPE (se.string_length),
 				memsz));
+	      else if ((al->expr->ts.type == BT_DERIVED
+			|| al->expr->ts.type == BT_CLASS)
+		       && expr->ts.u.derived->attr.unlimited_polymorphic)
+		{
+		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
+		  gfc_add_modify (&se.pre, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						memsz));
+		}
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)
 		tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
 	      else
-	      tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+		tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
 	      tmp = TYPE_SIZE_UNIT (tmp);
 	      memsz = fold_build2_loc (input_location, MULT_EXPR,
 				       TREE_TYPE (tmp), tmp,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 51ad910..3926c2a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -348,6 +348,7 @@ gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_len_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_vtable_hash_get (tree);

[-- Attachment #3: pr60255_4.patch --]
[-- Type: text/x-patch, Size: 23795 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 0286c9e..f5a815c 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -34,6 +34,12 @@ along with GCC; see the file COPYING3.  If not see
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
 
+    Only for unlimited polymorphic classes:
+    * _len:  An integer(4) to store the string length when the unlimited
+             polymorphic pointer is used to point to a char array. The '_len'
+             component will be zero when no character array is stored in
+             '_data'.
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -544,10 +550,41 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.  */
+
+gfc_expr *
+gfc_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;
+}
+
 /* Build a polymorphic CLASS entity, using the symbol that comes from
    build_sym. A CLASS entity is represented by an encapsulating type,
    which contains the declared type as '_data' component, plus a pointer
-   component '_vptr' which determines the dynamic type.  */
+   component '_vptr' which determines the dynamic type. When this CLASS
+   entity is unlimited polymorphic, then also add a component '_len' to
+   store the length of string when that is stored in it.  */
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,19 +682,36 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!gfc_add_component (fclass, "_vptr", &c))
 	return false;
       c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
 	  vtab = gfc_find_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
+
+	  /* Add component '_len'.  Only unlimited polymorphic pointers may
+             have a string assigned to them, i.e., only those need the _len
+             component.  */
+	  if (!gfc_add_component (fclass, "_len", &c))
+	    return false;
+	  c->ts.type = BT_INTEGER;
+	  c->ts.kind = 4;
+	  c->attr.access = ACCESS_PRIVATE;
+	  c->attr.artificial = 1;
+
+	  /* Build minimal expression to initialize component with zero.
+	     TODO: When doing this, one goes to hell in the select type
+		   id association something in generating the constructor
+		   code really goes wrong.  Not using an initializer here
+		   needs extra code in the alloc statements.  */
+//	  c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+//					     NULL, 0);
 	}
       else
 	/* Build vtab later.  */
 	c->ts.u.derived = NULL;
-
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.pointer = 1;
     }
 
   if (!ts->u.derived->attr.unlimited_polymorphic)
@@ -2415,18 +2469,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)
@@ -2438,8 +2483,8 @@ 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);
+        sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+                 charlen, ts->kind);
       else
 	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1058502..07de61b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3190,8 +3190,10 @@ bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
 gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
+gfc_expr *gfc_get_len_component (gfc_expr *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+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/simplify.c b/gcc/fortran/simplify.c
index 7ccabc7..ed6c057 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3687,7 +3687,6 @@ gfc_simplify_leadz (gfc_expr *e)
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
 }
 
-
 gfc_expr *
 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
 {
@@ -3711,6 +3710,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 gfc_get_len_component (e);
+    }
   else
     return NULL;
 }
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 713f969..cb2c656 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -550,15 +550,15 @@ static void
 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 {
   tree new_type;
-  /* TREE_ADDRESSABLE means the address of this variable is actually needed.
-     This is the equivalent of the TARGET variables.
-     We also need to set this if the variable is passed by reference in a
-     CALL statement.  */
 
   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
   if (sym->attr.cray_pointee)
     gfc_finish_cray_pointee (decl, sym);
 
+  /* TREE_ADDRESSABLE means the address of this variable is actually needed.
+     This is the equivalent of the TARGET variables.
+     We also need to set this if the variable is passed by reference in a
+     CALL statement.  */
   if (sym->attr.target)
     TREE_ADDRESSABLE (decl) = 1;
   /* If it wasn't used we wouldn't be getting it.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f8e4df8..d52f3cc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -94,6 +94,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
    in future implementations.  Use the corresponding APIs.  */
 #define CLASS_DATA_FIELD 0
 #define CLASS_VPTR_FIELD 1
+#define CLASS_LEN_FIELD 2
 #define VTABLE_HASH_FIELD 0
 #define VTABLE_SIZE_FIELD 1
 #define VTABLE_EXTENDS_FIELD 2
@@ -148,6 +149,20 @@ gfc_class_vptr_get (tree decl)
 }
 
 
+tree
+gfc_class_len_get (tree decl)
+{
+  tree len;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_LEN_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (len), decl, len,
+			  NULL_TREE);
+}
+
+
 static tree
 gfc_vtable_field_get (tree decl, int field)
 {
@@ -617,6 +632,40 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
+  /* When the actual arg is a char array, then set the _len component of the
+     unlimited polymorphic entity, too.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      ctree = gfc_class_len_get (var);
+      if (e->ts.u.cl->backend_decl)
+        {
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+        }
+      else if (parmse->string_length)
+        {
+          gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+        }
+      else
+        {
+          /* Try to simplify the expression.  */
+          gfc_simplify_expr (e, 0);
+          if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+            {
+              /* Amazingly all data is present to compute the length of a constant
+                 string, but the expression is not yet there.  */
+              e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1, &e->where);
+              mpz_set_ui (e->ts.u.cl->length->value.integer, e->value.character.length);
+              gfc_conv_const_charlen (e->ts.u.cl);
+              e->ts.u.cl->resolved = 1;
+              gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+            }
+          else
+            {
+              gfc_error ("Can't compute the length of the char array at %L.",
+                         &e->where);
+            }
+        }
+    }
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 }
@@ -1034,11 +1083,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);
@@ -6415,6 +6464,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 				  fold_convert (TREE_TYPE (cm->backend_decl),
 						val));
 	}
+      else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+        {
+          gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+          val = gfc_conv_constant_to_tree (e);
+          CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+                                  fold_convert (TREE_TYPE (cm->backend_decl),
+                                                val));
+        }
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6491,7 +6548,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
+      /* TODO: Need to check, if this is correctly working for all cases. */
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -6695,6 +6754,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 +6855,18 @@ 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_CLASS || expr1->ts.type == BT_DERIVED)
+          && expr1->ts.u.derived->attr.unlimited_polymorphic
+          && (expr2->ts.type == BT_CHARACTER ||
+              ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
+              && expr2->ts.u.derived->attr.unlimited_polymorphic))
+          )
+        {
+          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/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index d17b075..7c8974e 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1143,6 +1143,21 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Return true, when the class has a _len component.  */
+
+static bool
+class_has_len_component (gfc_symbol *sym)
+{
+  gfc_component *comp = sym->ts.u.derived->components;
+  while (comp)
+    {
+      if (strcmp (comp->name, "_len") == 0)
+        return true;
+      comp = comp->next;
+    }
+  return false;
+}
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1156,6 +1171,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   tree offset;
   tree dim;
   int n;
+  tree charlen;
+  bool need_len_assign;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1166,6 +1183,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  /* Assignments to the string length need to be generated, when
+     ( sym is a char array or
+       sym has a _len component
+     ) and the associated expression is unlimited polymorphic, which is
+     not (yet) correctly in 'unlimited', because for an already associated
+     BT_DERIVED the u-poly flag is not set, i.e.,
+      __tmp_CHARACTER_0_1 => w => arg
+       ^ generated temp      ^ from code, the w does not have the u-poly
+     flag set, where UNLIMITED_POLY(e) expects it.  */
+  need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
+                     && e->ts.u.derived->attr.unlimited_polymorphic))
+      && (sym->ts.type == BT_CHARACTER
+          || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
+              && class_has_len_component (sym))
+          )
+      );
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
@@ -1217,7 +1250,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
 	}
-
       /* Done, register stuff as init / cleanup code.  */
       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
 			    gfc_finish_block (&se.post));
@@ -1247,7 +1279,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_add_modify (&se.pre, tmp,
 			  gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
 	}
-
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -1286,6 +1317,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 				        gfc_array_index_type,
 				        offset, tmp);
 	    }
+	  if (need_len_assign)
+	    {
+	      /* Get the _len comp from the target expr.  */
+	      tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
+	      /* Get the component-ref for the temp structure's _len comp.  */
+	      charlen = gfc_class_len_get (se.expr);
+	      /* Add the assign to the beginning of the the block...  */
+	      gfc_add_modify (&se.pre, charlen,
+			      fold_convert (TREE_TYPE (charlen), tmp));
+	      /* and the oposite way at the end of the block, to hand changes
+	         on the string length back.  */
+	      gfc_add_modify (&se.post, tmp,
+			      fold_convert (TREE_TYPE (tmp), charlen));
+	      /* Length assignment done, prevent adding it again below.  */
+	      need_len_assign = false;
+	    }
 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
 	}
       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
@@ -1300,7 +1347,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
-	gfc_conv_expr (&se, e);
+        {
+          /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
+             which has the string length included.  For CHARACTERS it is still
+             needed and will be done at the end of this routine.  */
+          gfc_conv_expr (&se, e);
+          need_len_assign = sym->ts.type == BT_CHARACTER;
+        }
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,19 +1374,17 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_add_init_cleanup (block, tmp, NULL_TREE);
     }
 
-  /* Set the stringlength from the vtable size.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+  /* Set the stringlength, when needed.  */
+  if (need_len_assign)
     {
-      tree charlen;
       gfc_se se;
       gfc_init_se (&se, NULL);
-      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
-      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
-      tmp = gfc_vtable_size_get (tmp);
+      tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);
-      charlen = sym->ts.u.cl->backend_decl;
+      charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+                                             : gfc_class_len_get (sym->backend_decl);
       gfc_add_modify (&se.pre, charlen,
-		      fold_convert (TREE_TYPE (charlen), tmp));
+                      fold_convert (TREE_TYPE (charlen), tmp));
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -5048,12 +5099,21 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_modify (&se.pre, se.string_length,
 				fold_convert (TREE_TYPE (se.string_length),
 				memsz));
+	      else if ((al->expr->ts.type == BT_DERIVED
+			|| al->expr->ts.type == BT_CLASS)
+		       && expr->ts.u.derived->attr.unlimited_polymorphic)
+		{
+		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
+		  gfc_add_modify (&se.pre, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						memsz));
+		}
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)
 		tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
 	      else
-	      tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+		tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
 	      tmp = TYPE_SIZE_UNIT (tmp);
 	      memsz = fold_build2_loc (input_location, MULT_EXPR,
 				       TREE_TYPE (tmp), tmp,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 51ad910..3926c2a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -348,6 +348,7 @@ gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_len_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_vtable_hash_get (tree);
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
index 7a0df1a..9044199 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
@@ -1,6 +1,6 @@
 ! { dg-do compile }
-! Testing fix for
-! PR fortran/60414
+! Testing fix for 
+! PR fortran/60414 
 !
 module m
     implicit none
@@ -23,7 +23,7 @@ contains
                 if ( abs (X - this%expectedScalar) > 0.0001 ) then
                     call abort()
                 end if
-            class default
+            class default 
                 call abort ()
          end select
     end subroutine FCheck
@@ -62,8 +62,8 @@ end module
 program test
    use :: m
    implicit none
-
+  
    real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
    call checktextvector(vec, 6, 5.0)
-end program test
+end program test 
 
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

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

[Dominique d'Humières]

Hi Andre,

I have posted my results with your patch (and those for pr63851) at

https://gcc.gnu.org/ml/gcc-testresults/2014-12/msg02408.html.

I don’t see any problem with unlimited_polymorphic_2.f90. However the character
lengths are now wrong (they are 0) with your old patch for pr60289 at

https://gcc.gnu.org/ml/fortran/2014-08/msg00022.html.

I have also noticed that you don’t comply to the GNU policy about spaces,
in particular there should be no space at the end of a line, see the patch for
gfortran.dg/unlimited_polymorphic_18.f90.

Thanks for working hard on these issues,

Dominique

> Le 18 déc. 2014 à 19:41, Andre Vehreschild <vehre@gmx.de> a écrit :
> 
> Hi all,
> 
> here is my next try on proposing a patch for the issue in pr60255. It took me
> quite some time to understand the intricacies with handling variables
> associated in a select type. I think I got most of the issues fixed now:
> 
> - Added generation of _len component for each unlimited polymorphic pointer.
> - Removed (my own) _len component creation routine.
> - Removed the double underscore in get_len_component().
> - Associating an unlimited polymorphic entity to a deferred char array now lets
>  the deferred char array use the actual string length from the '_len'
>  component of the unlimited polymorphic entity for the charlen instead of the
>  size component of the vptr.
> - Removed: Generating a special vtab name for deferred strings. A deferred
>  string assigned to the unlimited polymorphic entity is now stored as having 
>  charlen zero again.
> - Basic support for char array arrays (No stuttering here) in u-poly variables.
> 
> Bootstraps ok on x86_64-linux-gnu. Comparing regtests I get a difference in
> unlimited_polymorphic_2.f90 that I don't understand yet. May be that is only,
> because one error message disappeared.
> 
> Attached is the full patch for trunk and a delta patch for those of you who
> already have my pr60255_3 added.
> 
> I don't provide a changelog entry yet, because I think review will find some
> issues still to fix. So, comments welcome!
> 
> Regards,
> 	Andre

[PATCH, fortran, final] PR fortran/60255 Deferred character length

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 1080 bytes --]

Hi all,

attached is the patch and changelog for fixing pr60255. All comments I received
have been integrated into the current patch, therefore I submit this patch as
final and hope to see it in trunk soon. 

The patch fixes the assignment of deferred length char arrays to unlimited
polymorphic entities by introducing a _len component.

Bootstrapped and regtested ok on x86_64-linux-gnu.

As my system is rather slow in bootstrapping and regtesting here a preview of
what I plan to submit in the next two days:
- patch on pr60289: Took the proposal from Janus and extended to pass all
  regtests and introduced new testcase.
- patch on pr60357 and pr55901: This incorporates Paul's patch on pr55901,
  which I had to modify and extend to handle allocatable components including
  deferred char arrays. I furthermore contains a patch from Tobias to correct
  the attribute transport from the module to its place of use, which I adapted
  to fully fix pr60357.

Regards,
	Andre
-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

[-- Attachment #2: pr60255_5.clog --]
[-- Type: application/octet-stream, Size: 1252 bytes --]

gcc/fortran/ChangeLog:

2014-12-28  Andre Vehreschild  <vehre@gmx.de>, Janus Weil <janus@gcc.gnu.org>

	Initial patch version: Janus Weil
	* class.c (gfc_get_len_component): Added new routine.
	(gfc_build_class_symbol): Added _len component for unlimit. poly.
	(find_intrinsic_vtab): Removed emitting error message.
	* gfortran.h: Added prototype for gfc_get_len_component.
	* simplify.c (gfc_simplify_len): Use _len component where available.
	* trans-expr.c (gfc_class_len_get): Added routine.
	(gfc_conv_intrinsic_to_class): Added handling for deferred chararrays.
	(gfc_conv_structure): Treat _len component correctly.
	(gfc_conv_expr): Prevent bind_c handling when not required. 
	(add_assignment_of_string_len_to_len_component): Do _len = _len.
	(gfc_trans_pointer_assignment): Ensure _len component is propagated.
	* trans-stmt.c (class_has_len_component): Added.
	(trans_associate_var): _len component treatement for associate context.
	(gfc_trans_allocate): Same as for trans_associate_var().
	* trans.h: Added prototype for gfc_class_len_get.

gcc/testsuite/ChangeLog:

2014-12-28  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/unlimited_polymorphic_2.f03: Removed expected error.
	* gfortran.dg/unlimited_polymorphic_20.f03: New test.



[-- Attachment #3: pr60255_5.patch --]
[-- Type: text/x-patch, Size: 23078 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 5130022..3438826 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -34,6 +34,12 @@ along with GCC; see the file COPYING3.  If not see
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
 
+    Only for unlimited polymorphic classes:
+    * _len:  An integer(4) to store the string length when the unlimited
+             polymorphic pointer is used to point to a char array.  The '_len'
+             component will be zero when no character array is stored in
+             '_data'.
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -544,10 +550,42 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.  */
+
+gfc_expr *
+gfc_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;
+}
+
+
 /* Build a polymorphic CLASS entity, using the symbol that comes from
    build_sym. A CLASS entity is represented by an encapsulating type,
    which contains the declared type as '_data' component, plus a pointer
-   component '_vptr' which determines the dynamic type.  */
+   component '_vptr' which determines the dynamic type.  When this CLASS
+   entity is unlimited polymorphic, then also add a component '_len' to
+   store the length of string when that is stored in it.  */
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,19 +683,36 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!gfc_add_component (fclass, "_vptr", &c))
 	return false;
       c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
 	  vtab = gfc_find_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
+
+	  /* Add component '_len'.  Only unlimited polymorphic pointers may
+             have a string assigned to them, i.e., only those need the _len
+             component.  */
+	  if (!gfc_add_component (fclass, "_len", &c))
+	    return false;
+	  c->ts.type = BT_INTEGER;
+	  c->ts.kind = 4;
+	  c->attr.access = ACCESS_PRIVATE;
+	  c->attr.artificial = 1;
+
+	  /* Build minimal expression to initialize component with zero.
+	     TODO: When doing this, one goes to hell in the select type
+		   id association something in generating the constructor
+		   code really goes wrong.  Not using an initializer here
+		   needs extra code in the alloc statements.  */
+//	  c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+//					     NULL, 0);
 	}
       else
 	/* Build vtab later.  */
 	c->ts.u.derived = NULL;
-
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.pointer = 1;
     }
 
   if (!ts->u.derived->attr.unlimited_polymorphic)
@@ -2415,18 +2470,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)
@@ -2438,8 +2484,8 @@ 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);
+        sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+                 charlen, ts->kind);
       else
 	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 41c6c57..20c86b7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3123,8 +3123,10 @@ bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
 gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
+gfc_expr *gfc_get_len_component (gfc_expr *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+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/simplify.c b/gcc/fortran/simplify.c
index d46c5db..f4436ab 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3689,7 +3689,6 @@ gfc_simplify_leadz (gfc_expr *e)
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
 }
 
-
 gfc_expr *
 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
 {
@@ -3713,6 +3712,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 gfc_get_len_component (e);
+    }
   else
     return NULL;
 }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3793cfb..d5a49af 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -94,6 +94,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
    in future implementations.  Use the corresponding APIs.  */
 #define CLASS_DATA_FIELD 0
 #define CLASS_VPTR_FIELD 1
+#define CLASS_LEN_FIELD 2
 #define VTABLE_HASH_FIELD 0
 #define VTABLE_SIZE_FIELD 1
 #define VTABLE_EXTENDS_FIELD 2
@@ -148,6 +149,20 @@ gfc_class_vptr_get (tree decl)
 }
 
 
+tree
+gfc_class_len_get (tree decl)
+{
+  tree len;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_LEN_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (len), decl, len,
+			  NULL_TREE);
+}
+
+
 static tree
 gfc_vtable_field_get (tree decl, int field)
 {
@@ -617,6 +632,42 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
+  /* When the actual arg is a char array, then set the _len component of the
+     unlimited polymorphic entity, too.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      ctree = gfc_class_len_get (var);
+      if (e->ts.u.cl->backend_decl)
+        {
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+        }
+      else if (parmse->string_length)
+        {
+          gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+        }
+      else
+        {
+          /* Try to simplify the expression.  */
+          gfc_simplify_expr (e, 0);
+          if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+            {
+              /* Amazingly all data is present to compute the length of a
+                 constant string, but the expression is not yet there.  */
+              e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1,
+                                                          &e->where);
+              mpz_set_ui (e->ts.u.cl->length->value.integer,
+                          e->value.character.length);
+              gfc_conv_const_charlen (e->ts.u.cl);
+              e->ts.u.cl->resolved = 1;
+              gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+            }
+          else
+            {
+              gfc_error ("Can't compute the length of the char array at %L.",
+                         &e->where);
+            }
+        }
+    }
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 }
@@ -6489,6 +6540,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 				  fold_convert (TREE_TYPE (cm->backend_decl),
 						val));
 	}
+      else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+        {
+          gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+          val = gfc_conv_constant_to_tree (e);
+          CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+                                  fold_convert (TREE_TYPE (cm->backend_decl),
+                                                val));
+        }
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6565,7 +6624,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
+      /* TODO: Need to check, if this is correctly working for all cases.  */
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -6769,6 +6830,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)
 {
@@ -6833,6 +6931,19 @@ 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_CLASS || expr1->ts.type == BT_DERIVED)
+          && expr1->ts.u.derived->attr.unlimited_polymorphic
+          && (expr2->ts.type == BT_CHARACTER ||
+              ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
+              && expr2->ts.u.derived->attr.unlimited_polymorphic)))
+        {
+          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/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 24e47f2..c560d05 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1143,6 +1143,21 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Return true, when the class has a _len component.  */
+
+static bool
+class_has_len_component (gfc_symbol *sym)
+{
+  gfc_component *comp = sym->ts.u.derived->components;
+  while (comp)
+    {
+      if (strcmp (comp->name, "_len") == 0)
+        return true;
+      comp = comp->next;
+    }
+  return false;
+}
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1156,6 +1171,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   tree offset;
   tree dim;
   int n;
+  tree charlen;
+  bool need_len_assign;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1166,6 +1183,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  /* Assignments to the string length need to be generated, when
+     ( sym is a char array or
+       sym has a _len component)
+     and the associated expression is unlimited polymorphic, which is
+     not (yet) correctly in 'unlimited', because for an already associated
+     BT_DERIVED the u-poly flag is not set, i.e.,
+      __tmp_CHARACTER_0_1 => w => arg
+       ^ generated temp      ^ from code, the w does not have the u-poly
+     flag set, where UNLIMITED_POLY(e) expects it.  */
+  need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
+                     && e->ts.u.derived->attr.unlimited_polymorphic))
+      && (sym->ts.type == BT_CHARACTER
+          || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
+              && class_has_len_component (sym))));
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
@@ -1217,7 +1248,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
 	}
-
       /* Done, register stuff as init / cleanup code.  */
       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
 			    gfc_finish_block (&se.post));
@@ -1247,7 +1277,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_add_modify (&se.pre, tmp,
 			  gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
 	}
-
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -1286,6 +1315,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 				        gfc_array_index_type,
 				        offset, tmp);
 	    }
+	  if (need_len_assign)
+	    {
+	      /* Get the _len comp from the target expr.  */
+	      tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
+	      /* Get the component-ref for the temp structure's _len comp.  */
+	      charlen = gfc_class_len_get (se.expr);
+	      /* Add the assign to the beginning of the the block...  */
+	      gfc_add_modify (&se.pre, charlen,
+			      fold_convert (TREE_TYPE (charlen), tmp));
+	      /* and the oposite way at the end of the block, to hand changes
+	         on the string length back.  */
+	      gfc_add_modify (&se.post, tmp,
+			      fold_convert (TREE_TYPE (tmp), charlen));
+	      /* Length assignment done, prevent adding it again below.  */
+	      need_len_assign = false;
+	    }
 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
 	}
       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
@@ -1300,7 +1345,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
-	gfc_conv_expr (&se, e);
+        {
+          /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
+             which has the string length included.  For CHARACTERS it is still
+             needed and will be done at the end of this routine.  */
+          gfc_conv_expr (&se, e);
+          need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
+        }
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,21 +1372,30 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_add_init_cleanup (block, tmp, NULL_TREE);
     }
 
-  /* Set the stringlength from the vtable size.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+  /* Set the stringlength, when needed.  */
+  if (need_len_assign)
     {
-      tree charlen;
       gfc_se se;
       gfc_init_se (&se, NULL);
-      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
-      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
-      tmp = gfc_vtable_size_get (tmp);
+      if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+        {
+          /* What about deferred strings?  */
+          gcc_assert (!e->symtree->n.sym->ts.deferred);
+          tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
+        }
+      else
+        tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);
-      charlen = sym->ts.u.cl->backend_decl;
-      gfc_add_modify (&se.pre, charlen,
-		      fold_convert (TREE_TYPE (charlen), tmp));
-      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
-			    gfc_finish_block (&se.post));
+      charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+                                       : gfc_class_len_get (sym->backend_decl);
+      /* Prevent adding a noop len= len.  */
+      if (tmp != charlen)
+        {
+          gfc_add_modify (&se.pre, charlen,
+                          fold_convert (TREE_TYPE (charlen), tmp));
+          gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+                                gfc_finish_block (&se.post));
+        }
     }
 }
 
@@ -5050,6 +5110,15 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_modify (&se.pre, se.string_length,
 				fold_convert (TREE_TYPE (se.string_length),
 				memsz));
+	      else if ((al->expr->ts.type == BT_DERIVED
+			|| al->expr->ts.type == BT_CLASS)
+		       && expr->ts.u.derived->attr.unlimited_polymorphic)
+		{
+		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
+		  gfc_add_modify (&se.pre, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						memsz));
+		}
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 51ad910..3926c2a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -348,6 +348,7 @@ gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_len_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_vtable_hash_get (tree);
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
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
new file mode 100644
index 0000000..c6c6d29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
@@ -0,0 +1,104 @@
+! { dg-do run }
+!
+! Testing fix for PR fortran/60255
+!
+! Author: Andre Vehreschild <vehre@gmx.de>
+!
+MODULE m
+
+contains
+  subroutine bar (arg, res)
+    class(*) :: arg
+    character(100) :: res
+    select type (w => arg)
+      type is (character(*))
+        write (res, '(I2)') len(w)
+    end select
+  end subroutine
+
+END MODULE
+
+program test
+    use m;
+    implicit none
+    character(LEN=:), allocatable, target :: S
+    character(LEN=100) :: res
+    class(*), pointer :: ucp
+    call sub1 ("long test string", 16)
+    call sub2 ()
+    S = "test"
+    ucp => S
+    call sub3 (ucp)
+    call sub4 (S, 4)
+    call sub4 ("This is a longer string.", 24)
+    call bar (S, res)
+    if (trim (res) .NE. " 4") call abort ()
+    call bar(ucp, res)
+    if (trim (res) .NE. " 4") call abort ()
+
+contains
+
+    subroutine sub1(dcl, ilen)
+        character(len=*), target :: dcl
+        integer(4) :: ilen
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        ucp => dcl
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(dcl) .NE. ilen) call abort ()
+            if (len(ucp) .NE. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .NE. ilen) call abort ()
+        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) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub3(ucp)
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. 4) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. 4) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub4(ucp, ilen)
+        character(len=:), allocatable :: hlp
+        integer(4) :: ilen
+        class(*) :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. ilen) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+end program
+

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

[Dominique d'Humières]

For the record, compiling the tests in pr61337 with the patch applied on top of r219099 gives ICEs:

   use array_list
 1
internal compiler error: in gfc_advance_chain, at fortran/trans.c:58

Since this replaces some wrong-code generation by some ICEs, I don’t think this should delay the fix of pr60255.

Cheers,

Dominique

> Le 29 déc. 2014 à 11:07, Andre Vehreschild <vehre@gmx.de> a écrit :
> 
> Hi all,
> 
> attached is the patch and changelog for fixing pr60255. All comments I received
> have been integrated into the current patch, therefore I submit this patch as
> final and hope to see it in trunk soon. 
> 
> The patch fixes the assignment of deferred length char arrays to unlimited
> polymorphic entities by introducing a _len component.
> 
> Bootstrapped and regtested ok on x86_64-linux-gnu.
> 
> As my system is rather slow in bootstrapping and regtesting here a preview of
> what I plan to submit in the next two days:
> - patch on pr60289: Took the proposal from Janus and extended to pass all
>  regtests and introduced new testcase.
> - patch on pr60357 and pr55901: This incorporates Paul's patch on pr55901,
>  which I had to modify and extend to handle allocatable components including
>  deferred char arrays. I furthermore contains a patch from Tobias to correct
>  the attribute transport from the module to its place of use, which I adapted
>  to fully fix pr60357.
> 
> Regards,
> 	Andre
> -- 
> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> Tel.: +49 241 9291018 * Email: vehre@gmx.de 

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

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 2071 bytes --]

Hi Dominique,

thanks for pointing that out. That was caused by a flaw in the current patch.
In the attached version this is fixed now.

Bootstraps and regtests ok on x86_64-linux-gnu.

Regards,
	Andre

On Mon, 29 Dec 2014 16:32:27 +0100
Dominique d'Humières <dominiq@lps.ens.fr> wrote:

> For the record, compiling the tests in pr61337 with the patch applied on top
> of r219099 gives ICEs:
> 
>    use array_list
>  1
> internal compiler error: in gfc_advance_chain, at fortran/trans.c:58
> 
> Since this replaces some wrong-code generation by some ICEs, I don’t think
> this should delay the fix of pr60255.
> 
> Cheers,
> 
> Dominique
> 
> > Le 29 déc. 2014 à 11:07, Andre Vehreschild <vehre@gmx.de> a écrit :
> > 
> > Hi all,
> > 
> > attached is the patch and changelog for fixing pr60255. All comments I
> > received have been integrated into the current patch, therefore I submit
> > this patch as final and hope to see it in trunk soon. 
> > 
> > The patch fixes the assignment of deferred length char arrays to unlimited
> > polymorphic entities by introducing a _len component.
> > 
> > Bootstrapped and regtested ok on x86_64-linux-gnu.
> > 
> > As my system is rather slow in bootstrapping and regtesting here a preview
> > of what I plan to submit in the next two days:
> > - patch on pr60289: Took the proposal from Janus and extended to pass all
> >  regtests and introduced new testcase.
> > - patch on pr60357 and pr55901: This incorporates Paul's patch on pr55901,
> >  which I had to modify and extend to handle allocatable components including
> >  deferred char arrays. I furthermore contains a patch from Tobias to correct
> >  the attribute transport from the module to its place of use, which I
> > adapted to fully fix pr60357.
> > 
> > Regards,
> > 	Andre
> > -- 
> > Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> > Tel.: +49 241 9291018 * Email: vehre@gmx.de 
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

[-- Attachment #2: pr60255_6.clog --]
[-- Type: application/octet-stream, Size: 1252 bytes --]

gcc/fortran/ChangeLog:

2014-12-30  Andre Vehreschild  <vehre@gmx.de>, Janus Weil <janus@gcc.gnu.org>

	Initial patch version: Janus Weil
	* class.c (gfc_get_len_component): Added new routine.
	(gfc_build_class_symbol): Added _len component for unlimit. poly.
	(find_intrinsic_vtab): Removed emitting error message.
	* gfortran.h: Added prototype for gfc_get_len_component.
	* simplify.c (gfc_simplify_len): Use _len component where available.
	* trans-expr.c (gfc_class_len_get): Added routine.
	(gfc_conv_intrinsic_to_class): Added handling for deferred chararrays.
	(gfc_conv_structure): Treat _len component correctly.
	(gfc_conv_expr): Prevent bind_c handling when not required. 
	(add_assignment_of_string_len_to_len_component): Do _len = _len.
	(gfc_trans_pointer_assignment): Ensure _len component is propagated.
	* trans-stmt.c (class_has_len_component): Added.
	(trans_associate_var): _len component treatement for associate context.
	(gfc_trans_allocate): Same as for trans_associate_var().
	* trans.h: Added prototype for gfc_class_len_get.

gcc/testsuite/ChangeLog:

2014-12-30  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/unlimited_polymorphic_2.f03: Removed expected error.
	* gfortran.dg/unlimited_polymorphic_20.f03: New test.



[-- Attachment #3: pr60255_6.patch --]
[-- Type: text/x-patch, Size: 23713 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 5130022..3438826 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -34,6 +34,12 @@ along with GCC; see the file COPYING3.  If not see
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
 
+    Only for unlimited polymorphic classes:
+    * _len:  An integer(4) to store the string length when the unlimited
+             polymorphic pointer is used to point to a char array.  The '_len'
+             component will be zero when no character array is stored in
+             '_data'.
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -544,10 +550,42 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.  */
+
+gfc_expr *
+gfc_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;
+}
+
+
 /* Build a polymorphic CLASS entity, using the symbol that comes from
    build_sym. A CLASS entity is represented by an encapsulating type,
    which contains the declared type as '_data' component, plus a pointer
-   component '_vptr' which determines the dynamic type.  */
+   component '_vptr' which determines the dynamic type.  When this CLASS
+   entity is unlimited polymorphic, then also add a component '_len' to
+   store the length of string when that is stored in it.  */
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,19 +683,36 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!gfc_add_component (fclass, "_vptr", &c))
 	return false;
       c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
 	  vtab = gfc_find_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
+
+	  /* Add component '_len'.  Only unlimited polymorphic pointers may
+             have a string assigned to them, i.e., only those need the _len
+             component.  */
+	  if (!gfc_add_component (fclass, "_len", &c))
+	    return false;
+	  c->ts.type = BT_INTEGER;
+	  c->ts.kind = 4;
+	  c->attr.access = ACCESS_PRIVATE;
+	  c->attr.artificial = 1;
+
+	  /* Build minimal expression to initialize component with zero.
+	     TODO: When doing this, one goes to hell in the select type
+		   id association something in generating the constructor
+		   code really goes wrong.  Not using an initializer here
+		   needs extra code in the alloc statements.  */
+//	  c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+//					     NULL, 0);
 	}
       else
 	/* Build vtab later.  */
 	c->ts.u.derived = NULL;
-
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.pointer = 1;
     }
 
   if (!ts->u.derived->attr.unlimited_polymorphic)
@@ -2415,18 +2470,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)
@@ -2438,8 +2484,8 @@ 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);
+        sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+                 charlen, ts->kind);
       else
 	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 41c6c57..20c86b7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3123,8 +3123,10 @@ bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
 gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
+gfc_expr *gfc_get_len_component (gfc_expr *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+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/simplify.c b/gcc/fortran/simplify.c
index d46c5db..f4436ab 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3689,7 +3689,6 @@ gfc_simplify_leadz (gfc_expr *e)
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
 }
 
-
 gfc_expr *
 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
 {
@@ -3713,6 +3712,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 gfc_get_len_component (e);
+    }
   else
     return NULL;
 }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3793cfb..d5a49af 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -94,6 +94,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
    in future implementations.  Use the corresponding APIs.  */
 #define CLASS_DATA_FIELD 0
 #define CLASS_VPTR_FIELD 1
+#define CLASS_LEN_FIELD 2
 #define VTABLE_HASH_FIELD 0
 #define VTABLE_SIZE_FIELD 1
 #define VTABLE_EXTENDS_FIELD 2
@@ -148,6 +149,20 @@ gfc_class_vptr_get (tree decl)
 }
 
 
+tree
+gfc_class_len_get (tree decl)
+{
+  tree len;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_LEN_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (len), decl, len,
+			  NULL_TREE);
+}
+
+
 static tree
 gfc_vtable_field_get (tree decl, int field)
 {
@@ -617,6 +632,42 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
+  /* When the actual arg is a char array, then set the _len component of the
+     unlimited polymorphic entity, too.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      ctree = gfc_class_len_get (var);
+      if (e->ts.u.cl->backend_decl)
+        {
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+        }
+      else if (parmse->string_length)
+        {
+          gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+        }
+      else
+        {
+          /* Try to simplify the expression.  */
+          gfc_simplify_expr (e, 0);
+          if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+            {
+              /* Amazingly all data is present to compute the length of a
+                 constant string, but the expression is not yet there.  */
+              e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1,
+                                                          &e->where);
+              mpz_set_ui (e->ts.u.cl->length->value.integer,
+                          e->value.character.length);
+              gfc_conv_const_charlen (e->ts.u.cl);
+              e->ts.u.cl->resolved = 1;
+              gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+            }
+          else
+            {
+              gfc_error ("Can't compute the length of the char array at %L.",
+                         &e->where);
+            }
+        }
+    }
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 }
@@ -6489,6 +6540,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 				  fold_convert (TREE_TYPE (cm->backend_decl),
 						val));
 	}
+      else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+        {
+          gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+          val = gfc_conv_constant_to_tree (e);
+          CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+                                  fold_convert (TREE_TYPE (cm->backend_decl),
+                                                val));
+        }
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6565,7 +6624,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
+      /* TODO: Need to check, if this is correctly working for all cases.  */
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -6769,6 +6830,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)
 {
@@ -6833,6 +6931,19 @@ 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_CLASS || expr1->ts.type == BT_DERIVED)
+          && expr1->ts.u.derived->attr.unlimited_polymorphic
+          && (expr2->ts.type == BT_CHARACTER ||
+              ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
+              && expr2->ts.u.derived->attr.unlimited_polymorphic)))
+        {
+          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/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 24e47f2..78d11c1 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1143,6 +1143,21 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Return true, when the class has a _len component.  */
+
+static bool
+class_has_len_component (gfc_symbol *sym)
+{
+  gfc_component *comp = sym->ts.u.derived->components;
+  while (comp)
+    {
+      if (strcmp (comp->name, "_len") == 0)
+        return true;
+      comp = comp->next;
+    }
+  return false;
+}
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1156,6 +1171,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   tree offset;
   tree dim;
   int n;
+  tree charlen;
+  bool need_len_assign;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1166,6 +1183,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  /* Assignments to the string length need to be generated, when
+     ( sym is a char array or
+       sym has a _len component)
+     and the associated expression is unlimited polymorphic, which is
+     not (yet) correctly in 'unlimited', because for an already associated
+     BT_DERIVED the u-poly flag is not set, i.e.,
+      __tmp_CHARACTER_0_1 => w => arg
+       ^ generated temp      ^ from code, the w does not have the u-poly
+     flag set, where UNLIMITED_POLY(e) expects it.  */
+  need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
+                     && e->ts.u.derived->attr.unlimited_polymorphic))
+      && (sym->ts.type == BT_CHARACTER
+          || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
+              && class_has_len_component (sym))));
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
@@ -1217,7 +1248,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
 	}
-
       /* Done, register stuff as init / cleanup code.  */
       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
 			    gfc_finish_block (&se.post));
@@ -1247,7 +1277,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_add_modify (&se.pre, tmp,
 			  gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
 	}
-
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -1265,8 +1294,11 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	 unconditionally associate pointers and the symbol is scalar.  */
       if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
 	{
+	  tree target_expr;
 	  /* For a class array we need a descriptor for the selector.  */
 	  gfc_conv_expr_descriptor (&se, e);
+	  /* Needed to get/set the _len component below.  */
+	  target_expr = se.expr;
 
 	  /* Obtain a temporary class container for the result.  */
 	  gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
@@ -1286,6 +1318,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 				        gfc_array_index_type,
 				        offset, tmp);
 	    }
+	  if (need_len_assign)
+	    {
+	      /* Get the _len comp from the target expr by stripping _data
+		 from it and adding component-ref to _len.  */
+	      tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0));
+	      /* Get the component-ref for the temp structure's _len comp.  */
+	      charlen = gfc_class_len_get (se.expr);
+	      /* Add the assign to the beginning of the the block...  */
+	      gfc_add_modify (&se.pre, charlen,
+			      fold_convert (TREE_TYPE (charlen), tmp));
+	      /* and the oposite way at the end of the block, to hand changes
+	         on the string length back.  */
+	      gfc_add_modify (&se.post, tmp,
+			      fold_convert (TREE_TYPE (tmp), charlen));
+	      /* Length assignment done, prevent adding it again below.  */
+	      need_len_assign = false;
+	    }
 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
 	}
       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
@@ -1300,7 +1349,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
-	gfc_conv_expr (&se, e);
+        {
+          /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
+             which has the string length included.  For CHARACTERS it is still
+             needed and will be done at the end of this routine.  */
+          gfc_conv_expr (&se, e);
+          need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
+        }
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,21 +1376,30 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_add_init_cleanup (block, tmp, NULL_TREE);
     }
 
-  /* Set the stringlength from the vtable size.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+  /* Set the stringlength, when needed.  */
+  if (need_len_assign)
     {
-      tree charlen;
       gfc_se se;
       gfc_init_se (&se, NULL);
-      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
-      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
-      tmp = gfc_vtable_size_get (tmp);
+      if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+        {
+          /* What about deferred strings?  */
+          gcc_assert (!e->symtree->n.sym->ts.deferred);
+          tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
+        }
+      else
+        tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);
-      charlen = sym->ts.u.cl->backend_decl;
-      gfc_add_modify (&se.pre, charlen,
-		      fold_convert (TREE_TYPE (charlen), tmp));
-      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
-			    gfc_finish_block (&se.post));
+      charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+                                       : gfc_class_len_get (sym->backend_decl);
+      /* Prevent adding a noop len= len.  */
+      if (tmp != charlen)
+        {
+          gfc_add_modify (&se.pre, charlen,
+                          fold_convert (TREE_TYPE (charlen), tmp));
+          gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+                                gfc_finish_block (&se.post));
+        }
     }
 }
 
@@ -5050,6 +5114,15 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_modify (&se.pre, se.string_length,
 				fold_convert (TREE_TYPE (se.string_length),
 				memsz));
+	      else if ((al->expr->ts.type == BT_DERIVED
+			|| al->expr->ts.type == BT_CLASS)
+		       && expr->ts.u.derived->attr.unlimited_polymorphic)
+		{
+		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
+		  gfc_add_modify (&se.pre, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						memsz));
+		}
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 51ad910..3926c2a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -348,6 +348,7 @@ gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_len_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_vtable_hash_get (tree);
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
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
new file mode 100644
index 0000000..c6c6d29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
@@ -0,0 +1,104 @@
+! { dg-do run }
+!
+! Testing fix for PR fortran/60255
+!
+! Author: Andre Vehreschild <vehre@gmx.de>
+!
+MODULE m
+
+contains
+  subroutine bar (arg, res)
+    class(*) :: arg
+    character(100) :: res
+    select type (w => arg)
+      type is (character(*))
+        write (res, '(I2)') len(w)
+    end select
+  end subroutine
+
+END MODULE
+
+program test
+    use m;
+    implicit none
+    character(LEN=:), allocatable, target :: S
+    character(LEN=100) :: res
+    class(*), pointer :: ucp
+    call sub1 ("long test string", 16)
+    call sub2 ()
+    S = "test"
+    ucp => S
+    call sub3 (ucp)
+    call sub4 (S, 4)
+    call sub4 ("This is a longer string.", 24)
+    call bar (S, res)
+    if (trim (res) .NE. " 4") call abort ()
+    call bar(ucp, res)
+    if (trim (res) .NE. " 4") call abort ()
+
+contains
+
+    subroutine sub1(dcl, ilen)
+        character(len=*), target :: dcl
+        integer(4) :: ilen
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        ucp => dcl
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(dcl) .NE. ilen) call abort ()
+            if (len(ucp) .NE. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .NE. ilen) call abort ()
+        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) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub3(ucp)
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. 4) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. 4) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub4(ucp, ilen)
+        character(len=:), allocatable :: hlp
+        integer(4) :: ilen
+        class(*) :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. ilen) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+end program
+

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

[Dominique d'Humières]

The new patch fixes the ICEs, but still emit the wrong codes reported in pr61337.

Thanks and Happy New Year to all,

Dominique

> Le 30 déc. 2014 à 14:39, Andre Vehreschild <vehre@gmx.de> a écrit :
> 
> Hi Dominique,
> 
> thanks for pointing that out. That was caused by a flaw in the current patch.
> In the attached version this is fixed now.
> 
> Bootstraps and regtests ok on x86_64-linux-gnu.
> 
> Regards,
> 	Andre
> 
> On Mon, 29 Dec 2014 16:32:27 +0100
> Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> 
>> For the record, compiling the tests in pr61337 with the patch applied on top
>> of r219099 gives ICEs:
>> 
>>   use array_list
>> 1
>> internal compiler error: in gfc_advance_chain, at fortran/trans.c:58
>> 
>> Since this replaces some wrong-code generation by some ICEs, I don’t think
>> this should delay the fix of pr60255.
>> 
>> Cheers,
>> 
>> Dominique

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

[Andre Vehreschild]

Hi all,

sorry for duplicates, but the initial answer was rejected by the qmail-daemon
of the fortran-list due to my mobile sending html.

Now, the patch was not intended to solve 61337. Although I have looked into the
pseudo code generated for 61337, I couldn't figure easily what is going on
there. In my impression, this is something from incorrectly computed bounds to
an integer(8),pointer integer(4),pointer mix up. Therefore no patch for that
from my side currently. 

Nevertheless, do I hope that some reviewer finds a minute to look at the patch
for pr60255.

Regards,
	Andre

On Tue, 30 Dec 2014 16:35:48 +0100
Dominique d'Humières <dominiq@lps.ens.fr> wrote:

> The new patch fixes the ICEs, but still emit the wrong codes reported in
> pr61337.
> 
> Thanks and Happy New Year to all,
> 
> Dominique
> 
> > Le 30 déc. 2014 à 14:39, Andre Vehreschild <vehre@gmx.de> a écrit :
> > 
> > Hi Dominique,
> > 
> > thanks for pointing that out. That was caused by a flaw in the current
> > patch. In the attached version this is fixed now.
> > 
> > Bootstraps and regtests ok on x86_64-linux-gnu.
> > 
> > Regards,
> > 	Andre
> > 
> > On Mon, 29 Dec 2014 16:32:27 +0100
> > Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> > 
> >> For the record, compiling the tests in pr61337 with the patch applied on
> >> top of r219099 gives ICEs:
> >> 
> >>   use array_list
> >> 1
> >> internal compiler error: in gfc_advance_chain, at fortran/trans.c:58
> >> 
> >> Since this replaces some wrong-code generation by some ICEs, I don’t think
> >> this should delay the fix of pr60255.
> >> 
> >> Cheers,
> >> 
> >> Dominique
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

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

[Janus Weil]

Hi Andre,

> Now, the patch was not intended to solve 61337. Although I have looked into the
> pseudo code generated for 61337, I couldn't figure easily what is going on
> there. In my impression, this is something from incorrectly computed bounds to
> an integer(8),pointer integer(4),pointer mix up. Therefore no patch for that
> from my side currently.

I think that this a completely different issue from that addressed by
your patch and I don't think you should tackle anything
non-character-related in your patch.


> Nevertheless, do I hope that some reviewer finds a minute to look at the patch
> for pr60255.

I had a look over the patch, and it looks mostly fine to me. A few remarks:

1) There are still two TODO markers in the patch. It might be a good
idea to take care of them before committing the patch. In particular
for the first one (adding the initializer in gfc_build_class_symbol)
it would be good to understand where those problems come from. For the
second one (in gfc_conv_expr), I don't directly see how it's related
to deferred char-len. Why is this change needed?

2) You're making a lot of changes to 'trans_associate_var', but I
don't see any ASSOCIATE statements covered in your test case. Can you
add more test cases which cover this code?

3) The function 'gfc_get_len_component' that you're introducing is
only called in a single place. Do you expect this to be useful in
other places in the future, or could one remove the function and
insert the code inline?

4) You're adding a prototype for a function
'gfc_assign_charlen_to_unlimited_poly' in gfortran.h which never gets
implemented.

5) The second hunk in find_intrinsic_vtab is a whitespace-only change
which should not occur at all AFAICS.

In any case, thanks for working on this!

Cheers,
Janus



> On Tue, 30 Dec 2014 16:35:48 +0100
> Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>
>> The new patch fixes the ICEs, but still emit the wrong codes reported in
>> pr61337.
>>
>> Thanks and Happy New Year to all,
>>
>> Dominique
>>
>> > Le 30 déc. 2014 à 14:39, Andre Vehreschild <vehre@gmx.de> a écrit :
>> >
>> > Hi Dominique,
>> >
>> > thanks for pointing that out. That was caused by a flaw in the current
>> > patch. In the attached version this is fixed now.
>> >
>> > Bootstraps and regtests ok on x86_64-linux-gnu.
>> >
>> > Regards,
>> >     Andre
>> >
>> > On Mon, 29 Dec 2014 16:32:27 +0100
>> > Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>> >
>> >> For the record, compiling the tests in pr61337 with the patch applied on
>> >> top of r219099 gives ICEs:
>> >>
>> >>   use array_list
>> >> 1
>> >> internal compiler error: in gfc_advance_chain, at fortran/trans.c:58
>> >>
>> >> Since this replaces some wrong-code generation by some ICEs, I don’t think
>> >> this should delay the fix of pr60255.
>> >>
>> >> Cheers,
>> >>
>> >> Dominique
>>
>
>
> --
> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> Tel.: +49 241 9291018 * Email: vehre@gmx.de

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

[Andre Vehreschild]

Hi Janus,

thank you for your review. 

> I had a look over the patch, and it looks mostly fine to me. A few remarks:
> 
> 1) There are still two TODO markers in the patch. It might be a good
> idea to take care of them before committing the patch. In particular
> for the first one (adding the initializer in gfc_build_class_symbol)
> it would be good to understand where those problems come from. 

I started with the initializer for the _len component and ran into "Pointer
assignment target is neither TARGET nor POINTER at %L" errors (expr.c:3714). I
tracked this back to the constructor resolve of the class type. Resolving the
constructor somehow concludes, that something needs to be done for the constant
initializer although it is marked artificial. I could not track down the
location that is causing this behavior, or if I need to set a flag in the class
itself to get through with it. I am hoping, that either some fortran guru says
"You just need to do xyz to get it running." or that we conclude to remove the
TODO and the commented instructions (setting a zero value for _len is done where
needed (gfc_conv_structure trans-expr.c:6540)).

> For the
> second one (in gfc_conv_expr), I don't directly see how it's related
> to deferred char-len. Why is this change needed?

That change is needed, because in some rare case where an associated variable
in a "select type ()" is used, then the type and f90_type match the condition
while them not really being in a bind_c context. Therefore I have added
the check for bind_c. Btw, I now have removed the TODO, because that case is
covered by the regression tests. 

> 2) You're making a lot of changes to 'trans_associate_var', but I
> don't see any ASSOCIATE statements covered in your test case. Can you
> add more test cases which cover this code?

Select type (assoc => upoly) uses these where an explicit assoc is supplied.
The many changes are needed to migrate from using _vptr%size to then _len
component. All these changes are covered by existing regression tests starting
from unlimited_polymorphic_N.* to the character_length tests. The remaining open
cases not covered by existing tests are in unlimited_polymorphic_20.f03.

> 3) The function 'gfc_get_len_component' that you're introducing is
> only called in a single place. Do you expect this to be useful in
> other places in the future, or could one remove the function and
> insert the code inline?

In one of the first versions it was uses from two locations. But I had to
remove one call site again. I am currently not sure, if I will be using it in
the patch for allocatable components when deferred char arrays are handled. So
what I do I do now? Inline it and when needed make it explicit again in a
future patch?

> 4) You're adding a prototype for a function
> 'gfc_assign_charlen_to_unlimited_poly' in gfortran.h which never gets
> implemented.

Whoopsie, sorry, removed. 

> 5) The second hunk in find_intrinsic_vtab is a whitespace-only change
> which should not occur at all AFAICS.

Yep, agreed. Misconfigured my IDE. Fixed. Sorry for the noise.


So two open questions remain:
ad 1) How to handle the initializer?
ad 3) What to do with the function?

Can you give me an opinion, then I will change the patch and resubmit.

> In any case, thanks for working on this!

Your welcome and happy new year to you.

Regards,
	Andre

Btw, just cleaning up some oddities in the allocatable component patch for
pr60357/pr61337/pr55901 (and may be covering others). Then that one goes
public, too. (pr60357 is just my working title. I know it is fixed already by
your patch.)

> 
> Cheers,
> Janus
> 
> 
> 
> > On Tue, 30 Dec 2014 16:35:48 +0100
> > Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> >
> >> The new patch fixes the ICEs, but still emit the wrong codes reported in
> >> pr61337.
> >>
> >> Thanks and Happy New Year to all,
> >>
> >> Dominique
> >>
> >> > Le 30 déc. 2014 à 14:39, Andre Vehreschild <vehre@gmx.de> a écrit :
> >> >
> >> > Hi Dominique,
> >> >
> >> > thanks for pointing that out. That was caused by a flaw in the current
> >> > patch. In the attached version this is fixed now.
> >> >
> >> > Bootstraps and regtests ok on x86_64-linux-gnu.
> >> >
> >> > Regards,
> >> >     Andre
> >> >
> >> > On Mon, 29 Dec 2014 16:32:27 +0100
> >> > Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> >> >
> >> >> For the record, compiling the tests in pr61337 with the patch applied on
> >> >> top of r219099 gives ICEs:
> >> >>
> >> >>   use array_list
> >> >> 1
> >> >> internal compiler error: in gfc_advance_chain, at fortran/trans.c:58
> >> >>
> >> >> Since this replaces some wrong-code generation by some ICEs, I don’t
> >> >> think this should delay the fix of pr60255.
> >> >>
> >> >> Cheers,
> >> >>
> >> >> Dominique
> >>
> >
> >
> > --
> > Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> > Tel.: +49 241 9291018 * Email: vehre@gmx.de


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

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

[Janus Weil]

Hi Andre,

>> 1) There are still two TODO markers in the patch. It might be a good
>> idea to take care of them before committing the patch. In particular
>> for the first one (adding the initializer in gfc_build_class_symbol)
>> it would be good to understand where those problems come from.
>
> I started with the initializer for the _len component and ran into "Pointer
> assignment target is neither TARGET nor POINTER at %L" errors (expr.c:3714). I
> tracked this back to the constructor resolve of the class type. Resolving the
> constructor somehow concludes, that something needs to be done for the constant
> initializer although it is marked artificial. I could not track down the
> location that is causing this behavior, or if I need to set a flag in the class
> itself to get through with it. I am hoping, that either some fortran guru says
> "You just need to do xyz to get it running." or that we conclude to remove the
> TODO and the commented instructions (setting a zero value for _len is done where
> needed (gfc_conv_structure trans-expr.c:6540)).

I can reproduce the "pointer assignment ..." error, but I'm not sure
if there is any good way to get rid of it.
I'm not even sure if it is a good idea to add an initializer for the
_len component at all, since neither _data nor _vptr have one.
So, I'm fine with just removing the commented code and the TODO
marker, as long as everything works and you make sure the _len
component is properly initialized before it is accessed.


>> For the
>> second one (in gfc_conv_expr), I don't directly see how it's related
>> to deferred char-len. Why is this change needed?
>
> That change is needed, because in some rare case where an associated variable
> in a "select type ()" is used, then the type and f90_type match the condition
> while them not really being in a bind_c context. Therefore I have added
> the check for bind_c. Btw, I now have removed the TODO, because that case is
> covered by the regression tests.

I don't understand how f90_type can be BT_VOID without being in a
BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
case is the one that triggered this?


>> 2) You're making a lot of changes to 'trans_associate_var', but I
>> don't see any ASSOCIATE statements covered in your test case. Can you
>> add more test cases which cover this code?
>
> Select type (assoc => upoly) uses these where an explicit assoc is supplied.

Ah, right. Forgot about that.


>> 3) The function 'gfc_get_len_component' that you're introducing is
>> only called in a single place. Do you expect this to be useful in
>> other places in the future, or could one remove the function and
>> insert the code inline?
>
> In one of the first versions it was uses from two locations. But I had to
> remove one call site again. I am currently not sure, if I will be using it in
> the patch for allocatable components when deferred char arrays are handled. So
> what I do I do now? Inline it and when needed make it explicit again in a
> future patch?

I leave that up to you. In principle I'm fine with keeping it as it
is. The only problem I see is that the function name sounds rather
general, but it apparently expects the expression to be an ASSOCIATE
symbol.

If you want to keep the function, I would either:
a) document it more properly, or
b) even better: make it more general by calling it like

return gfc_get_len_component (e->symtree->n.sym->assoc->target);

and inside use

gfc_expr *len_comp = gfc_copy_expr (e);

Maybe it can be more useful also in other places like this?


Cheers,
Janus

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

[Andre Vehreschild]

Hi Janus,

thanks for the quick response. Please see my answers inline.

On Sat, 3 Jan 2015 13:12:28 +0100
Janus Weil <janus@gcc.gnu.org> wrote:

<snipp>
> > I started with the initializer for the _len component and ran into "Pointer
> > assignment target is neither TARGET nor POINTER at %L" errors
> > (expr.c:3714). I tracked this back to the constructor resolve of the class
> > type. Resolving the constructor somehow concludes, that something needs to
> > be done for the constant initializer although it is marked artificial. I
> > could not track down the location that is causing this behavior, or if I
> > need to set a flag in the class itself to get through with it. I am hoping,
> > that either some fortran guru says "You just need to do xyz to get it
> > running." or that we conclude to remove the TODO and the commented
> > instructions (setting a zero value for _len is done where needed
> > (gfc_conv_structure trans-expr.c:6540)).
> 
> I can reproduce the "pointer assignment ..." error, but I'm not sure
> if there is any good way to get rid of it.
> I'm not even sure if it is a good idea to add an initializer for the
> _len component at all, since neither _data nor _vptr have one.
> So, I'm fine with just removing the commented code and the TODO
> marker, as long as everything works and you make sure the _len
> component is properly initialized before it is accessed.

Removed it.

> >> For the
> >> second one (in gfc_conv_expr), I don't directly see how it's related
> >> to deferred char-len. Why is this change needed?
> >
> > That change is needed, because in some rare case where an associated
> > variable in a "select type ()" is used, then the type and f90_type match
> > the condition while them not really being in a bind_c context. Therefore I
> > have added the check for bind_c. Btw, I now have removed the TODO, because
> > that case is covered by the regression tests.
> 
> I don't understand how f90_type can be BT_VOID without being in a
> BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
> case is the one that triggered this?

This case is triggered by the test-case in the patch, where in the select type
(w => arg) in module m routine bar the w meets the criteria to make the
condition become true. The type of w is then "fixed" and gfortran would
terminate, because the type of w would be set be and BT_INTEGER. I tried to
backtrace where this is coming from, but to no success. In the resolve () of
the select type it looks all quite ok, but in the trans stage the criteria are
met. Most intriguing to me is, that in the condition we are talking about the
type of w and f90_type of the derived class' ts
(expr->ts.u.derived->ts.f90_type) of w is examined. But expr->ts.u.derived->ts
does not describe the type of w, but of the class w is associate with __STAR...

So I am not quite sure how to fix this, if this really needs fixing. When I
understand you right, then f90_type should only be set in a bind_c context, so
adding that check wouldn't hurt, right?
 
<snipp>

> >> 3) The function 'gfc_get_len_component' that you're introducing is
> >> only called in a single place. Do you expect this to be useful in
> >> other places in the future, or could one remove the function and
> >> insert the code inline?
> >
> > In one of the first versions it was uses from two locations. But I had to
> > remove one call site again. I am currently not sure, if I will be using it
> > in the patch for allocatable components when deferred char arrays are
> > handled. So what I do I do now? Inline it and when needed make it explicit
> > again in a future patch?
> 
> I leave that up to you. In principle I'm fine with keeping it as it
> is. The only problem I see is that the function name sounds rather
> general, but it apparently expects the expression to be an ASSOCIATE
> symbol.

I am nearly finished with the patch on allocatable scalar components and I don't
need the code there. Therefore I have inlined the routine.

So, what do we do about the bind_c issue above? Is some bind_c guru available
to have a look at this? It would be very much appreciated.

Regards,
	Andre
-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

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

[Janus Weil]

Hi Andre,

>> >> For the
>> >> second one (in gfc_conv_expr), I don't directly see how it's related
>> >> to deferred char-len. Why is this change needed?
>> >
>> > That change is needed, because in some rare case where an associated
>> > variable in a "select type ()" is used, then the type and f90_type match
>> > the condition while them not really being in a bind_c context. Therefore I
>> > have added the check for bind_c. Btw, I now have removed the TODO, because
>> > that case is covered by the regression tests.
>>
>> I don't understand how f90_type can be BT_VOID without being in a
>> BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
>> case is the one that triggered this?
>
> This case is triggered by the test-case in the patch, where in the select type
> (w => arg) in module m routine bar the w meets the criteria to make the
> condition become true. The type of w is then "fixed" and gfortran would
> terminate, because the type of w would be set be and BT_INTEGER. I tried to
> backtrace where this is coming from, but to no success. In the resolve () of
> the select type it looks all quite ok, but in the trans stage the criteria are
> met. Most intriguing to me is, that in the condition we are talking about the
> type of w and f90_type of the derived class' ts
> (expr->ts.u.derived->ts.f90_type) of w is examined. But expr->ts.u.derived->ts
> does not describe the type of w, but of the class w is associate with __STAR...
>
> So I am not quite sure how to fix this, if this really needs fixing. When I
> understand you right, then f90_type should only be set in a bind_c context, so
> adding that check wouldn't hurt, right?

Yes, in principle adding the check for attr.bind_c looks ok to me
(alternatively one could also check for attr.unlimited_polymorphic). I
think originally BT_VOID was indeed only used in a bind_c context, but
recently it has also been 'hijacked' for unlimited polymorphism, e.g.
for the STAR symbol and some of the components of the intrinsic vtabs.

What I don't really understand is why these problems are triggered by
your patch now and have not crept up earlier in other use-cases of
CLASS(*).


>> >> 3) The function 'gfc_get_len_component' that you're introducing is
>> >> only called in a single place. Do you expect this to be useful in
>> >> other places in the future, or could one remove the function and
>> >> insert the code inline?
>> >
>> > In one of the first versions it was uses from two locations. But I had to
>> > remove one call site again. I am currently not sure, if I will be using it
>> > in the patch for allocatable components when deferred char arrays are
>> > handled. So what I do I do now? Inline it and when needed make it explicit
>> > again in a future patch?
>>
>> I leave that up to you. In principle I'm fine with keeping it as it
>> is. The only problem I see is that the function name sounds rather
>> general, but it apparently expects the expression to be an ASSOCIATE
>> symbol.
>
> I am nearly finished with the patch on allocatable scalar components and I don't
> need the code there. Therefore I have inlined the routine.

Ok, good. Could you please post an updated patch?


> So, what do we do about the bind_c issue above? Is some bind_c guru available
> to have a look at this? It would be very much appreciated.

From my non-guru POV, it can stay as is.

It would be helpful if someone like Paul or Tobias could have a look
at the patch before it goes to trunk. I think it's pretty close to
being ready for prime-time. Thanks for your work!

Cheers,
Janus

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

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 5698 bytes --]

Hi Janus, hi Paul, hi Tobias,

Janus: During code review, I found that I had the code in
gfc_get_len_component() duplicated. So I now reintroduced and documented the
routine making is more commonly usable and added more documentation. The call
sites are now simplify.c (gfc_simplify_len) and trans-expr.c
(gfc_trans_pointer_assignment). Attached is the reworked version of the patch.

Paul, Tobias: Can one of you have a look at line 253 of the patch? I need some
expertise on the bind_c behavior. My patch needs the check for is_bind_c added
in trans_expr.c (gfc_conv_expr) to prevent mistyping an associated variable
in a select type() during the conv. Background: This code fragment taken from
the testcase in the patch:

MODULE m
contains
  subroutine bar (arg, res)
    class(*) :: arg
    character(100) :: res
    select type (w => arg)
      type is (character(*))
        write (res, '(I2)') len(w)
    end select
  end subroutine
END MODULE

has the conditions required for line trans-expr.c:6630 of gfc_conv_expr when
the associate variable w is converted. This transforms the type of the
associate variable to something unexpected in the further processing leading to
some issues during fortraning. Janus told me, that the f90_type has been abused
for some other things (unlimited polymorphic treatment). Although I believe
that reading the comments above the if in question, the check I had to enhance
is treating bind_c stuff (see the threads content for more). I would feel safer
when one of you gfortran gurus can have a look and given an opinion, whether
the change is problematic. I couldn't figure why w is resolved to meet the
criteria (any ideas). Btw, all regtest are ok reporting no issues at all.

Bootstraps and regtests ok on x86_64-linux-gnu

Regards,
	Andre


On Sat, 3 Jan 2015 16:45:07 +0100
Janus Weil <janus@gcc.gnu.org> wrote:

> Hi Andre,
> 
> >> >> For the
> >> >> second one (in gfc_conv_expr), I don't directly see how it's related
> >> >> to deferred char-len. Why is this change needed?
> >> >
> >> > That change is needed, because in some rare case where an associated
> >> > variable in a "select type ()" is used, then the type and f90_type match
> >> > the condition while them not really being in a bind_c context. Therefore
> >> > I have added the check for bind_c. Btw, I now have removed the TODO,
> >> > because that case is covered by the regression tests.
> >>
> >> I don't understand how f90_type can be BT_VOID without being in a
> >> BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
> >> case is the one that triggered this?
> >
> > This case is triggered by the test-case in the patch, where in the select
> > type (w => arg) in module m routine bar the w meets the criteria to make the
> > condition become true. The type of w is then "fixed" and gfortran would
> > terminate, because the type of w would be set be and BT_INTEGER. I tried to
> > backtrace where this is coming from, but to no success. In the resolve () of
> > the select type it looks all quite ok, but in the trans stage the criteria
> > are met. Most intriguing to me is, that in the condition we are talking
> > about the type of w and f90_type of the derived class' ts
> > (expr->ts.u.derived->ts.f90_type) of w is examined. But
> > expr->ts.u.derived->ts does not describe the type of w, but of the class w
> > is associate with __STAR...
> >
> > So I am not quite sure how to fix this, if this really needs fixing. When I
> > understand you right, then f90_type should only be set in a bind_c context,
> > so adding that check wouldn't hurt, right?
> 
> Yes, in principle adding the check for attr.bind_c looks ok to me
> (alternatively one could also check for attr.unlimited_polymorphic). I
> think originally BT_VOID was indeed only used in a bind_c context, but
> recently it has also been 'hijacked' for unlimited polymorphism, e.g.
> for the STAR symbol and some of the components of the intrinsic vtabs.
> 
> What I don't really understand is why these problems are triggered by
> your patch now and have not crept up earlier in other use-cases of
> CLASS(*).
> 
> 
> >> >> 3) The function 'gfc_get_len_component' that you're introducing is
> >> >> only called in a single place. Do you expect this to be useful in
> >> >> other places in the future, or could one remove the function and
> >> >> insert the code inline?
> >> >
> >> > In one of the first versions it was uses from two locations. But I had to
> >> > remove one call site again. I am currently not sure, if I will be using
> >> > it in the patch for allocatable components when deferred char arrays are
> >> > handled. So what I do I do now? Inline it and when needed make it
> >> > explicit again in a future patch?
> >>
> >> I leave that up to you. In principle I'm fine with keeping it as it
> >> is. The only problem I see is that the function name sounds rather
> >> general, but it apparently expects the expression to be an ASSOCIATE
> >> symbol.
> >
> > I am nearly finished with the patch on allocatable scalar components and I
> > don't need the code there. Therefore I have inlined the routine.
> 
> Ok, good. Could you please post an updated patch?
> 
> 
> > So, what do we do about the bind_c issue above? Is some bind_c guru
> > available to have a look at this? It would be very much appreciated.
> 
> From my non-guru POV, it can stay as is.
> 
> It would be helpful if someone like Paul or Tobias could have a look
> at the patch before it goes to trunk. I think it's pretty close to
> being ready for prime-time. Thanks for your work!
> 
> Cheers,
> Janus


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

[-- Attachment #2: pr60255_7.clog --]
[-- Type: application/octet-stream, Size: 1231 bytes --]

gcc/fortran/ChangeLog:

2015-01-04  Andre Vehreschild  <vehre@gmx.de>, Janus Weil <janus@gcc.gnu.org>

        Initial patch version: Janus Weil
	* class.c (gfc_get_len_component): Added new routine (len get on expr).
	(gfc_build_class_symbol): Added _len component for unlimit. poly.
	(find_intrinsic_vtab): Removed emitting of error message.
	* gfortran.h: Added prototype for gfc_get_len_component.
	* simplify.c (gfc_simplify_len): Use _len component where available.
	* trans-expr.c (gfc_class_len_get): Added routine (len get on trees).
	(gfc_conv_intrinsic_to_class): Added handling for deferred chararrays.
	(gfc_conv_structure): Treat _len component correctly.
	(gfc_conv_expr): Prevent bind_c handling when not required.
	(gfc_trans_pointer_assignment): Ensure _len component is propagated.
	* trans-stmt.c (class_has_len_component): Added.
	(trans_associate_var): _len component treatement for associate context.
	(gfc_trans_allocate): Same as for trans_associate_var()
	* trans.h: Added prototype for gfc_class_len_get.

gcc/testsuite/ChangeLog:

2015-01-04  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/unlimited_polymorphic_2.f03: Removed expected error.
	* gfortran.dg/unlimited_polymorphic_20.f03: New test.



[-- Attachment #3: pr60255_7.patch --]
[-- Type: text/x-patch, Size: 21241 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 5130022..eda825c 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -34,6 +34,12 @@ along with GCC; see the file COPYING3.  If not see
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
 
+    Only for unlimited polymorphic classes:
+    * _len:  An integer(4) to store the string length when the unlimited
+             polymorphic pointer is used to point to a char array.  The '_len'
+             component will be zero when no character array is stored in
+             '_data'.
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -544,10 +550,48 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.
+   For unlimited polymorphic entities a ref to the _data component is available
+   while a ref to the _len component is needed.  This routine traverese the
+   ref-chain and strips the last ref to a _data from it replacing it with a
+   ref to the _len component.  */
+
+gfc_expr *
+gfc_get_len_component (gfc_expr *e)
+{
+  gfc_expr *ptr;
+  gfc_ref *ref, **last;
+
+  ptr = gfc_copy_expr (e);
+
+  /* We need to remove the last _data component ref from ptr.  */
+  last = &(ptr->ref);
+  ref = ptr->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;
+    }
+  /* And replace if with a ref to the _len component.  */
+  gfc_add_component_ref (ptr, "_len");
+  return ptr;
+}
+
+
 /* Build a polymorphic CLASS entity, using the symbol that comes from
    build_sym. A CLASS entity is represented by an encapsulating type,
    which contains the declared type as '_data' component, plus a pointer
-   component '_vptr' which determines the dynamic type.  */
+   component '_vptr' which determines the dynamic type.  When this CLASS
+   entity is unlimited polymorphic, then also add a component '_len' to
+   store the length of string when that is stored in it.  */
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,19 +689,28 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!gfc_add_component (fclass, "_vptr", &c))
 	return false;
       c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
 	  vtab = gfc_find_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
+
+	  /* Add component '_len'.  Only unlimited polymorphic pointers may
+             have a string assigned to them, i.e., only those need the _len
+             component.  */
+	  if (!gfc_add_component (fclass, "_len", &c))
+	    return false;
+	  c->ts.type = BT_INTEGER;
+	  c->ts.kind = 4;
+	  c->attr.access = ACCESS_PRIVATE;
+	  c->attr.artificial = 1;
 	}
       else
 	/* Build vtab later.  */
 	c->ts.u.derived = NULL;
-
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.pointer = 1;
     }
 
   if (!ts->u.derived->attr.unlimited_polymorphic)
@@ -2415,18 +2468,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)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 41c6c57..d4bfeea 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3123,6 +3123,7 @@ bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
 gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
+gfc_expr *gfc_get_len_component (gfc_expr *e);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index d46c5db..ac2d3f7 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3713,6 +3713,14 @@ 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)
+    /* The expression in assoc->target points to a ref to the _data component
+       of the unlimited polymorphic entity.  To get the _len component the last
+       _data ref needs to be stripped and a ref to the _len component added.  */
+    return gfc_get_len_component (e->symtree->n.sym->assoc->target);
   else
     return NULL;
 }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3793cfb..2ebf959 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -94,6 +94,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
    in future implementations.  Use the corresponding APIs.  */
 #define CLASS_DATA_FIELD 0
 #define CLASS_VPTR_FIELD 1
+#define CLASS_LEN_FIELD 2
 #define VTABLE_HASH_FIELD 0
 #define VTABLE_SIZE_FIELD 1
 #define VTABLE_EXTENDS_FIELD 2
@@ -148,6 +149,20 @@ gfc_class_vptr_get (tree decl)
 }
 
 
+tree
+gfc_class_len_get (tree decl)
+{
+  tree len;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_LEN_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (len), decl, len,
+			  NULL_TREE);
+}
+
+
 static tree
 gfc_vtable_field_get (tree decl, int field)
 {
@@ -617,6 +632,45 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
+  /* When the actual arg is a char array, then set the _len component of the
+     unlimited polymorphic entity, too.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      ctree = gfc_class_len_get (var);
+      /* Start with parmse->string_length because this seems to be set to a
+	 correct value more often.  */
+      if (parmse->string_length)
+	  gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+      /* When the string_length is not yet set, then try the backend_decl of
+	 the cl.  */
+      else if (e->ts.u.cl->backend_decl)
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+      /* If both of the above approaches fail, then try to generate an
+	 expression from the input, which is only feasible currently, when the
+	 expression can be evaluated to a constant one.  */
+      else
+        {
+          /* Try to simplify the expression.  */
+          gfc_simplify_expr (e, 0);
+          if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+            {
+              /* Amazingly all data is present to compute the length of a
+                 constant string, but the expression is not yet there.  */
+              e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1,
+                                                          &e->where);
+              mpz_set_ui (e->ts.u.cl->length->value.integer,
+                          e->value.character.length);
+              gfc_conv_const_charlen (e->ts.u.cl);
+              e->ts.u.cl->resolved = 1;
+              gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+            }
+          else
+            {
+              gfc_error ("Can't compute the length of the char array at %L.",
+                         &e->where);
+            }
+        }
+    }
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 }
@@ -6489,6 +6543,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 				  fold_convert (TREE_TYPE (cm->backend_decl),
 						val));
 	}
+      else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+        {
+          gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+          val = gfc_conv_constant_to_tree (e);
+          CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+                                  fold_convert (TREE_TYPE (cm->backend_decl),
+                                                val));
+        }
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6565,7 +6627,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -6833,6 +6896,27 @@ 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_CLASS || expr1->ts.type == BT_DERIVED)
+	  && expr1->ts.u.derived->attr.unlimited_polymorphic
+	  && (expr2->ts.type == BT_CHARACTER ||
+	      ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
+	       && expr2->ts.u.derived->attr.unlimited_polymorphic)))
+	{
+	  gfc_expr *len_comp;
+	  gfc_se se;
+	  len_comp = gfc_get_len_component (expr1);
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, len_comp);
+
+	  /* ptr % _len = len (str)  */
+	  gfc_add_modify (&block, se.expr, rse.string_length);
+	  lse.string_length = se.expr;
+	  gfc_free_expr (len_comp);
+	}
+
       /* 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/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 24e47f2..3a3c31b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1143,6 +1143,22 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Return true, when the class has a _len component.  */
+
+static bool
+class_has_len_component (gfc_symbol *sym)
+{
+  gfc_component *comp = sym->ts.u.derived->components;
+  while (comp)
+    {
+      if (strcmp (comp->name, "_len") == 0)
+	return true;
+      comp = comp->next;
+    }
+  return false;
+}
+
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1156,6 +1172,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   tree offset;
   tree dim;
   int n;
+  tree charlen;
+  bool need_len_assign;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1166,6 +1184,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  /* Assignments to the string length need to be generated, when
+     ( sym is a char array or
+       sym has a _len component)
+     and the associated expression is unlimited polymorphic, which is
+     not (yet) correctly in 'unlimited', because for an already associated
+     BT_DERIVED the u-poly flag is not set, i.e.,
+      __tmp_CHARACTER_0_1 => w => arg
+       ^ generated temp      ^ from code, the w does not have the u-poly
+     flag set, where UNLIMITED_POLY(e) expects it.  */
+  need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
+                     && e->ts.u.derived->attr.unlimited_polymorphic))
+      && (sym->ts.type == BT_CHARACTER
+          || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
+              && class_has_len_component (sym))));
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
@@ -1265,8 +1297,11 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	 unconditionally associate pointers and the symbol is scalar.  */
       if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
 	{
+	  tree target_expr;
 	  /* For a class array we need a descriptor for the selector.  */
 	  gfc_conv_expr_descriptor (&se, e);
+	  /* Needed to get/set the _len component below.  */
+	  target_expr = se.expr;
 
 	  /* Obtain a temporary class container for the result.  */
 	  gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
@@ -1286,6 +1321,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 				        gfc_array_index_type,
 				        offset, tmp);
 	    }
+	  if (need_len_assign)
+	    {
+	      /* Get the _len comp from the target expr by stripping _data
+		 from it and adding component-ref to _len.  */
+	      tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0));
+	      /* Get the component-ref for the temp structure's _len comp.  */
+	      charlen = gfc_class_len_get (se.expr);
+	      /* Add the assign to the beginning of the the block...  */
+	      gfc_add_modify (&se.pre, charlen,
+			      fold_convert (TREE_TYPE (charlen), tmp));
+	      /* and the oposite way at the end of the block, to hand changes
+		 on the string length back.  */
+	      gfc_add_modify (&se.post, tmp,
+			      fold_convert (TREE_TYPE (tmp), charlen));
+	      /* Length assignment done, prevent adding it again below.  */
+	      need_len_assign = false;
+	    }
 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
 	}
       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
@@ -1300,7 +1352,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
-	gfc_conv_expr (&se, e);
+	{
+	  /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
+	     which has the string length included.  For CHARACTERS it is still
+	     needed and will be done at the end of this routine.  */
+	  gfc_conv_expr (&se, e);
+	  need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
+	}
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,21 +1379,30 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_add_init_cleanup (block, tmp, NULL_TREE);
     }
 
-  /* Set the stringlength from the vtable size.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+  /* Set the stringlength, when needed.  */
+  if (need_len_assign)
     {
-      tree charlen;
       gfc_se se;
       gfc_init_se (&se, NULL);
-      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
-      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
-      tmp = gfc_vtable_size_get (tmp);
+      if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+	{
+	  /* What about deferred strings?  */
+	  gcc_assert (!e->symtree->n.sym->ts.deferred);
+	  tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
+	}
+      else
+	tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);
-      charlen = sym->ts.u.cl->backend_decl;
-      gfc_add_modify (&se.pre, charlen,
-		      fold_convert (TREE_TYPE (charlen), tmp));
-      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
-			    gfc_finish_block (&se.post));
+      charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+					: gfc_class_len_get (sym->backend_decl);
+      /* Prevent adding a noop len= len.  */
+      if (tmp != charlen)
+	{
+	  gfc_add_modify (&se.pre, charlen,
+			  fold_convert (TREE_TYPE (charlen), tmp));
+	  gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+				gfc_finish_block (&se.post));
+	}
     }
 }
 
@@ -5050,6 +5117,15 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_modify (&se.pre, se.string_length,
 				fold_convert (TREE_TYPE (se.string_length),
 				memsz));
+	      else if ((al->expr->ts.type == BT_DERIVED
+			|| al->expr->ts.type == BT_CLASS)
+		       && expr->ts.u.derived->attr.unlimited_polymorphic)
+		{
+		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
+		  gfc_add_modify (&se.pre, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						memsz));
+		}
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 51ad910..3926c2a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -348,6 +348,7 @@ gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_len_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_vtable_hash_get (tree);
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
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
new file mode 100644
index 0000000..c6c6d29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
@@ -0,0 +1,104 @@
+! { dg-do run }
+!
+! Testing fix for PR fortran/60255
+!
+! Author: Andre Vehreschild <vehre@gmx.de>
+!
+MODULE m
+
+contains
+  subroutine bar (arg, res)
+    class(*) :: arg
+    character(100) :: res
+    select type (w => arg)
+      type is (character(*))
+        write (res, '(I2)') len(w)
+    end select
+  end subroutine
+
+END MODULE
+
+program test
+    use m;
+    implicit none
+    character(LEN=:), allocatable, target :: S
+    character(LEN=100) :: res
+    class(*), pointer :: ucp
+    call sub1 ("long test string", 16)
+    call sub2 ()
+    S = "test"
+    ucp => S
+    call sub3 (ucp)
+    call sub4 (S, 4)
+    call sub4 ("This is a longer string.", 24)
+    call bar (S, res)
+    if (trim (res) .NE. " 4") call abort ()
+    call bar(ucp, res)
+    if (trim (res) .NE. " 4") call abort ()
+
+contains
+
+    subroutine sub1(dcl, ilen)
+        character(len=*), target :: dcl
+        integer(4) :: ilen
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        ucp => dcl
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(dcl) .NE. ilen) call abort ()
+            if (len(ucp) .NE. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .NE. ilen) call abort ()
+        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) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub3(ucp)
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. 4) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. 4) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub4(ucp, ilen)
+        character(len=:), allocatable :: hlp
+        integer(4) :: ilen
+        class(*) :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. ilen) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+end program
+

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

[Paul Richard Thomas]

Dear Andre,

Thanks for the patch. As I have said to you, off list, I think that
the _size field in the vtable should contain the kind information and
that the _len field should carry the length of the string in bytes. I
think that it is better to optimise array access this way than to
avoid the division in evaluating LEN (). I am happy to accept contrary
opinions from the others.

I do not believe that the bind_c issue is an issue. Your patch
correctly deals with it IMHO.

Subject to the above change in the value of _len, I think that your
patch is OK for trunk.

With best regards

Paul

On 4 January 2015 at 13:40, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Janus, hi Paul, hi Tobias,
>
> Janus: During code review, I found that I had the code in
> gfc_get_len_component() duplicated. So I now reintroduced and documented the
> routine making is more commonly usable and added more documentation. The call
> sites are now simplify.c (gfc_simplify_len) and trans-expr.c
> (gfc_trans_pointer_assignment). Attached is the reworked version of the patch.
>
> Paul, Tobias: Can one of you have a look at line 253 of the patch? I need some
> expertise on the bind_c behavior. My patch needs the check for is_bind_c added
> in trans_expr.c (gfc_conv_expr) to prevent mistyping an associated variable
> in a select type() during the conv. Background: This code fragment taken from
> the testcase in the patch:
>
> MODULE m
> contains
>   subroutine bar (arg, res)
>     class(*) :: arg
>     character(100) :: res
>     select type (w => arg)
>       type is (character(*))
>         write (res, '(I2)') len(w)
>     end select
>   end subroutine
> END MODULE
>
> has the conditions required for line trans-expr.c:6630 of gfc_conv_expr when
> the associate variable w is converted. This transforms the type of the
> associate variable to something unexpected in the further processing leading to
> some issues during fortraning. Janus told me, that the f90_type has been abused
> for some other things (unlimited polymorphic treatment). Although I believe
> that reading the comments above the if in question, the check I had to enhance
> is treating bind_c stuff (see the threads content for more). I would feel safer
> when one of you gfortran gurus can have a look and given an opinion, whether
> the change is problematic. I couldn't figure why w is resolved to meet the
> criteria (any ideas). Btw, all regtest are ok reporting no issues at all.
>
> Bootstraps and regtests ok on x86_64-linux-gnu
>
> Regards,
>         Andre
>
>
> On Sat, 3 Jan 2015 16:45:07 +0100
> Janus Weil <janus@gcc.gnu.org> wrote:
>
>> Hi Andre,
>>
>> >> >> For the
>> >> >> second one (in gfc_conv_expr), I don't directly see how it's related
>> >> >> to deferred char-len. Why is this change needed?
>> >> >
>> >> > That change is needed, because in some rare case where an associated
>> >> > variable in a "select type ()" is used, then the type and f90_type match
>> >> > the condition while them not really being in a bind_c context. Therefore
>> >> > I have added the check for bind_c. Btw, I now have removed the TODO,
>> >> > because that case is covered by the regression tests.
>> >>
>> >> I don't understand how f90_type can be BT_VOID without being in a
>> >> BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
>> >> case is the one that triggered this?
>> >
>> > This case is triggered by the test-case in the patch, where in the select
>> > type (w => arg) in module m routine bar the w meets the criteria to make the
>> > condition become true. The type of w is then "fixed" and gfortran would
>> > terminate, because the type of w would be set be and BT_INTEGER. I tried to
>> > backtrace where this is coming from, but to no success. In the resolve () of
>> > the select type it looks all quite ok, but in the trans stage the criteria
>> > are met. Most intriguing to me is, that in the condition we are talking
>> > about the type of w and f90_type of the derived class' ts
>> > (expr->ts.u.derived->ts.f90_type) of w is examined. But
>> > expr->ts.u.derived->ts does not describe the type of w, but of the class w
>> > is associate with __STAR...
>> >
>> > So I am not quite sure how to fix this, if this really needs fixing. When I
>> > understand you right, then f90_type should only be set in a bind_c context,
>> > so adding that check wouldn't hurt, right?
>>
>> Yes, in principle adding the check for attr.bind_c looks ok to me
>> (alternatively one could also check for attr.unlimited_polymorphic). I
>> think originally BT_VOID was indeed only used in a bind_c context, but
>> recently it has also been 'hijacked' for unlimited polymorphism, e.g.
>> for the STAR symbol and some of the components of the intrinsic vtabs.
>>
>> What I don't really understand is why these problems are triggered by
>> your patch now and have not crept up earlier in other use-cases of
>> CLASS(*).
>>
>>
>> >> >> 3) The function 'gfc_get_len_component' that you're introducing is
>> >> >> only called in a single place. Do you expect this to be useful in
>> >> >> other places in the future, or could one remove the function and
>> >> >> insert the code inline?
>> >> >
>> >> > In one of the first versions it was uses from two locations. But I had to
>> >> > remove one call site again. I am currently not sure, if I will be using
>> >> > it in the patch for allocatable components when deferred char arrays are
>> >> > handled. So what I do I do now? Inline it and when needed make it
>> >> > explicit again in a future patch?
>> >>
>> >> I leave that up to you. In principle I'm fine with keeping it as it
>> >> is. The only problem I see is that the function name sounds rather
>> >> general, but it apparently expects the expression to be an ASSOCIATE
>> >> symbol.
>> >
>> > I am nearly finished with the patch on allocatable scalar components and I
>> > don't need the code there. Therefore I have inlined the routine.
>>
>> Ok, good. Could you please post an updated patch?
>>
>>
>> > So, what do we do about the bind_c issue above? Is some bind_c guru
>> > available to have a look at this? It would be very much appreciated.
>>
>> From my non-guru POV, it can stay as is.
>>
>> It would be helpful if someone like Paul or Tobias could have a look
>> at the patch before it goes to trunk. I think it's pretty close to
>> being ready for prime-time. Thanks for your work!
>>
>> Cheers,
>> Janus
>
>
> --
> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> Tel.: +49 241 9291018 * Email: vehre@gmx.de



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

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

[Andre Vehreschild]

Hi all, hi Paul,

I started to implement the changes requested below, but I stumbled over an
oddity:

For a deferred length kind4 char array, the length of the string is stored
without multiplication by 4 in the length variable attached. So when we now
decide to store the length of the string in an unlimited polymorphic entity in
bytes in the component formerly called _len and the size of each character in
_vtype->_size then we have an inconsistency with the style deferred char
lengths are stored. IMHO we should store this consistently, i.e., both
'length'-variables store either the length of the string ('length' = array_len)
or the size of the memory needed ('length' = array_len * char_size). What do
you think?

Furthermore, think about debugging: When looking at an unlimited polymorphic
entity storing a kind-4-char-array of length 7, then having a 'length' component
set to 28 will lead to confusion. I humbly predict, that this will produce many
entries in the bugtracker, because people don't understand that 'length' stores
the product of elem_size times string_len, because all they see is an
assignment of a length-7 char array.

What do we do about it?

Regards,
	Andre

On Thu, 8 Jan 2015 20:56:43 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Dear Andre,
> 
> Thanks for the patch. As I have said to you, off list, I think that
> the _size field in the vtable should contain the kind information and
> that the _len field should carry the length of the string in bytes. I
> think that it is better to optimise array access this way than to
> avoid the division in evaluating LEN (). I am happy to accept contrary
> opinions from the others.
> 
> I do not believe that the bind_c issue is an issue. Your patch
> correctly deals with it IMHO.
> 
> Subject to the above change in the value of _len, I think that your
> patch is OK for trunk.
> 
> With best regards
> 
> Paul
> 
> On 4 January 2015 at 13:40, Andre Vehreschild <vehre@gmx.de> wrote:
> > Hi Janus, hi Paul, hi Tobias,
> >
> > Janus: During code review, I found that I had the code in
> > gfc_get_len_component() duplicated. So I now reintroduced and documented the
> > routine making is more commonly usable and added more documentation. The
> > call sites are now simplify.c (gfc_simplify_len) and trans-expr.c
> > (gfc_trans_pointer_assignment). Attached is the reworked version of the
> > patch.
> >
> > Paul, Tobias: Can one of you have a look at line 253 of the patch? I need
> > some expertise on the bind_c behavior. My patch needs the check for
> > is_bind_c added in trans_expr.c (gfc_conv_expr) to prevent mistyping an
> > associated variable in a select type() during the conv. Background: This
> > code fragment taken from the testcase in the patch:
> >
> > MODULE m
> > contains
> >   subroutine bar (arg, res)
> >     class(*) :: arg
> >     character(100) :: res
> >     select type (w => arg)
> >       type is (character(*))
> >         write (res, '(I2)') len(w)
> >     end select
> >   end subroutine
> > END MODULE
> >
> > has the conditions required for line trans-expr.c:6630 of gfc_conv_expr when
> > the associate variable w is converted. This transforms the type of the
> > associate variable to something unexpected in the further processing
> > leading to some issues during fortraning. Janus told me, that the f90_type
> > has been abused for some other things (unlimited polymorphic treatment).
> > Although I believe that reading the comments above the if in question, the
> > check I had to enhance is treating bind_c stuff (see the threads content
> > for more). I would feel safer when one of you gfortran gurus can have a
> > look and given an opinion, whether the change is problematic. I couldn't
> > figure why w is resolved to meet the criteria (any ideas). Btw, all regtest
> > are ok reporting no issues at all.
> >
> > Bootstraps and regtests ok on x86_64-linux-gnu
> >
> > Regards,
> >         Andre
> >
> >
> > On Sat, 3 Jan 2015 16:45:07 +0100
> > Janus Weil <janus@gcc.gnu.org> wrote:
> >
> >> Hi Andre,
> >>
> >> >> >> For the
> >> >> >> second one (in gfc_conv_expr), I don't directly see how it's related
> >> >> >> to deferred char-len. Why is this change needed?
> >> >> >
> >> >> > That change is needed, because in some rare case where an associated
> >> >> > variable in a "select type ()" is used, then the type and f90_type
> >> >> > match the condition while them not really being in a bind_c context.
> >> >> > Therefore I have added the check for bind_c. Btw, I now have removed
> >> >> > the TODO, because that case is covered by the regression tests.
> >> >>
> >> >> I don't understand how f90_type can be BT_VOID without being in a
> >> >> BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
> >> >> case is the one that triggered this?
> >> >
> >> > This case is triggered by the test-case in the patch, where in the select
> >> > type (w => arg) in module m routine bar the w meets the criteria to make
> >> > the condition become true. The type of w is then "fixed" and gfortran
> >> > would terminate, because the type of w would be set be and BT_INTEGER. I
> >> > tried to backtrace where this is coming from, but to no success. In the
> >> > resolve () of the select type it looks all quite ok, but in the trans
> >> > stage the criteria are met. Most intriguing to me is, that in the
> >> > condition we are talking about the type of w and f90_type of the derived
> >> > class' ts (expr->ts.u.derived->ts.f90_type) of w is examined. But
> >> > expr->ts.u.derived->ts does not describe the type of w, but of the class
> >> > w is associate with __STAR...
> >> >
> >> > So I am not quite sure how to fix this, if this really needs fixing.
> >> > When I understand you right, then f90_type should only be set in a
> >> > bind_c context, so adding that check wouldn't hurt, right?
> >>
> >> Yes, in principle adding the check for attr.bind_c looks ok to me
> >> (alternatively one could also check for attr.unlimited_polymorphic). I
> >> think originally BT_VOID was indeed only used in a bind_c context, but
> >> recently it has also been 'hijacked' for unlimited polymorphism, e.g.
> >> for the STAR symbol and some of the components of the intrinsic vtabs.
> >>
> >> What I don't really understand is why these problems are triggered by
> >> your patch now and have not crept up earlier in other use-cases of
> >> CLASS(*).
> >>
> >>
> >> >> >> 3) The function 'gfc_get_len_component' that you're introducing is
> >> >> >> only called in a single place. Do you expect this to be useful in
> >> >> >> other places in the future, or could one remove the function and
> >> >> >> insert the code inline?
> >> >> >
> >> >> > In one of the first versions it was uses from two locations. But I
> >> >> > had to remove one call site again. I am currently not sure, if I will
> >> >> > be using it in the patch for allocatable components when deferred
> >> >> > char arrays are handled. So what I do I do now? Inline it and when
> >> >> > needed make it explicit again in a future patch?
> >> >>
> >> >> I leave that up to you. In principle I'm fine with keeping it as it
> >> >> is. The only problem I see is that the function name sounds rather
> >> >> general, but it apparently expects the expression to be an ASSOCIATE
> >> >> symbol.
> >> >
> >> > I am nearly finished with the patch on allocatable scalar components and
> >> > I don't need the code there. Therefore I have inlined the routine.
> >>
> >> Ok, good. Could you please post an updated patch?
> >>
> >>
> >> > So, what do we do about the bind_c issue above? Is some bind_c guru
> >> > available to have a look at this? It would be very much appreciated.
> >>
> >> From my non-guru POV, it can stay as is.
> >>
> >> It would be helpful if someone like Paul or Tobias could have a look
> >> at the patch before it goes to trunk. I think it's pretty close to
> >> being ready for prime-time. Thanks for your work!
> >>
> >> Cheers,
> >> Janus
> >
> >
> > --
> > Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> > Tel.: +49 241 9291018 * Email: vehre@gmx.de
> 
> 
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

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

[Paul Richard Thomas]

Dear Andre,

Perhaps, rather than calling the new component _len, we should call it
_mem_size or some such?

Cheers

Paul

On 9 January 2015 at 11:52, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all, hi Paul,
>
> I started to implement the changes requested below, but I stumbled over an
> oddity:
>
> For a deferred length kind4 char array, the length of the string is stored
> without multiplication by 4 in the length variable attached. So when we now
> decide to store the length of the string in an unlimited polymorphic entity in
> bytes in the component formerly called _len and the size of each character in
> _vtype->_size then we have an inconsistency with the style deferred char
> lengths are stored. IMHO we should store this consistently, i.e., both
> 'length'-variables store either the length of the string ('length' = array_len)
> or the size of the memory needed ('length' = array_len * char_size). What do
> you think?
>
> Furthermore, think about debugging: When looking at an unlimited polymorphic
> entity storing a kind-4-char-array of length 7, then having a 'length' component
> set to 28 will lead to confusion. I humbly predict, that this will produce many
> entries in the bugtracker, because people don't understand that 'length' stores
> the product of elem_size times string_len, because all they see is an
> assignment of a length-7 char array.
>
> What do we do about it?
>
> Regards,
>         Andre
>
> On Thu, 8 Jan 2015 20:56:43 +0100
> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
>
>> Dear Andre,
>>
>> Thanks for the patch. As I have said to you, off list, I think that
>> the _size field in the vtable should contain the kind information and
>> that the _len field should carry the length of the string in bytes. I
>> think that it is better to optimise array access this way than to
>> avoid the division in evaluating LEN (). I am happy to accept contrary
>> opinions from the others.
>>
>> I do not believe that the bind_c issue is an issue. Your patch
>> correctly deals with it IMHO.
>>
>> Subject to the above change in the value of _len, I think that your
>> patch is OK for trunk.
>>
>> With best regards
>>
>> Paul
>>
>> On 4 January 2015 at 13:40, Andre Vehreschild <vehre@gmx.de> wrote:
>> > Hi Janus, hi Paul, hi Tobias,
>> >
>> > Janus: During code review, I found that I had the code in
>> > gfc_get_len_component() duplicated. So I now reintroduced and documented the
>> > routine making is more commonly usable and added more documentation. The
>> > call sites are now simplify.c (gfc_simplify_len) and trans-expr.c
>> > (gfc_trans_pointer_assignment). Attached is the reworked version of the
>> > patch.
>> >
>> > Paul, Tobias: Can one of you have a look at line 253 of the patch? I need
>> > some expertise on the bind_c behavior. My patch needs the check for
>> > is_bind_c added in trans_expr.c (gfc_conv_expr) to prevent mistyping an
>> > associated variable in a select type() during the conv. Background: This
>> > code fragment taken from the testcase in the patch:
>> >
>> > MODULE m
>> > contains
>> >   subroutine bar (arg, res)
>> >     class(*) :: arg
>> >     character(100) :: res
>> >     select type (w => arg)
>> >       type is (character(*))
>> >         write (res, '(I2)') len(w)
>> >     end select
>> >   end subroutine
>> > END MODULE
>> >
>> > has the conditions required for line trans-expr.c:6630 of gfc_conv_expr when
>> > the associate variable w is converted. This transforms the type of the
>> > associate variable to something unexpected in the further processing
>> > leading to some issues during fortraning. Janus told me, that the f90_type
>> > has been abused for some other things (unlimited polymorphic treatment).
>> > Although I believe that reading the comments above the if in question, the
>> > check I had to enhance is treating bind_c stuff (see the threads content
>> > for more). I would feel safer when one of you gfortran gurus can have a
>> > look and given an opinion, whether the change is problematic. I couldn't
>> > figure why w is resolved to meet the criteria (any ideas). Btw, all regtest
>> > are ok reporting no issues at all.
>> >
>> > Bootstraps and regtests ok on x86_64-linux-gnu
>> >
>> > Regards,
>> >         Andre
>> >
>> >
>> > On Sat, 3 Jan 2015 16:45:07 +0100
>> > Janus Weil <janus@gcc.gnu.org> wrote:
>> >
>> >> Hi Andre,
>> >>
>> >> >> >> For the
>> >> >> >> second one (in gfc_conv_expr), I don't directly see how it's related
>> >> >> >> to deferred char-len. Why is this change needed?
>> >> >> >
>> >> >> > That change is needed, because in some rare case where an associated
>> >> >> > variable in a "select type ()" is used, then the type and f90_type
>> >> >> > match the condition while them not really being in a bind_c context.
>> >> >> > Therefore I have added the check for bind_c. Btw, I now have removed
>> >> >> > the TODO, because that case is covered by the regression tests.
>> >> >>
>> >> >> I don't understand how f90_type can be BT_VOID without being in a
>> >> >> BIND_C context, but I'm not really a ISO_C_BINDING expert. Which test
>> >> >> case is the one that triggered this?
>> >> >
>> >> > This case is triggered by the test-case in the patch, where in the select
>> >> > type (w => arg) in module m routine bar the w meets the criteria to make
>> >> > the condition become true. The type of w is then "fixed" and gfortran
>> >> > would terminate, because the type of w would be set be and BT_INTEGER. I
>> >> > tried to backtrace where this is coming from, but to no success. In the
>> >> > resolve () of the select type it looks all quite ok, but in the trans
>> >> > stage the criteria are met. Most intriguing to me is, that in the
>> >> > condition we are talking about the type of w and f90_type of the derived
>> >> > class' ts (expr->ts.u.derived->ts.f90_type) of w is examined. But
>> >> > expr->ts.u.derived->ts does not describe the type of w, but of the class
>> >> > w is associate with __STAR...
>> >> >
>> >> > So I am not quite sure how to fix this, if this really needs fixing.
>> >> > When I understand you right, then f90_type should only be set in a
>> >> > bind_c context, so adding that check wouldn't hurt, right?
>> >>
>> >> Yes, in principle adding the check for attr.bind_c looks ok to me
>> >> (alternatively one could also check for attr.unlimited_polymorphic). I
>> >> think originally BT_VOID was indeed only used in a bind_c context, but
>> >> recently it has also been 'hijacked' for unlimited polymorphism, e.g.
>> >> for the STAR symbol and some of the components of the intrinsic vtabs.
>> >>
>> >> What I don't really understand is why these problems are triggered by
>> >> your patch now and have not crept up earlier in other use-cases of
>> >> CLASS(*).
>> >>
>> >>
>> >> >> >> 3) The function 'gfc_get_len_component' that you're introducing is
>> >> >> >> only called in a single place. Do you expect this to be useful in
>> >> >> >> other places in the future, or could one remove the function and
>> >> >> >> insert the code inline?
>> >> >> >
>> >> >> > In one of the first versions it was uses from two locations. But I
>> >> >> > had to remove one call site again. I am currently not sure, if I will
>> >> >> > be using it in the patch for allocatable components when deferred
>> >> >> > char arrays are handled. So what I do I do now? Inline it and when
>> >> >> > needed make it explicit again in a future patch?
>> >> >>
>> >> >> I leave that up to you. In principle I'm fine with keeping it as it
>> >> >> is. The only problem I see is that the function name sounds rather
>> >> >> general, but it apparently expects the expression to be an ASSOCIATE
>> >> >> symbol.
>> >> >
>> >> > I am nearly finished with the patch on allocatable scalar components and
>> >> > I don't need the code there. Therefore I have inlined the routine.
>> >>
>> >> Ok, good. Could you please post an updated patch?
>> >>
>> >>
>> >> > So, what do we do about the bind_c issue above? Is some bind_c guru
>> >> > available to have a look at this? It would be very much appreciated.
>> >>
>> >> From my non-guru POV, it can stay as is.
>> >>
>> >> It would be helpful if someone like Paul or Tobias could have a look
>> >> at the patch before it goes to trunk. I think it's pretty close to
>> >> being ready for prime-time. Thanks for your work!
>> >>
>> >> Cheers,
>> >> Janus
>> >
>> >
>> > --
>> > Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
>> > Tel.: +49 241 9291018 * Email: vehre@gmx.de
>>
>>
>>
>
>
> --
> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> Tel.: +49 241 9291018 * Email: vehre@gmx.de



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx