PR fortran 57893

2013-10-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran 57893
	* class.c : Include target-memory.h.
	(gfc_find_intrinsic_vtab) Build a minimal expression so that
	gfc_element_size can be used to obtain the storage size, rather
	that the kind value.

2013-10-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran 57893
	* gfortran.dg/unlimited_polymorphic_13.f90 : New test.

From-SVN: r203915

4 files changed, 85 insertions, 11 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5e51f2b..3539d2c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2013-10-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran 57893
+	* class.c : Include target-memory.h.
+	(gfc_find_intrinsic_vtab) Build a minimal expression so that
+	gfc_element_size can be used to obtain the storage size, rather
+	that the kind value.
+
 2013-10-21  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/58803
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index be4959a..52b9760 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -53,6 +53,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "coretypes.h"
 #include "gfortran.h"
 #include "constructor.h"
+#include "target-memory.h"
 
 /* Inserts a derived type component reference in a data reference chain.
     TS: base type of the ref chain so far, in which we will pick the component
@@ -618,7 +619,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!ts->u.derived->attr.unlimited_polymorphic)
 	fclass->attr.abstract = ts->u.derived->attr.abstract;
       fclass->f2k_derived = gfc_get_namespace (NULL, 0);
-      if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL, 
+      if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
 			   &gfc_current_locus))
 	return false;
 
@@ -2135,7 +2136,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	{
 	  gfc_get_symbol (name, ns, &vtab);
 	  vtab->ts.type = BT_DERIVED;
-	  if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, 
+	  if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
 			       &gfc_current_locus))
 	    goto cleanup;
 	  vtab->attr.target = 1;
@@ -2152,7 +2153,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      gfc_symbol *parent = NULL, *parent_vtab = NULL;
 
 	      gfc_get_symbol (name, ns, &vtype);
-	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, 
+	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
 				   &gfc_current_locus))
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
@@ -2456,7 +2457,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
 	{
 	  gfc_get_symbol (name, ns, &vtab);
 	  vtab->ts.type = BT_DERIVED;
-	  if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, 
+	  if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
 			       &gfc_current_locus))
 	    goto cleanup;
 	  vtab->attr.target = 1;
@@ -2473,9 +2474,10 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
 	      int hash;
 	      gfc_namespace *sub_ns;
 	      gfc_namespace *contained;
+	      gfc_expr *e;
 
 	      gfc_get_symbol (name, ns, &vtype);
-	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, 
+	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
 				   &gfc_current_locus))
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
@@ -2498,12 +2500,16 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = 4;
 	      c->attr.access = ACCESS_PRIVATE;
-	      if (ts->type == BT_CHARACTER)
-		c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
-						   NULL, charlen*ts->kind);
-	      else
-		c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
-						   NULL, ts->kind);
+
+	      /* Build a minimal expression to make use of
+		 target-memory.c/gfc_element_size for 'size'. */
+	      e = gfc_get_expr ();
+	      e->ts = *ts;
+	      e->expr_type = EXPR_VARIABLE;
+	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL,
+						 (int)gfc_element_size (e));
+	      gfc_free_expr (e);
 
 	      /* Add component _extends.  */
 	      if (!gfc_add_component (vtype, "_extends", &c))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4f277ac..ff48a24 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-10-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran 57893
+	* gfortran.dg/unlimited_polymorphic_13.f90 : New test.
+
 2013-10-21  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/58803
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90
new file mode 100644
index 0000000..8b76495
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90
@@ -0,0 +1,55 @@
+! { dg-do run }
+!
+! PR fortran/58793
+!
+! Contributed by  Vladimir Fuka
+!
+! Had the wrong value for the storage_size for complex
+!
+module m
+  use iso_fortran_env
+  implicit none
+  integer, parameter :: c1 = real_kinds(1)
+  integer, parameter :: c2 = real_kinds(2)
+  integer, parameter :: c3 = real_kinds(size(real_kinds)-1)
+  integer, parameter :: c4 = real_kinds(size(real_kinds))
+contains
+ subroutine s(o, k)
+    class(*) :: o
+    integer :: k
+    integer :: sz
+
+    select case (k)
+     case (4)
+      sz = 32*2
+     case (8)
+      sz = 64*2
+     case (10,16)
+      sz = 128*2
+     case default
+       call abort()
+    end select
+
+    if (storage_size(o) /= sz) call abort()
+    select type (o)
+      type is (complex(c1))
+        if (storage_size(o) /= sz) call abort()
+      type is (complex(c2))
+        if (storage_size(o) /= sz) call abort()
+    end select
+    select type (o)
+      type is (complex(c3))
+        if (storage_size(o) /= sz) call abort()
+      type is (complex(c4))
+        if (storage_size(o) /= sz) call abort()
+    end select
+  end subroutine s
+end module m
+
+program p
+ use m
+ call s((1._c1, 2._c1), c1)
+ call s((1._c2, 2._c2), c2)
+ call s((1._c3, 2._c3), c3)
+ call s((1._c4, 2._c4), c4)
+end program p