diff options
Diffstat (limited to 'gcc/fortran/trans-array.c')
| -rw-r--r-- | gcc/fortran/trans-array.c | 919 |
1 files changed, 644 insertions, 275 deletions
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); |