From patchwork Fri Jul 25 23:47:02 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 373846 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 102AF1400E6 for ; Sat, 26 Jul 2014 09:47:24 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=q/yQrQS9hHA4czsPdEwYCf9Yu6aFoFZPbJ1ZuZXkcy6gK9 dVauYjjgR4QjesAtKeCF/oPLZWrn34sS/5IJjQhcxVqv+BEAPbJeVqqffh6QfWxb h5hW9BCFg0WxmKWR/TWPnqkD9iGPzIErjIQGHz3es6D+kWXLoo39ztrnSdUxc= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=VgiMSQwPzlzNiwc0Nt6DlplTrMg=; b=kUdb8xy07dBp2BQoQqih BSHJB+3nXxhdMpLZXeScszCh0SqUyhKBMXjLQ5+VypmGmcg7T2jxuU9Kwzzfbf96 kTxT1Rb8b6eddzGJ4na8H+9ykGNR7D+8qd/GXA5SCIztqQUcL1G0dMoAeOa5f1x7 0PZII0Kj0yUWWyeFNFBbhKo= Received: (qmail 1605 invoked by alias); 25 Jul 2014 23:47:12 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 1581 invoked by uid 89); 25 Jul 2014 23:47:09 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.2 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx01.qsc.de Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Fri, 25 Jul 2014 23:47:07 +0000 Received: from tux.net-b.de (port-92-194-213-151.dynamic.qsc.de [92.194.213.151]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx01.qsc.de (Postfix) with ESMTPSA id 239D13CB2E; Sat, 26 Jul 2014 01:47:02 +0200 (CEST) Message-ID: <53D2EC76.3000907@net-b.de> Date: Sat, 26 Jul 2014 01:47:02 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.6.0 MIME-Version: 1.0 To: gcc-patches , gfortran Subject: [Patch, Fortran] PRs 61881/61888 - Fix issues with SIZEOF, CLASS(*) and assumed-rank The patch has been motivated by the needs for implementing the openacc module. In particular, it does: - Fix passing intrinsic types to CLASS(*) [F2003] - Fix STORAGE_SIZE for polymorphic arrays [F2003] - Permit the vendor intrinsic SIZEOF also for TYPE(*) if and only if an array descriptor has been used [extend GNU extension] - Fix SIZEOF with assumed-rank [fix GNU extension] - Document that SIZEOF's result are not well defined for noncontiguous arrays. [fix GNU extension] Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 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. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index eff2c4c..ff7e53d 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 d681d70..1ad1e69 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 152b46c..6c4cb09 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 81f2137..02cec97 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 3de0b09..31c9207 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/gfortran.dg/sizeof_2.f90 b/gcc/testsuite/gfortran.dg/sizeof_2.f90 index 5f19288..e6661a5 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/sizeof_4.f90 b/gcc/testsuite/gfortran.dg/sizeof_4.f90 new file mode 100644 index 0000000..d4d8baa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/sizeof_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/storage_size_1.f08 b/gcc/testsuite/gfortran.dg/storage_size_1.f08 index ade9dfc..71d3589 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