Hi all, please find attached a more elaborate patch for pr60255. I totally agree that my first attempt was just scratching the surface of the work needed.
This patch also is *not* complete, but because I am really new to gfortran patching, I don't want to present a final patch only to learn then, that I have violated design rules, common practice or the like. Therefore please comment and direct me to any sources/ideas to improve the patch. Topic: The pr 60255 is about assigning a char array to an unlimited polymorphic entity. In the comments the concern about the lost length information is raised. The patch adds a _len component to the unlimited polymorphic entity (after _data and _vtab) and adds an assignment of the string length to _len when a string is pointer assigned to the unlimited poly entity. Furthermore is the intrinsic len(unlimited poly pointing to a string) resolved to give the _len component. Yet missing: - assign _len component back to deferred char array length component - transport length along chains of unlimited poly entities, i.e., a => b; c => a where all objects are unlimited poly and b is a string. - allocate() in this context Patch dependencies: none Comments, concerns, candy welcome! Regards, Andre On Sun, 17 Aug 2014 14:32:21 +0200 domi...@lps.ens.fr (Dominique Dhumieres) wrote: > > the testcase should check that the code generated is actually working, > > not just that the ICE disappeared. > > I agree. Note that there is a test in the comment 3 of PR60255 that > can be used to check the run time behavior (and possibly check the > vtab issue). > > Dominique -- Andre Vehreschild * Email: vehre ad gmx dot de
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 0286c9e..29e31e1 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2403,6 +2403,38 @@ yes: return true; } +/* Add the component _len to the class-type variable in c->expr1. */ + +void +gfc_add_len_component (gfc_code *c) +{ + /* Just make sure input is correct. This is already at the calling site, + but may be this routine is called from somewhere else in the furure. */ + gcc_assert (UNLIMITED_POLY(c->expr1) + && c->expr2 + && c->expr2->ts.type== BT_CHARACTER); + + gfc_component *len; + gfc_expr *e; + /* Check that _len is not present already. */ + if ((len= gfc_find_component (c->expr1->ts.u.derived, "_len", true, true))) + return; + /* Create the new component. */ + if (!gfc_add_component (c->expr1->ts.u.derived, "_len", &len)) + // Possible errors are already reported in add_component + return; + len->ts.type = BT_INTEGER; + len->ts.kind = 4; + len->attr.access = ACCESS_PRIVATE; + + /* Build minimal expression to initialize component with zero. */ + e = gfc_get_expr(); + e->ts = c->expr1->ts; + e->expr_type = EXPR_VARIABLE; + len->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 0); + gfc_free_expr (e); +} /* Find (or generate) the symbol for an intrinsic type's vtab. This is needed to support unlimited polymorphism. */ @@ -2415,18 +2447,9 @@ find_intrinsic_vtab (gfc_typespec *ts) gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; int charlen = 0; - if (ts->type == BT_CHARACTER) - { - if (ts->deferred) - { - gfc_error ("TODO: Deferred character length variable at %C cannot " - "yet be associated with unlimited polymorphic entities"); - return NULL; - } - else if (ts->u.cl && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = mpz_get_si (ts->u.cl->length->value.integer); - } + if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (ts->u.cl->length->value.integer); /* Find the top-level namespace. */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -2437,10 +2460,16 @@ find_intrinsic_vtab (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; - if (ts->type == BT_CHARACTER) - sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), - charlen, ts->kind); - else + if (ts->type == BT_CHARACTER) { + if (!ts->deferred) + sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), + charlen, ts->kind); + else + /* The type is deferred here. Ensure that this is easily seen in the + vtable. */ + sprintf (tname, "%s_DEFERRED_%d", gfc_basic_typename (ts->type), + ts->kind); + } else sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); sprintf (name, "__vtab_%s", tname); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 1058502..f99c3f8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3192,6 +3192,8 @@ gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *); unsigned int gfc_hash_value (gfc_symbol *); bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **); +void gfc_add_len_component(gfc_code *); +void gfc_assign_charlen_to_unlimited_poly(gfc_code *c); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_symbol *gfc_find_vtab (gfc_typespec *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9d7d3c2..6e14e74 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10081,7 +10081,11 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) if (!t) break; - gfc_check_pointer_assign (code->expr1, code->expr2); + if (gfc_check_pointer_assign (code->expr1, code->expr2) + && UNLIMITED_POLY(code->expr1) + && code->expr2->ts.type== BT_CHARACTER) + gfc_add_len_component (code); + break; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7ccabc7..88cd8e7 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3687,6 +3687,31 @@ gfc_simplify_leadz (gfc_expr *e) return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); } +static gfc_expr * +get__len_component (gfc_expr *e) +{ + gfc_expr *len_comp; + gfc_ref *ref, **last; + len_comp = gfc_copy_expr(e->symtree->n.sym->assoc->target); + /* We need to remove the last _data component ref from ptr. */ + last = &(len_comp->ref); + ref = len_comp->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list(ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + gfc_add_component_ref(len_comp, "_len"); + return len_comp; +} gfc_expr * gfc_simplify_len (gfc_expr *e, gfc_expr *kind) @@ -3711,6 +3736,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); return range_check (result, "LEN"); } + else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER + && e->symtree->n.sym + && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target + && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED) + { + return get__len_component (e); + } else return NULL; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f8e4df8..9a08bde 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1034,11 +1034,11 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_add_vptr_component (lhs); if (UNLIMITED_POLY (expr1) - && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) - { - rhs = gfc_get_null_expr (&expr2->where); - goto assign_vptr; - } + && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) + { + rhs = gfc_get_null_expr (&expr2->where); + goto assign_vptr; + } if (expr2->expr_type == EXPR_NULL) vtab = gfc_find_vtab (&expr1->ts); @@ -6695,6 +6695,43 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } +/* Create the character length assignment to the _len component. */ + +void +add_assignment_of_string_len_to_len_component (stmtblock_t *block, + gfc_expr *ptr, gfc_se *ptr_se, + gfc_se *str) +{ + gfc_expr *len_comp; + gfc_ref *ref, **last; + gfc_se lse; + len_comp = gfc_copy_expr(ptr); + /* We need to remove the last _data component ref from ptr. */ + last = &(len_comp->ref); + ref = len_comp->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list(ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + gfc_add_component_ref(len_comp, "_len"); + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, len_comp); + + /* ptr % _len = len (str) */ + gfc_add_modify (block, lse.expr, str->string_length); + ptr_se->string_length = lse.expr; + gfc_free_expr (len_comp); +} + tree gfc_trans_pointer_assign (gfc_code * code) { @@ -6759,6 +6796,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); + /* For string assignments to unlimited polymorphic pointers add an + assignment of the string_length to the _len component of the pointer. */ + if (expr1->ts.type == BT_DERIVED + && expr1->ts.u.derived->attr.unlimited_polymorphic + && expr2->ts.type == BT_CHARACTER) + { + add_assignment_of_string_len_to_len_component (&block, expr1, &lse, &rse); + } + /* Check character lengths if character expression. The test is only really added if -fbounds-check is enabled. Exclude deferred character length lefthand sides. */ diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 new file mode 100644 index 0000000..6042882 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 @@ -0,0 +1,57 @@ +! { dg-do run } +! Testing fix for +! PR fortran/60255 +! +program test + implicit none + character(LEN=:), allocatable :: S + call subP(S) + call sub2() + call sub1("test") + +contains + + subroutine sub1(dcl) + character(len=*), target :: dcl + class(*), pointer :: ucp +! character(len=:), allocatable ::def + + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .NE. 4) then + call abort() +! else +! def = ucp +! if (len(def) .NE. 4) then +! call abort() ! This abort is expected currently +! end if + end if + class default + call abort() + end select + end subroutine + + subroutine sub2 + character(len=:), allocatable, target :: dcl + class(*), pointer :: ucp + + dcl = "ttt" + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .NE. 3) then + call abort() + end if + class default + call abort() + end select + end subroutine + + subroutine subP(P) + class(*) :: P + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 index 8e80386..30e4797 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 @@ -5,7 +5,7 @@ ! Contributed by Paul Thomas <pa...@gcc.gnu.org> ! and Tobias Burnus <bur...@gcc.gnu.org> ! - CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" } + CHARACTER(:), allocatable, target :: chr ! F2008: C5100 integer :: i(2) logical :: flag