1! Copyright (c) 2010, NVIDIA CORPORATION. All rights reserved. 2! 3! Licensed under the Apache License, Version 2.0 (the "License"); 4! you may not use this file except in compliance with the License. 5! You may obtain a copy of the License at 6! 7! http://www.apache.org/licenses/LICENSE-2.0 8! 9! Unless required by applicable law or agreed to in writing, software 10! distributed under the License is distributed on an "AS IS" BASIS, 11! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12! See the License for the specific language governing permissions and 13! limitations under the License. 14! 15 16module shape_mod 17 18type shape 19 integer :: color 20 logical :: filled 21 integer :: x 22 integer :: y 23contains 24 procedure :: write => write_shape 25 procedure :: draw => draw_shape 26 procedure :: func => shape_func 27end type shape 28 29type, EXTENDS ( shape ) :: rectangle 30 integer :: the_length 31 integer :: the_width 32contains 33 procedure,pass(this) :: write => write_rec 34 procedure :: draw => draw_rectangle 35 procedure :: func => rec_func 36end type rectangle 37 38type, extends (rectangle) :: square 39contains 40 procedure :: draw => draw_sq 41 procedure :: write => write_sq 42 procedure,pass(this) :: write2 => write_sq2 43 procedure :: write3 => write_sq3 44 procedure :: func => sq_func 45 46end type square 47contains 48 49 subroutine write_shape(this,results,i) 50 class (shape) :: this 51 logical results(:) 52 integer i 53 type(shape) :: sh 54 !results(i) = same_type_as(sh,this) 55 select type(this) 56 type is (shape) 57 results(i) = .true. 58 class default 59 results(i) = .false. 60 end select 61 end subroutine write_shape 62 63 subroutine write_rec(this,results,i) 64 class (rectangle) :: this 65 logical results(:) 66 integer i 67 type(shape) :: sh 68 !results(i) = same_type_as(sh,this) 69 select type(this) 70 type is (rectangle) 71 results(i) = .true. 72 class default 73 results(i) = .false. 74 end select 75 end subroutine write_rec 76 77 subroutine draw_shape(this,results,i) 78 class (shape) :: this 79 logical results(:) 80 integer i 81 print *, 'draw shape!' 82 results(i) = .true. 83 end subroutine draw_shape 84 85 subroutine draw_rectangle(this,results,i) 86 class (rectangle) :: this 87 logical results(:) 88 integer i 89 type(rectangle) :: rec 90 !results(i) = extends_type_of(this,rec) 91 select type(this) 92 class is (rectangle) 93 results(i) = .true. 94 class default 95 results(i) = .false. 96 end select 97 end subroutine draw_rectangle 98 99 subroutine write_sq(this,results,i) 100 class (square) :: this 101 logical results(:) 102 integer i 103 type(rectangle) :: rec 104 !results(i) = extends_type_of(this,rec) 105 select type(this) 106 class is (square) 107 results(i) = .true. 108 class default 109 results(i) = .false. 110 end select 111 end subroutine write_sq 112 113 subroutine draw_sq(this,results,i) 114 class (square) :: this 115 logical results(:) 116 integer i 117 type(rectangle) :: rec 118 !results(i) = extends_type_of(this,rec) 119 select type(this) 120 class is (square) 121 results(i) = .true. 122 class default 123 results(i) = .false. 124 end select 125 end subroutine draw_sq 126 127 subroutine write_sq2(i,this,results) 128 class (square) :: this 129 integer i 130 logical results(:) 131 type(rectangle) :: rec 132 !results(i) = extends_type_of(this,rec) 133 select type(this) 134 class is (square) 135 results(i) = .true. 136 class default 137 results(i) = .false. 138 end select 139 end subroutine write_sq2 140 141 logical function write_sq3(this) 142 class (square) :: this 143 type(rectangle) :: rec 144 !write_sq3 = extends_type_of(this,rec) 145 select type(this) 146 class is (square) 147 write_sq3 = .true. 148 class default 149 write_sq3 = .false. 150 end select 151 end function 152 153 logical function sq_func(this) 154 class (square) :: this 155 sq_func = .false. 156 end function 157 158 logical function rec_func(this) 159 class (rectangle) :: this 160 type(square) :: sq 161 select type(this) 162 type is (rectangle) 163 rec_func = .true. 164 class default 165 rec_func = .false. 166 end select 167 168 end function 169 170 logical function shape_func(this) 171 class (shape) :: this 172 shape_func = .false. 173 end function 174 175end module shape_mod 176 177program p 178USE CHECK_MOD 179use shape_mod 180 181logical l 182logical results(6) 183logical expect(6) 184class(square),allocatable :: s 185class(shape),allocatable :: sh 186type(rectangle) :: r 187type(square),allocatable :: sq 188 189expect = .true. 190results = .false. 191 192allocate(s) 193call s%write2(1,results) 194call s%write(results,2) 195call s%draw(results,3) 196 197allocate(sq) 198results(5) = sq%write3() 199 200allocate(sh) 201call write_shape(sh,results,4) 202 203results(6) = s%rectangle%func() 204 205call check(results,expect,6) 206 207 208end 209 210 211