* [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
@ 2013-04-10 16:41 Tobias Burnus
2013-04-11 9:41 ` Tobias Burnus
0 siblings, 1 reply; 10+ messages in thread
From: Tobias Burnus @ 2013-04-10 16:41 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2856 bytes --]
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.
[-- Attachment #2: no_arg_check.diff --]
[-- Type: text/x-patch, Size: 22440 bytes --]
2013-04-10 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(*).
(resolve_global_procedure): Require explicit interface
for NO_ARG_CHECK.
2013-04-10 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 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 835b57f..26bd650 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2292,6 +2292,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)
@@ -4654,6 +4662,29 @@ resolve_variable (gfc_expr *e)
return FAILURE;
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 FAILURE;
+ }
+#if 0
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: See note for TYPE(*). */
+ gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute as actual argument to "
+ "an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+#endif
+ }
+
+
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED)
{
@@ -4675,13 +4706,12 @@ resolve_variable (gfc_expr *e)
return FAILURE;
}
}
-
/* 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)
{
@@ -4702,11 +4732,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 FAILURE;
+ }
+ /* 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 FAILURE;
@@ -12853,7 +12891,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
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-10 16:41 [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK Tobias Burnus
@ 2013-04-11 9:41 ` Tobias Burnus
2013-04-12 17:55 ` Tobias Burnus
0 siblings, 1 reply; 10+ messages in thread
From: Tobias Burnus @ 2013-04-11 9:41 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 3092 bytes --]
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.
[-- Attachment #2: no_arg_check.diff --]
[-- Type: text/x-patch, Size: 22178 bytes --]
2013-04-11 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(*).
(resolve_global_procedure): Require explicit interface
for NO_ARG_CHECK.
2013-04-11 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 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
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-11 9:41 ` Tobias Burnus
@ 2013-04-12 17:55 ` Tobias Burnus
2013-04-15 7:10 ` *ping* - " Tobias Burnus
2013-04-16 7:05 ` Thomas Koenig
0 siblings, 2 replies; 10+ messages in thread
From: Tobias Burnus @ 2013-04-12 17:55 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 3334 bytes --]
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.
>
[-- Attachment #2: no_arg_check-v2.diff --]
[-- Type: text/x-patch, Size: 22030 bytes --]
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
^ permalink raw reply [flat|nested] 10+ messages in thread
* *ping* - Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-12 17:55 ` Tobias Burnus
@ 2013-04-15 7:10 ` Tobias Burnus
2013-04-16 7:05 ` Thomas Koenig
1 sibling, 0 replies; 10+ messages in thread
From: Tobias Burnus @ 2013-04-15 7:10 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
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.
>>
>
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-12 17:55 ` Tobias Burnus
2013-04-15 7:10 ` *ping* - " Tobias Burnus
@ 2013-04-16 7:05 ` Thomas Koenig
2013-04-16 8:36 ` Tobias Burnus
1 sibling, 1 reply; 10+ messages in thread
From: Thomas Koenig @ 2013-04-16 7:05 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
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
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-16 7:05 ` Thomas Koenig
@ 2013-04-16 8:36 ` Tobias Burnus
2013-04-16 8:59 ` Tobias Burnus
0 siblings, 1 reply; 10+ messages in thread
From: Tobias Burnus @ 2013-04-16 8:36 UTC (permalink / raw)
To: Thomas Koenig; +Cc: gcc patches, gfortran
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
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-16 8:36 ` Tobias Burnus
@ 2013-04-16 8:59 ` Tobias Burnus
2013-04-17 9:03 ` Tobias Burnus
0 siblings, 1 reply; 10+ messages in thread
From: Tobias Burnus @ 2013-04-16 8:59 UTC (permalink / raw)
To: Thomas Koenig; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1069 bytes --]
Tobias Burnus wrote:
> Am 15.04.2013 23:03, schrieb Thomas Koenig:
>> I see that it can be useful, but I really dislike disabling the TKR
>> checks.
Side remark: TS29113 already allows to disable TK checks via TYPE(*).
And I find disabling TRK checks very useful for certain applications -
and MPI buffers is one. On has just to make sure that it is difficult to
abuse it. The J3 team spend some time on it to ensure this for TYPE(*) -
and the NO_ARG_CHECK makes use of that feature.
>> 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.?
Namely, the attached patch?
Tobias
[-- Attachment #2: fdirectives.diff --]
[-- Type: text/x-patch, Size: 4324 bytes --]
2013-04-16 Tobias Burnus <burnus@net-b.de>
PR fortran/39505
* gfortran.h (gfc_option_t): Add flag_directives.
* gfortran.texi (GCC Fortran directives): Mention
-fno-directives.
* invoke.texi (-fno-directives): Add.
* lang.opt (fdirectives): Add.
* options.c (gfc_init_options, gfc_handle_option): Handle it.
* scanner.c (skip_gcc_attribute): Ditto.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a69cea2..bb4ec1b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2300,6 +2300,7 @@ typedef struct
int flag_realloc_lhs;
int flag_aggressive_function_elimination;
int flag_frontend_optimize;
+ int flag_directives;
int fpe;
int rtcheck;
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 61cb3bb..c2bb0d5 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -2663,6 +2663,9 @@ on the processor; see
@ref{Top,,C Extensions,gcc,Using the GNU Compiler Collection (GCC)}
for details.
+Note that the parsing of the directives can be disabled via the
+@option{-fno-directives} option.
+
For procedures and procedure pointers, the following attributes can
be used to change the calling convention:
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 12c200e..9f250ad 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -116,7 +116,7 @@ by type. Explanations are in the following sections.
@xref{Fortran Dialect Options,,Options controlling Fortran dialect}.
@gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol
-fd-lines-as-comments -fdefault-double-8 -fdefault-integer-8 @gol
--fdefault-real-8 -fdollar-ok -ffixed-line-length-@var{n} @gol
+-fdefault-real-8 -fdirectives -fdollar-ok -ffixed-line-length-@var{n} @gol
-ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol
-ffree-line-length-none -fimplicit-none -finteger-4-integer-8 @gol
-fmax-identifier-length -fmodule-private -fno-fixed-form -fno-range-check @gol
@@ -250,6 +250,11 @@ the kind of non-double real constants like @code{1.0}, and does promote
the default width of @code{DOUBLE PRECISION} to 16 bytes if possible, unless
@code{-fdefault-double-8} is given, too.
+@item -fno-directives
+@opindex @code{fdirectives}
+@opindex @code{fno-directives}
+Disable the GNU Fortran Compiler Directives (@code{!GCC$}) directives.
+
@item -fdollar-ok
@opindex @code{fdollar-ok}
@cindex @code{$}
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index dbc3f6b..5fb1a13 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -389,6 +389,10 @@ fdollar-ok
Fortran
Allow dollar signs in entity names
+fdirectives
+Fortran
+Enable !GCC$ directives
+
fdump-core
Fortran Ignore
Does nothing. Preserved for backward compatibility.
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 3f5de03..00e6a50 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -122,6 +122,7 @@ gfc_init_options (unsigned int decoded_options_count,
gfc_option.flag_integer4_kind = 0;
gfc_option.flag_real4_kind = 0;
gfc_option.flag_real8_kind = 0;
+ gfc_option.flag_directives = 1;
gfc_option.flag_dollar_ok = 0;
gfc_option.flag_underscoring = 1;
gfc_option.flag_f2c = 0;
@@ -766,6 +767,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
gfc_option.flag_d_lines = 0;
break;
+ case OPT_fdirectives:
+ gfc_option.flag_directives = value;
+ break;
+
case OPT_fdump_fortran_original:
case OPT_fdump_parse_tree:
gfc_option.dump_fortran_original = value;
diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c
index fd8f284..8c95f90 100644
--- a/gcc/fortran/scanner.c
+++ b/gcc/fortran/scanner.c
@@ -718,6 +718,9 @@ skip_gcc_attribute (locus start)
char c;
locus old_loc = gfc_current_locus;
+ if (!gfc_option.flag_directives)
+ return false;
+
if ((c = next_char ()) == 'g' || c == 'G')
if ((c = next_char ()) == 'c' || c == 'C')
if ((c = next_char ()) == 'c' || c == 'C')
@@ -770,7 +773,7 @@ skip_free_comments (void)
if (c == '!')
{
/* Keep the !GCC$ line. */
- if (at_bol && skip_gcc_attribute (start))
+ if (at_bol && skip_gcc_attribute (start))
return false;
/* If -fopenmp, we need to handle here 2 things:
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-16 8:59 ` Tobias Burnus
@ 2013-04-17 9:03 ` Tobias Burnus
2013-04-18 8:06 ` Thomas Koenig
0 siblings, 1 reply; 10+ messages in thread
From: Tobias Burnus @ 2013-04-17 9:03 UTC (permalink / raw)
To: Thomas Koenig; +Cc: gcc patches, gfortran
Tobias Burnus wrote:
>>> Can you put this behind an option so the user has to specify that
>>> he really means it?
>>
>> 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.?
> Namely, the attached patch?
I have now committed the original patch (Rev. 198011). The option thing
can be done as follow up. Is my -f(no-)directives patch okay? Or do you
envision something else?
Tobias
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-17 9:03 ` Tobias Burnus
@ 2013-04-18 8:06 ` Thomas Koenig
2013-04-18 8:21 ` Tobias Burnus
0 siblings, 1 reply; 10+ messages in thread
From: Thomas Koenig @ 2013-04-18 8:06 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
Hi Tobias,
> Is my -f(no-)directives patch okay? Or do you envision something else?
In principle, it is OK; the only question is what the default should be :-)
For OpenMP, we require an option to change the semantics of a program
based on special comments. Currently, we do not do so for directives
which do the same thing. So, what should we do?
Does anybody else have an opinion here? I'm willing to go with the
majority here.
Thomas
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK
2013-04-18 8:06 ` Thomas Koenig
@ 2013-04-18 8:21 ` Tobias Burnus
0 siblings, 0 replies; 10+ messages in thread
From: Tobias Burnus @ 2013-04-18 8:21 UTC (permalink / raw)
To: Thomas Koenig; +Cc: gcc patches, gfortran
Thomas Koenig wrote:
>> Is my -f(no-)directives patch okay? Or do you envision something else?
>
> In principle, it is OK; the only question is what the default should
> be :-)
I am in favor of "on".
> For OpenMP, we require an option to change the semantics of a program
> based on special comments. Currently, we do not do so for directives
> which do the same thing.
Well, I see a difference here: (Nearly) all program using OpenMP work
also as serial program (-fno-openmp). On the other hand, without "!GCC$
attributes" directives (or the C equivalent: "__attribute__((...))"),
the program does not work properly. The attributes are used to be able
to express some feature which is not available in the standard but still
in some way required: stdcall, fastcall, dllimport, dllexport. "unused"
arguments, weak bindings (not yet for Fortran), disabling argument
checking (only Fortran), etc.
Tobias
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2013-04-17 21:34 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-04-10 16:41 [Patch, Fortran] PR39505 - add support for !GCC$ attributes NO_ARG_CHECK Tobias Burnus
2013-04-11 9:41 ` Tobias Burnus
2013-04-12 17:55 ` Tobias Burnus
2013-04-15 7:10 ` *ping* - " Tobias Burnus
2013-04-16 7:05 ` Thomas Koenig
2013-04-16 8:36 ` Tobias Burnus
2013-04-16 8:59 ` Tobias Burnus
2013-04-17 9:03 ` Tobias Burnus
2013-04-18 8:06 ` Thomas Koenig
2013-04-18 8:21 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).