gcc/testsuite/gfortran.dg/argument_checking_13.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/34796
   4 !
   5 ! Argument checks:
   6 ! - elements of deferred-shape arrays (= non-dummies) are allowed
   7 !   as the memory is contiguous
   8 ! - while assumed-shape arrays (= dummy arguments) and pointers are
   9 !   not (strides can make them non-contiguous)
  10 ! and
  11 ! - if the memory is non-contigous, character arguments have as
  12 !   storage size only the size of the element itself, check for
  13 !   too short actual arguments.
  14 !
  15 subroutine test1(assumed_sh_dummy, pointer_dummy)
  16 implicit none
  17 interface
  18   subroutine rlv1(y)
  19     real   :: y(3)
  20   end subroutine rlv1
  21 end interface
  22
  23 real          :: assumed_sh_dummy(:,:,:)
  24 real, pointer :: pointer_dummy(:,:,:)
  25
  26 real, allocatable :: deferred(:,:,:)
  27 real, pointer     :: ptr(:,:,:)
  28 call rlv1(deferred(1,1,1))         ! valid since contiguous
  29 call rlv1(ptr(1,1,1))              ! { dg-error "Element of assumed-shaped or pointer array" }
  30 call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
  31 call rlv1(pointer_dummy(1,1,1))    ! { dg-error "Element of assumed-shaped or pointer array" }
  32 end
  33
  34 subroutine test2(assumed_sh_dummy, pointer_dummy)
  35 implicit none
  36 interface
  37   subroutine rlv2(y)
  38     character   :: y(3)
  39   end subroutine rlv2
  40 end interface
  41
  42 character(3)          :: assumed_sh_dummy(:,:,:)
  43 character(3), pointer :: pointer_dummy(:,:,:)
  44
  45 character(3), allocatable :: deferred(:,:,:)
  46 character(3), pointer     :: ptr(:,:,:)
  47 call rlv2(deferred(1,1,1))         ! Valid since contiguous
  48 call rlv2(ptr(1,1,1))              ! Valid F2003
  49 call rlv2(assumed_sh_dummy(1,1,1)) ! Valid F2003
  50 call rlv2(pointer_dummy(1,1,1))    ! Valid F2003
  51
  52 ! The following is kind of ok: The memory access it valid
  53 ! We warn nonetheless as the result is not what is intented
  54 ! and also formally wrong.
  55 ! Using (1:string_length) would be ok.
  56 call rlv2(ptr(1,1,1)(1:1))              ! { dg-warning "contains too few elements" }
  57 call rlv2(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-warning "contains too few elements" }
  58 call rlv2(pointer_dummy(1,1,1)(1:3))    ! Valid F2003
  59 end
  60
  61 subroutine test3(assumed_sh_dummy, pointer_dummy)
  62 implicit none
  63 interface
  64   subroutine rlv3(y)
  65     character   :: y(3)
  66   end subroutine rlv3
  67 end interface
  68
  69 character(2)          :: assumed_sh_dummy(:,:,:)
  70 character(2), pointer :: pointer_dummy(:,:,:)
  71
  72 character(2), allocatable :: deferred(:,:,:)
  73 character(2), pointer     :: ptr(:,:,:)
  74 call rlv3(deferred(1,1,1))         ! Valid since contiguous
  75 call rlv3(ptr(1,1,1))              ! { dg-warning "contains too few elements" }
  76 call rlv3(assumed_sh_dummy(1,1,1)) ! { dg-warning "contains too few elements" }
  77 call rlv3(pointer_dummy(1,1,1))    ! { dg-warning "contains too few elements" }
  78
  79 call rlv3(deferred(1,1,1)(1:2))         ! Valid since contiguous
  80 call rlv3(ptr(1,1,1)(1:2))              ! { dg-warning "contains too few elements" }
  81 call rlv3(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-warning "contains too few elements" }
  82 call rlv3(pointer_dummy(1,1,1)(1:2))    ! { dg-warning "contains too few elements" }
  83 end