diff options
Diffstat (limited to 'gcc')
65 files changed, 2561 insertions, 933 deletions
diff --git a/gcc/ChangeLog.fortran-dev b/gcc/ChangeLog.fortran-dev new file mode 100644 index 00000000000..8291ab6da74 --- /dev/null +++ b/gcc/ChangeLog.fortran-dev @@ -0,0 +1,3 @@ +2013-04-01 Tobias Burnus <burnus@net-b.de> + + * dwarf2out.h (array_descr_info): Change dim to 15. diff --git a/gcc/fortran/ChangeLog.fortran-dev b/gcc/fortran/ChangeLog.fortran-dev new file mode 100644 index 00000000000..9109ddfcd87 --- /dev/null +++ b/gcc/fortran/ChangeLog.fortran-dev @@ -0,0 +1,343 @@ +2016-20-10 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_conv_expr_descriptor): Detect class object + with an abstract declared type. Use the type of the data field + and the dynamic element length from the symbol backend_decl. + * trans-decl.c (gfc_trans_deferred_vars): Initialize the + descriptor of allocatable class arrays.. + +2016-09-10 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_alloc_allocatable_for_assignment): Put + calculation of element length before setting of extent and sm + so that the element length field is set, ready for this. + * trans-intrinsic.c (conv_isocbinding_subroutine): Set the elem + len field of the descriptor. + * trans-stmt.c (gfc_conv_intrinsic_size): The one that is + subtracted from arg_2 has to be an integer_type. + +2016-09-07 Paul Thomas <pault@gcc.gnu.org> + + * trans-expr.c (gfc_conv_scalar_to_descriptor): Correct error + in setting 'type'. + (gfc_conv_intrinsic_to_class): Use the expression typespec for + unlimited polymorphic classes. + * trans-intrinsic.c (conv_isocbinding_subroutine): Set the elem + len field of the descriptor. + * trans-stmt.c (trans_associate_var): Build a null descriptor + for the associate name, if the target is unlimited polymorphic, + and copy the dtype, element length and stride measures to the + associate name. + +2016-09-07 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_build_null_descriptor): Set the element + length to zero for deferred types. + (gfc_trans_static_array_pointer): Initialize deferred string + length to zero. + (gfc_array_init_size): Restore chunk for calculating the ubound + of array constructor sources. + * trans-expr.c (gfc_conv_scalar_to_descriptor): If the type is + NULL_TREE, set the element length to zero. + (gfc_trans_pointer_assignment): Copy the element length. + trans-io.c (gfc_build_io_library_fndecls): Update arguments for + namelist transfers. + (transfer_namelist_element): Calculate element length and + update arguments to transfer calls. + +2016-08-30 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_array_init_size): Remove argument 'ts'. + Use the 'expr' typespec instead. + (gfc_array_allocate): Remove the typespec argument in the call + to gfc_array_init_size. + * trans-expr.c (gfc_conv_scalar_to_descriptor): Use the type + of the scalar to get the element size, rather than that of + the descriptor. + (gfc_conv_intrinsic_to_class): Provide the typespec for the + call to gfc_conv_scalar_to_descriptor. + (gfc_conv_component_ref): Whitespace. + (gfc_conv_procedure_call): Provide the typespec as above. + (gfc_conv_structure): Provide rank for call to + gfc_conv_initializer. + (gfc_trans_pointer_assignment): Update the rank field in the + case of rank remap. + * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Provide the + typespec for the calls to gfc_conv_scalar_to_descriptor. Change + call to gfc_get_dtype_rank_type into gfc_get_dtype. Provide + extra arguments for call to gfc_trans_create_temp_array. + (conv_caf_send): As previous and eliminate 'tmp2'. + (gfc_conv_intrinsic_sizeof): Use the elem_len field. + +2014-06-14 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_conv_array_parameter): Assign 'old_desc' + to 'new_desc' rather than some of the components. + +2014-06-03 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_conv_expr_descriptor): Use the type of the + expression for the type of the array. The element length should + be set initially to the descriptor element type so that the + stride measure is calculated correctly. + * trans-stmt.c (gfc_conv_elemental_dependencies): Use the type + of the elements of the descriptor for 'temptype'. Change the + comment accordingly. + +2014-05-22 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c (gfc_conv_descriptor_stride_get, + gfc_conv_descriptor_stride_get): Only use 'elem_len' field for + element size. + * trans-stmt.c (trans_associate_var): Eliminate redundant + declaration of 'desc'. Use 'sm' and 'elem_len' fields directly + to calculate offset. + +2013-06-05 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (gfc_array_init_size): Remove superfluous + "ts" argument due to trunk merging. + (gfc_array_allocate): Pass only one ts. + +2013-05-07 Tobias Burnus <burnus@net-b.de> + + * trans-intrinsic.c (gfc_conv_intrinsic_bound, + gfc_conv_intrinsic_size): Set argse.data_not_needed. + +2013-05-07 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (gfc_conv_descriptor_stride_get, + gfc_conv_descriptor_stride_set): Use elem_len, unless it is + a nonstring intrinsic type for which size_in_bytes is used. + (gfc_array_init_size): Set elem_len before handling the + strides. + * trans-expr.c (gfc_conv_subref_array_arg): Remove no-op + extent shifting code. + +2013-05-06 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (gfc_conv_ss_startstride, set_loop_bounds): Handle + GFC_ISYM_SHAPE in the scalarizer. + (gfc_array_init_size, gfc_conv_expr_descriptor): Ensure that + extent is never negative except for assumed size arrays. + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Optimizations + of the bounds handling. + (gfc_conv_intrinsic_size): Handle SIZE and SHAPE directly without + calling the library. + (gfc_conv_intrinsic_function, gfc_add_intrinsic_ss_code, + gfc_walk_intrinsic_bound, gfc_is_intrinsic_libcall, + gfc_walk_intrinsic_function): Handle SHAPE. + +2013-04-30 Tobias Burnus <burnus@net-b.de> + + * libgfortran.h (GFC_TYPE_MASK, GFC_TYPE_KIND_SHIFT, + GFC_TYPE_INTEGER, GFC_TYPE_LOGICAL, GFC_TYPE_REAL, GFC_TYPE_COMPLEX, + GFC_TYPE_CHARACTER, GFC_TYPE_STRUCT, GFC_TYPE_CPTR, GFC_TYPE_CFUNPTR, + GFC_TYPE_OTHER): New. + (GFC_DTYPE_TYPE_SHIFT, GFC_DTYPE_TYPE_MASK, GFC_DTYPE_SIZE_SHIFT): + Remove. + (bt): Reorder. + * trans-array.c (OFFSET_FIELD, ATTR_FIELD): Change value (swap order). + (gfc_conv_descriptor_rank_set, gfc_conv_descriptor_attr_set, + gfc_build_null_descriptor): Change data type. + (gfc_trans_create_temp_array): Add ts and strlen arguments. + (gfc_trans_array_constructor_subarray, trans_array_constructor, + gfc_alloc_allocatable_for_assignment): Update call. + (gfc_conv_loop_setup, gfc_array_init_size): Ditto; add ts argument. + (gfc_array_allocate, gfc_conv_array_initializer, + gfc_conv_expr_descriptor): Update calls. + (gfc_conv_expr_descriptor): Properly set the elem_len. + (structure_alloc_comps, gfc_trans_deferred_array): Update + get_dtype call. + * trans-array.h (gfc_trans_create_temp_array, gfc_conv_loop_setup, + gfc_build_null_descriptor): Update prototype. + * trans-decl.c (gfc_trans_deferred_vars, gfc_trans_deferred_vars): + Update calls. + * trans-expr.c (gfc_conv_scalar_to_descriptor, + realloc_lhs_loop_for_fcn_call): Take ts argument. + (gfc_conv_class_to_class, gfc_conv_subref_array_arg, + gfc_conv_procedure_call, gfc_conv_procedure_call, + gfc_conv_initializer, gfc_trans_subarray_assign, + gfc_trans_pointer_assignment, gfc_trans_arrayfunc_assign, + gfc_trans_assignment_1): Update calls. + * trans-intrinsic.c (trans_this_image): Change to extent. + (gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count, + gfc_conv_intrinsic_arith, gfc_conv_intrinsic_dot_product, + gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_minmaxval, + gfc_conv_intrinsic_transfer, conv_isocbinding_subroutine): Update + calls. + * trans-io.c (transfer_namelist_element, transfer_array_component, + gfc_trans_transfer): Update calls. + * trans-stmt.c (gfc_conv_elemental_dependencies, gfc_trans_call, + trans_associate_var, generate_loop_for_temp_to_lhs, + generate_loop_for_rhs_to_temp, compute_inner_temp_size, + gfc_trans_pointer_assign_need_temp, gfc_evaluate_where_mask, + gfc_trans_where_assign, gfc_copy_loopinfo_to_se): Ditto. + * trans-types.c (gfc_init_types, gfc_get_dtype): Update dtype + handling. + (gfc_get_array_descriptor_base): Change data types of the + descriptor. + (struct gfc_array_descriptor): Update comment. + * trans-types.h (gfc_get_dtype): Update prototype. + * trans.c (gfc_build_final_call): Update calls. + +2013-04-30 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (gfc_trans_dummy_array_bias, get_std_lbound, + gfc_alloc_allocatable_for_assignment): Change ubound to extent. + * trans-expr.c (gfc_trans_alloc_subarray_assign): Ditto. + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Ditto. + +2013-04-25 Tobias Burnus <burnus@net-b.de> + + * libgfortran.h (GFC_ATTRIBUTE_*): New defines. + * trans-array.c (gfc_conv_descriptor_elem_len, + gfc_conv_descriptor_elem_len_get, + gfc_conv_descriptor_elem_len_set, gfc_conv_descriptor_rank_set, + gfc_conv_descriptor_version_set, gfc_conv_descriptor_attr_set): + New functions. + (gfc_build_null_descriptor, gfc_trans_static_array_pointer, + gfc_trans_create_temp_array, gfc_conv_array_initializer, + gfc_conv_expr_descriptor, structure_alloc_comps): Fill new fields at + decl time/DT-alloc time. + (gfc_conv_descriptor_size_1, get_full_array_size, + gfc_alloc_allocatable_for_assignment): Use extent directly. + * trans-array.h (gfc_conv_descriptor_elem_len_get, + gfc_conv_descriptor_elem_len_set, gfc_conv_descriptor_rank_set, + gfc_conv_descriptor_version_set, gfc_conv_descriptor_attr_set): New + prototype. + * trans-common.c (create_common): Update calls. + * trans-decl.c (gfc_get_symbol_decl, get_proc_pointer_decl, + gfc_trans_deferred_vars, gfc_emit_parameter_debug_info): Ditto. + * trans-expr.c (gfc_conv_scalar_to_descriptor, + class_array_data_assign, gfc_conv_derived_to_class, + gfc_conv_class_to_class, gfc_conv_initializer, + gfc_trans_pointer_assignment, fcncall_realloc_result): Set new fields. + (gfc_conv_structure): Update calls. + (gfc_set_interface_mapping_bounds, + gfc_conv_subref_array_arg): Use extent directly. + * trans-intrinsic.c (size_of_string_in_bytes): Remove static. + * trans-io.c (transfer_namelist_element): Pass elem_size. + * trans-types.c (gfc_get_array_descriptor_base): Add "attribute" field. + * trans.h (size_of_string_in_bytes): New prototype. + (gfc_get_module_backend_decl): Update prototype. + +2013-04-01 Tobias Burnus <burnus@net-b.de> + + * libgfortran.h (GFC_MAX_DIMENSIONS): Change to 15. + (GFC_DTYPE_RANK_MASK): Remove. + * trans-array.c (RANK_FIELD): New define. + (gfc_conv_descriptor_rank): Use rank field. + (gfc_trans_create_temp_array, gfc_array_init_size, + gfc_conv_expr_descriptor, + gfc_alloc_allocatable_for_assignment): Set rank field. + * trans-expr.c (gfc_conv_scalar_to_descriptor, + class_array_data_assign, gfc_conv_derived_to_class, + gfc_conv_class_to_class, gfc_trans_pointer_assignment, + fcncall_realloc_result): Ditto. + * trans-intrinsic.c (conv_isocbinding_subroutine): Ditto. + * trans-io.c (gfc_build_io_library_fndecls, + transfer_namelist_element): Pass rank as extra argument. + * trans-types.c (gfc_get_element_type, gfc_get_dtype): Don't + add the rank to dtype. + (gfc_get_array_descriptor_base): New "rank" field. + +2013-03-31 Tobias Burnus <burnus@net-b.de> + + * trans-intrinsic.c (conv_isocbinding_subroutine): Fix + merge-resolution bug. + +2013-03-31 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (VERSION_FIELD): New define. + (ELEM_LEN_FIELD): Renamed from SIZE_FIELD, reordered the fields. + (gfc_build_null_descriptor): Also set version field (to 1). + * trans-types.c (gfc_get_array_descriptor_base): Rename "size" to + "elem_len" and move up, add "version" field. + +2012-07-20 Tobias Burnus <burnus@net-b.de> + + * trans-expr.c (conv_isocbinding_procedure): For C_F_Pointer, + directly set extent and sm instead of using ubound and stride. + +2012-07-15 Tobias Burnus <burnus@net-b.de> + + * trans-intrinsic.c (gfc_conv_intrinsic_size, + gfc_conv_intrinsic_sizeof): Replace (ubound-lbound+1) calculation + by "extent". + * trans-expr.c (fcncall_realloc_result): Ditto. + * trans-io.c (gfc_convert_array_to_string): Ditto. + * trans-openmp.c (gfc_omp_clause_default_ctor, + gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op, + gfc_trans_omp_array_reduction): Ditto. + * trans-array.c (array_parameter_size): Ditto. + (gfc_grow_array): Ditto - and fix size calculation for realloc. + +2012-07-15 Tobias Burnus <burnus@net-b.de> + + * trans-intrinsic.c (gfc_conv_associated): Compare sm + instead of stride. + +2012-03-12 Tobias Burnus <burnus@net-b.de> + + * trans-types.c (gfc_get_array_descriptor_base): Rename "data" + to "base_addr". + +2012-03-11 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (UBOUND_SUBFIELD, STRIDE_SUBFIELD): Remove. + (LBOUND_SUBFIELD, EXTENT_SUBFIELD, SM_SUBFIELD): Change value. + (gfc_conv_descriptor_stride): Remove. + (gfc_conv_descriptor_stride_set): Only set "sm". + (gfc_conv_descriptor_ubound): Remove. + (gfc_conv_descriptor_ubound_set): Only set "extent" + (gfc_conv_shift_descriptor_lbound): Remove ubound-setting call. + (gfc_conv_array_sm, gfc_conv_array_extent): New functions. + * trans-array.h (gfc_conv_array_sm, gfc_conv_array_extent): New + prototypes. + * trans-types.c (gfc_get_desc_dim_type): Remove stride/ubound, + rename and reorder according to TS29113. + * trans-io.h (transfer_namelist_element): Pass extent/sm instead + of ubound/stride. + +2012-03-10 Tobias Burnus <burnus@net-b.de> + + * trans-array.c (CAF_TOKEN_FIELD): Set to the correct value. + (gfc_conv_descriptor_ubound_get, gfc_conv_descriptor_ubound_set): + Remove bogus byte-size handling, correctly handle lower bounds + which don't start with unity. + (gfc_conv_shift_descriptor_lbound): Reorder to make sure that + lbound comes before ubound. + * trans-expr.c (gfc_conv_subref_array_arg, + gfc_trans_alloc_subarray_assign): Ditto. + +2010-09-01 Paul Thomas <pault@gcc.gnu.org> + + * trans-array.c : Define and subsequently undefine descriptor + SIZE_FIELD, SM_SUBFIELD and EXTENT_SUBFIELD. Change the offset + for DIMENSION_FIELD. + (gfc_data_field_from_base_field): New function. + (gfc_conv_descriptor_data_addr): Call it to maintain API. + (gfc_dimension_field_from_base_field): New function. + (gfc_conv_descriptor_dimension): Call it. + (gfc_conv_descriptor_stride_get): Compute the stride from the + 'sm' field. + (gfc_conv_descriptor_stride_set): Compute and set 'sm' field. + (gfc_conv_descriptor_sm, gfc_conv_descriptor_sm_get, + gfc_conv_descriptor_sm_set): New functions. + (gfc_conv_descriptor_extent, gfc_conv_descriptor_extent_get, + gfc_conv_descriptor_extent_set): New functions. + (gfc_conv_descriptor_ubound_get): Compute the ubound from the + 'extent' field. + (gfc_conv_descriptor_ubound_set): Compute and set 'extent' + field. + trans-array.h: New prototypes for gfc_conv_descriptor_sm_get, + gfc_conv_descriptor_extent_get, gfc_data_field_from_base_field, + gfc_dimension_field_from_base_field,gfc_conv_descriptor_sm_set, + and gfc_conv_descriptor_extent_set. + trans-types.c (gfc_get_desc_dim_type): Add 'sm' and 'extent' + fields. + (gfc_get_array_descriptor_base): Add 'size' field. + (gfc_get_array_descr_info): Call gfc_data_field_from_base_field + and gfc_dimension_field_from_base_field instead of using the + field offsets explicitly. diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index e9132506367..eb6b7860d42 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -148,22 +148,39 @@ typedef enum #define GFC_STDOUT_UNIT_NUMBER 6 #define GFC_STDERR_UNIT_NUMBER 0 +#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_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 +#define GFC_ATTRIBUTE_ALLOCATABLE 2 +#define GFC_ATTRIBUTE_OTHER 3 -#define GFC_DTYPE_RANK_MASK 0x07 -#define GFC_DTYPE_TYPE_SHIFT 3 -#define GFC_DTYPE_TYPE_MASK 0x38 -#define GFC_DTYPE_SIZE_SHIFT 6 /* 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 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_UNION } bt; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 2699a767dbf..7706ba95423 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -123,14 +123,18 @@ gfc_array_dataptr_type (tree desc) Don't forget to #undef these! */ #define DATA_FIELD 0 -#define OFFSET_FIELD 1 -#define DTYPE_FIELD 2 -#define DIMENSION_FIELD 3 -#define CAF_TOKEN_FIELD 4 - -#define STRIDE_SUBFIELD 0 -#define LBOUND_SUBFIELD 1 -#define UBOUND_SUBFIELD 2 +#define ELEM_LEN_FIELD 1 +#define VERSION_FIELD 2 +#define RANK_FIELD 3 +#define ATTR_FIELD 4 +#define DTYPE_FIELD 5 +#define OFFSET_FIELD 6 +#define DIMENSION_FIELD 7 +#define CAF_TOKEN_FIELD 8 + +#define LBOUND_SUBFIELD 0 +#define EXTENT_SUBFIELD 1 +#define SM_SUBFIELD 2 /* This provides READ-ONLY access to the data field. The field itself doesn't have the proper type. */ @@ -178,6 +182,16 @@ gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) } +/* This is trivial but unifies the API. */ + +tree +gfc_data_field_from_base_field (tree field) +{ + gcc_assert (DATA_FIELD == 0); + return gfc_advance_chain (field, DATA_FIELD); +} + + /* This provides address access to the data field. This should only be used by array allocation, passing this on to the runtime. */ @@ -189,8 +203,7 @@ gfc_conv_descriptor_data_addr (tree desc) type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - field = TYPE_FIELDS (type); - gcc_assert (DATA_FIELD == 0); + field = gfc_data_field_from_base_field (TYPE_FIELDS (type)); t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); @@ -198,6 +211,37 @@ gfc_conv_descriptor_data_addr (tree desc) } static tree +gfc_conv_descriptor_elem_len (tree desc) +{ + tree type; + tree field; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), ELEM_LEN_FIELD); + gcc_assert (field != NULL_TREE && TREE_TYPE (field) == size_type_node); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + +tree +gfc_conv_descriptor_elem_len_get (tree desc) +{ + return gfc_conv_descriptor_elem_len (desc); +} + +void +gfc_conv_descriptor_elem_len_set (stmtblock_t *block, tree desc, + tree value) +{ + tree t = gfc_conv_descriptor_elem_len (desc); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + + +static tree gfc_conv_descriptor_offset (tree desc) { tree type; @@ -238,24 +282,80 @@ 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); } +tree +gfc_dimension_field_from_base_field (tree field) +{ + return gfc_advance_chain (field, DIMENSION_FIELD); +} + tree gfc_conv_descriptor_rank (tree desc) { - tree tmp; - tree dtype; + tree field; + tree type; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), RANK_FIELD); + 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); +} + + +void +gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int rank) +{ + tree field = gfc_conv_descriptor_rank (desc); + gfc_add_modify (block, field, build_int_cst (TREE_TYPE (field), rank)); +} + + +void +gfc_conv_descriptor_version_set (stmtblock_t *block, tree desc) +{ + tree field; + tree type; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), VERSION_FIELD); + gcc_assert (field != NULL_TREE && TREE_TYPE (field) == integer_type_node); + + 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, 1)); +} + + +void +gfc_conv_descriptor_attr_set (stmtblock_t *block, tree desc, int attr) +{ + tree field; + tree type; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), ATTR_FIELD); + gcc_assert (field != NULL_TREE + && TREE_CODE (TREE_TYPE (field)) == INTEGER_TYPE); - 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); + field = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, field, build_int_cst (TREE_TYPE (field), attr)); } @@ -267,7 +367,7 @@ gfc_get_descriptor_dimension (tree desc) type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); + field = gfc_dimension_field_from_base_field (TYPE_FIELDS (type)); gcc_assert (field != NULL_TREE && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); @@ -309,15 +409,58 @@ gfc_conv_descriptor_token (tree desc) } +tree +gfc_conv_descriptor_stride_get (tree desc, tree dim) +{ + tree tmp, size, cond; + tree type = TREE_TYPE (desc); + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + if (integer_zerop (dim) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) + return gfc_index_one_node; + + tmp = gfc_get_element_type (type); + + size = gfc_conv_descriptor_elem_len_get (desc); + + size = fold_convert (gfc_array_index_type, size); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, gfc_array_index_type, + gfc_conv_descriptor_sm_get (desc, dim), size); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, size, + gfc_index_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, + gfc_index_zero_node, tmp); + return tmp; +} + + +void +gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, + tree dim, tree value) +{ + tree tmp; + tmp = gfc_get_element_type (TREE_TYPE (desc)); + tmp = gfc_conv_descriptor_elem_len_get (desc); + + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, value), + fold_convert (gfc_array_index_type, tmp)); + gfc_conv_descriptor_sm_set (block, desc, dim, tmp); +} + static tree -gfc_conv_descriptor_stride (tree desc, tree dim) +gfc_conv_descriptor_sm (tree desc, tree dim) { tree tmp; tree field; tmp = gfc_conv_descriptor_dimension (desc, dim); field = TYPE_FIELDS (TREE_TYPE (tmp)); - field = gfc_advance_chain (field, STRIDE_SUBFIELD); + field = gfc_advance_chain (field, SM_SUBFIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), @@ -326,37 +469,27 @@ gfc_conv_descriptor_stride (tree desc, tree dim) } tree -gfc_conv_descriptor_stride_get (tree desc, tree dim) +gfc_conv_descriptor_sm_get (tree desc, tree dim) { - tree type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - if (integer_zerop (dim) - && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) - return gfc_index_one_node; - - return gfc_conv_descriptor_stride (desc, dim); + return gfc_conv_descriptor_sm (desc, dim); } void -gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, +gfc_conv_descriptor_sm_set (stmtblock_t *block, tree desc, tree dim, tree value) { - tree t = gfc_conv_descriptor_stride (desc, dim); + tree t = gfc_conv_descriptor_sm (desc, dim); gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); } static tree -gfc_conv_descriptor_lbound (tree desc, tree dim) +gfc_conv_descriptor_extent (tree desc, tree dim) { tree tmp; tree field; - tmp = gfc_conv_descriptor_dimension (desc, dim); field = TYPE_FIELDS (TREE_TYPE (tmp)); - field = gfc_advance_chain (field, LBOUND_SUBFIELD); + field = gfc_advance_chain (field, EXTENT_SUBFIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), @@ -365,28 +498,29 @@ gfc_conv_descriptor_lbound (tree desc, tree dim) } tree -gfc_conv_descriptor_lbound_get (tree desc, tree dim) +gfc_conv_descriptor_extent_get (tree desc, tree dim) { - return gfc_conv_descriptor_lbound (desc, dim); + return gfc_conv_descriptor_extent (desc, dim); } void -gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, +gfc_conv_descriptor_extent_set (stmtblock_t *block, tree desc, tree dim, tree value) { - tree t = gfc_conv_descriptor_lbound (desc, dim); + tree t = gfc_conv_descriptor_extent (desc, dim); gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); } + static tree -gfc_conv_descriptor_ubound (tree desc, tree dim) +gfc_conv_descriptor_lbound (tree desc, tree dim) { tree tmp; tree field; tmp = gfc_conv_descriptor_dimension (desc, dim); field = TYPE_FIELDS (TREE_TYPE (tmp)); - field = gfc_advance_chain (field, UBOUND_SUBFIELD); + field = gfc_advance_chain (field, LBOUND_SUBFIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), @@ -395,35 +529,94 @@ gfc_conv_descriptor_ubound (tree desc, tree dim) } tree +gfc_conv_descriptor_lbound_get (tree desc, tree dim) +{ + return gfc_conv_descriptor_lbound (desc, dim); +} + +void +gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, + tree dim, tree value) +{ + tree t = gfc_conv_descriptor_lbound (desc, dim); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + +tree gfc_conv_descriptor_ubound_get (tree desc, tree dim) { - return gfc_conv_descriptor_ubound (desc, dim); + tree lb = gfc_conv_descriptor_lbound (desc, dim); + tree tmp = gfc_conv_descriptor_extent_get (desc, dim); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, lb), + fold_convert (gfc_array_index_type, tmp)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + return tmp; } void gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, tree dim, tree value) { - tree t = gfc_conv_descriptor_ubound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); + tree tmp; + tmp = gfc_conv_descriptor_lbound (desc, dim); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, value), + fold_convert (gfc_array_index_type, tmp)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_conv_descriptor_extent_set (block, desc, dim, tmp); } /* Build a null array descriptor constructor. */ tree -gfc_build_null_descriptor (tree type) +gfc_build_null_descriptor (tree desc_type, int rank, int attr, + gfc_typespec *ts) { tree field; tree tmp; + tree elem_len; + vec<constructor_elt, va_gc> *init = NULL; - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (desc_type)); gcc_assert (DATA_FIELD == 0); - field = TYPE_FIELDS (type); /* Set a NULL data pointer. */ - tmp = build_constructor_single (type, field, null_pointer_node); + field = TYPE_FIELDS (desc_type); + CONSTRUCTOR_APPEND_ELT (init, field, null_pointer_node); + + /* Set elem_len. */ + tmp = gfc_advance_chain (field, ELEM_LEN_FIELD); + if (ts->deferred) + elem_len = build_int_cst (integer_type_node, 0); + else + elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (desc_type)); + CONSTRUCTOR_APPEND_ELT (init, tmp, elem_len); + + /* Set version to 1. */ + tmp = gfc_advance_chain (field, VERSION_FIELD); + CONSTRUCTOR_APPEND_ELT (init, tmp, + build_int_cst (integer_type_node, 1)); + + /* Set rank. */ + tmp = gfc_advance_chain (field, RANK_FIELD); + CONSTRUCTOR_APPEND_ELT (init, tmp, + 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 (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); TREE_CONSTANT (tmp) = 1; - /* All other fields are ignored. */ return tmp; } @@ -436,32 +629,26 @@ void gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim, tree new_lbound) { - tree offs, ubound, lbound, stride; + tree offs, lbound, stride; tree diff, offs_diff; new_lbound = fold_convert (gfc_array_index_type, new_lbound); offs = gfc_conv_descriptor_offset_get (desc); lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); /* Get difference (new - old) by which to shift stuff. */ diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, new_lbound, lbound); - /* Shift ubound and offset accordingly. This has to be done before - updating the lbound, as they depend on the lbound expression! */ - ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, diff); - gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, diff, stride); offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, offs, offs_diff); gfc_conv_descriptor_offset_set (block, desc, offs); - /* Finally set lbound to value we want. */ + /* Set lbound to value we want. */ gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); } @@ -469,13 +656,19 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, /* Cleanup those #defines. */ #undef DATA_FIELD +#undef ELEM_LEN_FIELD +#undef VERSION_FIELD +#undef RANK_FIELD #undef OFFSET_FIELD #undef DTYPE_FIELD +#undef ATTR_FIELD #undef DIMENSION_FIELD #undef CAF_TOKEN_FIELD #undef STRIDE_SUBFIELD #undef LBOUND_SUBFIELD #undef UBOUND_SUBFIELD +#undef SM_SUBFIELD +#undef EXTENT_SUBFIELD /* Mark a SS chain as used. Flags specifies in which loops the SS is used. @@ -726,11 +919,25 @@ void gfc_trans_static_array_pointer (gfc_symbol * sym) { tree type; + int attr; gcc_assert (TREE_STATIC (sym->backend_decl)); - /* Just zero the data member. */ + + if (sym->attr.pointer) + attr = GFC_ATTRIBUTE_POINTER; + else if (sym->attr.allocatable) + attr = GFC_ATTRIBUTE_ALLOCATABLE; + else + gcc_unreachable (); + type = TREE_TYPE (sym->backend_decl); - DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); + DECL_INITIAL (sym->backend_decl) + = gfc_build_null_descriptor (type, sym->as->rank, attr, &sym->ts); + + if (sym->ts.type == BT_CHARACTER && sym->ts.deferred + && sym->ts.u.cl->backend_decl) + DECL_INITIAL (sym->ts.u.cl->backend_decl) = + build_int_cst (gfc_charlen_type_node, 0); } @@ -1001,7 +1208,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; @@ -1011,6 +1219,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; @@ -1092,7 +1301,21 @@ 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. */ + + if (class_expr != NULL_TREE) + elem_len = gfc_class_vtab_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); /* Emit a DECL_EXPR for the variable sized array type in GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type @@ -1106,23 +1329,26 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, /* Fill in the array dtype. */ tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + 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++) @@ -1142,8 +1368,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, of the descriptor fields. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); + gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]), + gfc_index_one_node); s->loop->to[n] = tmp; } else @@ -1151,17 +1377,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); @@ -1180,27 +1406,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_class_vtab_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; } @@ -1245,27 +1465,25 @@ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) tree arg0, arg1; tree tmp; tree size; - tree ubound; + tree extent; if (integer_zerop (extra)) return; - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); + extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[0]); - /* Add EXTRA to the upper bound. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, extra); - gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); + /* Add EXTRA to the extent. */ + extent = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + extent, extra); + gfc_conv_descriptor_extent_set (pblock, desc, gfc_rank_cst[0], extent); /* Get the value of the current data pointer. */ arg0 = gfc_conv_descriptor_data_get (desc); /* Calculate the new array size. */ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, gfc_index_one_node); arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, tmp), + fold_convert (size_type_node, extent), fold_convert (size_type_node, size)); /* Call the realloc() function. */ @@ -1486,7 +1704,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) @@ -2353,7 +2571,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; @@ -2443,8 +2662,8 @@ set_vector_loop_bounds (gfc_ss * ss) zero = gfc_rank_cst[0]; tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, zero), - gfc_conv_descriptor_lbound_get (desc, zero)); + gfc_conv_descriptor_extent_get (desc, zero), + gfc_index_one_node); tmp = gfc_evaluate_now (tmp, &outer_loop->pre); loop->to[n] = tmp; } @@ -2773,6 +2992,32 @@ gfc_conv_array_offset (tree descriptor) } +/* Get an expression for the array stride multiplier. */ + +tree +gfc_conv_array_sm (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + /* For descriptorless arrays use the array size. */ + tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); + if (tmp != NULL_TREE) + { + tree size = gfc_get_element_type (TREE_TYPE (descriptor)); + size = size_in_bytes (size); + size = fold_convert (gfc_array_index_type, size); + return fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, size); + } + + tmp = gfc_conv_descriptor_sm_get (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + /* Get an expression for the array stride. */ tree @@ -2812,6 +3057,31 @@ gfc_conv_array_lbound (tree descriptor, int dim) } +/* Like gfc_conv_array_stride, but for the extent. */ + +tree +gfc_conv_array_extent (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (tmp != NULL_TREE) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + GFC_TYPE_ARRAY_UBOUND (type, dim), tmp); + return fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, gfc_index_one_node); + } + + tmp = gfc_conv_descriptor_extent_get (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + /* Like gfc_conv_array_stride, but for the upper bound. */ tree @@ -3948,6 +4218,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_ISYM_UBOUND: case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: + case GFC_ISYM_SHAPE: case GFC_ISYM_THIS_IMAGE: loop->dimen = ss->dimen; goto done; @@ -3999,11 +4270,13 @@ done: /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_SHAPE: { gfc_expr *arg; /* This is the variant without DIM=... */ - gcc_assert (expr->value.function.actual->next->expr == NULL); + gcc_assert (expr->value.function.actual->next->expr == NULL + || expr->value.function.isym->id == GFC_ISYM_SHAPE); arg = expr->value.function.actual->expr; if (arg->rank == -1) @@ -4788,10 +5061,12 @@ set_loop_bounds (gfc_loopinfo *loop) { gfc_expr *expr = loopspec[n]->info->expr; - /* The {l,u}bound of an assumed rank. */ + /* The {l,u}bound and shape of an assumed rank. */ gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND - || expr->value.function.isym->id == GFC_ISYM_UBOUND) - && expr->value.function.actual->next->expr == NULL + || expr->value.function.isym->id == GFC_ISYM_UBOUND + || expr->value.function.isym->id == GFC_ISYM_SHAPE) + && (expr->value.function.actual->next->expr == NULL + || expr->value.function.isym->id == GFC_ISYM_SHAPE) && expr->value.function.actual->expr->rank == -1); loop->to[n] = info->end[dim]; @@ -4839,7 +5114,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; @@ -4875,7 +5150,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 @@ -4989,14 +5265,9 @@ gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim) for (dim = from_dim; dim < to_dim; ++dim) { - tree lbound; - tree ubound; tree extent; - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]); res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, res, extent); } @@ -5083,20 +5354,41 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, stride = gfc_index_one_node; offset = gfc_index_zero_node; - /* Set the dtype. */ - if (expr->ts.type == BT_CHARACTER && expr->ts.deferred - && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL) + /* Set the rank and dtype. */ + gfc_conv_descriptor_rank_set (descriptor_block, descriptor, rank); + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (&expr->ts)); + + if (expr3_elem_size != NULL_TREE) + tmp = expr3_elem_size; + else if (expr3 != NULL) { - type = gfc_typenode_for_spec (&expr->ts); - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, - gfc_get_dtype_rank_type (rank, type)); + if (expr3->ts.type == BT_CLASS) + { + gfc_se se_sz; + gfc_expr *sz = gfc_copy_expr (expr3); + gfc_add_vptr_component (sz); + gfc_add_size_component (sz); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + tmp = se_sz.expr; + } + else + { + tmp = gfc_typenode_for_spec (&expr3->ts); + tmp = TYPE_SIZE_UNIT (tmp); + } } + else if (expr->ts.type != BT_UNKNOWN && expr->ts.type != BT_CHARACTER) + /* FIXME: Properly handle characters. See PR 57456. */ + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts)); else - { - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type)); - } + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + + /* Convert to size_t. */ + element_size = fold_convert (size_type_node, tmp); + gfc_conv_descriptor_elem_len_set (descriptor_block, descriptor, element_size); or_expr = boolean_false_node; @@ -5150,7 +5442,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, offset, tmp); - /* Set upper bound. */ + /* Set extent. */ gfc_init_se (&se, NULL); if (expr3_desc != NULL_TREE) { @@ -5183,10 +5475,20 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, if (ubound->expr_type == EXPR_FUNCTION) se.expr = gfc_evaluate_now (se.expr, pblock); } + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); conv_ubound = se.expr; + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + conv_ubound, conv_lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + tmp, gfc_index_zero_node); + gfc_conv_descriptor_extent_set (descriptor_block, descriptor, + gfc_rank_cst[n], tmp); + /* Store the stride. */ gfc_conv_descriptor_stride_set (descriptor_block, descriptor, gfc_rank_cst[n], stride); @@ -5264,36 +5566,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, } } - /* The stride is the number of elements in the array, so multiply by the - size of an element to get the total size. Obviously, if there is a - SOURCE expression (expr3) we must use its element size. */ - if (expr3_elem_size != NULL_TREE) - tmp = expr3_elem_size; - else if (expr3 != NULL) - { - if (expr3->ts.type == BT_CLASS) - { - gfc_se se_sz; - gfc_expr *sz = gfc_copy_expr (expr3); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - tmp = se_sz.expr; - } - else - { - tmp = gfc_typenode_for_spec (&expr3->ts); - tmp = TYPE_SIZE_UNIT (tmp); - } - } - else - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - - /* Convert to size_t. */ - element_size = fold_convert (size_type_node, tmp); - if (rank == 0) return element_size; @@ -5482,8 +5754,9 @@ 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, alloc_w_e3_arr_spec ? expr->rank - : ref->u.ar.as->rank, + size = gfc_array_init_size (se->expr, + alloc_w_e3_arr_spec ? expr->rank + : ref->u.ar.as->rank, coarray ? ref->u.ar.as->corank : 0, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, @@ -5741,7 +6014,8 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) break; case EXPR_NULL: - return gfc_build_null_descriptor (type); + return gfc_build_null_descriptor (type, 1, GFC_ATTRIBUTE_OTHER, + &expr->ts); default: gcc_unreachable (); @@ -6735,11 +7009,15 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) int n; tree tmp; tree desc; + tree elem_type; stmtblock_t block; tree start; tree offset; + tree elem_len; int full; bool subref_array_target = false; + bool assumed_size = false; + bool abstract_class = false; gfc_expr *arg, *ss_expr; if (se->want_coarray) @@ -6786,6 +7064,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (se->force_tmp) need_tmp = 1; + if (info->ref->u.ar.as->type == AS_ASSUMED_SIZE) + assumed_size = true; + if (need_tmp) full = 0; else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) @@ -6938,7 +7219,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) { @@ -7060,6 +7341,20 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } desc = info->descriptor; + + /* Classes with an abstract declared type present particular problems + because they mess up the 'desc' totally and they have to be detected + to provide the dynamic type elem_len. + TODO extend this to all class expressions. */ + abstract_class = gfc_expr_attr (expr).abstract + && expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->ts.type == BT_CLASS; + + if (abstract_class) + elem_type = gfc_typenode_for_spec(&CLASS_DATA (expr->symtree->n.sym)->ts); + else + elem_type = gfc_typenode_for_spec(&expr->ts); + if (se->direct_byref && !se->byref_noassign) { /* For pointer assignments we fill in the destination. */ @@ -7069,8 +7364,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else { /* Otherwise make a new one. */ - parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, + parmtype = gfc_get_array_type_bounds (elem_type, + loop.dimen, codim, loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); @@ -7087,9 +7382,34 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) We don't have to worry about numeric overflows when calculating the offsets because all elements are within the array data. */ - /* Set the dtype. */ + /* Set elem_len, version, rank, dtype and attribute. */ + if (expr->ts.type == BT_CHARACTER && !is_subref_array (expr)) + elem_len = size_of_string_in_bytes (expr->ts.kind, se->string_length); + else if (abstract_class) + { + tmp = expr->symtree->n.sym->backend_decl; + if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + + tmp = gfc_get_vptr_from_expr (tmp); + if (tmp != NULL_TREE) + elem_len = gfc_vptr_size_get (tmp); + else + elem_len = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + } + else + /* TODO Set this to the size of elem_type rather than the size of the + descriptor elements. */ + elem_len = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + + elem_len = fold_convert (gfc_array_index_type, elem_len); + + 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 the full array. */ @@ -7156,9 +7476,22 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_rank_cst[dim], from); - /* Set the new upper bound. */ - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[dim], to); + /* Set the new extent. */ + if (assumed_size && dim == ndim - 1) + tmp = build_int_cst (gfc_array_index_type, -1); + else + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, to, from); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + tmp = fold_build2_loc (input_location, MAX_EXPR, + gfc_array_index_type, tmp, + gfc_index_zero_node); + } + gfc_conv_descriptor_extent_set (&loop.pre, parm, + gfc_rank_cst[dim], tmp); /* Multiply the stride by the section stride to get the total stride. */ @@ -7196,9 +7529,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) TREE_TYPE (base), tmp, base); } - /* Store the new stride. */ - gfc_conv_descriptor_stride_set (&loop.pre, parm, - gfc_rank_cst[dim], stride); + /* Store the new stride measure. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, elem_len); + gfc_conv_descriptor_sm_set (&loop.pre, parm, + gfc_rank_cst[dim], tmp); } for (n = loop.dimen; n < loop.dimen + codim; n++) @@ -7256,6 +7591,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) it to zero here. */ gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node); } + desc = parm; } @@ -7301,13 +7637,7 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size) gfc_build_addr_expr (NULL, desc)); else { - tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); - tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); - - *size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *size, gfc_index_one_node); + *size = gfc_conv_descriptor_extent_get (desc, gfc_index_zero_node); *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, *size, gfc_index_zero_node); } @@ -7580,13 +7910,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, tree old_desc = tmp; tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc"); - old_field = gfc_conv_descriptor_dtype (old_desc); - new_field = gfc_conv_descriptor_dtype (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - - old_field = gfc_conv_descriptor_offset (old_desc); - new_field = gfc_conv_descriptor_offset (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); + gfc_add_modify (&se->pre, new_desc, old_desc); for (int i = 0; i < expr->rank; i++) { @@ -7728,15 +8052,10 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank) tree nelems; tree tmp; idx = gfc_rank_cst[rank - 1]; - nelems = gfc_conv_descriptor_ubound_get (decl, idx); - tmp = gfc_conv_descriptor_lbound_get (decl, idx); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - nelems, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, block); + nelems = gfc_conv_descriptor_extent_get (decl, idx); + nelems = gfc_evaluate_now (nelems, block); - nelems = gfc_conv_descriptor_stride_get (decl, idx); + tmp = gfc_conv_descriptor_stride_get (decl, idx); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, nelems, tmp); return gfc_evaluate_now (tmp, block); @@ -8146,14 +8465,37 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, break; case NULLIFY_ALLOC_COMP: - if (c->attr.pointer || c->attr.proc_pointer) + /* We also need to set the version, attribute etc. fields of + pointers to arrays. */ + cmp_has_alloc_comps = cmp_has_alloc_comps + || ((c->ts.type == BT_DERIVED + || c->ts.type == BT_CLASS) + && c->ts.u.derived->attr.pointer_comp); + + if (c->attr.proc_pointer) continue; - else if (c->attr.allocatable - && (c->attr.dimension|| c->attr.codimension)) + if (c->ts.type != BT_CLASS && (c->attr.allocatable || c->attr.pointer) + && (c->attr.dimension || c->attr.codimension)) { + tree type; + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); + if (!UNLIMITED_POLY (c)) + { + type = gfc_get_element_type (TREE_TYPE (comp)); + gfc_conv_descriptor_elem_len_set (&fnblock, comp, + TYPE_SIZE_UNIT (type)); + } + 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 (&c->ts)); + gfc_conv_descriptor_attr_set (&fnblock, comp, + c->attr.allocatable + ? GFC_ATTRIBUTE_ALLOCATABLE + : GFC_ATTRIBUTE_POINTER); } else if (c->attr.allocatable) { @@ -8175,7 +8517,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_expr_to_block (&fnblock, tmp); } } - else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) + else if (c->ts.type == BT_CLASS + && (CLASS_DATA (c)->attr.allocatable + || CLASS_DATA (c)->attr.dimension + || (CLASS_DATA (c)->attr.codimension + && flag_coarray != GFC_FCOARRAY_LIB))) { /* Allocatable CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, @@ -8184,8 +8530,26 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); + if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) + { + gfc_conv_descriptor_data_set (&fnblock, comp, + null_pointer_node); + if (!UNLIMITED_POLY (c)) + { + tree type = gfc_get_element_type (TREE_TYPE (comp)); + gfc_conv_descriptor_elem_len_set (&fnblock, comp, + TYPE_SIZE_UNIT (type)); + } + gfc_conv_descriptor_version_set (&fnblock, comp); + gfc_conv_descriptor_rank_set (&fnblock, comp, + CLASS_DATA (c)->as->rank); + gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), + gfc_get_dtype (&c->ts)); + gfc_conv_descriptor_attr_set (&fnblock, comp, + c->attr.allocatable + ? GFC_ATTRIBUTE_ALLOCATABLE + : GFC_ATTRIBUTE_POINTER); + } else { tmp = fold_build2_loc (input_location, MODIFY_EXPR, @@ -8194,6 +8558,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_expr_to_block (&fnblock, tmp); } } + else if (c->attr.pointer) + continue; else if (cmp_has_alloc_comps) { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, @@ -8447,7 +8813,7 @@ static tree get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) { tree lbound; - tree ubound; + tree extent; tree stride; tree cond, cond1, cond3, cond4; tree tmp; @@ -8457,10 +8823,10 @@ get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) { tmp = gfc_rank_cst[dim]; lbound = gfc_conv_descriptor_lbound_get (desc, tmp); - ubound = gfc_conv_descriptor_ubound_get (desc, tmp); + extent = gfc_conv_descriptor_extent_get (desc, tmp); stride = gfc_conv_descriptor_stride_get (desc, tmp); - cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - ubound, lbound); + cond1 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, stride, gfc_index_zero_node); cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, @@ -8641,13 +9007,14 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tree alloc_expr; tree size1; tree size2; + tree elem_len; tree array1; tree cond_null; tree cond; tree tmp; tree tmp2; tree lbound; - tree ubound; + tree extent; tree desc; tree old_desc; tree desc2; @@ -8655,7 +9022,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tree jump_label1; tree jump_label2; tree neq_size; - tree lbd; int n; int dim; gfc_array_spec * as; @@ -8749,21 +9115,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, bounds and doing the reallocation....... */ for (n = 0; n < expr1->rank; n++) { + tree extent; /* Check the shape. */ - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); + extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[n]); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]); tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, lbound); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - tmp, ubound); + tmp, gfc_index_one_node); cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp, gfc_index_zero_node); + tmp, extent); tmp = build3_v (COND_EXPR, cond, build1_v (GOTO_EXPR, jump_label1), build_empty_stmt (input_location)); @@ -8841,39 +9204,68 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, size1 = gfc_index_one_node; offset = gfc_index_zero_node; + /* Get the new lhs size in bytes. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr2->ts.deferred) + { + if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL) + tmp = expr2->ts.u.cl->backend_decl; + else + tmp = rss->info->string_length; + } + else + { + tmp = expr2->ts.u.cl->backend_decl; + if (!tmp && expr2->expr_type == EXPR_OP + && expr2->value.op.op == INTRINSIC_CONCAT) + { + tmp = concat_str_length (expr2); + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); + } + + if (expr1->ts.u.cl->backend_decl + && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL) + gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); + else + gfc_add_modify (&fblock, lss->info->string_length, tmp); + } + else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) + { + tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + expr1->ts.u.cl->backend_decl); + } + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); + + elem_len = fold_convert (gfc_array_index_type, tmp); + + gfc_conv_descriptor_elem_len_set (&fblock, desc, elem_len); + for (n = 0; n < expr2->rank; n++) { + lbound = gfc_index_one_node; tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, + extent = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp, gfc_index_one_node); - lbound = gfc_index_one_node; - ubound = tmp; - if (as) - { - lbd = get_std_lbound (expr2, desc2, n, - as->type == AS_ASSUMED_SIZE); - ubound = fold_build2_loc (input_location, - MINUS_EXPR, - gfc_array_index_type, - ubound, lbound); - ubound = fold_build2_loc (input_location, - PLUS_EXPR, - gfc_array_index_type, - ubound, lbd); - lbound = lbd; - } + lbound = get_std_lbound (expr2, desc2, n, + as->type == AS_ASSUMED_SIZE); gfc_conv_descriptor_lbound_set (&fblock, desc, gfc_rank_cst[n], lbound); - gfc_conv_descriptor_ubound_set (&fblock, desc, + gfc_conv_descriptor_extent_set (&fblock, desc, gfc_rank_cst[n], - ubound); + extent); gfc_conv_descriptor_stride_set (&fblock, desc, gfc_rank_cst[n], size1); @@ -8887,7 +9279,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, offset, tmp2); size1 = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - tmp, size1); + extent, size1); } /* Set the lhs descriptor and scalarizer offsets. For rank > 1, @@ -8912,47 +9304,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, linfo->delta[dim], tmp); } - /* Get the new lhs size in bytes. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr2->ts.deferred) - { - if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL) - tmp = expr2->ts.u.cl->backend_decl; - else - tmp = rss->info->string_length; - } - else - { - tmp = expr2->ts.u.cl->backend_decl; - if (!tmp && expr2->expr_type == EXPR_OP - && expr2->value.op.op == INTRINSIC_CONCAT) - { - tmp = concat_str_length (expr2); - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - } - - if (expr1->ts.u.cl->backend_decl - && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL) - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); - else - gfc_add_modify (&fblock, lss->info->string_length, tmp); - } - else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) - { - tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - expr1->ts.u.cl->backend_decl); - } - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); - tmp = fold_convert (gfc_array_index_type, tmp); size2 = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - tmp, size2); + elem_len, size2); size2 = fold_convert (size_type_node, size2); size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size2, size_one_node); @@ -8963,15 +9317,14 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) { - tree type; + gfc_typespec *ts; tmp = gfc_conv_descriptor_dtype (desc); if (expr2->ts.u.cl->backend_decl) - type = gfc_typenode_for_spec (&expr2->ts); + ts = &expr2->ts; else - type = gfc_typenode_for_spec (&expr1->ts); + ts = &expr1->ts; - gfc_add_modify (&fblock, tmp, - gfc_get_dtype_rank_type (expr1->rank,type)); + gfc_add_modify (&fblock, tmp, gfc_get_dtype (ts)); } /* Realloc expression. Note that the scalarizer uses desc.data @@ -9016,6 +9369,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 1, size2); gfc_conv_descriptor_data_set (&alloc_block, desc, tmp); + gfc_conv_descriptor_rank_set (&alloc_block, desc, expr1->rank); /* We already set the dtype in the case of deferred character length arrays. */ @@ -9023,7 +9377,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)) { 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) @@ -9152,9 +9506,24 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) type = TREE_TYPE (descriptor); } - /* NULLIFY the data pointer, for non-saved allocatables. */ + /* NULLIFY the data pointer and set default values for the fields. */ + /* NULLIFY the data pointer and set default values for the fields, + for non-saved allocatables. */ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable) - gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + { + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + gfc_conv_descriptor_elem_len_set (&init, descriptor, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + 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 (&sym->ts)); + gcc_assert (sym->attr.allocatable || sym->attr.pointer); + gfc_conv_descriptor_attr_set (&init, descriptor, + sym->attr.allocatable + ? GFC_ATTRIBUTE_ALLOCATABLE + : GFC_ATTRIBUTE_POINTER); + } gfc_restore_backend_locus (&loc); gfc_init_block (&cleanup); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index d0309b27831..1025b9f75eb 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. */ @@ -120,13 +121,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); +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_expr *, locus *); @@ -148,8 +149,10 @@ tree gfc_conv_array_data (tree); tree gfc_conv_array_offset (tree); /* Return either an INT_CST or an expression for that part of the descriptor. */ tree gfc_conv_array_stride (tree, int); +tree gfc_conv_array_sm (tree, int); tree gfc_conv_array_lbound (tree, int); tree gfc_conv_array_ubound (tree, int); +tree gfc_conv_array_extent (tree, int); /* Set cobounds of an array. */ void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *); @@ -164,13 +167,25 @@ tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); tree gfc_conv_descriptor_ubound_get (tree, tree); +tree gfc_conv_descriptor_sm_get (tree, tree); +tree gfc_conv_descriptor_extent_get (tree, tree); tree gfc_conv_descriptor_token (tree); +tree gfc_conv_descriptor_elem_len_get (tree); +void gfc_conv_descriptor_elem_len_set (stmtblock_t *, tree, tree); +void gfc_conv_descriptor_rank_set (stmtblock_t *, tree, int); +void gfc_conv_descriptor_version_set (stmtblock_t *, tree); +void gfc_conv_descriptor_attr_set (stmtblock_t *, tree, int); + +tree gfc_data_field_from_base_field (tree); +tree gfc_dimension_field_from_base_field (tree); void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree); void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree); void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree); +void gfc_conv_descriptor_sm_set (stmtblock_t *, tree, tree, tree); +void gfc_conv_descriptor_extent_set (stmtblock_t *, tree, tree, tree); /* Shift lower bound of descriptor, updating ubound and offset. */ void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 20ec69eb570..2e7517871e4 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -676,7 +676,8 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) TREE_TYPE (s->field), s->sym->attr.dimension, s->sym->attr.pointer - || s->sym->attr.allocatable, false); + || s->sym->attr.allocatable, false, + s->sym->as ? s->sym->as->rank : 0); CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 5bae8ca2b19..332cc725577 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1752,7 +1752,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) && sym->attr.allocatable), sym->attr.pointer || sym->attr.allocatable || sym->ts.type == BT_CLASS, - sym->attr.proc_pointer); + sym->attr.proc_pointer, + sym->as ? sym->as->rank : 0); } if (!TREE_STATIC (decl) @@ -1862,7 +1863,8 @@ get_proc_pointer_decl (gfc_symbol *sym) DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl), sym->attr.dimension, - false, true); + false, true, + sym->as ? sym->as->rank : 0); } /* Handle threadprivate procedure pointers. */ @@ -4188,9 +4190,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) NULL_TREE); } - if (sym->ts.type == BT_CLASS + if (sym->ts.type == BT_CLASS && !sym->attr.dummy && (sym->attr.save || flag_max_stack_var_size == 0) - && CLASS_DATA (sym)->attr.allocatable) + && (CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.dimension + || (CLASS_DATA (sym)->attr.codimension + && flag_coarray != GFC_FCOARRAY_LIB))) { tree vptr; @@ -4208,8 +4213,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) || (CLASS_DATA (sym)->attr.codimension && flag_coarray != GFC_FCOARRAY_LIB)) { + int attr; + + if (CLASS_DATA (sym)->attr.class_pointer) + attr = GFC_ATTRIBUTE_POINTER; + else if (CLASS_DATA (sym)->attr.allocatable) + attr = GFC_ATTRIBUTE_ALLOCATABLE; + else + gcc_unreachable (); + tmp = gfc_class_data_get (sym->backend_decl); - tmp = gfc_build_null_descriptor (TREE_TYPE (tmp)); + tmp = gfc_build_null_descriptor (TREE_TYPE (tmp), + CLASS_DATA (sym)->as->rank, + attr, &sym->ts); } else tmp = null_pointer_node; @@ -4350,6 +4366,24 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_set_backend_locus (&sym->declared_at); gfc_start_block (&init); + if (!sym->attr.dummy && sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->as) + { + tree cdesc = gfc_class_data_get (sym->backend_decl); + tree type = TREE_TYPE (CLASS_DATA (sym)->backend_decl); + gfc_conv_descriptor_elem_len_set (&init, cdesc, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + gfc_conv_descriptor_version_set (&init, cdesc); + gfc_conv_descriptor_rank_set (&init, cdesc, + CLASS_DATA (sym)->as->rank); + tmp = gfc_conv_descriptor_dtype (cdesc); + gfc_add_modify (&init, tmp, gfc_get_dtype (&sym->ts)); + gfc_conv_descriptor_attr_set (&init, cdesc, + CLASS_DATA (sym)->attr.allocatable + ? GFC_ATTRIBUTE_ALLOCATABLE + : GFC_ATTRIBUTE_POINTER); + } + if (!sym->attr.pointer) { /* Nullify and automatic deallocation of allocatable @@ -4994,7 +5028,8 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym) DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl), sym->attr.dimension, - false, false); + false, false, + sym->as ? sym->as->rank : 0); debug_hooks->early_global_decl (decl); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 19239fb51f2..f0cdfca77c1 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -64,19 +64,40 @@ 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; + tree desc, type, dtype, elem_len; + int desc_attr; - type = get_scalar_to_descriptor_type (scalar, attr); - desc = gfc_create_var (type, "desc"); + dtype = get_scalar_to_descriptor_type (scalar, attr); + desc = gfc_create_var (dtype, "desc"); DECL_ARTIFICIAL (desc) = 1; if (!POINTER_TYPE_P (TREE_TYPE (scalar))) scalar = gfc_build_addr_expr (NULL_TREE, scalar); + + type = gfc_typenode_for_spec (ts); + + if (type == NULL_TREE) + elem_len = build_int_cst (size_type_node, 0); + else + elem_len = TYPE_SIZE_UNIT (type); + gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (type)); + gfc_get_dtype (ts)); gfc_conv_descriptor_data_set (&se->pre, desc, scalar); + gfc_conv_descriptor_elem_len_set (&se->pre, desc, elem_len); + gfc_conv_descriptor_version_set (&se->pre, desc); + gfc_conv_descriptor_rank_set (&se->pre, desc, 0); + + if (attr.pointer) + desc_attr = GFC_ATTRIBUTE_POINTER; + else if (attr.allocatable) + desc_attr = GFC_ATTRIBUTE_ALLOCATABLE; + else + desc_attr = GFC_ATTRIBUTE_OTHER; + gfc_conv_descriptor_attr_set (&se->pre, desc, desc_attr); /* Copy pointer address back - but only if it could have changed and if the actual argument is a pointer and not, e.g., NULL(). */ @@ -447,23 +468,37 @@ gfc_get_vptr_from_expr (tree expr) static void class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, - bool lhs_type) + bool lhs_type, int rank, symbol_attribute attr) { tree tmp, tmp2, type; + int desc_attr; gfc_conv_descriptor_data_set (block, lhs_desc, gfc_conv_descriptor_data_get (rhs_desc)); gfc_conv_descriptor_offset_set (block, lhs_desc, gfc_conv_descriptor_offset_get (rhs_desc)); + type = gfc_get_element_type (TREE_TYPE (lhs_desc)); + gfc_conv_descriptor_elem_len_set (block, lhs_desc, TYPE_SIZE_UNIT (type)); + gfc_conv_descriptor_version_set (block, lhs_desc); + gfc_conv_descriptor_rank_set (block, lhs_desc, rank); gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc), gfc_conv_descriptor_dtype (rhs_desc)); + if (attr.pointer) + desc_attr = GFC_ATTRIBUTE_POINTER; + else if (attr.allocatable) + desc_attr = GFC_ATTRIBUTE_ALLOCATABLE; + else + desc_attr = GFC_ATTRIBUTE_OTHER; + gfc_conv_descriptor_attr_set (block, lhs_desc, desc_attr); + + /* Assign the dimension as range-ref. */ tmp = gfc_get_descriptor_dimension (lhs_desc); tmp2 = gfc_get_descriptor_dimension (rhs_desc); - type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); + tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, gfc_index_zero_node, NULL_TREE, NULL_TREE); tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, @@ -550,17 +585,33 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, if (class_ts.u.derived->components->as) { tree type; - type = get_scalar_to_descriptor_type (parmse->expr, - gfc_expr_attr (e)); - gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), - gfc_get_dtype (type)); + int desc_attr; + symbol_attribute attr; + + attr = gfc_expr_attr (e); + type = get_scalar_to_descriptor_type (parmse->expr, attr); + if (optional) parmse->expr = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr), cond_optional, parmse->expr, fold_convert (TREE_TYPE (parmse->expr), null_pointer_node)); + gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr); + gfc_conv_descriptor_elem_len_set (&parmse->pre, ctree, TYPE_SIZE_UNIT (type)); + 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 (&class_ts)); + + if (attr.pointer) + desc_attr = GFC_ATTRIBUTE_POINTER; + else if (attr.allocatable) + desc_attr = GFC_ATTRIBUTE_ALLOCATABLE; + else + desc_attr = GFC_ATTRIBUTE_OTHER; + gfc_conv_descriptor_attr_set (&parmse->pre, ctree, desc_attr); } else { @@ -585,7 +636,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { gcc_assert (class_ts.u.derived->components->as->type == AS_ASSUMED_RANK); - class_array_data_assign (&block, ctree, parmse->expr, false); + class_array_data_assign (&block, ctree, parmse->expr, false, + e->rank, gfc_expr_attr (e)); } else { @@ -766,6 +818,9 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, } else { + gfc_typespec *ts = &class_ts.u.derived->components->ts; + if (class_ts.u.derived->attr.unlimited_polymorphic) + ts = &e->ts; ss = gfc_walk_expr (e); if (ss == gfc_ss_terminator) { @@ -775,7 +830,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK) { tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr, - gfc_expr_attr (e)); + gfc_expr_attr (e), ts); tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, TREE_TYPE (ctree), tmp); } @@ -927,10 +982,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, { if (e->rank == 0) { - tree type = get_scalar_to_descriptor_type (parmse->expr, - gfc_expr_attr (e)); + 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))) @@ -939,7 +993,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, gfc_conv_descriptor_data_set (&block, ctree, tmp); } else - class_array_data_assign (&block, ctree, parmse->expr, false); + class_array_data_assign (&block, ctree, parmse->expr, false, + e->rank, gfc_expr_attr (e)); } else { @@ -961,7 +1016,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr), gfc_conv_descriptor_data_get (ctree)); else - class_array_data_assign (&parmse->post, parmse->expr, ctree, true); + class_array_data_assign (&parmse->post, parmse->expr, ctree, true, + e->rank, gfc_expr_attr (e)); } else gfc_add_modify (&parmse->post, parmse->expr, ctree); @@ -3817,8 +3873,8 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) { tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, dim), - gfc_conv_descriptor_lbound_get (desc, dim)); + gfc_conv_descriptor_extent_get (desc, dim), + gfc_index_one_node); tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, GFC_TYPE_ARRAY_LBOUND (type, n), tmp); @@ -4370,7 +4426,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; @@ -4450,7 +4506,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); @@ -4546,15 +4602,6 @@ class_array_fcn: offset = gfc_index_zero_node; for (n = 0; n < dimen; n++) { - tmp = gfc_conv_descriptor_ubound_get (parmse->expr, - gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&parmse->pre, - parmse->expr, - gfc_rank_cst[n], - tmp); gfc_conv_descriptor_lbound_set (&parmse->pre, parmse->expr, gfc_rank_cst[n], @@ -5240,7 +5287,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); } @@ -5907,6 +5955,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. */ @@ -5942,6 +5992,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. */ @@ -6208,7 +6260,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, se->expr = gfc_evaluate_now (se->expr, &se->pre); tmp = gfc_class_data_get (se->expr); tmp = gfc_conv_scalar_to_descriptor (se, tmp, - CLASS_DATA (expr->value.function.esym->result)->attr); + CLASS_DATA (expr->value.function.esym->result)->attr, + &expr->ts); } final_fndecl = gfc_class_vtab_final_get (se->expr); @@ -6664,7 +6717,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) tree gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, - bool array, bool pointer, bool procptr) + bool array, bool pointer, bool procptr, int rank) { gfc_se se; @@ -6701,7 +6754,8 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, tree ctor; /* Arrays need special handling. */ if (pointer) - ctor = gfc_build_null_descriptor (type); + ctor = gfc_build_null_descriptor (type, rank, + GFC_ATTRIBUTE_POINTER, ts); /* Special case assigning an array to zero. */ else if (is_zero_initializer_p (expr)) ctor = build_constructor (type, NULL); @@ -6817,7 +6871,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); @@ -6934,7 +6988,6 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, for (n = 0; n < expr->rank; n++) { - tree span; tree lbound; /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9. @@ -6964,14 +7017,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, lbound = fold_convert (gfc_array_index_type, lbound); - /* Shift the bounds and set the offset accordingly. */ - tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); - span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - span, lbound); - gfc_conv_descriptor_ubound_set (&block, dest, - gfc_rank_cst[n], tmp); + /* Shift the lower_bound and set the offset accordingly. */ gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n], lbound); @@ -7451,7 +7497,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) val = gfc_conv_initializer (c->expr, &expr->ts, TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer, - cm->attr.proc_pointer); + cm->attr.proc_pointer, expr->rank); val = unshare_expr_without_location (val); /* Append it to the constructor list. */ @@ -7498,7 +7544,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) val = gfc_conv_initializer (c->expr, &cm->ts, TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer, - cm->attr.proc_pointer); + cm->attr.proc_pointer, + cm->as ? cm->as->rank : 0); val = unshare_expr_without_location (val); /* Append it to the constructor list. */ @@ -8048,19 +8095,29 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) converted in rse and now have to build the correct LHS descriptor for it. */ - tree dtype, data; + tree dtype, data, elem_len; tree offs, stride; tree lbound, ubound; /* Set dtype. */ - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_get_dtype (TREE_TYPE (desc)); - gfc_add_modify (&block, dtype, tmp); + if (expr1->ts.deferred || expr1->ts.type == BT_CLASS) + { + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_get_dtype (&expr2->ts); + gfc_add_modify (&block, dtype, tmp); + } /* Copy data pointer. */ data = gfc_conv_descriptor_data_get (rse.expr); gfc_conv_descriptor_data_set (&block, desc, data); + /* Copy element size. */ + elem_len = gfc_conv_descriptor_elem_len_get (rse.expr); + gfc_conv_descriptor_elem_len_set (&block, desc, elem_len); + + /* Set the new rank. */ + gfc_conv_descriptor_rank_set (&block, desc, expr1->rank); + /* Copy offset but adjust it such that it would correspond to a lbound of zero. */ offs = gfc_conv_descriptor_offset_get (rse.expr); @@ -8517,8 +8574,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. */ @@ -8527,7 +8584,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); @@ -8558,10 +8615,7 @@ fcncall_realloc_result (gfc_se *se, int rank) if (POINTER_TYPE_P (TREE_TYPE (desc))) desc = build_fold_indirect_ref_loc (input_location, desc); - /* Unallocated, the descriptor does not have a dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); - + /* Unallocated, set descriptor to NULL. */ res_desc = gfc_evaluate_now (desc, &se->pre); gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); se->expr = gfc_build_addr_expr (NULL_TREE, res_desc); @@ -8583,19 +8637,10 @@ fcncall_realloc_result (gfc_se *se, int rank) for (n = 0 ; n < rank; n++) { tree tmp1; - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, tmp1); - tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, tmp1); - tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, tmp1); + tmp = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[n]); + tmp1 = gfc_conv_descriptor_extent_get (res_desc, gfc_rank_cst[n]); tmp = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, - gfc_index_zero_node); + boolean_type_node, tmp, tmp1); tmp = gfc_evaluate_now (tmp, &se->post); zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, tmp, @@ -8708,7 +8753,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 @@ -9295,7 +9341,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 81678428f18..ab6252e5e9d 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1152,10 +1152,12 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, argse.string_length); else res_var = gfc_create_var (type, "caf_res"); - dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr); + dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr, + &array_expr->ts); dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); } - argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); + argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr, + &array_expr->ts); argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); } else @@ -1178,9 +1180,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that has the wrong type if component references are done. */ gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : array_expr->rank, - type)); + gfc_get_dtype (&array_expr->ts)); if (has_vector) { vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2); @@ -1200,6 +1200,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, } gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type, NULL_TREE, false, true, false, + &array_expr->ts, NULL_TREE, &array_expr->where); res_var = se->ss->info->data.array.descriptor; dst_var = gfc_build_addr_expr (NULL_TREE, res_var); @@ -1276,7 +1277,8 @@ conv_caf_send (gfc_code *code) { gfc_clear_attr (&attr); gfc_conv_expr (&lhs_se, lhs_expr); lhs_type = TREE_TYPE (lhs_se.expr); - lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr); + lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr, + &lhs_expr->ts); lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); } else @@ -1302,9 +1304,7 @@ conv_caf_send (gfc_code *code) { lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : lhs_expr->rank, - lhs_type)); + gfc_get_dtype (&lhs_expr->ts)); if (has_vector) { vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); @@ -1349,7 +1349,8 @@ conv_caf_send (gfc_code *code) { gfc_conv_expr (&rhs_se, rhs_expr); if (!gfc_is_coindexed (rhs_expr) && rhs_expr->ts.type != BT_CHARACTER) rhs_se.expr = fold_convert (lhs_type , rhs_se.expr); - rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr); + rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr, + &rhs_expr->ts); rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr); } else @@ -1358,7 +1359,6 @@ conv_caf_send (gfc_code *code) { vector bounds separately. */ gfc_array_ref *ar, ar2; bool has_vector = false; - tree tmp2; if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr)) { @@ -1374,11 +1374,8 @@ conv_caf_send (gfc_code *code) { /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that has the wrong type if component references are done. */ tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); - tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : rhs_expr->rank, - tmp2)); + gfc_get_dtype (&rhs_expr->ts)); if (has_vector) { rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2); @@ -1454,7 +1451,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; gfc_expr *distance = expr->value.function.actual->next->next->expr; @@ -1622,10 +1619,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, @@ -1747,12 +1741,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, @@ -1846,7 +1839,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)); } @@ -1862,12 +1856,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree type; tree bound; tree tmp; - tree cond, cond1, cond3, cond4, size; - tree ubound; + tree cond; tree lbound; + tree extent; gfc_se argse; + gfc_ref *ref; + gfc_array_ref *ar; gfc_array_spec * as; - bool assumed_rank_lb_one; + bool lb_one; arg = expr->value.function.actual; arg2 = arg->next; @@ -1901,13 +1897,20 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) /* TODO: don't re-evaluate the descriptor on each iteration. */ /* Get a descriptor for the first parameter. */ gfc_init_se (&argse, NULL); + argse.data_not_needed = 1; gfc_conv_expr_descriptor (&argse, arg->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; - as = gfc_get_full_arrayspec_from_expr (arg->expr); + for (ref = arg->expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) + break; + + ar = ref ? &ref->u.ar : NULL; + as = ar ? ar->as : NULL; if (INTEGER_CST_P (bound)) { @@ -1931,7 +1934,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, @@ -1940,17 +1943,21 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) } /* Take care of the lbound shift for assumed-rank arrays, which are - nonallocatable and nonpointers. Those has a lbound of 1. */ - assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK - && ((arg->expr->ts.type != BT_CLASS - && !arg->expr->symtree->n.sym->attr.allocatable - && !arg->expr->symtree->n.sym->attr.pointer) - || (arg->expr->ts.type == BT_CLASS - && !CLASS_DATA (arg->expr)->attr.allocatable - && !CLASS_DATA (arg->expr)->attr.class_pointer)); - - ubound = gfc_conv_descriptor_ubound_get (desc, bound); + nonallocatable and nonpointers. Those have a lbound of 1. */ + lb_one = as && as->type == AS_ASSUMED_RANK + && ((arg->expr->ts.type != BT_CLASS + && !arg->expr->symtree->n.sym->attr.allocatable + && !arg->expr->symtree->n.sym->attr.pointer) + || (arg->expr->ts.type == BT_CLASS + && !CLASS_DATA (arg->expr)->attr.allocatable + && !CLASS_DATA (arg->expr)->attr.class_pointer)); + lb_one = lb_one || ar == NULL || ar->type != AR_FULL; + + if (ref && ref->next) + lb_one = true; + lbound = gfc_conv_descriptor_lbound_get (desc, bound); + extent = gfc_conv_descriptor_extent_get (desc, bound); /* 13.14.53: Result value for LBOUND @@ -1973,82 +1980,43 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) not have size zero and has value zero if dimension DIM has size zero. */ - if (!upper && assumed_rank_lb_one) + if (!upper && lb_one) se->expr = gfc_index_one_node; - else if (as) + else if (lb_one) + se->expr = extent; + else { - tree stride = gfc_conv_descriptor_stride_get (desc, bound); - - cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - - if (upper) + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + if (!upper) { - tree cond5; - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond3, cond4); - cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - gfc_index_one_node, lbound); - cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond4, cond5); + tree cond2; - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond5); + if (as->type == AS_ASSUMED_SIZE) + cond2 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank - 1)); + else + cond2 = boolean_false_node; - if (assumed_rank_lb_one) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, gfc_index_one_node); - } - else - tmp = ubound; + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond, cond2); se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - tmp, gfc_index_zero_node); + lbound, gfc_index_one_node); } else { - if (as->type == AS_ASSUMED_SIZE) - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - bound, build_int_cst (TREE_TYPE (bound), - arg->expr->rank - 1)); - else - cond = boolean_false_node; - - cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond3, cond4); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond1); - + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, extent, lbound); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, gfc_index_one_node); se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - lbound, gfc_index_one_node); - } - } - else - { - if (upper) - { - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - se->expr = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, size, - gfc_index_one_node); - se->expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, se->expr, - gfc_index_zero_node); + tmp, gfc_index_zero_node); } - else - se->expr = gfc_index_one_node; } type = gfc_typenode_for_spec (&expr->ts); @@ -3221,7 +3189,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. */ @@ -3303,7 +3271,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. */ @@ -3437,7 +3405,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) @@ -3658,7 +3626,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); @@ -3899,7 +3867,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]) @@ -4355,7 +4323,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]) @@ -5830,100 +5798,182 @@ gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) static void -gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) +gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr, bool shape) { - gfc_actual_arglist *actual; - tree arg1; + gfc_actual_arglist *arg; + gfc_actual_arglist *arg2; + tree desc; tree type; - tree fncall0; - tree fncall1; + tree exit_label, tmp, cond, extent, size; + tree arg2_var = NULL_TREE, present = NULL_TREE, bound = NULL_TREE; gfc_se argse; + gfc_array_spec * as; + stmtblock_t loop; + bool optional; - gfc_init_se (&argse, NULL); - actual = expr->value.function.actual; + arg = expr->value.function.actual; + arg2 = arg->next; - if (actual->expr->ts.type == BT_CLASS) - gfc_add_class_array_ref (actual->expr); + optional = !shape && arg2->expr && arg2->expr->expr_type == EXPR_VARIABLE + && arg2->expr->symtree->n.sym->attr.optional && !arg2->expr->ref; - argse.want_pointer = 1; + /* For SIZE, the dim= variable can be an optional, which requires special + handling. */ + + if (se->ss) + { + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (shape); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->info->expr == expr); + gfc_advance_se_ss_chain (se); + bound = se->loop->loopvar[0]; + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, bound, + se->loop->from[0]); + } + else if (arg2->expr) + { + /* use the passed argument. */ + gcc_assert (!shape); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + arg2_var = argse.expr; + /* Convert from one based to zero based. */ + if (!optional) + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, arg2_var, + gfc_index_one_node); + } + + if (!se->ss && (!arg2->expr || optional)) + { + /* SIZE without dim= - or with optional dim. */ + gcc_assert (!shape); + bound = gfc_create_var (integer_type_node, NULL); + + if (optional) + present = gfc_conv_expr_present (arg2->expr->symtree->n.sym); + } + + /* TODO: don't re-evaluate the descriptor on each iteration. */ + /* Get a descriptor for the first parameter. */ + gfc_init_se (&argse, NULL); argse.data_not_needed = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); + gfc_conv_expr_descriptor (&argse, arg->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - arg1 = gfc_evaluate_now (argse.expr, &se->pre); - /* Build the call to size0. */ - fncall0 = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, arg1); + desc = argse.expr; - actual = actual->next; + as = gfc_get_full_arrayspec_from_expr (arg->expr); + + if (arg2_var != NULL_TREE && INTEGER_CST_P (arg2_var) + && (((!as || as->type != AS_ASSUMED_RANK) + && wi::geu_p (bound, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))) + || wi::gtu_p (bound, GFC_MAX_DIMENSIONS))) + gfc_error ("'dim' argument of SIZE intrinsic at %L is not a valid " + "dimension index", &expr->where); - if (actual->expr) + if (arg2_var != NULL_TREE + && (!INTEGER_CST_P (arg2_var) || (as && as->type == AS_ASSUMED_RANK))) { - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, actual->expr, - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + arg2_var = gfc_evaluate_now (arg2_var, &se->pre); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + arg2_var, + build_int_cst (TREE_TYPE (arg2_var), 1)); + if (as && as->type == AS_ASSUMED_RANK) + tmp = gfc_conv_descriptor_rank (desc); + else + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + arg2_var, + fold_convert (TREE_TYPE (arg2_var), tmp)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + boolean_type_node, cond, tmp); + if (optional) + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present, cond); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + gfc_msg_fault); + } + } - /* Unusually, for an intrinsic, size does not exclude - an optional arg2, so we must test for it. */ - if (actual->expr->expr_type == EXPR_VARIABLE - && actual->expr->symtree->n.sym->attr.dummy - && actual->expr->symtree->n.sym->attr.optional) - { - tree tmp; - /* Build the call to size1. */ - fncall1 = build_call_expr_loc (input_location, - gfor_fndecl_size1, 2, - arg1, argse.expr); + extent = gfc_conv_descriptor_extent_get (desc, bound); + type = gfc_typenode_for_spec (&expr->ts); - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - argse.data_not_needed = 1; - gfc_conv_expr (&argse, actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - argse.expr, null_pointer_node); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->expr = fold_build3_loc (input_location, COND_EXPR, - pvoid_type_node, tmp, fncall1, fncall0); - } - else - { - se->expr = NULL_TREE; - argse.expr = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - argse.expr, gfc_index_one_node); - } - } - else if (expr->value.function.actual->expr->rank == 1) + if (shape || (arg2->expr && !optional)) { - argse.expr = gfc_index_zero_node; - se->expr = NULL_TREE; + se->expr = convert (type, extent); + return; } - else - se->expr = fncall0; - if (se->expr == NULL_TREE) - { - tree ubound, lbound; + /* bound = 0; - or: bound = present ? arg2_var - 1 : 0; + size = 1; + for (;;) + { + if (bound >= rank) - or: if (bound >= (present ? arg2_var : rank)) + goto exit; + size = size * extent[bound]; + bound++; + } + exit: */ - arg1 = build_fold_indirect_ref_loc (input_location, - arg1); - ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); - lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); - se->expr = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - se->expr = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - se->expr, gfc_index_one_node); - se->expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, se->expr, - gfc_index_zero_node); + /* bound = 0; - or: bound = present ? arg2_var : 0; */ + tmp = build_int_cst (integer_type_node, 0); + if (optional) + { + tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR, + integer_type_node, + fold_convert (integer_type_node, arg2_var), + build_int_cst (integer_type_node, 1)); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, + present, tmp2, tmp); } + gfc_add_modify (&se->pre, bound, tmp); - type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, se->expr); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + size = gfc_create_var (gfc_array_index_type, NULL); + gfc_add_modify (&se->pre, size, gfc_index_one_node); + + gfc_init_block (&loop); + + /* Exit condition: if (bound >= rank-1) goto exit_label. */ + tmp = fold_convert (integer_type_node, gfc_conv_descriptor_rank (desc)); + if (optional) + tmp = fold_build3_loc (input_location, COND_EXPR, + integer_type_node, present, + fold_convert (integer_type_node, arg2_var), tmp); + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, bound, + tmp); + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&loop, tmp); + + gfc_add_modify (&loop, size, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, extent)); + + gfc_add_modify (&loop, bound, + fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + bound, + build_int_cst (integer_type_node, 1))); + + tmp = gfc_finish_block (&loop); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&se->pre, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = convert (type, size); } @@ -5953,8 +6003,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) gfc_se argse; tree source_bytes; tree tmp; - tree lower; - tree upper; tree byte_size; int n; @@ -5978,10 +6026,7 @@ 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_elem_len_get (tmp); byte_size = fold_convert (gfc_array_index_type, tmp); } else if (arg->ts.type == BT_CLASS) @@ -6056,9 +6101,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); - lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var); - upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var); - tmp = gfc_conv_array_extent_dim (lower, upper, NULL); + tmp = gfc_conv_descriptor_extent_get (argse.expr, loop_var); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, tmp, source_bytes); gfc_add_modify (&body, source_bytes, tmp); @@ -6084,9 +6127,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) { tree idx; idx = gfc_rank_cst[n]; - lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); - upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); - tmp = gfc_conv_array_extent_dim (lower, upper, NULL); + tmp = gfc_conv_descriptor_extent_get (argse.expr, idx); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, tmp, source_bytes); gfc_add_modify (&argse.pre, source_bytes, tmp); @@ -6483,7 +6524,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); @@ -6762,6 +6804,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) present. */ arg1se.descriptor_only = 1; gfc_conv_expr_lhs (&arg1se, arg1->expr); + if (arg1->expr->rank == -1) { tmp = gfc_conv_descriptor_rank (arg1se.expr); @@ -6770,7 +6813,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } else tmp = gfc_rank_cst[arg1->expr->rank - 1]; - tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); + + tmp = gfc_conv_descriptor_sm_get (arg1se.expr, tmp); nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); @@ -7279,7 +7323,7 @@ conv_isocbinding_subroutine (gfc_code *code) gfc_se fptrse; gfc_se shapese; gfc_ss *shape_ss; - tree desc, dim, tmp, stride, offset; + tree desc, dim, tmp, sm, offset; stmtblock_t body, block; gfc_loopinfo loop; gfc_actual_arglist *arg = code->ext.actual; @@ -7319,11 +7363,12 @@ conv_isocbinding_subroutine (gfc_code *code) gfc_add_block_to_block (&block, &fptrse.pre); desc = fptrse.expr; - /* Set data value, dtype, and offset. */ + /* 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_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. */ @@ -7334,15 +7379,17 @@ 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); shapese.ss = shape_ss; - stride = gfc_create_var (gfc_array_index_type, "stride"); + sm = gfc_create_var (gfc_array_index_type, "sm"); offset = gfc_create_var (gfc_array_index_type, "offset"); - gfc_add_modify (&block, stride, gfc_index_one_node); + tmp = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + gfc_conv_descriptor_elem_len_set (&block, desc, tmp); + gfc_add_modify (&block, sm, fold_convert (TREE_TYPE (sm), tmp)); gfc_add_modify (&block, offset, gfc_index_zero_node); /* Loop body. */ @@ -7351,23 +7398,28 @@ conv_isocbinding_subroutine (gfc_code *code) dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, loop.loopvar[0], loop.from[0]); - /* Set bounds and stride. */ + /* Set bounds and stride multiplier. */ gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); - gfc_conv_descriptor_stride_set (&body, desc, dim, stride); + gfc_conv_descriptor_sm_set (&body, desc, dim, sm); gfc_conv_expr (&shapese, arg->next->next->expr); gfc_add_block_to_block (&body, &shapese.pre); - gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); + gfc_conv_descriptor_extent_set (&body, desc, dim, shapese.expr); gfc_add_block_to_block (&body, &shapese.post); - /* Calculate offset. */ + /* Calculate offset. Change from the stride multiplier back to the + stride. */ + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, sm, + fold_convert (TREE_TYPE (sm), tmp)); gfc_add_modify (&body, offset, fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, offset, stride)); - /* Update stride. */ - gfc_add_modify (&body, stride, + gfc_array_index_type, offset, tmp)); + + /* Update stride multiplier. */ + gfc_add_modify (&body, sm, fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, + gfc_array_index_type, sm, fold_convert (gfc_array_index_type, shapese.expr))); /* Finish scalarization loop. */ @@ -8263,12 +8315,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_scale (se, expr); break; + case GFC_ISYM_SHAPE: + gfc_conv_intrinsic_size (se, expr, true); + break; + case GFC_ISYM_SIGN: gfc_conv_intrinsic_sign (se, expr); break; case GFC_ISYM_SIZE: - gfc_conv_intrinsic_size (se, expr); + gfc_conv_intrinsic_size (se, expr, false); break; case GFC_ISYM_SIZEOF: @@ -8575,6 +8631,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) case GFC_ISYM_LBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_LCOBOUND: + case GFC_ISYM_SHAPE: case GFC_ISYM_THIS_IMAGE: break; @@ -8593,8 +8650,9 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) if (expr->value.function.actual->expr->ts.type == BT_CLASS) gfc_add_class_array_ref (expr->value.function.actual->expr); - /* The two argument version returns a scalar. */ - if (expr->value.function.actual->next->expr) + /* The two argument version returns a scalar, except for SHAPE. */ + if (expr->value.function.isym->id != GFC_ISYM_SHAPE + && expr->value.function.actual->next->expr) return ss; return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); @@ -8677,7 +8735,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) case GFC_ISYM_PARITY: case GFC_ISYM_PRODUCT: case GFC_ISYM_SUM: - case GFC_ISYM_SHAPE: case GFC_ISYM_SPREAD: case GFC_ISYM_YN2: /* Ignore absent optional parameters. */ @@ -8724,6 +8781,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, case GFC_ISYM_UBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: + case GFC_ISYM_SHAPE: return gfc_walk_intrinsic_bound (ss, expr); case GFC_ISYM_TRANSFER: @@ -8800,7 +8858,8 @@ conv_co_collective (gfc_code *code) gfc_conv_expr (&argse, code->ext.actual->expr); gfc_add_block_to_block (&block, &argse.pre); gfc_add_block_to_block (&post_block, &argse.post); - array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); + array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr, + &code->ext.actual->expr->ts); array = gfc_build_addr_expr (NULL_TREE, array); } else diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 2c843497295..c4781dc39e5 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -471,14 +471,15 @@ 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); + void_type_node, 7, 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); 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, + void_type_node, 9, dt_parm_type, pvoid_type_node, pvoid_type_node, gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node, - pvoid_type_node, pvoid_type_node); + gfc_int4_type_node, pvoid_type_node, pvoid_type_node); iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("st_set_nml_var_dim")), ".w", @@ -755,16 +756,10 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) else { gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - size = gfc_conv_array_stride (array, rank); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_array_ubound (array, rank), - gfc_conv_array_lbound (array, rank)); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, size); + gfc_array_index_type, + gfc_conv_array_stride (array, rank), + gfc_conv_array_extent (array, rank)); } gcc_assert (size); @@ -1630,14 +1625,13 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, tree dt = NULL; tree string; tree tmp; - tree dtype; + tree elem_len; tree dt_parm_addr; tree decl = NULL_TREE; tree gfc_int4_type_node = gfc_get_int_type (4); - tree dtio_proc = null_pointer_node; - tree vtable = null_pointer_node; + tree dtio_proc = NULL_TREE; + tree vtable = NULL_TREE; int n_dim; - int itype; int rank = 0; gcc_assert (sym || c); @@ -1657,23 +1651,29 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, if (as) rank = as->rank; + decl = (sym) ? sym->backend_decl : c->backend_decl; if (rank) { - decl = (sym) ? sym->backend_decl : c->backend_decl; 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); + if (POINTER_TYPE_P (tmp) || TREE_CODE (tmp) == REFERENCE_TYPE) + tmp = TREE_TYPE (tmp); + tmp = TYPE_SIZE_UNIT (tmp); } + elem_len = tmp; + /* 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); @@ -1700,22 +1700,35 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, } if (ts->type == BT_CHARACTER) - tmp = ts->u.cl->backend_decl; + { + elem_len = ts->u.cl->backend_decl; + tmp = build_int_cst (gfc_charlen_type_node, ts->kind); + elem_len = fold_build2_loc (input_location, MULT_EXPR, + gfc_charlen_type_node, + elem_len, tmp); + gfc_evaluate_now (elem_len, block); + } else - tmp = build_int_cst (gfc_charlen_type_node, 0); + elem_len = fold_convert (gfc_charlen_type_node, elem_len); + if (dtio_proc == NULL_TREE) tmp = build_call_expr_loc (input_location, - iocall[IOCALL_SET_NML_VAL], 6, + iocall[IOCALL_SET_NML_VAL], 7, dt_parm_addr, addr_expr, string, build_int_cst (gfc_int4_type_node, ts->kind), - tmp, dtype); + elem_len, + build_int_cst (gfc_int4_type_node, rank), + build_int_cst (gfc_int4_type_node, ts->type)); else tmp = build_call_expr_loc (input_location, - iocall[IOCALL_SET_NML_DTIO_VAL], 8, + iocall[IOCALL_SET_NML_DTIO_VAL], 9, dt_parm_addr, addr_expr, string, build_int_cst (gfc_int4_type_node, ts->kind), - tmp, dtype, dtio_proc, vtable); + elem_len, + build_int_cst (gfc_int4_type_node, rank), + build_int_cst (integer_type_node, ts->type), + dtio_proc, vtable); gfc_add_expr_to_block (block, tmp); /* If the object is an array, transfer rank times: @@ -1727,14 +1740,14 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, iocall[IOCALL_SET_NML_VAL_DIM], 5, dt_parm_addr, build_int_cst (gfc_int4_type_node, n_dim), - gfc_conv_array_stride (decl, n_dim), gfc_conv_array_lbound (decl, n_dim), - gfc_conv_array_ubound (decl, n_dim)); + gfc_conv_array_extent (decl, n_dim), + gfc_conv_array_sm (decl, n_dim)); gfc_add_expr_to_block (block, tmp); } if (gfc_bt_struct (ts->type) && ts->u.derived->components - && dtio_proc == null_pointer_node) + && dtio_proc == NULL_TREE) { gfc_component *cmp; @@ -2097,7 +2110,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); @@ -2513,7 +2526,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-openmp.c b/gcc/fortran/trans-openmp.c index e4a2975719e..4f1a1beb8cc 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -481,12 +481,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) { gfc_add_modify (&cond_block, decl, outer); tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (decl, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (decl, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); + size = gfc_conv_descriptor_extent_get (decl, rank); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, @@ -585,12 +580,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) if (GFC_DESCRIPTOR_TYPE_P (type)) { tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); + size = gfc_conv_descriptor_extent_get (dest, rank); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, @@ -704,12 +694,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) if (GFC_DESCRIPTOR_TYPE_P (type)) { tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (src, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (src, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); + size = gfc_conv_descriptor_extent_get (dest, rank); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 5884e7a4e24..46205302218 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -291,16 +291,14 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, if (e->ts.type != BT_CLASS) { - /* Find the type of the temporary to create; we don't use the type - of e itself as this breaks for subcomponent-references in e - (where the type of e is that of the final reference, but - parmse.expr's type corresponds to the full derived-type). */ - /* TODO: Fix this somehow so we don't need a temporary of the whole - array but instead only the components referenced. */ - temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ - gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); - temptype = TREE_TYPE (temptype); - temptype = gfc_get_element_type (temptype); + /* Set the type of the temporary to create using that of + the element type of the descriptor. */ + for (tmp = parmse.expr; tmp; tmp = TREE_OPERAND (tmp, 0)) + { + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + break; + } + temptype = gfc_get_element_type (TREE_TYPE (tmp)); } else @@ -316,7 +314,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); @@ -452,7 +451,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. */ @@ -1536,7 +1535,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) { gfc_se se; - tree desc; bool cst_array_ctor; desc = sym->backend_decl; @@ -1623,11 +1621,26 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) if (unlimited) { - /* Recover the dtype, which has been overwritten by the - 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))); + /* Generate the dtype, element length and stride measures, which + have been overwritten by the assignment from an unlimited + polymorphic object. */ + tree tdesc; + tdesc = gfc_build_null_descriptor (TREE_TYPE (sym->backend_decl), + e->rank, GFC_ATTRIBUTE_OTHER, + &sym->ts); + tmp = gfc_conv_descriptor_dtype (tdesc); + gfc_add_modify (&se.pre, + gfc_conv_descriptor_dtype (sym->backend_decl), tmp); + + tmp = gfc_conv_descriptor_elem_len_get (tdesc); + gfc_conv_descriptor_elem_len_set (&se.pre, sym->backend_decl, tmp); + + for (n = 0; n < e->rank; n++) + { + gfc_conv_descriptor_sm_get (tdesc, gfc_rank_cst[n]); + gfc_conv_descriptor_sm_set (&se.pre, sym->backend_decl, + gfc_rank_cst[n], tmp); + } } gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), @@ -1665,12 +1678,16 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) dim = gfc_rank_cst[n]; tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - gfc_conv_descriptor_stride_get (desc, dim), + gfc_conv_descriptor_sm_get (desc, dim), gfc_conv_descriptor_lbound_get (desc, dim)); offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, offset, tmp); } + tmp = fold_convert (gfc_array_index_type, + gfc_conv_descriptor_elem_len_get (desc)); + offset = fold_build2_loc (input_location, FLOOR_DIV_EXPR, + gfc_array_index_type, offset, tmp); if (need_len_assign) { if (e->symtree @@ -3424,7 +3441,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); @@ -3524,7 +3541,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. */ @@ -3643,7 +3660,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++) @@ -3988,7 +4005,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; @@ -4507,7 +4524,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. */ @@ -4677,7 +4694,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); @@ -5128,7 +5145,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 6a89b30e3bf..89850be5ac6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" /* For rest_of_decl_compilation. */ #include "trans-types.h" #include "trans-const.h" +#include "trans-array.h" #include "dwarf2out.h" /* For struct array_descr_info. */ @@ -68,7 +69,6 @@ tree gfc_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)]; @@ -864,7 +864,6 @@ gfc_init_types (void) char name_buf[18]; int index; tree type; - unsigned n; /* Create and name the types. */ #define PUSH_TYPE(name, node) \ @@ -951,16 +950,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; - gfc_max_array_element_size - = wide_int_to_tree (size_type_node, - wi::mask (n, UNSIGNED, - TYPE_PRECISION (size_type_node))); - 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); @@ -1199,21 +1188,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 @@ -1225,10 +1218,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: - 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 + 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 @@ -1381,19 +1374,19 @@ gfc_get_desc_dim_type (void) TYPE_NAME (type) = get_identifier ("descriptor_dimension"); TYPE_PACKED (type) = 1; - /* Consists of the stride, lbound and ubound members. */ + /* Consists of the lower_bound, extent and stride-multiplier members. */ decl = gfc_add_field_to_struct_1 (type, - get_identifier ("stride"), + get_identifier ("lower_bound"), gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; decl = gfc_add_field_to_struct_1 (type, - get_identifier ("lbound"), + get_identifier ("extent"), gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; decl = gfc_add_field_to_struct_1 (type, - get_identifier ("ubound"), + get_identifier ("sm"), gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; @@ -1412,100 +1405,44 @@ gfc_get_desc_dim_type (void) unknown cases abort. */ tree -gfc_get_dtype_rank_type (int rank, tree etype) +gfc_get_dtype (gfc_typespec *ts) { - tree size; - int n; - HOST_WIDE_INT i; - tree tmp; - tree dtype; + int type; + tree int16_type_node + = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (16)); - 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; + else 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; - } - - gcc_assert (rank <= GFC_DTYPE_RANK_MASK); - size = TYPE_SIZE_UNIT (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"); - - i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; + type = GFC_TYPE_OTHER; } - 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. */ - - return dtype; -} - - -tree -gfc_get_dtype (tree type) -{ - tree dtype; - tree etype; - int rank; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); - - if (GFC_TYPE_ARRAY_DTYPE (type)) - return GFC_TYPE_ARRAY_DTYPE (type); - - rank = GFC_TYPE_ARRAY_RANK (type); - etype = gfc_get_element_type (type); - dtype = gfc_get_dtype_rank_type (rank, etype); - - GFC_TYPE_ARRAY_DTYPE (type) = dtype; - return dtype; + return build_int_cst (int16_type_node, type); } @@ -1727,9 +1664,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; @@ -1755,20 +1698,44 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, /* Add the data member as the first element of the descriptor. */ decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("data"), + get_identifier ("base_addr"), (restricted ? prvoid_type_node : ptr_type_node), &chain); - /* Add the base component. */ + /* Add the elem_len component. */ decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("offset"), - gfc_array_index_type, &chain); + get_identifier ("elem_len"), + size_type_node, &chain); + TREE_NO_WARNING (decl) = 1; + + /* Add the version component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("version"), + integer_type_node, &chain); + TREE_NO_WARNING (decl) = 1; + + /* Add the rank component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("rank"), + int8_type_node, &chain); + TREE_NO_WARNING (decl) = 1; + + /* Add the attribute component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("attribute"), + int8_type_node, &chain); TREE_NO_WARNING (decl) = 1; - /* Add the dtype component. */ + /* Add the type component. */ decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("dtype"), + get_identifier ("type"), + int16_type_node, &chain); + TREE_NO_WARNING (decl) = 1; + + /* Add the offset component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("offset"), gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; @@ -3112,6 +3079,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) tree etype, ptype, field, t, base_decl; tree data_off, dim_off, dim_size, elem_size; tree lower_suboff, upper_suboff, stride_suboff; + tree type_fields; if (! GFC_DESCRIPTOR_TYPE_P (type)) { @@ -3170,11 +3138,10 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) elem_size = GFC_TYPE_ARRAY_SPAN (type); else elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); - field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); + type_fields = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); + field = gfc_data_field_from_base_field (type_fields); data_off = byte_position (field); - field = DECL_CHAIN (field); - field = DECL_CHAIN (field); - field = DECL_CHAIN (field); + field = gfc_dimension_field_from_base_field (type_fields); dim_off = byte_position (field); dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field))); field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field))); diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index c518cc18926..270b7a31d79 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -97,8 +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_rank_type (int, tree); -tree gfc_get_dtype (tree); +tree gfc_get_dtype (gfc_typespec *); tree gfc_get_ppc_type (gfc_component *); tree gfc_get_caf_vector_type (int dim); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 28d1341cc7e..62c4f158378 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -935,7 +935,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, to zero. */ gfc_clear_attr (&attr); 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); gcc_assert (se.post.head == NULL_TREE); } } @@ -976,7 +976,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, to zero. */ gfc_clear_attr (&attr); 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); } gcc_assert (se.post.head == NULL_TREE); } @@ -1057,7 +1057,7 @@ gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, { gfc_clear_attr (&attr); gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); + array = gfc_conv_scalar_to_descriptor (&se, array, attr, &comp->ts); gfc_add_block_to_block (&block2, &se.pre); gcc_assert (se.post.head == NULL_TREE); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 512615ab1e4..d1cdbaccc0a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -441,7 +441,11 @@ 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); /* trans-expr.c */ @@ -565,7 +569,8 @@ bool gfc_get_module_backend_decl (gfc_symbol *); tree gfc_get_symbol_decl (gfc_symbol *); /* Build a static initializer. */ -tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool); +tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, + bool, int); /* Assign a default initializer to a derived type. */ void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool); diff --git a/gcc/testsuite/ChangeLog.fortran-dev b/gcc/testsuite/ChangeLog.fortran-dev new file mode 100644 index 00000000000..f394be14306 --- /dev/null +++ b/gcc/testsuite/ChangeLog.fortran-dev @@ -0,0 +1,129 @@ +2016-09-07 Dominique Dhumieres <dominiq@lps.ens.fr> + + PR fortran/48298 + * gfortran.dg/assumed_rank_12.f90: Correct tree scan. + * gfortran.dg/assumed_type_2.f90: Correct tree scans. + * gfortran.dg/coarray_lib_comm_1.f90: Likewise. + * gfortran.dg/coarray_lib_this_image_2.f90: Likewise. + * gfortran.dg/coarray_lock_7.f90: Likewise. + * gfortran.dg/coarray_stat_function.f90: Likewise. + * gfortran.dg/no_arg_check_2.f90: Likewise. + * gfortran.dg/pr32921.f: Likewise. + +2016-09-07 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/array_section_2.f90: Remove invocation of cleanup + tree dump. + * gfortran.dg/class_allocate_14.f90: Likewise. + * gfortran.dg/iso-ts-29113_2.f90: Likewise. + * gfortran.dg/pr32921.f: Likewise. + +2014-06-03 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/pr48636.f90 : Change the expected numbers of + 'phi predicate' predicate from 5 to 7. + * gfortran.dg/assign_10.f90 : Change the expected numbers of + 'parm' predicate from 32 to 30. + * gfortran.dg/transpose_optimization_2.f90 : Change the + expected numbers of 'parm' predicate from 102 to 90. + +2014-05-24 Dominique d'Humieres <dominiq@lps.ens.fr> + + * ChangeLog: Remove missing changes. + * gfortran.dg/coarray_12.f90: Adjust regexps. + * gfortran.dg/coarray_31.f90: Likewise. + * gfortran.dg/coarray_lib_alloc_2.f90: Likewise. + +2014-05-24 Dominique d'Humieres <dominiq@lps.ens.fr> + + * gfortran.dg/assign_10.f90: Adjust regexps. + * gfortran.dg/assumed_rank_12.f90: Likewise. + * gfortran.dg/coarray_lib_alloc_3.f90: Likewise. + * gfortran.dg/coarray_lib_this_image_1.f90: Likewise. + * gfortran.dg/coarray_lib_this_image_2.f90: Likewise. + * gfortran.dg/coarray_lib_token_4.f90: Likewise. + * gfortran.dg/coarray_poly_5.f90: Likewise. + * gfortran.dg/coarray_poly_6.f90: Likewise. + * gfortran.dg/coarray_poly_7.f90: Likewise. + * gfortran.dg/coarray_poly_8.f90: Likewise. + * gfortran.dg/contiguous_3.f90: Likewise. + * gfortran.dg/finalize_10.f90: Likewise. + * gfortran.dg/finalize_18.f90: Likewise. + * gfortran.dg/realloc_on_assign_18.f90: Likewise. + * gfortran.dg/transpose_optimization_2.f90: Likewise. + +2013-06-03 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/assumed_rank_14.f90: Renamed from assumed_rank_13.f90. + +2013-05-06 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/assumed_rank_13.f90: New. + * gfortran.dg/array_section_2.f90: Remove tree-dump check. + * gfortran.dg/assign_10.f90: Update dump-times. + * gfortran.dg/transpose_optimization_2.f90: Ditto. + * gfortran.dg/coarray_12.f90: Update dump pattern. + * gfortran.dg/coarray_30.f90: Ditto. + * gfortran.dg/intrinsic_size_3.f90: Ditto. + +2013-05-02 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/iso-ts-29113_2.f90: Update scan-dump. + +2013-04-30 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/iso-ts-29113_2.f90: New. + * gfortran.dg/iso-ts-29113_1_c.c: Enable type check. + * gfortran.dg/assumed_rank_12.f90: Update scan-dump. + * gfortran.dg/c_loc_test_22.f90: Ditto. + * gfortran.dg/class_allocate_14.f90: Ditto. + +2013-04-25 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/assign_10.f90: Update scan dump times. + * gfortran.dg/associate_11.f90: Ditto. + * gfortran.dg/assumed_rank_10.f90: Ditto. + * gfortran.dg/assumed_rank_12.f90: Ditto. + * gfortran.dg/assumed_type_2.f90: Ditto. + * gfortran.dg/class_allocate_14.f90: Ditto. + * gfortran.dg/intrinsic_size_3.f90: Ditto. + * gfortran.dg/no_arg_check_2.f90: Ditto. + * gfortran.dg/transpose_optimization_2.f90: Ditto. + * gfortran.dg/iso-ts-29113_1.f90: New. + * gfortran.dg/iso-ts-29113_1_c.c: New. + +2013-03-31 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/c_f_pointer_tests.f90: Move to trunk version. + +2012-07-20 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/c_f_pointer_tests_3.f90: Update scan-tree-dump + pattern. + +2012-07-15 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/array_section_2.f90: Update scan-tree-dump pattern. + +2012-03-12 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/assign_10.f90: Update scan-tree-dump-times. + * gfortran.dg/internal_pack_4.f90: Ditto. + +2012-03-12 Tobias Burnus <burnus@net-b.de> + + * assumed_type_2.f90: Change "data" to "base_addr" in + scan-tree-dump. + * block_2.f08: Ditto. + * coarray_lib_token_2.f90: Ditto. + * coarray_lib_token_3.f90: Ditto. + * coarray_lib_token_4.f90: Ditto. + * pr43984.f90: Ditto. + +2012-03-12 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/coarray_12.f90: Update scan-tree-dump-times. + * gfortran.dg/contiguous_3.f90: Ditto. + * gfortran.dg/array_section_2.f90: Ditto. + * gfortran.dg/transpose_optimization_2.f90: Ditto. + * gfortran.dg/pr32921.f: Ditto. diff --git a/gcc/testsuite/gfortran.dg/array_section_2.f90 b/gcc/testsuite/gfortran.dg/array_section_2.f90 index 272f0e5834e..dab735bc907 100644 --- a/gcc/testsuite/gfortran.dg/array_section_2.f90 +++ b/gcc/testsuite/gfortran.dg/array_section_2.f90 @@ -1,11 +1,14 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } ! ! PR38033 - size(a) was not stabilized correctly and so the expression was ! evaluated twice outside the loop and then within the scalarization loops. ! ! Contributed by Thomas Bruel <tmbdev@gmail.com> ! +! Note: With the new array descriptor, which uses extent directly and inlined +! SIZE, this is no longer simply testable in the dump. +! (Before, the code had a -fdump-tree-original check.) +! program test integer, parameter :: n = 100 real, pointer :: a(:),temp(:) ! pointer or allocatable have the same effect diff --git a/gcc/testsuite/gfortran.dg/assign_10.f90 b/gcc/testsuite/gfortran.dg/assign_10.f90 index 58124b69b78..1d006610721 100644 --- a/gcc/testsuite/gfortran.dg/assign_10.f90 +++ b/gcc/testsuite/gfortran.dg/assign_10.f90 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-options "-O3 -fdump-tree-original" } +! { dg-options "-fdump-tree-original" } ! Tests the fix for PR33850, in which one of the two assignments ! below would produce an unnecessary temporary for the index ! expression, following the fix for PR33749. @@ -23,5 +23,5 @@ end ! cases will all yield a temporary, so that atmp appears 18 times. ! Note that it is the kind conversion that generates the temp. ! -! { dg-final { scan-tree-dump-times "parm" 18 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 18 "original" } } +! { dg-final { scan-tree-dump-times "parm" 30 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 26 "original" } } diff --git a/gcc/testsuite/gfortran.dg/associate_11.f90 b/gcc/testsuite/gfortran.dg/associate_11.f90 index 3ef31f48fa1..d640ad0a2d0 100644 --- a/gcc/testsuite/gfortran.dg/associate_11.f90 +++ b/gcc/testsuite/gfortran.dg/associate_11.f90 @@ -21,4 +21,4 @@ contains end subroutine foo end program bug -! { dg-final { scan-tree-dump-times "foo ..integer.kind=4..0:. . restrict. a.data.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo ..integer.kind=4..0:. . restrict. a.base_addr.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 index 4a6b9088de0..d1f04e0dbfa 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 @@ -99,7 +99,7 @@ end program test ! We should have exactly one copy back per variable ! -! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } } -! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } } -! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } } -! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.base_addr;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 index 873498f82d7..840ab0ddc37 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 @@ -16,5 +16,4 @@ function f() result(res) end function f end -! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" "original" } } - +! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.type = 1025;.*desc.0.base_addr = .void .. D.\[0-9\]+;.*desc.0.elem_len = 4;.*desc.0.version = 1;.*desc.0.rank = 0;.*desc.0.attribute = 1;.*sub \\(&desc.0\\);.*D.\[0-9\]+ = .integer.kind=4. .. desc.0.base_addr;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_14.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_14.f90 new file mode 100644 index 00000000000..2b928e0c281 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_14.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! Ensure that SIZE/SHAPE/UBOUND/LBOUND work properly with +! assumed-rank arrays for scalars and assumed-size arrays +! +program main + implicit none + integer :: A(2,2) + integer :: B + call foo(A) + call test2(B) +contains + subroutine foo(x) + integer :: x(2,*) + call bar(x) + end subroutine foo + subroutine bar(y) + integer :: y(..) +! print *, rank(y) ! 2 +! print *, lbound(y) ! 1 1 +! print *, ubound(y) ! 2 -1 +! print *, shape(y) ! 2 -1 +! print *, size(y) ! -2 + if (rank(y) /= 2) call abort () + if (any (lbound(y) /= [1, 1])) call abort + if (any (ubound(y) /= [2,-1])) call abort + if (any (shape(y) /= [2,-1])) call abort + if (size(y,1) /= 2) call abort + if (size(y,2) /= -1) call abort + if (size(y) /= -2) call abort + end subroutine bar + subroutine test2(z) + integer :: z(..) + if (rank(z) /= 0) call abort() ! 1 + if (size(lbound(z)) /= 0) call abort() ! zero-sized array + if (size(ubound(z)) /= 0) call abort() ! zero-sized array + if (size(shape(z)) /= 0) call abort() ! zero-sized array + if (size(z) /= 1) call abort() ! 1 + end subroutine test2 +end program main diff --git a/gcc/testsuite/gfortran.dg/assumed_type_2.f90 b/gcc/testsuite/gfortran.dg/assumed_type_2.f90 index f1a20747884..9a3388f3f3a 100644 --- a/gcc/testsuite/gfortran.dg/assumed_type_2.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_type_2.f90 @@ -150,23 +150,24 @@ end ! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.base_addr" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 3 "original" } } ! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.base_addr" 1 "original" } } ! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.base_addr = \\(void .\\) &array_t1.0.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_internal_pack \\(&array_t3_ptr\\);\[^\\n\]*\\n *sub_array_assumed \\(D\\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.base_addr\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_real_alloc," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_char_ptr," 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/block_2.f08 b/gcc/testsuite/gfortran.dg/block_2.f08 index a2ba2d5caea..8c0e15e1f25 100644 --- a/gcc/testsuite/gfortran.dg/block_2.f08 +++ b/gcc/testsuite/gfortran.dg/block_2.f08 @@ -35,4 +35,4 @@ PROGRAM main IF (str /= "12345") CALL abort () END BLOCK END PROGRAM main -! { dg-final { scan-tree-dump-times "free \\(\\(void \\*\\) alloc_arr\\.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "free \\(\\(void \\*\\) alloc_arr\\.base_addr" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 index ece08339990..aa0b5479682 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 @@ -31,10 +31,10 @@ end program test ! ! Array c_f_pointer: ! -! { dg-final { scan-tree-dump-times " fptr_array.data = cptr;" 1 "original" } } -! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].ubound = " 1 "original" } } -! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].stride = " 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.base_addr = cptr;" 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].extent = " 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].sm = " 1 "original" } } ! ! Check c_f_procpointer ! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. ... cfunptr;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 index 5f4f9775b4a..aa1c29f1853 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 @@ -15,9 +15,9 @@ 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" } } diff --git a/gcc/testsuite/gfortran.dg/class_allocate_14.f90 b/gcc/testsuite/gfortran.dg/class_allocate_14.f90 index 0eed2bd3c85..99afd05c668 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_14.f90 +++ b/gcc/testsuite/gfortran.dg/class_allocate_14.f90 @@ -25,6 +25,5 @@ call sub() call sub2() end -! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.data=0B}, ._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" } } - diff --git a/gcc/testsuite/gfortran.dg/coarray_12.f90 b/gcc/testsuite/gfortran.dg/coarray_12.f90 index 70efaaff516..d9a4091e149 100644 --- a/gcc/testsuite/gfortran.dg/coarray_12.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_12.f90 @@ -45,32 +45,32 @@ subroutine testAlloc5() end subroutine testAlloc5 -! { dg-final { scan-tree-dump-times "a.dim.0..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "a.dim.0..ubound = .*nn;" 1 "original" } } -! { dg-final { scan-tree-dump-times "a.dim.1..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "a.dim.1..ubound = .*mm;" 1 "original" } } -! { dg-final { scan-tree-dump-times "a.dim.2..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "a.dim.2..ubound" 0 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.0..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.0..extent = MAX_EXPR <.*nn.*, 0>;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.1..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.1..extent = .*mm - a.dim.1..lower_bound. \\+ 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.2..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.2..extent" 0 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.0..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.0..ubound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.1..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.1..ubound = 7;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.2..lbound = -5;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.2..ubound = 8;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.3..lbound = .*mmm;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.3..ubound = 2;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.4..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "xxx.dim.4..ubound" 0 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.0..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.0..extent = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.1..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.1..extent = 8 - xxx.dim.1..lower_bound;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.2..lower_bound = -5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.2..extent = 9 - xxx.dim.2..lower_bound;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.3..lower_bound = .*mmm;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.3..extent = 3 - xxx.dim.3..lower_bound;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.4..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.4..extent" 0 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.0..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.0..ubound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.1..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.1..ubound = 7;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.2..lbound = -5;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.2..ubound = .*ppp;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.3..lbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.3..ubound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.4..lbound = .*ooo;" 1 "original" } } -! { dg-final { scan-tree-dump-times "yyy.dim.4..ubound" 0 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.0..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.0..extent = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.1..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.1..extent = 8 - yyy.dim.1..lower_bound;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.2..lower_bound = -5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.2..extent = .*ppp - yyy.dim.2..lower_bound. \\+ 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.3..lower_bound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.3..extent = 2 - yyy.dim.3..lower_bound;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.4..lower_bound = .*ooo;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.4..extent" 0 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_18.f90 b/gcc/testsuite/gfortran.dg/coarray_18.f90 index 474e9391edb..18a0fb86227 100644 --- a/gcc/testsuite/gfortran.dg/coarray_18.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_18.f90 @@ -19,14 +19,17 @@ 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" } + 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 :: i2(2,2,2,2,2,2,2)[2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" } + 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,*] + integer :: ip[2,2,2,2,2,2,2,2,2,2,2,2,2,2,*] + integer :: ip[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_30.f90 b/gcc/testsuite/gfortran.dg/coarray_30.f90 index d68bcccf794..71ddf764640 100644 --- a/gcc/testsuite/gfortran.dg/coarray_30.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_30.f90 @@ -11,4 +11,4 @@ program main write(greeting,"(a)") "z" end -! { dg-final { scan-tree-dump-times "greeting.data = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "greeting.base_addr = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_31.f90 b/gcc/testsuite/gfortran.dg/coarray_31.f90 index 0da4d90ce14..c08c564c1fe 100644 --- a/gcc/testsuite/gfortran.dg/coarray_31.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_31.f90 @@ -16,6 +16,6 @@ type(t2) :: a, b a = b end -! { dg-final { scan-tree-dump "a.y.x.data = D.\[0-9\]+.y.x.data;" "original" } } -! { dg-final { scan-tree-dump "a.y.z._data.data = D.\[0-9\]+.y.z._data.data;" "original" } } -! { dg-final { scan-tree-dump "a.y.d._data.data = D.\[0-9\]+.y.d._data.data;" "original" } } +! { dg-final { scan-tree-dump "a.y.x.base_addr = D.\[0-9\]+.y.x.base_addr;" "original" } } +! { dg-final { scan-tree-dump "a.y.z._data.base_addr = D.\[0-9\]+.y.z._data.base_addr;" "original" } } +! { dg-final { scan-tree-dump "a.y.d._data.base_addr = D.\[0-9\]+.y.d._data.base_addr;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 index 19c60a0b59c..9110e634924 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 @@ -15,8 +15,8 @@ deallocate(xx,yy,stat=stat, errmsg=errmsg) end -! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_register .(40|72), 1, &xx._data.token, &stat.., &errmsg, 200.;" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_register .(104|192), 1, &yy._data.token, &stat.., &errmsg, 200.;" "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 index 696c937e600..63144cbd7df 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 @@ -16,8 +16,8 @@ subroutine test deallocate(xx,yy,stat=stat, errmsg=errmsg) end -! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_register .(40|72), 1, &xx._data.token, &stat.., &errmsg, 200.;" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_register .(104|192), 1, &yy._data.token, &stat.., &errmsg, 200.;" "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 index 7b4d9375de5..a56ea2cd3b6 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 @@ -38,8 +38,8 @@ B(1:5) = B(3:7) if (any (A-B /= 0)) call abort end -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1, 0B\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0, 0B\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 index 63cca3e32c7..10c1530a130 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 @@ -18,8 +18,8 @@ end ! { dg-final { scan-tree-dump-times "bar \\(real\\(kind=4\\)\\\[2\\\] \\* 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" } } +! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lower_bound = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lower_bound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } ! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1 "original" } } 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..0eeaed26e09 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 @@ -16,11 +16,11 @@ 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" } } +! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lower_bound = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lower_bound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } ! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.base_addr - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 index b408529184b..08165056cc7 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 @@ -93,10 +93,10 @@ end program main ! ! CALL 1 ! -! sub ((integer(kind=4) *) caf.data, &((struct t * restrict) caf_dt.data)->b, +! sub ((integer(kind=4) *) caf.base_addr, &((struct t * restrict) caf_dt.base_addr)->b, ! caf.token, 0, caf_dt.token, 4); ! -! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf.data, &\[^,\]*caf_dt.data.->b, caf.token, 0, caf_dt.token, 4\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf.base_addr, &\[^,\]*caf_dt.base_addr.->b, caf.token, 0, caf_dt.token, 4\\)" 1 "original" } } ! ! sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2, ! caf_token.4, NON_LVALUE_EXPR <caf_offset.5>, @@ -110,5 +110,5 @@ end program main ! ! CALL 4 ! -! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf.data, caf.token, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf.base_addr, caf.token, 0\\)" 1 "original" } } ! diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_token_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_token_3.f90 index 1a92f02d48a..aaeb8108d22 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_token_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_3.f90 @@ -8,5 +8,5 @@ allocate(CAF(1)[*]) allocate(CAF_SCALAR[*]) end -! { dg-final { scan-tree-dump-times "caf.data = \\(void . restrict\\) _gfortran_caf_register \\(4, 1, &caf.token, 0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "caf_scalar.data = \\(void . restrict\\) _gfortran_caf_register \\(4, 1, &caf_scalar.token, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "caf.base_addr = \\(void . restrict\\) _gfortran_caf_register \\(4, 1, &caf.token, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "caf_scalar.base_addr = \\(void . restrict\\) _gfortran_caf_register \\(4, 1, &caf_scalar.token, 0B, 0B, 0\\);" 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..189a56c6539 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 @@ -35,17 +35,17 @@ 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" } } +! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.base_addr - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } } ! -! { dg-final { scan-tree-dump-times "expl \\(\\(integer\\(kind=4\\).0:. .\\) parm.\[0-9\]+.data, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(\\(integer\\(kind=.\\)\\) y.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 0 "original" } } +! { dg-final { scan-tree-dump-times "expl \\(\\(integer\\(kind=4\\).0:. .\\) parm.\[0-9\]+.base_addr, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.base_addr - \\(\\(integer\\(kind=.\\)\\) y.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 0 "original" } } ! ! { dg-final { scan-tree-dump-times "foo \\(&a, &a, &C.\[0-9\]+, a.token, 0, a.token, 0\\);" 1 "original" } } ! -! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &parm.\[0-9\]+, &C.\[0-9\]+, a.token, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) a.data, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &parm.\[0-9\]+, &C.\[0-9\]+, a.token, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.base_addr - \\(integer\\(kind=.\\)\\) a.base_addr, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.base_addr - \\(integer\\(kind=.\\)\\) b\\);" 1 "original" } } ! -! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &a, &C.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b, a.token, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &a, &C.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.base_addr - \\(integer\\(kind=.\\)\\) b, a.token, 0\\);" 1 "original" } } ! diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 index b8920f1240d..8840189f8e4 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 @@ -29,18 +29,18 @@ end ! { dg-final { scan-tree-dump-times "one = \\(void \\* \\* restrict\\) _gfortran_caf_register \\(1, 2, \\(void \\* \\*\\) &caf_token.., 0B, 0B, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "two = \\(void \\*\\\[25\\\] \\* restrict\\) _gfortran_caf_register \\(25, 2, \\(void \\* \\*\\) &caf_token.., 0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "three.data = \\(void \\* restrict\\) _gfortran_caf_register \\(1, 3, &three.token, &stat.., 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "four.data = \\(void \\* restrict\\) _gfortran_caf_register \\(7, 3, &four.token, &stat.., 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "three.base_addr = \\(void \\* restrict\\) _gfortran_caf_register \\(1, 3, &three.token, &stat.., 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "four.base_addr = \\(void \\* restrict\\) _gfortran_caf_register \\(7, 3, &four.token, &stat.., 0B, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., 0, 0, 0B, 0B, 0B, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., 0, 0, 0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lbound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);|_gfortran_caf_lock \\(caf_token.1, \\(3 - parm...dim\\\[0\\\].lbound\\) \\+ MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., \\(2 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lbound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(caf_token.., \\(2 - parm...dim\\\[0\\\].lbound\\) \\+ MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lower_bound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(\\(\\(parm...dim\\\[0\\\].lower_bound \\+ parm...dim\\\[0\\\].extent\\) \\+ -1\\) - parm...dim\\\[0\\\].lower_bound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lower_bound\\), 0, 0B, &ii, 0B, 0\\);|_gfortran_caf_lock \\(caf_token.1, \\(3 - parm...dim\\\[0\\\].lower_bound\\) \\+ MAX_EXPR <\\(\\(\\(parm...dim\\\[0\\\].lower_bound \\+ parm...dim\\\[0\\\].extent\\) \\+ -1\\) - parm...dim\\\[0\\\].lower_bound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lower_bound\\), 0, 0B, &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., \\(2 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lower_bound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(\\(\\(parm...dim\\\[0\\\].lower_bound \\+ parm...dim\\\[0\\\].extent\\) \\+ -1\\) - parm...dim\\\[0\\\].lower_bound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lower_bound\\), 0, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(caf_token.., \\(2 - parm...dim\\\[0\\\].lower_bound\\) \\+ MAX_EXPR <\\(\\(\\(parm...dim\\\[0\\\].lower_bound \\+ parm...dim\\\[0\\\].extent\\) \\+ -1\\) - parm...dim\\\[0\\\].lower_bound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lower_bound\\), 0, &ii, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(three.token, 0, 5 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &acquired.8, 0B, 0B, 0\\);|_gfortran_caf_lock \\(three.token, 0, 5 - three.dim\\\[0\\\].lbound, &acquired.., 0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(three.token, 0, 8 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(three.token, 0, 8 - three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(three.token, 0, 5 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lower_bound, &acquired.8, 0B, 0B, 0\\);|_gfortran_caf_lock \\(three.token, 0, 5 - three.dim\\\[0\\\].lower_bound, &acquired.., 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(three.token, 0, 8 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lower_bound, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(three.token, 0, 8 - three.dim\\\[0\\\].lower_bound, &ii, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(four.token, 1 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 7 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, &acquired.., &ii, 0B, 0\\);|_gfortran_caf_lock \\(four.token, 1 - four.dim\\\[0\\\].lbound, 7 - four.dim\\\[1\\\].lbound, &acquired.., &ii, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(four.token, 2 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 8 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);|_gfortran_caf_unlock \\(four.token, 2 - four.dim\\\[0\\\].lbound, 8 - four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(four.token, 1 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lower_bound, 7 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lower_bound, &acquired.., &ii, 0B, 0\\);|_gfortran_caf_lock \\(four.token, 1 - four.dim\\\[0\\\].lower_bound, 7 - four.dim\\\[1\\\].lower_bound, &acquired.., &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(four.token, 2 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lower_bound, 8 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lower_bound, 0B, 0B, 0\\);|_gfortran_caf_unlock \\(four.token, 2 - four.dim\\\[0\\\].lower_bound, 8 - four.dim\\\[1\\\].lower_bound, 0B, 0B, 0\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_4.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_4.f90 index ff574c1ef65..900bf8b3722 100644 --- a/gcc/testsuite/gfortran.dg/coarray_poly_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_poly_4.f90 @@ -19,4 +19,4 @@ allocate(var%x[*]) call sub(var%x) end subroutine test -! { dg-final { scan-tree-dump-times "sub \\(\\(real\\(kind=4\\) \\*\\) var.x.data, var.x.token, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub \\(\\(real\\(kind=4\\) \\*\\) var.x.base_addr, var.x.token, 0\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_5.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_5.f90 index f406da8d352..bc6835b53ce 100644 --- a/gcc/testsuite/gfortran.dg/coarray_poly_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_poly_5.f90 @@ -10,4 +10,4 @@ class(t) :: x allocate(x%x[*]) end subroutine test -! { dg-final { scan-tree-dump-times "x->_data->x.data = _gfortran_caf_register \\(4, 1, &x->_data->x.token, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_data->x.base_addr = _gfortran_caf_register \\(4, 1, &x->_data->x.token, 0B, 0B, 0\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_6.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_6.f90 index 06c07430b08..09754bb4fe7 100644 --- a/gcc/testsuite/gfortran.dg/coarray_poly_6.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_poly_6.f90 @@ -18,4 +18,4 @@ end ! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.base_addr - \\(integer\\(kind=\[48\]\\)\\) y._data._data.base_addr\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_7.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_7.f90 index 65d1c93fede..08f8aca307f 100644 --- a/gcc/testsuite/gfortran.dg/coarray_poly_7.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_poly_7.f90 @@ -18,4 +18,4 @@ end ! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.base_addr - \\(integer\\(kind=\[48\]\\)\\) y._data._data.base_addr\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_8.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_8.f90 index bfca8a46d10..70900a271c4 100644 --- a/gcc/testsuite/gfortran.dg/coarray_poly_8.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_poly_8.f90 @@ -18,4 +18,4 @@ end ! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.base_addr - \\(integer\\(kind=\[48\]\\)\\) y._data._data.base_addr\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 index c29687efbe2..8a55ceabb53 100644 --- a/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 @@ -40,6 +40,6 @@ contains end program function_stat -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 4, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 1, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat2\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 3, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 4, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 1, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat2\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.base_addr - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 3, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/contiguous_3.f90 b/gcc/testsuite/gfortran.dg/contiguous_3.f90 index 0999f7b5b91..dfd5af53951 100644 --- a/gcc/testsuite/gfortran.dg/contiguous_3.f90 +++ b/gcc/testsuite/gfortran.dg/contiguous_3.f90 @@ -31,10 +31,10 @@ subroutine t2(a1,b1,c2,d2) c2 = d2 end subroutine t2 -! { dg-final { scan-tree-dump-times "= a1->dim.0..stride;" 0 "original" } } -! { dg-final { scan-tree-dump-times "= b1->dim.0..stride;" 0 "original" } } -! { dg-final { scan-tree-dump-times "= c2->dim.0..stride;" 1 "original" } } -! { dg-final { scan-tree-dump-times "= d2->dim.0..stride;" 1 "original" } } +! { dg-final { scan-tree-dump-times "= a1->dim.0..sm" 0 "original" } } +! { dg-final { scan-tree-dump-times "= b1->dim.0..sm" 0 "original" } } +! { dg-final { scan-tree-dump-times "!= 0 . c2->dim.0..sm /.fl. .integer.kind=\[48\].. c2->elem_len : 0;" 1 "original" } } +! { dg-final { scan-tree-dump-times "!= 0 . d2->dim.0..sm /.fl. .integer.kind=\[48\].. d2->elem_len : 0;" 1 "original" } } subroutine test3() @@ -57,7 +57,7 @@ contains end subroutine test3 ! Once for test1 (third call), once for test3 (second call) -! { dg-final { scan-tree-dump-times "data = origptr" 1 "original" } } +! { dg-final { scan-tree-dump-times "base_addr = origptr" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_internal_pack .&parm" 2 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack .&parm" 2 "original" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_10.f90 b/gcc/testsuite/gfortran.dg/finalize_10.f90 index 937dff5a167..3e21958c4c1 100644 --- a/gcc/testsuite/gfortran.dg/finalize_10.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_10.f90 @@ -31,8 +31,8 @@ end subroutine foo ! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(" 1 "original" } } ! FINALIZE TYPE: -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } ! { dg-final { scan-tree-dump-times "__final_m_T2 \\(&parm.\[0-9\]+, 0, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } } +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.base_addr = \\(void \\* restrict\\) bb;" 1 "original" } } ! { dg-final { scan-tree-dump-times "__final_m_T2 \\(&desc.\[0-9\]+, 0, 0\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90 index c8b4afcff50..f6873f5326b 100644 --- a/gcc/testsuite/gfortran.dg/finalize_18.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_18.f90 @@ -33,11 +33,11 @@ end ! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } } ! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } } -! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.base_addr != 0B\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.base_addr != 0B\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } } -! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.base_addr = \\(void . restrict\\) y.aa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.base_addr = \\(void . restrict\\) y.cc._data;" 1 "original" } } ! { dg-final { scan-tree-dump-times "__final_m_T \\(&desc.\[0-9\]+, 0, 1\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "__final_m_T \\(&y.bb, 0, 1\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/inline_sum_1.f90 b/gcc/testsuite/gfortran.dg/inline_sum_1.f90 index a9d4f7baa78..c6203c2e52c 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 array0._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/internal_pack_4.f90 b/gcc/testsuite/gfortran.dg/internal_pack_4.f90 index 368e9804bc4..cd2a0b10d72 100644 --- a/gcc/testsuite/gfortran.dg/internal_pack_4.f90 +++ b/gcc/testsuite/gfortran.dg/internal_pack_4.f90 @@ -26,5 +26,5 @@ USE M1 CALL S2() END -! { dg-final { scan-tree-dump-times "a != 0B \\? \\\(.*\\\) _gfortran_internal_pack" 1 "original" } } -! { dg-final { scan-tree-dump-times "if \\(a != 0B &&" 1 "original" } } +! { dg-final { scan-tree-dump-times " a != 0B && \\(real\\(kind=.\\).0:. . restrict\\) a->base_addr != 0B \\? \\\(.*\\\) _gfortran_internal_pack" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(a != 0B && \\(real\\(kind=.\\).0:. . restrict\\) a->base_addr != 0B\\) &&" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 index 923cbc3473d..c74df470fc8 100644 --- a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 +++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 @@ -22,4 +22,4 @@ program bug stop end program bug -! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(D.\[0-9\]+->dim.0..ubound - D.\[0-9\]+->dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } } +! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) a.dim.0..extent;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/iso-ts-29113_1.f90 b/gcc/testsuite/gfortran.dg/iso-ts-29113_1.f90 new file mode 100644 index 00000000000..5dec490bee8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso-ts-29113_1.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-additional-sources iso-ts-29113_1_c.c } +! +! Test whether accessing the array from C works using +! TS29113's ISO_Fortran_binding.h +! +! The C examples are based on TS29113's. +! +use iso_c_binding +implicit none +real(C_float) :: A(100,100) +real(C_float), allocatable :: B(:,:) +integer :: i, j + +type, bind(c) :: t + real(c_double) :: x + complex(c_double_complex) :: y +end type t + +interface + subroutine test_address(x) bind(C) + import + real(C_float) :: x(..) + end subroutine test_address + subroutine test_allocate(x) bind(C) + import + real(C_float) :: x(..) + end subroutine test_allocate + subroutine test_deallocate(x) bind(C) + import + real(C_float) :: x(..) + end subroutine test_deallocate +end interface + +do i = 1, 100 + do j = 1, 100 + A(j,i) = j + 1000*i + end do +end do +call test_address (A) + +call test_allocate (B) +if (.not. allocated (B)) call abort() +if (any (lbound (B) /= [-1,5])) call abort() +if (any (ubound (B) /= [100,500])) call abort() + +call test_deallocate (B) +if (allocated (B)) call abort() +end diff --git a/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c b/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c new file mode 100644 index 00000000000..9f60b7bd605 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c @@ -0,0 +1,97 @@ +/* To be complied together with iso-ts-29113_1.f90. + + Test whether accessing the array from C works using + TS29113's ISO_Fortran_binding.h + + The examples are based on TS29113's. */ + +#include <ISO_Fortran_binding.h> +#include <stdio.h> +#include <stdlib.h> + +void +test_address (CFI_cdesc_t *dv) +{ + CFI_index_t subscripts[2]; + float *address; + int i, j; + + if (dv->rank != 2) abort (); + if (dv->version != CFI_VERSION) abort (); + if (dv->elem_len != sizeof (float)/ sizeof (char)) abort (); + if (dv->attribute != CFI_attribute_other) abort (); + if (dv->type != CFI_type_float) abort (); + + /* FIXME: TS 29113 requires lower_bound == 0, + currently, lower_bound == 1 is used. */ + if (dv->dim[0].lower_bound != 1) abort (); + if (dv->dim[1].lower_bound != 1) abort (); + if (dv->dim[0].extent != 100) abort (); + if (dv->dim[1].extent != 100) abort (); + if (dv->dim[0].sm != 1*dv->elem_len) abort (); + if (dv->dim[1].sm != 100*dv->elem_len) abort (); + + /* Fixme: LB should be 0. */ + for (i = 1; i <= 100; i++) + for (j = 1; j <= 100; j++) + { + subscripts[0] = j; + subscripts[1] = i; + address = (float *) CFI_address (dv, subscripts); + if (*address != j + 1000*i) abort (); + } +} + +void +test_allocate (CFI_cdesc_t *dv) { + CFI_index_t lower[2], upper[2]; + int ind; + size_t dummy = 0; + + if (dv->rank != 2) abort (); + if (dv->version != CFI_VERSION) abort (); + if (dv->attribute != CFI_attribute_allocatable) abort (); + if (dv->base_addr != NULL) abort (); + if (dv->elem_len != sizeof (float)/ sizeof (char)) abort (); + + lower[0] = -1; + lower[1] = 5; + upper[0] = 100; + upper[1] = 500; + ind = CFI_allocate (dv, lower, upper, dummy); + if (ind != CFI_SUCCESS) abort (); + if (dv->dim[0].lower_bound != -1) abort (); + if (dv->dim[1].lower_bound != 5) abort (); + if (dv->dim[0].extent != 100-(-1)+1) abort (); + if (dv->dim[1].extent != 500-5+1) abort (); + if (dv->dim[0].sm != 1*dv->elem_len) abort (); + if (dv->dim[1].sm != 102*dv->elem_len) abort (); + + ind = CFI_allocate (dv, lower, upper, dummy); + if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) abort (); +} + +void +test_deallocate (CFI_cdesc_t *dv) { + int ind; + + if (dv->rank != 2) abort (); + if (dv->version != CFI_VERSION) abort (); + if (dv->attribute != CFI_attribute_allocatable) abort (); + if (dv->base_addr == NULL) abort (); + if (dv->elem_len != sizeof (float)/ sizeof (char)) abort (); + + if (dv->dim[0].lower_bound != -1) abort (); + if (dv->dim[1].lower_bound != 5) abort (); + if (dv->dim[0].extent != 100-(-1)+1) abort (); + if (dv->dim[1].extent != 500-5+1) abort (); + if (dv->dim[0].sm != 1*dv->elem_len) abort (); + if (dv->dim[1].sm != 102*dv->elem_len) abort (); + + ind = CFI_deallocate (dv); + if (ind != CFI_SUCCESS) abort (); + if (dv->base_addr != NULL) abort (); + + ind = CFI_deallocate (dv); + if (ind != CFI_ERROR_BASE_ADDR_NULL) abort (); +} diff --git a/gcc/testsuite/gfortran.dg/iso-ts-29113_2.f90 b/gcc/testsuite/gfortran.dg/iso-ts-29113_2.f90 new file mode 100644 index 00000000000..d366f314ea1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso-ts-29113_2.f90 @@ -0,0 +1,157 @@ +! { 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 "x_cptr.type = (1025|2049);" "original" } } +! { dg-final { scan-tree-dump "x_funcptr.type = (1025|2049);" "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" } } + diff --git a/gcc/testsuite/gfortran.dg/iso-ts-29113_3.f90 b/gcc/testsuite/gfortran.dg/iso-ts-29113_3.f90 new file mode 100644 index 00000000000..b6b7a29ff75 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso-ts-29113_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/iso-ts-29113_3_c.c b/gcc/testsuite/gfortran.dg/iso-ts-29113_3_c.c new file mode 100644 index 00000000000..be2d941a2e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso-ts-29113_3_c.c @@ -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 <ISO_Fortran_binding.h> +#include <stdio.h> +#include <stdlib.h> + + +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); +} diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 index b3fb4685efe..5bb35aa4160 100644 --- a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 +++ b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 @@ -132,21 +132,21 @@ end ! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.base_addr" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.base_addr" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 3 "original" } } ! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.base_addr" 1 "original" } } ! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.base_addr = \\(void .\\) &array_t1.0.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.base_addr\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pr32921.f b/gcc/testsuite/gfortran.dg/pr32921.f index 0661208edde..154f0e0de67 100644 --- a/gcc/testsuite/gfortran.dg/pr32921.f +++ b/gcc/testsuite/gfortran.dg/pr32921.f @@ -45,4 +45,5 @@ RETURN END -! { dg-final { scan-tree-dump-times "stride" 4 "lim2" } } + +! { dg-final { scan-tree-dump-times "sm" 4 "lim2" } } diff --git a/gcc/testsuite/gfortran.dg/pr43984.f90 b/gcc/testsuite/gfortran.dg/pr43984.f90 index 130d114462c..f2c366444c4 100644 --- a/gcc/testsuite/gfortran.dg/pr43984.f90 +++ b/gcc/testsuite/gfortran.dg/pr43984.f90 @@ -50,6 +50,6 @@ end subroutine end -! There should be two loads from iyz.data, not four. +! There should be two loads from iyz.base_addr, not four. -! { dg-final { scan-tree-dump-times "= iyz.data" 2 "pre" } } +! { dg-final { scan-tree-dump-times "= iyz.base_addr" 2 "pre" } } diff --git a/gcc/testsuite/gfortran.dg/pr48636.f90 b/gcc/testsuite/gfortran.dg/pr48636.f90 index 926d8f3fc5a..94826fa4790 100644 --- a/gcc/testsuite/gfortran.dg/pr48636.f90 +++ b/gcc/testsuite/gfortran.dg/pr48636.f90 @@ -34,5 +34,5 @@ program main end program main ! { dg-final { scan-ipa-dump "bar\[^\\n\]*inline copy in MAIN" "inline" } } -! { dg-final { scan-ipa-dump-times "phi predicate:" 3 "inline" } } +! { dg-final { scan-ipa-dump-times "phi predicate:" 5 "inline" } } ! { dg-final { scan-ipa-dump "inline hints: loop_iterations" "inline" } } 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/gcc/testsuite/gfortran.dg/realloc_on_assign_18.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_18.f90 index 7dcd22e11b0..cbec679f1ca 100644 --- a/gcc/testsuite/gfortran.dg/realloc_on_assign_18.f90 +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_18.f90 @@ -16,4 +16,4 @@ if (.not. allocated (y)) call abort () end ! { dg-final { scan-tree-dump "x = \\(struct t .\\) __builtin_malloc \\(1\\);" "original" } } -! { dg-final { scan-tree-dump "y.data = \\(void . restrict\\) __builtin_malloc \\(1\\);" "original" } } +! { dg-final { scan-tree-dump "y.base_addr = \\(void . restrict\\) __builtin_malloc \\(1\\);" "original" } } diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 index baa9ad5fff8..1931417a30c 100644 --- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 +++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 @@ -60,5 +60,5 @@ end ! ! The check below for temporaries gave 14 and 33 for "parm" and "atmp". ! -! { dg-final { scan-tree-dump-times "parm" 66 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 12 "original" } } +! { dg-final { scan-tree-dump-times "parm" 90 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 16 "original" } } |