Commit a00a2d4b authored by domob's avatar domob
Browse files

2009-08-17 Daniel Kraft <d@domob.eu>

	PR fortran/37425
	* resolve.c (get_checked_tb_operator_target): New routine to do checks
	on type-bound operators in common between intrinsic and user operators.
	(resolve_typebound_intrinsic_op): Call it.
	(resolve_typebound_user_op): Ditto.

2009-08-17  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/typebound_operator_2.f03: Test for error with illegal
	NOPASS bindings as operators.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150856 138bc75d-0d04-0410-961f-82ee72b054a4
parent ed184982
2009-08-17 Daniel Kraft <d@domob.eu>
PR fortran/37425
* resolve.c (get_checked_tb_operator_target): New routine to do checks
on type-bound operators in common between intrinsic and user operators.
(resolve_typebound_intrinsic_op): Call it.
(resolve_typebound_user_op): Ditto.
2009-08-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/41075
......
......@@ -8965,6 +8965,29 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
}
/* Retrieve the target-procedure of an operator binding and do some checks in
common for intrinsic and user-defined type-bound operators. */
static gfc_symbol*
get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
{
gfc_symbol* target_proc;
gcc_assert (target->specific && !target->specific->is_generic);
target_proc = target->specific->u.specific->n.sym;
gcc_assert (target_proc);
/* All operator bindings must have a passed-object dummy argument. */
if (target->specific->nopass)
{
gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
return NULL;
}
return target_proc;
}
/* Resolve a type-bound intrinsic operator. */
static gfc_try
......@@ -8998,9 +9021,9 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
{
gfc_symbol* target_proc;
gcc_assert (target->specific && !target->specific->is_generic);
target_proc = target->specific->u.specific->n.sym;
gcc_assert (target_proc);
target_proc = get_checked_tb_operator_target (target, p->where);
if (!target_proc)
return FAILURE;
if (!gfc_check_operator_interface (target_proc, op, p->where))
return FAILURE;
......@@ -9059,9 +9082,9 @@ resolve_typebound_user_op (gfc_symtree* stree)
{
gfc_symbol* target_proc;
gcc_assert (target->specific && !target->specific->is_generic);
target_proc = target->specific->u.specific->n.sym;
gcc_assert (target_proc);
target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
if (!target_proc)
goto error;
if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
goto error;
......
2009-08-17 Daniel Kraft <d@domob.eu>
PR fortran/37425
* gfortran.dg/typebound_operator_2.f03: Test for error with illegal
NOPASS bindings as operators.
2009-08-17 Uros Bizjak <ubizjak@gmail.com>
* lib/target-supports.exp
......
......@@ -13,8 +13,8 @@ MODULE m
PROCEDURE, PASS :: onearg
PROCEDURE, PASS :: onearg_alt => onearg
PROCEDURE, PASS :: onearg_alt2 => onearg
PROCEDURE, NOPASS :: nopassed => onearg
PROCEDURE, PASS :: threearg
PROCEDURE, NOPASS :: noarg
PROCEDURE, PASS :: sub
PROCEDURE, PASS :: sub2 ! { dg-error "must be a FUNCTION" }
PROCEDURE, PASS :: func
......@@ -26,10 +26,15 @@ MODULE m
GENERIC :: OPERATOR(.UOPA.) => sub ! { dg-error "must be a FUNCTION" }
GENERIC :: OPERATOR(.UOPB.) => threearg ! { dg-error "at most, two arguments" }
GENERIC :: OPERATOR(.UOPC.) => noarg ! { dg-error "at least one argument" }
! We can't check for the 'at least one argument' error, because in this case
! the procedure must be NOPASS and that other error is issued. But of
! course this should be alright.
GENERIC :: OPERATOR(.UNARY.) => onearg_alt
GENERIC, PRIVATE :: OPERATOR(.UNARY.) => onearg_alt2 ! { dg-error "must have the same access" }
GENERIC :: OPERATOR(.UNARYPRIME.) => nopassed ! { dg-error "can't be NOPASS" }
GENERIC :: OPERATOR(-) => nopassed ! { dg-error "can't be NOPASS" }
END TYPE t
CONTAINS
......@@ -44,10 +49,6 @@ CONTAINS
threearg = 42
END FUNCTION threearg
INTEGER FUNCTION noarg ()
noarg = 42
END FUNCTION noarg
LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" }
CLASS(t), INTENT(OUT) :: me
CLASS(t), INTENT(IN) :: b
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment