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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@203915 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5e51f2bbc276bffa8486db03ad2d532c1cafd60b..3539d2cbebdda15cb84169ded3de2cc49cd725b1 100644 (file)
--- 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 be4959a7deed7d0659a01137802af1f7b944e0d1..52b9760b271738638d0427bd0244045415db261f 100644 (file)
--- 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 4f277ac9e6197fc8ac45bd0defcb2ec58dc169b5..ff48a244cee55cbe7cc3d9cf0c905eb3a12edb5a 100644 (file)
--- 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 (file)
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