From 8ae1ec924d6775e4ed3dab5546ff8344b63321ee Mon Sep 17 00:00:00 2001 From: Alessandro Fanfarillo Date: Sun, 13 May 2012 04:52:32 -0600 Subject: [PATCH] re PR fortran/52158 (Regression on character function with gfortran 4.7) 2012-05-13 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-13 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. Co-Authored-By: Tobias Burnus From-SVN: r187436 --- gcc/fortran/ChangeLog | 16 ++++++++ gcc/fortran/resolve.c | 2 +- gcc/fortran/trans-expr.c | 41 ++++++++++--------- gcc/testsuite/ChangeLog | 7 ++++ .../gfortran.dg/deferred_type_param_3.f90 | 23 +++++++++++ .../deferred_type_proc_pointer_1.f90 | 27 ++++++++++++ .../deferred_type_proc_pointer_2.f90 | 27 ++++++++++++ 7 files changed, 122 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index faffa290f24..251194b46af 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2012-05-13 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 Tobias Burnus PR fortran/49110 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4a072303c49..9814c14753a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11665,7 +11665,7 @@ resolve_fl_derived0 (gfc_symbol *sym) 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 --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 8045b1f029b..81562d2162d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2073,7 +2073,8 @@ tree 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 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) 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 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) /* 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 --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2869ef23e1f..9a34ac44c35 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-05-13 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. + 2012-05-12 Eric Botcazou * gnat.dg/null_pointer_deref3.adb: New test. diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 new file mode 100644 index 00000000000..809738d5b98 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 @@ -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 --git a/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 new file mode 100644 index 00000000000..3fc055e0e9c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 @@ -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 --git a/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 new file mode 100644 index 00000000000..dbdb3bdba34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 @@ -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 -- 2.30.2