2013-04-12 Tobias Burnus <burnus@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(*).
        (gfc_explicit_interface_required): Require explicit interface
        for NO_ARG_CHECK.

2013-04-12  Tobias Burnus  <burnus@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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@198011 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 481 insertions, 16 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ee160b6c673..2f99025ea33 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2013-04-16  Tobias Burnus  <burnus@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(*).
+	(gfc_explicit_interface_required): Require explicit interface
+	for NO_ARG_CHECK.
+
 2013-04-16  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/56968
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ffaa65d6a5a..f9891c98d0f 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -8572,12 +8572,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 a69cea2b349..27662f7ca40 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -679,6 +679,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 61cb3bb9746..f4bcdef69c4 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 741416469f4..8f7cad72992 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -518,6 +518,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;
 
@@ -1900,6 +1904,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,
@@ -2060,6 +2065,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 684d2058b2d..90bce536c2d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2191,6 +2191,11 @@ gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
 	  strncpy (errmsg, _("polymorphic argument"), err_len);
 	  return true;
 	}
+      else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+	{
+	  strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
+	  return true;
+	}
       else if (arg->sym->ts.type == BT_ASSUMED)
 	{
 	  /* As assumed-type is unlimited polymorphic (cf. above).
@@ -4644,8 +4649,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)
 	{
@@ -4665,13 +4681,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)
 	{
@@ -4692,11 +4707,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;
@@ -12837,7 +12860,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/ChangeLog b/gcc/testsuite/ChangeLog
index 50a04dc82d9..02cb9473ef6 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2013-04-16  Tobias Burnus  <burnus@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.
+
 2013-04-16  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/56968
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 00000000000..1e1855d3174
--- /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 00000000000..5ff98940d6f
--- /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 00000000000..c3a80899ade
--- /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