From 69c3654cc6596daad012afc093ed05b6756b0377 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sat, 26 Jul 2014 11:49:00 +0200 Subject: [PATCH] check.c (gfc_check_sizeof): Permit for assumed type if and only if it has an array descriptor. 2014-07-26 Tobias Burnus * 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 * gfortran.dg/sizeof_2.f90: Change dg-error. * gfortran.dg/sizeof_4.f90: New. * gfortran.dg/storage_size_1.f08: Correct expected value. From-SVN: r213079 --- gcc/fortran/ChangeLog | 14 ++ gcc/fortran/check.c | 7 +- gcc/fortran/intrinsic.c | 6 +- gcc/fortran/intrinsic.texi | 4 +- gcc/fortran/trans-expr.c | 24 ++- gcc/fortran/trans-intrinsic.c | 165 ++++++++++++++----- gcc/testsuite/ChangeLog | 7 + gcc/testsuite/gfortran.dg/sizeof_2.f90 | 2 +- gcc/testsuite/gfortran.dg/storage_size_1.f08 | 2 +- 9 files changed, 176 insertions(+), 55 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8071e117e56..9a82894275b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2014-07-26 Tobias Burnus + + * 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-25 Tobias Burnus * simplify.c (gfc_simplify_storage_size): Use proper diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index eff2c4c78a7..95d28693f27 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index d681d702822..1ad1e692135 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 152b46c8f06..6c4cb0917a4 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -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 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 81f21371177..02cec973c1a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 3de0b096759..9059878b9da 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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)); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f63bd99a7bf..e007f31a782 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2014-07-26 Tobias Burnus + + * gfortran.dg/sizeof_2.f90: Change dg-error. + * gfortran.dg/sizeof_4.f90: New. + * gfortran.dg/storage_size_1.f08: Correct expected + value. + 2014-07-26 Marc Glisse PR target/44551 diff --git a/gcc/testsuite/gfortran.dg/sizeof_2.f90 b/gcc/testsuite/gfortran.dg/sizeof_2.f90 index 5f192882806..e6661a56b30 100644 --- a/gcc/testsuite/gfortran.dg/sizeof_2.f90 +++ b/gcc/testsuite/gfortran.dg/sizeof_2.f90 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/storage_size_1.f08 b/gcc/testsuite/gfortran.dg/storage_size_1.f08 index ade9dfc30b0..71d3589c8ed 100644 --- a/gcc/testsuite/gfortran.dg/storage_size_1.f08 +++ b/gcc/testsuite/gfortran.dg/storage_size_1.f08 @@ -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 -- 2.30.2