2012-05-12 Alessandro Fanfarillo Tobias Burnus PR fortran/52158 PR fortran/45170 PR fortran/49430 * resolve.c (resolve_fl_derived0): Deferred character length procedure components are supported. * trans-expr.c (gfc_conv_procedure_call): Handle TBP with deferred-length results. (gfc_string_to_single_character): Add a new check to prevent NULL read. (gfc_conv_procedure_call): Remove unuseful checks on symbol's attributes. Add new checks to prevent NULL read on string length. 2012-05-12 Alessandro Fanfarillo PR fortran/45170 * gfortran.dg/deferred_type_param_3.f90: New. * gfortran.dg/deferred_type_proc_pointer_1.f90: New. * gfortran.dg/deferred_type_proc_pointer_2.f90: New. diff -urN gcc-original/gcc/fortran/resolve.c gcc-last/gcc/fortran/resolve.c --- gcc-original/gcc/fortran/resolve.c 2012-05-12 10:50:54.872632641 +0200 +++ gcc-last/gcc/fortran/resolve.c 2012-05-12 10:08:19.496688495 +0200 @@ -11665,7 +11665,7 @@ for ( ; c != NULL; c = c->next) { /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */ - if (c->ts.type == BT_CHARACTER && c->ts.deferred) + if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function) { gfc_error ("Deferred-length character component '%s' at %L is not " "yet supported", c->name, &c->loc); diff -urN gcc-original/gcc/fortran/trans-expr.c gcc-last/gcc/fortran/trans-expr.c --- gcc-original/gcc/fortran/trans-expr.c 2012-05-12 10:50:54.972632638 +0200 +++ gcc-last/gcc/fortran/trans-expr.c 2012-05-12 10:08:19.496688495 +0200 @@ -2073,7 +2073,8 @@ gfc_string_to_single_character (tree len, tree str, int kind) { - if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0 + if (len == NULL + || !INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0 || !POINTER_TYPE_P (TREE_TYPE (str))) return NULL_TREE; @@ -4175,7 +4176,7 @@ we take the character length of the first argument for the result. For dummies, we have to look through the formal argument list for this function and use the character length found there.*/ - if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer)) + if (ts.deferred) cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen"); else if (!sym->attr.dummy) cl.backend_decl = VEC_index (tree, stringargs, 0); @@ -4186,6 +4187,7 @@ if (strcmp (formal->sym->name, sym->name) == 0) cl.backend_decl = formal->sym->ts.u.cl->backend_decl; } + len = cl.backend_decl; } else { @@ -4343,9 +4345,13 @@ if ((!comp && sym->attr.allocatable) || (comp && comp->attr.allocatable)) - gfc_add_modify (&se->pre, var, - fold_convert (TREE_TYPE (var), - null_pointer_node)); + { + gfc_add_modify (&se->pre, var, + fold_convert (TREE_TYPE (var), + null_pointer_node)); + tmp = gfc_call_free (convert (pvoid_type_node, var)); + gfc_add_expr_to_block (&se->post, tmp); + } /* Provide an address expression for the function arguments. */ var = gfc_build_addr_expr (NULL_TREE, var); @@ -4364,17 +4370,16 @@ VEC_safe_push (tree, gc, retargs, var); } - if (ts.type == BT_CHARACTER && ts.deferred - && (sym->attr.allocatable || sym->attr.pointer)) + /* Add the string length to the argument list. */ + if (ts.type == BT_CHARACTER && ts.deferred) { tmp = len; if (TREE_CODE (tmp) != VAR_DECL) tmp = gfc_evaluate_now (len, &se->pre); - len = gfc_build_addr_expr (NULL_TREE, tmp); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + VEC_safe_push (tree, gc, retargs, tmp); } - - /* Add the string length to the argument list. */ - if (ts.type == BT_CHARACTER) + else if (ts.type == BT_CHARACTER) VEC_safe_push (tree, gc, retargs, len); } gfc_free_interface_mapping (&mapping); @@ -4483,10 +4488,7 @@ else se->expr = var; - if (!ts.deferred) - se->string_length = len; - else if (sym->attr.allocatable || sym->attr.pointer) - se->string_length = cl.backend_decl; + se->string_length = len; } else { @@ -5776,8 +5778,7 @@ really added if -fbounds-check is enabled. Exclude deferred character length lefthand sides. */ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL - && !(expr1->ts.deferred - && (TREE_CODE (lse.string_length) == VAR_DECL)) + && !expr1->ts.deferred && !expr1->symtree->n.sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (expr1, NULL)) { @@ -5790,11 +5791,11 @@ /* The assignment to an deferred character length sets the string length to that of the rhs. */ - if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL)) + if (expr1->ts.deferred) { - if (expr2->expr_type != EXPR_NULL) + if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL) gfc_add_modify (&block, lse.string_length, rse.string_length); - else + else if (lse.string_length != NULL) gfc_add_modify (&block, lse.string_length, build_int_cst (gfc_charlen_type_node, 0)); } diff -urN gcc-original/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 gcc-last/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 --- gcc-original/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc-last/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 2012-05-12 10:49:15.508634814 +0200 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/45170 +! PR fortran/52158 +! +! Contributed by Damian Rouson + +module speaker_class + type speaker + contains + procedure :: speak + end type +contains + function speak(this) + class(speaker) ,intent(in) :: this + character(:) ,allocatable :: speak + end function + subroutine say_something(somebody) + class(speaker) :: somebody + print *,somebody%speak() + end subroutine +end module + diff -urN gcc-original/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 gcc-last/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 --- gcc-original/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc-last/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 2012-05-12 10:49:20.736634703 +0200 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/45170 +! PR fortran/52158 +! +! Contributed by Tobias Burnus + +module test + implicit none + type t + procedure(deferred_len), pointer, nopass :: ppt + end type t +contains + function deferred_len() + character(len=:), allocatable :: deferred_len + deferred_len = 'abc' + end function deferred_len + subroutine doIt() + type(t) :: x + x%ppt => deferred_len + if ("abc" /= x%ppt()) call abort() + end subroutine doIt +end module test + +use test +call doIt () +end diff -urN gcc-original/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 gcc-last/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 --- gcc-original/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc-last/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 2012-05-12 10:49:20.736634703 +0200 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/45170 +! PR fortran/52158 + +module test + implicit none + type t + procedure(deferred_len), pointer, nopass :: ppt + end type t +contains + function deferred_len() + character(len=:), allocatable :: deferred_len + deferred_len = 'abc' + end function deferred_len + subroutine doIt() + type(t) :: x + character(:), allocatable :: temp + x%ppt => deferred_len + temp = deferred_len() + if ("abc" /= temp) call abort() + end subroutine doIt +end module test + +use test +call doIt () +end