From cddf01232d2ad3843c4f973ed93195be8fab6585 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 22 Oct 2013 04:40:57 +0000 Subject: PR fortran 57893 2013-10-22 Paul Thomas 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 PR fortran 57893 * gfortran.dg/unlimited_polymorphic_13.f90 : New test. From-SVN: r203915 --- gcc/fortran/ChangeLog | 8 ++++ gcc/fortran/class.c | 28 ++++++----- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/unlimited_polymorphic_13.f90 | 55 ++++++++++++++++++++++ 4 files changed, 85 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90 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 + + 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 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 + + PR fortran 57893 + * gfortran.dg/unlimited_polymorphic_13.f90 : New test. + 2013-10-21 Tobias Burnus 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 -- cgit v1.1