gcc/testsuite/gfortran.dg/no_arg_check_3.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=single" }
   3 !
   4 ! PR fortran/39505
   5 !
   6 ! Test NO_ARG_CHECK
   7 ! Copied from assumed_type_2.f90
   8 !
   9 subroutine one(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
  10 !GCC$ attributes NO_ARG_CHECK :: a
  11   integer, value :: a
  12 end subroutine one
  13
  14 subroutine two(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
  15 !GCC$ attributes NO_ARG_CHECK :: a
  16   integer, pointer :: a
  17 end subroutine two
  18
  19 subroutine three(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
  20 !GCC$ attributes NO_ARG_CHECK :: a
  21   integer, allocatable :: a
  22 end subroutine three
  23
  24 subroutine four(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
  25 !GCC$ attributes NO_ARG_CHECK :: a
  26   integer  :: a[*]
  27 end subroutine four
  28
  29 subroutine five(a) ! { dg-error "with NO_ARG_CHECK attribute shall either be a scalar or an assumed-size array" }
  30 !GCC$ attributes NO_ARG_CHECK :: a
  31   integer :: a(3)
  32 end subroutine five
  33
  34 subroutine six()
  35 !GCC$ attributes NO_ARG_CHECK :: nodum ! { dg-error "with NO_ARG_CHECK attribute shall be a dummy argument" }
  36   integer :: nodum
  37 end subroutine six
  38
  39 subroutine seven(y)
  40 !GCC$ attributes NO_ARG_CHECK :: y
  41  integer :: y(*)
  42  call a7(y(3:5)) ! { dg-error "with NO_ARG_CHECK attribute shall not have a subobject reference" }
  43 contains
  44  subroutine a7(x)
  45 !GCC$ attributes NO_ARG_CHECK :: x
  46    integer :: x(*)
  47  end subroutine a7
  48 end subroutine seven
  49
  50 subroutine nine()
  51   interface one
  52     subroutine okay(x)
  53 !GCC$ attributes NO_ARG_CHECK :: x
  54       integer :: x
  55     end subroutine okay
  56   end interface
  57   interface two
  58     subroutine ambig1(x)  ! { dg-error "Ambiguous interfaces" }
  59 !GCC$ attributes NO_ARG_CHECK :: x
  60       integer :: x
  61     end subroutine ambig1
  62     subroutine ambig2(x)  ! { dg-error "Ambiguous interfaces" }
  63 !GCC$ attributes NO_ARG_CHECK :: x
  64       integer :: x(*)
  65     end subroutine ambig2
  66   end interface
  67   interface three
  68     subroutine ambig3(x)   ! { dg-error "Ambiguous interfaces" }
  69 !GCC$ attributes NO_ARG_CHECK :: x
  70       integer :: x
  71     end subroutine ambig3
  72     subroutine ambig4(x)   ! { dg-error "Ambiguous interfaces" }
  73       integer :: x
  74     end subroutine ambig4
  75   end interface
  76 end subroutine nine
  77
  78 subroutine ten()
  79  interface
  80    subroutine bar()
  81    end subroutine
  82  end interface
  83  type t
  84  contains
  85    procedure, nopass :: proc => bar
  86  end type
  87  type(t) :: xx
  88  call sub(xx) ! { dg-error "is of derived type with type-bound or FINAL procedures" }
  89 contains
  90   subroutine sub(a)
  91 !GCC$ attributes NO_ARG_CHECK :: a
  92     integer :: a
  93   end subroutine sub
  94 end subroutine ten
  95
  96 subroutine eleven(x)
  97   external bar
  98 !GCC$ attributes NO_ARG_CHECK :: x
  99   integer :: x
 100   call bar(x) ! { dg-error "Assumed-type argument x at .1. requires an explicit interface" }
 101 end subroutine eleven
 102
 103 subroutine twelf(x)
 104 !GCC$ attributes NO_ARG_CHECK :: x
 105   integer :: x
 106   call bar(x) ! { dg-error "Type mismatch in argument" }
 107 contains
 108   subroutine bar(x)
 109     integer :: x
 110   end subroutine bar
 111 end subroutine twelf
 112
 113 subroutine thirteen(x, y)
 114 !GCC$ attributes NO_ARG_CHECK :: x
 115   integer :: x
 116   integer :: y(:)
 117   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" }
 118 end subroutine thirteen
 119
 120 subroutine fourteen(x)
 121 !GCC$ attributes NO_ARG_CHECK :: x
 122   integer :: x
 123   x = x ! { dg-error "with NO_ARG_CHECK attribute may only be used as actual argument" }
 124 end subroutine fourteen