diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 59 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 265 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 814 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 27 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 | 3 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/allocate_class_4.f90 | 36 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 | 213 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03 | 215 |
16 files changed, 1291 insertions, 416 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0120d9c..ef4abc2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,62 @@ +2015-03-24 Andre Vehreschild <vehre@gmx.de> + + PR fortran/64787 + PR fortran/57456 + PR fortran/63230 + * class.c (gfc_add_component_ref): Free no longer needed + ref-chains to prevent memory loss. + (find_intrinsic_vtab): For deferred length char arrays or + unlimited polymorphic objects, store the size in bytes of one + character in the size component of the vtab. + * gfortran.h: Added gfc_add_len_component () define. + * trans-array.c (gfc_trans_create_temp_array): Switched to new + function name for getting a class' vtab's field. + (build_class_array_ref): Likewise. + (gfc_array_init_size): Using the size information from allocate + more consequently now, i.e., the typespec of the entity to + allocate is no longer needed. This is to address the last open + comment in PR fortran/57456. + (gfc_array_allocate): Likewise. + (structure_alloc_comps): gfc_copy_class_to_class () needs to + know whether the class is unlimited polymorphic. + * trans-array.h: Changed interface of gfc_array_allocate () to + reflect the no longer needed typespec. + * trans-expr.c (gfc_find_and_cut_at_last_class_ref): New. + (gfc_reset_len): New. + (gfc_get_class_array_ref): Switch to new function name for + getting a class' vtab's field. + (gfc_copy_class_to_class): Added flag to know whether the class + to copy is unlimited polymorphic. Adding _len dependent code + then, which calls ->vptr->copy () with four arguments adding + the length information ->vptr->copy(from, to, from_len, to_cap). + (gfc_conv_procedure_call): Switch to new function name for + getting a class' vtab's field. + (alloc_scalar_allocatable_for_assignment): Use the string_length + as computed by gfc_conv_expr and not the statically backend_decl + which may be incorrect when ref-ing. + (gfc_trans_assignment_1): Use the string_length variable and + not the rse.string_length. The former has been computed more + generally. + * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Switch to new + function name for getting a class' vtab's field. + (gfc_conv_intrinsic_storage_size): Likewise. + (gfc_conv_intrinsic_transfer): Likewise. + * trans-stmt.c (gfc_trans_allocate): Restructured to evaluate + source=expr3 only once before the loop over the objects to + allocate, when the objects are not arrays. Doing correct _len + initialization and calling of vptr->copy () fixing PR 64787. + (gfc_trans_deallocate): Reseting _len to 0, preventing future + errors. + * trans.c (gfc_build_array_ref): Switch to new function name + for getting a class' vtab's field. + (gfc_add_comp_finalizer_call): Likewise. + * trans.h: Define the prototypes for the gfc_class_vtab_*_get () + and gfc_vptr_*_get () functions. + Added gfc_find_and_cut_at_last_class_ref () and + gfc_reset_len () routine prototype. Added flag to + gfc_copy_class_to_class () prototype to signal an unlimited + polymorphic entity to copy. + 2015-03-24 Iain Sandoe <iain@codesourcery.com> Tobias Burnus <burnus@net-b.de> diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 786876c..7990399 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -234,6 +234,9 @@ gfc_add_component_ref (gfc_expr *e, const char *name) } if (*tail != NULL && strcmp (name, "_data") == 0) next = *tail; + else + /* Avoid losing memory. */ + gfc_free_ref_list (*tail); (*tail) = gfc_get_ref(); (*tail)->next = next; (*tail)->type = REF_COMPONENT; @@ -2562,13 +2565,19 @@ find_intrinsic_vtab (gfc_typespec *ts) c->attr.access = ACCESS_PRIVATE; /* Build a minimal expression to make use of - target-memory.c/gfc_element_size for 'size'. */ + target-memory.c/gfc_element_size for 'size'. Special handling + for character arrays, that are not constant sized: to support + len (str) * kind, only the kind information is stored in the + vtab. */ e = gfc_get_expr (); e->ts = *ts; e->expr_type = EXPR_VARIABLE; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, - (int)gfc_element_size (e)); + ts->type == BT_CHARACTER + && charlen == 0 ? + ts->kind : + (int)gfc_element_size (e)); gfc_free_expr (e); /* Add component _extends. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9be2010..8e6595f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3175,6 +3175,7 @@ void gfc_add_component_ref (gfc_expr *, const char *); void gfc_add_class_array_ref (gfc_expr *); #define gfc_add_data_component(e) gfc_add_component_ref(e,"_data") #define gfc_add_vptr_component(e) gfc_add_component_ref(e,"_vptr") +#define gfc_add_len_component(e) gfc_add_component_ref(e,"_len") #define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash") #define gfc_add_size_component(e) gfc_add_component_ref(e,"_size") #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init") diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0dbfdaa..1768974 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1196,7 +1196,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, elemsize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); else - elemsize = gfc_vtable_size_get (class_expr); + elemsize = gfc_class_vtab_size_get (class_expr); size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, elemsize); @@ -3066,7 +3066,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index) if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) return false; - size = gfc_vtable_size_get (decl); + size = gfc_class_vtab_size_get (decl); /* Build the address of the element. */ type = TREE_TYPE (TREE_TYPE (base)); @@ -4956,8 +4956,7 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - gfc_typespec *ts) + tree expr3_elem_size, tree *nelems, gfc_expr *expr3) { tree type; tree tmp; @@ -4983,7 +4982,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type)); or_expr = boolean_false_node; @@ -5137,9 +5136,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = TYPE_SIZE_UNIT (tmp); } } - else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER) - /* FIXME: Properly handle characters. See PR 57456. */ - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts)); else tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); @@ -5211,7 +5207,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3, gfc_typespec *ts) + tree *nelems, gfc_expr *expr3) { tree tmp; tree pointer; @@ -5296,7 +5292,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, ts); + expr3_elem_size, nelems, expr3); if (dimension) { @@ -7942,7 +7938,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dst_data = gfc_class_data_get (dcmp); src_data = gfc_class_data_get (comp); - size = fold_convert (size_type_node, gfc_vtable_size_get (comp)); + size = fold_convert (size_type_node, + gfc_class_vtab_size_get (comp)); if (CLASS_DATA (c)->attr.dimension) { @@ -7977,7 +7974,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, fold_convert (TREE_TYPE (dst_data), tmp)); } - tmp = gfc_copy_class_to_class (comp, dcmp, nelems); + tmp = gfc_copy_class_to_class (comp, dcmp, nelems, + UNLIMITED_POLY (c)); gfc_add_expr_to_block (&tmpblock, tmp); tmp = gfc_finish_block (&tmpblock); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 583000e..8544534 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, gfc_typespec *); + tree, tree *, gfc_expr *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index fd3dd8c2..9bf976a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -166,72 +166,85 @@ gfc_class_len_get (tree decl) if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), - CLASS_LEN_FIELD); + CLASS_LEN_FIELD); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (len), decl, len, NULL_TREE); } +/* Get the specified FIELD from the VPTR. */ + static tree -gfc_vtable_field_get (tree decl, int field) +vptr_field_get (tree vptr, int fieldno) { - tree size; - tree vptr; - vptr = gfc_class_vptr_get (decl); + tree field; vptr = build_fold_indirect_ref_loc (input_location, vptr); - size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)), - field); - size = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (size), vptr, size, - NULL_TREE); - /* Always return size as an array index type. */ - if (field == VTABLE_SIZE_FIELD) - size = fold_convert (gfc_array_index_type, size); - gcc_assert (size); - return size; + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)), + fieldno); + field = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), vptr, field, + NULL_TREE); + gcc_assert (field); + return field; } -tree -gfc_vtable_hash_get (tree decl) -{ - return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD); -} - +/* Get the field from the class' vptr. */ -tree -gfc_vtable_size_get (tree decl) +static tree +class_vtab_field_get (tree decl, int fieldno) { - return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD); + tree vptr; + vptr = gfc_class_vptr_get (decl); + return vptr_field_get (vptr, fieldno); } -tree -gfc_vtable_extends_get (tree decl) -{ - return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD); +/* Define a macro for creating the class_vtab_* and vptr_* accessors in + unison. */ +#define VTAB_GET_FIELD_GEN(name, field) tree \ +gfc_class_vtab_## name ##_get (tree cl) \ +{ \ + return class_vtab_field_get (cl, field); \ +} \ + \ +tree \ +gfc_vptr_## name ##_get (tree vptr) \ +{ \ + return vptr_field_get (vptr, field); \ } +VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD) +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) -tree -gfc_vtable_def_init_get (tree decl) -{ - return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD); -} +/* The size field is returned as an array index type. Therefore treat + it and only it specially. */ tree -gfc_vtable_copy_get (tree decl) +gfc_class_vtab_size_get (tree cl) { - return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD); + tree size; + size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD); + /* Always return size as an array index type. */ + size = fold_convert (gfc_array_index_type, size); + gcc_assert (size); + return size; } - tree -gfc_vtable_final_get (tree decl) +gfc_vptr_size_get (tree vptr) { - return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD); + tree size; + size = vptr_field_get (vptr, VTABLE_SIZE_FIELD); + /* Always return size as an array index type. */ + size = fold_convert (gfc_array_index_type, size); + gcc_assert (size); + return size; } @@ -245,6 +258,61 @@ gfc_vtable_final_get (tree decl) #undef VTABLE_FINAL_FIELD +/* Search for the last _class ref in the chain of references of this + expression and cut the chain there. Albeit this routine is similiar + to class.c::gfc_add_component_ref (), is there a significant + difference: gfc_add_component_ref () concentrates on an array ref to + be the last ref in the chain. This routine is oblivious to the kind + of refs following. */ + +gfc_expr * +gfc_find_and_cut_at_last_class_ref (gfc_expr *e) +{ + gfc_expr *base_expr; + gfc_ref *ref, *class_ref, *tail; + + /* Find the last class reference. */ + class_ref = NULL; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS) + class_ref = ref; + + if (ref->next == NULL) + break; + } + + /* Remove and store all subsequent references after the + CLASS reference. */ + if (class_ref) + { + tail = class_ref->next; + class_ref->next = NULL; + } + else + { + tail = e->ref; + e->ref = NULL; + } + + base_expr = gfc_expr_to_initialize (e); + + /* Restore the original tail expression. */ + if (class_ref) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = tail; + } + else + { + gfc_free_ref_list (e->ref); + e->ref = tail; + } + return base_expr; +} + + /* Reset the vptr to the declared type, e.g. after deallocation. */ void @@ -294,6 +362,23 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) } +/* Reset the len for unlimited polymorphic objects. */ + +void +gfc_reset_len (stmtblock_t *block, gfc_expr *expr) +{ + gfc_expr *e; + gfc_se se_len; + e = gfc_find_and_cut_at_last_class_ref (expr); + gfc_add_len_component (e); + gfc_init_se (&se_len, NULL); + gfc_conv_expr (&se_len, e); + gfc_add_modify (block, se_len.expr, + fold_convert (TREE_TYPE (se_len.expr), integer_zero_node)); + gfc_free_expr (e); +} + + /* Obtain the vptr of the last class reference in an expression. Return NULL_TREE if no class reference is found. */ @@ -873,7 +958,7 @@ tree gfc_get_class_array_ref (tree index, tree class_decl) { tree data = gfc_class_data_get (class_decl); - tree size = gfc_vtable_size_get (class_decl); + tree size = gfc_class_vtab_size_get (class_decl); tree offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, index, size); @@ -891,39 +976,57 @@ gfc_get_class_array_ref (tree index, tree class_decl) that the _vptr is set. */ tree -gfc_copy_class_to_class (tree from, tree to, tree nelems) +gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) { tree fcn; tree fcn_type; tree from_data; + tree from_len; tree to_data; + tree to_len; tree to_ref; tree from_ref; vec<tree, va_gc> *args; tree tmp; + tree stdcopy; + tree extcopy; tree index; - stmtblock_t loopbody; - stmtblock_t body; - gfc_loopinfo loop; args = NULL; + /* To prevent warnings on uninitialized variables. */ + from_len = to_len = NULL_TREE; if (from != NULL_TREE) - fcn = gfc_vtable_copy_get (from); + fcn = gfc_class_vtab_copy_get (from); else - fcn = gfc_vtable_copy_get (to); + fcn = gfc_class_vtab_copy_get (to); fcn_type = TREE_TYPE (TREE_TYPE (fcn)); if (from != NULL_TREE) - from_data = gfc_class_data_get (from); + from_data = gfc_class_data_get (from); else - from_data = gfc_vtable_def_init_get (to); + from_data = gfc_class_vtab_def_init_get (to); + + if (unlimited) + { + if (from != NULL_TREE && unlimited) + from_len = gfc_class_len_get (from); + else + from_len = integer_zero_node; + } to_data = gfc_class_data_get (to); + if (unlimited) + to_len = gfc_class_len_get (to); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))) { + stmtblock_t loopbody; + stmtblock_t body; + stmtblock_t ifbody; + gfc_loopinfo loop; + gfc_init_block (&body); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, nelems, @@ -955,8 +1058,42 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems) loop.loopvar[0] = index; loop.to[0] = nelems; gfc_trans_scalarizing_loops (&loop, &loopbody); - gfc_add_block_to_block (&body, &loop.pre); - tmp = gfc_finish_block (&body); + gfc_init_block (&ifbody); + gfc_add_block_to_block (&ifbody, &loop.pre); + stdcopy = gfc_finish_block (&ifbody); + if (unlimited) + { + vec_safe_push (args, from_len); + vec_safe_push (args, to_len); + tmp = build_call_vec (fcn_type, fcn, args); + /* Build the body of the loop. */ + gfc_init_block (&loopbody); + gfc_add_expr_to_block (&loopbody, tmp); + + /* Build the loop and return. */ + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &loopbody); + gfc_init_block (&ifbody); + gfc_add_block_to_block (&ifbody, &loop.pre); + extcopy = gfc_finish_block (&ifbody); + + tmp = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, from_len, + integer_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, extcopy, stdcopy); + gfc_add_expr_to_block (&body, tmp); + tmp = gfc_finish_block (&body); + } + else + { + gfc_add_expr_to_block (&body, stdcopy); + tmp = gfc_finish_block (&body); + } gfc_cleanup_loop (&loop); } else @@ -964,12 +1101,27 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems) gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))); vec_safe_push (args, from_data); vec_safe_push (args, to_data); - tmp = build_call_vec (fcn_type, fcn, args); + stdcopy = build_call_vec (fcn_type, fcn, args); + + if (unlimited) + { + vec_safe_push (args, from_len); + vec_safe_push (args, to_len); + extcopy = build_call_vec (fcn_type, fcn, args); + tmp = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, from_len, + integer_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, extcopy, stdcopy); + } + else + tmp = stdcopy; } return tmp; } + static tree gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) { @@ -5693,7 +5845,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (expr->value.function.esym->result)->attr); } - final_fndecl = gfc_vtable_final_get (se->expr); + final_fndecl = gfc_class_vtab_final_get (se->expr); is_final = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, final_fndecl, @@ -5704,7 +5856,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = build_call_expr_loc (input_location, final_fndecl, 3, gfc_build_addr_expr (NULL, tmp), - gfc_vtable_size_get (se->expr), + gfc_class_vtab_size_get (se->expr), boolean_false_node); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, is_final, tmp, @@ -8529,7 +8681,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) { cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - expr1->ts.u.cl->backend_decl, size); + lse.string_length, size); /* Jump past the realloc if the lengths are the same. */ tmp = build3_v (COND_EXPR, cond, build1_v (GOTO_EXPR, jump_label2), @@ -8546,10 +8698,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, /* Update the lhs character length. */ size = string_length; - if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL) - gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size); - else - gfc_add_modify (block, lse.string_length, size); + gfc_add_modify (block, lse.string_length, size); } } @@ -8839,7 +8988,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { /* F2003: Add the code for reallocation on assignment. */ if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)) - alloc_scalar_allocatable_for_assignment (&block, rse.string_length, + alloc_scalar_allocatable_for_assignment (&block, string_length, expr1, expr2); /* Use the scalar assignment as is. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 6f23a97..c4ccb7b 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2755,7 +2755,7 @@ if (least <= 2) arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) : null_pointer_node; } - + if (least == 2) { arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) @@ -5922,9 +5922,9 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) else if (arg->ts.type == BT_CLASS) { if (arg->rank) - byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); + byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); else - byte_size = gfc_vtable_size_get (argse.expr); + byte_size = gfc_class_vtab_size_get (argse.expr); } else { @@ -6053,7 +6053,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) gfc_conv_expr_descriptor (&argse, arg); if (arg->ts.type == BT_CLASS) { - tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); + tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); tmp = fold_convert (result_type, tmp); goto done; } @@ -6198,7 +6198,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) argse.string_length); break; case BT_CLASS: - tmp = gfc_vtable_size_get (argse.expr); + tmp = gfc_class_vtab_size_get (argse.expr); break; default: source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, @@ -6322,7 +6322,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); break; case BT_CLASS: - tmp = gfc_vtable_size_get (argse.expr); + tmp = gfc_class_vtab_size_get (argse.expr); break; default: tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type)); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6450a0e..a6fb52c 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4932,9 +4932,8 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *e; gfc_expr *expr; - gfc_se se; + gfc_se se, se_sz; tree tmp; tree parm; tree stat; @@ -4943,21 +4942,23 @@ gfc_trans_allocate (gfc_code * code) tree label_errmsg; tree label_finish; tree memsz; - tree expr3; - tree slen3; + tree al_vptr, al_len; + /* If an expr3 is present, then store the tree for accessing its + _vptr, and _len components in the variables, respectively. The + element size, i.e. _vptr%size, is stored in expr3_esize. Any of + the trees may be the NULL_TREE indicating that this is not + available for expr3's type. */ + tree expr3, expr3_vptr, expr3_len, expr3_esize; stmtblock_t block; stmtblock_t post; - gfc_expr *sz; - gfc_se se_sz; - tree class_expr; tree nelems; - tree memsize = NULL_TREE; - tree classexpr = NULL_TREE; + bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set; if (!code->ext.alloc.list) return NULL_TREE; - stat = tmp = memsz = NULL_TREE; + stat = tmp = memsz = al_vptr = al_len = NULL_TREE; + expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; label_errmsg = label_finish = errmsg = errlen = NULL_TREE; gfc_init_block (&block); @@ -4991,206 +4992,364 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - expr3 = NULL_TREE; - slen3 = NULL_TREE; + /* When an expr3 is present, try to evaluate it only once. In most + cases expr3 is invariant for all elements of the allocation list. + Only exceptions are arrays. Furthermore the standards prevent a + dependency of expr3 on the objects in the allocate list. Therefore + it is safe to pre-evaluate expr3 for complicated expressions, i.e. + everything not a variable or constant. When an array allocation + is wanted, then the following block nevertheless evaluates the + _vptr, _len and element_size for expr3. */ + if (code->expr3) + { + bool vtab_needed = false; + /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., + the expression is only needed to get the _vptr, _len a.s.o. */ + tree expr3_tmp = NULL_TREE; + + /* Figure whether we need the vtab from expr3. */ + for (al = code->ext.alloc.list; !vtab_needed && al != NULL; + al = al->next) + vtab_needed = (al->expr->ts.type == BT_CLASS); + + /* A array expr3 needs the scalarizer, therefore do not process it + here. */ + if (code->expr3->expr_type != EXPR_ARRAY + && (code->expr3->rank == 0 + || code->expr3->expr_type == EXPR_FUNCTION) + && (!code->expr3->symtree + || !code->expr3->symtree->n.sym->as) + && !gfc_is_class_array_ref (code->expr3, NULL)) + { + /* When expr3 is a variable, i.e., a very simple expression, + then convert it once here. */ + if ((code->expr3->expr_type == EXPR_VARIABLE) + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) + { + /* Convert expr3 to a tree. */ + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, code->expr3); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false,false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a + variable declaration. */ + if (!VAR_P (se.expr)) + { + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + tmp = gfc_evaluate_now (tmp, &block); + } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); + } + } + + /* Figure how to get the _vtab entry. This also obtains the tree + expression for accessing the _len component, because only + unlimited polymorphic objects, which are a subcategory of class + types, have a _len component. */ + if (code->expr3->ts.type == BT_CLASS) + { + gfc_expr *rhs; + /* Polymorphic SOURCE: VPTR must be determined at run time. */ + if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + tmp = gfc_class_vptr_get (expr3); + else if (expr3_tmp != NULL_TREE + && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + tmp = gfc_class_vptr_get (expr3_tmp); + else + { + rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_vptr_component (rhs); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, rhs); + tmp = se.expr; + gfc_free_expr (rhs); + } + /* Set the element size. */ + expr3_esize = gfc_vptr_size_get (tmp); + if (vtab_needed) + expr3_vptr = tmp; + /* Initialize the ref to the _len component. */ + if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3)) + { + /* Same like for retrieving the _vptr. */ + if (expr3 != NULL_TREE && !code->expr3->ref) + expr3_len = gfc_class_len_get (expr3); + else if (expr3_tmp != NULL_TREE && !code->expr3->ref) + expr3_len = gfc_class_len_get (expr3_tmp); + else + { + rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_len_component (rhs); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, rhs); + expr3_len = se.expr; + gfc_free_expr (rhs); + } + } + } + else + { + /* When the object to allocate is polymorphic type, then it + needs its vtab set correctly, so deduce the required _vtab + and _len from the source expression. */ + if (vtab_needed) + { + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + + vtab = gfc_find_vtab (&code->expr3->ts); + gcc_assert (vtab); + expr3_vptr = gfc_get_symbol_decl (vtab); + expr3_vptr = gfc_build_addr_expr (NULL_TREE, + expr3_vptr); + } + /* _len component needs to be set, when ts is a character + array. */ + if (expr3_len == NULL_TREE + && code->expr3->ts.type == BT_CHARACTER) + { + if (code->expr3->ts.u.cl + && code->expr3->ts.u.cl->length) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, code->expr3->ts.u.cl->length); + gfc_add_block_to_block (&block, &se.pre); + expr3_len = gfc_evaluate_now (se.expr, &block); + } + gcc_assert (expr3_len); + } + /* For character arrays only the kind's size is needed, because + the array mem_size is _len * (elem_size = kind_size). + For all other get the element size in the normal way. */ + if (code->expr3->ts.type == BT_CHARACTER) + expr3_esize = TYPE_SIZE_UNIT ( + gfc_get_char_type (code->expr3->ts.kind)); + else + expr3_esize = TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&code->expr3->ts)); + } + gcc_assert (expr3_esize); + expr3_esize = fold_convert (sizetype, expr3_esize); + } + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + { + /* Compute the explicit typespec given only once for all objects + to allocate. */ + if (code->ext.alloc.ts.type != BT_CHARACTER) + expr3_esize = TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + { + gfc_expr *sz; + gcc_assert (code->ext.alloc.ts.u.cl->length != NULL); + sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + tmp = gfc_get_char_type (code->ext.alloc.ts.kind); + tmp = TYPE_SIZE_UNIT (tmp); + tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp); + expr3_esize = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (se_sz.expr), + tmp, se_sz.expr); + } + } + /* Loop over all objects to allocate. */ for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = gfc_copy_expr (al->expr); + /* UNLIMITED_POLY () needs the _data component to be set, when + expr is a unlimited polymorphic object. But the _data component + has not been set yet, so check the derived type's attr for the + unlimited polymorphic flag to be safe. */ + upoly_expr = UNLIMITED_POLY (expr) + || (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.unlimited_polymorphic); + gfc_init_se (&se, NULL); + /* For class types prepare the expressions to ref the _vptr + and the _len component. The latter for unlimited polymorphic + types only. */ if (expr->ts.type == BT_CLASS) - gfc_add_data_component (expr); - - gfc_init_se (&se, NULL); + { + gfc_expr *expr_ref_vptr, *expr_ref_len; + gfc_add_data_component (expr); + /* Prep the vptr handle. */ + expr_ref_vptr = gfc_copy_expr (al->expr); + gfc_add_vptr_component (expr_ref_vptr); + se.want_pointer = 1; + gfc_conv_expr (&se, expr_ref_vptr); + al_vptr = se.expr; + se.want_pointer = 0; + gfc_free_expr (expr_ref_vptr); + /* Allocated unlimited polymorphic objects always have a _len + component. */ + if (upoly_expr) + { + expr_ref_len = gfc_copy_expr (al->expr); + gfc_add_len_component (expr_ref_len); + gfc_conv_expr (&se, expr_ref_len); + al_len = se.expr; + gfc_free_expr (expr_ref_len); + } + else + /* In a loop ensure that all loop variable dependent variables + are initialized at the same spot in all execution paths. */ + al_len = NULL_TREE; + } + else + al_vptr = al_len = NULL_TREE; se.want_pointer = 1; se.descriptor_only = 1; gfc_conv_expr (&se, expr); - - /* Evaluate expr3 just once if not a variable. */ - if (al == code->ext.alloc.list - && al->expr->ts.type == BT_CLASS - && code->expr3 - && code->expr3->ts.type == BT_CLASS - && code->expr3->expr_type != EXPR_VARIABLE) - { - gfc_init_se (&se_sz, NULL); - gfc_conv_expr_reference (&se_sz, code->expr3); - gfc_conv_class_to_class (&se_sz, code->expr3, - code->expr3->ts, false, true, false, false); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - gfc_add_block_to_block (&se.post, &se_sz.post); - classexpr = build_fold_indirect_ref_loc (input_location, - se_sz.expr); - classexpr = gfc_evaluate_now (classexpr, &se.pre); - memsize = gfc_vtable_size_get (classexpr); - memsize = fold_convert (sizetype, memsize); - } - - memsz = memsize; - class_expr = classexpr; - + if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + /* se.string_length now stores the .string_length variable of expr + needed to allocate character(len=:) arrays. */ + al_len = se.string_length; + + al_len_needs_set = al_len != NULL_TREE; + /* When allocating an array one can not use much of the + pre-evaluated expr3 expressions, because for most of them the + scalarizer is needed which is not available in the pre-evaluation + step. Therefore gfc_array_allocate () is responsible (and able) + to handle the complete array allocation. Only the element size + needs to be provided, which is done most of the time by the + pre-evaluation step. */ nelems = NULL_TREE; - if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, - memsz, &nelems, code->expr3, &code->ext.alloc.ts)) + if (expr3_len && code->expr3->ts.type == BT_CHARACTER) + /* When al is an array, then the element size for each element + in the array is needed, which is the product of the len and + esize for char arrays. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (expr3_esize), expr3_esize, + fold_convert (TREE_TYPE (expr3_esize), + expr3_len)); + else + tmp = expr3_esize; + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, + label_finish, tmp, &nelems, code->expr3)) { - bool unlimited_char; - - unlimited_char = UNLIMITED_POLY (al->expr) - && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER) - || (code->ext.alloc.ts.type == BT_CHARACTER - && code->ext.alloc.ts.u.cl - && code->ext.alloc.ts.u.cl->length)); + /* A scalar or derived type. First compute the size to + allocate. - /* A scalar or derived type. */ - - /* Determine allocate size. */ - if (al->expr->ts.type == BT_CLASS - && !unlimited_char - && code->expr3 - && memsz == NULL_TREE) + expr3_len is set when expr3 is an unlimited polymorphic + object or a deferred length string. */ + if (expr3_len != NULL_TREE) { - if (code->expr3->ts.type == BT_CLASS) - { - sz = gfc_copy_expr (code->expr3); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - memsz = se_sz.expr; - } - else - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); - } - else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) - || unlimited_char) && code->expr3) - { - if (!code->expr3->ts.u.cl->backend_decl) - { - /* Convert and use the length expression. */ - gfc_init_se (&se_sz, NULL); - if (code->expr3->expr_type == EXPR_VARIABLE - || code->expr3->expr_type == EXPR_CONSTANT) - { - gfc_conv_expr (&se_sz, code->expr3); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - se_sz.string_length - = gfc_evaluate_now (se_sz.string_length, &se.pre); - gfc_add_block_to_block (&se.pre, &se_sz.post); - memsz = se_sz.string_length; - } - else if (code->expr3->mold - && code->expr3->ts.u.cl - && code->expr3->ts.u.cl->length) - { - gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); - gfc_add_block_to_block (&se.pre, &se_sz.post); - memsz = se_sz.expr; - } - else - { - /* This is would be inefficient and possibly could - generate wrong code if the result were not stored - in expr3/slen3. */ - if (slen3 == NULL_TREE) - { - gfc_conv_expr (&se_sz, code->expr3); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - expr3 = gfc_evaluate_now (se_sz.expr, &se.pre); - gfc_add_block_to_block (&post, &se_sz.post); - slen3 = gfc_evaluate_now (se_sz.string_length, - &se.pre); - } - memsz = slen3; - } - } + tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (expr3_esize), + expr3_esize, tmp); + if (code->expr3->ts.type != BT_CLASS) + /* expr3 is a deferred length string, i.e., we are + done. */ + memsz = tmp; else - /* Otherwise use the stored string length. */ - memsz = code->expr3->ts.u.cl->backend_decl; - tmp = al->expr->ts.u.cl->backend_decl; - - /* Store the string length. */ - if (tmp && TREE_CODE (tmp) == VAR_DECL) - gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), - memsz)); - else if (al->expr->ts.type == BT_CHARACTER - && al->expr->ts.deferred && se.string_length) - gfc_add_modify (&se.pre, se.string_length, - fold_convert (TREE_TYPE (se.string_length), - memsz)); - else if ((al->expr->ts.type == BT_DERIVED - || al->expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.unlimited_polymorphic) { - tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl); - gfc_add_modify (&se.pre, tmp, - fold_convert (TREE_TYPE (tmp), - memsz)); + /* For unlimited polymorphic enties build + (len > 0) ? element_size * len : element_size + to compute the number of bytes to allocate. + This allows the allocation of unlimited polymorphic + objects from an expr3 that is also unlimited + polymorphic and stores a _len dependent object, + e.g., a string. */ + memsz = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, expr3_len, + integer_zero_node); + memsz = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (expr3_esize), + memsz, tmp, expr3_esize); } - - /* Convert to size in bytes, using the character KIND. */ - if (unlimited_char) - tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts)); - else - tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); - tmp = TYPE_SIZE_UNIT (tmp); - memsz = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (tmp), memsz)); } - else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) - || unlimited_char) + else if (expr3_esize != NULL_TREE) + /* Any other object in expr3 just needs element size in + bytes. */ + memsz = expr3_esize; + else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred) + || (upoly_expr + && code->ext.alloc.ts.type == BT_CHARACTER)) { - gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length); + /* Allocating deferred length char arrays need the length + to allocate in the alloc_type_spec. But also unlimited + polymorphic objects may be allocated as char arrays. + Both are handled here. */ gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); gfc_add_block_to_block (&se.pre, &se_sz.pre); se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); gfc_add_block_to_block (&se.pre, &se_sz.post); - /* Store the string length. */ - if ((expr->symtree->n.sym->ts.type == BT_CLASS - || expr->symtree->n.sym->ts.type == BT_DERIVED) - && expr->ts.u.derived->attr.unlimited_polymorphic) - /* For unlimited polymorphic entities get the backend_decl of - the _len component for that. */ - tmp = gfc_class_len_get (gfc_get_symbol_decl ( - expr->symtree->n.sym)); - else - /* Else use what is stored in the charlen->backend_decl. */ - tmp = al->expr->ts.u.cl->backend_decl; - gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), - se_sz.expr)); - tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); - tmp = TYPE_SIZE_UNIT (tmp); + expr3_len = se_sz.expr; + tmp_expr3_len_flag = true; + tmp = TYPE_SIZE_UNIT ( + gfc_get_char_type (code->ext.alloc.ts.kind)); memsz = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (se_sz.expr), - se_sz.expr)); + TREE_TYPE (tmp), + fold_convert (TREE_TYPE (tmp), + expr3_len), + tmp); } - else if (code->ext.alloc.ts.type != BT_UNKNOWN) - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); - else if (memsz == NULL_TREE) - memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); - - if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) + else if (expr->ts.type == BT_CHARACTER) { - memsz = se.string_length; - - /* Convert to size in bytes, using the character KIND. */ - tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); - tmp = TYPE_SIZE_UNIT (tmp); + /* Compute the number of bytes needed to allocate a fixed + length char array. */ + gcc_assert (se.string_length != NULL_TREE); + tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)); memsz = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (tmp), memsz)); + fold_convert (TREE_TYPE (tmp), + se.string_length)); } + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + /* Handle all types, where the alloc_type_spec is set. */ + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + /* Handle size computation of the type declared to alloc. */ + memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));; /* Allocate - for non-pointers with re-alloc checking. */ if (gfc_expr_attr (expr).allocatable) gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE, - stat, errmsg, errlen, label_finish, expr); + stat, errmsg, errlen, label_finish, + expr); else gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); @@ -5202,6 +5361,19 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&se.pre, tmp); } } + else + { + if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE + && expr3_len != NULL_TREE) + { + /* Arrays need to have a _len set before the array + descriptor is filled. */ + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), expr3_len)); + /* Prevent setting the length twice. */ + al_len_needs_set = false; + } + } gfc_add_block_to_block (&block, &se.pre); @@ -5218,124 +5390,114 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* We need the vptr of CLASS objects to be initialized. */ - e = gfc_copy_expr (al->expr); - if (e->ts.type == BT_CLASS) + /* Set the vptr. */ + if (al_vptr != NULL_TREE) { - gfc_expr *lhs, *rhs; - gfc_se lse; - gfc_ref *ref, *class_ref, *tail; - - /* Find the last class reference. */ - class_ref = NULL; - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS) - class_ref = ref; - - if (ref->next == NULL) - break; - } - - /* Remove and store all subsequent references after the - CLASS reference. */ - if (class_ref) - { - tail = class_ref->next; - class_ref->next = NULL; - } - else - { - tail = e->ref; - e->ref = NULL; - } - - lhs = gfc_expr_to_initialize (e); - gfc_add_vptr_component (lhs); - - /* Remove the _vptr component and restore the original tail - references. */ - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - class_ref->next = tail; - } - else - { - gfc_free_ref_list (e->ref); - e->ref = tail; - } - - if (class_expr != NULL_TREE) - { - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - gfc_init_se (&lse, NULL); - lse.want_pointer = 1; - gfc_conv_expr (&lse, lhs); - tmp = gfc_class_vptr_get (class_expr); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); - } - else if (code->expr3 && code->expr3->ts.type == BT_CLASS) - { - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - rhs = gfc_copy_expr (code->expr3); - gfc_add_vptr_component (rhs); - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (rhs); - rhs = gfc_expr_to_initialize (e); - } + if (expr3_vptr != NULL_TREE) + /* The vtab is already known, so just assign it. */ + gfc_add_modify (&block, al_vptr, + fold_convert (TREE_TYPE (al_vptr), expr3_vptr)); else { /* VPTR is fixed at compile time. */ gfc_symbol *vtab; gfc_typespec *ts; + if (code->expr3) + /* Although expr3 is pre-evaluated above, it may happen, + that for arrays or in mold= cases the pre-evaluation + was not successful. In these rare cases take the vtab + from the typespec of expr3 here. */ ts = &code->expr3->ts; - else if (e->ts.type == BT_DERIVED) - ts = &e->ts; - else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr)) + else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr) + /* The alloc_type_spec gives the type to allocate or the + al is unlimited polymorphic, which enforces the use of + an alloc_type_spec that is not necessarily a BT_DERIVED. */ ts = &code->ext.alloc.ts; - else if (e->ts.type == BT_CLASS) - ts = &CLASS_DATA (e)->ts; else - ts = &e->ts; - - if (ts->type == BT_DERIVED || UNLIMITED_POLY (e)) - { - vtab = gfc_find_vtab (ts); - gcc_assert (vtab); - gfc_init_se (&lse, NULL); - lse.want_pointer = 1; - gfc_conv_expr (&lse, lhs); - tmp = gfc_build_addr_expr (NULL_TREE, - gfc_get_symbol_decl (vtab)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); - } + /* Prepare for setting the vtab as declared. */ + ts = &expr->ts; + + vtab = gfc_find_vtab (ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, al_vptr, + fold_convert (TREE_TYPE (al_vptr), tmp)); } - gfc_free_expr (lhs); } - gfc_free_expr (e); - + /* Add assignment for string length. */ + if (al_len != NULL_TREE && al_len_needs_set) + { + if (expr3_len != NULL_TREE) + { + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + expr3_len)); + /* When tmp_expr3_len_flag is set, then expr3_len is + abused to carry the length information from the + alloc_type. Clear it to prevent setting incorrect len + information in future loop iterations. */ + if (tmp_expr3_len_flag) + /* No need to reset tmp_expr3_len_flag, because the + presence of an expr3 can not change within in the + loop. */ + expr3_len = NULL_TREE; + } + else if (code->ext.alloc.ts.type == BT_CHARACTER + && code->ext.alloc.ts.u.cl->length) + { + /* Cover the cases where a string length is explicitly + specified by a type spec for deferred length character + arrays or unlimited polymorphic objects without a + source= or mold= expression. */ + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + se_sz.expr)); + } + else + /* No length information needed, because type to allocate + has no length. Set _len to 0. */ + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + integer_zero_node)); + } if (code->expr3 && !code->expr3->mold) { /* Initialization via SOURCE block (or static default initializer). */ gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (class_expr != NULL_TREE) + if (expr3 != NULL_TREE + && ((POINTER_TYPE_P (TREE_TYPE (expr3)) + && TREE_CODE (expr3) != POINTER_PLUS_EXPR) + || VAR_P (expr3)) + && code->expr3->ts.type == BT_CLASS + && (expr->ts.type == BT_CLASS + || expr->ts.type == BT_DERIVED)) { tree to; - to = TREE_OPERAND (se.expr, 0); - - tmp = gfc_copy_class_to_class (class_expr, to, nelems); + to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); + tmp = gfc_copy_class_to_class (expr3, to, + nelems, upoly_expr); + } + else if (code->expr3->ts.type == BT_CHARACTER) + { + tmp = INDIRECT_REF_P (se.expr) ? + se.expr : + build_fold_indirect_ref_loc (input_location, + se.expr); + gfc_trans_string_copy (&block, al_len, tmp, + code->expr3->ts.kind, + expr3_len, expr3, + code->expr3->ts.kind); + tmp = NULL_TREE; } else if (al->expr->ts.type == BT_CLASS) { - gfc_actual_arglist *actual; + gfc_actual_arglist *actual, *last_arg; gfc_expr *ppc; gfc_code *ppc_code; gfc_ref *ref, *dataref; @@ -5345,15 +5507,15 @@ gfc_trans_allocate (gfc_code * code) actual->expr = gfc_copy_expr (rhs); if (rhs->ts.type == BT_CLASS) gfc_add_data_component (actual->expr); - actual->next = gfc_get_actual_arglist (); - actual->next->expr = gfc_copy_expr (al->expr); - actual->next->expr->ts.type = BT_CLASS; - gfc_add_data_component (actual->next->expr); + last_arg = actual->next = gfc_get_actual_arglist (); + last_arg->expr = gfc_copy_expr (al->expr); + last_arg->expr->ts.type = BT_CLASS; + gfc_add_data_component (last_arg->expr); dataref = NULL; /* Make sure we go up through the reference chain to the _data reference, where the arrayspec is found. */ - for (ref = actual->next->expr->ref; ref; ref = ref->next) + for (ref = last_arg->expr->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT && strcmp (ref->u.c.component->name, "_data") == 0) dataref = ref; @@ -5387,7 +5549,10 @@ gfc_trans_allocate (gfc_code * code) } if (rhs->ts.type == BT_CLASS) { - ppc = gfc_copy_expr (rhs); + if (rhs->ref) + ppc = gfc_find_and_cut_at_last_class_ref (rhs); + else + ppc = gfc_copy_expr (rhs); gfc_add_vptr_component (ppc); } else @@ -5396,6 +5561,7 @@ gfc_trans_allocate (gfc_code * code) ppc_code = gfc_get_code (EXEC_CALL); ppc_code->resolved_sym = ppc->symtree->n.sym; + ppc_code->loc = al->expr->where; /* Although '_copy' is set to be elemental in class.c, it is not staying that way. Find out why, sometime.... */ ppc_code->resolved_sym->attr.elemental = 1; @@ -5404,19 +5570,53 @@ gfc_trans_allocate (gfc_code * code) /* Since '_copy' is elemental, the scalarizer will take care of arrays in gfc_trans_call. */ tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false); + /* We need to add the + if (al_len > 0) + al_vptr->copy (expr3_data, al_data, expr3_len, al_len); + else + al_vptr->copy (expr3_data, al_data); + block, because al is unlimited polymorphic or a deferred + length char array, whose copy routine needs the array lengths + as third and fourth arguments. */ + if (al_len && UNLIMITED_POLY (code->expr3)) + { + tree stdcopy, extcopy; + /* Add al%_len. */ + last_arg->next = gfc_get_actual_arglist (); + last_arg = last_arg->next; + last_arg->expr = gfc_find_and_cut_at_last_class_ref ( + al->expr); + gfc_add_len_component (last_arg->expr); + /* Add expr3's length. */ + last_arg->next = gfc_get_actual_arglist (); + last_arg = last_arg->next; + if (code->expr3->ts.type == BT_CLASS) + { + last_arg->expr = + gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_len_component (last_arg->expr); + } + else if (code->expr3->ts.type == BT_CHARACTER) + last_arg->expr = + gfc_copy_expr (code->expr3->ts.u.cl->length); + else + gcc_unreachable (); + + stdcopy = tmp; + extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false); + + tmp = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, expr3_len, + integer_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, extcopy, stdcopy); + } gfc_free_statements (ppc_code); } - else if (expr3 != NULL_TREE) - { - tmp = build_fold_indirect_ref_loc (input_location, se.expr); - gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind, - slen3, expr3, code->expr3->ts.kind); - tmp = NULL_TREE; - } else { - /* Switch off automatic reallocation since we have just done - the ALLOCATE. */ + /* Switch off automatic reallocation since we have just + done the ALLOCATE. */ int realloc_lhs = flag_realloc_lhs; flag_realloc_lhs = 0; tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), @@ -5433,12 +5633,13 @@ gfc_trans_allocate (gfc_code * code) object, we can use gfc_copy_class_to_class in its initialization mode. */ tmp = TREE_OPERAND (se.expr, 0); - tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems); + tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems, + upoly_expr); gfc_add_expr_to_block (&block, tmp); } gfc_free_expr (expr); - } + } // for-loop /* STAT. */ if (code->expr1) @@ -5463,17 +5664,20 @@ gfc_trans_allocate (gfc_code * code) slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, - slen); + slen = fold_build2_loc (input_location, MIN_EXPR, + TREE_TYPE (slen), dlen, slen); - gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, - slen, errmsg_str, gfc_default_character_kind); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, + code->expr2->ts.kind, + slen, errmsg_str, + gfc_default_character_kind); dlen = gfc_finish_block (&errmsg_block); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, - build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + stat, build_int_cst (TREE_TYPE (stat), 0)); - tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); + tmp = build3_v (COND_EXPR, tmp, + dlen, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } @@ -5571,7 +5775,7 @@ gfc_trans_deallocate (gfc_code *code) last = ref; /* Do not deallocate the components of a derived type - ultimate pointer component. */ + ultimate pointer component. */ if (!(last && last->u.c.component->attr.pointer) && !(!last && expr->symtree->n.sym->attr.pointer)) { @@ -5616,7 +5820,14 @@ gfc_trans_deallocate (gfc_code *code) } if (al->expr->ts.type == BT_CLASS) - gfc_reset_vptr (&se.pre, al->expr); + { + gfc_reset_vptr (&se.pre, al->expr); + if (UNLIMITED_POLY (al->expr) + || (al->expr->ts.type == BT_DERIVED + && al->expr->ts.u.derived->attr.unlimited_polymorphic)) + /* Clear _len, too. */ + gfc_reset_len (&se.pre, al->expr); + } } else { @@ -5631,7 +5842,14 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_expr_to_block (&se.pre, tmp); if (al->expr->ts.type == BT_CLASS) - gfc_reset_vptr (&se.pre, al->expr); + { + gfc_reset_vptr (&se.pre, al->expr); + if (UNLIMITED_POLY (al->expr) + || (al->expr->ts.type == BT_DERIVED + && al->expr->ts.u.derived->attr.unlimited_polymorphic)) + /* Clear _len, too. */ + gfc_reset_len (&se.pre, al->expr); + } } if (code->expr1) diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index b749783..b7ec0e5 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -373,7 +373,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl) return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); - span = gfc_vtable_size_get (decl); + span = gfc_class_vtab_size_get (decl); } else if (GFC_DECL_SUBREF_ARRAY_P (decl)) span = GFC_DECL_SPAN(decl); @@ -1015,8 +1015,8 @@ gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, return false; gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr); - final_fndecl = gfc_vtable_final_get (decl); - size = gfc_vtable_size_get (decl); + final_fndecl = gfc_class_vtab_final_get (decl); + size = gfc_class_vtab_size_get (decl); array = gfc_class_data_get (decl); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index be11363..1998358 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -350,20 +350,31 @@ typedef struct gfc_wrapped_block; /* Class API functions. */ +tree gfc_class_set_static_fields (tree, tree, tree); tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); +gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *); +/* Get an accessor to the class' vtab's * field, when a class handle is + available. */ +tree gfc_class_vtab_hash_get (tree); +tree gfc_class_vtab_size_get (tree); +tree gfc_class_vtab_extends_get (tree); +tree gfc_class_vtab_def_init_get (tree); +tree gfc_class_vtab_copy_get (tree); +tree gfc_class_vtab_final_get (tree); +/* Get an accessor to the vtab's * field, when a vptr handle is present. */ +tree gfc_vtpr_hash_get (tree); +tree gfc_vptr_size_get (tree); +tree gfc_vptr_extends_get (tree); +tree gfc_vptr_def_init_get (tree); +tree gfc_vptr_copy_get (tree); +tree gfc_vptr_final_get (tree); void gfc_reset_vptr (stmtblock_t *, gfc_expr *); -tree gfc_class_set_static_fields (tree, tree, tree); -tree gfc_vtable_hash_get (tree); -tree gfc_vtable_size_get (tree); -tree gfc_vtable_extends_get (tree); -tree gfc_vtable_def_init_get (tree); -tree gfc_vtable_copy_get (tree); -tree gfc_vtable_final_get (tree); +void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); -tree gfc_copy_class_to_class (tree, tree, tree); +tree gfc_copy_class_to_class (tree, tree, tree, bool); bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *); bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 55f6ed6..6049784 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2015-03-24 Andre Vehreschild <vehre@gmx.de> + + * gfortran.dg/allocate_alloc_opt_13.f90: Added tests for + source= and mold= expressions functionality. + * gfortran.dg/allocate_class_4.f90: New test. + * gfortran.dg/unlimited_polymorphic_20.f90: Added test whether + copying an unlimited polymorhpic object containing a char array + to another unlimited polymorphic object respects the _len + component. + * gfortran.dg/unlimited_polymorphic_22.f90: Extended to check + whether deferred length char array allocate works, unlimited + polymorphic object allocation from a string works and if + allocating an array of deferred length strings works. + * gfortran.dg/unlimited_polymorphic_24.f03: New test. + 2015-03-24 Paolo Carlini <paolo.carlini@oracle.com> PR c++/65513 diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 index 462b121..f9e199c 100644 --- a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 @@ -12,6 +12,9 @@ class(t), pointer :: b, d(:) allocate (a, b, source=c(1)) allocate (c(4), d(6), source=e) +allocate (a, b, mold=f()) +allocate (c(1), d(6), mold=g()) + allocate (a, b, source=f()) allocate (c(1), d(6), source=g()) diff --git a/gcc/testsuite/gfortran.dg/allocate_class_4.f90 b/gcc/testsuite/gfortran.dg/allocate_class_4.f90 new file mode 100644 index 0000000..23c9d53 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_class_4.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Part of PR 51946, but breaks easily, therefore introduce its own test +! Authors: Damian Rouson <damian@sourceryinstitute.org>, +! Dominique Pelletier <dominique.pelletier@polymtl.ca> +! Contributed by: Andre Vehreschild <vehre@gcc.gnu.org> + +module integrable_model_module + + implicit none + + type, abstract, public :: integrable_model + contains + procedure(default_constructor), deferred :: empty_instance + end type + + abstract interface + function default_constructor(this) result(blank_slate) + import :: integrable_model + class(integrable_model), intent(in) :: this + class(integrable_model), allocatable :: blank_slate + end function + end interface + + contains + + subroutine integrate(this) + class(integrable_model), intent(inout) :: this + class(integrable_model), allocatable :: residual + allocate(residual, source=this%empty_instance()) + end subroutine + +end module integrable_model_module + +! { dg-final { cleanup-modules "integrable_model_module" } } + diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 index c6c6d29..49d35c8 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 @@ -23,12 +23,14 @@ program test implicit none character(LEN=:), allocatable, target :: S character(LEN=100) :: res - class(*), pointer :: ucp + class(*), pointer :: ucp, ucp2 call sub1 ("long test string", 16) call sub2 () S = "test" ucp => S call sub3 (ucp) + allocate (ucp2, source=ucp) + call sub3 (ucp2) call sub4 (S, 4) call sub4 ("This is a longer string.", 24) call bar (S, res) diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 index 0753fe0..1d44c9f 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 @@ -5,52 +5,211 @@ program test implicit none - class(*), pointer :: P + class(*), pointer :: P1, P2, P3 + class(*), pointer, dimension(:) :: PA1 + class(*), allocatable :: A1, A2 integer :: string_len = 10 *2 + character(len=:), allocatable, target :: str + character(len=:,kind=4), allocatable :: str4 + type T + class(*), pointer :: content + end type + type(T) :: o1, o2 + + str = "string for test" + str4 = 4_"string for test" + + allocate(character(string_len)::P1) + + select type(P1) + type is (character(*)) + P1 ="some test string" + if (P1 .ne. "some test string") call abort () + if (len(P1) .ne. 20) call abort () + if (len(P1) .eq. len("some test string")) call abort () + class default + call abort () + end select + + allocate(A1, source = P1) - allocate(character(string_len)::P) + select type(A1) + type is (character(*)) + if (A1 .ne. "some test string") call abort () + if (len(A1) .ne. 20) call abort () + if (len(A1) .eq. len("some test string")) call abort () + class default + call abort () + end select + + allocate(A2, source = convertType(P1)) - select type(P) + select type(A2) type is (character(*)) - P ="some test string" - if (P .ne. "some test string") then - call abort () - end if - if (len(P) .ne. 20) then - call abort () - end if - if (len(P) .eq. len("some test string")) then - call abort () - end if + if (A2 .ne. "some test string") call abort () + if (len(A2) .ne. 20) call abort () + if (len(A2) .eq. len("some test string")) call abort () class default call abort () end select - deallocate(P) + allocate(P2, source = str) + + select type(P2) + type is (character(*)) + if (P2 .ne. "string for test") call abort () + if (len(P2) .eq. 20) call abort () + if (len(P2) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(P3, source = "string for test") + + select type(P3) + type is (character(*)) + if (P3 .ne. "string for test") call abort () + if (len(P3) .eq. 20) call abort () + if (len(P3) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(character(len=10)::PA1(3)) + + select type(PA1) + type is (character(*)) + PA1(1) = "string 10 " + if (PA1(1) .ne. "string 10 ") call abort () + if (any(len(PA1(:)) .ne. [10,10,10])) call abort () + class default + call abort () + end select + + deallocate(PA1) + deallocate(P3) +! if (len(P3) .ne. 0) call abort() ! Can't check, because select +! type would be needed, which needs the vptr, which is 0 now. + deallocate(P2) + deallocate(A2) + deallocate(A1) + deallocate(P1) ! Now for kind=4 chars. - allocate(character(len=20,kind=4)::P) + allocate(character(len=20,kind=4)::P1) + + select type(P1) + type is (character(len=*,kind=4)) + P1 ="some test string" + if (P1 .ne. 4_"some test string") call abort () + if (len(P1) .ne. 20) call abort () + if (len(P1) .eq. len("some test string")) call abort () + type is (character(len=*,kind=1)) + call abort () + class default + call abort () + end select + + allocate(A1, source=P1) - select type(P) + select type(A1) type is (character(len=*,kind=4)) - P ="some test string" - if (P .ne. 4_"some test string") then - call abort () - end if - if (len(P) .ne. 20) then - call abort () - end if - if (len(P) .eq. len("some test string")) then - call abort () - end if + if (A1 .ne. 4_"some test string") call abort () + if (len(A1) .ne. 20) call abort () + if (len(A1) .eq. len("some test string")) call abort () type is (character(len=*,kind=1)) call abort () class default call abort () end select - deallocate(P) + allocate(A2, source = convertType(P1)) + + select type(A2) + type is (character(len=*, kind=4)) + if (A2 .ne. 4_"some test string") call abort () + if (len(A2) .ne. 20) call abort () + if (len(A2) .eq. len("some test string")) call abort () + class default + call abort () + end select + + allocate(P2, source = str4) + + select type(P2) + type is (character(len=*,kind=4)) + if (P2 .ne. 4_"string for test") call abort () + if (len(P2) .eq. 20) call abort () + if (len(P2) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(P3, source = convertType(P2)) + select type(P3) + type is (character(len=*, kind=4)) + if (P3 .ne. 4_"string for test") call abort () + if (len(P3) .eq. 20) call abort () + if (len(P3) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(character(kind=4, len=10)::PA1(3)) + + select type(PA1) + type is (character(len=*, kind=4)) + PA1(1) = 4_"string 10 " + if (PA1(1) .ne. 4_"string 10 ") call abort () + if (any(len(PA1(:)) .ne. [10,10,10])) call abort () + class default + call abort () + end select + + deallocate(PA1) + deallocate(P3) + deallocate(P2) + deallocate(A2) + deallocate(P1) + deallocate(A1) + + allocate(o1%content, source='test string') + allocate(o2%content, source=o1%content) + select type (c => o1%content) + type is (character(*)) + if (c /= 'test string') call abort () + class default + call abort() + end select + select type (d => o2%content) + type is (character(*)) + if (d /= 'test string') call abort () + class default + end select + + call AddCopy ('test string') + +contains + + function convertType(in) + class(*), pointer, intent(in) :: in + class(*), pointer :: convertType + + convertType => in + end function + + subroutine AddCopy(C) + class(*), intent(in) :: C + class(*), pointer :: P + allocate(P, source=C) + select type (P) + type is (character(*)) + if (P /= 'test string') call abort() + class default + call abort() + end select + end subroutine end program test diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03 new file mode 100644 index 0000000..48efa11 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03 @@ -0,0 +1,215 @@ +! { dg-do run } +! +! Test case for unlimited polymorphism that is derived from the article +! by Mark Leair, in the 'PGI Insider': +! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm +! Note that 'getValue' has been removed from the generic 'add' becuse +! gfortran asserts that this is ambiguous. See +! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion. +! +module link_mod + private + public :: link, output, index + character(6) :: output (14) + integer :: index = 0 + type link + private + class(*), pointer :: value => null() ! value stored in link + type(link), pointer :: next => null()! next link in list + contains + procedure :: getValue ! return value pointer + procedure :: printLinks ! print linked list starting with this link + procedure :: nextLink ! return next pointer + procedure :: setNextLink ! set next pointer + end type link + + interface link + procedure constructor ! construct/initialize a link + end interface + +contains + + function nextLink(this) + class(link) :: this + class(link), pointer :: nextLink + nextLink => this%next + end function nextLink + + subroutine setNextLink(this,next) + class(link) :: this + class(link), pointer :: next + this%next => next + end subroutine setNextLink + + function getValue(this) + class(link) :: this + class(*), pointer :: getValue + getValue => this%value + end function getValue + + subroutine printLink(this) + class(link) :: this + + index = index + 1 + + select type(v => this%value) + type is (integer) + write (output(index), '(i6)') v + type is (character(*)) + write (output(index), '(a6)') v + type is (real) + write (output(index), '(f6.2)') v + class default + stop 'printLink: unexepected type for link' + end select + + end subroutine printLink + + subroutine printLinks(this) + class(link) :: this + class(link), pointer :: curr + + call printLink(this) + curr => this%next + do while(associated(curr)) + call printLink(curr) + curr => curr%next + end do + + end subroutine + + function constructor(value, next) + class(link),pointer :: constructor + class(*) :: value + class(link), pointer :: next + allocate(constructor) + constructor%next => next + allocate(constructor%value, source=value) + end function constructor + +end module link_mod + +module list_mod + use link_mod + private + public :: list + type list + private + class(link),pointer :: firstLink => null() ! first link in list + class(link),pointer :: lastLink => null() ! last link in list + contains + procedure :: printValues ! print linked list + procedure :: addInteger ! add integer to linked list + procedure :: addChar ! add character to linked list + procedure :: addReal ! add real to linked list + procedure :: addValue ! add class(*) to linked list + procedure :: firstValue ! return value associated with firstLink + procedure :: isEmpty ! return true if list is empty + generic :: add => addInteger, addChar, addReal + end type list + +contains + + subroutine printValues(this) + class(list) :: this + + if (.not.this%isEmpty()) then + call this%firstLink%printLinks() + endif + end subroutine printValues + + subroutine addValue(this, value) + class(list) :: this + class(*) :: value + class(link), pointer :: newLink + + if (.not. associated(this%firstLink)) then + this%firstLink => link(value, this%firstLink) + this%lastLink => this%firstLink + else + newLink => link(value, this%lastLink%nextLink()) + call this%lastLink%setNextLink(newLink) + this%lastLink => newLink + end if + + end subroutine addValue + + subroutine addInteger(this, value) + class(list) :: this + integer value + class(*), allocatable :: v + allocate(v,source=value) + call this%addValue(v) + end subroutine addInteger + + subroutine addChar(this, value) + class(list) :: this + character(*) :: value + class(*), allocatable :: v + + allocate(v,source=value) + call this%addValue(v) + end subroutine addChar + + subroutine addReal(this, value) + class(list) :: this + real value + class(*), allocatable :: v + + allocate(v,source=value) + call this%addValue(v) + end subroutine addReal + + function firstValue(this) + class(list) :: this + class(*), pointer :: firstValue + + firstValue => this%firstLink%getValue() + + end function firstValue + + function isEmpty(this) + class(list) :: this + logical isEmpty + + if (associated(this%firstLink)) then + isEmpty = .false. + else + isEmpty = .true. + endif + end function isEmpty + +end module list_mod + +program main + use link_mod, only : output + use list_mod + implicit none + integer i, j + type(list) :: my_list + + do i=1, 10 + call my_list%add(i) + enddo + call my_list%add(1.23) + call my_list%add('A') + call my_list%add('BC') + call my_list%add('DEF') + call my_list%printvalues() + do i = 1, 14 + select case (i) + case (1:10) + read (output(i), '(i6)') j + if (j .ne. i) call abort + case (11) + if (output(i) .ne. " 1.23") call abort + case (12) + if (output(i) .ne. " A") call abort + case (13) + if (output(i) .ne. " BC") call abort + case (14) + if (output(i) .ne. " DEF") call abort + end select + end do +end program main + |