|
111
|
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-error "contains too few elements" }
|
|
|
57 call rlv2(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "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-error "contains too few elements" }
|
|
|
76 call rlv3(assumed_sh_dummy(1,1,1)) ! { dg-error "contains too few elements" }
|
|
|
77 call rlv3(pointer_dummy(1,1,1)) ! { dg-error "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-error "contains too few elements" }
|
|
|
81 call rlv3(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "contains too few elements" }
|
|
|
82 call rlv3(pointer_dummy(1,1,1)(1:2)) ! { dg-error "contains too few elements" }
|
|
|
83 end
|
