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 <bur...@net-b.de>
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 <bur...@net-b.de>
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
