Skip to content

R
riscv-gcc-1
Commit cddf0123 by Paul Thomas
Options

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
parent 8223bb78
Showing with 85 additions and 11 deletions
gcc/fortran/ChangeLog
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
......
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))
......
gcc/testsuite/ChangeLog
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
......
gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment