re PR fortran/39505 (Consider a 'no arg check' directive)

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.

From-SVN: r198011

6 files changed, 141 insertions, 16 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ee160b6..2f99025 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 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 684d205..90bce53 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)