From patchwork Fri Apr 26 20:02:29 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 240042 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id E42522C0119 for ; Sat, 27 Apr 2013 06:03:00 +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=TIyCsb+WWx31UkKC1fNn61HdLRqJQiV8b6S9H16oSUDnQE AysfVDbzhrcxHvyK9S3/yoqHAOtVOLXzomp0LQlLft8IH8JfswWYBsF5BPw8G1lH HmpmDdIyNWviNQrIFCWyxpo95iH7QXpVQP2O7B0Pw9ut/QPsD8C9vZVSvWX6c= 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=MDFarYk1i0KdxFfpkbS1bTr2P+0=; b=AYSfl69FbPgDKzsS/2u9 HISqHmAnp36EF6xBhyCPQMc4otiYMqQI72BEH8d3l0br/dFkQwri9tYu3/0eWaiG LlNcQg0ieQqVhFMFOXE++48JGaxX1Z9MdeA+JRzZYh+J5Fx4LBVjAbyofa3YBAfe kZShlM6FJbimqn/29REqE9g= Received: (qmail 8537 invoked by alias); 26 Apr 2013 20:02:42 -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 8514 invoked by uid 89); 26 Apr 2013 20:02:42 -0000 X-Spam-SWARE-Status: No, score=-0.4 required=5.0 tests=AWL, BAYES_50, RCVD_IN_DNSWL_NONE, RCVD_IN_SEMBACKSCATTER, TW_CP, TW_HF, TW_PL, TW_TM autolearn=no version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Fri, 26 Apr 2013 20:02:35 +0000 Received: from archimedes.net-b.de (port-92-195-76-58.dynamic.qsc.de [92.195.76.58]) by mx01.qsc.de (Postfix) with ESMTP id 05D0E3DA95; Fri, 26 Apr 2013 22:02:29 +0200 (CEST) Message-ID: <517ADD55.2020709@net-b.de> Date: Fri, 26 Apr 2013 22:02:29 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130329 Thunderbird/17.0.5 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Fortran-dev] Implement TS29113 type handling This patch implements the TS29113 type handling. However, there is a catch: It does not fix any regression but adds two new ones: gfortran.dg/mvbits_7.f90 gfortran.dg/mvbits_8.f90 The problem with those is that this patch correctly sets the elem_len; that might cause that elem_len and sm do not agree with another. That issue shows up with packing: type t integer :: i, j end type t type(t), pointer :: x(:) call bar(x(:)%i) Here, "x(:)%i" has the elem_len=4 (= "integer(4)") while the stride multiplier is dim[0].sm = 8. Before, the old code used the TYPE_UNIT_SIZE(element_type(prev-desc)), which was 8. Usually, that shouldn't cause a problem - except if one doesn't start with the first element but has a span (possibly with negative strides). In that base, the code sets: "base_addr[offset]" - and the offset calculation is based on the element size. It should be "((char*)base_addr) + byte_offset" instead. Namely, gfc_get_dataptr_offset has to be fixed. Another issue is that in gfc_trans_create_temp_array, the elem_len cannot always be set for strings, e.g. the call from TRANSFER where the string is the result of a function call - in that case, the string length is not available. I haven't tried to check whether the elem_len gets properly set later on or not. But now to the good stuff: * The type handling now matches TS29113 and in the array functions, real(10) and real(16) can be distinguished. * Even more C examples using the TS29113 interop work now (I had to fix some bugs) * The used data types in the descriptor has been updated - it is a bit more compact now * Some ubound -> extent changes have been done. Build and regtested on x86-64-gnu-linux. Do you have comments to that patch? - Or on the general direction/on the previous patches? TODO: * The most obvious candidate is gfc_get_dataptr_offset as that one caused the new regression. (As follow up: Other code which assumes that strides are multiples of an element - for the subelement arrays) * Internally, lower_bound should start with 0 at some cases (see TS29113) - to fix more of the C interop * Fix remaining testsuite issues (still 22 test-case files fail), see also PR56818 * Remove "offset" field * Other bugs, cleanup, ... Tobias tob@archimedes:~/projects/gcc/gcc/testsuite > diffstat /dev/shm/array-desc-type-v2.diff b/gcc/fortran/libgfortran.h | 23 - b/gcc/fortran/trans-array.c | 134 +++--- b/gcc/fortran/trans-array.h | 7 b/gcc/fortran/trans-decl.c | 4 b/gcc/fortran/trans-expr.c | 43 +- b/gcc/fortran/trans-intrinsic.c | 39 - b/gcc/fortran/trans-io.c | 16 b/gcc/fortran/trans-stmt.c | 21 - b/gcc/fortran/trans-types.c | 165 ++----- b/gcc/fortran/trans-types.h | 2 b/gcc/fortran/trans.c | 4 b/gcc/fortran/trans.h | 3 b/gcc/testsuite/gfortran.dg/assign_10.f90 | 2 b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 3 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 | 10 b/gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 3 b/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c | 4 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 | 2 b/libgfortran/ISO_Fortran_binding.h.tmpl | 22 - b/libgfortran/intrinsics/associated.c | 2 b/libgfortran/intrinsics/cshift0.c | 63 +-- b/libgfortran/intrinsics/date_and_time.c | 4 b/libgfortran/intrinsics/iso_c_binding.c | 11 b/libgfortran/intrinsics/pack_generic.c | 154 +++---- b/libgfortran/intrinsics/spread_generic.c | 282 ++++++------- b/libgfortran/intrinsics/unpack_generic.c | 313 +++++++-------- b/libgfortran/io/io.h | 6 b/libgfortran/io/list_read.c | 40 - b/libgfortran/io/transfer.c | 22 - b/libgfortran/io/write.c | 26 - b/libgfortran/libgfortran.h | 95 ---- b/libgfortran/runtime/in_pack_generic.c | 119 ++--- b/libgfortran/runtime/in_unpack_generic.c | 136 +++--- b/libgfortran/runtime/iso_ts29113.c | 9 gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_2.f90 | 158 +++++++ gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_3.f90 | 71 +++ gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_3_c.c | 206 +++++++++ 37 files changed, 1239 insertions(+), 985 deletions(-) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 1444038..672a8d2 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -115,9 +115,24 @@ libgfortran_stat_codes; #define GFC_MAX_DIMENSIONS 15 -#define GFC_DTYPE_TYPE_SHIFT 3 -#define GFC_DTYPE_TYPE_MASK 0x38 -#define GFC_DTYPE_SIZE_SHIFT 6 +#define GFC_TYPE_MASK 0xFF +#define GFC_TYPE_KIND_SHIFT 8 + +/* Array-descriptor attributes, see ISO_Fortran_binding.h. */ +#define GFC_ATTRIBUTE_POINTER 1 +#define GFC_ATTRIBUTE_ALLOCATABLE 2 +#define GFC_ATTRIBUTE_OTHER 3 + +/* Array-descriptor basic types, see ISO_Fortran_binding.h. */ +#define GFC_TYPE_INTEGER 1 +#define GFC_TYPE_LOGICAL 2 +#define GFC_TYPE_REAL 3 +#define GFC_TYPE_COMPLEX 4 +#define GFC_TYPE_CHARACTER 5 +#define GFC_TYPE_STRUCT 6 +#define GFC_TYPE_CPTR 7 +#define GFC_TYPE_CFUNPTR 8 +#define GFC_TYPE_OTHER -1 /* Array-descriptor attributes, see ISO_Fortran_binding.h. */ #define GFC_ATTRIBUTE_POINTER 1 @@ -130,7 +145,7 @@ libgfortran_stat_codes; used in the run-time library for IO. */ typedef enum { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX, - BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID, + BT_CHARACTER, BT_DERIVED, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID, BT_ASSUMED } bt; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4d5e2f2..49eaaae 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -127,9 +127,9 @@ gfc_array_dataptr_type (tree desc) #define ELEM_LEN_FIELD 1 #define VERSION_FIELD 2 #define RANK_FIELD 3 -#define OFFSET_FIELD 4 +#define ATTR_FIELD 4 #define DTYPE_FIELD 5 -#define ATTR_FIELD 6 +#define OFFSET_FIELD 6 #define DIMENSION_FIELD 7 #define CAF_TOKEN_FIELD 8 @@ -283,7 +283,8 @@ gfc_conv_descriptor_dtype (tree desc) gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + gcc_assert (field != NULL_TREE + && TREE_CODE (TREE_TYPE (field)) == INTEGER_TYPE); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); @@ -306,7 +307,8 @@ gfc_conv_descriptor_rank (tree desc) gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); field = gfc_advance_chain (TYPE_FIELDS (type), RANK_FIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == integer_type_node); + gcc_assert (field != NULL_TREE + && TREE_CODE (TREE_TYPE (field)) == INTEGER_TYPE); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); @@ -316,8 +318,8 @@ gfc_conv_descriptor_rank (tree desc) void gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int rank) { - gfc_add_modify (block, gfc_conv_descriptor_rank (desc), - build_int_cst (integer_type_node, rank)); + tree field = gfc_conv_descriptor_rank (desc); + gfc_add_modify (block, field, build_int_cst (TREE_TYPE (field), rank)); } @@ -349,11 +351,12 @@ gfc_conv_descriptor_attr_set (stmtblock_t *block, tree desc, int attr) gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); field = gfc_advance_chain (TYPE_FIELDS (type), ATTR_FIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == integer_type_node); + gcc_assert (field != NULL_TREE + && TREE_CODE (TREE_TYPE (field)) == INTEGER_TYPE); field = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); - gfc_add_modify (block, field, build_int_cst (integer_type_node, attr)); + gfc_add_modify (block, field, build_int_cst (TREE_TYPE (field), attr)); } @@ -564,7 +567,8 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, /* Build a null array descriptor constructor. */ tree -gfc_build_null_descriptor (tree desc_type, int rank, int attr) +gfc_build_null_descriptor (tree desc_type, int rank, int attr, + gfc_typespec *ts) { tree field; tree tmp; @@ -590,16 +594,16 @@ gfc_build_null_descriptor (tree desc_type, int rank, int attr) /* Set rank. */ tmp = gfc_advance_chain (field, RANK_FIELD); CONSTRUCTOR_APPEND_ELT (init, tmp, - build_int_cst (integer_type_node, rank)); - - /* Set type. */ - tmp = gfc_advance_chain (field, DTYPE_FIELD); - CONSTRUCTOR_APPEND_ELT (init, tmp, gfc_get_dtype (desc_type)); + build_int_cst (TREE_TYPE (tmp), rank)); /* Set attribute (allocatable, pointer, other). */ tmp = gfc_advance_chain (field, ATTR_FIELD); CONSTRUCTOR_APPEND_ELT (init, tmp, - build_int_cst (integer_type_node, attr)); + build_int_cst (TREE_TYPE (tmp), attr)); + + /* Set type. */ + tmp = gfc_advance_chain (field, DTYPE_FIELD); + CONSTRUCTOR_APPEND_ELT (init, tmp, gfc_get_dtype (ts)); /* All other fields are set during allocate/pointer association. */ tmp = build_constructor (desc_type, init); @@ -919,7 +923,7 @@ gfc_trans_static_array_pointer (gfc_symbol * sym) type = TREE_TYPE (sym->backend_decl); DECL_INITIAL (sym->backend_decl) - = gfc_build_null_descriptor (type, sym->as->rank, attr); + = gfc_build_null_descriptor (type, sym->as->rank, attr, &sym->ts); } @@ -1190,7 +1194,8 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) tree gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tree eltype, tree initial, bool dynamic, - bool dealloc, bool callee_alloc, locus * where) + bool dealloc, bool callee_alloc, + gfc_typespec *ts, tree strlen, locus * where) { gfc_loopinfo *loop; gfc_ss *s; @@ -1200,6 +1205,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tree desc; tree tmp; tree size; + tree elem_len; tree nelem; tree cond; tree or_expr; @@ -1280,32 +1286,42 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, GFC_DECL_PACKED_ARRAY (desc) = 1; info->descriptor = desc; - size = gfc_index_one_node; /* Fill in the elem_len, version, rank, dtype and attribute. */ - gfc_conv_descriptor_elem_len_set (pre, desc, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); + + if (class_expr != NULL_TREE) + elem_len = gfc_vtable_size_get (class_expr); + else if (ts->type == BT_CHARACTER && strlen) + elem_len = size_of_string_in_bytes (ts->kind, strlen); + else if (ts->type != BT_CHARACTER) + elem_len = size_in_bytes (gfc_typenode_for_spec (ts)); + else + elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + + gfc_conv_descriptor_elem_len_set (pre, desc, elem_len); gfc_conv_descriptor_version_set (pre, desc); gfc_conv_descriptor_rank_set (pre, desc, total_dim); tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (type)); + gfc_add_modify (pre, tmp, gfc_get_dtype (ts)); gfc_conv_descriptor_attr_set (pre, desc, GFC_ATTRIBUTE_ALLOCATABLE); /* Fill in the bounds and stride. This is a packed array, so: - size = 1; + size = elem_len; for (n = 0; n < rank; n++) { - stride[n] = size - delta = ubound[n] + 1 - lbound[n]; + sm[n] = size + delta = extent[n]; size = size * delta; } - size = size * sizeof(element); */ or_expr = NULL_TREE; + elem_len = fold_convert (gfc_array_index_type, elem_len); + size = elem_len; + /* If there is at least one null loop->to[n], it is a callee allocated array. */ for (n = 0; n < total_dim; n++) @@ -1334,17 +1350,17 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, for (n = 0; n < total_dim; n++) { /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); + gfc_conv_descriptor_sm_set (pre, desc, gfc_rank_cst[n], size); gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], gfc_index_zero_node); - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, to[n], gfc_index_one_node); + gfc_conv_descriptor_extent_set (pre, desc, gfc_rank_cst[n], tmp); + /* Check whether the size for this dimension is negative. */ cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp, gfc_index_zero_node); @@ -1363,27 +1379,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, } /* Get the size of the array. */ - if (size && !callee_alloc) + if (size != NULL_TREE && !callee_alloc) { - tree elemsize; /* If or_expr is true, then the extent in at least one dimension is zero and the size is set to zero. */ size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, or_expr, gfc_index_zero_node, size); - - nelem = size; - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - else - elemsize = gfc_vtable_size_get (class_expr); - - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, elemsize); + nelem = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, size, elem_len); } else { - nelem = size; + nelem = (size == NULL_TREE) + ? NULL_TREE + : fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, size, elem_len); size = NULL_TREE; } @@ -1667,7 +1677,7 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock, /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); /* Make sure the constructed array has room for the new data. */ if (dynamic) @@ -2502,7 +2512,8 @@ trans_array_constructor (gfc_ss * ss, locus * where) } gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, - NULL_TREE, dynamic, true, false, where); + NULL_TREE, dynamic, true, false, &expr->ts, + ss_info->string_length, where); desc = ss_info->data.array.descriptor; offset = gfc_index_zero_node; @@ -4858,7 +4869,7 @@ set_loop_bounds (gfc_loopinfo *loop) moved outside the loop. */ void -gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) +gfc_conv_loop_setup (gfc_loopinfo *loop, locus *where, gfc_typespec *ts) { gfc_ss *tmp_ss; tree tmp; @@ -4894,7 +4905,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) gcc_assert (tmp_ss->dimen != 0); gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, - NULL_TREE, false, true, false, where); + NULL_TREE, false, true, false, ts, + tmp_ss_info->string_length, where); } /* For array parameters we don't have loop variables, so don't calculate the @@ -5067,7 +5079,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) /*GCC ARRAYS*/ static tree -gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, +gfc_array_init_size (tree descriptor, gfc_typespec *ts, + int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, tree expr3_elem_size, tree *nelems, gfc_expr *expr3) @@ -5095,11 +5108,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, offset = gfc_index_zero_node; /* Set the rank and dtype. */ - tmp = gfc_conv_descriptor_rank (descriptor); - gfc_add_modify (descriptor_block, tmp, build_int_cst (integer_type_node, - rank)); + gfc_conv_descriptor_rank_set (descriptor_block, descriptor, rank); tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (ts)); or_expr = boolean_false_node; @@ -5402,7 +5413,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, overflow = integer_zero_node; gfc_init_block (&set_descriptor_block); - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, + size = gfc_array_init_size (se->expr, &expr->ts, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, expr3_elem_size, nelems, expr3); @@ -5676,7 +5687,8 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) break; case EXPR_NULL: - return gfc_build_null_descriptor (type, 1, GFC_ATTRIBUTE_OTHER); + return gfc_build_null_descriptor (type, 1, GFC_ATTRIBUTE_OTHER, + &expr->ts); default: gcc_unreachable (); @@ -6852,7 +6864,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_add_ss_to_loop (&loop, loop.temp_ss); } - gfc_conv_loop_setup (&loop, & expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); if (need_tmp) { @@ -6986,13 +6998,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (expr->ts.type == BT_CHARACTER) elem_len = size_of_string_in_bytes (expr->ts.kind, se->string_length); else - elem_len = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + elem_len = size_in_bytes (gfc_typenode_for_spec(&expr->ts)); gfc_conv_descriptor_elem_len_set (&loop.pre, parm, elem_len); gfc_conv_descriptor_version_set (&loop.pre, parm); gfc_conv_descriptor_rank_set (&loop.pre, parm, loop.dimen); tmp = gfc_conv_descriptor_dtype (parm); - gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); + gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (&expr->ts)); gfc_conv_descriptor_attr_set (&loop.pre, parm, GFC_ATTRIBUTE_OTHER); /* Set offset for assignments to pointer only to zero if it is not @@ -7889,7 +7901,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_conv_descriptor_version_set (&fnblock, comp); gfc_conv_descriptor_rank_set (&fnblock, comp, c->as->rank); gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), - gfc_get_dtype (TREE_TYPE (comp))); + gfc_get_dtype (&c->ts)); gfc_conv_descriptor_attr_set (&fnblock, comp, c->attr.allocatable ? GFC_ATTRIBUTE_ALLOCATABLE @@ -7932,7 +7944,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_conv_descriptor_rank_set (&fnblock, comp, CLASS_DATA (c)->as->rank); gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), - gfc_get_dtype (TREE_TYPE (comp))); + gfc_get_dtype (&c->ts)); gfc_conv_descriptor_attr_set (&fnblock, comp, c->attr.allocatable ? GFC_ATTRIBUTE_ALLOCATABLE @@ -8534,11 +8546,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 1, size2); gfc_conv_descriptor_data_set (&alloc_block, desc, tmp); - tmp = gfc_conv_descriptor_rank (desc); - gfc_add_modify (&alloc_block, tmp, build_int_cst (integer_type_node, - expr1->rank)); + gfc_conv_descriptor_rank_set (&alloc_block, desc, expr1->rank); tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); + gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (&expr1->ts)); if ((expr1->ts.type == BT_DERIVED) && expr1->ts.u.derived->attr.alloc_comp) { @@ -8673,7 +8683,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) gfc_conv_descriptor_version_set (&init, descriptor); gfc_conv_descriptor_rank_set (&init, descriptor, sym->as->rank); tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (&init, tmp, gfc_get_dtype (type)); + gfc_add_modify (&init, tmp, gfc_get_dtype (&sym->ts)); gcc_assert (sym->attr.allocatable || sym->attr.pointer); gfc_conv_descriptor_attr_set (&init, descriptor, sym->attr.allocatable diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index e4804e9..bb3d4c8 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -32,7 +32,8 @@ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, /* Generate code to create a temporary array. */ tree gfc_trans_create_temp_array (stmtblock_t *, stmtblock_t *, gfc_ss *, - tree, tree, bool, bool, bool, locus *); + tree, tree, bool, bool, bool, + gfc_typespec *, tree, locus *); /* Generate function entry code for allocation of compiler allocated array variables. */ @@ -114,13 +115,13 @@ void gfc_trans_scalarizing_loops (gfc_loopinfo *, stmtblock_t *); /* Mark the end of the main loop body and the start of the copying loop. */ void gfc_trans_scalarized_loop_boundary (gfc_loopinfo *, stmtblock_t *); /* Initialize the scalarization loop parameters. */ -void gfc_conv_loop_setup (gfc_loopinfo *, locus *); +void gfc_conv_loop_setup (gfc_loopinfo *, locus *, gfc_typespec *ts); /* Set each array's delta. */ void gfc_set_delta (gfc_loopinfo *); /* Resolve array assignment dependencies. */ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *); /* Build a null array descriptor constructor. */ -tree gfc_build_null_descriptor (tree, int, int); +tree gfc_build_null_descriptor (tree, int, int, gfc_typespec *); /* Get a single array element. */ void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_symbol *, locus *); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 37ec402..aa95051 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3686,7 +3686,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) tmp = gfc_class_data_get (sym->backend_decl); tmp = gfc_build_null_descriptor (TREE_TYPE (tmp), CLASS_DATA (sym)->as->rank, - attr); + attr, &sym->ts); } else tmp = null_pointer_node; @@ -3843,7 +3843,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_conv_descriptor_rank_set (&init, descriptor, CLASS_DATA (sym)->as->rank); tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (&init, tmp, gfc_get_dtype (type)); + gfc_add_modify (&init, tmp, gfc_get_dtype (&sym->ts)); gfc_conv_descriptor_attr_set (&init, descriptor, CLASS_DATA (sym)->attr.allocatable ? GFC_ATTRIBUTE_ALLOCATABLE diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5407819..e21c3d2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -60,7 +60,8 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) } tree -gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) +gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr, + gfc_typespec *ts) { tree desc, type; int desc_attr; @@ -74,7 +75,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) gfc_conv_descriptor_version_set (&se->pre, desc); gfc_conv_descriptor_rank_set (&se->pre, desc, 0); gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (type)); + gfc_get_dtype (ts)); if (attr.pointer) desc_attr = GFC_ATTRIBUTE_POINTER; else if (attr.allocatable) @@ -385,7 +386,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_conv_descriptor_version_set (&parmse->pre, ctree); gfc_conv_descriptor_rank_set (&parmse->pre, ctree, 0); gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), - gfc_get_dtype (type)); + gfc_get_dtype (&class_ts)); if (attr.pointer) desc_attr = GFC_ATTRIBUTE_POINTER; @@ -652,13 +653,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, { if (e->rank == 0) { -// FIXME: Use gfc_conv_scalar_to_descriptor - tree type = get_scalar_to_descriptor_type (parmse->expr, - gfc_expr_attr (e)); - gfc_add_modify (&block, gfc_conv_descriptor_rank (ctree), - build_int_cst (integer_type_node, 0)); + gfc_conv_descriptor_rank_set (&block, ctree, 0); gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree), - gfc_get_dtype (type)); + gfc_get_dtype (&e->ts)); tmp = gfc_class_data_get (parmse->expr); if (!POINTER_TYPE_P (TREE_TYPE (tmp))) @@ -3616,7 +3613,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gfc_add_ss_to_loop (&loop, loop.temp_ss); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); /* Pass the temporary descriptor back to the caller. */ info = &loop.temp_ss->info->data.array; @@ -3680,7 +3677,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gfc_conv_ss_startstride (&loop2); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop2, &expr->where); + gfc_conv_loop_setup (&loop2, &expr->where, &expr->ts); gfc_copy_loopinfo_to_se (&lse, &loop2); gfc_copy_loopinfo_to_se (&rse, &loop2); @@ -4334,7 +4331,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0)))) tmp = TREE_OPERAND (tmp, 0); parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp, - fsym->attr); + fsym->attr, + &e->ts); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } @@ -4921,6 +4919,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, tmp, NULL_TREE, false, !comp->attr.pointer, callee_alloc, + &se->ss->info->expr->ts, + se->ss->info->string_length, &se->ss->info->expr->where); /* Pass the temporary as the first argument. */ @@ -4957,6 +4957,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, tmp, NULL_TREE, false, !sym->attr.pointer, callee_alloc, + &se->ss->info->expr->ts, + se->ss->info->string_length, &se->ss->info->expr->where); /* Pass the temporary as the first argument. */ @@ -5617,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, /* Arrays need special handling. */ if (pointer) ctor = gfc_build_null_descriptor (type, rank, - GFC_ATTRIBUTE_POINTER); + GFC_ATTRIBUTE_POINTER, ts); /* Special case assigning an array to zero. */ else if (is_zero_initializer_p (expr)) ctor = build_constructor (type, NULL); @@ -5725,7 +5727,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_ss_startstride (&loop); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); /* Setup the gfc_se structures. */ gfc_copy_loopinfo_to_se (&lse, &loop); @@ -6554,7 +6556,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (expr1->ts.deferred || expr1->ts.type == BT_CLASS) { dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_get_dtype (TREE_TYPE (desc)); + tmp = gfc_get_dtype (&expr2->ts); gfc_add_modify (&block, dtype, tmp); } @@ -7005,8 +7007,8 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) reallocatable assignments from extrinsic function calls. */ static void -realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, - gfc_loopinfo *loop) +realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_typespec *ts, + gfc_ss **ss, gfc_loopinfo *loop) { /* Signal that the function call should not be made by gfc_conv_loop_setup. */ @@ -7015,7 +7017,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, gfc_add_ss_to_loop (loop, *ss); gfc_add_ss_to_loop (loop, se->ss); gfc_conv_ss_startstride (loop); - gfc_conv_loop_setup (loop, where); + gfc_conv_loop_setup (loop, where, ts); gfc_copy_loopinfo_to_se (se, loop); gfc_add_block_to_block (&se->pre, &loop->pre); gfc_add_block_to_block (&se->pre, &loop->post); @@ -7184,7 +7186,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ss = gfc_walk_expr (expr1); gcc_assert (ss != gfc_ss_terminator); - realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop); + realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &expr1->ts, + &ss, &loop); ss->is_alloc_lhs = 1; } else @@ -7656,7 +7659,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Resolve any data dependencies in the statement. */ gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop, &expr2->where); + gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts); /* Setup the gfc_se structures. */ gfc_copy_loopinfo_to_se (&lse, &loop); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 1d7543c..de3ba4a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -926,7 +926,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr) { stmtblock_t loop; tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, - lbound, ubound, extent, ml; + lbound, extent, ml; gfc_se argse; int rank, corank; @@ -1082,10 +1082,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr) gfc_add_modify (&loop, ml, m); /* extent = ... */ - lbound = gfc_conv_descriptor_lbound_get (desc, loop_var); - ubound = gfc_conv_descriptor_ubound_get (desc, loop_var); - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); - extent = fold_convert (type, extent); + extent = fold_convert (type, gfc_conv_descriptor_extent_get (desc, loop_var)); /* m = m/extent. */ gfc_add_modify (&loop, m, @@ -1208,12 +1205,11 @@ trans_image_index (gfc_se * se, gfc_expr *expr) for (codim = corank + rank - 2; codim >= rank; codim--) { - tree extent, ubound; + tree extent; /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[codim]); /* coindex *= extent. */ coindex = fold_build2_loc (input_location, MULT_EXPR, @@ -1280,7 +1276,8 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - se->expr = gfc_conv_descriptor_rank (argse.expr); + se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), + gfc_conv_descriptor_rank (argse.expr)); } @@ -1370,7 +1367,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) else tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - bound, fold_convert(TREE_TYPE (bound), tmp)); + bound, fold_convert (TREE_TYPE (bound), tmp)); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -2491,7 +2488,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); gfc_mark_ss_chain_used (arrayss, 1); /* Generate the loop body. */ @@ -2573,7 +2570,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); gfc_mark_ss_chain_used (arrayss, 1); /* Generate the loop body. */ @@ -2707,7 +2704,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); gfc_mark_ss_chain_used (arrayss, 1); if (maskexpr && maskexpr->rank > 0) @@ -2928,7 +2925,7 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); gfc_mark_ss_chain_used (arrayss1, 1); gfc_mark_ss_chain_used (arrayss2, 1); @@ -3169,7 +3166,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) loops (without conflicting with temporary management), or use a single loop minmaxloc implementation. See PR 31067. */ loop.temp_dim = loop.dimen; - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); gcc_assert (loop.dimen == 1); if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) @@ -3629,7 +3626,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) loops (without conflicting with temporary management), or use a single loop minmaxval implementation. See PR 31067. */ loop.temp_dim = loop.dimen; - gfc_conv_loop_setup (&loop, &expr->where); + gfc_conv_loop_setup (&loop, &expr->where, &expr->ts); if (nonempty == NULL && maskss == NULL && loop.dimen == 1 && loop.from[0] && loop.to[0]) @@ -5603,7 +5600,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) /* Build a destination descriptor, using the pointer, source, as the data field. */ gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type, - NULL_TREE, false, true, false, &expr->where); + NULL_TREE, false, true, false, + &expr->ts, NULL_TREE, &expr->where); /* Cast the pointer to the result. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); @@ -6428,10 +6426,9 @@ conv_isocbinding_subroutine (gfc_code *code) /* Set data value, rank, dtype, and offset. */ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr)); - gfc_add_modify (&block, gfc_conv_descriptor_rank (desc), - build_int_cst (integer_type_node, arg->next->expr->rank)); + gfc_conv_descriptor_rank_set (&block, desc, arg->next->expr->rank); gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (TREE_TYPE (desc))); + gfc_get_dtype (&arg->next->expr->ts)); /* Start scalarization of the bounds, using the shape argument. */ @@ -6442,7 +6439,7 @@ conv_isocbinding_subroutine (gfc_code *code) gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, shape_ss); gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &arg->next->expr->where); + gfc_conv_loop_setup (&loop, &arg->next->expr->where, &arg->next->expr->ts); gfc_mark_ss_chain_used (shape_ss, 1); gfc_copy_loopinfo_to_se (&shapese, &loop); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 7b03a6b..8cc9d50 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1539,11 +1539,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, tree dt = NULL; tree string; tree tmp; - tree dtype; tree dt_parm_addr; tree decl = NULL_TREE; int n_dim; - int itype; int rank = 0; gcc_assert (sym || c); @@ -1569,13 +1567,10 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, if (sym && sym->attr.dummy) decl = build_fold_indirect_ref_loc (input_location, decl); dt = TREE_TYPE (decl); - dtype = gfc_get_dtype (dt); tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dt)); } else { - itype = ts->type; - dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT); tmp = TREE_TYPE (decl); if (TREE_CODE (tmp) == REFERENCE_TYPE) tmp = TREE_TYPE (tmp); @@ -1586,15 +1581,16 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, /* Build up the arguments for the transfer call. The call for the scalar part transfers: - (address, name, type, kind or string_length, dtype) */ + (address, name, kind, elem_len, type) */ dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 7, dt_parm_addr, addr_expr, string, - IARG (ts->kind), tmp, - build_int_cst (integer_type_node, rank), dtype); + build_int_cst (integer_type_node, ts->kind), tmp, + build_int_cst (integer_type_node, rank), + build_int_cst (integer_type_node, ts->type)); gfc_add_expr_to_block (block, tmp); /* If the object is an array, transfer rank times: @@ -1972,7 +1968,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where) gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, ss); gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, where); + gfc_conv_loop_setup (&loop, where, &cm->ts); gfc_mark_ss_chain_used (ss, 1); gfc_start_scalarized_body (&loop, &body); @@ -2286,7 +2282,7 @@ gfc_trans_transfer (gfc_code * code) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &code->expr1->where); + gfc_conv_loop_setup (&loop, &code->expr1->where, &code->expr1->ts); /* The main loop body. */ gfc_mark_ss_chain_used (ss, 1); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1b65f2c..19a92e7 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -315,7 +315,8 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, gfc_init_block (&temp_post); tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss, temptype, initial, false, true, - false, &arg->expr->where); + false, &e->ts, se->string_length, + &arg->expr->where); gfc_add_modify (&se->pre, size, tmp); tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data); gfc_add_modify (&se->pre, data, tmp); @@ -451,7 +452,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, subscripts. This could be prevented in the elemental case as temporaries are handled separatedly (below in gfc_conv_elemental_dependencies). */ - gfc_conv_loop_setup (&loop, &code->expr1->where); + gfc_conv_loop_setup (&loop, &code->expr1->where, &code->expr1->ts); gfc_mark_ss_chain_used (ss, 1); /* Convert the arguments, checking for dependencies. */ @@ -1217,7 +1218,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) assignment from an unlimited polymorphic object. */ tmp = gfc_conv_descriptor_dtype (sym->backend_decl); gfc_add_modify (&se.pre, tmp, - gfc_get_dtype (TREE_TYPE (sym->backend_decl))); + gfc_get_dtype (&sym->ts)); } gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), @@ -2952,7 +2953,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, /* Calculate the bounds of the scalarization. */ gfc_conv_ss_startstride (&loop1); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop1, &expr->where); + gfc_conv_loop_setup (&loop1, &expr->where, &expr->ts); gfc_mark_ss_chain_used (lss, 1); @@ -3052,7 +3053,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, gfc_add_ss_to_loop (&loop, rss); gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr2->where); + gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts); gfc_mark_ss_chain_used (rss, 1); /* Start the loop body. */ @@ -3171,7 +3172,7 @@ compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS; gfc_conv_ss_startstride (&loop); gfc_option.rtcheck = save_flag; - gfc_conv_loop_setup (&loop, &expr2->where); + gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts); /* Figure out how many elements we need. */ for (i = 0; i < loop.dimen; i++) @@ -3516,7 +3517,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, /* Setup the scalarizing loops and bounds. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr2->where); + gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts); info = &rss->info->data.array; desc = info->descriptor; @@ -4034,7 +4035,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, gfc_add_ss_to_loop (&loop, rss); gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &me->where); + gfc_conv_loop_setup (&loop, &me->where, &me->ts); gfc_mark_ss_chain_used (rss, 1); /* Start the loop body. */ @@ -4204,7 +4205,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_conv_resolve_dependencies (&loop, lss_section, rss); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop, &expr2->where); + gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts); /* Setup the gfc_se structures. */ gfc_copy_loopinfo_to_se (&lse, &loop); @@ -4651,7 +4652,7 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) } gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &tdst->where); + gfc_conv_loop_setup (&loop, &tdst->where, &tdst->ts); gfc_mark_ss_chain_used (css, 1); gfc_mark_ss_chain_used (tdss, 1); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 9bd6a16..98a4f43 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -78,7 +78,6 @@ tree complex_float128_type_node = NULL_TREE; bool gfc_real16_is_float128 = false; static GTY(()) tree gfc_desc_dim_type; -static GTY(()) tree gfc_max_array_element_size; static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)]; static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)]; @@ -861,9 +860,6 @@ gfc_init_types (void) char name_buf[18]; int index; tree type; - unsigned n; - unsigned HOST_WIDE_INT hi; - unsigned HOST_WIDE_INT lo; /* Create and name the types. */ #define PUSH_TYPE(name, node) \ @@ -950,19 +946,6 @@ gfc_init_types (void) build_int_cst (gfc_array_index_type, 0), NULL_TREE); - /* The maximum array element size that can be handled is determined - by the number of bits available to store this field in the array - descriptor. */ - - n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT; - lo = ~ (unsigned HOST_WIDE_INT) 0; - if (n > HOST_BITS_PER_WIDE_INT) - hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n); - else - hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n; - gfc_max_array_element_size - = build_int_cst_wide (long_unsigned_type_node, lo, hi); - boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind); boolean_true_node = build_int_cst (boolean_type_node, 1); boolean_false_node = build_int_cst (boolean_type_node, 0); @@ -1190,21 +1173,25 @@ gfc_get_element_type (tree type) /* Build an array. This function is called from gfc_sym_type(). Actually returns array descriptor type. - Format of array descriptors is as follows: + Format of array descriptors is as follows, cf. TS29113:2012. struct gfc_array_descriptor { - array *data - index offset; - index dtype; - struct descriptor_dimension dimension[N_DIM]; + base_type *base_addr; + size_t elem_len; + int version; + int8_t rank; + int8_t attribute; + int16_t type; + ptrdiff_t offset; + struct CFI_dim_t dim[N_DIM]; } - struct descriptor_dimension + struct CFI_dim_t { - index stride; - index lbound; - index ubound; + ptrdiff_t lower_bound; + ptrdiff_t extent; + ptrdiff_t sm; } Translation code should use gfc_conv_descriptor_* rather than @@ -1216,10 +1203,10 @@ gfc_get_element_type (tree type) are gfc_array_index_type and the data node is a pointer to the data. See below for the handling of character types. - The dtype member is formatted as follows: - // 3 unused bits (used to be the rank) - type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits - size = dtype >> GFC_DTYPE_SIZE_SHIFT + The type member is formatted as follows; the lower byte contains + the type, the upper byte contains the kind value. + data_type = (type & GFC_TYPE_MASK) + kind = (type >> GFC_TYPE_KIND_SHIFT) I originally used nested ARRAY_TYPE nodes to represent arrays, but this generated poor code for assumed/deferred size arrays. These @@ -1386,87 +1373,45 @@ gfc_get_desc_dim_type (void) unknown cases abort. */ tree -gfc_get_dtype (tree type) +gfc_get_dtype (gfc_typespec *ts) { - tree size; - int n; - HOST_WIDE_INT i; - tree tmp; - tree dtype; - tree etype; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); + int type; + tree int16_type_node + = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (16)); - if (GFC_TYPE_ARRAY_DTYPE (type)) - return GFC_TYPE_ARRAY_DTYPE (type); - - etype = gfc_get_element_type (type); - - switch (TREE_CODE (etype)) + switch (ts->type) { - case INTEGER_TYPE: - n = BT_INTEGER; - break; - - case BOOLEAN_TYPE: - n = BT_LOGICAL; + case BT_INTEGER: + type = GFC_TYPE_INTEGER + (ts->kind << GFC_TYPE_KIND_SHIFT); break; - - case REAL_TYPE: - n = BT_REAL; + case BT_LOGICAL: + type = GFC_TYPE_LOGICAL + (ts->kind << GFC_TYPE_KIND_SHIFT); break; - - case COMPLEX_TYPE: - n = BT_COMPLEX; + case BT_REAL: + type = GFC_TYPE_REAL + (ts->kind << GFC_TYPE_KIND_SHIFT); break; - - /* We will never have arrays of arrays. */ - case RECORD_TYPE: - n = BT_DERIVED; + case BT_COMPLEX: + type = GFC_TYPE_COMPLEX + (ts->kind << GFC_TYPE_KIND_SHIFT); break; - - case ARRAY_TYPE: - n = BT_CHARACTER; + case BT_CHARACTER: + type = GFC_TYPE_CHARACTER + (ts->kind << GFC_TYPE_KIND_SHIFT); break; - - case POINTER_TYPE: - n = BT_ASSUMED; + case BT_DERIVED: + if (ts->f90_type == BT_VOID) + type = ts->u.derived + && ts->u.derived->intmod_sym_id == ISOCBINDING_PTR + ? GFC_TYPE_CFUNPTR : GFC_TYPE_CPTR; + type = GFC_TYPE_STRUCT; + if (ts->u.derived->attr.sequence || ts->u.derived->attr.is_bind_c) + type = GFC_TYPE_STRUCT; + else + type = GFC_TYPE_OTHER; break; - default: - /* TODO: Don't do dtype for temporary descriptorless arrays. */ - /* We can strange array types for temporary arrays. */ - return gfc_index_zero_node; + type = GFC_TYPE_OTHER; } - size = TYPE_SIZE_UNIT (etype); - - i = (n << GFC_DTYPE_TYPE_SHIFT); - if (size && INTEGER_CST_P (size)) - { - if (tree_int_cst_lt (gfc_max_array_element_size, size)) - gfc_fatal_error ("Array element size too big at %C"); - - i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; - } - dtype = build_int_cst (gfc_array_index_type, i); - - if (size && !INTEGER_CST_P (size)) - { - tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT); - tmp = fold_build2_loc (input_location, LSHIFT_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, size), tmp); - dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, dtype); - } - /* If we don't know the size we leave it as zero. This should never happen - for anything that is actually used. */ - /* TODO: Check this is actually true, particularly when repacking - assumed size parameters. */ - - GFC_TYPE_ARRAY_DTYPE (type) = dtype; - return dtype; + return build_int_cst (int16_type_node, type); } @@ -1689,9 +1634,15 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, enum gfc_array_kind akind) { tree fat_type, decl, arraytype, *chain = NULL; + tree int8_type_node, int16_type_node; char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; int idx; + int8_type_node + = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (8)); + int16_type_node + = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (16)); + /* Assumed-rank array. */ if (dimen == -1) dimen = GFC_MAX_DIMENSIONS; @@ -1737,25 +1688,25 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, /* Add the rank component. */ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("rank"), - integer_type_node, &chain); + int8_type_node, &chain); TREE_NO_WARNING (decl) = 1; - /* Add the offset component. */ + /* Add the attribute component. */ decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("offset"), - gfc_array_index_type, &chain); + get_identifier ("attribute"), + int8_type_node, &chain); TREE_NO_WARNING (decl) = 1; /* Add the type component. */ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("type"), - gfc_array_index_type, &chain); + int16_type_node, &chain); TREE_NO_WARNING (decl) = 1; - /* Add the attribute component. */ + /* Add the offset component. */ decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("attribute"), - integer_type_node, &chain); + get_identifier ("offset"), + gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; /* Build the array type for the stride and bound components. */ diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index eaecfe1..d7bf588 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -97,7 +97,7 @@ int gfc_return_by_reference (gfc_symbol *); int gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ -tree gfc_get_dtype (tree); +tree gfc_get_dtype (gfc_typespec *); tree gfc_get_ppc_type (gfc_component *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 8211573..e2e3eae 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1078,7 +1078,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, tmp = TREE_OPERAND (array, 0); gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); + array = gfc_conv_scalar_to_descriptor (&se, array, attr, &var->ts); array = gfc_build_addr_expr (NULL, array); gcc_assert (se.post.head == NULL_TREE); } @@ -1122,7 +1122,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, /* attr: Argument is neither a pointer/allocatable, i.e. no copy back needed */ gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); + array = gfc_conv_scalar_to_descriptor (&se, array, attr, &var->ts); array = gfc_build_addr_expr (NULL, array); gcc_assert (se.post.head == NULL_TREE); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3eb64d2..8b09bb7 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -404,7 +404,8 @@ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr); void gfc_conv_expr_reference (gfc_se * se, gfc_expr *); void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); -tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute); +tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute, + gfc_typespec *); /* Termine the byte-size of a string. */ tree size_of_string_in_bytes (int, tree); diff --git a/gcc/testsuite/gfortran.dg/assign_10.f90 b/gcc/testsuite/gfortran.dg/assign_10.f90 index 3aaa8fc..e37a414 100644 --- a/gcc/testsuite/gfortran.dg/assign_10.f90 +++ b/gcc/testsuite/gfortran.dg/assign_10.f90 @@ -24,5 +24,5 @@ end ! Note that it is the kind conversion that generates the temp. ! ! { dg-final { scan-tree-dump-times "parm" 28 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 28 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 26 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 index d5d0dd5..4e4df4e 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 @@ -16,6 +16,5 @@ function f() result(res) end function f end -! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.base_addr = .void .. D.\[0-9\]+;.*desc.0.elem_len = 48;.*desc.0.version = 1;.*desc.0.rank = 0;.*desc.0.type = 600;.*desc.0.attribute = 1;.*sub \\(&desc.0\\);.*D.\[0-9\]+ = .integer.kind=4. .. desc.0.base_addr;" "original" } } +! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.base_addr = .void .. D.\[0-9\]+;.*desc.0.elem_len = 32;.*desc.0.version = 1;.*desc.0.rank = 0;.*desc.0.type = 1025;.*desc.0.attribute = 1;.*sub \\(&desc.0\\);.*D.\[0-9\]+ = .integer.kind=4. .. desc.0.base_addr;" "original" } } ! { dg-final { cleanup-tree-dump "original" } } - diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 index 5263060..67e7063 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 @@ -15,10 +15,10 @@ subroutine sub(xxx, yyy) ptr4 = c_loc (yyy(5:)) end ! { dg-final { scan-tree-dump-not " _gfortran_internal_pack" "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.base_addr;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } } ! { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/class_allocate_14.f90 b/gcc/testsuite/gfortran.dg/class_allocate_14.f90 index 076176c..00c3c60 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_14.f90 +++ b/gcc/testsuite/gfortran.dg/class_allocate_14.f90 @@ -25,7 +25,8 @@ call sub() call sub2() end -! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.base_addr=0B, .elem_len=4, .version=1, .rank=1, .type=296, .attribute=2}, ._vptr=&__vtab_m_T};" 1 "original" } } +! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.base_addr=0B, .elem_len=4, .version=1, .rank=1, .attribute=2, .type=-1}, ._vptr=&__vtab_m_T};" 1 "original" } } ! { dg-final { scan-tree-dump-times "static struct __class_m_T_a y = {._data=0B, ._vptr=&__vtab_m_T};" 1 "original" } } + ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c b/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c index ed9fc8b..9f60b7b 100644 --- a/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c +++ b/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c @@ -20,9 +20,7 @@ test_address (CFI_cdesc_t *dv) if (dv->version != CFI_VERSION) abort (); if (dv->elem_len != sizeof (float)/ sizeof (char)) abort (); if (dv->attribute != CFI_attribute_other) abort (); - - /* FIXME: Add type assert: - if (dv->type != CFI_type_float) abort (); */ + if (dv->type != CFI_type_float) abort (); /* FIXME: TS 29113 requires lower_bound == 0, currently, lower_bound == 1 is used. */ diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 index 5be77cf..e8efc34 100644 --- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 +++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 @@ -61,5 +61,5 @@ end ! The check below for temporaries gave 14 and 33 for "parm" and "atmp". ! ! { dg-final { scan-tree-dump-times "parm" 102 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 18 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 16 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/libgfortran/ISO_Fortran_binding.h.tmpl b/libgfortran/ISO_Fortran_binding.h.tmpl index dd7e7cf..c52052a 100644 --- a/libgfortran/ISO_Fortran_binding.h.tmpl +++ b/libgfortran/ISO_Fortran_binding.h.tmpl @@ -67,9 +67,9 @@ extern "C" { /* Types definitions. */ typedef ptrdiff_t CFI_index_t; -typedef int CFI_attribute_t; -typedef ptrdiff_t CFI_type_t; -typedef int CFI_rank_t; +typedef int8_t CFI_rank_t; +typedef int8_t CFI_attribute_t; +typedef int16_t CFI_type_t; typedef struct CFI_dim_t @@ -86,9 +86,9 @@ typedef struct CFI_cdesc_t size_t elem_len; int version; CFI_rank_t rank; - size_t offset; - CFI_type_t type; CFI_attribute_t attribute; + CFI_type_t type; + size_t offset; CFI_dim_t dim[]; } CFI_cdesc_t; @@ -102,13 +102,13 @@ struct {\ size_t elem_len;\ int version; \ CFI_rank_t rank; \ - size_t offset;\ - CFI_index_t type;\ CFI_attribute_t attribute; \ + CFI_type_t type;\ + size_t offset;\ CFI_dim_t dim[r];\ } -#define CFI_CDESC_T(r) CFI_GFC_CDESC_T (r, void) +#define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void) /* Functions. */ @@ -141,9 +141,9 @@ int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []); /* Types without kind paramter. */ -#define CFI_type_struct 7 -#define CFI_type_cptr 8 -#define CFI_type_cfunptr 9 +#define CFI_type_struct 6 +#define CFI_type_cptr 7 +#define CFI_type_cfunptr 8 #define CFI_type_other -1 diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c index d34a063..e46fe7e 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -37,7 +37,7 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target) return 0; if (GFC_DESCRIPTOR_DATA (pointer) != GFC_DESCRIPTOR_DATA (target)) return 0; - if (GFC_DESCRIPTOR_DTYPE (pointer) != GFC_DESCRIPTOR_DTYPE (target)) + if (GFC_DESCRIPTOR_TYPE (pointer) != GFC_DESCRIPTOR_TYPE (target)) return 0; rank = GFC_DESCRIPTOR_RANK (pointer); diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index ee81111..832e807 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -51,7 +51,7 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, index_type n; index_type arraysize; - index_type type_size; + CFI_type_t type; if (which < 1 || which > GFC_DESCRIPTOR_RANK (array)) runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'"); @@ -92,98 +92,84 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, if (arraysize == 0) return; - type_size = GFC_DTYPE_TYPE_SIZE (array); + type = GFC_DESCRIPTOR_TYPE (array); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (array) == 1) + type = CFI_type_Integer1; - switch(type_size) + switch(type) { - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_INTEGER_1: - case GFC_DTYPE_DERIVED_1: + case CFI_type_Integer1: + case CFI_type_Logical1: cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which); return; - case GFC_DTYPE_LOGICAL_2: - case GFC_DTYPE_INTEGER_2: + case CFI_type_Integer2: + case CFI_type_Logical2: cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which); return; - case GFC_DTYPE_LOGICAL_4: - case GFC_DTYPE_INTEGER_4: + case CFI_type_Integer4: + case CFI_type_Logical4: cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which); return; - case GFC_DTYPE_LOGICAL_8: - case GFC_DTYPE_INTEGER_8: + case CFI_type_Integer8: + case CFI_type_Logical8: cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which); return; #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_LOGICAL_16: - case GFC_DTYPE_INTEGER_16: + case CFI_type_Integer16: + case CFI_type_Logical16: cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift, which); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_REAL_10 - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift, which); return; # endif # ifdef HAVE_GFC_REAL_16 - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift, which); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_COMPLEX_10 - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift, which); return; # endif # ifdef HAVE_GFC_COMPLEX_16 - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift, which); return; # endif -#endif default: break; @@ -286,7 +272,6 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, break; } - which = which - 1; sstride[0] = 0; rstride[0] = 0; diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c index d53ea29..ce90bb4 100644 --- a/libgfortran/intrinsics/date_and_time.c +++ b/libgfortran/intrinsics/date_and_time.c @@ -271,9 +271,7 @@ secnds (GFC_REAL_4 *x) /* Make the INTEGER*4 array for passing to date_and_time. */ gfc_array_i4 *avalues = xmalloc (sizeof (gfc_array_i4)); avalues->base_addr = &values[0]; - GFC_DESCRIPTOR_DTYPE (avalues) = ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) - & GFC_DTYPE_TYPE_MASK) + - (4 << GFC_DTYPE_SIZE_SHIFT); + GFC_DESCRIPTOR_TYPE (avalues) = CFI_type_Real4; GFC_DESCRIPTOR_ELEM_LEN (avalues) = sizeof (GFC_INTEGER_4); GFC_DIMENSION_SET (avalues->dim[0], 0, 8, sizeof (GFC_REAL_4)); diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c index e3e095d..0be7176 100644 --- a/libgfortran/intrinsics/iso_c_binding.c +++ b/libgfortran/intrinsics/iso_c_binding.c @@ -60,7 +60,8 @@ ISO_C_BINDING_PREFIX (c_f_pointer) (void *c_ptr_in, f_ptr_out->offset = 0; /* Set the data type (e.g., BT_INTEGER). */ - f_ptr_out->type = (type << GFC_DTYPE_TYPE_SHIFT); + f_ptr_out->type = type; + f_ptr_out->elem_len = elemSize; } /* Use the generic version of c_f_pointer to set common fields. */ @@ -156,8 +157,7 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in, shift right by TYPE_SHIFT bits we'll throw away the existing rank. Then, shift left by the same number to shift in zeros and or with the new rank. */ - f_ptr_out->type = ((f_ptr_out->type >> GFC_DTYPE_TYPE_SHIFT) - << GFC_DTYPE_TYPE_SHIFT); + f_ptr_out->type = f_ptr_out->type; } } @@ -176,8 +176,7 @@ ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in, /* Preserve the size and rank bits, but reset the type. */ if (shape != NULL) { - f_ptr_out->type = f_ptr_out->type & (~GFC_DTYPE_TYPE_MASK); - f_ptr_out->type = f_ptr_out->type - | (BT_DERIVED << GFC_DTYPE_TYPE_SHIFT); + f_ptr_out->type = f_ptr_out->type; + f_ptr_out->type = CFI_type_struct; } } diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index bae059a..5836c25 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -122,6 +122,8 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); sstride[n] = GFC_DESCRIPTOR_SM(array,n); mstride[n] = GFC_DESCRIPTOR_SM(mask,n); + if (extent[n] <= 0) + mptr = NULL; } if (sstride[0] == 0) sstride[0] = size; @@ -248,160 +250,154 @@ void pack (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_l1 *mask, const gfc_array_char *vector) { - index_type type_size; + CFI_type_t type; index_type size; - type_size = GFC_DTYPE_TYPE_SIZE(array); + type = GFC_DESCRIPTOR_TYPE (array); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (array) == 1) + type = CFI_type_Integer1; - switch(type_size) + switch(type) { - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_INTEGER_1: - case GFC_DTYPE_DERIVED_1: + case CFI_type_Integer1: + case CFI_type_Logical1: pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); return; - case GFC_DTYPE_LOGICAL_2: - case GFC_DTYPE_INTEGER_2: + case CFI_type_Integer2: + case CFI_type_Logical2: pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); return; - case GFC_DTYPE_LOGICAL_4: - case GFC_DTYPE_INTEGER_4: + case CFI_type_Integer4: + case CFI_type_Logical4: pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); return; - case GFC_DTYPE_LOGICAL_8: - case GFC_DTYPE_INTEGER_8: + case CFI_type_Integer8: + case CFI_type_Logical8: pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); return; #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_LOGICAL_16: - case GFC_DTYPE_INTEGER_16: + case CFI_type_Integer16: + case CFI_type_Logical16: pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_REAL_10 - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); return; # endif # ifdef HAVE_GFC_REAL_16 - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_COMPLEX_10 - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); return; # endif # ifdef HAVE_GFC_COMPLEX_16 - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); return; # endif -#endif /* For derived types, let's check the actual alignment of the data pointers. If they are aligned, we can safely call the unpack functions. */ - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr) - || (vector && GFC_UNALIGNED_2(vector->base_addr))) - break; - else - { - pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, - (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); - return; - } + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(array)) + { + case 2: + if (GFC_UNALIGNED_2(ret->base_addr) + || GFC_UNALIGNED_2(array->base_addr) + || (vector && GFC_UNALIGNED_2(vector->base_addr))) + break; + else + { + pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, + (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); + return; + } - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr) - || (vector && GFC_UNALIGNED_4(vector->base_addr))) - break; - else - { - pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, - (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); - return; - } + case 4: + if (GFC_UNALIGNED_4(ret->base_addr) + || GFC_UNALIGNED_4(array->base_addr) + || (vector && GFC_UNALIGNED_4(vector->base_addr))) + break; + else + { + pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, + (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); + return; + } - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr) - || (vector && GFC_UNALIGNED_8(vector->base_addr))) - break; - else - { - pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, - (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); - return; - } + case 8: + if (GFC_UNALIGNED_8(ret->base_addr) + || GFC_UNALIGNED_8(array->base_addr) + || (vector && GFC_UNALIGNED_8(vector->base_addr))) + break; + else + { + pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, + (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); + return; + } #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr) - || (vector && GFC_UNALIGNED_16(vector->base_addr))) - break; - else - { - pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, - (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); - return; - } + case 16: + if (GFC_UNALIGNED_16(ret->base_addr) + || GFC_UNALIGNED_16(array->base_addr) + || (vector && GFC_UNALIGNED_16(vector->base_addr))) + break; + else + { + pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); + return; + } #endif - + } } size = GFC_DESCRIPTOR_ELEM_LEN (array); diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index 00c10bf..56a2090 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -252,8 +252,9 @@ spread_internal_scalar (gfc_array_char *ret, const char *source, } else { - if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) - / GFC_DESCRIPTOR_STRIDE(ret,0)) + if (ncopies - 1 + > (index_type) ((GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0))) runtime_error ("dim too large in spread()"); } @@ -272,150 +273,146 @@ void spread (gfc_array_char *ret, const gfc_array_char *source, const index_type *along, const index_type *pncopies) { - index_type type_size; + CFI_type_t type; - type_size = GFC_DTYPE_TYPE_SIZE(ret); - switch(type_size) + type = GFC_DESCRIPTOR_TYPE (ret); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (ret) == 1) + type = CFI_type_Integer1; + + switch(type) { - case GFC_DTYPE_DERIVED_1: - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_INTEGER_1: + case CFI_type_Integer1: + case CFI_type_Logical1: spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source, *along, *pncopies); return; - case GFC_DTYPE_LOGICAL_2: - case GFC_DTYPE_INTEGER_2: + case CFI_type_Integer2: + case CFI_type_Logical2: spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, *along, *pncopies); return; - case GFC_DTYPE_LOGICAL_4: - case GFC_DTYPE_INTEGER_4: + case CFI_type_Integer4: + case CFI_type_Logical4: spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, *along, *pncopies); return; - case GFC_DTYPE_LOGICAL_8: - case GFC_DTYPE_INTEGER_8: + case CFI_type_Integer8: + case CFI_type_Logical8: spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, *along, *pncopies); return; #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_LOGICAL_16: - case GFC_DTYPE_INTEGER_16: + case CFI_type_Integer16: + case CFI_type_Logical16: spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, *along, *pncopies); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source, *along, *pncopies); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source, *along, *pncopies); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef GFC_HAVE_REAL_10 - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source, *along, *pncopies); return; # endif # ifdef GFC_HAVE_REAL_16 - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source, *along, *pncopies); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source, *along, *pncopies); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source, *along, *pncopies); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef GFC_HAVE_COMPLEX_10 - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source, *along, *pncopies); return; # endif # ifdef GFC_HAVE_COMPLEX_16 - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source, *along, *pncopies); return; # endif -#endif - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr)) - break; - else + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(ret)) { - spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, - *along, *pncopies); + case 2: + if (GFC_UNALIGNED_2(ret->base_addr) + || GFC_UNALIGNED_2(source->base_addr)) + break; + else + { + spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, + *along, *pncopies); return; - } + } - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr)) - break; - else - { - spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, - *along, *pncopies); + case 4: + if (GFC_UNALIGNED_4(ret->base_addr) + || GFC_UNALIGNED_4(source->base_addr)) + break; + else + { + spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, + *along, *pncopies); return; - } + } - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr)) - break; - else - { - spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, - *along, *pncopies); + case 8: + if (GFC_UNALIGNED_8(ret->base_addr) + || GFC_UNALIGNED_8(source->base_addr)) + break; + else + { + spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, + *along, *pncopies); return; - } + } #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(ret->base_addr) - || GFC_UNALIGNED_16(source->base_addr)) - break; - else - { - spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, - *along, *pncopies); - return; - } + case 16: + if (GFC_UNALIGNED_16(ret->base_addr) + || GFC_UNALIGNED_16(source->base_addr)) + break; + else + { + spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, + *along, *pncopies); + return; + } #endif + } + break; } spread_internal (ret, source, along, pncopies); @@ -465,151 +462,144 @@ void spread_scalar (gfc_array_char *ret, const char *source, const index_type *along, const index_type *pncopies) { - index_type type_size; + CFI_type_t type; if (!ret->type) runtime_error ("return array missing descriptor in spread()"); - type_size = GFC_DTYPE_TYPE_SIZE(ret); - switch(type_size) + type = GFC_DESCRIPTOR_TYPE (ret); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (ret) == 1) + type = CFI_type_Integer1; + + switch(type) { - case GFC_DTYPE_DERIVED_1: - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_INTEGER_1: + case CFI_type_Integer1: + case CFI_type_Logical1: spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source, *along, *pncopies); return; - case GFC_DTYPE_LOGICAL_2: - case GFC_DTYPE_INTEGER_2: + case CFI_type_Integer2: + case CFI_type_Logical2: spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, *along, *pncopies); return; - case GFC_DTYPE_LOGICAL_4: - case GFC_DTYPE_INTEGER_4: + case CFI_type_Integer4: + case CFI_type_Logical4: spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, *along, *pncopies); return; - case GFC_DTYPE_LOGICAL_8: - case GFC_DTYPE_INTEGER_8: + case CFI_type_Integer8: + case CFI_type_Logical8: spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, *along, *pncopies); return; #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_LOGICAL_16: - case GFC_DTYPE_INTEGER_16: + case CFI_type_Integer16: + case CFI_type_Logical16: spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, *along, *pncopies); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source, *along, *pncopies); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source, *along, *pncopies); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_REAL_10 - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source, *along, *pncopies); return; # endif # ifdef HAVE_GFC_REAL_16 - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source, *along, *pncopies); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source, *along, *pncopies); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source, *along, *pncopies); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_COMPLEX_10 - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source, *along, *pncopies); return; # endif # ifdef HAVE_GFC_COMPLEX_16 - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source, *along, *pncopies); return; # endif -#endif - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source)) - break; - else + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(ret)) { - spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, - *along, *pncopies); - return; - } + case 2: + if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source)) + break; + else + { + spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, + *along, *pncopies); + return; + } - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source)) - break; - else - { - spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, - *along, *pncopies); - return; - } + case 4: + if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source)) + break; + else + { + spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, + *along, *pncopies); + return; + } + + case 8: + if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source)) + break; + else + { + spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, + *along, *pncopies); + return; + } - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source)) - break; - else - { - spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, - *along, *pncopies); - return; - } #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source)) - break; - else - { - spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, - *along, *pncopies); - return; - } + case 16: + if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source)) + break; + else + { + spread_scalar_i16 ((gfc_array_i16 *) ret, + (GFC_INTEGER_16 *) source, *along, *pncopies); + return; + } #endif + } } spread_internal_scalar (ret, source, along, pncopies); diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index eb72ddf..22fd152 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -207,160 +207,155 @@ void unpack1 (gfc_array_char *ret, const gfc_array_char *vector, const gfc_array_l1 *mask, const gfc_array_char *field) { - index_type type_size; + CFI_type_t type; index_type size; if (unlikely(compile_options.bounds_check)) unpack_bounds (ret, vector, mask, field); - type_size = GFC_DTYPE_TYPE_SIZE (vector); size = GFC_DESCRIPTOR_ELEM_LEN (vector); - switch(type_size) + type = GFC_DESCRIPTOR_TYPE (vector); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (vector) == 1) + type = CFI_type_Integer1; + + switch (type) { - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_INTEGER_1: - case GFC_DTYPE_DERIVED_1: + case CFI_type_Integer1: + case CFI_type_Logical1: unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, mask, (gfc_array_i1 *) field); return; - case GFC_DTYPE_LOGICAL_2: - case GFC_DTYPE_INTEGER_2: + case CFI_type_Integer2: + case CFI_type_Logical2: unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, mask, (gfc_array_i2 *) field); return; - case GFC_DTYPE_LOGICAL_4: - case GFC_DTYPE_INTEGER_4: + case CFI_type_Integer4: + case CFI_type_Logical4: unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, mask, (gfc_array_i4 *) field); return; - case GFC_DTYPE_LOGICAL_8: - case GFC_DTYPE_INTEGER_8: + case CFI_type_Integer8: + case CFI_type_Logical8: unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, mask, (gfc_array_i8 *) field); return; #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_LOGICAL_16: - case GFC_DTYPE_INTEGER_16: + case CFI_type_Integer16: + case CFI_type_Logical16: unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, mask, (gfc_array_i16 *) field); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, mask, (gfc_array_r4 *) field); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector, mask, (gfc_array_r8 *) field); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_REAL_10 - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, mask, (gfc_array_r10 *) field); return; # endif # ifdef HAVE_GFC_REAL_16 - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, mask, (gfc_array_r16 *) field); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, mask, (gfc_array_c4 *) field); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, mask, (gfc_array_c8 *) field); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_COMPLEX_10 - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, mask, (gfc_array_c10 *) field); return; # endif # ifdef HAVE_GFC_COMPLEX_16 - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, mask, (gfc_array_c16 *) field); return; # endif -#endif - - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr) - || GFC_UNALIGNED_2(field->base_addr)) - break; - else - { - unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, - mask, (gfc_array_i2 *) field); - return; - } - - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr) - || GFC_UNALIGNED_4(field->base_addr)) - break; - else - { - unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, - mask, (gfc_array_i4 *) field); - return; - } - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr) - || GFC_UNALIGNED_8(field->base_addr)) - break; - else - { - unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, - mask, (gfc_array_i8 *) field); - return; - } + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(vector)) + { + case 2: + if (GFC_UNALIGNED_2(ret->base_addr) + || GFC_UNALIGNED_2(vector->base_addr) + || GFC_UNALIGNED_2(field->base_addr)) + break; + else + { + unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (gfc_array_i2 *) field); + return; + } + + case 4: + if (GFC_UNALIGNED_4(ret->base_addr) + || GFC_UNALIGNED_4(vector->base_addr) + || GFC_UNALIGNED_4(field->base_addr)) + break; + else + { + unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (gfc_array_i4 *) field); + return; + } + + case 8: + if (GFC_UNALIGNED_8(ret->base_addr) + || GFC_UNALIGNED_8(vector->base_addr) + || GFC_UNALIGNED_8(field->base_addr)) + break; + else + { + unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (gfc_array_i8 *) field); + return; + } #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(ret->base_addr) - || GFC_UNALIGNED_16(vector->base_addr) - || GFC_UNALIGNED_16(field->base_addr)) - break; - else - { - unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, - mask, (gfc_array_i16 *) field); - return; - } + case 16: + if (GFC_UNALIGNED_16(ret->base_addr) + || GFC_UNALIGNED_16(vector->base_addr) + || GFC_UNALIGNED_16(field->base_addr)) + break; + else + { + unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (gfc_array_i16 *) field); + return; + } #endif + } } unpack_internal (ret, vector, mask, field, size); @@ -419,160 +414,152 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector, const gfc_array_l1 *mask, char *field) { gfc_array_char tmp; - - index_type type_size; + CFI_type_t type; if (unlikely(compile_options.bounds_check)) unpack_bounds (ret, vector, mask, NULL); - type_size = GFC_DTYPE_TYPE_SIZE (vector); + type = GFC_DESCRIPTOR_TYPE (vector); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (vector) == 1) + type = CFI_type_Integer1; - switch (type_size) + switch (type) { - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_INTEGER_1: - case GFC_DTYPE_DERIVED_1: + case CFI_type_Integer1: + case CFI_type_Logical1: unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, mask, (GFC_INTEGER_1 *) field); return; - case GFC_DTYPE_LOGICAL_2: - case GFC_DTYPE_INTEGER_2: + case CFI_type_Integer2: + case CFI_type_Logical2: unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, mask, (GFC_INTEGER_2 *) field); return; - case GFC_DTYPE_LOGICAL_4: - case GFC_DTYPE_INTEGER_4: + case CFI_type_Integer4: + case CFI_type_Logical4: unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, mask, (GFC_INTEGER_4 *) field); return; - case GFC_DTYPE_LOGICAL_8: - case GFC_DTYPE_INTEGER_8: + case CFI_type_Integer8: + case CFI_type_Logical8: unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, mask, (GFC_INTEGER_8 *) field); return; #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_LOGICAL_16: - case GFC_DTYPE_INTEGER_16: + case CFI_type_Integer16: + case CFI_type_Logical16: unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, mask, (GFC_INTEGER_16 *) field); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, mask, (GFC_REAL_4 *) field); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector, mask, (GFC_REAL_8 *) field); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_REAL_10 - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, mask, (GFC_REAL_10 *) field); return; # endif # ifdef HAVE_GFC_REAL_16 - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, mask, (GFC_REAL_16 *) field); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, mask, (GFC_COMPLEX_4 *) field); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, mask, (GFC_COMPLEX_8 *) field); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # ifdef HAVE_GFC_COMPLEX_10 - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, mask, (GFC_COMPLEX_10 *) field); return; # endif # ifdef HAVE_GFC_COMPLEX_16 - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, mask, (GFC_COMPLEX_16 *) field); return; # endif -#endif - - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr) - || GFC_UNALIGNED_2(field)) - break; - else - { - unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, - mask, (GFC_INTEGER_2 *) field); - return; - } - - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr) - || GFC_UNALIGNED_4(field)) - break; - else - { - unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, - mask, (GFC_INTEGER_4 *) field); - return; - } - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr) - || GFC_UNALIGNED_8(field)) - break; - else + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(vector)) { - unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, - mask, (GFC_INTEGER_8 *) field); - return; - } + case 2: + if (GFC_UNALIGNED_2(ret->base_addr) + || GFC_UNALIGNED_2(vector->base_addr) + || GFC_UNALIGNED_2(field)) + break; + else + { + unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (GFC_INTEGER_2 *) field); + return; + } + + case 4: + if (GFC_UNALIGNED_4(ret->base_addr) + || GFC_UNALIGNED_4(vector->base_addr) + || GFC_UNALIGNED_4(field)) + break; + else + { + unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (GFC_INTEGER_4 *) field); + return; + } + + case 8: + if (GFC_UNALIGNED_8(ret->base_addr) + || GFC_UNALIGNED_8(vector->base_addr) + || GFC_UNALIGNED_8(field)) + break; + else + { + unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (GFC_INTEGER_8 *) field); + return; + } #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(ret->base_addr) - || GFC_UNALIGNED_16(vector->base_addr) - || GFC_UNALIGNED_16(field)) - break; - else - { - unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, - mask, (GFC_INTEGER_16 *) field); - return; - } + case 16: + if (GFC_UNALIGNED_16(ret->base_addr) + || GFC_UNALIGNED_16(vector->base_addr) + || GFC_UNALIGNED_16(field)) + break; + else + { + unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (GFC_INTEGER_16 *) field); + return; + } #endif - + } } memset (&tmp, 0, sizeof (tmp)); diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 8ea9326..18f4bfe 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -106,6 +106,9 @@ typedef struct namelist_type /* Object type. */ bt type; + /* Intrinsic kind. */ + int kind; + /* Object name. */ char * var_name; @@ -115,9 +118,6 @@ typedef struct namelist_type /* Flag to show that a read is to be attempted for this node. */ int touched; - /* Length of intrinsic type in bytes. */ - int len; - /* Rank of the object. */ int var_rank; diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 7188b47..45e57e4 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -2486,7 +2486,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, namelist_info * cmp; char * obj_name; int nml_carry; - int len; + int kind; int dim; index_type dlen; index_type m; @@ -2501,29 +2501,11 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, dtp->u.p.repeat_count = 0; eat_spaces (dtp); - len = nl->len; - switch (nl->type) - { - case BT_INTEGER: - case BT_LOGICAL: - dlen = len; - break; - - case BT_REAL: - dlen = size_from_real_kind (len); - break; - - case BT_COMPLEX: - dlen = size_from_complex_kind (len); - break; - - case BT_CHARACTER: - dlen = chigh ? (chigh - clow + 1) : nl->string_length; - break; - - default: - dlen = 0; - } + kind = nl->kind; + if (nl->type == BT_CHARACTER) + dlen = chigh ? (chigh - clow + 1) : nl->string_length; + else + dlen = nl->size; do { @@ -2553,27 +2535,27 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, switch (nl->type) { case BT_INTEGER: - read_integer (dtp, len); + read_integer (dtp, kind); break; case BT_LOGICAL: - read_logical (dtp, len); + read_logical (dtp, kind); break; case BT_CHARACTER: - read_character (dtp, len); + read_character (dtp, kind); break; case BT_REAL: /* Need to copy data back from the real location to the temp in order to handle nml reads into arrays. */ - read_real (dtp, pdata, len); + read_real (dtp, pdata, kind); memcpy (dtp->u.p.value, pdata, dlen); break; case BT_COMPLEX: /* Same as for REAL, copy back to temp. */ - read_complex (dtp, pdata, len, dlen); + read_complex (dtp, pdata, kind, dlen); memcpy (dtp->u.p.value, pdata, dlen); break; diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 9238600..cdeea1d 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2132,7 +2132,11 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; - iotype = (bt) GFC_DESCRIPTOR_TYPE (desc); + iotype = (bt) (GFC_DESCRIPTOR_TYPE (desc) & CFI_type_mask); + + if (iotype > CFI_type_Character) + internal_error (NULL, "transfer_array(): Bad type"); + size = iotype == BT_CHARACTER ? charlen : (index_type) GFC_DESCRIPTOR_ELEM_LEN (desc); @@ -3749,15 +3753,13 @@ st_wait (st_parameter_wait *wtp __attribute__((unused))) in a linked list of namelist_info types. */ extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, - GFC_INTEGER_4, size_t, int, - GFC_INTEGER_4); + int, size_t, int, int); export_proto(st_set_nml_var); void st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, - GFC_INTEGER_4 len, size_t elem_len, - int rank, GFC_INTEGER_4 type) + int kind, size_t elem_len, int rank, int type) { namelist_info *t1 = NULL; namelist_info *nml; @@ -3771,12 +3773,12 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, memcpy (nml->var_name, var_name, var_name_len); nml->var_name[var_name_len] = '\0'; - nml->len = (int) len; - nml->string_length = len ? (index_type) elem_len/len : 0; - - nml->var_rank = rank; + nml->type = (bt) type; + nml->kind = kind; nml->size = (index_type) elem_len; - nml->type = (bt) ((type & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT); + nml->string_length = nml->type == BT_CHARACTER + ? (index_type) elem_len/kind : 0; + nml->var_rank = rank; if (nml->var_rank > 0) { diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 153da2e..17dde93 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1744,28 +1744,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, num = 1; - len = obj->len; - - switch (obj->type) - { - - case BT_REAL: - obj_size = size_from_real_kind (len); - break; - - case BT_COMPLEX: - obj_size = size_from_complex_kind (len); - break; - - case BT_CHARACTER: - obj_size = obj->string_length; - break; - - default: - obj_size = len; - } - - if (obj->var_rank) + len = obj->kind; + if (obj->type == BT_CHARACTER) + obj_size = obj->string_length; + else obj_size = obj->size; /* Set the index vector and count the number of elements. */ diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index f897d1d..90be2d8 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -324,9 +324,20 @@ internal_proto(big_endian); #if GFC_ATTRIBUTE_POINTER != CFI_attribute_pointer \ || GFC_ATTRIBUTE_ALLOCATABLE != CFI_attribute_allocatable \ - || GFC_ATTRIBUTE_OTHER != CFI_attribute_other - || GFC_MAX_DIMENSIONS != CFI_MAX_RANK - chokeme + || GFC_ATTRIBUTE_OTHER != CFI_attribute_other \ + || GFC_MAX_DIMENSIONS != CFI_MAX_RANK \ + || GFC_TYPE_INTEGER != CFI_type_Integer \ + || GFC_TYPE_LOGICAL != CFI_type_Logical \ + || GFC_TYPE_REAL != CFI_type_Real \ + || GFC_TYPE_COMPLEX != CFI_type_Complex \ + || GFC_TYPE_CHARACTER != CFI_type_Character \ + || GFC_TYPE_STRUCT != CFI_type_struct \ + || GFC_TYPE_CPTR != CFI_type_cptr \ + || GFC_TYPE_CFUNPTR != CFI_type_cfunptr \ + || GFC_TYPE_OTHER != CFI_type_other \ + || GFC_TYPE_KIND_SHIFT != CFI_type_kind_shift \ + || GFC_TYPE_MASK != CFI_type_mask + choke me #endif typedef CFI_dim_t descriptor_dimension; @@ -367,8 +378,7 @@ typedef CFI_CDESC_TYPE_T (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; #define GFC_DESCRIPTOR_RANK(desc) ((desc)->rank) -#define GFC_DESCRIPTOR_TYPE(desc) (((desc)->type & GFC_DTYPE_TYPE_MASK) \ - >> GFC_DTYPE_TYPE_SHIFT) +#define GFC_DESCRIPTOR_TYPE(desc) ((desc)->type) #define GFC_DESCRIPTOR_ELEM_LEN(desc) ((desc)->elem_len) /* This is for getting the size of a type when the type of the @@ -376,7 +386,6 @@ typedef CFI_CDESC_TYPE_T (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; #define GFC_DESCRIPTOR_SIZE_TYPEKNOWN(desc) (sizeof((desc)->base_addr[0])) #define GFC_DESCRIPTOR_DATA(desc) ((desc)->base_addr) -#define GFC_DESCRIPTOR_DTYPE(desc) ((desc)->type) #define GFC_DIMENSION_LBOUND(dim) ((dim).lower_bound) #define GFC_DIMENSION_UBOUND(dim) ((dim).lower_bound + (dim).extent - 1) @@ -407,80 +416,8 @@ typedef CFI_CDESC_TYPE_T (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; types. */ #define GFC_DESCRIPTOR_STRIDE_TYPEKNOWN(desc,i) \ - (GFC_DESCRIPTOR_SM(desc,i) / GFC_DESCRIPTOR_SIZE_TYPEKNOWN(desc)) + ((index_type)(GFC_DESCRIPTOR_SM(desc,i) / GFC_DESCRIPTOR_SIZE_TYPEKNOWN(desc))) -/* Macros to get both the size and the type with a single masking operation */ - -#define GFC_DTYPE_SIZE_MASK \ - ((~((index_type) 0) >> GFC_DTYPE_SIZE_SHIFT) << GFC_DTYPE_SIZE_SHIFT) -#define GFC_DTYPE_TYPE_SIZE_MASK (GFC_DTYPE_SIZE_MASK | GFC_DTYPE_TYPE_MASK) - -#define GFC_DTYPE_TYPE_SIZE(desc) ((desc)->type & GFC_DTYPE_TYPE_SIZE_MASK) - -#define GFC_DTYPE_INTEGER_1 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_INTEGER_2 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_2) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_INTEGER_4 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_4) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_INTEGER_8 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_8) << GFC_DTYPE_SIZE_SHIFT)) -#ifdef HAVE_GFC_INTEGER_16 -#define GFC_DTYPE_INTEGER_16 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_16) << GFC_DTYPE_SIZE_SHIFT)) -#endif - -#define GFC_DTYPE_LOGICAL_1 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_LOGICAL_1) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_LOGICAL_2 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_LOGICAL_2) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_LOGICAL_4 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_LOGICAL_4) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_LOGICAL_8 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_LOGICAL_8) << GFC_DTYPE_SIZE_SHIFT)) -#ifdef HAVE_GFC_LOGICAL_16 -#define GFC_DTYPE_LOGICAL_16 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_LOGICAL_16) << GFC_DTYPE_SIZE_SHIFT)) -#endif - -#define GFC_DTYPE_REAL_4 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_REAL_4) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_REAL_8 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_REAL_8) << GFC_DTYPE_SIZE_SHIFT)) -#ifdef HAVE_GFC_REAL_10 -#define GFC_DTYPE_REAL_10 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_REAL_10) << GFC_DTYPE_SIZE_SHIFT)) -#endif -#ifdef HAVE_GFC_REAL_16 -#define GFC_DTYPE_REAL_16 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_REAL_16) << GFC_DTYPE_SIZE_SHIFT)) -#endif - -#define GFC_DTYPE_COMPLEX_4 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_COMPLEX_4) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_COMPLEX_8 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_COMPLEX_8) << GFC_DTYPE_SIZE_SHIFT)) -#ifdef HAVE_GFC_COMPLEX_10 -#define GFC_DTYPE_COMPLEX_10 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_COMPLEX_10) << GFC_DTYPE_SIZE_SHIFT)) -#endif -#ifdef HAVE_GFC_COMPLEX_16 -#define GFC_DTYPE_COMPLEX_16 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_COMPLEX_16) << GFC_DTYPE_SIZE_SHIFT)) -#endif - -#define GFC_DTYPE_DERIVED_1 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_DERIVED_2 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_2) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_DERIVED_4 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_4) << GFC_DTYPE_SIZE_SHIFT)) -#define GFC_DTYPE_DERIVED_8 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_8) << GFC_DTYPE_SIZE_SHIFT)) -#ifdef HAVE_GFC_INTEGER_16 -#define GFC_DTYPE_DERIVED_16 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ - | (sizeof(GFC_INTEGER_16) << GFC_DTYPE_SIZE_SHIFT)) -#endif /* Macros to determine the alignment of pointers. */ diff --git a/libgfortran/runtime/in_pack_generic.c b/libgfortran/runtime/in_pack_generic.c index 6e5b2b5..df92218 100644 --- a/libgfortran/runtime/in_pack_generic.c +++ b/libgfortran/runtime/in_pack_generic.c @@ -46,109 +46,102 @@ internal_pack (gfc_array_char * source) int n; int packed; index_type size; - index_type type_size; + CFI_type_t type; if (source->base_addr == NULL) - return NULL; + return source->base_addr; + + type = GFC_DESCRIPTOR_TYPE (source); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (source) == 1) + type = CFI_type_Integer1; - type_size = GFC_DTYPE_TYPE_SIZE(source); - switch (type_size) + switch (type) { - case GFC_DTYPE_INTEGER_1: - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_DERIVED_1: + case CFI_type_Integer1: + case CFI_type_Logical1: return internal_pack_1 ((gfc_array_i1 *) source); - case GFC_DTYPE_INTEGER_2: - case GFC_DTYPE_LOGICAL_2: + case CFI_type_Integer2: + case CFI_type_Logical2: return internal_pack_2 ((gfc_array_i2 *) source); - case GFC_DTYPE_INTEGER_4: - case GFC_DTYPE_LOGICAL_4: + case CFI_type_Integer4: + case CFI_type_Logical4: return internal_pack_4 ((gfc_array_i4 *) source); - case GFC_DTYPE_INTEGER_8: - case GFC_DTYPE_LOGICAL_8: + case CFI_type_Integer8: + case CFI_type_Logical8: return internal_pack_8 ((gfc_array_i8 *) source); #if defined(HAVE_GFC_INTEGER_16) - case GFC_DTYPE_INTEGER_16: - case GFC_DTYPE_LOGICAL_16: + case CFI_type_Integer16: + case CFI_type_Logical16: return internal_pack_16 ((gfc_array_i16 *) source); #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: return internal_pack_r4 ((gfc_array_r4 *) source); - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: return internal_pack_r8 ((gfc_array_r8 *) source); -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # if defined (HAVE_GFC_REAL_10) - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: return internal_pack_r10 ((gfc_array_r10 *) source); # endif # if defined (HAVE_GFC_REAL_16) - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: return internal_pack_r16 ((gfc_array_r16 *) source); # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: return internal_pack_c4 ((gfc_array_c4 *) source); - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: return internal_pack_c8 ((gfc_array_c8 *) source); -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # if defined (HAVE_GFC_COMPLEX_10) - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: return internal_pack_c10 ((gfc_array_c10 *) source); # endif # if defined (HAVE_GFC_COMPLEX_16) - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: return internal_pack_c16 ((gfc_array_c16 *) source); # endif -#endif - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(source->base_addr)) - break; - else - return internal_pack_2 ((gfc_array_i2 *) source); - - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(source->base_addr)) - break; - else - return internal_pack_4 ((gfc_array_i4 *) source); - - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(source->base_addr)) - break; - else - return internal_pack_8 ((gfc_array_i8 *) source); + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(source)) + { + case 2: + if (GFC_UNALIGNED_2(source->base_addr)) + break; + else + return internal_pack_2 ((gfc_array_i2 *) source); + + case 4: + if (GFC_UNALIGNED_4(source->base_addr)) + break; + else + return internal_pack_4 ((gfc_array_i4 *) source); + + case 8: + if (GFC_UNALIGNED_8(source->base_addr)) + break; + else + return internal_pack_8 ((gfc_array_i8 *) source); #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(source->base_addr)) - break; - else - return internal_pack_16 ((gfc_array_i16 *) source); + case 16: + if (GFC_UNALIGNED_16(source->base_addr)) + break; + else + return internal_pack_16 ((gfc_array_i16 *) source); #endif + } + break; default: break; @@ -179,8 +172,8 @@ internal_pack (gfc_array_char * source) if (packed) return source->base_addr; - /* Allocate storage for the destination. */ - destptr = xmalloc (ssize * size); + /* Allocate storage for the destination. */ + destptr = xmalloc (ssize); dest = (char *)destptr; src = source->base_addr; sm0 = sm[0]; diff --git a/libgfortran/runtime/in_unpack_generic.c b/libgfortran/runtime/in_unpack_generic.c index 8389b94..9ee8673 100644 --- a/libgfortran/runtime/in_unpack_generic.c +++ b/libgfortran/runtime/in_unpack_generic.c @@ -44,142 +44,136 @@ internal_unpack (gfc_array_char * d, const void * s) const char *src; int n; int size; - int type_size; + CFI_type_t type; dest = d->base_addr; /* This check may be redundant, but do it anyway. */ if (s == dest || !s) return; - type_size = GFC_DTYPE_TYPE_SIZE (d); - switch (type_size) + type = GFC_DESCRIPTOR_TYPE (d); + if ((type == CFI_type_struct || type == CFI_type_other) + && GFC_DESCRIPTOR_ELEM_LEN (d) == 1) + type = CFI_type_Integer1; + + switch (type) { - case GFC_DTYPE_INTEGER_1: - case GFC_DTYPE_LOGICAL_1: - case GFC_DTYPE_DERIVED_1: + case CFI_type_Integer1: + case CFI_type_Logical1: internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s); return; - case GFC_DTYPE_INTEGER_2: - case GFC_DTYPE_LOGICAL_2: + case CFI_type_Integer2: + case CFI_type_Logical2: internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); return; - case GFC_DTYPE_INTEGER_4: - case GFC_DTYPE_LOGICAL_4: + case CFI_type_Integer4: + case CFI_type_Logical4: internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); return; - case GFC_DTYPE_INTEGER_8: - case GFC_DTYPE_LOGICAL_8: + case CFI_type_Integer8: + case CFI_type_Logical8: internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); return; #if defined (HAVE_GFC_INTEGER_16) - case GFC_DTYPE_INTEGER_16: - case GFC_DTYPE_LOGICAL_16: + case CFI_type_Integer16: + case CFI_type_Logical16: internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s); return; #endif - case GFC_DTYPE_REAL_4: + case CFI_type_Real4: internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s); return; - case GFC_DTYPE_REAL_8: + case CFI_type_Real8: internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # if defined(HAVE_GFC_REAL_10) - case GFC_DTYPE_REAL_10: + case CFI_type_Real10: internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s); return; # endif # if defined(HAVE_GFC_REAL_16) - case GFC_DTYPE_REAL_16: + case CFI_type_Real16: internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s); return; # endif -#endif - case GFC_DTYPE_COMPLEX_4: + case CFI_type_Complex4: internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s); return; - case GFC_DTYPE_COMPLEX_8: + case CFI_type_Complex8: internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s); return; -/* FIXME: This here is a hack, which will have to be removed when - the array descriptor is reworked. Currently, we don't store the - kind value for the type, but only the size. Because on targets with - __float128, we have sizeof(logn double) == sizeof(__float128), - we cannot discriminate here and have to fall back to the generic - handling (which is suboptimal). */ -#if !defined(GFC_REAL_16_IS_FLOAT128) # if defined(HAVE_GFC_COMPLEX_10) - case GFC_DTYPE_COMPLEX_10: + case CFI_type_Complex10: internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s); return; # endif # if defined(HAVE_GFC_COMPLEX_16) - case GFC_DTYPE_COMPLEX_16: + case CFI_type_Complex16: internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s); return; # endif -#endif - - case GFC_DTYPE_DERIVED_2: - if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s)) - break; - else - { - internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); - return; - } - case GFC_DTYPE_DERIVED_4: - if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s)) - break; - else - { - internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); - return; - } - case GFC_DTYPE_DERIVED_8: - if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s)) - break; - else + case CFI_type_struct: + case CFI_type_other: + switch (GFC_DESCRIPTOR_ELEM_LEN(d)) { - internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); - return; - } + case 2: + if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s)) + break; + else + { + internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); + return; + } + + case 4: + if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s)) + break; + else + { + internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); + return; + } + + case 8: + if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s)) + break; + else + { + internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); + return; + } #ifdef HAVE_GFC_INTEGER_16 - case GFC_DTYPE_DERIVED_16: - if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s)) - break; - else - { - internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s); - return; - } + case 16: + if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s)) + break; + else + { + internal_unpack_16 ((gfc_array_i16 *) d, + (const GFC_INTEGER_16 *) s); + return; + } #endif + } + break; default: break; } - dim = GFC_DESCRIPTOR_RANK (d); size = GFC_DESCRIPTOR_ELEM_LEN (d); dsize = size; diff --git a/libgfortran/runtime/iso_ts29113.c b/libgfortran/runtime/iso_ts29113.c index cb2d728..891efeb 100644 --- a/libgfortran/runtime/iso_ts29113.c +++ b/libgfortran/runtime/iso_ts29113.c @@ -1,4 +1,4 @@ -/* ISO_Fortran_binding.h of GCC's GNU Fortran compiler. +/* iso_ts29113.c. of GCC's GNU Fortran compiler. Copyright (C) 2013 Free Software Foundation, Inc. This file is part of the GNU Fortran runtime library (libgfortran) @@ -252,9 +252,9 @@ CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, for (i = 0, j = 0; i < source->rank; i++) { if (lower_bounds) - offset += lower_bounds[i]*source->dim[i].sm; + offset += (lower_bounds[i]-source->dim[i].lower_bound)*source->dim[i].sm; - if (source->dim[i].sm == 0) + if (strides && strides[i] == 0) continue; result->dim[j].lower_bound = lower_bounds @@ -262,7 +262,7 @@ CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, if (upper_bounds) { CFI_index_t extent; - extent = upper_bounds[i] - result->dim[j].lower_bound; + extent = upper_bounds[i] - result->dim[j].lower_bound + 1; result->dim[j].extent = extent < 0 ? 0 : extent; } else @@ -273,6 +273,7 @@ CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, else { result->dim[j].sm = source->dim[i].sm * strides[i]; + result->dim[j].extent /= strides[i]; } j++; --- /dev/null 2013-04-26 08:22:44.909104543 +0200 +++ gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_2.f90 2013-04-25 19:36:51.194328662 +0200 @@ -0,0 +1,158 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check whether the type files are properly set +! +subroutine test + use iso_c_binding + implicit none + + interface + subroutine foo(x,i) + type(*) :: x(..) + integer(2), value :: i + end subroutine foo + end interface + +! /* Array-descriptor basic types, see ISO_Fortran_binding.h. */ +! #define GFC_TYPE_INTEGER 1 +! #define GFC_TYPE_LOGICAL 2 +! #define GFC_TYPE_REAL 3 +! #define GFC_TYPE_COMPLEX 4 +! #define GFC_TYPE_CHARACTER 5 +! #define GFC_TYPE_STRUCT 6 +! #define GFC_TYPE_CPTR 7 +! #define GFC_TYPE_CFUNPTR 8 +! #define GFC_TYPE_OTHER -1 + + integer(2), parameter :: CFI_Int = 1 + integer(2), parameter :: CFI_Log = 2 + integer(2), parameter :: CFI_Real = 3 + integer(2), parameter :: CFI_Cmplx = 4 + integer(2), parameter :: CFI_Char = 5 + integer(2), parameter :: CFI_Struct = 6 + integer(2), parameter :: CFI_cptr = 7 + integer(2), parameter :: CFI_funcptr = 8 + integer(2), parameter :: CFI_other = -1 + + + integer(1), allocatable :: x_int1(:) + integer(2), allocatable :: x_int2(:) + integer(4), allocatable :: x_int4(:) + integer(8), allocatable :: x_int8(:) + + logical(1), allocatable :: x_log1(:) + logical(2), allocatable :: x_log2(:) + logical(4), allocatable :: x_log4(:) + logical(8), allocatable :: x_log8(:) + + real(4), allocatable :: x_real4(:) + real(8), allocatable :: x_real8(:) + + complex(4), allocatable :: x_cmplx4(:) + complex(8), allocatable :: x_cmplx8(:) + + character(kind=1,len=1), allocatable :: x_str1a(:) + character(kind=1,len=:), allocatable :: x_str1b(:) + character(kind=4,len=1), allocatable :: x_str4a(:) + character(kind=4,len=:), allocatable :: x_str4b(:) + + type(c_ptr), allocatable :: x_cptr(:) + type(c_funptr), allocatable :: x_funcptr(:) + + + type t_seq + sequence + integer :: iii + end type t_seq + + type, bind(C) :: t_bindc + integer(c_int) :: iii + end type t_bindc + + type :: t_ext + integer :: iii + end type t_ext + + type(t_seq), allocatable :: x_seq(:) + type(t_bindc), allocatable :: x_bindc(:) + type(t_ext), allocatable :: x_ext(:) + class(t_ext), allocatable :: x_class(:) + + call foo(x_int1, CFI_Int + ishft (int(kind(x_int1),kind=2),8)) + call foo(x_int2, CFI_Int + ishft (int(kind(x_int2),kind=2),8)) + call foo(x_int4, CFI_Int + ishft (int(kind(x_int4),kind=2),8)) + call foo(x_int8, CFI_Int + ishft (int(kind(x_int8),kind=2),8)) + + call foo(x_log1, CFI_Log + ishft (int(kind(x_log1),kind=2),8)) + call foo(x_log2, CFI_Log + ishft (int(kind(x_log2),kind=2),8)) + call foo(x_log4, CFI_Log + ishft (int(kind(x_log4),kind=2),8)) + call foo(x_log8, CFI_Log + ishft (int(kind(x_log8),kind=2),8)) + + call foo(x_real4, CFI_Real + ishft (int(kind(x_real4),kind=2),8)) + call foo(x_real8, CFI_Real + ishft (int(kind(x_real8),kind=2),8)) + + call foo(x_cmplx4, CFI_cmplx + ishft (int(kind(x_cmplx4),kind=2),8)) + call foo(x_cmplx8, CFI_cmplx + ishft (int(kind(x_cmplx8),kind=2),8)) + + call foo(x_str1a, CFI_char + ishft (int(kind(x_str1a),kind=2),8)) + call foo(x_str1b, CFI_char + ishft (int(kind(x_str1a),kind=2),8)) + call foo(x_str4a, CFI_char + ishft (int(kind(x_str4a),kind=2),8)) + call foo(x_str4b, CFI_char + ishft (int(kind(x_str4a),kind=2),8)) + + call foo(x_cptr, CFI_cptr) + call foo(x_funcptr, CFI_funcptr) + + call foo(x_seq, CFI_struct) + call foo(x_bindc, CFI_struct) + call foo(x_ext, CFI_other) + call foo(x_class, CFI_other) +end subroutine test + +! { dg-final { scan-tree-dump-times "x_cmplx4.type = 1028;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_cmplx8.type = 2052;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_int1.type = 257;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_int2.type = 513;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_int4.type = 1025;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_int8.type = 2049;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_log1.type = 258;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_log2.type = 514;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_log4.type = 1026;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_log8.type = 2050;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_real4.type = 1027;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_real8.type = 2051;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_str1a.type = 261;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_str1b.type = 261;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_str4a.type = 1029;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_str4b.type = 1029;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_cptr.type = 2049;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_funcptr.type = 2049;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_seq.type = 6;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_bindc.type = 6;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_ext.type = -1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "x_class._data.type = -1;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "foo \\(&x_int1, 257\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_int2, 513\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_int4, 1025\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_int8, 2049\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_log1, 258\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_log2, 514\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_log4, 1026\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_log8, 2050\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_real4, 1027\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_real8, 2051\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_cmplx4, 1028\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_cmplx8, 2052\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_str1a, 261, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_str1b, 261, .x_str1b\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_str4a, 1029, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_str4b, 1029, .x_str4b\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_cptr, 7\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_funcptr, 8\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_seq, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_bindc, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_ext, -1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&x_class._data, -1\\);" 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } --- /dev/null 2013-04-26 08:22:44.909104543 +0200 +++ gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_3.f90 2013-04-26 16:54:02.750866417 +0200 @@ -0,0 +1,71 @@ +! { dg-do run } +! { dg-additional-sources iso-ts-29113_3_c.c } +! { dg-options "" } +! +! dg-options is required to silence -pedantic warnings for +! the C code. +! +! Test whether accessing the array from C works using +! TS29113's ISO_Fortran_binding.h +! +! The C examples are based on TS29113's. +! +module m + use iso_c_binding + implicit none + + interface + subroutine test_establish1() bind(C) + end subroutine test_establish1 + subroutine test_establish2() bind(C) + end subroutine test_establish2 + subroutine test_section1(x) bind(C) + import + real(c_float) :: x(:) + end subroutine test_section1 + subroutine test_section2(x) bind(C) + import + real(c_float) :: x(:,:) + end subroutine test_section2 + end interface + + real, target :: A(100) + real, target :: B(100, 100) +contains + subroutine check_section1(x) bind(C) + real(c_float), target :: x(:) + + if (size (x) /= size (A(3::5))) call abort () + if (lbound (x,1) /= lbound (A(3::5),1)) call abort () + if (ubound (x,1) /= ubound (A(3::5),1)) call abort () + if (loc (x(1)) /= loc (A(2))) call abort () ! FIXME: Should be A(3::5), lower_bound 0<->1 issue + if (any (x /= A(2::5))) call abort () + end subroutine + subroutine check_section2(x) bind(C) + real(c_float), target :: x(:) + + if (size (x) /= size (B(:,42))) call abort () + if (lbound (x,1) /= lbound (B(:,42),1)) call abort () + if (ubound (x,1) /= ubound (B(:,42),1)) call abort () + if (loc (x(1)) /= loc (B(1,41))) call abort () ! FIXME: Should be B(1,42), lower_bound 0<->1 issue + if (any (x /= B(:,41))) call abort () ! FIXME: Should be B(:,42), lower_bound 0<->1 issue + end subroutine +end module m + +use m +implicit none +integer :: i,j + +call test_establish1 () +call test_establish2 () + +A = [(i+100, i=0,99)] +call test_section1 (A) + +do j = 1, 100 + do i = 1, 100 + B(i,j) = -i - 1000*j + end do +end do +call test_section2 (B) +end --- /dev/null 2013-04-26 08:22:44.909104543 +0200 +++ gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_3_c.c 2013-04-26 16:53:23.333562851 +0200 @@ -0,0 +1,206 @@ +/* To be complied together with iso-ts-29113_2.f90. + + Test whether accessing the array from C works using + TS29113's ISO_Fortran_binding.h + + The examples are based on TS29113's. */ + +#include +#include +#include + + +void check_section1 (CFI_cdesc_t *); +void check_section2 (CFI_cdesc_t *); + + +void +test_establish1 (void) +{ + int ind; + + /* For establish */ + CFI_rank_t rank; + CFI_CDESC_T(1) field; + + /* For allocate */ + CFI_index_t lower[1], upper[1]; + size_t dummy = 0; + + rank = 1; + ind = CFI_establish ((CFI_cdesc_t *) &field, NULL, CFI_attribute_allocatable, + CFI_type_double, 0, rank, NULL); + + if (ind != CFI_SUCCESS) abort (); + if (field.base_addr != NULL) abort (); + if (field.rank != 1) abort(); + if (field.version != CFI_VERSION) abort (); + if (field.type != CFI_type_double) abort (); + if (field.attribute != CFI_attribute_allocatable) abort (); + + lower[0] = -1; + upper[0] = 100; + ind = CFI_allocate ((CFI_cdesc_t *) &field, lower, upper, dummy); + if (ind != CFI_SUCCESS) abort (); + if (field.elem_len != sizeof (double)) abort (); + if (field.dim[0].lower_bound != -1) abort (); + if (field.dim[0].extent != 100-(-1)+1) abort (); + if (field.dim[0].sm != 1*field.elem_len) abort (); + + ind = CFI_allocate ((CFI_cdesc_t *) &field, lower, upper, dummy); + if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) abort (); + + ind = CFI_deallocate ((CFI_cdesc_t *) &field); + if (ind != CFI_SUCCESS) abort (); +} + + +void +test_establish2 (void) +{ + int ind; + + /* For establish */ + typedef struct {double x; double _Complex y;} t; + t a_c[100]; + CFI_CDESC_T(1) a_fortran; + CFI_index_t extent[1]; + + /* For allocate */ + CFI_index_t lower[2], upper[2]; + size_t dummy = 0; + + extent[0] = 100; + ind = CFI_establish((CFI_cdesc_t *) &a_fortran, a_c, CFI_attribute_other, + CFI_type_struct, sizeof(t), 1, extent); + + if (ind != CFI_SUCCESS) abort (); + if (a_fortran.base_addr != a_c) abort (); + if (a_fortran.rank != 1) abort(); + if (a_fortran.version != CFI_VERSION) abort (); + if (a_fortran.type != CFI_type_struct) abort (); + if (a_fortran.elem_len != sizeof(t)) abort (); + if (a_fortran.attribute != CFI_attribute_other) abort (); + if (a_fortran.dim[0].lower_bound != 0) abort (); + if (a_fortran.dim[0].extent != 100) abort (); + if (a_fortran.dim[0].sm != a_fortran.elem_len) abort (); + + lower[0] = -1; + upper[0] = 100; + ind = CFI_allocate ((CFI_cdesc_t *) &a_fortran, lower, upper, dummy); + if (ind != CFI_INVALID_ATTRIBUTE) abort (); + + if (a_fortran.base_addr != a_c) abort (); + if (a_fortran.rank != 1) abort(); + if (a_fortran.version != CFI_VERSION) abort (); + if (a_fortran.type != CFI_type_struct) abort (); + if (a_fortran.elem_len != sizeof(t)) abort (); + if (a_fortran.attribute != CFI_attribute_other) abort (); + if (a_fortran.dim[0].lower_bound != 0) abort (); + if (a_fortran.dim[0].extent != 100) abort (); + if (a_fortran.dim[0].sm != a_fortran.elem_len) abort (); +} + + +void +test_section1 (CFI_cdesc_t *source) +{ + int ind; + + CFI_index_t lower_bounds[] = {2}, strides[] = {5}; + CFI_CDESC_T(1) section; + + CFI_rank_t rank = 1; + ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, + CFI_attribute_other, CFI_type_float, 0, rank, NULL); + if (ind != CFI_SUCCESS) abort (); + if (section.base_addr != NULL) abort (); + if (section.rank != 1) abort(); + if (section.version != CFI_VERSION) abort (); + if (section.type != CFI_type_float) abort (); + if (section.attribute != CFI_attribute_other) abort (); + + if (source->base_addr == NULL) abort (); + if (source->rank != 1) abort(); + if (source->version != CFI_VERSION) abort (); + if (source->type != CFI_type_float) abort (); + if (source->attribute != CFI_attribute_other) abort (); + if (source->elem_len != sizeof(float)) abort (); + /* FIXME: lower_bound should be 0. */ + if (source->dim[0].lower_bound != 1) abort (); + if (source->dim[0].extent != 100) abort (); + if (source->dim[0].sm != source->elem_len) abort (); + + for (ind = 0; ind < 100; ind++) + if (((float *)source->base_addr)[ind] != 100 + ind) abort(); + + ind = CFI_section ((CFI_cdesc_t *) §ion, source, lower_bounds, + NULL, strides); + if (ind != CFI_SUCCESS) abort (); + /* FIXME: Off by one due to 0<->1 lower_bound issue. */ + if (section.base_addr != source->base_addr+1*source->dim[0].sm) abort (); + if (section.dim[0].lower_bound != 2) abort (); /* FIXME: Is this correct? */ + if (section.dim[0].extent != 20) abort (); + if (section.dim[0].sm != source->elem_len*5) abort (); + if (section.rank != 1) abort(); + if (section.version != CFI_VERSION) abort (); + if (section.type != CFI_type_float) abort (); + if (section.attribute != CFI_attribute_other) abort (); + if (section.elem_len != sizeof(float)) abort (); + + check_section1 ((CFI_cdesc_t *) §ion); +} + + +void +test_section2 (CFI_cdesc_t *source) +{ + int ind; + CFI_index_t lower_bounds[] = {source->dim[0].lower_bound, 41}, + upper_bounds[] = {source->dim[0].lower_bound+source->dim[0].extent-1, 41}, + strides[] = {1, 0}; + CFI_CDESC_T(1) section; + + + CFI_rank_t rank = 1 ; + ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, + CFI_attribute_other, CFI_type_float, 0, rank, NULL); + + if (ind != CFI_SUCCESS) abort (); + if (section.base_addr != NULL) abort (); + if (section.rank != 1) abort(); + if (section.version != CFI_VERSION) abort (); + if (section.type != CFI_type_float) abort (); + if (section.attribute != CFI_attribute_other) abort (); + + if (source->base_addr == NULL) abort (); + if (source->rank != 2) abort(); + if (source->version != CFI_VERSION) abort (); + if (source->type != CFI_type_float) abort (); + if (source->attribute != CFI_attribute_other) abort (); + if (source->elem_len != sizeof(float)) abort (); + /* FIXME: Off by one due to 0<->1 lower_bound issue. */ + if (source->dim[0].lower_bound != 1) abort (); + if (source->dim[1].lower_bound != 1) abort (); + if (source->dim[0].extent != 100) abort (); + if (source->dim[1].extent != 100) abort (); + if (source->dim[0].sm != source->elem_len) abort (); + if (source->dim[1].sm != 100*source->elem_len) abort (); + + ind = CFI_section ((CFI_cdesc_t *) §ion, source, + lower_bounds, upper_bounds, strides ); + if (ind != CFI_SUCCESS) abort (); + /* FIXME: Off by one due to 0<->1 lower_bound issue. */ + if (section.dim[0].lower_bound != 1) abort (); + if (section.dim[0].extent != 100) abort (); + if (section.dim[0].sm != source->elem_len) abort (); + /* FIXME: Off by one due to 0<->1 lower_bound issue. */ + if (section.base_addr != source->base_addr+40*100*source->dim[0].sm) abort (); + if (section.rank != 1) abort(); + if (section.version != CFI_VERSION) abort (); + if (section.type != CFI_type_float) abort (); + if (section.attribute != CFI_attribute_other) abort (); + if (section.elem_len != sizeof(float)) abort (); + + check_section2 ((CFI_cdesc_t *) §ion); +}