From patchwork Thu Apr 11 08:25:28 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 235605 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]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 5EE192C00C2 for ; Thu, 11 Apr 2013 18:33:05 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:references :in-reply-to:content-type; q=dns; s=default; b=nf3mswIli1NmVXHyH /h4lv3m9kadR8ZmTSvhPpUEStPf3a4/TsGtTYRAKKuz59eqUHojCUeJTA7WkTfVG v7zrkcblEBY+7OtZHgeEdS5Zcj/Y7L46xcPgZ4M2conWL1nLmpe6XPo6GMJsgBKv 6UZ7Iudl4zn+ywQKDp1C+H9eWw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:references :in-reply-to:content-type; s=default; bh=8qV4NEvq2hASW5BQX0b1KBP Ejq4=; b=vs1udxjS5vz8UIl9WimDWOkrb224Hno/b6bLd6IdKQyO16xqb09m2i2 efmsAMwlvGx/ITw8CR/aPfLg1RuAcJDbExe4avmuXsI9BCumqj9ZVSMaqQUDgUMa 4jePDBPI27ZgYDTAgMcZMr6BypIt1cs5XTmB4hjgHZjvVn9oy2OA= Received: (qmail 30521 invoked by alias); 11 Apr 2013 08:25:38 -0000 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 Received: (qmail 30496 invoked by uid 89); 11 Apr 2013 08:25:37 -0000 X-Spam-SWARE-Status: No, score=-2.9 required=5.0 tests=AWL, BAYES_00, KHOP_THREADED, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Thu, 11 Apr 2013 08:25:35 +0000 Received: from archimedes.net-b.de (port-92-195-195-180.dynamic.qsc.de [92.195.195.180]) by mx01.qsc.de (Postfix) with ESMTP id ED6303CDBE; Thu, 11 Apr 2013 10:25:29 +0200 (CEST) Message-ID: <51667378.2090209@net-b.de> Date: Thu, 11 Apr 2013 10:25:28 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130329 Thunderbird/17.0.5 MIME-Version: 1.0 To: gcc patches , gfortran Subject: Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK References: <51657380.2000809@net-b.de> In-Reply-To: <51657380.2000809@net-b.de> X-Virus-Found: No Minor patch update: - Changed FAILURE to false due to Janne's patch - Removed a left-over #if 0 debug code Tobias Burnus wrote: > Many compilers have some pragma or directive to disable the type, kind > and rank (TKR) checks. That feature matches C's "void*" pointer and > can be used in conjunction with passing some byte data to a procedure, > which only needs to know either the pointer address or pointer address > and size. > > I think the most useful application are MPI implementation. Currently, > the do not offer explicit interfaces for their procedures which take a > "void *buffer" argument. For MPI 3.0, many compiler have started to > use compiler directives which disable TKR checks - and where gfortran > is left out. > > The Fortran standard does not provide such a feature - and it likely > won't have one in the next standard, either. The Technical > Specification ISO/ICE TS 29113:2012 provides TYPE(*), which disables > the TK part of TKR. That's fine if one has either scalars or arrays > (including array elements) - then one can use "type(*) :: buf" and > "type(*),dimension(*) :: buf". But that doesn't allow for scalars > *and* arrays [1]. The next Fortran standard might allow for scalars > passed to type(*),dimension(*) in Bind(C) procedures - but seemingly > not for non-Bind(C) procedures nor is a draft in sight [2]. > > (There is a possibility to pass both scalars and arrays to a dummy > argument, namely: "type(*), dimension(..)" but that uses not directly > the address but passes an array descriptor.) > > Other compilers have: > > !DEC$ ATTRIBUTES NO_ARG_CHECK :: buf > !$PRAGMA IGNORE_TKR buf > !DIR$ IGNORE_TKR buf > !IBM* IGNORE_TKR buf > > With the attached patch, gfortran does likewise. I essentially use the > same mechanism as TYPE(*) with the code - after resolving the symbol, > I even set ts.type = BT_ASSUMED. Contrary to some other compilers, > which only allow the attribute for interfaces, this patch also allows > it for Fortran procedures. But due to the TYPE(*) constraints, one can > only use it with C_LOC or pass it on to another NO_ARG_CHECK dummy. > > By the way, the recommended data type with this feature is TYPE(*). In > order to increase compatibility with other codes, it also accepts > intrinsic numeric types (and logical) of any kind. > > Build and regtested on x86-64-gnu-linux. > OK for the trunk? > > Tobias > > [1] Generic interfaces are not really a solution as one needs one per > rank, i.e. scalar+15 ranks = 16 specific functions; with two such > arguments, up to 16*16 = 256 combinations. As other compilers support > directives and as, e.g., MPI has many interfaces, MPI vendors won't go > that route. However, I assume that they will start using gfortran's > dimension(..) at some point, in line with MPI 3. Either the 4.8+ one > with gfortran's current descriptor or the one from Fortran-Dev. > > [2] Even if a first draft were available, one had to wait until at > least the first J3/WG5 vote to be _reasonable_ sure that the proposal > is in and won't be modified. 2013-04-11 Tobias Burnus PR fortran/39505 * decl.c (ext_attr_list): Add EXT_ATTR_NO_ARG_CHECK. * gfortran.h (ext_attr_id_t): Ditto. * gfortran.texi (GNU Fortran Compiler Directives): Document it. * interface.c (compare_type_rank): Ignore rank for NO_ARG_CHECK. (compare_parameter): Ditto - and regard as unlimited polymorphic. * resolve.c (resolve_symbol, resolve_variable): Add same constraint checks as for TYPE(*); turn dummy to TYPE(*),dimension(*). (resolve_global_procedure): Require explicit interface for NO_ARG_CHECK. 2013-04-11 Tobias Burnus PR fortran/39505 * gfortran.dg/no_arg_check_1.f90: New. * gfortran.dg/no_arg_check_2.f90: New. * gfortran.dg/no_arg_check_3.f90: New. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 3188eae..afae899 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -8628,12 +8628,13 @@ gfc_match_final_decl (void) const ext_attr_t ext_attr_list[] = { - { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" }, - { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" }, - { "cdecl", EXT_ATTR_CDECL, "cdecl" }, - { "stdcall", EXT_ATTR_STDCALL, "stdcall" }, - { "fastcall", EXT_ATTR_FASTCALL, "fastcall" }, - { NULL, EXT_ATTR_LAST, NULL } + { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" }, + { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" }, + { "cdecl", EXT_ATTR_CDECL, "cdecl" }, + { "stdcall", EXT_ATTR_STDCALL, "stdcall" }, + { "fastcall", EXT_ATTR_FASTCALL, "fastcall" }, + { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL }, + { NULL, EXT_ATTR_LAST, NULL } }; /* Match a !GCC$ ATTRIBUTES statement of the form: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4ebe987..ab15cc1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -687,6 +687,7 @@ typedef enum EXT_ATTR_STDCALL, EXT_ATTR_CDECL, EXT_ATTR_FASTCALL, + EXT_ATTR_NO_ARG_CHECK, EXT_ATTR_LAST, EXT_ATTR_NUM = EXT_ATTR_LAST } ext_attr_id_t; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 61cb3bb..f4bcdef 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -2688,6 +2688,29 @@ are in a shared library. The following attributes are available: @item @code{DLLIMPORT} -- reference the function or variable using a global pointer @end itemize +For dummy arguments, the @code{NO_ARG_CHECK} attribute can be used; in +other compilers, it is also known as @code{IGNORE_TKR}. For dummy arguments +with this attribute actual arguments of any type and kind (similar to +@code{TYPE(*)}), scalars and arrays of any rank (no equivalent +in Fortran standard) are accepted. As with @code{TYPE(*)}, the argument +is unlimited polymorphic and no type information is available. +Additionally, the same restrictions apply, i.e. the argument may only be +passed to dummy arguments with the @code{NO_ARG_CHECK} attribute and as +argument to the @code{C_LOC} intrinsic function of the @code{ISO_C_BINDING} +module. + +Variables with @code{NO_ARG_CHECK} attribute shall be of assumed-type +(@code{TYPE(*)}; recommended) or of an intrinsic numeric type; they +shall not have the @code{ALLOCATE}, @code{CODIMENSION}, @code{INTENT(OUT)}, +@code{POINTER} or @code{VALUE} attribute; furthermore, they shall be +either scalar or of assumed-size (@code{dimension(*)}). As @code{TYPE(*)}, +the @code{NO_ARG_CHECK} attribute requires an explicit interface. + +@itemize +@item @code{NO_ARG_CHECK} -- disable the type, kind and rank checking +@end itemize + + The attributes are specified using the syntax @code{!GCC$ ATTRIBUTES} @var{attribute-list} @code{::} @var{variable-list} diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5741911..22d0d35 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -519,6 +519,10 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) gfc_array_spec *as1, *as2; int r1, r2; + if (s1->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK) + || s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + return 1; + as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as; as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as; @@ -1902,6 +1906,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && actual->ts.type != BT_HOLLERITH && formal->ts.type != BT_ASSUMED + && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && !gfc_compare_types (&formal->ts, &actual->ts) && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS && gfc_compare_derived_types (formal->ts.u.derived, @@ -2062,6 +2067,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || formal->as->type == AS_DEFERRED) && actual->expr_type != EXPR_NULL; + /* Skip rank checks for NO_ARG_CHECK. */ + if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + return 1; + /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ if (rank_check || ranks_must_agree || (formal->attr.pointer && actual->expr_type != EXPR_NULL) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9098d2c..f29ee70 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2289,6 +2289,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + { + gfc_error ("Procedure '%s' at %L with NO_ARG_CHECK attribute " + "for dummy argument '%s' must have an explicit " + "interface", sym->name, &sym->declared_at, + arg->sym->name); + break; + } /* As assumed-type is unlimited polymorphic (cf. above). See also TS 29113, Note 6.1. */ else if (arg->sym->ts.type == BT_ASSUMED) @@ -4650,8 +4658,19 @@ resolve_variable (gfc_expr *e) return false; sym = e->symtree->n.sym; + /* Use same check as for TYPE(*) below; this check has to be before TYPE(*) + as ts.type is set to BT_ASSUMED in resolve_symbol. */ + if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + { + if (!actual_arg || inquiry_argument) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only " + "be used as actual argument", sym->name, &e->where); + return false; + } + } /* TS 29113, 407b. */ - if (e->ts.type == BT_ASSUMED) + else if (e->ts.type == BT_ASSUMED) { if (!actual_arg) { @@ -4671,13 +4690,12 @@ resolve_variable (gfc_expr *e) return false; } } - /* TS 29113, C535b. */ - if ((sym->ts.type == BT_CLASS && sym->attr.class_ok - && CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) - || (sym->ts.type != BT_CLASS && sym->as - && sym->as->type == AS_ASSUMED_RANK)) + else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) { if (!actual_arg) { @@ -4698,11 +4716,19 @@ resolve_variable (gfc_expr *e) } } - /* TS 29113, 407b. */ - if (e->ts.type == BT_ASSUMED && e->ref + if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL && e->ref->next == NULL)) { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have " + "a subobject reference", sym->name, &e->ref->u.ar.where); + return false; + } + /* TS 29113, 407b. */ + else if (e->ts.type == BT_ASSUMED && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { gfc_error ("Assumed-type variable %s at %L shall not have a subobject " "reference", sym->name, &e->ref->u.ar.where); return false; @@ -12841,7 +12867,61 @@ resolve_symbol (gfc_symbol *sym) } } - if (sym->ts.type == BT_ASSUMED) + /* Use the same constraints as TYPE(*), except for the type check + and that only scalars and assumed-size arrays are permitted. */ + if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + { + if (!sym->attr.dummy) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " + "a dummy argument", sym->name, &sym->declared_at); + return; + } + + if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER + && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL + && sym->ts.type != BT_COMPLEX) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " + "of type TYPE(*) or of an numeric intrinsic type", + sym->name, &sym->declared_at); + return; + } + + if (sym->attr.allocatable || sym->attr.codimension + || sym->attr.pointer || sym->attr.value) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " + "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE " + "attribute", sym->name, &sym->declared_at); + return; + } + + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " + "have the INTENT(OUT) attribute", + sym->name, &sym->declared_at); + return; + } + if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall " + "either be a scalar or an assumed-size array", + sym->name, &sym->declared_at); + return; + } + + /* Set the type to TYPE(*) and add a dimension(*) to ensure + NO_ARG_CHECK is correctly handled in trans*.c, e.g. with + packing. */ + sym->ts.type = BT_ASSUMED; + sym->as = gfc_get_array_spec (); + sym->as->type = AS_ASSUMED_SIZE; + sym->as->rank = 1; + sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + } + else if (sym->ts.type == BT_ASSUMED) { /* TS 29113, C407a. */ if (!sym->attr.dummy) diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_1.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_1.f90 new file mode 100644 index 0000000..1e1855d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/no_arg_check_1.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_1.f90 +! +module mpi_interface + implicit none + + interface !mpi_send + subroutine MPI_Send (buf, count, datatype, dest, tag, comm, ierr) +!GCC$ attributes NO_ARG_CHECK :: buf + integer, intent(in) :: buf + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + + interface !mpi_send2 + subroutine MPI_Send2 (buf, count, datatype, dest, tag, comm, ierr) +!GCC$ attributes NO_ARG_CHECK :: buf + type(*), intent(in) :: buf(*) + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + +end module + +use mpi_interface + real :: a(3) + integer :: b(3) + call foo(a) + call foo(b) + call foo(a(1:2)) + call foo(b(1:2)) + call MPI_Send(a, 1, 1,1,1,j,i) + call MPI_Send(b, 1, 1,1,1,j,i) + call MPI_Send2(a, 1, 1,1,1,j,i) + call MPI_Send2(b, 1, 1,1,1,j,i) +contains + subroutine foo(x) +!GCC$ attributes NO_ARG_CHECK :: x + real :: x(*) + call MPI_Send2(x, 1, 1,1,1,j,i) + end +end diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 new file mode 100644 index 0000000..5ff9894 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 @@ -0,0 +1,153 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_2.f90 +! + +module mod + use iso_c_binding, only: c_loc, c_ptr, c_bool + implicit none + interface my_c_loc + function my_c_loc1(x) bind(C) + import c_ptr +!GCC$ attributes NO_ARG_CHECK :: x + type(*) :: x + type(c_ptr) :: my_c_loc1 + end function + end interface my_c_loc +contains + subroutine sub_scalar (arg1, presnt) + integer(8), target, optional :: arg1 + logical :: presnt + type(c_ptr) :: cpt +!GCC$ attributes NO_ARG_CHECK :: arg1 + if (presnt .neqv. present (arg1)) call abort () + cpt = c_loc (arg1) + end subroutine sub_scalar + + subroutine sub_array_assumed (arg3) +!GCC$ attributes NO_ARG_CHECK :: arg3 + logical(1), target :: arg3(*) + type(c_ptr) :: cpt + cpt = c_loc (arg3) + end subroutine sub_array_assumed +end module + +use mod +use iso_c_binding, only: c_int, c_null_ptr +implicit none +type t1 + integer :: a +end type t1 +type :: t2 + sequence + integer :: b +end type t2 +type, bind(C) :: t3 + integer(c_int) :: c +end type t3 + +integer :: scalar_int +real, allocatable :: scalar_real_alloc +character, pointer :: scalar_char_ptr + +integer :: array_int(3) +real, allocatable :: array_real_alloc(:,:) +character, pointer :: array_char_ptr(:,:) + +type(t1) :: scalar_t1 +type(t2), allocatable :: scalar_t2_alloc +type(t3), pointer :: scalar_t3_ptr + +type(t1) :: array_t1(4) +type(t2), allocatable :: array_t2_alloc(:,:) +type(t3), pointer :: array_t3_ptr(:,:) + +class(t1), allocatable :: scalar_class_t1_alloc +class(t1), pointer :: scalar_class_t1_ptr + +class(t1), allocatable :: array_class_t1_alloc(:,:) +class(t1), pointer :: array_class_t1_ptr(:,:) + +scalar_char_ptr => null() +scalar_t3_ptr => null() + +call sub_scalar (presnt=.false.) +call sub_scalar (scalar_real_alloc, .false.) +call sub_scalar (scalar_char_ptr, .false.) +call sub_scalar (null (), .false.) +call sub_scalar (scalar_t2_alloc, .false.) +call sub_scalar (scalar_t3_ptr, .false.) + +allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) +allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) +allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) +allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) +allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) + +call sub_scalar (scalar_int, .true.) +call sub_scalar (scalar_real_alloc, .true.) +call sub_scalar (scalar_char_ptr, .true.) +call sub_scalar (array_int(2), .true.) +call sub_scalar (array_real_alloc(3,2), .true.) +call sub_scalar (array_char_ptr(0,1), .true.) +call sub_scalar (scalar_t1, .true.) +call sub_scalar (scalar_t2_alloc, .true.) +call sub_scalar (scalar_t3_ptr, .true.) +call sub_scalar (array_t1(2), .true.) +call sub_scalar (array_t2_alloc(3,2), .true.) +call sub_scalar (array_t3_ptr(0,1), .true.) +call sub_scalar (array_class_t1_alloc(2,1), .true.) +call sub_scalar (array_class_t1_ptr(3,3), .true.) + +call sub_array_assumed (array_int) +call sub_array_assumed (array_real_alloc) +call sub_array_assumed (array_char_ptr) +call sub_array_assumed (array_t1) +call sub_array_assumed (array_t2_alloc) +call sub_array_assumed (array_t3_ptr) +call sub_array_assumed (array_class_t1_alloc) +call sub_array_assumed (array_class_t1_ptr) + +deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) +deallocate (array_class_t1_ptr, array_t3_ptr) +contains + subroutine sub(x) + integer :: x(:) + call sub_array_assumed (x) + end subroutine sub +end + +! { dg-final { scan-tree-dump-times "sub_scalar .0B," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_ptr._data.dat" 1 "original" } }a + +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 3 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_3.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_3.f90 new file mode 100644 index 0000000..c3a8089 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/no_arg_check_3.f90 @@ -0,0 +1,124 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_2.f90 +! +subroutine one(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer, value :: a +end subroutine one + +subroutine two(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer, pointer :: a +end subroutine two + +subroutine three(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer, allocatable :: a +end subroutine three + +subroutine four(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer :: a[*] +end subroutine four + +subroutine five(a) ! { dg-error "with NO_ARG_CHECK attribute shall either be a scalar or an assumed-size array" } +!GCC$ attributes NO_ARG_CHECK :: a + integer :: a(3) +end subroutine five + +subroutine six() +!GCC$ attributes NO_ARG_CHECK :: nodum ! { dg-error "with NO_ARG_CHECK attribute shall be a dummy argument" } + integer :: nodum +end subroutine six + +subroutine seven(y) +!GCC$ attributes NO_ARG_CHECK :: y + integer :: y(*) + call a7(y(3:5)) ! { dg-error "with NO_ARG_CHECK attribute shall not have a subobject reference" } +contains + subroutine a7(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x(*) + end subroutine a7 +end subroutine seven + +subroutine nine() + interface one + subroutine okay(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + end subroutine okay + end interface + interface two + subroutine ambig1(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + end subroutine ambig1 + subroutine ambig2(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x(*) + end subroutine ambig2 ! { dg-error "Ambiguous interfaces 'ambig2' and 'ambig1' in generic interface 'two'" } + end interface + interface three + subroutine ambig3(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + end subroutine ambig3 + subroutine ambig4(x) + integer :: x + end subroutine ambig4 ! { dg-error "Ambiguous interfaces 'ambig4' and 'ambig3' in generic interface 'three'" } + end interface +end subroutine nine + +subroutine ten() + interface + subroutine bar() + end subroutine + end interface + type t + contains + procedure, nopass :: proc => bar + end type + type(t) :: xx + call sub(xx) ! { dg-error "is of derived type with type-bound or FINAL procedures" } +contains + subroutine sub(a) +!GCC$ attributes NO_ARG_CHECK :: a + integer :: a + end subroutine sub +end subroutine ten + +subroutine eleven(x) + external bar +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + call bar(x) ! { dg-error "Assumed-type argument x at .1. requires an explicit interface" } +end subroutine eleven + +subroutine twelf(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + call bar(x) ! { dg-error "Type mismatch in argument" } +contains + subroutine bar(x) + integer :: x + end subroutine bar +end subroutine twelf + +subroutine thirteen(x, y) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + integer :: y(:) + print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" } +end subroutine thirteen + +subroutine fourteen(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + x = x ! { dg-error "with NO_ARG_CHECK attribute may only be used as actual argument" } +end subroutine fourteen