diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/trans-array.cc | 146 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 57 |
2 files changed, 168 insertions, 35 deletions
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index c93a5f1..9fb0b2b 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1301,23 +1301,28 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) is a class expression. */ static tree -get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) +get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, + gfc_ss **fcnss) { + gfc_ss *loop_ss = ss->loop->ss; gfc_ss *lhs_ss; gfc_ss *rhs_ss; + gfc_ss *fcn_ss = NULL; tree tmp; tree tmp2; tree vptr; - tree rhs_class_expr = NULL_TREE; + tree class_expr = NULL_TREE; tree lhs_class_expr = NULL_TREE; bool unlimited_rhs = false; bool unlimited_lhs = false; bool rhs_function = false; + bool unlimited_arg1 = false; gfc_symbol *vtab; + tree cntnr = NULL_TREE; /* The second element in the loop chain contains the source for the - temporary; ie. the rhs of the assignment. */ - rhs_ss = ss->loop->ss->loop_chain; + class temporary created in gfc_trans_create_temp_array. */ + rhs_ss = loop_ss->loop_chain; if (rhs_ss != gfc_ss_terminator && rhs_ss->info @@ -1326,28 +1331,58 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) && rhs_ss->info->data.array.descriptor) { if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE) - rhs_class_expr + class_expr = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); else - rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); + class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION) rhs_function = true; } + /* Usually, ss points to the function. When the function call is an actual + argument, it is instead rhs_ss because the ss chain is shifted by one. */ + *fcnss = fcn_ss = rhs_function ? rhs_ss : ss; + + /* If this is a transformational function with a class result, the info + class_container field points to the class container of arg1. */ + if (class_expr != NULL_TREE + && fcn_ss->info && fcn_ss->info->expr + && fcn_ss->info->expr->expr_type == EXPR_FUNCTION + && fcn_ss->info->expr->value.function.isym + && fcn_ss->info->expr->value.function.isym->transformational) + { + cntnr = ss->info->class_container; + unlimited_arg1 + = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr); + } + /* For an assignment the lhs is the next element in the loop chain. If we have a class rhs, this had better be a class variable - expression! */ + expression! Otherwise, the class container from arg1 can be used + to set the vptr and len fields of the result class container. */ lhs_ss = rhs_ss->loop_chain; - if (lhs_ss != gfc_ss_terminator - && lhs_ss->info - && lhs_ss->info->expr + if (lhs_ss && lhs_ss != gfc_ss_terminator + && lhs_ss->info && lhs_ss->info->expr && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE && lhs_ss->info->expr->ts.type == BT_CLASS) { tmp = lhs_ss->info->data.array.descriptor; unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); } + else if (cntnr != NULL_TREE) + { + tmp = gfc_class_vptr_get (class_expr); + gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp), + gfc_class_vptr_get (cntnr))); + if (unlimited_rhs) + { + tmp = gfc_class_len_get (class_expr); + if (unlimited_arg1) + gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr)); + } + tmp = NULL_TREE; + } else tmp = NULL_TREE; @@ -1355,35 +1390,33 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator) lhs_class_expr = gfc_get_class_from_expr (tmp); else - return rhs_class_expr; + return class_expr; gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); /* Set the lhs vptr and, if necessary, the _len field. */ - if (rhs_class_expr) + if (class_expr) { /* Both lhs and rhs are class expressions. */ tmp = gfc_class_vptr_get (lhs_class_expr); gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp), - gfc_class_vptr_get (rhs_class_expr))); + gfc_class_vptr_get (class_expr))); if (unlimited_lhs) { + gcc_assert (unlimited_rhs); tmp = gfc_class_len_get (lhs_class_expr); - if (unlimited_rhs) - tmp2 = gfc_class_len_get (rhs_class_expr); - else - tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + tmp2 = gfc_class_len_get (class_expr); gfc_add_modify (pre, tmp, tmp2); } if (rhs_function) { - tmp = gfc_class_data_get (rhs_class_expr); + tmp = gfc_class_data_get (class_expr); gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); } } - else + else if (rhs_ss->info->data.array.descriptor) { /* lhs is class and rhs is intrinsic or derived type. */ *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); @@ -1411,7 +1444,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) } } - return rhs_class_expr; + return class_expr; } @@ -1452,6 +1485,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tree or_expr; tree elemsize; tree class_expr = NULL_TREE; + gfc_ss *fcn_ss = NULL; int n, dim, tmp_dim; int total_dim = 0; @@ -1471,7 +1505,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, The descriptor can be obtained from the ss->info and then converted to the class object. */ if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) - class_expr = get_class_info_from_ss (pre, ss, &eltype); + class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss); /* If the dynamic type is not available, use the declared type. */ if (eltype && GFC_CLASS_TYPE_P (eltype)) @@ -1571,14 +1605,46 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, gfc_add_expr_to_block (pre, build1 (DECL_EXPR, arraytype, TYPE_NAME (arraytype))); - if (class_expr != NULL_TREE) + if (class_expr != NULL_TREE + || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)) { tree class_data; tree dtype; + gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL; - /* Create a class temporary. */ - tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); - gfc_add_modify (pre, tmp, class_expr); + /* Create a class temporary for the result using the lhs class object. */ + if (class_expr != NULL_TREE) + { + tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); + gfc_add_modify (pre, tmp, class_expr); + } + else + { + tree vptr; + class_expr = fcn_ss->info->class_container; + gcc_assert (expr1); + + /* Build a new class container using the arg1 class object. The class + typespec must be rebuilt because the rank might have changed. */ + gfc_typespec ts = CLASS_DATA (expr1)->ts; + symbol_attribute attr = CLASS_DATA (expr1)->attr; + gfc_change_class (&ts, &attr, NULL, expr1->rank, 0); + tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp"); + fcn_ss->info->class_container = tmp; + + /* Set the vptr and obtain the element size. */ + vptr = gfc_class_vptr_get (tmp); + gfc_add_modify (pre, vptr, + fold_convert (TREE_TYPE (vptr), + gfc_class_vptr_get (class_expr))); + elemsize = gfc_class_vtab_size_get (class_expr); + elemsize = gfc_evaluate_now (elemsize, pre); + + /* Set the _len field, if necessary. */ + if (UNLIMITED_POLY (expr1)) + gfc_add_modify (pre, gfc_class_len_get (tmp), + gfc_class_len_get (class_expr)); + } /* Assign the new descriptor to the _data field. This allows the vptr _copy to be used for scalarized assignment since the class @@ -1588,11 +1654,25 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, TREE_TYPE (desc), desc); gfc_add_modify (pre, class_data, tmp); - /* Take the dtype from the class expression. */ - dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); - tmp = gfc_conv_descriptor_dtype (class_data); - gfc_add_modify (pre, tmp, dtype); + if (expr1 && expr1->expr_type == EXPR_FUNCTION + && expr1->value.function.isym + && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE + || expr1->value.function.isym->id == GFC_ISYM_UNPACK)) + { + /* Take the dtype from the class expression. */ + dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); + tmp = gfc_conv_descriptor_dtype (class_data); + gfc_add_modify (pre, tmp, dtype); + /* Transformational functions reshape and reduce can change the rank. */ + if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container) + { + tmp = gfc_conv_descriptor_rank (class_data); + gfc_add_modify (pre, tmp, + build_int_cst (TREE_TYPE (tmp), ss->loop->dimen)); + fcn_ss->info->class_container = NULL_TREE; + } + } /* Point desc to the class _data field. */ desc = class_data; } @@ -5990,6 +6070,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc)); } + else if (expr->ts.type == BT_CLASS + && expr3 && expr3->ts.type != BT_CLASS + && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE) + { + tmp = gfc_conv_descriptor_elem_len (descriptor); + gfc_add_modify (pblock, tmp, + fold_convert (TREE_TYPE (tmp), expr3_elem_size)); + } else { tmp = gfc_conv_descriptor_dtype (descriptor); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index feb43fd..3677e49 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1226,6 +1226,21 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, stmtblock_t block; bool full_array = false; + /* Class transformational function results are the data field of a class + temporary and so the class expression can be obtained directly. */ + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym + && e->value.function.isym->transformational + && TREE_CODE (parmse->expr) == COMPONENT_REF + && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))) + { + parmse->expr = TREE_OPERAND (parmse->expr, 0); + if (!VAR_P (parmse->expr)) + parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); + parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); + return; + } + gfc_init_block (&block); class_ref = NULL; @@ -6326,7 +6341,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_component *comp = NULL; int arglen; unsigned int argc; - + tree arg1_cntnr = NULL_TREE; arglist = NULL; retargs = NULL; stringargs = NULL; @@ -6334,6 +6349,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, var = NULL_TREE; len = NULL_TREE; gfc_clear_ts (&ts); + gfc_intrinsic_sym *isym = expr && expr->rank ? + expr->value.function.isym : NULL; comp = gfc_get_proc_ptr_comp (expr); @@ -7428,6 +7445,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, e->representation.length); } + /* Make the class container for the first argument available with class + valued transformational functions. */ + if (argc == 0 && e && e->ts.type == BT_CLASS + && isym && isym->transformational + && se->ss && se->ss->info) + { + arg1_cntnr = parmse.expr; + if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr))) + arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr); + arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr); + se->ss->info->class_container = arg1_cntnr; + } + if (fsym && e) { /* Obtain the character length of an assumed character length @@ -8029,6 +8059,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Set the type of the array. */ tmp = gfc_typenode_for_spec (&ts); + tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp; gcc_assert (se->ss->dimen == se->loop->dimen); /* Evaluate the bounds of the result, if known. */ @@ -8309,8 +8340,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, argument is actually given. */ arg = expr->value.function.actual; if (result && arg && expr->rank - && expr->value.function.isym - && expr->value.function.isym->transformational + && isym && isym->transformational && arg->expr && arg->expr->ts.type == BT_DERIVED && arg->expr->ts.u.derived->attr.alloc_comp) @@ -11255,7 +11285,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, result to the original descriptor. */ static void -fcncall_realloc_result (gfc_se *se, int rank) +fcncall_realloc_result (gfc_se *se, int rank, tree dtype) { tree desc; tree res_desc; @@ -11274,7 +11304,10 @@ fcncall_realloc_result (gfc_se *se, int rank) /* 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))); + if (dtype != NULL_TREE) + gfc_add_modify (&se->pre, tmp, dtype); + else + gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); res_desc = gfc_evaluate_now (desc, &se->pre); gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); @@ -11491,7 +11524,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ss->is_alloc_lhs = 1; } else - fcncall_realloc_result (&se, expr1->rank); + { + tree dtype = NULL_TREE; + tree type = gfc_typenode_for_spec (&expr2->ts); + if (expr1->ts.type == BT_CLASS) + { + tmp = gfc_class_vptr_get (sym->backend_decl); + tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); + tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); + gfc_add_modify (&se.pre, tmp, tmp2); + dtype = gfc_get_dtype_rank_type (expr1->rank,type); + } + fcncall_realloc_result (&se, expr1->rank, dtype); + } } gfc_conv_function_expr (&se, expr2); |