diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c477e96d5bd..d96ce8ec63a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,46 @@ +2018-25-01 Paul Thomas + + PR fortran/37577 + * array.c (gfc_match_array_ref): If standard earlier than F2008 + it is an error if the reference dimension is greater than 7. + libgfortran.h : Increase GFC_MAX_DIMENSIONS to 15. Change the + dtype masks and shifts accordingly. + * trans-array.c (gfc_conv_descriptor_dtype): Use the dtype + type node to check the field. + (gfc_conv_descriptor_dtype): Access the rank field of dtype. + (duplicate_allocatable_coarray): Access the rank field of the + dtype descriptor rather than the dtype itself. + * trans-expr.c (get_scalar_to_descriptor_type): Store the type + of 'scalar' on entry and use its TREE_TYPE if it is ARRAY_TYPE + (ie. a character). + (gfc_conv_procedure_call): Pass TREE_OPERAND (tmp,0) to + get_scalar_to_descriptor_type if the actual expression is a + constant. + (gfc_trans_structure_assign): Assign the rank directly to the + dtype rank field. + * trans-intrinsic.c (gfc_conv_intrinsic_rank): Cast the result + to default integer kind. + (gfc_conv_intrinsic_sizeof): Obtain the element size from the + 'elem_len' field of the dtype. + * trans-io.c (gfc_build_io_library_fndecls): Replace + gfc_int4_type_node with dtype_type_node where necessary. + (transfer_namelist_element): Use gfc_get_dtype_rank_type for + scalars. + * trans-types.c : Provide 'get_dtype_type_node' to acces the + dtype_type_node and, if necessary, build it. + The maximum size of an array element is now determined by the + maximum value of size_t. + Update the description of the array descriptor, including the + type def for the dtype_type. + (gfc_get_dtype_rank_type): Build a constructor for the dtype. + Distinguish RECORD_TYPEs that are BT_DERIVED or BT_CLASS. + (gfc_get_array_descriptor_base): Change the type of the dtype + field to dtype_type_node. + (gfc_get_array_descr_info): Get the offset to the rank field of + the dtype. + * trans-types.h : Add a prototype for 'get_dtype_type_node ()'. + * trans.h : Define the indices of the dtype fields. + 2018-23-01 Paul Thomas PR fortran/83866 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 93deb0d932b..caa0b7fe656 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -197,6 +197,11 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, } } + if (ar->dimen >= 7 + && !gfc_notify_std (GFC_STD_F2008, + "Array reference at %C has more than 7 dimensions")) + return MATCH_ERROR; + gfc_error ("Array reference at %C cannot have more than %d dimensions", GFC_MAX_DIMENSIONS); return MATCH_ERROR; diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 27946355cdd..b7954a9dcd9 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -150,15 +150,13 @@ typedef enum #define GFC_STDOUT_UNIT_NUMBER 6 #define GFC_STDERR_UNIT_NUMBER 0 +/* F2003 onward. For std < F2003, error caught in array.c(gfc_match_array_ref). */ +#define GFC_MAX_DIMENSIONS 15 -/* FIXME: Increase to 15 for Fortran 2008. Also needs changes to - GFC_DTYPE_RANK_MASK. See PR 36825. */ -#define GFC_MAX_DIMENSIONS 7 - -#define GFC_DTYPE_RANK_MASK 0x07 -#define GFC_DTYPE_TYPE_SHIFT 3 -#define GFC_DTYPE_TYPE_MASK 0x38 -#define GFC_DTYPE_SIZE_SHIFT 6 +#define GFC_DTYPE_RANK_MASK 0x0F +#define GFC_DTYPE_TYPE_SHIFT 4 +#define GFC_DTYPE_TYPE_MASK 0x70 +#define GFC_DTYPE_SIZE_SHIFT 7 /* Basic types. BT_VOID is used by ISO C Binding so funcs like c_f_pointer can take any arg with the pointer attribute as a param. These are also diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0cf1831802b..c16b8754fa3 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -239,7 +239,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_TYPE (field) == get_dtype_type_node ()); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); @@ -283,10 +284,11 @@ gfc_conv_descriptor_rank (tree desc) tree dtype; dtype = gfc_conv_descriptor_dtype (desc); - tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), - dtype, tmp); - return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); + gcc_assert (tmp!= NULL_TREE + && TREE_TYPE (tmp) == signed_char_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); } @@ -8205,7 +8207,7 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, else { /* Set the rank or unitialized memory access may be reported. */ - tmp = gfc_conv_descriptor_dtype (dest); + tmp = gfc_conv_descriptor_rank (dest); gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank)); if (rank) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e90036f4306..f03aa18274d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -66,9 +66,10 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) tree gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) { - tree desc, type; + tree desc, type, etype; type = get_scalar_to_descriptor_type (scalar, attr); + etype = TREE_TYPE (scalar); desc = gfc_create_var (type, "desc"); DECL_ARTIFICIAL (desc) = 1; @@ -81,8 +82,10 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) } if (!POINTER_TYPE_P (TREE_TYPE (scalar))) scalar = gfc_build_addr_expr (NULL_TREE, scalar); + else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE) + etype = TREE_TYPE (etype); gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (type)); + gfc_get_dtype_rank_type (0, etype)); gfc_conv_descriptor_data_set (&se->pre, desc, scalar); /* Copy pointer address back - but only if it could have changed and @@ -5323,7 +5326,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = parmse.expr; if (TREE_CODE (tmp) == ADDR_EXPR - && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0)))) + && (POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))) + || e->expr_type == EXPR_CONSTANT)) tmp = TREE_OPERAND (tmp, 0); parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp, fsym->attr); @@ -7611,8 +7615,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) rank = 1; size = integer_zero_node; desc = field; - gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), - build_int_cst (gfc_array_index_type, rank)); + gfc_add_modify (&block, gfc_conv_descriptor_rank (desc), + build_int_cst (signed_char_type_node, rank)); } else { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index f4defb079b4..af647c42668 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2602,6 +2602,8 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) 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), + se->expr); } @@ -6783,6 +6785,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) tree lower; tree upper; tree byte_size; + tree field; int n; gfc_init_se (&argse, NULL); @@ -6805,10 +6808,13 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp; if (POINTER_TYPE_P (TREE_TYPE (tmp))) tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp)); - tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp, - build_int_cst (TREE_TYPE (tmp), - GFC_DTYPE_SIZE_SHIFT)); + + tmp = gfc_conv_descriptor_dtype (tmp); + field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()), + GFC_DTYPE_ELEM_LEN); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); + byte_size = fold_convert (gfc_array_index_type, tmp); } else if (arg->ts.type == BT_CLASS) diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 082b9f7a52f..021c788ba54 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -478,12 +478,12 @@ gfc_build_io_library_fndecls (void) iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("st_set_nml_var")), ".w.R", void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node); + gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node()); iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R", void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node, + gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(), pvoid_type_node, pvoid_type_node); iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( @@ -1662,7 +1662,6 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, tree dtio_proc = null_pointer_node; tree vtable = null_pointer_node; int n_dim; - int itype; int rank = 0; gcc_assert (sym || c); @@ -1699,8 +1698,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, } else { - itype = ts->type; - dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT); + dt = gfc_typenode_for_spec (ts); + dtype = gfc_get_dtype_rank_type (0, dt); } /* Build up the arguments for the transfer call. diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index abcbf957e5d..fd25ce57c7f 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -130,6 +130,47 @@ int gfc_size_kind; int gfc_numeric_storage_size; int gfc_character_storage_size; +tree dtype_type_node = NULL_TREE; + + +/* Build the dtype_type_node if necessary. */ +tree get_dtype_type_node (void) +{ + tree field; + tree dtype_node; + tree *dtype_chain = NULL; + + if (dtype_type_node == NULL_TREE) + { + dtype_node = make_node (RECORD_TYPE); + TYPE_NAME (dtype_node) = get_identifier ("dtype_type"); + TYPE_NAMELESS (dtype_node) = 1; + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("elem_len"), + size_type_node, &dtype_chain); + TREE_NO_WARNING (field) = 1; + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("version"), + integer_type_node, &dtype_chain); + TREE_NO_WARNING (field) = 1; + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("rank"), + signed_char_type_node, &dtype_chain); + TREE_NO_WARNING (field) = 1; + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("type"), + signed_char_type_node, &dtype_chain); + TREE_NO_WARNING (field) = 1; + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("attribute"), + short_integer_type_node, &dtype_chain); + TREE_NO_WARNING (field) = 1; + gfc_finish_type (dtype_node); + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1; + dtype_type_node = dtype_node; + } + return dtype_type_node; +} bool gfc_check_any_c_kind (gfc_typespec *ts) @@ -1003,7 +1044,7 @@ gfc_init_types (void) 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; + n = TYPE_PRECISION (size_type_node); gfc_max_array_element_size = wide_int_to_tree (size_type_node, wi::mask (n, UNSIGNED, @@ -1255,12 +1296,21 @@ gfc_get_element_type (tree type) struct gfc_array_descriptor { - array *data + array *data; index offset; - index dtype; + struct dtype_type dtype; struct descriptor_dimension dimension[N_DIM]; } + struct dtype_type + { + size_t elem_len; + int version; + signed char rank; + signed char type; + signed short attribute; + } + struct descriptor_dimension { index stride; @@ -1277,11 +1327,6 @@ 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: - rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits - type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits - size = dtype >> GFC_DTYPE_SIZE_SHIFT - I originally used nested ARRAY_TYPE nodes to represent arrays, but this generated poor code for assumed/deferred size arrays. These require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part @@ -1468,9 +1513,10 @@ gfc_get_dtype_rank_type (int rank, tree etype) { tree size; int n; - HOST_WIDE_INT i; tree tmp; tree dtype; + tree field; + vec *v = NULL; switch (TREE_CODE (etype)) { @@ -1490,18 +1536,21 @@ gfc_get_dtype_rank_type (int rank, tree etype) n = BT_COMPLEX; break; - /* We will never have arrays of arrays. */ case RECORD_TYPE: - n = BT_DERIVED; + if (GFC_CLASS_TYPE_P (etype)) + n = BT_CLASS; + else + n = BT_DERIVED; break; + /* We will never have arrays of arrays. */ case ARRAY_TYPE: n = BT_CHARACTER; break; case POINTER_TYPE: n = BT_ASSUMED; - break; + break; default: /* TODO: Don't do dtype for temporary descriptorless arrays. */ @@ -1509,32 +1558,27 @@ gfc_get_dtype_rank_type (int rank, tree etype) return gfc_index_zero_node; } - gcc_assert (rank <= GFC_DTYPE_RANK_MASK); size = TYPE_SIZE_UNIT (etype); + if (n == BT_CHARACTER && size == NULL_TREE) + size = TYPE_SIZE_UNIT (TREE_TYPE (etype)); - i = rank | (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"); + tmp = get_dtype_type_node (); + field = gfc_advance_chain (TYPE_FIELDS (tmp), + GFC_DTYPE_ELEM_LEN); + CONSTRUCTOR_APPEND_ELT (v, field, + fold_convert (TREE_TYPE (field), size)); - i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; - } - dtype = build_int_cst (gfc_array_index_type, i); + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_RANK); + CONSTRUCTOR_APPEND_ELT (v, field, + build_int_cst (TREE_TYPE (field), rank)); - 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. */ + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_TYPE); + CONSTRUCTOR_APPEND_ELT (v, field, + build_int_cst (TREE_TYPE (field), n)); + + dtype = build_constructor (tmp, v); return dtype; } @@ -1820,7 +1864,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) /* Add the dtype component. */ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dtype"), - gfc_array_index_type, &chain); + get_dtype_type_node (), &chain); TREE_NO_WARNING (decl) = 1; /* Add the span component. */ @@ -3232,6 +3276,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) tree etype, ptype, t, base_decl; tree data_off, dim_off, dtype_off, dim_size, elem_size; tree lower_suboff, upper_suboff, stride_suboff; + tree dtype, field, rank_off; if (! GFC_DESCRIPTOR_TYPE_P (type)) { @@ -3313,11 +3358,15 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) t = base_decl; if (!integer_zerop (dtype_off)) t = fold_build_pointer_plus (t, dtype_off); + dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ()); + field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK); + rank_off = byte_position (field); + if (!integer_zerop (dtype_off)) + t = fold_build_pointer_plus (t, rank_off); + t = build1 (NOP_EXPR, build_pointer_type (gfc_array_index_type), t); t = build1 (INDIRECT_REF, gfc_array_index_type, t); - info->rank = build2 (BIT_AND_EXPR, gfc_array_index_type, t, - build_int_cst (gfc_array_index_type, - GFC_DTYPE_RANK_MASK)); + info->rank = t; t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off)); t = size_binop (MULT_EXPR, t, dim_size); dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off); diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 99798ab617c..197b173f041 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -73,6 +73,7 @@ void gfc_init_kinds (void); void gfc_init_types (void); void gfc_init_c_interop_kinds (void); +tree get_dtype_type_node (void); tree gfc_get_int_type (int); tree gfc_get_real_type (int); tree gfc_get_complex_type (int); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 31b0930350d..35e1bd28379 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -914,6 +914,12 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit; /* gfortran-specific declaration information, the _CONT versions denote arrays with CONTIGUOUS attribute. */ +#define GFC_DTYPE_ELEM_LEN 0 +#define GFC_DTYPE_VERSION 1 +#define GFC_DTYPE_RANK 2 +#define GFC_DTYPE_TYPE 3 +#define GFC_DTYPE_ATTRIBUTE 4 + enum gfc_array_kind { GFC_ARRAY_UNKNOWN, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1a62d91ab5e..ff91f1e6701 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2018-25-01 Paul Thomas + + PR fortran/37577 + * gfortran.dg/coarray_18.f90: Allow dimension 15 for F2008. + * gfortran.dg/coarray_lib_this_image_2.f90: Change 'array1' to + 'array01' in the tree dump comparison. + * gfortran.dg/coarray_lib_token_4.f90: Likewise. + * gfortran.dg/inline_sum_1.f90: Similar - allow two digits. + * gfortran.dg/rank_1.f90: Allow dimension 15 for F2008. + 2018-01-25 Jan Hubicka PR middle-end/83055 diff --git a/gcc/testsuite/gfortran.dg/coarray_18.f90 b/gcc/testsuite/gfortran.dg/coarray_18.f90 index 474e9391edb..1e80df986e8 100644 --- a/gcc/testsuite/gfortran.dg/coarray_18.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_18.f90 @@ -5,8 +5,7 @@ ! dimensions (normal + codimensions). ! ! Fortran 2008 allows (co)arrays with 15 ranks -! Currently, gfortran only supports 7, cf. PR 37577 -! Thus, the program is valid Fortran 2008 ... +! Previously gfortran only supported 7, cf. PR 37577 ! ! See also general coarray PR 18918 ! @@ -19,14 +18,20 @@ program ar integer :: ic(2)[*] integer :: id(2,2)[2,*] integer :: ie(2,2,2)[2,2,*] - integer :: ig(2,2,2,2)[2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: ih(2,2,2,2,2)[2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: ij(2,2,2,2,2,2)[2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: ik(2,2,2,2,2,2,2)[2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: il[2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: im[2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: in[2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } - integer :: io[2,2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" } +! Previously, these would give errors. + integer :: ig(2,2,2,2)[2,2,2,*] + integer :: ih(2,2,2,2,2)[2,2,2,2,*] + integer :: ij(2,2,2,2,2,2)[2,2,2,2,2,*] + integer :: ik(2,2,2,2,2,2,2)[2,2,2,2,2,2,*] + integer :: il[2,2,2,2,2,2,2,*] + integer :: im[2,2,2,2,2,2,2,2,*] + integer :: in[2,2,2,2,2,2,2,2,2,*] + integer :: io[2,2,2,2,2,2,2,2,2,2,*] +! Now with max dimensions 15..... + integer :: ip(2,2,2,2,2,2,2,2)[2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" } + integer :: iq[2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" } +! Check a non-coarray + integer :: ir(2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2) ! { dg-error "has more than 15 dimensions" } real :: x2(2,2,4)[2,*] complex :: c2(4,2)[2,*] double precision :: d2(1,5,9)[2,*] diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 index 196a2d3b93e..7b44c73211b 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 @@ -16,7 +16,7 @@ contains end subroutine bar end -! { dg-final { scan-tree-dump-times "bar \\(struct array1_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct array01_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } ! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 index 8183140bd93..b09552a7f03 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 @@ -35,9 +35,9 @@ end program test_caf ! { dg-final { scan-tree-dump-times "expl \\(integer\\(kind=4\\).0:. . restrict z, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } ! -! { dg-final { scan-tree-dump-times "bar \\(struct array1_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct array01_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } ! -! { dg-final { scan-tree-dump-times "foo \\(struct array1_integer\\(kind=4\\) & restrict x, struct array1_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(struct array01_integer\\(kind=4\\) & restrict x, struct array01_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } } ! diff --git a/gcc/testsuite/gfortran.dg/inline_sum_1.f90 b/gcc/testsuite/gfortran.dg/inline_sum_1.f90 index a9d4f7baa78..bff01bcbf31 100644 --- a/gcc/testsuite/gfortran.dg/inline_sum_1.f90 +++ b/gcc/testsuite/gfortran.dg/inline_sum_1.f90 @@ -188,6 +188,6 @@ contains o = i end subroutine tes end -! { dg-final { scan-tree-dump-times "struct array._integer\\(kind=4\\) atmp" 13 "original" } } +! { dg-final { scan-tree-dump-times "struct array.._integer\\(kind=4\\) atmp" 13 "original" } } ! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 13 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_sum_" 0 "original" } } diff --git a/gcc/testsuite/gfortran.dg/rank_1.f90 b/gcc/testsuite/gfortran.dg/rank_1.f90 index 6a81e410bd5..3467faded2b 100644 --- a/gcc/testsuite/gfortran.dg/rank_1.f90 +++ b/gcc/testsuite/gfortran.dg/rank_1.f90 @@ -4,7 +4,6 @@ ! Fortran < 2008 allows 7 dimensions ! Fortran 2008 allows 15 dimensions (including co-array ranks) ! -! FIXME: Rank patch was reverted because of PR 36825. -integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) ! { dg-error "has more than 7 dimensions" } -integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 7 dimensions" } +integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) +integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 15 dimensions" } end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 55b087f22ee..bd12b5d12bf 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,20 @@ +2018-25-01 Paul Thomas + + PR fortran/37577 + * caf/single.c (_gfortran_caf_failed_images): Access the 'type' + and 'elem_len' fields of the dtype instead of the shifts. + (_gfortran_caf_stopped_images): Likewise. + * intrinsics/associated.c (associated): Compare the 'type' and + 'elem_len' fields instead of the dtype. + * caf/date_and_time.c : Access the dtype fields rather using + shifts and masks. + * io/transfer.c (transfer_array ): Comment on item count. + (set_nml_var,st_set_nml_var): Change dtype type and use fields. + (st_set_nml_dtio_var): Likewise. + * libgfortran.h : Change definition of GFC_ARRAY_DESCRIPTOR and + add a typedef for the dtype_type. Change the GFC_DTYPE_* macros + to access the dtype fields. + 2018-01-15 Thomas Koenig PR fortran/54613 diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 8911752f168..bead09a386f 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -332,8 +332,8 @@ _gfortran_caf_failed_images (gfc_descriptor_t *array, int local_kind = kind != NULL ? *kind : 4; array->base_addr = NULL; - array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) - | (local_kind << GFC_DTYPE_SIZE_SHIFT)); + array->dtype.type = BT_INTEGER; + array->dtype.elem_len = local_kind; /* Setting lower_bound higher then upper_bound is what the compiler does to indicate an empty array. */ array->dim[0].lower_bound = 0; @@ -354,8 +354,8 @@ _gfortran_caf_stopped_images (gfc_descriptor_t *array, int local_kind = kind != NULL ? *kind : 4; array->base_addr = NULL; - array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) - | (local_kind << GFC_DTYPE_SIZE_SHIFT)); + array->dtype.type = BT_INTEGER; + array->dtype.elem_len = local_kind; /* Setting lower_bound higher then upper_bound is what the compiler does to indicate an empty array. */ array->dim[0].lower_bound = 0; diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c index 290781889d0..08a7412ba97 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -37,7 +37,9 @@ 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_DTYPE (pointer).elem_len != GFC_DESCRIPTOR_DTYPE (target).elem_len) + return 0; + if (GFC_DESCRIPTOR_DTYPE (pointer).type != GFC_DESCRIPTOR_DTYPE (target).type) return 0; rank = GFC_DESCRIPTOR_RANK (pointer); diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c index 7e288ef7c5e..a493b448b6a 100644 --- a/libgfortran/intrinsics/date_and_time.c +++ b/libgfortran/intrinsics/date_and_time.c @@ -270,10 +270,9 @@ 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_DTYPE (avalues).type = BT_REAL; + GFC_DESCRIPTOR_DTYPE (avalues).elem_len = 4; + GFC_DESCRIPTOR_DTYPE (avalues).rank = 1; GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1); date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0); diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 7e076de84fa..8bc828c0214 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2406,6 +2406,8 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, char *data; bt iotype; + /* Adjust item_count before emitting error message. */ + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; @@ -2413,6 +2415,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc); rank = GFC_DESCRIPTOR_RANK (desc); + for (n = 0; n < rank; n++) { count[n] = 0; @@ -4208,7 +4211,7 @@ st_wait (st_parameter_wait *wtp __attribute__((unused))) static void set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name, GFC_INTEGER_4 len, gfc_charlen_type string_length, - GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable) + dtype_type dtype, void *dtio_sub, void *vtable) { namelist_info *t1 = NULL; namelist_info *nml; @@ -4227,9 +4230,9 @@ set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name, nml->len = (int) len; nml->string_length = (index_type) string_length; - nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK); - nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT); - nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT); + nml->var_rank = (int) (dtype.rank); + nml->size = (index_type) (dtype.elem_len); + nml->type = (bt) (dtype.type); if (nml->var_rank > 0) { @@ -4259,13 +4262,13 @@ set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name, } extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, - GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4); + GFC_INTEGER_4, gfc_charlen_type, dtype_type); 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, gfc_charlen_type string_length, - GFC_INTEGER_4 dtype) + dtype_type dtype) { set_nml_var (dtp, var_addr, var_name, len, string_length, dtype, NULL, NULL); @@ -4275,7 +4278,7 @@ st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name, /* Essentially the same as previous but carrying the dtio procedure and the vtable as additional arguments. */ extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *, - GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4, + GFC_INTEGER_4, gfc_charlen_type, dtype_type, void *, void *); export_proto(st_set_nml_dtio_var); @@ -4283,7 +4286,7 @@ export_proto(st_set_nml_dtio_var); void st_set_nml_dtio_var (st_parameter_dt *dtp, void *var_addr, char *var_name, GFC_INTEGER_4 len, gfc_charlen_type string_length, - GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable) + dtype_type dtype, void *dtio_sub, void *vtable) { set_nml_var (dtp, var_addr, var_name, len, string_length, dtype, dtio_sub, vtable); diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 4c643b7e17b..80580a91082 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -327,14 +327,23 @@ typedef struct descriptor_dimension index_type lower_bound; index_type _ubound; } - descriptor_dimension; +typedef struct dtype_type +{ + size_t elem_len; + int version; + signed char rank; + signed char type; + signed short attribute; +} +dtype_type; + #define GFC_ARRAY_DESCRIPTOR(r, type) \ struct {\ type *base_addr;\ size_t offset;\ - index_type dtype;\ + dtype_type dtype;\ index_type span;\ descriptor_dimension dim[r];\ } @@ -375,10 +384,9 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; typedef gfc_array_i1 gfc_array_s1; typedef gfc_array_i4 gfc_array_s4; -#define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype & GFC_DTYPE_RANK_MASK) -#define GFC_DESCRIPTOR_TYPE(desc) (((desc)->dtype & GFC_DTYPE_TYPE_MASK) \ - >> GFC_DTYPE_TYPE_SHIFT) -#define GFC_DESCRIPTOR_SIZE(desc) ((desc)->dtype >> GFC_DTYPE_SIZE_SHIFT) +#define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype.rank) +#define GFC_DESCRIPTOR_TYPE(desc) ((desc)->dtype.type) +#define GFC_DESCRIPTOR_SIZE(desc) ((desc)->dtype.elem_len) #define GFC_DESCRIPTOR_DATA(desc) ((desc)->base_addr) #define GFC_DESCRIPTOR_DTYPE(desc) ((desc)->dtype) @@ -411,18 +419,24 @@ typedef gfc_array_i4 gfc_array_s4; #define GFC_DTYPE_SIZE_MASK (-((index_type) 1 << 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)->dtype & GFC_DTYPE_TYPE_SIZE_MASK) +#define GFC_DTYPE_TYPE_SIZE(desc) (( ((desc)->dtype.type << GFC_DTYPE_TYPE_SHIFT) \ + | ((desc)->dtype.elem_len << GFC_DTYPE_SIZE_SHIFT) ) & GFC_DTYPE_TYPE_SIZE_MASK) /* Macros to set size and type information. */ #define GFC_DTYPE_COPY(a,b) do { (a)->dtype = (b)->dtype; } while(0) #define GFC_DTYPE_COPY_SETRANK(a,b,n) \ do { \ - (a)->dtype = (((b)->dtype & ~GFC_DTYPE_RANK_MASK) | n ); \ + (a)->dtype.rank = ((b)->dtype.rank | n ); \ } while (0) -#define GFC_DTYPE_IS_UNSET(a) (unlikely((a)->dtype == 0)) -#define GFC_DTYPE_CLEAR(a) do { (a)->dtype = 0; } while(0) +#define GFC_DTYPE_IS_UNSET(a) (unlikely((a)->dtype.elem_len == 0)) +#define GFC_DTYPE_CLEAR(a) do { (a)->dtype.elem_len = 0; \ + (a)->dtype.version = 0; \ + (a)->dtype.rank = 0; \ + (a)->dtype.type = 0; \ + (a)->dtype.attribute = 0; \ +} while(0) #define GFC_DTYPE_INTEGER_1 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \ | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT))