mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 00:31:30 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/46662 ([OOP] gfortran accepts "CALL polymorphic%abstract_type%ppc()")

Browse Source 
2010-11-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46662
	* resolve.c (update_ppc_arglist): Add check for abstract passed object.

2010-11-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46662
	* gfortran.dg/proc_ptr_comp_pass_7.f90: New.

From-SVN: r167225
This commit is contained in:
Janus Weil 2010-11-28 21:22:29 +01:00
parent e4ba38383a
commit 8b29bd22d9
4 changed files with 88 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/fortran/ChangeLog
View File

@ -1,3 +1,8 @@
2010-11-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/46662
* resolve.c (update_ppc_arglist): Add check for abstract passed object.
2010-11-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/35810

15
gcc/fortran/resolve.c
View File

@ -5383,12 +5383,21 @@ update_ppc_arglist (gfc_expr* e)
if (!po)
return FAILURE;
/* F08:R739. */
if (po->rank > 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
}
/* F08:C611. */
if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for procedure-pointer component call at %L is of"
" ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
return FAILURE;
}
gcc_assert (tb->pass_arg_num > 0);
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
tb->pass_arg_num,
@ -5413,6 +5422,7 @@ check_typebound_baseobject (gfc_expr* e)
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
/* F08:C611. */
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
@ -5420,7 +5430,8 @@ check_typebound_baseobject (gfc_expr* e)
goto cleanup;
}
/* If the procedure called is NOPASS, the base object must be scalar. */
/* F08:C1230. If the procedure called is NOPASS,
the base object must be scalar. */
if (e->value.compcall.tbp->nopass && base->rank > 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
@ -5428,7 +5439,7 @@ check_typebound_baseobject (gfc_expr* e)
goto cleanup;
}
/* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
/* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
if (base->rank > 0)
{
gfc_error ("Non-scalar base object at %L currently not implemented",

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2010-11-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/46662
* gfortran.dg/proc_ptr_comp_pass_7.f90: New.
2010-11-28 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/aliasing2.adb (dg-final): Robustify pattern matching.

65
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_7.f90 Normal file
View File

@ -0,0 +1,65 @@
! { dg-do compile }
!
! PR 46662: [OOP] gfortran accepts "CALL polymorphic%abstract_type%ppc()"
!
! Contributed by Wolfgang Kilian <kilian@hep.physik.uni-siegen.de>
! cf. http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/a0857fa4a692d518
module types
implicit none
type, abstract :: base_t
integer :: i = 0
procedure(base_write_i), pointer :: write_procptr
contains
procedure :: write_i => base_write_i
end type base_t
type, extends (base_t) :: t
end type t
contains
subroutine base_write_i (obj)
class (base_t), intent(in) :: obj
print *, obj%i
end subroutine base_write_i
end module types
program main
use types
implicit none
type(t) :: obj
print *, "Direct printing"
obj%i = 1
print *, obj%i
print *, "Direct printing via parent"
obj%base_t%i = 2
print *, obj%base_t%i
print *, "Printing via TBP"
obj%i = 3
call obj%write_i
print *, "Printing via parent TBP"
obj%base_t%i = 4
call obj%base_t%write_i ! { dg-error "is of ABSTRACT type" }
print *, "Printing via OBP"
obj%i = 5
obj%write_procptr => base_write_i
call obj%write_procptr
print *, "Printing via parent OBP"
obj%base_t%i = 6
obj%base_t%write_procptr => base_write_i
call obj%base_t%write_procptr ! { dg-error "is of ABSTRACT type" }
end program main
! { dg-final { cleanup-modules "types" } }