Patchwork [Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK

login
register
mail settings
Submitter Tobias Burnus
Date April 12, 2013, 3:23 p.m.
Message ID <516826F8.4070408@net-b.de>
Download mbox | patch
Permalink /patch/236135/
State New
Headers show

Comments

Tobias Burnus - April 12, 2013, 3:23 p.m.
Minor patch update due to Janus' gfc_explicit_interface_required patch.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias


Tobias Burnus wrote:
> 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.
>
Tobias Burnus - April 14, 2013, 5:06 p.m.
Early *ping*.

For a usage, see for instance Open MPI, which since 1.7.0 uses it. From 
their trunk version:
http://svn.open-mpi.org/svn/ompi/trunk/config/ompi_fortran_check_ignore_tkr.m4
http://svn.open-mpi.org/svn/ompi/trunk/ompi/mpi/fortran/use-mpi-ignore-tkr/mpi-ignore-tkr-interfaces.h.in

Tobias


Tobias Burnus wrote:
> Minor patch update due to Janus' gfc_explicit_interface_required patch.
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
>
>
> Tobias Burnus wrote:
>> Minor patch update:
>> - Changed FAILURE to false due to Janne's patch
>> - Removed a left-over #if 0 debug code
>>
>> On 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.
>>
>
Thomas Koenig - April 15, 2013, 9:03 p.m.
Hi Tobias,

> Minor patch update due to Janus' gfc_explicit_interface_required patch.
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?

I see that it can be useful, but I really dislike disabling the TKR
checks.

Can you put this behind an option so the user has to specify that
he really means it?

OK with this change; also OK if other people think that requiring
such an option is a Bad Idea.

	Thomas
Tobias Burnus - April 15, 2013, 9:25 p.m.
Am 15.04.2013 23:03, schrieb Thomas Koenig:
> Hi Tobias,
>
>> Minor patch update due to Janus' gfc_explicit_interface_required patch.
>>
>> Build and regtested on x86-64-gnu-linux.
>> OK for the trunk?
>
> I see that it can be useful, but I really dislike disabling the TKR
> checks. Can you put this behind an option so the user has to specify that
> he really means it?

Well, it is difficult to write accidentally
   !GCC$ attributes NO_ARG_CHECKS :: args

Additionally, for the purpose of libraries - such as MPI, it makes sense 
to disable the TKR check without requiring the users to always compile 
their programs with special options.

Regarding an option: Would be -f(no-)directives (with default = on) a 
suitable option, which also affects the other !GCC$ attributes, such as 
dllexport etc.?

> OK with this change; also OK if other people think that requiring
> such an option is a Bad Idea.

Tobias

Patch

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.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ffaa65d..f9891c9 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 a69cea2..27662f7 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 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 7414164..8f7cad7 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 30cfcd0..b132a42 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;
@@ -12835,7 +12858,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