re PR fortran/44649 ([OOP] F2008: storage_size intrinsic (also working for polymorphic types))
2010-07-08 Janus Weil <janus@gcc.gnu.org> PR fortran/44649 * gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE. * intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size, gfc_resolve_storage_size): New prototypes. * check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions. * intrinsic.c (add_functions): Add STORAGE_SIZE. * iresolve.c (gfc_resolve_storage_size): New function. * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic arguments. (gfc_conv_intrinsic_storage_size): New function. (gfc_conv_intrinsic_function): Handle STORAGE_SIZE. 2010-07-08 Janus Weil <janus@gcc.gnu.org> PR fortran/44649 * gfortran.dg/c_sizeof_1.f90: Modified. * gfortran.dg/storage_size_1.f08: New. * gfortran.dg/storage_size_2.f08: New. From-SVN: r161977
This commit is contained in:
Janus Weil
parent
1df15c3d3a
commit
048510c866
|
|
@ -1,3 +1,17 @@
|
|||
2010-07-08 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44649
|
||||
* gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE.
|
||||
* intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size,
|
||||
gfc_resolve_storage_size): New prototypes.
|
||||
* check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions.
|
||||
* intrinsic.c (add_functions): Add STORAGE_SIZE.
|
||||
* iresolve.c (gfc_resolve_storage_size): New function.
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic
|
||||
arguments.
|
||||
(gfc_conv_intrinsic_storage_size): New function.
|
||||
(gfc_conv_intrinsic_function): Handle STORAGE_SIZE.
|
||||
|
||||
2010-07-08 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR fortran/44847
|
||||
|
|
|
|||
|
|
@ -3045,6 +3045,20 @@ gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
|
|||
}
|
||||
|
||||
|
||||
gfc_try
|
||||
gfc_check_c_sizeof (gfc_expr *arg)
|
||||
{
|
||||
if (verify_c_interop (&arg->ts) != SUCCESS)
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an "
|
||||
"interoperable data entity", gfc_current_intrinsic_arg[0],
|
||||
gfc_current_intrinsic, &arg->where);
|
||||
return FAILURE;
|
||||
}
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
gfc_try
|
||||
gfc_check_sleep_sub (gfc_expr *seconds)
|
||||
{
|
||||
|
|
@ -4559,3 +4573,27 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
|
|||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
gfc_try
|
||||
gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
|
||||
{
|
||||
if (kind == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (kind, 1, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (kind, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind->expr_type != EXPR_CONSTANT)
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
|
||||
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
|
||||
&kind->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -348,6 +348,7 @@ enum gfc_isym_id
|
|||
GFC_ISYM_CPU_TIME,
|
||||
GFC_ISYM_CSHIFT,
|
||||
GFC_ISYM_CTIME,
|
||||
GFC_ISYM_C_SIZEOF,
|
||||
GFC_ISYM_DATE_AND_TIME,
|
||||
GFC_ISYM_DBLE,
|
||||
GFC_ISYM_DIGITS,
|
||||
|
|
@ -504,6 +505,7 @@ enum gfc_isym_id
|
|||
GFC_ISYM_SRAND,
|
||||
GFC_ISYM_SR_KIND,
|
||||
GFC_ISYM_STAT,
|
||||
GFC_ISYM_STORAGE_SIZE,
|
||||
GFC_ISYM_SUM,
|
||||
GFC_ISYM_SYMLINK,
|
||||
GFC_ISYM_SYMLNK,
|
||||
|
|
|
|||
|
|
@ -2459,7 +2459,10 @@ add_functions (void)
|
|||
x, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
|
||||
make_alias ("c_sizeof", GFC_STD_F2008);
|
||||
|
||||
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
|
||||
BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
|
||||
x, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
|
||||
gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
|
||||
|
|
@ -2500,6 +2503,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
|
||||
|
||||
add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
|
||||
BT_INTEGER, di, GFC_STD_F2008,
|
||||
gfc_check_storage_size, NULL, gfc_resolve_storage_size,
|
||||
a, BT_UNKNOWN, 0, REQUIRED,
|
||||
kind, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
|
||||
gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
|
||||
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
|
||||
|
|
|
|||
|
|
@ -133,10 +133,12 @@ gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
gfc_try gfc_check_sign (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_signal (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_sizeof (gfc_expr *);
|
||||
gfc_try gfc_check_c_sizeof (gfc_expr *);
|
||||
gfc_try gfc_check_sngl (gfc_expr *);
|
||||
gfc_try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_srand (gfc_expr *);
|
||||
gfc_try gfc_check_stat (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_storage_size (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_symlnk (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
|
|
@ -494,6 +496,7 @@ void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind);
|
||||
void gfc_resolve_srand (gfc_code *);
|
||||
void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
|
|
|
|||
|
|
@ -2318,6 +2318,18 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
|
||||
gfc_expr *kind)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
if (kind)
|
||||
f->ts.kind = mpz_get_si (kind->value.integer);
|
||||
else
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -3885,6 +3885,9 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
|
|||
|
||||
if (ss == gfc_ss_terminator)
|
||||
{
|
||||
if (arg->ts.type == BT_CLASS)
|
||||
gfc_add_component_ref (arg, "$data");
|
||||
|
||||
gfc_conv_expr_reference (&argse, arg);
|
||||
|
||||
type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
|
||||
|
|
@ -3934,6 +3937,56 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
|
|||
}
|
||||
|
||||
|
||||
static void
|
||||
gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
|
||||
{
|
||||
gfc_expr *arg;
|
||||
gfc_ss *ss;
|
||||
gfc_se argse,eight;
|
||||
tree type, result_type, tmp;
|
||||
|
||||
arg = expr->value.function.actual->expr;
|
||||
gfc_init_se (&eight, NULL);
|
||||
gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
|
||||
|
||||
gfc_init_se (&argse, NULL);
|
||||
ss = gfc_walk_expr (arg);
|
||||
result_type = gfc_get_int_type (expr->ts.kind);
|
||||
|
||||
if (ss == gfc_ss_terminator)
|
||||
{
|
||||
if (arg->ts.type == BT_CLASS)
|
||||
{
|
||||
gfc_add_component_ref (arg, "$vptr");
|
||||
gfc_add_component_ref (arg, "$size");
|
||||
gfc_conv_expr (&argse, arg);
|
||||
tmp = fold_convert (result_type, argse.expr);
|
||||
goto done;
|
||||
}
|
||||
|
||||
gfc_conv_expr_reference (&argse, arg);
|
||||
type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
|
||||
argse.expr));
|
||||
}
|
||||
else
|
||||
{
|
||||
argse.want_pointer = 0;
|
||||
gfc_conv_expr_descriptor (&argse, arg, ss);
|
||||
type = gfc_get_element_type (TREE_TYPE (argse.expr));
|
||||
}
|
||||
|
||||
/* Obtain the argument's word length. */
|
||||
if (arg->ts.type == BT_CHARACTER)
|
||||
tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
|
||||
else
|
||||
tmp = fold_convert (result_type, size_in_bytes (type));
|
||||
|
||||
done:
|
||||
se->expr = fold_build2 (MULT_EXPR, result_type, tmp, eight.expr);
|
||||
gfc_add_block_to_block (&se->pre, &argse.pre);
|
||||
}
|
||||
|
||||
|
||||
/* Intrinsic string comparison functions. */
|
||||
|
||||
static void
|
||||
|
|
@ -5270,9 +5323,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
break;
|
||||
|
||||
case GFC_ISYM_SIZEOF:
|
||||
case GFC_ISYM_C_SIZEOF:
|
||||
gfc_conv_intrinsic_sizeof (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_STORAGE_SIZE:
|
||||
gfc_conv_intrinsic_storage_size (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_SPACING:
|
||||
gfc_conv_intrinsic_spacing (se, expr);
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2010-07-08 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44649
|
||||
* gfortran.dg/c_sizeof_1.f90: Modified.
|
||||
* gfortran.dg/storage_size_1.f08: New.
|
||||
* gfortran.dg/storage_size_2.f08: New.
|
||||
|
||||
2010-07-08 Mikael Pettersson <mikpe@it.uu.se>
|
||||
|
||||
* gcc.c-torture/execute/20100708-1.c: New test.
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
! { dg-do run }
|
||||
! Support F2008's c_sizeof()
|
||||
!
|
||||
integer(4) :: i, j(10)
|
||||
character(4),parameter :: str(1) = "abcd"
|
||||
use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr
|
||||
|
||||
integer(kind=c_int) :: i, j(10)
|
||||
character(kind=c_char,len=4),parameter :: str(1) = "abcd"
|
||||
type(c_ptr) :: cptr
|
||||
integer(c_intptr_t) :: iptr
|
||||
|
||||
! Using F2008's C_SIZEOF
|
||||
i = c_sizeof(i)
|
||||
|
|
@ -18,9 +22,10 @@ i = c_sizeof(str(1))
|
|||
if (i /= 4) call abort()
|
||||
|
||||
i = c_sizeof(str(1)(1:3))
|
||||
print *, i
|
||||
if (i /= 3) call abort()
|
||||
|
||||
write(*,*) c_sizeof(cptr), c_sizeof(iptr), c_sizeof(C_NULL_PTR)
|
||||
|
||||
! Using GNU's SIZEOF
|
||||
i = sizeof(i)
|
||||
if (i /= 4) call abort()
|
||||
|
|
@ -36,5 +41,6 @@ if (i /= 4) call abort()
|
|||
|
||||
i = sizeof(str(1)(1:3))
|
||||
if (i /= 3) call abort()
|
||||
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 44649: [OOP] F2008: storage_size intrinsic
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
type :: t
|
||||
integer(4) :: i
|
||||
real(4) :: r
|
||||
end type
|
||||
|
||||
type,extends(t) :: t2
|
||||
integer(4) :: j
|
||||
end type
|
||||
|
||||
type(t) :: a
|
||||
type(t), dimension(1:3) :: b
|
||||
class(t), allocatable :: cp
|
||||
|
||||
allocate(t2::cp)
|
||||
|
||||
if (sizeof(a) /= 8) call abort()
|
||||
if (storage_size(a) /= 64) call abort()
|
||||
|
||||
if (sizeof(b) /= 24) call abort()
|
||||
if (storage_size(b) /= 64) call abort()
|
||||
|
||||
if (sizeof(cp) /= 8) call abort()
|
||||
if (storage_size(cp) /= 96) call abort()
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 44649: [OOP] F2008: storage_size intrinsic
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
use iso_c_binding, only: c_int
|
||||
|
||||
type, bind(c) :: t
|
||||
integer(c_int) :: j
|
||||
end type
|
||||
|
||||
integer(4) :: i1
|
||||
integer(c_int) :: i2
|
||||
type(t) :: x
|
||||
|
||||
print *,c_sizeof(i1) ! { dg-error "must be be an interoperable data entity" }
|
||||
print *,c_sizeof(i2)
|
||||
print *,c_sizeof(x)
|
||||
print *, c_sizeof(ran()) ! { dg-error "must be be an interoperable data entity" }
|
||||
|
||||
print *,storage_size(1.0,4)
|
||||
print *,storage_size(1.0,3.2) ! { dg-error "must be INTEGER" }
|
||||
print *,storage_size(1.0,(/1,2/)) ! { dg-error "must be a scalar" }
|
||||
print *,storage_size(1.0,irand()) ! { dg-error "must be a constant" }
|
||||
|
||||
end
|
||||
Loading…
Reference in New Issue