From patchwork Thu Jul 26 14:01:36 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 173441 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8C48D2C0332 for ; Fri, 27 Jul 2012 00:02:30 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1343916151; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=spj2ar2 ST4NchhetH93Nrntk/xc=; b=nkwCgCSiakAEnNbIL5stBc91FDfVs0T7GJcjz1O 2Zi3a7s8PX6PhFF7cORG7z0dKC/4TyDRW+8rZS8H4XlhbiJDM2G9JmXj/yjmuPwJ 5rfW6cglCUdyIPpK45TH05U3bS8z99Xrz5XQtKqDs6UmlLqUByf3mvVXVqPBQT8M NC1w= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=vHBfzg5swOIXsDK90XC00EYHSqioSXCdc17wpDdxWBUtcq2t27tZZVZUe0DxM0 vZMi8NIuqa16HkVW91262D0rEkEzHd9SJ2XXKkiLGpCTg9RHpCOpx/GyYeLqUEKF 4himv0sXUTIui88VOaR1buTP96m6Qqfscvu1Ie6oa83TQ=; Received: (qmail 31863 invoked by alias); 26 Jul 2012 14:02:16 -0000 Received: (qmail 31844 invoked by uid 22791); 26 Jul 2012 14:02:09 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 26 Jul 2012 14:01:47 +0000 Received: from [192.168.178.22] (port-92-204-86-97.dynamic.qsc.de [92.204.86.97]) by mx02.qsc.de (Postfix) with ESMTP id 0287527CE0; Thu, 26 Jul 2012 16:01:39 +0200 (CEST) Message-ID: <50114DC0.60903@net-b.de> Date: Thu, 26 Jul 2012 16:01:36 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:14.0) Gecko/20120713 Thunderbird/14.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Update c_funloc/c_f_procpointer for TS29113 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org TS29113 allows also non interoperable procedures with c_funloc/c_f_procpointer; hence, this patch allows them with -std=f2008ts: "The function C F PROCPOINTER from the intrinsic module ISO C BINDING has the restriction in ISO/IEC 1539-1:2010 that CPTR and FPTR shall not be the C address and interface of a noninteroperable Fortran procedure. "The function C FUNLOC from the intrinsic module ISO C BINDING has the restriction in ISO/IEC 1539-1:2010 that its argument shall be interoperable. "These restrictions are removed." Additionally, I changed "parameter" to "argument" and added a diagnostic that the first argument to c_f_pointer/c_f_procpointer is the correct one - before both accepted c_ptr and c_funptr. Build and regtested on x86-64-linux. OK for the trunk? Tobias PS: For c_loc/c_f_pointer a similar restriction has been removed. However, to fix c_loc is more complicated as the current implementation has several rejects-valid/wrong-code bugs (cf. the existing PRs). For the full to-do list of TS29113, see http://gcc.gnu.org/ml/fortran/2012-07/msg00115.html 2012-07-26 Tobias Burnus * interface.c (gfc_procedure_use): Return gfc_try instead of void. * gfortran.h (gfc_procedure_use): Update prototype. * resolve.c (gfc_iso_c_func_interface): Allow noninteroperable procedures for c_funloc for TS29113. * (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer. 2012-07-26 Tobias Burnus * gfortran.dg/c_funloc_tests_6.f90: New. * gfortran.dg/c_funloc_tests_7.f90: New. * gfortran.dg/c_funloc_tests_5.f03: Compile with -std=f2003. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e1f2e3c..f803916 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2848,7 +2848,7 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *); int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int, char *, int, const char *, const char *); void gfc_check_interfaces (gfc_namespace *); -void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); +gfc_try gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *); gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_actual_arglist **); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 098ec3d2..0f8951c 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2927,7 +2927,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) well, the actual argument list will also end up being properly sorted. */ -void +gfc_try gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { /* Warn about calls with an implicit interface. Special case @@ -2954,7 +2954,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error("The pointer object '%s' at %L must have an explicit " "function interface or be declared as array", sym->name, where); - return; + return FAILURE; } if (sym->attr.allocatable && !sym->attr.external) @@ -2962,14 +2962,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error("The allocatable object '%s' at %L must have an explicit " "function interface or be declared as array", sym->name, where); - return; + return FAILURE; } if (sym->attr.allocatable) { gfc_error("Allocatable function '%s' at %L must have an explicit " "function interface", sym->name, where); - return; + return FAILURE; } for (a = *ap; a; a = a->next) @@ -3009,7 +3009,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) && a->expr->ts.type == BT_UNKNOWN) { gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); - return; + return FAILURE; } /* TS 29113, C407b. */ @@ -3018,19 +3018,23 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { gfc_error ("Assumed-rank argument requires an explicit interface " "at %L", &a->expr->where); - return; + return FAILURE; } } - return; + return SUCCESS; } if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where)) - return; + return FAILURE; + + if (check_intents (sym->formal, *ap) == FAILURE) + return FAILURE; - check_intents (sym->formal, *ap); if (gfc_option.warn_aliasing) check_some_aliasing (sym->formal, *ap); + + return SUCCESS; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 370e5cd..b4c3e4d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3012,20 +3007,18 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { /* TODO: Update this error message to allow for procedure pointers once they are implemented. */ - gfc_error_now ("Parameter '%s' to '%s' at %L must be a " + gfc_error_now ("Argument '%s' to '%s' at %L must be a " "procedure", args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } - else if (args_sym->attr.is_bind_c != 1) - { - gfc_error_now ("Parameter '%s' to '%s' at %L must be " - "BIND(C)", - args_sym->name, sym->name, - &(args->expr->where)); - retval = FAILURE; - } + else if (args_sym->attr.is_bind_c != 1 + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "argument '%s' to '%s' at %L", + args_sym->name, sym->name, + &(args->expr->where)) == FAILURE) + retval = FAILURE; } /* for c_loc/c_funloc, the new symbol is the same as the old one */ @@ -3480,7 +3473,11 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) /* Make sure the actual arguments are in the necessary order (based on the formal args) before resolving. */ - gfc_procedure_use (sym, &c->ext.actual, &(c->loc)); + if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE) + { + c->resolved_sym = sym; + return MATCH_ERROR; + } if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) || (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) @@ -3491,6 +3488,15 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) { if (c->ext.actual != NULL && c->ext.actual->next != NULL) { + if (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR) + { + gfc_error ("Argument at %L to C_F_POINTER shall have the type" + " C_PTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + /* Make sure we got a third arg if the second arg has non-zero rank. We must also check that the type and rank are correct since we short-circuit this check in @@ -3516,7 +3522,26 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) } } } - + else /* ISOCBINDING_F_PROCPOINTER. */ + { + if (c->ext.actual + && (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_FUNPTR)) + { + gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type " + "C_FUNPTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + if (c->ext.actual && c->ext.actual->next + && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "procedure-pointer at %L to C_F_FUNPOINTER", + &c->ext.actual->next->expr->where) + == FAILURE) + m = MATCH_ERROR; + } + if (m != MATCH_ERROR) { /* the 1 means to add the optional arg to formal list */ --- /dev/null 2012-07-26 07:22:20.983742380 +0200 +++ gcc/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 2012-07-26 11:04:39.000000000 +0200 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Check relaxed TS29113 constraints for procedures +! and c_f_*pointer argument checking for c_ptr/c_funptr. +! + +use iso_c_binding +implicit none +type(c_ptr) :: cp +type(c_funptr) :: cfp + +interface + subroutine sub() bind(C) + end subroutine sub +end interface +integer(c_int), pointer :: int +procedure(sub), pointer :: fsub + +integer, external :: noCsub +procedure(integer), pointer :: fint + +cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." }) +cfp = c_loc (int) ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." } + +call c_f_pointer (cfp, int) ! { dg-error "Argument at .1. to C_F_POINTER shall have the type C_PTR" } +call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" } + +cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" } +call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure-pointer at .1. to C_F_FUNPOINTER" } +end --- /dev/null 2012-07-26 07:22:20.983742380 +0200 +++ gcc/gcc/testsuite/gfortran.dg/c_funloc_tests_7.f90 2012-07-26 11:03:47.000000000 +0200 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts -fdump-tree-original" } +! +! Check relaxed TS29113 constraints for procedures +! and c_f_*pointer argument checking for c_ptr/c_funptr. +! + +use iso_c_binding +implicit none +type(c_funptr) :: cfp + +integer, external :: noCsub +procedure(integer), pointer :: fint + +cfp = c_funloc (noCsub) +call c_f_procpointer (cfp, fint) +end + +! { dg-final { scan-tree-dump-times "cfp =\[^;\]+ nocsub;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fint =\[^;\]+ cfp;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } + diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 index bbb418d..5d0862c 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=f2003" } ! Test that the arg checking for c_funloc verifies the procedures are ! C interoperable. module c_funloc_tests_5 @@ -7,9 +8,9 @@ contains subroutine sub0() bind(c) type(c_funptr) :: my_c_funptr - my_c_funptr = c_funloc(sub1) ! { dg-error "must be BIND.C." } + my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable argument" } - my_c_funptr = c_funloc(func0) ! { dg-error "must be BIND.C." } + my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable argument" } end subroutine sub0 subroutine sub1()