diff --git a/expr.c b/expr.c index 211f304..2491803 100644 --- a/expr.c +++ b/expr.c @@ -3897,6 +3897,33 @@ gfc_get_variable_expr (gfc_symtree *var) } +/* Adds a full array reference to an expression, as needed. */ + +void +gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) +{ + gfc_ref *ref; + for (ref = e->ref; ref; ref = ref->next) + if (!ref->next) + break; + if (ref) + { + ref->next = gfc_get_ref (); + ref = ref->next; + } + else + { + e->ref = gfc_get_ref (); + ref = e->ref; + } + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = e->rank; + ref->u.ar.where = e->where; + ref->u.ar.as = as; +} + + gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *sym) { @@ -3910,16 +3937,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) /* It will always be a full array. */ lval->rank = sym->as ? sym->as->rank : 0; if (lval->rank) - { - lval->ref = gfc_get_ref (); - lval->ref->type = REF_ARRAY; - lval->ref->u.ar.type = AR_FULL; - lval->ref->u.ar.dimen = lval->rank; - lval->ref->u.ar.where = sym->declared_at; - lval->ref->u.ar.as = sym->ts.type == BT_CLASS - ? CLASS_DATA (sym)->as : sym->as; - } - + gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? + CLASS_DATA (sym)->as : sym->as); return lval; } diff --git a/gfortran.h b/gfortran.h index fabc16a..3bcffe9 100644 --- a/gfortran.h +++ b/gfortran.h @@ -786,9 +786,11 @@ typedef struct /* The symbol is a derived type with allocatable components, pointer components or private components, procedure pointer components, possibly nested. zero_comp is true if the derived type has no - component at all. */ + component at all. defined_assign_comp is true if the derived + type or an ancestor has a typebound defined assignment. */ unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, - private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1; + private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1, + defined_assign_comp:1; /* This is a temporary selector for SELECT TYPE. */ unsigned select_type_temporary:1; @@ -2761,6 +2763,7 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); bool gfc_has_default_initializer (gfc_symbol *); gfc_expr *gfc_default_initializer (gfc_typespec *); gfc_expr *gfc_get_variable_expr (gfc_symtree *); +void gfc_add_full_array_ref (gfc_expr *, gfc_array_spec *); gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *); gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr); diff --git a/resolve.c b/resolve.c index 53d695c..43ac38c 100644 --- a/resolve.c +++ b/resolve.c @@ -9553,6 +9553,396 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } +/* Add a component reference onto an expression. */ + +static void +add_comp_ref (gfc_expr *e, gfc_component *c) +{ + gfc_ref **ref; + ref = &(e->ref); + while (*ref) + ref = &((*ref)->next); + *ref = gfc_get_ref(); + (*ref)->type = REF_COMPONENT; + (*ref)->u.c.sym = e->ts.u.derived; + (*ref)->u.c.component = c; + e->ts = c->ts; + + /* Add a full array ref, as necessary. */ + if (c->as) + { + gfc_add_full_array_ref (e, c->as); + e->rank = c->as->rank; + } +} + + +/* Build an assignment. Keep the argument 'op' for future use, so that + pointer assignments can be made. */ + +static gfc_code * +build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, + gfc_component *comp1, gfc_component *comp2, locus loc) +{ + gfc_code *this_code; + + this_code = gfc_get_code (); + this_code->op = op; + this_code->next = NULL; + this_code->expr1 = gfc_copy_expr (expr1); + this_code->expr2 = gfc_copy_expr (expr2); + this_code->loc = loc; + if (comp1 && comp2) + { + add_comp_ref (this_code->expr1, comp1); + add_comp_ref (this_code->expr2, comp2); + } + + return this_code; +} + + +/* Makes a temporary variable expression based on the characteristics of + a given expression. */ + +static gfc_expr* +get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) +{ + static int serial = 0; + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + gfc_array_spec *as; + gfc_array_ref *aref; + gfc_ref *ref; + + sprintf (name, "DA@%d", serial++); + gfc_get_sym_tree (name, ns, &tmp, false); + gfc_add_type (tmp->n.sym, &e->ts, NULL); + + as = NULL; + ref = NULL; + aref = NULL; + + /* Obtain the arrayspec for the temporary. */ + if (e->rank) + { + aref = gfc_find_array_ref (e); + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->as == aref->as) + as = aref->as; + else + { + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && ref->u.c.component->as == aref->as) + { + as = aref->as; + break; + } + } + } + + /* Add the attributes and the arrayspec to the temporary. */ + tmp->n.sym->attr = gfc_expr_attr (e); + if (as) + { + tmp->n.sym->as = gfc_copy_array_spec (as); + if (!ref) + ref = e->ref; + if (as->type == AS_DEFERRED) + tmp->n.sym->attr.allocatable = 1; + } + else + tmp->n.sym->attr.dimension = 0; + + gfc_set_sym_referenced (tmp->n.sym); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + e = gfc_lval_expr_from_sym (tmp->n.sym); + + /* Should the lhs be a section, use its array ref for the + temporary expression. */ + if (aref && aref->type != AR_FULL) + { + gfc_free_ref_list (e->ref); + e->ref = gfc_copy_ref (ref); + } + return e; +} + + +/* Add one line of code to the code chain, making sure that 'head' and + 'tail' are appropriately updated. */ + +static void +add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) +{ + gcc_assert (this_code); + if (*head == NULL) + *head = *tail = *this_code; + else + *tail = gfc_append_code (*tail, *this_code); + *this_code = NULL; +} + + +/* Counts the potential number of part array references that would + result from resolution of typebound defined assignments. */ + +static int +nonscalar_typebound_assign (gfc_symbol *derived, int depth) +{ + gfc_component *c; + int c_depth = 0, t_depth; + + for (c= derived->components; c; c = c->next) + { + if ((c->ts.type != BT_DERIVED + || c->attr.pointer + || c->attr.allocatable + || c->attr.proc_pointer_comp + || c->attr.class_pointer + || c->attr.proc_pointer) + && !c->attr.defined_assign_comp) + continue; + + if (c->as && c_depth == 0) + c_depth = 1; + + if (c->ts.u.derived->attr.defined_assign_comp) + t_depth = nonscalar_typebound_assign (c->ts.u.derived, + c->as ? 1 : 0); + else + t_depth = 0; + + c_depth = t_depth > c_depth ? t_depth : c_depth; + } + return depth + c_depth; +} + + +/* Implement 7.2.1.3 of the F08 standard: + "An intrinsic assignment where the variable is of derived type is + performed as if each component of the variable were assigned from the + corresponding component of expr using pointer assignment (7.2.2) for + each pointer component, defined assignment for each nonpointer + nonallocatable component of a type that has a type-bound defined + assignment consistent with the component, intrinsic assignment for + each other nonpointer nonallocatable component, ..." + + The pointer assignments are taken care of by the intrinsic + assignment of the structure itself. This function recursively adds + defined assignments where required. The recursion is accomplished + by calling resolve_code. + + When the lhs in a defined assignment has intent INOUT, we need a + temporary for the lhs. In pseudo-code: + + ! Only call function lhs once. + if (lhs is not a constant or an variable) + temp_x = expr2 + expr2 => temp_x + ! Do the intrinsic assignment + expr1 = expr2 + ! Now do the defined assignments + do over components with typebound defined assignment [%cmp] + if (arg1 of defined assignment procedure is INOUT) + t1%cmp {defined=} expr2%cmp ! ensures INOUT lhs uses value + ! unaffected by intrinsic assign + expr1%cmp = t1%cmp ! Store in the result + else + expr1%cmp {defined=} expr2%cmp + */ + +/* The temporary assignments have to be put on top of the additional + code to avoid the result being changed by the intrinsic assignment. + */ +static int component_assignment_level = 0; +static gfc_code *tmp_head = NULL, *tmp_tail = NULL; + +static void +generate_component_assignments (gfc_code **code, gfc_namespace *ns) +{ + gfc_component *comp1, *comp2; + gfc_code *this_code = NULL, *head = NULL, *tail = NULL; + gfc_expr *t1; + int error_count, depth; +/* gfc_array_ref *aref;*/ + + gfc_get_errors (NULL, &error_count); + + /* Filter out continuing processing after an error. */ + if (error_count + || (*code)->expr1->ts.type != BT_DERIVED + || (*code)->expr2->ts.type != BT_DERIVED) + return; + + /* TODO: Handle more than one part array reference in assignments. */ + depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived, + (*code)->expr1->rank ? 1 : 0); + if (depth > 1) + { + gfc_warning ("TODO: type-bound defined assignment(s) at %L not " + "done because multiple part array references would " + "occur in intermediate expressions.", &(*code)->loc); + return; + } + + component_assignment_level++; + + /* Create a temporary so that functions get called only once. */ + if ((*code)->expr2->expr_type != EXPR_VARIABLE + && (*code)->expr2->expr_type != EXPR_CONSTANT) + { + gfc_expr *tmp_expr; + + /* Assign the rhs to the temporary. */ + tmp_expr = get_temp_from_expr ((*code)->expr1, ns); + this_code = build_assignment (EXEC_ASSIGN, + tmp_expr, (*code)->expr2, + NULL, NULL, (*code)->loc); + /* Add the code and substitute the rhs expression. */ + add_code_to_chain (&this_code, &tmp_head, &tmp_tail); + gfc_free_expr ((*code)->expr2); + (*code)->expr2 = tmp_expr; + } + + /* Do the intrinsic assignment. This is not needed if the lhs is one + of the temporaries generated here, since the intrinsic assignment + to the final result already does this. */ + if ((*code)->expr1->symtree->n.sym->name[2] != '@') + { + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, (*code)->expr2, + NULL, NULL, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + } + + comp1 = (*code)->expr1->ts.u.derived->components; + comp2 = (*code)->expr2->ts.u.derived->components; + + t1 = NULL; + for (; comp1; comp1 = comp1->next, comp2 = comp2->next) + { + bool inout = false; + + /* The intrinsic assignment does the right thing for pointers + of all kinds and allocatable components. */ + if (comp1->ts.type != BT_DERIVED + || comp1->attr.pointer + || comp1->attr.allocatable + || comp1->attr.proc_pointer_comp + || comp1->attr.class_pointer + || comp1->attr.proc_pointer) + continue; + + if (this_code) + add_code_to_chain (&this_code, &head, &tail); + + /* Make an assigment for this component. */ + this_code = gfc_get_code (); + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, (*code)->expr2, + comp1, comp2, (*code)->loc); + + /* Convert the assignment if there is a defined assignment for + this type. Otherwise, using the call from resolve_code, + recurse into its components. */ + resolve_code (this_code, ns); + + if (this_code->op == EXEC_ASSIGN_CALL) + { + gfc_symbol *rsym; + /* Check that there is a typebound defined assignment. If not, + then this must be a module defined assignment. We cannot + use the defined_assign_comp attribute here because it must + be this derived type that has the defined assignment and not + a parent type. */ + if (!(comp1->ts.u.derived->f2k_derived + && comp1->ts.u.derived->f2k_derived + ->tb_op[INTRINSIC_ASSIGN])) + { + gfc_free_statements (this_code); + continue; + } + + /* If the first argument of the subroutine has intent INOUT + a temporary must be generated and used instead. */ + rsym = this_code->resolved_sym; + if (rsym->formal + && rsym->formal->sym->attr.intent == INTENT_INOUT) + { + gfc_code *temp_code; + inout = true; + + /* Build the temporary required for the assignment and put + it at the head of the generated code. */ + if (!t1) + { + t1 = get_temp_from_expr ((*code)->expr1, ns); + temp_code = build_assignment (EXEC_ASSIGN, + t1, (*code)->expr1, + NULL, NULL, (*code)->loc); + add_code_to_chain (&temp_code, &tmp_head, &tmp_tail); + } + + /* Replace the first actual arg with the component of the + temporary. */ + gfc_free_expr (this_code->ext.actual->expr); + this_code->ext.actual->expr = gfc_copy_expr (t1); + add_comp_ref (this_code->ext.actual->expr, comp1); + } + } + else if (this_code->op == EXEC_ASSIGN && !this_code->next) + { + /* Don't add intrinsic assignments since they are already + effected by the intrinsic assignment of the structure. */ + gfc_free_statements (this_code); + this_code = NULL; + continue; + } + + add_code_to_chain (&this_code, &head, &tail); + + if (t1 && inout) + { + /* Transfer the value to the final result. */ + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, t1, + comp1, comp2, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + } + } + + if (this_code) + { + gfc_free_statements (this_code); + this_code = NULL; + } + + /* Put the temporary assignments at the top of the generated code. */ + if (tmp_head && component_assignment_level == 1) + { + gfc_append_code (tmp_head, head); + head = tmp_head; + tmp_head = tmp_tail = NULL; + } + + /* Now attach the remaining code chain to the input code. Step on + to the end of the new code since resolution is complete. */ + gcc_assert ((*code)->op == EXEC_ASSIGN); + tail->next = (*code)->next; + /* Overwrite 'code' because this would place the intrinsic assignment + before the temporary for the lhs is created. */ + gfc_free_expr ((*code)->expr1); + gfc_free_expr ((*code)->expr2); + **code = *head; + free (head); + *code = tail; + + component_assignment_level--; +} + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -9715,6 +10105,12 @@ resolve_code (gfc_code *code, gfc_namespace *ns) else goto call; } + + /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ + if (code->expr1->ts.type == BT_DERIVED + && code->expr1->ts.u.derived->attr.defined_assign_comp) + generate_component_assignments (&code, ns); + break; case EXEC_LABEL_ASSIGN: @@ -11948,6 +12344,43 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) } +/* This check for typebound defined assignments is done recursively + since the order in which derived types are resolved is not always in + order of the declarations. */ + +static void +check_defined_assignments (gfc_symbol *derived) +{ + gfc_component *c; + + for (c = derived->components; c; c = c->next) + { + if (c->ts.type != BT_DERIVED + || c->attr.pointer + || c->attr.allocatable + || c->attr.proc_pointer_comp + || c->attr.class_pointer + || c->attr.proc_pointer) + continue; + + if (c->ts.u.derived->attr.defined_assign_comp + || (c->ts.u.derived->f2k_derived + && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])) + { + derived->attr.defined_assign_comp = 1; + return; + } + + check_defined_assignments (c->ts.u.derived); + if (c->ts.u.derived->attr.defined_assign_comp) + { + derived->attr.defined_assign_comp = 1; + return; + } + } +} + + /* Resolve the components of a derived type. This does not have to wait until resolution stage, but can be done as soon as the dt declaration has been parsed. */ @@ -12345,6 +12778,12 @@ resolve_fl_derived0 (gfc_symbol *sym) return FAILURE; } + check_defined_assignments (sym); + + if (!sym->attr.defined_assign_comp && super_type) + sym->attr.defined_assign_comp + = super_type->attr.defined_assign_comp; + /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract @@ -14402,6 +14841,7 @@ gfc_resolve (gfc_namespace *ns) old_cs_base = cs_base; resolve_types (ns); + component_assignment_level = 0; resolve_codes (ns); gfc_current_ns = old_ns;