diff options
Diffstat (limited to 'gcc/fortran/trans-array.c')
| -rw-r--r-- | gcc/fortran/trans-array.c | 61 |
1 files changed, 38 insertions, 23 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7eeef55..a6bcd2b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -860,16 +860,25 @@ gfc_get_array_span (tree desc, gfc_expr *expr) size of the array. Attempt to deal with unbounded character types if possible. Otherwise, return NULL_TREE. */ tmp = gfc_get_element_type (TREE_TYPE (desc)); - if (tmp && TREE_CODE (tmp) == ARRAY_TYPE - && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE - || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))))) - { - if (expr->expr_type == EXPR_VARIABLE - && expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, - gfc_get_expr_charlen (expr)); - else - tmp = NULL_TREE; + if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) + { + gcc_assert (expr->ts.type == BT_CHARACTER); + + tmp = gfc_get_character_len_in_bytes (tmp); + + if (tmp == NULL_TREE || integer_zerop (tmp)) + { + tree bs; + + tmp = gfc_get_expr_charlen (expr); + tmp = fold_convert (gfc_array_index_type, tmp); + bs = build_int_cst (gfc_array_index_type, expr->ts.kind); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, bs); + } + + tmp = (tmp && !integer_zerop (tmp)) + ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); } else tmp = fold_convert (gfc_array_index_type, @@ -7328,6 +7337,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) expr = expr->value.function.actual->expr; } + if (!se->direct_byref) + se->unlimited_polymorphic = UNLIMITED_POLY (expr); + /* Special case things we know we can pass easily. */ switch (expr->expr_type) { @@ -7351,9 +7363,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) && TREE_CODE (desc) == COMPONENT_REF) deferred_array_component = true; - subref_array_target = se->direct_byref && is_subref_array (expr); - need_tmp = gfc_ref_needs_temporary_p (expr->ref) - && !subref_array_target; + subref_array_target = (is_subref_array (expr) + && (se->direct_byref + || expr->ts.type == BT_CHARACTER)); + need_tmp = (gfc_ref_needs_temporary_p (expr->ref) + && !subref_array_target); if (se->force_tmp) need_tmp = 1; @@ -7390,9 +7404,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) subref_array_target, expr); /* ....and set the span field. */ - tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE && !integer_zerop (tmp)) - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); + tmp = gfc_conv_descriptor_span_get (desc); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) { @@ -7607,6 +7620,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) int dim, ndim, codim; tree parm; tree parmtype; + tree dtype; tree stride; tree from; tree to; @@ -7689,7 +7703,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else { /* Otherwise make a new one. */ - if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + if (expr->ts.type == BT_CHARACTER) parmtype = gfc_typenode_for_spec (&expr->ts); else parmtype = gfc_get_element_type (TREE_TYPE (desc)); @@ -7723,11 +7737,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } /* Set the span field. */ - if (expr->ts.type == BT_CHARACTER && ss_info->string_length) - tmp = ss_info->string_length; - else - tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE) + tmp = gfc_get_array_span (desc, expr); + if (tmp) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); /* The following can be somewhat confusing. We have two @@ -7741,7 +7752,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (parm); - gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); + if (se->unlimited_polymorphic) + dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen); + else + dtype = gfc_get_dtype (parmtype); + gfc_add_modify (&loop.pre, tmp, dtype); /* The 1st element in the section. */ base = gfc_index_zero_node; |