2006-02-09 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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
+2006-02-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <coudert@clipper.ens.fr>
PR libfortran/25425
}
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",
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)
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);
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;
}
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))
{
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);
+2006-02-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <joern.rennecke@st.com>
PR target/26141
--- /dev/null
+! { 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 <eedelmanncc.gnu.org>
+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
--- /dev/null
+! { dg-do compile }
+! Tests fix for PR25070; was no error for actual and assumed shape
+! dummy ranks not matching.
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+
+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
+
--- /dev/null
+! { dg-do compile }
+! Tests fix for PR25059, which gave and ICE after error message
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+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
projects / gcc.git / commitdiff