diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 1357 |
1 files changed, 1001 insertions, 356 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 18358a4e03..7bced25df4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,5 +1,5 @@ /* Expression translation - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> and Steven Bosscher <s.bosscher@student.tudelft.nl> @@ -72,6 +72,13 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) desc = gfc_create_var (type, "desc"); DECL_ARTIFICIAL (desc) = 1; + if (CONSTANT_CLASS_P (scalar)) + { + tree tmp; + tmp = gfc_create_var (TREE_TYPE (scalar), "scalar"); + gfc_add_modify (&se->pre, tmp, scalar); + scalar = tmp; + } if (!POINTER_TYPE_P (TREE_TYPE (scalar))) scalar = gfc_build_addr_expr (NULL_TREE, scalar); gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), @@ -88,6 +95,56 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) } +/* Get the coarray token from the ultimate array or component ref. + Returns a NULL_TREE, when the ref object is not allocatable or pointer. */ + +tree +gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr) +{ + gfc_symbol *sym = expr->symtree->n.sym; + bool is_coarray = sym->attr.codimension; + gfc_expr *caf_expr = gfc_copy_expr (expr); + gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL; + + while (ref) + { + if (ref->type == REF_COMPONENT + && (ref->u.c.component->attr.allocatable + || ref->u.c.component->attr.pointer) + && (is_coarray || ref->u.c.component->attr.codimension)) + last_caf_ref = ref; + ref = ref->next; + } + + if (last_caf_ref == NULL) + return NULL_TREE; + + tree comp = last_caf_ref->u.c.component->caf_token, caf; + gfc_se se; + bool comp_ref = !last_caf_ref->u.c.component->attr.dimension; + if (comp == NULL_TREE && comp_ref) + return NULL_TREE; + gfc_init_se (&se, outerse); + gfc_free_ref_list (last_caf_ref->next); + last_caf_ref->next = NULL; + caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank; + se.want_pointer = comp_ref; + gfc_conv_expr (&se, caf_expr); + gfc_add_block_to_block (&outerse->pre, &se.pre); + + if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref) + se.expr = TREE_OPERAND (se.expr, 0); + gfc_free_expr (caf_expr); + + if (comp_ref) + caf = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (comp), se.expr, comp, NULL_TREE); + else + caf = gfc_conv_descriptor_token (se.expr); + return gfc_build_addr_expr (NULL_TREE, caf); +} + + /* This is the seed for an eventual trans-class.c The following parameters should not be used directly since they might @@ -101,6 +158,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) #define VTABLE_DEF_INIT_FIELD 3 #define VTABLE_COPY_FIELD 4 #define VTABLE_FINAL_FIELD 5 +#define VTABLE_DEALLOCATE_FIELD 6 tree @@ -141,7 +199,7 @@ gfc_class_vptr_get (tree decl) tree vptr; /* For class arrays decl may be a temporary descriptor handle, the vptr is then available through the saved descriptor. */ - if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) @@ -160,7 +218,7 @@ gfc_class_len_get (tree decl) tree len; /* For class arrays decl may be a temporary descriptor handle, the len is then available through the saved descriptor. */ - if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) @@ -182,7 +240,7 @@ gfc_class_len_or_zero_get (tree decl) tree len; /* For class arrays decl may be a temporary descriptor handle, the vptr is then available through the saved descriptor. */ - if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) @@ -243,6 +301,7 @@ VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD) VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD) VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD) VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD) +VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD) /* The size field is returned as an array index type. Therefore treat @@ -293,15 +352,14 @@ gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *e) { gfc_expr *base_expr; - gfc_ref *ref, *class_ref, *tail, *array_ref; + gfc_ref *ref, *class_ref, *tail = NULL, *array_ref; /* Find the last class reference. */ class_ref = NULL; array_ref = NULL; for (ref = e->ref; ref; ref = ref->next) { - if (ref->type == REF_ARRAY - && ref->u.ar.type != AR_ELEMENT) + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) array_ref = ref; if (ref->type == REF_COMPONENT @@ -310,11 +368,10 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) /* Component to the right of a part reference with nonzero rank must not have the ALLOCATABLE attribute. If attempts are made to reference such a component reference, an error results - followed by anICE. */ - if (array_ref - && CLASS_DATA (ref->u.c.component)->attr.allocatable) + followed by an ICE. */ + if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable) return NULL; - class_ref = ref; + class_ref = ref; } if (ref->next == NULL) @@ -328,7 +385,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) tail = class_ref->next; class_ref->next = NULL; } - else + else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { tail = e->ref; e->ref = NULL; @@ -342,7 +399,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) gfc_free_ref_list (class_ref->next); class_ref->next = tail; } - else + else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { gfc_free_ref_list (e->ref); e->ref = tail; @@ -430,9 +487,16 @@ gfc_get_vptr_from_expr (tree expr) else type = NULL_TREE; } - if (TREE_CODE (tmp) == VAR_DECL) + if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) break; } + + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + + if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + return gfc_class_vptr_get (tmp); + return NULL_TREE; } @@ -511,7 +575,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, if (optional) cond_optional = gfc_conv_expr_present (e->symtree->n.sym); - if (parmse->ss && parmse->ss->info->useflags) + if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr))) + { + /* If there is a ready made pointer to a derived type, use it + rather than evaluating the expression again. */ + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags) { /* For an array reference in an elemental procedure call we need to retain the ss to provide the scalarized array reference. */ @@ -522,7 +593,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, cond_optional, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); gfc_add_modify (&parmse->pre, ctree, tmp); - } else { @@ -792,7 +862,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, { ctree = gfc_class_len_get (var); /* When the actual arg is a char array, then set the _len component of the - unlimited polymorphic entity, too. */ + unlimited polymorphic entity to the length of the string. */ if (e->ts.type == BT_CHARACTER) { /* Start with parmse->string_length because this seems to be set to a @@ -964,8 +1034,13 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { tmp = e->symtree->n.sym->backend_decl; + + if (TREE_CODE (tmp) == FUNCTION_DECL) + tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); + if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + slen = integer_zero_node; } else @@ -1016,6 +1091,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = integer_zero_node; gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); + + /* Return the len component, except in the case of scalarized array + references, where the dynamic type cannot change. */ + if (!elemental && full_array && copyback) + gfc_add_modify (&parmse->post, tmp, + fold_convert (TREE_TYPE (tmp), ctree)); } if (optional) @@ -1166,6 +1247,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) stmtblock_t body; stmtblock_t ifbody; gfc_loopinfo loop; + tree orig_nelems = nelems; /* Needed for bounds check. */ gfc_init_block (&body); tmp = fold_build2_loc (input_location, MINUS_EXPR, @@ -1193,6 +1275,31 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) } vec_safe_push (args, to_ref); + /* Add bounds check. */ + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc) + { + char *msg; + const char *name = "<<unknown>>"; + tree from_len; + + if (DECL_P (to)) + name = (const char *)(DECL_NAME (to)->identifier.id.str); + + from_len = gfc_conv_descriptor_size (from_data, 1); + tmp = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, from_len, orig_nelems); + msg = xasprintf ("Array bound mismatch for dimension %d " + "of array '%s' (%%ld/%%ld)", + 1, name); + + gfc_trans_runtime_check (true, false, tmp, &body, + &gfc_current_locus, msg, + fold_convert (long_integer_type_node, orig_nelems), + fold_convert (long_integer_type_node, from_len)); + + free (msg); + } + tmp = build_call_vec (fcn_type, fcn, args); /* Build the body of the loop. */ @@ -1357,8 +1464,13 @@ gfc_trans_class_init_assign (gfc_code *code) rhs->rank = 0; if (code->expr1->ts.type == BT_CLASS - && CLASS_DATA (code->expr1)->attr.dimension) - tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); + && CLASS_DATA (code->expr1)->attr.dimension) + { + gfc_array_spec *tmparr = gfc_get_array_spec (); + *tmparr = *CLASS_DATA (code->expr1)->as; + gfc_add_full_array_ref (lhs, tmparr); + tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); + } else { sz = gfc_copy_expr (code->expr1); @@ -1403,114 +1515,6 @@ gfc_trans_class_init_assign (gfc_code *code) } -/* Translate an assignment to a CLASS object - (pointer or ordinary assignment). */ - -tree -gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) -{ - stmtblock_t block; - tree tmp; - gfc_expr *lhs; - gfc_expr *rhs; - gfc_ref *ref; - - gfc_start_block (&block); - - ref = expr1->ref; - while (ref && ref->next) - ref = ref->next; - - /* Class valued proc_pointer assignments do not need any further - preparation. */ - if (ref && ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer - && expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE - && op == EXEC_POINTER_ASSIGN) - goto assign; - - if (expr2->ts.type != BT_CLASS) - { - /* Insert an additional assignment which sets the '_vptr' field. */ - gfc_symbol *vtab = NULL; - gfc_symtree *st; - - lhs = gfc_copy_expr (expr1); - gfc_add_vptr_component (lhs); - - if (UNLIMITED_POLY (expr1) - && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) - { - rhs = gfc_get_null_expr (&expr2->where); - goto assign_vptr; - } - - if (expr2->expr_type == EXPR_NULL) - vtab = gfc_find_vtab (&expr1->ts); - else - vtab = gfc_find_vtab (&expr2->ts); - gcc_assert (vtab); - - rhs = gfc_get_expr (); - rhs->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); - rhs->symtree = st; - rhs->ts = vtab->ts; -assign_vptr: - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } - else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2)) - { - /* F2003:C717 only sequence and bind-C types can come here. */ - gcc_assert (expr1->ts.u.derived->attr.sequence - || expr1->ts.u.derived->attr.is_bind_c); - gfc_add_data_component (expr2); - goto assign; - } - else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION) - { - /* Insert an additional assignment which sets the '_vptr' field. */ - lhs = gfc_copy_expr (expr1); - gfc_add_vptr_component (lhs); - - rhs = gfc_copy_expr (expr2); - gfc_add_vptr_component (rhs); - - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } - - /* Do the actual CLASS assignment. */ - if (expr2->ts.type == BT_CLASS - && !CLASS_DATA (expr2)->attr.dimension) - op = EXEC_ASSIGN; - else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS - || !CLASS_DATA (expr2)->attr.dimension) - gfc_add_data_component (expr1); - -assign: - - if (op == EXEC_ASSIGN) - tmp = gfc_trans_assignment (expr1, expr2, false, true); - else if (op == EXEC_POINTER_ASSIGN) - tmp = gfc_trans_pointer_assignment (expr1, expr2); - else - gcc_unreachable(); - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - /* End of prototype trans-class.c */ @@ -1813,69 +1817,54 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr) { tree caf_decl; bool found = false; - gfc_ref *ref, *comp_ref = NULL; + gfc_ref *ref; gcc_assert (expr && expr->expr_type == EXPR_VARIABLE); /* Not-implemented diagnostic. */ + if (expr->symtree->n.sym->ts.type == BT_CLASS + && UNLIMITED_POLY (expr->symtree->n.sym) + && CLASS_DATA (expr->symtree->n.sym)->attr.codimension) + gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at " + "%L is not supported", &expr->where); + for (ref = expr->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT) { - comp_ref = ref; - if ((ref->u.c.component->ts.type == BT_CLASS - && !CLASS_DATA (ref->u.c.component)->attr.codimension - && (CLASS_DATA (ref->u.c.component)->attr.pointer - || CLASS_DATA (ref->u.c.component)->attr.allocatable)) - || (ref->u.c.component->ts.type != BT_CLASS - && !ref->u.c.component->attr.codimension - && (ref->u.c.component->attr.pointer - || ref->u.c.component->attr.allocatable))) - gfc_error ("Sorry, coindexed access to a pointer or allocatable " - "component of the coindexed coarray at %L is not yet " - "supported", &expr->where); + if (ref->u.c.component->ts.type == BT_CLASS + && UNLIMITED_POLY (ref->u.c.component) + && CLASS_DATA (ref->u.c.component)->attr.codimension) + gfc_error ("Sorry, coindexed access to an unlimited polymorphic " + "component at %L is not supported", &expr->where); } - if ((!comp_ref - && ((expr->symtree->n.sym->ts.type == BT_CLASS - && CLASS_DATA (expr->symtree->n.sym)->attr.alloc_comp) - || (expr->symtree->n.sym->ts.type == BT_DERIVED - && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp))) - || (comp_ref - && ((comp_ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (comp_ref->u.c.component)->attr.alloc_comp) - || (comp_ref->u.c.component->ts.type == BT_DERIVED - && comp_ref->u.c.component->ts.u.derived->attr.alloc_comp)))) - gfc_error ("Sorry, coindexed coarray at %L with allocatable component is " - "not yet supported", &expr->where); - - if (expr->rank) - { - /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in - general not possible as the required stride multiplier might be not - a multiple of c_sizeof(b). In case of noncoindexed access, the - scalarizer often takes care of it - for coarrays, it always fails. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - && ((ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (ref->u.c.component)->attr.codimension) - || (ref->u.c.component->ts.type != BT_CLASS - && ref->u.c.component->attr.codimension))) - break; - if (ref == NULL) - ref = expr->ref; - for ( ; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.dimen) - break; - for ( ; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - gfc_error ("Sorry, coindexed access at %L to a scalar component " - "with an array partref is not yet supported", - &expr->where); - } - caf_decl = expr->symtree->n.sym->backend_decl; - gcc_assert (caf_decl); + /* Make sure the backend_decl is present before accessing it. */ + caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE + ? gfc_get_symbol_decl (expr->symtree->n.sym) + : expr->symtree->n.sym->backend_decl; + if (expr->symtree->n.sym->ts.type == BT_CLASS) - caf_decl = gfc_class_data_get (caf_decl); + { + if (expr->ref && expr->ref->type == REF_ARRAY) + { + caf_decl = gfc_class_data_get (caf_decl); + if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension) + return caf_decl; + } + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && strcmp (ref->u.c.component->name, "_data") != 0) + { + caf_decl = gfc_class_data_get (caf_decl); + if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension) + return caf_decl; + break; + } + else if (ref->type == REF_ARRAY && ref->u.ar.dimen) + break; + } + } if (expr->symtree->n.sym->attr.codimension) return caf_decl; @@ -1893,7 +1882,14 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr) TREE_TYPE (comp->backend_decl), caf_decl, comp->backend_decl, NULL_TREE); if (comp->ts.type == BT_CLASS) - caf_decl = gfc_class_data_get (caf_decl); + { + caf_decl = gfc_class_data_get (caf_decl); + if (CLASS_DATA (comp)->attr.codimension) + { + found = true; + break; + } + } if (comp->attr.codimension) { found = true; @@ -1908,8 +1904,8 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr) /* Obtain the Coarray token - and optionally also the offset. */ void -gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr, - gfc_expr *expr) +gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl, + tree se_expr, gfc_expr *expr) { tree tmp; @@ -1964,7 +1960,47 @@ gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, *offset, fold_convert (gfc_array_index_type, tmp)); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) + if (expr->symtree->n.sym->ts.type == BT_DERIVED + && expr->symtree->n.sym->attr.codimension + && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp) + { + gfc_expr *base_expr = gfc_copy_expr (expr); + gfc_ref *ref = base_expr->ref; + gfc_se base_se; + + // Iterate through the refs until the last one. + while (ref->next) + ref = ref->next; + + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_FULL) + { + const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen; + int i; + for (i = 0; i < ranksum; ++i) + { + ref->u.ar.start[i] = NULL; + ref->u.ar.end[i] = NULL; + } + ref->u.ar.type = AR_FULL; + } + gfc_init_se (&base_se, NULL); + if (gfc_caf_attr (base_expr).dimension) + { + gfc_conv_expr_descriptor (&base_se, base_expr); + tmp = gfc_conv_descriptor_data_get (base_se.expr); + } + else + { + gfc_conv_expr (&base_se, base_expr); + tmp = base_se.expr; + } + + gfc_free_expr (base_expr); + gfc_add_block_to_block (&se->pre, &base_se.pre); + gfc_add_block_to_block (&se->post, &base_se.post); + } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) tmp = gfc_conv_descriptor_data_get (caf_decl); else { @@ -1995,6 +2031,12 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) break; gcc_assert (ref != NULL); + if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE) + { + return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, + integer_zero_node); + } + img_idx = integer_zero_node; extent = integer_one_node; if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) @@ -2102,6 +2144,7 @@ flatten_array_ctors_without_strlen (gfc_expr* e) } /* Otherwise, fall through to handle constructor elements. */ + gcc_fallthrough (); case EXPR_STRUCTURE: for (c = gfc_constructor_first (e->value.constructor); c; c = gfc_constructor_next (c)) @@ -2127,9 +2170,7 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) gfc_init_se (&se, NULL); - if (!cl->length - && cl->backend_decl - && TREE_CODE (cl->backend_decl) == VAR_DECL) + if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl)) return; /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but @@ -2236,7 +2277,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' " "is less than one", name); else - msg = xasprintf ("Substring out of bounds: lower bound (%%ld)" + msg = xasprintf ("Substring out of bounds: lower bound (%%ld) " "is less than one"); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, @@ -2319,7 +2360,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) On the other hand, if the context is a UNION or a MAP (a RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */ - if (context != TREE_TYPE (decl) + if (context != TREE_TYPE (decl) && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */ || TREE_CODE (context) == UNION_TYPE)) /* Field is map */ { @@ -2503,8 +2544,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) if (se_expr) se->expr = se_expr; - /* Procedure actual arguments. */ - else if (sym->attr.flavor == FL_PROCEDURE + /* Procedure actual arguments. Look out for temporary variables + with the same attributes as function values. */ + else if (!sym->attr.temporary + && sym->attr.flavor == FL_PROCEDURE && se->expr != current_function_decl) { if (!sym->attr.dummy && !sym->attr.proc_pointer) @@ -2826,9 +2869,9 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) return 0; m = wrhs.to_shwi (); - /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care - of the asymmetric range of the integer type. */ - n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m); + /* Use the wide_int's routine to reliably get the absolute value on all + platforms. Then convert it to a HOST_WIDE_INT like above. */ + n = wi::abs (wrhs).to_shwi (); type = TREE_TYPE (lhs); sgn = tree_int_cst_sgn (rhs); @@ -3631,7 +3674,7 @@ conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr) gfc_ref *ref; tree var; - if (TREE_CODE (base_object) != VAR_DECL) + if (!VAR_P (base_object)) { var = gfc_create_var (TREE_TYPE (base_object), NULL); gfc_add_modify (&se->pre, var, base_object); @@ -3902,6 +3945,10 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, if (sym->attr.flavor == FL_PROCEDURE) value = se->expr; + /* If the argument is a pass-by-value scalar, use the value as is. */ + else if (!sym->attr.dimension && sym->attr.value) + value = se->expr; + /* If the argument is either a string or a pointer to a string, convert it to a boundless character type. */ else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER) @@ -4074,6 +4121,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) new_expr = gfc_copy_expr (arg1->ts.u.cl->length); break; + case GFC_ISYM_LEN_TRIM: + new_expr = gfc_copy_expr (arg1); + gfc_apply_interface_mapping_to_expr (mapping, new_expr); + + if (!new_expr) + return false; + + gfc_replace_expr (arg1, new_expr); + return true; + case GFC_ISYM_SIZE: if (!sym->as || sym->as->rank == 0) return false; @@ -4633,10 +4690,11 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias) { gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e); - if ((proc_ifc->result->ts.type == BT_CLASS - && proc_ifc->result->ts.u.derived->attr.is_class - && CLASS_DATA (proc_ifc->result)->attr.class_pointer) - || proc_ifc->result->attr.pointer) + if (proc_ifc->result != NULL + && ((proc_ifc->result->ts.type == BT_CLASS + && proc_ifc->result->ts.u.derived->attr.is_class + && CLASS_DATA (proc_ifc->result)->attr.class_pointer) + || proc_ifc->result->attr.pointer)) return true; else return false; @@ -5165,7 +5223,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ptr = gfc_class_data_get (ptr); tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE, - true, e, e->ts); + NULL_TREE, true, + e, e->ts); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ptr, @@ -5274,7 +5333,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_deallocate_with_status (ptr, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, e, - false); + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ptr, @@ -5397,7 +5456,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp, false, e); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + e, + GFC_CAF_COARRAY_NOCOARRAY); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) @@ -5509,7 +5573,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree local_tmp; local_tmp = gfc_evaluate_now (tmp, &se->pre); - local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank); + local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, + parm_rank, 0); gfc_add_expr_to_block (&se->post, local_tmp); } @@ -5525,7 +5590,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank); - gfc_add_expr_to_block (&se->post, tmp); + gfc_prepend_expr_to_block (&post, tmp); } /* Add argument checking of passing an unallocated/NULL actual to @@ -5637,8 +5702,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { tmp = parmse.string_length; - if (TREE_CODE (tmp) != VAR_DECL - && TREE_CODE (tmp) != COMPONENT_REF) + if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF) tmp = gfc_evaluate_now (parmse.string_length, &se->pre); parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp); } @@ -5767,8 +5831,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (comp) ts = comp->ts; + else if (sym->ts.type == BT_CLASS) + ts = CLASS_DATA (sym)->ts; else - ts = sym->ts; + ts = sym->ts; if (ts.type == BT_CHARACTER && sym->attr.is_bind_c) se->string_length = build_int_cst (gfc_charlen_type_node, 1); @@ -5837,7 +5903,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))))) se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); + se->expr); /* If the lhs of an assignment x = f(..) is allocatable and f2003 is allowed, we must do the automatic reallocation. @@ -5941,6 +6007,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, type = gfc_get_character_type (ts.kind, ts.u.cl); type = build_pointer_type (type); + /* Emit a DECL_EXPR for the VLA type. */ + tmp = TREE_TYPE (type); + if (TYPE_SIZE (tmp) + && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST) + { + tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp); + DECL_ARTIFICIAL (tmp) = 1; + DECL_IGNORED_P (tmp) = 1; + tmp = fold_build1_loc (input_location, DECL_EXPR, + TREE_TYPE (tmp), tmp); + gfc_add_expr_to_block (&se->pre, tmp); + } + /* Return an address to a char[0:len-1]* temporary for character pointers. */ if ((!comp && (sym->attr.pointer || sym->attr.allocatable)) @@ -5979,7 +6058,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (ts.type == BT_CHARACTER && ts.deferred) { tmp = len; - if (TREE_CODE (tmp) != VAR_DECL) + if (!VAR_P (tmp)) tmp = gfc_evaluate_now (len, &se->pre); TREE_STATIC (tmp) = 1; gfc_add_modify (&se->pre, tmp, @@ -6123,19 +6202,41 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } + /* Associate the rhs class object's meta-data with the result, when the + result is a temporary. */ + if (args && args->expr && args->expr->ts.type == BT_CLASS + && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result) + && !GFC_CLASS_TYPE_P (TREE_TYPE (result))) + { + gfc_se parmse; + gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr); + + gfc_init_se (&parmse, NULL); + parmse.data_not_needed = 1; + gfc_conv_expr (&parmse, class_expr); + if (!DECL_LANG_SPECIFIC (result)) + gfc_allocate_lang_decl (result); + GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr; + gfc_free_expr (class_expr); + gcc_assert (parmse.pre.head == NULL_TREE + && parmse.post.head == NULL_TREE); + } + /* Follow the function call with the argument post block. */ if (byref) { gfc_add_block_to_block (&se->pre, &post); /* Transformational functions of derived types with allocatable - components must have the result allocatable components copied. */ + components must have the result allocatable components copied when the + argument is actually given. */ arg = expr->value.function.actual; if (result && arg && expr->rank - && expr->value.function.isym - && expr->value.function.isym->transformational - && arg->expr->ts.type == BT_DERIVED - && arg->expr->ts.u.derived->attr.alloc_comp) + && expr->value.function.isym + && expr->value.function.isym->transformational + && arg->expr + && arg->expr->ts.type == BT_DERIVED + && arg->expr->ts.u.derived->attr.alloc_comp) { tree tmp2; /* Copy the allocatable components. We have to use a @@ -6143,7 +6244,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, from being corrupted. */ tmp2 = gfc_evaluate_now (result, &se->pre); tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived, - result, tmp2, expr->rank); + result, tmp2, expr->rank, 0); gfc_add_expr_to_block (&se->pre, tmp); tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2), expr->rank); @@ -6153,7 +6254,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_conv_descriptor_data_get (tmp2); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, - NULL, false); + NULL, GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&se->pre, tmp); } } @@ -6356,33 +6457,19 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, return; } + /* The string copy algorithm below generates code like + + if (dlen > 0) { + memmove (dest, src, min(dlen, slen)); + if (slen < dlen) + memset(&dest[slen], ' ', dlen - slen); + } + */ + /* Do nothing if the destination length is zero. */ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen, build_int_cst (size_type_node, 0)); - /* The following code was previously in _gfortran_copy_string: - - // The two strings may overlap so we use memmove. - void - copy_string (GFC_INTEGER_4 destlen, char * dest, - GFC_INTEGER_4 srclen, const char * src) - { - if (srclen >= destlen) - { - // This will truncate if too long. - memmove (dest, src, destlen); - } - else - { - memmove (dest, src, srclen); - // Pad with spaces. - memset (&dest[srclen], ' ', destlen - srclen); - } - } - - We're now doing it here for better optimization, but the logic - is the same. */ - /* For non-default character kinds, we have to multiply the string length by the base type size. */ chartype = gfc_get_char_type (dkind); @@ -6405,31 +6492,42 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, else src = gfc_build_addr_expr (pvoid_type_node, src); - /* Truncate string if source is too long. */ - cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen, - dlen); + /* First do the memmove. */ + tmp2 = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (dlen), dlen, + slen); tmp2 = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MEMMOVE), - 3, dest, src, dlen); + 3, dest, src, tmp2); + stmtblock_t tmpblock2; + gfc_init_block (&tmpblock2); + gfc_add_expr_to_block (&tmpblock2, tmp2); - /* Else copy and pad with spaces. */ - tmp3 = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMMOVE), - 3, dest, src, slen); + /* If the destination is longer, fill the end with spaces. */ + cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen, + dlen); + + /* Wstringop-overflow appears at -O3 even though this warning is not + explicitly available in fortran nor can it be switched off. If the + source length is a constant, its negative appears as a very large + postive number and triggers the warning in BUILTIN_MEMSET. Fixing + the result of the MINUS_EXPR suppresses this spurious warning. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE(dlen), dlen, slen); + if (slength && TREE_CONSTANT (slength)) + tmp = gfc_evaluate_now (tmp, block); tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen); - tmp4 = fill_with_spaces (tmp4, chartype, - fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE(dlen), dlen, slen)); + tmp4 = fill_with_spaces (tmp4, chartype, tmp); gfc_init_block (&tempblock); - gfc_add_expr_to_block (&tempblock, tmp3); gfc_add_expr_to_block (&tempblock, tmp4); tmp3 = gfc_finish_block (&tempblock); /* The whole copy_string function is there. */ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, - tmp2, tmp3); + tmp3, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&tmpblock2, tmp); + tmp = gfc_finish_block (&tmpblock2); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); @@ -6868,16 +6966,18 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Deal with arrays of derived types with allocatable components. */ if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp) + // TODO: Fix caf_mode tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, - cm->as->rank); + cm->as->rank, 0); else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED && CLASS_DATA(cm)->attr.allocatable) { if (cm->ts.u.derived->attr.alloc_comp) + // TODO: Fix caf_mode tmp = gfc_copy_alloc_comp (expr->ts.u.derived, se.expr, dest, - expr->rank); + expr->rank, 0); else { tmp = TREE_TYPE (dest); @@ -7257,7 +7357,30 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, fold_convert (TREE_TYPE (tmp), se.expr)); gfc_add_block_to_block (&block, &se.post); } - else if (gfc_bt_struct (expr->ts.type) && expr->ts.f90_type != BT_VOID) + else if (expr->ts.type == BT_UNION) + { + tree tmp; + gfc_constructor *c = gfc_constructor_first (expr->value.constructor); + /* We mark that the entire union should be initialized with a contrived + EXPR_NULL expression at the beginning. */ + if (c != NULL && c->n.component == NULL + && c->expr != NULL && c->expr->expr_type == EXPR_NULL) + { + tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node, + dest, build_constructor (TREE_TYPE (dest), NULL)); + gfc_add_expr_to_block (&block, tmp); + c = gfc_constructor_next (c); + } + /* The following constructor expression, if any, represents a specific + map intializer, as given by the user. */ + if (c != NULL && c->expr != NULL) + { + gcc_assert (expr->expr_type == EXPR_STRUCTURE); + tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL); + gfc_add_expr_to_block (&block, tmp); + } + } + else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID) { if (expr->expr_type != EXPR_STRUCTURE) { @@ -7280,8 +7403,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, if (cm->ts.u.derived->attr.alloc_comp && expr->expr_type != EXPR_NULL) { + // TODO: Fix caf_mode tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, - dest, expr->rank); + dest, expr->rank, 0); gfc_add_expr_to_block (&block, tmp); if (dealloc != NULL_TREE) gfc_add_expr_to_block (&block, dealloc); @@ -7347,13 +7471,14 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, /* Assign a derived type constructor to a variable. */ tree -gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) +gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) { gfc_constructor *c; gfc_component *cm; stmtblock_t block; tree field; tree tmp; + gfc_se se; gfc_start_block (&block); cm = expr->ts.u.derived->components; @@ -7362,7 +7487,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) { - gfc_se se, lse; + gfc_se lse; gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -7374,6 +7499,9 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) return gfc_finish_block (&block); } + if (coarray) + gfc_init_se (&se, NULL); + for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c), cm = cm->next) { @@ -7381,6 +7509,65 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) if (!c->expr && !cm->attr.allocatable) continue; + /* Register the component with the caf-lib before it is initialized. + Register only allocatable components, that are not coarray'ed + components (%comp[*]). Only register when the constructor is not the + null-expression. */ + if (coarray && !cm->attr.codimension + && (cm->attr.allocatable || cm->attr.pointer) + && (!c->expr || c->expr->expr_type == EXPR_NULL)) + { + tree token, desc, size; + bool is_array = cm->ts.type == BT_CLASS + ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension; + + field = cm->backend_decl; + field = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), dest, field, NULL_TREE); + if (cm->ts.type == BT_CLASS) + field = gfc_class_data_get (field); + + token = is_array ? gfc_conv_descriptor_token (field) + : fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (cm->caf_token), dest, + cm->caf_token, NULL_TREE); + + if (is_array) + { + /* The _caf_register routine looks at the rank of the array + descriptor to decide whether the data registered is an array + or not. */ + int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank + : cm->as->rank; + /* When the rank is not known just set a positive rank, which + suffices to recognize the data as array. */ + if (rank < 0) + rank = 1; + size = integer_zero_node; + desc = field; + gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), + build_int_cst (gfc_array_index_type, rank)); + } + else + { + desc = gfc_conv_scalar_to_descriptor (&se, field, + cm->ts.type == BT_CLASS + ? CLASS_DATA (cm)->attr + : cm->attr); + size = TYPE_SIZE_UNIT (TREE_TYPE (field)); + } + gfc_add_block_to_block (&block, &se.pre); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, + 7, size, build_int_cst ( + integer_type_node, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY), + gfc_build_addr_expr (pvoid_type_node, + token), + gfc_build_addr_expr (NULL_TREE, desc), + null_pointer_node, null_pointer_node, + integer_zero_node); + gfc_add_expr_to_block (&block, tmp); + } field = cm->backend_decl; tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE); @@ -7399,6 +7586,43 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) return gfc_finish_block (&block); } +void +gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v, + gfc_component *un, gfc_expr *init) +{ + gfc_constructor *ctor; + + if (un->ts.type != BT_UNION || un == NULL || init == NULL) + return; + + ctor = gfc_constructor_first (init->value.constructor); + + if (ctor == NULL || ctor->expr == NULL) + return; + + gcc_assert (init->expr_type == EXPR_STRUCTURE); + + /* If we have an 'initialize all' constructor, do it first. */ + if (ctor->expr->expr_type == EXPR_NULL) + { + tree union_type = TREE_TYPE (un->backend_decl); + tree val = build_constructor (union_type, NULL); + CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val); + ctor = gfc_constructor_next (ctor); + } + + /* Add the map initializer on top. */ + if (ctor != NULL && ctor->expr != NULL) + { + gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE); + tree val = gfc_conv_initializer (ctor->expr, &un->ts, + TREE_TYPE (un->backend_decl), + un->attr.dimension, un->attr.pointer, + un->attr.proc_pointer); + CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val); + } +} + /* Build an expression for a constructor. If init is nonzero then this is part of a static variable initializer. */ @@ -7422,29 +7646,12 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) se->expr = gfc_create_var (type, expr->ts.u.derived->name); /* The symtree in expr is NULL, if the code to generate is for initializing the static members only. */ - tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL); + tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL, + se->want_coarray); gfc_add_expr_to_block (&se->pre, tmp); return; } - /* Though unions appear to have multiple map components, they must only - have a single initializer since each map overlaps. TODO: squash map - constructors? */ - if (expr->ts.type == BT_UNION) - { - c = gfc_constructor_first (expr->value.constructor); - cm = c->n.component; - val = gfc_conv_initializer (c->expr, &expr->ts, - TREE_TYPE (cm->backend_decl), - cm->attr.dimension, cm->attr.pointer, - cm->attr.proc_pointer); - val = unshare_expr_without_location (val); - - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); - goto finish; - } - cm = expr->ts.u.derived->components; for (c = gfc_constructor_first (expr->value.constructor); @@ -7479,6 +7686,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, fold_convert (TREE_TYPE (cm->backend_decl), integer_zero_node)); + else if (cm->ts.type == BT_UNION) + gfc_conv_union_initializer (v, cm, c->expr); else { val = gfc_conv_initializer (c->expr, &cm->ts, @@ -7491,7 +7700,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } } -finish: + se->expr = build_constructor (type, v); if (init) TREE_CONSTANT (se->expr) = 1; @@ -7745,6 +7954,247 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } +/* Get the _len component for an unlimited polymorphic expression. */ + +static tree +trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr) +{ + gfc_se se; + gfc_ref *ref = expr->ref; + + gfc_init_se (&se, NULL); + while (ref && ref->next) + ref = ref->next; + gfc_add_len_component (expr); + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + if (ref) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + else + { + gfc_free_ref_list (expr->ref); + expr->ref = NULL; + } + return se.expr; +} + + +/* Assign _vptr and _len components as appropriate. BLOCK should be a + statement-list outside of the scalarizer-loop. When code is generated, that + depends on the scalarized expression, it is added to RSE.PRE. + Returns le's _vptr tree and when set the len expressions in to_lenp and + from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp]) + expression. */ + +static tree +trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, + gfc_expr * re, gfc_se *rse, + tree * to_lenp, tree * from_lenp) +{ + gfc_se se; + gfc_expr * vptr_expr; + tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr; + bool set_vptr = false, temp_rhs = false; + stmtblock_t *pre = block; + + /* Create a temporary for complicated expressions. */ + if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL + && rse->expr != NULL_TREE && !DECL_P (rse->expr)) + { + tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); + pre = &rse->pre; + gfc_add_modify (&rse->pre, tmp, rse->expr); + rse->expr = tmp; + temp_rhs = true; + } + + /* Get the _vptr for the left-hand side expression. */ + gfc_init_se (&se, NULL); + vptr_expr = gfc_find_and_cut_at_last_class_ref (le); + if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok) + { + /* Care about _len for unlimited polymorphic entities. */ + if (UNLIMITED_POLY (vptr_expr) + || (vptr_expr->ts.type == BT_DERIVED + && vptr_expr->ts.u.derived->attr.unlimited_polymorphic)) + to_len = trans_get_upoly_len (block, vptr_expr); + gfc_add_vptr_component (vptr_expr); + set_vptr = true; + } + else + vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts)); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + lhs_vptr = se.expr; + STRIP_NOPS (lhs_vptr); + + /* Set the _vptr only when the left-hand side of the assignment is a + class-object. */ + if (set_vptr) + { + /* Get the vptr from the rhs expression only, when it is variable. + Functions are expected to be assigned to a temporary beforehand. */ + vptr_expr = re->expr_type == EXPR_VARIABLE + ? gfc_find_and_cut_at_last_class_ref (re) + : NULL; + if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS) + { + if (to_len != NULL_TREE) + { + /* Get the _len information from the rhs. */ + if (UNLIMITED_POLY (vptr_expr) + || (vptr_expr->ts.type == BT_DERIVED + && vptr_expr->ts.u.derived->attr.unlimited_polymorphic)) + from_len = trans_get_upoly_len (block, vptr_expr); + } + gfc_add_vptr_component (vptr_expr); + } + else + { + if (re->expr_type == EXPR_VARIABLE + && DECL_P (re->symtree->n.sym->backend_decl) + && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl) + && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl) + && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR ( + re->symtree->n.sym->backend_decl)))) + { + vptr_expr = NULL; + se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR ( + re->symtree->n.sym->backend_decl)); + if (to_len) + from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR ( + re->symtree->n.sym->backend_decl)); + } + else if (temp_rhs && re->ts.type == BT_CLASS) + { + vptr_expr = NULL; + se.expr = gfc_class_vptr_get (rse->expr); + } + else if (re->expr_type != EXPR_NULL) + /* Only when rhs is non-NULL use its declared type for vptr + initialisation. */ + vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts)); + else + /* When the rhs is NULL use the vtab of lhs' declared type. */ + vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts)); + } + + if (vptr_expr) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + } + gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr), + se.expr)); + + if (to_len != NULL_TREE) + { + /* The _len component needs to be set. Figure how to get the + value of the right-hand side. */ + if (from_len == NULL_TREE) + { + if (rse->string_length != NULL_TREE) + from_len = rse->string_length; + else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length) + { + from_len = gfc_get_expr_charlen (re); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, re->ts.u.cl->length); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + from_len = gfc_evaluate_now (se.expr, block); + } + else + from_len = integer_zero_node; + } + gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len), + from_len)); + } + } + + /* Return the _len trees only, when requested. */ + if (to_lenp) + *to_lenp = to_len; + if (from_lenp) + *from_lenp = from_len; + return lhs_vptr; +} + + +/* Assign tokens for pointer components. */ + +static void +trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1, + gfc_expr *expr2) +{ + symbol_attribute lhs_attr, rhs_attr; + tree tmp, lhs_tok, rhs_tok; + /* Flag to indicated component refs on the rhs. */ + bool rhs_cr; + + lhs_attr = gfc_caf_attr (expr1); + if (expr2->expr_type != EXPR_NULL) + { + rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr); + if (lhs_attr.codimension && rhs_attr.codimension) + { + lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1); + lhs_tok = build_fold_indirect_ref (lhs_tok); + + if (rhs_cr) + rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2); + else + { + tree caf_decl; + caf_decl = gfc_get_tree_for_caf_expr (expr2); + gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl, + NULL_TREE, NULL); + } + tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node, + lhs_tok, + fold_convert (TREE_TYPE (lhs_tok), rhs_tok)); + gfc_prepend_expr_to_block (&lse->post, tmp); + } + } + else if (lhs_attr.codimension) + { + lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1); + lhs_tok = build_fold_indirect_ref (lhs_tok); + tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node, + lhs_tok, null_pointer_node); + gfc_prepend_expr_to_block (&lse->post, tmp); + } +} + +/* Indentify class valued proc_pointer assignments. */ + +static bool +pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_ref * ref; + + ref = expr1->ref; + while (ref && ref->next) + ref = ref->next; + + return ref && ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer + && expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE; +} + + tree gfc_trans_pointer_assign (gfc_code * code) { @@ -7757,20 +8207,22 @@ gfc_trans_pointer_assign (gfc_code * code) tree gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { - gfc_expr *expr1_vptr = NULL; gfc_se lse; gfc_se rse; stmtblock_t block; tree desc; tree tmp; tree decl; - bool scalar; + bool scalar, non_proc_pointer_assign; gfc_ss *ss; gfc_start_block (&block); gfc_init_se (&lse, NULL); + /* Usually testing whether this is not a proc pointer assignment. */ + non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2); + /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ ss = gfc_walk_expr (expr1); @@ -7779,7 +8231,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_free_ss_chain (ss); if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS - && expr2->expr_type != EXPR_FUNCTION) + && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign) { gfc_add_data_component (expr2); /* The following is required as gfc_add_data_component doesn't @@ -7796,6 +8248,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) rse.want_pointer = 1; gfc_conv_expr (&rse, expr2); + if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS) + { + trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, + NULL); + lse.expr = gfc_class_data_get (lse.expr); + } + if (expr1->symtree->n.sym->attr.proc_pointer && expr1->symtree->n.sym->attr.dummy) lse.expr = build_fold_indirect_ref_loc (input_location, @@ -7809,27 +8268,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); - /* For string assignments to unlimited polymorphic pointers add an - assignment of the string_length to the _len component of the - pointer. */ - if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.unlimited_polymorphic - && (expr2->ts.type == BT_CHARACTER || - ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS) - && expr2->ts.u.derived->attr.unlimited_polymorphic))) - { - gfc_expr *len_comp; - gfc_se se; - len_comp = gfc_get_len_component (expr1); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, len_comp); - - /* ptr % _len = len (str) */ - gfc_add_modify (&block, se.expr, rse.string_length); - lse.string_length = se.expr; - gfc_free_expr (len_comp); - } - /* Check character lengths if character expression. The test is only really added if -fbounds-check is enabled. Exclude deferred character length lefthand sides. */ @@ -7856,12 +8294,14 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) build_int_cst (gfc_charlen_type_node, 0)); } - if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS) - rse.expr = gfc_class_data_get (rse.expr); - gfc_add_modify (&block, lse.expr, fold_convert (TREE_TYPE (lse.expr), rse.expr)); + /* Also set the tokens for pointer components in derived typed + coarrays. */ + if (flag_coarray == GFC_FCOARRAY_LIB) + trans_caf_token_assign (&lse, &rse, expr1, expr2); + gfc_add_block_to_block (&block, &rse.post); gfc_add_block_to_block (&block, &lse.post); } @@ -7869,6 +8309,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_ref* remap; bool rank_remap; + tree expr1_vptr = NULL_TREE; tree strlen_lhs; tree strlen_rhs = NULL_TREE; @@ -7885,9 +8326,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&lse, NULL); if (remap) lse.descriptor_only = 1; - if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS - && expr1->ts.type == BT_CLASS) - expr1_vptr = gfc_copy_expr (expr1); gfc_conv_expr_descriptor (&lse, expr1); strlen_lhs = lse.string_length; desc = lse.expr; @@ -7913,16 +8351,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) rse.expr = gfc_class_data_get (rse.expr); else { + expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, + expr2, &rse, + NULL, NULL); gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); gfc_add_modify (&lse.pre, tmp, rse.expr); - gfc_add_vptr_component (expr1_vptr); - gfc_init_se (&rse, NULL); - rse.want_pointer = 1; - gfc_conv_expr (&rse, expr1_vptr); - gfc_add_modify (&lse.pre, rse.expr, - fold_convert (TREE_TYPE (rse.expr), + gfc_add_modify (&lse.pre, expr1_vptr, + fold_convert (TREE_TYPE (expr1_vptr), gfc_class_vptr_get (tmp))); rse.expr = gfc_class_data_get (tmp); } @@ -7939,17 +8376,21 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) bound, bound, 0, GFC_ARRAY_POINTER_CONT, false); tmp = gfc_create_var (tmp, "ptrtemp"); - lse.descriptor_only = 0; - lse.expr = tmp; - lse.direct_byref = 1; - gfc_conv_expr_descriptor (&lse, expr2); - strlen_rhs = lse.string_length; + rse.descriptor_only = 0; + rse.expr = tmp; + rse.direct_byref = 1; + gfc_conv_expr_descriptor (&rse, expr2); + strlen_rhs = rse.string_length; rse.expr = tmp; } else { gfc_conv_expr_descriptor (&rse, expr2); strlen_rhs = rse.string_length; + if (expr1->ts.type == BT_CLASS) + expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, + expr2, &rse, + NULL, NULL); } } else if (expr2->expr_type == EXPR_VARIABLE) @@ -7968,12 +8409,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&rse, NULL); rse.descriptor_only = 1; gfc_conv_expr (&rse, expr2); + if (expr1->ts.type == BT_CLASS) + trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, + NULL, NULL); tmp = gfc_get_element_type (TREE_TYPE (rse.expr)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); if (!INTEGER_CST_P (tmp)) gfc_add_block_to_block (&lse.post, &rse.pre); gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); } + else if (expr1->ts.type == BT_CLASS) + { + rse.expr = NULL_TREE; + rse.string_length = NULL_TREE; + trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, + NULL, NULL); + } } else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) { @@ -7987,16 +8438,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) } else { + expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, + expr2, &rse, NULL, + NULL); gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); gfc_add_modify (&lse.pre, tmp, rse.expr); - gfc_add_vptr_component (expr1_vptr); - gfc_init_se (&rse, NULL); - rse.want_pointer = 1; - gfc_conv_expr (&rse, expr1_vptr); - gfc_add_modify (&lse.pre, rse.expr, - fold_convert (TREE_TYPE (rse.expr), + gfc_add_modify (&lse.pre, expr1_vptr, + fold_convert (TREE_TYPE (expr1_vptr), gfc_class_vptr_get (tmp))); rse.expr = gfc_class_data_get (tmp); gfc_add_modify (&lse.pre, desc, rse.expr); @@ -8015,9 +8465,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&lse.pre, desc, tmp); } - if (expr1_vptr) - gfc_free_expr (expr1_vptr); - gfc_add_block_to_block (&block, &lse.pre); if (rank_remap) gfc_add_block_to_block (&block, &rse.pre); @@ -8245,7 +8692,7 @@ gfc_conv_string_parameter (gfc_se * se) tree gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool deep_copy, bool dealloc) + bool deep_copy, bool dealloc, bool in_coarray) { stmtblock_t block; tree tmp; @@ -8267,7 +8714,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, if (rse->string_length != NULL_TREE) { - gcc_assert (rse->string_length != NULL_TREE); gfc_conv_string_parameter (rse); gfc_add_block_to_block (&block, &rse->pre); rlen = rse->string_length; @@ -8323,7 +8769,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, same as the lhs. */ if (deep_copy) { - tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0); + int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0; + tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0, + caf_mode); tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); gfc_add_expr_to_block (&block, tmp); @@ -9050,7 +9499,25 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size_in_bytes, size_one_node); - if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) + if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB) + { + tree caf_decl, token; + gfc_se caf_se; + symbol_attribute attr; + + gfc_clear_attr (&attr); + gfc_init_se (&caf_se, NULL); + + caf_decl = gfc_get_tree_for_caf_expr (expr1); + gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE, + NULL); + gfc_add_block_to_block (block, &caf_se.pre); + gfc_allocate_allocatable (block, lse.expr, size_in_bytes, + gfc_build_addr_expr (NULL_TREE, token), + NULL_TREE, NULL_TREE, NULL_TREE, jump_label1, + expr1, 1); + } + else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) { tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_CALLOC), @@ -9205,14 +9672,122 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) return false; } + +static tree +trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, + gfc_se *lse, gfc_se *rse, bool use_vptr_copy, + bool class_realloc) +{ + tree tmp, fcn, stdcopy, to_len, from_len, vptr; + vec<tree, va_gc> *args = NULL; + + vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, + &from_len); + + /* Generate allocation of the lhs. */ + if (class_realloc) + { + stmtblock_t alloc; + tree class_han; + + tmp = gfc_vptr_size_get (vptr); + class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + gfc_init_block (&alloc); + gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE); + tmp = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, class_han, + build_int_cst (prvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (tmp, + PRED_FORTRAN_FAIL_ALLOC), + gfc_finish_block (&alloc), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&lse->pre, tmp); + } + + fcn = gfc_vptr_copy_get (vptr); + + tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) + ? gfc_class_data_get (rse->expr) : rse->expr; + if (use_vptr_copy) + { + if (!POINTER_TYPE_P (TREE_TYPE (tmp)) + || INDIRECT_REF_P (tmp) + || (rhs->ts.type == BT_DERIVED + && rhs->ts.u.derived->attr.unlimited_polymorphic + && !rhs->ts.u.derived->attr.pointer + && !rhs->ts.u.derived->attr.allocatable) + || (UNLIMITED_POLY (rhs) + && !CLASS_DATA (rhs)->attr.pointer + && !CLASS_DATA (rhs)->attr.allocatable)) + vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp)); + else + vec_safe_push (args, tmp); + tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + if (!POINTER_TYPE_P (TREE_TYPE (tmp)) + || INDIRECT_REF_P (tmp) + || (lhs->ts.type == BT_DERIVED + && lhs->ts.u.derived->attr.unlimited_polymorphic + && !lhs->ts.u.derived->attr.pointer + && !lhs->ts.u.derived->attr.allocatable) + || (UNLIMITED_POLY (lhs) + && !CLASS_DATA (lhs)->attr.pointer + && !CLASS_DATA (lhs)->attr.allocatable)) + vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp)); + else + vec_safe_push (args, tmp); + + stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); + + if (to_len != NULL_TREE && !integer_zerop (from_len)) + { + tree extcopy; + vec_safe_push (args, from_len); + vec_safe_push (args, to_len); + extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); + + tmp = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, from_len, + integer_zero_node); + return fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, + extcopy, stdcopy); + } + else + return stdcopy; + } + else + { + tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + stmtblock_t tblock; + gfc_init_block (&tblock); + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + if (!POINTER_TYPE_P (TREE_TYPE (rhst))) + rhst = gfc_build_addr_expr (NULL_TREE, rhst); + /* When coming from a ptr_copy lhs and rhs are swapped. */ + gfc_add_modify_loc (input_location, &tblock, rhst, + fold_convert (TREE_TYPE (rhst), tmp)); + return gfc_finish_block (&tblock); + } +} + /* Subroutine of gfc_trans_assignment that actually scalarizes the assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. init_flag indicates initialization expressions and dealloc that no - deallocate prior assignment is needed (if in doubt, set true). */ + deallocate prior assignment is needed (if in doubt, set true). + When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy + routine instead of a pointer assignment. Alias resolution is only done, + when MAY_ALIAS is set (the default). This flag is used by ALLOCATE() + where it is known, that newly allocated memory on the lhs can never be + an alias of the rhs. */ static tree gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, - bool dealloc) + bool dealloc, bool use_vptr_copy, bool may_alias) { gfc_se lse; gfc_se rse; @@ -9227,7 +9802,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, bool scalar_to_array; tree string_length; int n; - bool maybe_workshare = false; + bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false; + symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; + bool is_poly_assign; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -9248,6 +9825,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || gfc_is_alloc_class_scalar_function (expr2))) expr2->must_finalize = 1; + /* Checking whether a class assignment is desired is quite complicated and + needed at two locations, so do it once only before the information is + needed. */ + lhs_attr = gfc_expr_attr (expr1); + is_poly_assign = (use_vptr_copy || lhs_attr.pointer + || (lhs_attr.allocatable && !lhs_attr.dimension)) + && (expr1->ts.type == BT_CLASS + || gfc_is_class_array_ref (expr1, NULL) + || gfc_is_class_scalar_expr (expr1) + || gfc_is_class_array_ref (expr2, NULL) + || gfc_is_class_scalar_expr (expr2)); + + + /* Only analyze the expressions for coarray properties, when in coarray-lib + mode. */ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp); + rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp); + } + if (lss != gfc_ss_terminator) { /* The assignment needs scalarization. */ @@ -9268,6 +9866,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (rss == gfc_ss_terminator) /* The rhs is scalar. Add a ss for the expression. */ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + /* When doing a class assign, then the handle to the rhs needs to be a + pointer to allow for polymorphism. */ + if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2)) + rss->info->type = GFC_SS_REFERENCE; /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, lss); @@ -9279,7 +9881,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, for (n = 0; n < GFC_MAX_DIMENSIONS; n++) loop.reverse[n] = GFC_ENABLE_REVERSE; /* Resolve any data dependencies in the statement. */ - gfc_conv_resolve_dependencies (&loop, lss, rss); + if (may_alias) + gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ gfc_conv_loop_setup (&loop, &expr2->where); @@ -9319,6 +9922,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); /* Translate the expression. */ + rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag + && lhs_caf_attr.codimension; gfc_conv_expr (&rse, expr2); /* Deal with the case of a scalar class function assigned to a derived type. */ @@ -9331,7 +9936,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Stabilize a string length for temporaries. */ if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred - && !(TREE_CODE (rse.string_length) == VAR_DECL + && !(VAR_P (rse.string_length) || TREE_CODE (rse.string_length) == PARM_DECL || TREE_CODE (rse.string_length) == INDIRECT_REF)) string_length = gfc_evaluate_now (rse.string_length, &rse.pre); @@ -9358,13 +9963,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tree cond; const char* msg; + tmp = INDIRECT_REF_P (lse.expr) + ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr; + /* We should only get array references here. */ - gcc_assert (TREE_CODE (lse.expr) == POINTER_PLUS_EXPR - || TREE_CODE (lse.expr) == ARRAY_REF); + gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR + || TREE_CODE (tmp) == ARRAY_REF); /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR) or the array itself(ARRAY_REF). */ - tmp = TREE_OPERAND (lse.expr, 0); + tmp = TREE_OPERAND (tmp, 0); /* Provide the address of the array. */ if (TREE_CODE (lse.expr) == ARRAY_REF) @@ -9415,9 +10023,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, nullification occurs before the call to the finalizer. In the case of a scalar to array assignment, this is done in gfc_trans_scalar_assign as part of the deep copy. */ - if (!scalar_to_array && (expr1->ts.type == BT_DERIVED) - && (gfc_is_alloc_class_array_function (expr2) - || gfc_is_alloc_class_scalar_function (expr2))) + if (!scalar_to_array && expr1->ts.type == BT_DERIVED + && (gfc_is_alloc_class_array_function (expr2) + || gfc_is_alloc_class_scalar_function (expr2))) { tmp = rse.expr; tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0); @@ -9426,16 +10034,54 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_block_to_block (&loop.post, &rse.post); } - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - gfc_expr_is_variable (expr2) || scalar_to_array - || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc); + if (is_poly_assign) + tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, + use_vptr_copy || (lhs_attr.allocatable + && !lhs_attr.dimension), + flag_realloc_lhs && !lhs_attr.pointer); + else if (flag_coarray == GFC_FCOARRAY_LIB + && lhs_caf_attr.codimension && rhs_caf_attr.codimension + && ((lhs_caf_attr.allocatable && lhs_refs_comp) + || (rhs_caf_attr.allocatable && rhs_refs_comp))) + { + /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an + allocatable component, because those need to be accessed via the + caf-runtime. No need to check for coindexes here, because resolve + has rewritten those already. */ + gfc_code code; + gfc_actual_arglist a1, a2; + /* Clear the structures to prevent accessing garbage. */ + memset (&code, '\0', sizeof (gfc_code)); + memset (&a1, '\0', sizeof (gfc_actual_arglist)); + memset (&a2, '\0', sizeof (gfc_actual_arglist)); + a1.expr = expr1; + a1.next = &a2; + a2.expr = expr2; + a2.next = NULL; + code.ext.actual = &a1; + code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); + tmp = gfc_conv_intrinsic_subroutine (&code); + } + else + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + gfc_expr_is_variable (expr2) + || scalar_to_array + || expr2->expr_type == EXPR_ARRAY, + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension); + /* Add the pre blocks to the body. */ + gfc_add_block_to_block (&body, &rse.pre); + gfc_add_block_to_block (&body, &lse.pre); gfc_add_expr_to_block (&body, tmp); + /* Add the post blocks to the body. */ + gfc_add_block_to_block (&body, &rse.post); + gfc_add_block_to_block (&body, &lse.post); if (lss == gfc_ss_terminator) { /* F2003: Add the code for reallocation on assignment. */ - if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)) + if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1) + && !is_poly_assign) alloc_scalar_allocatable_for_assignment (&block, string_length, expr1, expr2); @@ -9476,11 +10122,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* F2003: Allocate or reallocate lhs of allocatable array. */ if (flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && !gfc_expr_attr (expr1).codimension - && !gfc_is_coindexed (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2)) + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2)) { realloc_lhs_warning (expr1->ts.type, true, &expr1->where); ompws_flags &= ~OMPWS_SCALARIZER_WS; @@ -9547,7 +10191,7 @@ copyable_array_p (gfc_expr * expr) tree gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, - bool dealloc) + bool dealloc, bool use_vptr_copy, bool may_alias) { tree tmp; @@ -9590,13 +10234,14 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Fallback to the scalarizer to generate explicit loops. */ - return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc); + return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc, + use_vptr_copy, may_alias); } tree gfc_trans_init_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, true, false); + return gfc_trans_assignment (code->expr1, code->expr2, true, false, true); } tree |