diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 46 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 39 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 35 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 688 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 10 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/defined_assignment_1.f90 | 90 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/defined_assignment_2.f90 | 74 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/defined_assignment_3.f90 | 38 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/defined_assignment_4.f90 | 35 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/defined_assignment_5.f90 | 76 |
10 files changed, 983 insertions, 148 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9530339e606..f9b6be75285 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,49 @@ +2012-12-01 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com> + Paul Thomas <pault@gcc.gnu.org> + + PR fortran/46897 + * gfortran.h : Add bit field 'defined_assign_comp' to + symbol_attribute structure. + Add primitive for gfc_add_full_array_ref. + * expr.c (gfc_add_full_array_ref): New function. + (gfc_lval_expr_from_sym): Call new function. + * resolve.c (add_comp_ref): New function. + (build_assignment): New function. + (get_temp_from_expr): New function + (add_code_to_chain): New function + (generate_component_assignments): New function that calls all + the above new functions. + (resolve_code): Call generate_component_assignments. + (check_defined_assignments): New function. + (resolve_fl_derived0): Call check_defined_assignments. + (gfc_resolve): Reset component_assignment_level in case it is + left in a bad state by errors. + + + * resolve.c (is_sym_host_assoc, resolve_procedure_interface, + resolve_contained_fntype, resolve_procedure_expression, + resolve_elemental_actual, resolve_global_procedure, + is_scalar_expr_ptr, gfc_iso_c_func_interface, resolve_function, + set_name_and_label, gfc_iso_c_sub_interface, + resolve_specific_s0, resolve_operator, compare_bound_mpz_t, + gfc_resolve_character_operator, resolve_typebound_function, + gfc_resolve_expr, forall_index, remove_last_array_ref, + conformable_arrays, resolve_allocate_expr, + resolve_allocate_deallocate, resolve_select_type, + resolve_transfer, resolve_where, + gfc_resolve_where_code_in_forall, gfc_resolve_forall_body, + gfc_count_forall_iterators, resolve_values, + resolve_bind_c_comms, resolve_bind_c_derived_types, + gfc_verify_binding_labels, apply_default_init, + build_default_init_expr, apply_default_init_local, + resolve_fl_var_and_proc, resolve_fl_procedure, + gfc_resolve_finalizers, check_generic_tbp_ambiguity, + resolve_typebound_intrinsic_op, resolve_typebound_procedure, + resolve_typebound_procedures, ensure_not_abstract, + resolve_fl_derived0, resolve_fl_parameter, resolve_symbol, + resolve_equivalence_derived): Remove trailing white space. + * gfortran.h : Remove trailing white space. + 2012-11-28 Tobias Burnus <burnus@net-b.de> PR fortran/52161 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 15570afb6ee..b535e8adf5d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3899,6 +3899,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) { @@ -3912,16 +3939,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/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fabc16a85e0..4942c1c920e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -98,7 +98,7 @@ gfc_try; /* These are flags for identifying whether we are reading a character literal between quotes or normal source code. */ - + typedef enum { NONSTRING = 0, INSTRING_WARN, INSTRING_NOWARN } gfc_instring; @@ -162,11 +162,11 @@ typedef enum INTRINSIC_AND, INTRINSIC_OR, INTRINSIC_EQV, INTRINSIC_NEQV, /* ==, /=, >, >=, <, <= */ INTRINSIC_EQ, INTRINSIC_NE, INTRINSIC_GT, INTRINSIC_GE, - INTRINSIC_LT, INTRINSIC_LE, + INTRINSIC_LT, INTRINSIC_LE, /* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */ INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS, - INTRINSIC_LT_OS, INTRINSIC_LE_OS, - INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, + INTRINSIC_LT_OS, INTRINSIC_LE_OS, + INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */ } gfc_intrinsic_op; @@ -199,7 +199,7 @@ typedef enum ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES, ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, - ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, + ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS, @@ -624,7 +624,7 @@ iso_fortran_env_symbol; #define NAMED_FUNCTION(a,b,c,d) a, typedef enum { - ISOCBINDING_INVALID = -1, + ISOCBINDING_INVALID = -1, #include "iso-c-binding.def" ISOCBINDING_LAST, ISOCBINDING_NUMBER = ISOCBINDING_LAST @@ -707,7 +707,7 @@ typedef struct use_only:1, /* Symbol has been use-associated, with ONLY. */ use_rename:1, /* Symbol has been use-associated and renamed. */ imported:1, /* Symbol has been associated by IMPORT. */ - host_assoc:1; /* Symbol has been host associated. */ + host_assoc:1; /* Symbol has been host associated. */ unsigned in_namelist:1, in_common:1, in_equivalence:1; unsigned function:1, subroutine:1, procedure:1; @@ -783,12 +783,14 @@ typedef struct /* Special attributes for Cray pointers, pointees. */ unsigned cray_pointer:1, cray_pointee:1; - /* The symbol is a derived type with allocatable components, pointer + /* 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 a (sub-)component 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; @@ -1240,7 +1242,7 @@ typedef struct gfc_symbol struct gfc_namespace *ns; /* namespace containing this symbol */ tree backend_decl; - + /* Identity of the intrinsic module the symbol comes from, or INTMOD_NONE if it's not imported from a intrinsic module. */ intmod_id from_intmod; @@ -1655,7 +1657,7 @@ typedef struct gfc_intrinsic_sym const char *name, *lib_name; gfc_intrinsic_arg *formal; gfc_typespec ts; - unsigned elemental:1, inquiry:1, transformational:1, pure:1, + unsigned elemental:1, inquiry:1, transformational:1, pure:1, generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1, from_module:1; @@ -1722,14 +1724,14 @@ typedef struct gfc_expr /* Sometimes, when an error has been emitted, it is necessary to prevent it from recurring. */ unsigned int error : 1; - + /* Mark an expression where a user operator has been substituted by a function call in interface.c(gfc_extend_expr). */ unsigned int user_operator : 1; /* Mark an expression as being a MOLD argument of ALLOCATE. */ unsigned int mold : 1; - + /* If an expression comes from a Hollerith constant or compile-time evaluation of a transfer statement, it may have a prescribed target- memory representation, and these cannot always be backformed from @@ -2040,7 +2042,7 @@ gfc_forall_iterator; typedef struct gfc_association_list { - struct gfc_association_list *next; + struct gfc_association_list *next; /* Whether this is association to a variable that can be changed; otherwise, it's association to an expression and the name may not be used as @@ -2351,7 +2353,7 @@ typedef struct gfc_finalizer still referenced or not for dereferencing it on deleting a gfc_finalizer structure. */ gfc_symbol* proc_sym; - gfc_symtree* proc_tree; + gfc_symtree* proc_tree; } gfc_finalizer; #define gfc_get_finalizer() XCNEW (gfc_finalizer) @@ -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/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f3d3beb8595..92df38c3ad7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -104,7 +104,7 @@ static bool is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) { for (ns = ns->parent; ns; ns = ns->parent) - { + { if (sym->ns == ns) return true; } @@ -220,7 +220,7 @@ resolve_procedure_interface (gfc_symbol *sym) sym->ts = ifc->result->ts; sym->result = sym; } - else + else sym->ts = ifc->ts; sym->ts.interface = ifc; sym->attr.function = ifc->attr.function; @@ -580,7 +580,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) } } - /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character + /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type, lists the only ways a character length value of * can be used: dummy arguments of procedures, named constants, and function results in external functions. Internal function results and results of module @@ -1323,7 +1323,7 @@ generic_sym (gfc_symbol *sym) return 0; gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); - + if (s != NULL) { if (s == sym) @@ -1444,7 +1444,7 @@ count_specific_procs (gfc_expr *e) int n; gfc_interface *p; gfc_symbol *sym; - + n = 0; sym = e->symtree->n.sym; @@ -1647,7 +1647,7 @@ resolve_procedure_expression (gfc_expr* expr) gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling" " itself recursively. Declare it RECURSIVE or use" " -frecursive", sym->name, &expr->where); - + return SUCCESS; } @@ -1955,7 +1955,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) else if (c && c->ext.actual != NULL) { arg0 = c->ext.actual; - + if (c->resolved_sym) esym = c->resolved_sym; else @@ -2371,7 +2371,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); - if (sym->attr.if_source != IFSRC_IFBODY) + if (sym->attr.if_source != IFSRC_IFBODY) gfc_procedure_use (def_sym, actual, where); gfc_errors_to_warnings (0); @@ -2774,7 +2774,7 @@ is_scalar_expr_ptr (gfc_expr *expr) { /* We have constant lower and upper bounds. If the difference between is 1, it can be considered a - scalar. + scalar. FIXME: Use gfc_dep_compare_expr instead. */ start = (int) mpz_get_si (ref->u.ar.as->lower[0]->value.integer); @@ -2841,7 +2841,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, the actual expression could be a part-ref of the expr symbol. */ arg_ts = &(args->expr->ts); arg_attr = gfc_expr_attr (args->expr); - + if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { /* If the user gave two args then they are providing something for @@ -2930,7 +2930,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, if (seen_section && retval == SUCCESS) gfc_warning ("Array section in '%s' call at %L", name, &(args->expr->where)); - + /* See if we have interoperable type and type param. */ if (gfc_verify_c_interop (arg_ts) == SUCCESS || gfc_check_any_c_kind (arg_ts) == SUCCESS) @@ -2944,7 +2944,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, is not an array of zero size. */ if (args_sym->attr.allocatable == 1) { - if (args_sym->attr.dimension != 0 + if (args_sym->attr.dimension != 0 && (args_sym->as && args_sym->as->rank == 0)) { gfc_error_now ("Allocatable variable '%s' used as a " @@ -2983,7 +2983,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, retval = FAILURE; } } - + /* Make sure it's not a character string. Arrays of any type should be ok if the variable is of a C interoperable type. */ @@ -3023,7 +3023,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, with no length type parameters. It still must have either the pointer or target attribute, and it can be allocatable (but must be allocated when c_loc is called). */ - if (args->expr->rank != 0 + if (args->expr->rank != 0 && is_scalar_expr_ptr (args->expr) != SUCCESS) { gfc_error_now ("Parameter '%s' to '%s' at %L must be a " @@ -3031,7 +3031,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)); retval = FAILURE; } - else if (arg_ts->type == BT_CHARACTER + else if (arg_ts->type == BT_CHARACTER && is_scalar_expr_ptr (args->expr) != SUCCESS) { gfc_error_now ("CHARACTER argument '%s' to '%s' at " @@ -3068,7 +3068,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)) == FAILURE) retval = FAILURE; } - + /* for c_loc/c_funloc, the new symbol is the same as the old one */ *new_sym = sym; } @@ -3148,7 +3148,7 @@ resolve_function (gfc_expr *expr) } inquiry_argument = false; - + /* Need to setup the call to the correct c_associated, depending on the number of cptrs to user gives to compare. */ if (sym && sym->attr.is_iso_c == 1) @@ -3156,12 +3156,12 @@ resolve_function (gfc_expr *expr) if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym) == FAILURE) return FAILURE; - + /* Get the symtree for the new symbol (resolved func). the old one will be freed later, when it's no longer used. */ gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree)); } - + /* Resume assumed_size checking. */ need_full_assumed_size--; @@ -3490,7 +3490,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym, sprintf (name, "%s_%c%d", sym->name, type, kind); /* Set up the binding label as the given symbol's label plus the type and kind. */ - *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type, + *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type, kind); } else @@ -3501,7 +3501,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym, sprintf (name, "%s", sym->name); *binding_label = sym->binding_label; } - + return; } @@ -3525,7 +3525,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) /* default to success; will override if find error */ match m = MATCH_YES; - /* Make sure the actual arguments are in the necessary order (based on the + /* Make sure the actual arguments are in the necessary order (based on the formal args) before resolving. */ if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE) { @@ -3537,7 +3537,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) { set_name_and_label (c, sym, name, &binding_label); - + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER) { if (c->ext.actual != NULL && c->ext.actual->next != NULL) @@ -3572,7 +3572,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) if (arg3 == NULL || arg3->expr == NULL) { m = MATCH_ERROR; - gfc_error ("Missing SHAPE argument for call to %s at %L", + gfc_error ("Missing SHAPE argument for call to %s at %L", sym->name, &c->loc); } else if (arg3->expr->ts.type != BT_INTEGER @@ -3609,7 +3609,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) { /* the 1 means to add the optional arg to formal list */ new_sym = get_iso_c_sym (sym, name, binding_label, 1); - + /* for error reporting, say it's declared where the original was */ new_sym->declared_at = sym->declared_at; } @@ -3625,7 +3625,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) c->resolved_sym = new_sym; else c->resolved_sym = sym; - + return m; } @@ -3642,7 +3642,7 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) m = gfc_iso_c_sub_interface (c,sym); return m; } - + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) { if (sym->attr.dummy) @@ -4072,7 +4072,7 @@ resolve_operator (gfc_expr *e) msg = "Equality comparison for %s at %L"; else msg = "Inequality comparison for %s at %L"; - + gfc_warning (msg, gfc_typename (&op1->ts), &op1->where); } } @@ -4083,7 +4083,7 @@ resolve_operator (gfc_expr *e) if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) sprintf (msg, _("Logicals at %%L must be compared with %s instead of %s"), - (e->value.op.op == INTRINSIC_EQ + (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS) ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); else @@ -4323,7 +4323,7 @@ compare_bound_mpz_t (gfc_expr *a, mpz_t b) } -/* Compute the last value of a sequence given by a triplet. +/* Compute the last value of a sequence given by a triplet. Return 0 if it wasn't able to compute the last value, or if the sequence if empty, and 1 otherwise. */ @@ -5620,7 +5620,7 @@ gfc_resolve_character_operator (gfc_expr *e) { gfc_free_expr (e1); gfc_free_expr (e2); - + return; } @@ -6281,7 +6281,7 @@ resolve_typebound_function (gfc_expr* e) e->value.function.esym = NULL; e->symtree = st; - if (new_ref) + if (new_ref) e->ref = new_ref; /* '_vptr' points to the vtab, which contains the procedure pointers. */ @@ -6607,7 +6607,7 @@ gfc_resolve_expr (gfc_expr *e) if (t == SUCCESS && e->ts.type == BT_CHARACTER) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER - here rather then add a duplicate test for it above. */ + here rather then add a duplicate test for it above. */ gfc_expand_constructor (e, false); t = gfc_resolve_character_array_constructor (e); } @@ -6769,7 +6769,7 @@ forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) { if (expr->expr_type != EXPR_VARIABLE) return false; - + /* A scalar assignment */ if (!expr->ref || *f == 1) { @@ -7052,7 +7052,7 @@ remove_last_array_ref (gfc_expr* e) /* Used in resolve_allocate_expr to check that a allocation-object and - a source-expr are conformable. This does not catch all possible + a source-expr are conformable. This does not catch all possible cases; in particular a runtime checking is needed. */ static gfc_try @@ -7060,7 +7060,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; for (tail = e2->ref; tail && tail->next; tail = tail->next); - + /* First compare rank. */ if (tail && e1->rank != tail->u.ar.as->rank) { @@ -7324,7 +7324,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) using _copy and trans_call. It is convenient to exploit that when the allocated type is different from the declared type but no SOURCE exists by setting expr3. */ - code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); + code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); } else if (!code->expr3) { @@ -7586,7 +7586,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* This is a potential collision. */ gfc_ref *pr = pe->ref; gfc_ref *qr = qe->ref; - + /* Follow the references until a) They start to differ, in which case there is no error; you can deallocate a%b and a%c in a single statement @@ -7622,18 +7622,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (pr->next && qr->next) { - int i; gfc_array_ref *par = &(pr->u.ar); gfc_array_ref *qar = &(qr->u.ar); - - for (i=0; i<par->dimen; i++) - { - if ((par->start[i] != NULL - || qar->start[i] != NULL) - && gfc_dep_compare_expr (par->start[i], - qar->start[i]) != 0) - goto break_label; - } + if ((par->start[0] != NULL || qar->start[0] != NULL) + && gfc_dep_compare_expr (par->start[0], + qar->start[0]) != 0) + break; } } else @@ -7641,12 +7635,10 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (pr->u.c.component->name != qr->u.c.component->name) break; } - + pr = pr->next; qr = qr->next; } - break_label: - ; } } } @@ -7668,7 +7660,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Callback function for our mergesort variant. Determines interval overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for - op1 > op2. Assumes we're not dealing with the default case. + op1 > op2. Assumes we're not dealing with the default case. We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). There are nine situations to check. */ @@ -8376,7 +8368,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) default_case = body; } } - + if (error > 0) return; @@ -8395,7 +8387,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) assoc->target = gfc_copy_expr (code->expr2); assoc->target->where = code->expr2->where; /* assoc->variable will be set by resolve_assoc_var. */ - + code->ext.block.assoc = assoc; code->expr1->symtree->n.sym->assoc = assoc; @@ -8466,7 +8458,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) resolve_assoc_var (st->n.sym, false); } - + /* Take out CLASS IS cases for separate treatment. */ body = code; while (body && body->block) @@ -8475,7 +8467,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { /* Add to class_is list. */ if (class_is == NULL) - { + { class_is = body->block; tail = class_is; } @@ -8496,7 +8488,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) if (class_is) { gfc_symbol *vtab; - + if (!default_case) { /* Add a default case to hold the CLASS IS cases. */ @@ -8544,7 +8536,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) } while (swapped); } - + /* Generate IF chain. */ if_st = gfc_get_code (); if_st->op = EXEC_IF; @@ -8580,7 +8572,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) new_st->op = EXEC_IF; new_st->next = default_case->next; } - + /* Replace CLASS DEFAULT code by the IF chain. */ default_case->next = if_st; } @@ -8597,7 +8589,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Resolve a transfer statement. This is making sure that: -- a derived type being transferred has only non-pointer components - -- a derived type being transferred doesn't have private components, unless + -- a derived type being transferred doesn't have private components, unless it's being transferred from the module where the type was defined -- we're not trying to transfer a whole assumed size array. */ @@ -8701,7 +8693,7 @@ resolve_transfer (gfc_code *code) /* Find the set of labels that are reachable from this block. We also record the last statement in each block. */ - + static void find_reachable_labels (gfc_code *block) { @@ -9007,7 +8999,7 @@ resolve_where (gfc_code *code, gfc_expr *mask) "inconsistent shape", &cnext->expr1->where); break; - + case EXEC_ASSIGN_CALL: resolve_call (cnext); if (!cnext->resolved_sym->attr.elemental) @@ -9093,7 +9085,7 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, case EXEC_ASSIGN: gfc_resolve_assign_in_forall (cnext, nvar, var_expr); break; - + /* WHERE operator assignment statement */ case EXEC_ASSIGN_CALL: resolve_call (cnext); @@ -9161,10 +9153,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) /* Counts the number of iterators needed inside a forall construct, including - nested forall constructs. This is used to allocate the needed memory + nested forall constructs. This is used to allocate the needed memory in gfc_resolve_forall. */ -static int +static int gfc_count_forall_iterators (gfc_code *code) { int max_iters, sub_iters, current_iters; @@ -9176,11 +9168,11 @@ gfc_count_forall_iterators (gfc_code *code) for (fa = code->ext.forall_iterator; fa; fa = fa->next) current_iters ++; - + code = code->block->next; while (code) - { + { if (code->op == EXEC_FORALL) { sub_iters = gfc_count_forall_iterators (code); @@ -9561,6 +9553,408 @@ 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 variable 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; + + /* This function could be expanded to support other expression type + but this is not needed here. */ + gcc_assert (e->expr_type == EXPR_VARIABLE); + + /* 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 one component's assignment procedure is INOUT + t1 = expr1 + #if expr2 non-variable + temp_x = expr2 + expr2 => temp_x + # endif + expr1 = expr2 + # for each cmp + t1%cmp {defined=} expr2%cmp + expr1%cmp = t1%cmp + #else + expr1 = expr2 + + # for each cmp + expr1%cmp {defined=} expr2%cmp + #endif + */ + +/* 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_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; + + /* 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); + this_code = NULL; + 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); + } + } + + /* This is probably not necessary. */ + 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. */ @@ -9723,6 +10117,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: @@ -9963,7 +10363,7 @@ resolve_values (gfc_symbol *sym) if (sym->value->expr_type == EXPR_STRUCTURE) t= resolve_structure_cons (sym->value, 1); - else + else t = gfc_resolve_expr (sym->value); if (t == FAILURE) @@ -9985,7 +10385,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree) { gfc_gsymbol *binding_label_gsym; gfc_gsymbol *comm_name_gsym; - const char * bind_label = comm_block_tree->n.common->binding_label + const char * bind_label = comm_block_tree->n.common->binding_label ? comm_block_tree->n.common->binding_label : ""; /* See if a global symbol exists by the common block's name. It may @@ -10028,7 +10428,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree) check and nothing to add as a global symbol for the label. */ if (!comm_block_tree->n.common->binding_label) return; - + binding_label_gsym = gfc_find_gsymbol (gfc_gsym_root, comm_block_tree->n.common->binding_label); @@ -10065,7 +10465,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree) comm_name_gsym->name, &(comm_name_gsym->where)); } } - + return; } @@ -10079,34 +10479,34 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym) if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED && derived_sym->attr.is_bind_c == 1) verify_bind_c_derived_type (derived_sym); - + return; } -/* Verify that any binding labels used in a given namespace do not collide +/* Verify that any binding labels used in a given namespace do not collide with the names or binding labels of any global symbols. */ static void gfc_verify_binding_labels (gfc_symbol *sym) { int has_error = 0; - - if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0 + + if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0 && sym->attr.flavor != FL_DERIVED && sym->binding_label) { gfc_gsymbol *bind_c_sym; bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label); - if (bind_c_sym != NULL + if (bind_c_sym != NULL && strcmp (bind_c_sym->name, sym->binding_label) == 0) { - if (sym->attr.if_source == IFSRC_DECL - && (bind_c_sym->type != GSYM_SUBROUTINE - && bind_c_sym->type != GSYM_FUNCTION) - && ((sym->attr.contained == 1 - && strcmp (bind_c_sym->sym_name, sym->name) != 0) - || (sym->attr.use_assoc == 1 + if (sym->attr.if_source == IFSRC_DECL + && (bind_c_sym->type != GSYM_SUBROUTINE + && bind_c_sym->type != GSYM_FUNCTION) + && ((sym->attr.contained == 1 + && strcmp (bind_c_sym->sym_name, sym->name) != 0) + || (sym->attr.use_assoc == 1 && (strcmp (bind_c_sym->mod_name, sym->module) != 0)))) { /* Make sure global procedures don't collide with anything. */ @@ -10116,10 +10516,10 @@ gfc_verify_binding_labels (gfc_symbol *sym) &(bind_c_sym->where)); has_error = 1; } - else if (sym->attr.contained == 0 - && (sym->attr.if_source == IFSRC_IFBODY - && sym->attr.flavor == FL_PROCEDURE) - && (bind_c_sym->sym_name != NULL + else if (sym->attr.contained == 0 + && (sym->attr.if_source == IFSRC_IFBODY + && sym->attr.flavor == FL_PROCEDURE) + && (bind_c_sym->sym_name != NULL && strcmp (bind_c_sym->sym_name, sym->name) != 0)) { /* Make sure procedures in interface bodies don't collide. */ @@ -10130,10 +10530,10 @@ gfc_verify_binding_labels (gfc_symbol *sym) &(bind_c_sym->where)); has_error = 1; } - else if (sym->attr.contained == 0 + else if (sym->attr.contained == 0 && sym->attr.if_source == IFSRC_UNKNOWN) if ((sym->attr.use_assoc && bind_c_sym->mod_name - && strcmp (bind_c_sym->mod_name, sym->module) != 0) + && strcmp (bind_c_sym->mod_name, sym->module) != 0) || sym->attr.use_assoc == 0) { gfc_error ("Binding label '%s' at %L collides with global " @@ -10350,7 +10750,7 @@ apply_default_init (gfc_symbol *sym) /* Build an initializer for a local integer, real, complex, logical, or character variable, based on the command line flags finit-local-zero, - finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns + finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns null if the symbol should not have a default initialization. */ static gfc_expr * build_default_init_expr (gfc_symbol *sym) @@ -10381,10 +10781,10 @@ build_default_init_expr (gfc_symbol *sym) characters, and only if the corresponding command-line flags were set. Otherwise, we free init_expr and return null. */ switch (sym->ts.type) - { + { case BT_INTEGER: if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) - mpz_set_si (init_expr->value.integer, + mpz_set_si (init_expr->value.integer, gfc_option.flag_init_integer_value); else { @@ -10421,7 +10821,7 @@ build_default_init_expr (gfc_symbol *sym) break; } break; - + case BT_COMPLEX: switch (gfc_option.flag_init_real) { @@ -10453,7 +10853,7 @@ build_default_init_expr (gfc_symbol *sym) break; } break; - + case BT_LOGICAL: if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE) init_expr->value.logical = 0; @@ -10465,9 +10865,9 @@ build_default_init_expr (gfc_symbol *sym) init_expr = NULL; } break; - + case BT_CHARACTER: - /* For characters, the length must be constant in order to + /* For characters, the length must be constant in order to create a default initializer. */ if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON && sym->ts.u.cl->length @@ -10506,7 +10906,7 @@ build_default_init_expr (gfc_symbol *sym) init_expr->value.function.actual = arg; } break; - + default: gfc_free_expr (init_expr); init_expr = NULL; @@ -10534,7 +10934,7 @@ apply_default_init_local (gfc_symbol *sym) /* For saved variables, we don't want to add an initializer at function entry, so we just add a static initializer. Note that automatic variables are stack allocated even with -fno-automatic. */ - if (sym->attr.save || sym->ns->save_all + if (sym->attr.save || sym->ns->save_all || (gfc_option.flag_max_stack_var_size == 0 && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))) { @@ -10639,7 +11039,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) return FAILURE; } } - + return SUCCESS; } @@ -11075,7 +11475,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) sym->attr.is_c_interop = 1; sym->ts.is_c_interop = 1; } - + curr_arg = sym->formal; while (curr_arg != NULL) { @@ -11087,7 +11487,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) BIND(C) to try and prevent multiple errors being reported. */ has_non_interop_arg = 1; - + curr_arg = curr_arg->next; } @@ -11100,7 +11500,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) sym->attr.is_bind_c = 0; } } - + if (!sym->attr.proc_pointer) { if (sym->attr.save == SAVE_EXPLICIT) @@ -11251,7 +11651,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) { gfc_error ("FINAL procedure '%s' declared at %L has the same" " rank (%d) as '%s'", - list->proc_sym->name, &list->where, my_rank, + list->proc_sym->name, &list->where, my_rank, i->proc_sym->name); goto error; } @@ -11337,7 +11737,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, else if (t2->specific->pass_arg) pass2 = t2->specific->pass_arg; else - pass2 = t2->specific->u.specific->n.sym->formal->sym->name; + pass2 = t2->specific->u.specific->n.sym->formal->sym->name; if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, NULL, 0, pass1, pass2)) { @@ -11514,7 +11914,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, { gfc_symbol* super_type; gfc_tbp_generic* target; - + /* If there's already an error here, do nothing (but don't fail again). */ if (p->error) return SUCCESS; @@ -11548,7 +11948,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, /* Add target to non-typebound operator list. */ if (!target->specific->deferred && !derived->attr.use_assoc - && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns) + && p->access != ACCESS_PRIVATE) { gfc_interface *head, *intr; if (gfc_check_new_interface (derived->ns->op[op], target_proc, @@ -11764,7 +12164,7 @@ resolve_typebound_procedure (gfc_symtree* stree) me_arg->name, &where, resolve_bindings_derived->name); goto error; } - + gcc_assert (me_arg->ts.type == BT_CLASS); if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) { @@ -11841,7 +12241,7 @@ resolve_typebound_procedures (gfc_symbol* derived) if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) return SUCCESS; - + super_type = gfc_get_derived_super_type (derived); if (super_type) resolve_typebound_procedures (super_type); @@ -11934,7 +12334,7 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) clearer than something sophisticated. */ gcc_assert (ancestor && !sub->attr.abstract); - + if (!ancestor->attr.abstract) return SUCCESS; @@ -11956,6 +12356,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. */ @@ -12069,7 +12506,7 @@ resolve_fl_derived0 (gfc_symbol *sym) c->attr.class_ok = ifc->result->attr.class_ok; } else - { + { c->ts = ifc->ts; c->attr.allocatable = ifc->attr.allocatable; c->attr.pointer = ifc->attr.pointer; @@ -12232,7 +12669,7 @@ resolve_fl_derived0 (gfc_symbol *sym) || (!sym->attr.is_class && c == sym->components)) && strcmp (super_type->name, c->name) == 0) c->attr.access = super_type->attr.access; - + /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ if (super_type && !sym->attr.is_class @@ -12353,6 +12790,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 @@ -12397,7 +12840,7 @@ resolve_fl_derived (gfc_symbol *sym) /* Resolve the finalizer procedures. */ if (gfc_resolve_finalizers (sym) == FAILURE) return FAILURE; - + if (sym->attr.is_class && sym->ts.u.derived == NULL) { /* Fix up incomplete CLASS symbols. */ @@ -12410,10 +12853,10 @@ resolve_fl_derived (gfc_symbol *sym) vptr->ts.u.derived = vtab->ts.u.derived; } } - + if (resolve_fl_derived0 (sym) == FAILURE) return FAILURE; - + /* Resolve the type-bound procedures. */ if (resolve_typebound_procedures (sym) == FAILURE) return FAILURE; @@ -12564,7 +13007,7 @@ static gfc_try resolve_fl_parameter (gfc_symbol *sym) { /* A parameter array's shape needs to be constant. */ - if (sym->as != NULL + if (sym->as != NULL && (sym->as->type == AS_DEFERRED || is_non_constant_shape_array (sym))) { @@ -12686,8 +13129,8 @@ resolve_symbol (gfc_symbol *sym) can. */ mp_flag = (sym->result != NULL && sym->result != sym); - /* Make sure that the intrinsic is consistent with its internal - representation. This needs to be done before assigning a default + /* Make sure that the intrinsic is consistent with its internal + representation. This needs to be done before assigning a default type to avoid spurious warnings. */ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE) @@ -12854,7 +13297,7 @@ resolve_symbol (gfc_symbol *sym) } if (sym->ts.type == BT_ASSUMED) - { + { /* TS 29113, C407a. */ if (!sym->attr.dummy) { @@ -12898,7 +13341,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED) { gfc_try t = SUCCESS; - + /* First, make sure the variable is declared at the module-level scope (J3/04-007, Section 15.3). */ if (sym->ns->proc_name->attr.flavor != FL_MODULE && @@ -12928,7 +13371,7 @@ resolve_symbol (gfc_symbol *sym) verify_bind_c_derived_type (sym->ts.u.derived); t = FAILURE; } - + /* Verify the variable itself as C interoperable if it is BIND(C). It is not possible for this to succeed if the verify_bind_c_derived_type failed, so don't have to handle @@ -13704,12 +14147,12 @@ gfc_implicit_pure (gfc_symbol *sym) sym = ns->proc_name; if (sym == NULL) return 0; - + if (sym->attr.flavor == FL_PROCEDURE) break; } } - + return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure && !sym->attr.pure; } @@ -13880,7 +14323,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) } -/* Resolve equivalence object. +/* Resolve equivalence object. An EQUIVALENCE object shall not be a dummy argument, a pointer, a target, an allocatable array, an object of nonsequence derived type, an object of sequence derived type containing a pointer at any level of component @@ -14410,6 +14853,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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a5e29e28d6b..38193deb82e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2012-12-01 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com> + Paul Thomas <pault@gcc.gnu.org> + + PR fortran/46897 + * gfortran.dg/defined_assignment_1.f90: New test. + * gfortran.dg/defined_assignment_2.f90: New test. + * gfortran.dg/defined_assignment_3.f90: New test. + * gfortran.dg/defined_assignment_4.f90: New test. + * gfortran.dg/defined_assignment_5.f90: New test. + 2012-12-01 Jakub Jelinek <jakub@redhat.com> PR c++/55542 diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_1.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_1.f90 new file mode 100644 index 00000000000..da06f26d191 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_1.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! Test the fix for PR46897. +! +! Contributed by Rouson Damian <rouson@sandia.gov> +! +module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo + end type + type, extends(parent) :: child + integer :: j + end type +contains + subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine + type(child) function new_child() + end function +end module + +module m1 + implicit none + type component1 + integer :: i = 1 + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type t + type(component1) :: foo + end type +contains + subroutine assign1(lhs,rhs) + class(component1), intent(out) :: lhs + class(component1), intent(in) :: rhs + lhs%i = 21 + end subroutine +end module + +module m2 + implicit none + type component2 + integer :: i = 2 + end type + interface assignment(=) + module procedure assign2 + end interface + type t2 + type(component2) :: foo + end type +contains + subroutine assign2(lhs,rhs) + type(component2), intent(out) :: lhs + type(component2), intent(in) :: rhs + lhs%i = 22 + end subroutine +end module + +program main + use m0 + use m1 + use m2 + implicit none + type(child) :: infant0 + type(t) :: infant1, newchild1 + type(t2) :: infant2, newchild2 + +! Test the reported problem. + infant0 = new_child() + if (infant0%parent%foo%i .ne. 20) call abort + +! Test the case of comment #1 of the PR. + infant1 = newchild1 + if (infant1%foo%i .ne. 21) call abort + +! Test the case of comment #2 of the PR. + infant2 = newchild2 + if (infant2%foo%i .ne. 2) call abort +end + + diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_2.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_2.f90 new file mode 100644 index 00000000000..78f2abb22fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_2.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR +! testcases run correctly, this checks that other requirements of the +! standard are satisfied. +! +module m0 + implicit none + type component + integer :: i = 0 + integer, allocatable :: j(:) + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo1 + end type + type, extends(parent) :: child + integer :: k = 1000 + integer, allocatable :: l(:) + type(component) :: foo2 + end type +contains + subroutine assign0(lhs,rhs) + class(component), intent(inout) :: lhs + class(component), intent(in) :: rhs + if (lhs%i .eq. 0) then + lhs%i = rhs%i + lhs%j = rhs%j + else + lhs%i = rhs%i*2 + lhs%j = [rhs%j, rhs%j*2] + end if + end subroutine + type(child) function new_child() + new_child%parent%foo1%i = 20 + new_child%foo2%i = 21 + new_child%parent%foo1%j = [99,199] + new_child%foo2%j = [199,299] + new_child%l = [299,399] + new_child%k = 1001 + end function +end module + +program main + use m0 + implicit none + type(child) :: infant0 + +! Check that the INTENT(INOUT) of assign0 is respected and that the +! correct thing is done with allocatable components. + infant0 = new_child() + if (infant0%parent%foo1%i .ne. 20) call abort + if (infant0%foo2%i .ne. 21) call abort + if (any (infant0%parent%foo1%j .ne. [99,199])) call abort + if (any (infant0%foo2%j .ne. [199,299])) call abort + if (infant0%foo2%i .ne. 21) call abort + if (any (infant0%l .ne. [299,399])) call abort + +! Now, since the defined assignment depends on whether or not the 'i' +! component is the default initialization value, the result will be +! different. + infant0 = new_child() + if (infant0%parent%foo1%i .ne. 40) call abort + if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) call abort + if (any (infant0%foo2%j .ne. [199,299,398,598])) call abort + if (infant0%foo2%i .ne. 42) call abort + if (any (infant0%l .ne. [299,399])) call abort + +! Finally, make sure that normal components of the declared type survive. + if (infant0%k .ne. 1001) call abort +end + + diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 new file mode 100644 index 00000000000..81a9841434f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR +! testcases run correctly, this checks array components are OK. +! +module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo(2) + end type + type, extends(parent) :: child + integer :: j + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + + +program main + use m0 + implicit none + type(child) :: infant0, infant1(2) + + infant0 = child([component(1),component(2)], 99) + if (any (infant0%parent%foo%i .ne. [20, 20])) call abort + +end + + diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_4.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_4.f90 new file mode 100644 index 00000000000..e7a1b8e0f64 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_4.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Test the fix for PR46897. First patch did not run this case correctly. +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +module a_mod + type :: a + integer :: i = 99 + contains + procedure :: a_ass + generic :: assignment(=) => a_ass + end type a + + type c + type(a) :: ta + end type c + + type :: b + type(c) :: tc + end type b + +contains + elemental subroutine a_ass(out, in) + class(a), intent(INout) :: out + type(a), intent(in) :: in + out%i = 2*in%i + end subroutine a_ass +end module a_mod + +program assign + use a_mod + type(b) :: tt + type(b) :: tb1 + tt = tb1 + if (tt%tc%ta%i .ne. 198) call abort +end program assign diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 new file mode 100644 index 00000000000..faf38298e42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! Further test of typebound defined assignment +! +module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo(2) + end type + type, extends(parent) :: child + integer :: j + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +module m1 + implicit none + type component1 + integer :: i = 0 + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type parent1 + type(component1) :: foo + end type + type, extends(parent1) :: child1 + integer :: j = 7 + end type +contains + elemental subroutine assign1(lhs,rhs) + class(component1), intent(out) :: lhs + class(component1), intent(in) :: rhs + lhs%i = 30 + end subroutine +end module + + +program main + use m0 + use m1 + implicit none + type(child) :: infant(2) + type(parent) :: dad, mum + type(child1) :: orphan(5) + type(child1), allocatable :: annie(:) + integer :: i, j, k + + dad = parent ([component (3), component (4)]) + mum = parent ([component (5), component (6)]) + infant = [child(dad, 999), child(mum, 9999)] ! { dg-warning "multiple part array references" } + +! Check that array sections are OK + i = 3 + j = 4 + orphan(i:j) = child1(component1(777), 1) + if (any (orphan%parent1%foo%i .ne. [0,0,30,30,0])) call abort + if (any (orphan%j .ne. [7,7,1,1,7])) call abort + +! Check that allocatable lhs's work OK. + annie = [(child1(component1(k), 2*k), k = 1,3)] + if (any (annie%parent1%foo%i .ne. [30,30,30])) call abort + if (any (annie%j .ne. [2,4,6])) call abort +end + + |