+2013-05-21 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/57035
+ * intrinsic.c (do_check): Add contraint check for
+ NO_ARG_CHECK, assumed rank and assumed type.
+ * gfortran.texi (NO_ARG_CHECK): Minor wording change,
+ allow PRESENT intrinsic.
+
2013-05-20 Tobias Burnus <burnus@net-b.de>
PR fortran/48858
@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.
+Additionally, the argument may only be passed to dummy arguments
+with the @code{NO_ARG_CHECK} attribute and as argument to the
+@code{PRESENT} intrinsic function and to @code{C_LOC} 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.
+(@code{TYPE(*)}; recommended) or of type @code{INTEGER}, @code{LOGICAL},
+@code{REAL} or @code{COMPLEX}. 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
do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
{
gfc_expr *a1, *a2, *a3, *a4, *a5;
+ gfc_actual_arglist *a;
if (arg == NULL)
return (*specific->check.f0) ();
+ /* Check TS29113, C407b for assumed type and C535b for assumed-rank,
+ and a likewise check for NO_ARG_CHECK. */
+ for (a = arg; a; a = a->next)
+ {
+ if (!a->expr)
+ continue;
+
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && (a->expr->symtree->n.sym->attr.ext_attr
+ & (1 << EXT_ATTR_NO_ARG_CHECK))
+ && specific->id != GFC_ISYM_C_LOC
+ && specific->id != GFC_ISYM_PRESENT)
+ {
+ gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only "
+ "permitted as argument to the intrinsic functions "
+ "C_LOC and PRESENT", &a->expr->where);
+ return false;
+ }
+ else if (a->expr->ts.type == BT_ASSUMED
+ && specific->id != GFC_ISYM_LBOUND
+ && specific->id != GFC_ISYM_PRESENT
+ && specific->id != GFC_ISYM_RANK
+ && specific->id != GFC_ISYM_SHAPE
+ && specific->id != GFC_ISYM_SIZE
+ && specific->id != GFC_ISYM_UBOUND
+ && specific->id != GFC_ISYM_C_LOC)
+ {
+ gfc_error ("Assumed-type argument at %L is not permitted as actual"
+ " argument to the intrinsic %s", &a->expr->where,
+ gfc_current_intrinsic);
+ return false;
+ }
+ else if (a->expr->ts.type == BT_ASSUMED && a != arg)
+ {
+ gfc_error ("Assumed-type argument at %L is only permitted as "
+ "first actual argument to the intrinsic %s",
+ &a->expr->where, gfc_current_intrinsic);
+ return false;
+ }
+ if (a->expr->rank == -1 && !specific->inquiry)
+ {
+ gfc_error ("Assumed-rank argument at %L is only permitted as actual "
+ "argument to intrinsic inquiry functions",
+ &a->expr->where);
+ return false;
+ }
+ if (a->expr->rank == -1 && arg != a)
+ {
+ gfc_error ("Assumed-rank argument at %L is only permitted as first "
+ "actual argument to the intrinsic inquiry function %s",
+ &a->expr->where, gfc_current_intrinsic);
+ return false;
+ }
+ }
+
a1 = arg->expr;
arg = arg->next;
if (arg == NULL)
+2013-05-21 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/57035
+ * gfortran.dg/assumed_type_5.f90: New.
+ * gfortran.dg/assumed_rank_1.f90: Comment invalid statement.
+ * gfortran.dg/assumed_rank_2.f90: Ditto.
+ * gfortran.dg/assumed_type_3.f90: Update dg-error.
+ * gfortran.dg/no_arg_check_3.f90: Ditto.
+
2013-05-21 Jakub Jelinek <jakub@redhat.com>
PR tree-optimization/57331
subroutine bar(a,b, prsnt)
integer, pointer, optional, intent(in) :: a(..),b(..)
logical, value :: prsnt
- ! The following is not valid, but it goes past the constraint check
- ! Technically, it could be allowed and might be in Fortran 2015:
if (.not. associated(a)) call abort()
if (present(b)) then
- if (.not. associated(a,b)) call abort()
+ ! The following is not valid.
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ ! if (.not. associated(a,b)) call abort()
else
if (.not. associated(a)) call abort()
end if
subroutine bar(a,b, prsnt)
integer, pointer, optional, intent(in) :: a(..),b(..)
logical, value :: prsnt
- ! The following is not valid, but it goes past the constraint check
- ! Technically, it could be allowed and might be in Fortran 2015:
if (.not. associated(a)) call abort()
if (present(b)) then
- if (.not. associated(a,b)) call abort()
+ ! The following is not valid
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ ! if (.not. associated(a,b)) call abort()
else
if (.not. associated(a)) call abort()
end if
subroutine thirteen(x, y)
type(*) :: x
integer :: y(:)
- print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" }
+ print *, ubound(y, dim=x) ! { dg-error "Assumed-type argument at .1. is only permitted as first actual argument to the intrinsic ubound" }
end subroutine thirteen
subroutine fourteen(x)
--- /dev/null
+! { dg-do compile }
+!
+! PR fortran/57035
+!
+!
+
+subroutine assumed_rank (a)
+ use iso_c_binding
+ integer, intent(in), target :: a(..)
+ integer :: c(1:4)
+ type(c_ptr) :: xx
+ c = ubound(c,a) ! { dg-error "Assumed-rank argument at .1. is only permitted as first actual argument to the intrinsic inquiry function ubound" }
+ c = transfer(a,1) ! { dg-error "Assumed-rank argument at .1. is only permitted as actual argument to intrinsic inquiry functions" }
+ xx = c_loc(a)
+end subroutine
+
+subroutine assumed_type (a)
+ use iso_c_binding
+ type(*), intent(in), target :: a
+ integer :: c(1:4)
+ type(c_ptr) :: xx
+ c = ubound(c,a) ! { dg-error "Assumed-type argument at .1. is only permitted as first actual argument to the intrinsic ubound" }
+ c = transfer(a,1) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic transfer" }
+ xx = c_loc(a)
+end subroutine
+
+subroutine no_arg_check (a)
+ use iso_c_binding
+ integer, intent(in), target :: a
+ !gcc$ attributes no_arg_check :: a
+ integer :: c(1:4)
+ type(c_ptr) :: xx
+ c = ubound(c,a) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" }
+ c = transfer(a,1) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" }
+ xx = c_loc(a)
+end subroutine
!GCC$ attributes NO_ARG_CHECK :: x
integer :: x
integer :: y(:)
- print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" }
+ print *, ubound(y, dim=x) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" }
end subroutine thirteen
subroutine fourteen(x)
integer(8) :: ii
procedure() :: proc
- ii = sizeof (x) ! { dg-error "shall not be TYPE\(.\)" }
- ii = c_sizeof (x) ! { dg-error "shall not be TYPE\(.\)" }
- ii = storage_size (x) ! { dg-error "shall not be TYPE\(.\)" }
+ ii = sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic sizeof" }
+ ii = c_sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic c_sizeof" }
+ ii = storage_size (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic storage_size" }
ii = sizeof (y) ! { dg-error "shall not be an assumed-size array" }
ii = c_sizeof (y) ! { dg-error "shall not be an assumed-size array" }
projects / platform / upstream / gcc.git / commitdiff