From c4bbc105641ea61b0d4e5a826d639f1051a00667 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 9 Feb 2006 23:23:28 +0000 Subject: [PATCH] re PR fortran/26038 (ICE on allocation of assumed length CHARACTER dummy.) 2006-02-09 Paul Thomas PR fortran/26038 * trans-stmt.c (gfc_trans_allocate): Provide assumed character length scalar with missing backend_decl for the hidden dummy charlen. PR fortran/25059 * interface.c (gfc_extend_assign): Remove detection of non-PURE subroutine in assignment interface, with gfc_error, and put it in * resolve.c (resolve_code). PR fortran/25070 * interface.c (gfc_procedure_use): Flag rank checking for non- elemental, contained or interface procedures in call to (compare_actual_formal), where ranks are checked for assumed shape arrays.. 2006-02-09 Paul Thomas PR fortran/26038 * gfortran.dg/allocate_char_star_scalar_1.f90: New test. PR fortran/25059 * gfortran.dg/impure_assignment_1.f90: New test. PR fortran/25070 * gfortran.dg/assumed_shape_ranks_1.f90: New test. From-SVN: r110816 --- gcc/fortran/ChangeLog | 17 ++++++++++ gcc/fortran/interface.c | 20 ++++++------ gcc/fortran/resolve.c | 11 ++++++- gcc/fortran/trans-stmt.c | 4 +++ gcc/testsuite/ChangeLog | 11 +++++++ .../allocate_char_star_scalar_1.f90 | 31 +++++++++++++++++++ .../gfortran.dg/assumed_shape_ranks_1.f90 | 25 +++++++++++++++ .../gfortran.dg/impure_assignment_1.f90 | 26 ++++++++++++++++ 8 files changed, 134 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/impure_assignment_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 83dd30cdb78..ae80278d962 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2006-02-09 Paul Thomas + + PR fortran/26038 + * trans-stmt.c (gfc_trans_allocate): Provide assumed character length + scalar with missing backend_decl for the hidden dummy charlen. + + PR fortran/25059 + * interface.c (gfc_extend_assign): Remove detection of non-PURE + subroutine in assignment interface, with gfc_error, and put it in + * resolve.c (resolve_code). + + PR fortran/25070 + * interface.c (gfc_procedure_use): Flag rank checking for non- + elemental, contained or interface procedures in call to + (compare_actual_formal), where ranks are checked for assumed + shape arrays.. + 2006-02-08 Francois-Xavier Coudert PR libfortran/25425 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 93e3657af71..7c8627952af 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1241,7 +1241,10 @@ compare_actual_formal (gfc_actual_arglist ** ap, } if (!compare_parameter - (f->sym, a->expr, ranks_must_agree, is_elemental)) + (f->sym, a->expr, + ranks_must_agree && f->sym->as + && f->sym->as->type == AS_ASSUMED_SHAPE, + is_elemental)) { if (where) gfc_error ("Type/rank mismatch in argument '%s' at %L", @@ -1563,6 +1566,10 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a) void gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where) { + int ranks_must_agree; + ranks_must_agree = !sym->attr.elemental && (sym->attr.contained + || sym->attr.if_source == IFSRC_IFBODY); + /* Warn about calls with an implicit interface. */ if (gfc_option.warn_implicit_interface && sym->attr.if_source == IFSRC_UNKNOWN) @@ -1570,8 +1577,8 @@ gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where) sym->name, where); if (sym->attr.if_source == IFSRC_UNKNOWN - || !compare_actual_formal (ap, sym->formal, 0, - sym->attr.elemental, where)) + || !compare_actual_formal (ap, sym->formal, ranks_must_agree, + sym->attr.elemental, where)) return; check_intents (sym->formal, *ap); @@ -1796,13 +1803,6 @@ gfc_extend_assign (gfc_code * c, gfc_namespace * ns) c->expr2 = NULL; c->ext.actual = actual; - if (gfc_pure (NULL) && !gfc_pure (sym)) - { - gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be " - "PURE", sym->name, &c->loc); - return FAILURE; - } - return SUCCESS; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2a964f74bb2..3e1c005f4e6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4241,7 +4241,16 @@ resolve_code (gfc_code * code, gfc_namespace * ns) break; if (gfc_extend_assign (code, ns) == SUCCESS) - goto call; + { + if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym)) + { + gfc_error ("Subroutine '%s' called instead of assignment at " + "%L must be PURE", code->symtree->n.sym->name, + &code->loc); + break; + } + goto call; + } if (gfc_pure (NULL)) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index d857f47bb40..2f8d09b3d6b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3455,6 +3455,10 @@ gfc_trans_allocate (gfc_code * code) gfc_add_modify_expr (&se.pre, val, tmp); tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + + if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE) + tmp = se.string_length; + parm = gfc_chainon_list (NULL_TREE, val); parm = gfc_chainon_list (parm, tmp); parm = gfc_chainon_list (parm, pstat); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f53188f5c9f..bd7b36f0fd9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2006-02-09 Paul Thomas + + PR fortran/26038 + * gfortran.dg/allocate_char_star_scalar_1.f90: New test. + + PR fortran/25059 + * gfortran.dg/impure_assignment_1.f90: New test. + + PR fortran/25070 + * gfortran.dg/assumed_shape_ranks_1.f90: New test. + 2006-02-09 J"orn Rennecke PR target/26141 diff --git a/gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90 b/gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90 new file mode 100644 index 00000000000..305136cd659 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Tests the patch for PR26038 that used to ICE in gfc_trans_allocate +! for the want of a string_length to pass to the library. +! Contributed by hjl@lucon.org && Erik Edelmann +module moo + +contains + + subroutine foo(self) + character(*) :: self + pointer :: self + + nullify(self) + allocate(self) ! Used to ICE here + print *, len(self) + end subroutine + +end module moo + + +program hum + + use moo + + character(5), pointer :: p + character(10), pointer :: q + + call foo(p) + call foo(q) + +end program hum diff --git a/gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 b/gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 new file mode 100644 index 00000000000..a7f24ea1bc5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! Tests fix for PR25070; was no error for actual and assumed shape +! dummy ranks not matching. +! Contributed by Joost VandeVondele + +module addon + interface extra + function foo (y) + integer :: foo (2), y (:) + end function foo + end interface extra +end module addon + + use addon + INTEGER :: I(2,2) + I=RESHAPE((/1,2,3,4/),(/2,2/)) + CALL TST(I) ! { dg-error "Type/rank mismatch in argument" } + i = foo (i) ! { dg-error "Type/rank mismatch|Incompatible ranks" } +CONTAINS + SUBROUTINE TST(I) + INTEGER :: I(:) + write(6,*) I + END SUBROUTINE TST +END + diff --git a/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 b/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 new file mode 100644 index 00000000000..772ba7567e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/impure_assignment_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests fix for PR25059, which gave and ICE after error message +! Contributed by Joost VandeVondele +MODULE M1 + TYPE T1 + INTEGER :: I + END TYPE T1 + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE S1 + END INTERFACE +CONTAINS + SUBROUTINE S1(I,J) + TYPE(T1), INTENT(OUT):: I + TYPE(T1), INTENT(IN) :: J + I%I=J%I**2 + END SUBROUTINE S1 +END MODULE M1 + +USE M1 +CONTAINS +PURE SUBROUTINE S2(I,J) + TYPE(T1), INTENT(OUT):: I + TYPE(T1), INTENT(IN) :: J + I=J ! { dg-error "must be PURE" } +END SUBROUTINE S2 +END \ No newline at end of file -- 2.30.2