2014-07-26 Tobias Burnus <burnus@net-b.de>
* check.c (gfc_check_sizeof): Permit for assumed type if and
only if it has an array descriptor.
* intrinsic.c (do_ts29113_check): Permit SIZEOF.
(add_functions): SIZEOF is an Inquiry function.
* intrinsic.texi (SIZEOF): Add note that only contiguous
arrays are permitted.
* trans-expr.c (gfc_conv_intrinsic_to_class): Handle assumed
rank.
* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle
assumed type + array descriptor, CLASS and assumed rank.
(gfc_conv_intrinsic_storage_size): Handle class arrays.
2014-07-26 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/sizeof_2.f90: Change dg-error.
* gfortran.dg/sizeof_4.f90: New.
* gfortran.dg/storage_size_1.f08: Correct expected
value.
@@ -3902,7 +3902,12 @@ gfc_check_sizeof (gfc_expr *arg)
return false;
}
- if (arg->ts.type == BT_ASSUMED)
+ // TYPE(*) is acceptable if and only if it uses an array descriptor.
+ if (arg->ts.type == BT_ASSUMED
+ && (arg->symtree->n.sym->as == NULL
+ || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
+ && arg->symtree->n.sym->as->type != AS_DEFERRED
+ && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
@@ -204,6 +204,7 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
&& specific->id != GFC_ISYM_RANK
&& specific->id != GFC_ISYM_SHAPE
&& specific->id != GFC_ISYM_SIZE
+ && specific->id != GFC_ISYM_SIZEOF
&& specific->id != GFC_ISYM_UBOUND
&& specific->id != GFC_ISYM_C_LOC)
{
@@ -2765,8 +2766,9 @@ add_functions (void)
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
make_from_module();
- add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
- GFC_STD_GNU, gfc_check_sizeof, gfc_simplify_sizeof, NULL,
+ add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
+ BT_INTEGER, ii, GFC_STD_GNU,
+ gfc_check_sizeof, gfc_simplify_sizeof, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
@@ -12205,7 +12205,9 @@ to is returned. If the argument is of a derived type with @code{POINTER}
or @code{ALLOCATABLE} components, the return value does not account for
the sizes of the data pointed to by these components. If the argument is
polymorphic, the size according to the declared type is returned. The argument
-may not be a procedure or procedure pointer.
+may not be a procedure or procedure pointer. Note that the code assumes for
+arrays that those are contiguous; for contiguous arrays, it returns the
+storage or an array element multiplicated by the size of the array.
@item @emph{Example}:
@smallexample
@@ -564,7 +564,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
- ctree = gfc_class_vptr_get (var);
+ ctree = gfc_class_vptr_get (var);
vtab = gfc_find_vtab (&e->ts);
gcc_assert (vtab);
@@ -573,7 +573,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
- ctree = gfc_class_data_get (var);
+ ctree = gfc_class_data_get (var);
if (parmse->ss && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
@@ -589,7 +589,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
{
parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ if (class_ts.u.derived->components->as
+ && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
+ {
+ tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
+ gfc_expr_attr (e));
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree), tmp);
+ }
+ else
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
@@ -597,7 +606,14 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
parmse->ss = ss;
parmse->use_offset = 1;
gfc_conv_expr_descriptor (parmse, e);
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ if (class_ts.u.derived->components->as->rank != e->rank)
+ {
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
@@ -5891,62 +5891,131 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
gfc_expr *arg;
gfc_se argse;
tree source_bytes;
- tree type;
tree tmp;
tree lower;
tree upper;
+ tree byte_size;
int n;
- arg = expr->value.function.actual->expr;
-
gfc_init_se (&argse, NULL);
+ arg = expr->value.function.actual->expr;
- if (arg->rank == 0)
+ if (arg->rank || arg->ts.type == BT_ASSUMED)
+ gfc_conv_expr_descriptor (&argse, arg);
+ else
+ gfc_conv_expr_reference (&argse, arg);
+
+ if (arg->ts.type == BT_ASSUMED)
+ {
+ // This only works if an array descriptor has been passed; thus, extract
+ // the size from the descriptor.
+ gcc_assert (TYPE_PRECISION (gfc_array_index_type)
+ == TYPE_PRECISION (size_type_node));
+ tmp = arg->symtree->n.sym->backend_decl;
+ tmp = DECL_LANG_SPECIFIC (tmp)
+ && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
+ ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp));
+ tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (TREE_TYPE (tmp),
+ GFC_DTYPE_SIZE_SHIFT));
+ byte_size = fold_convert (gfc_array_index_type, tmp);
+ }
+ else if (arg->ts.type == BT_CLASS)
+ {
+ if (arg->rank)
+ byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+ else
+ byte_size = gfc_vtable_size_get (argse.expr);
+ }
+ else
{
- if (arg->ts.type == BT_CLASS)
- gfc_add_data_component (arg);
-
- gfc_conv_expr_reference (&argse, arg);
-
- type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
- argse.expr));
-
- /* Obtain the source word length. */
if (arg->ts.type == BT_CHARACTER)
- se->expr = size_of_string_in_bytes (arg->ts.kind,
- argse.string_length);
+ byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
else
- se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
+ {
+ if (arg->rank == 0)
+ byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
+ else
+ byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
+ byte_size = fold_convert (gfc_array_index_type,
+ size_in_bytes (byte_size));
+ }
}
+
+ if (arg->rank == 0)
+ se->expr = byte_size;
else
{
source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
- argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg);
- type = gfc_get_element_type (TREE_TYPE (argse.expr));
+ gfc_add_modify (&argse.pre, source_bytes, byte_size);
- /* 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 (gfc_array_index_type,
- size_in_bytes (type));
- gfc_add_modify (&argse.pre, source_bytes, tmp);
-
- /* Obtain the size of the array in bytes. */
- for (n = 0; n < arg->rank; n++)
+ if (arg->rank == -1)
{
- tree idx;
- idx = gfc_rank_cst[n];
- lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, upper, lower);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, gfc_index_one_node);
+ tree cond, loop_var, exit_label;
+ stmtblock_t body;
+
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_conv_descriptor_rank (argse.expr));
+ loop_var = gfc_create_var (gfc_array_index_type, "i");
+ gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
+ exit_label = gfc_build_label_decl (NULL_TREE);
+
+ /* Create loop:
+ for (;;)
+ {
+ if (i >= rank)
+ goto exit;
+ source_bytes = source_bytes * array.dim[i].extent;
+ i = i + 1;
+ }
+ exit: */
+ gfc_start_block (&body);
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ loop_var, tmp);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
+ tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, source_bytes);
- gfc_add_modify (&argse.pre, source_bytes, tmp);
+ gfc_add_modify (&body, source_bytes, tmp);
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, loop_var,
+ gfc_index_one_node);
+ gfc_add_modify_loc (input_location, &body, loop_var, tmp);
+
+ tmp = gfc_finish_block (&body);
+
+ tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
+ tmp);
+ gfc_add_expr_to_block (&argse.pre, tmp);
+
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&argse.pre, tmp);
+ }
+ else
+ {
+ /* Obtain the size of the array in bytes. */
+ for (n = 0; n < arg->rank; n++)
+ {
+ tree idx;
+ idx = gfc_rank_cst[n];
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
+ tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, source_bytes);
+ gfc_add_modify (&argse.pre, source_bytes, tmp);
+ }
}
se->expr = source_bytes;
}
@@ -5970,13 +6039,13 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
if (arg->rank == 0)
{
if (arg->ts.type == BT_CLASS)
- {
- gfc_add_vptr_component (arg);
- gfc_add_size_component (arg);
- gfc_conv_expr (&argse, arg);
- tmp = fold_convert (result_type, argse.expr);
- goto done;
- }
+ {
+ gfc_add_vptr_component (arg);
+ gfc_add_size_component (arg);
+ 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,
@@ -5986,6 +6055,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg);
+ if (arg->ts.type == BT_CLASS)
+ {
+ tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+ tmp = fold_convert (result_type, tmp);
+ goto done;
+ }
type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
@@ -10,7 +10,7 @@ subroutine foo(x, y)
integer(8) :: ii
procedure() :: proc
- ii = sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic sizeof" }
+ ii = sizeof (x) ! { dg-error "'x' argument of 'sizeof' intrinsic at \\(1\\) shall not be TYPE\\(\\*\\)" }
ii = c_sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic c_sizeof" }
ii = storage_size (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic storage_size" }
new file mode 100644
@@ -0,0 +1,95 @@
+! { dg-do run }
+!
+! PR fortran/61881
+! PR fortran/61888
+!
+!
+use iso_c_binding
+implicit none
+
+call dim0(5, 4)
+
+call dim1([1, 2, 3], 4*3)
+
+call dimd(5, 4)
+call dimd([1, 2, 3], 4*3)
+call dimd(reshape([1, 4, 2, 3],[2, 2]), 4*4)
+
+call tdim1([1, 2, 3], 4*3)
+call tdim1([1_8, 2_8, 3_8], 8*3)
+
+call tdimd(5, 4)
+call tdimd([1, 2, 3], 4*3)
+call tdimd(reshape([1, 4, 2, 3], [2, 2]), 4*4)
+call tdimd(5_8, 8)
+call tdimd([1_8, 2_8, 3_8], 8*3)
+call tdimd(reshape([1_8, 4_8, 2_8, 3_8],[2,2]), 8*4)
+
+call cdim0(5, 4)
+
+call cdim1([1, 2, 3], 4*3)
+
+call cdimd(5, 4)
+call cdimd([1, 2, 3], 4*3)
+call cdimd(reshape([1,4,2,3],[2,2]), 4*4)
+call cdimd(5_8, 8)
+call cdimd([1_8, 2_8, 3_8], 8*3)
+call cdimd(reshape([1_8, 4_8, 2_8, 3_8], [2, 2]), 8*4)
+
+contains
+
+subroutine dim0(x, expected_size)
+ integer :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+ if (storage_size(x)/8 /= expected_size) call abort()
+end
+
+subroutine dim1(x, expected_size)
+ integer, dimension(:) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+ if (storage_size(x)/8*size(x) /= expected_size) call abort()
+end
+
+subroutine dimd(x, expected_size)
+ integer, dimension(..) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+ if (storage_size(x)/8*size(x) /= expected_size) call abort()
+end
+
+subroutine cdim0(x, expected_size)
+ class(*) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+ if (storage_size(x)/8 /= expected_size) call abort()
+end
+
+subroutine cdim1(x, expected_size)
+ class(*), dimension(:) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+ if (storage_size(x)/8*size(x) /= expected_size) call abort()
+end
+
+subroutine cdimd(x, expected_size)
+ class(*), dimension(..) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+ if (storage_size(x)/8*size(x) /= expected_size) call abort()
+end
+
+subroutine tdim1(x, expected_size)
+ type(*), dimension(:) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+end
+
+subroutine tdimd(x, expected_size)
+ type(*), dimension(..) :: x
+ integer, value :: expected_size
+ if (sizeof(x) /= expected_size) call abort()
+end
+
+end
@@ -25,7 +25,7 @@ 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 (sizeof(cp) /= 12) call abort()
if (storage_size(cp) /= 96) call abort()
end