From b325faf9d99e6d49917c5929a864534629c56892 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Mon, 17 Aug 2009 20:55:30 +0200 Subject: [PATCH] re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators) 2009-08-17 Daniel Kraft 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 PR fortran/37425 * gfortran.dg/typebound_operator_2.f03: Test for error with illegal NOPASS bindings as operators. From-SVN: r150856 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/resolve.c | 35 ++++++++++++++++++---- gcc/testsuite/ChangeLog | 6 ++++ gcc/testsuite/gfortran.dg/typebound_operator_2.f03 | 13 ++++---- 4 files changed, 50 insertions(+), 12 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3abd3bb..10f95fb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-08-17 Daniel Kraft + + 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 PR fortran/41075 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fb72b93..4f99aba 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c8713f5..7c905d7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-08-17 Daniel Kraft + + PR fortran/37425 + * gfortran.dg/typebound_operator_2.f03: Test for error with illegal + NOPASS bindings as operators. + 2009-08-17 Uros Bizjak * lib/target-supports.exp diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 index ccce3b5..67f467c 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 @@ -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 -- 2.7.4