1!-------------------------------------------------------------- 2! 3!! Basic functionality for reference-counted data structures 4!! For some background, see [here](|page|/page/datastructures/1-buds.html)) 5! 6! This file has to be included after the global declarations 7! for extra functionality, just where a "contains" statement 8! would go 9! 10! Parameter: "TYPE_NAME" has to be set to the name of the type 11!-------------------------------------------------------------- 12 13! Acknowledgements of inspiration from the community: 14! 15! Basic templating via include files as in the FLIBS project 16! by Arjen Markus 17! 18! Implementation of the classic reference-counting paradigm 19! in the PyF95 project. 20 21 PRIVATE 22 23 public :: TYPE_NAME 24 public :: init, delete, assignment(=), refcount, id 25 public :: name 26 public :: same ! same %data address (i.e. if: this1 = this2) 27 public :: initialized ! is allocated 28 29 interface assignment(=) 30 module procedure assign_ 31 end interface 32 33 interface init 34 module procedure init_ 35 end interface 36 37 interface delete 38 module procedure delete_ 39 end interface 40 41 interface refcount 42 module procedure refcount_ 43 end interface 44 45 interface id 46 module procedure id_ 47 end interface 48 49 interface name 50 module procedure name_ 51 end interface 52 53 interface initialized 54 module procedure initialized_ 55 end interface 56 57 interface same 58 module procedure same_ 59 end interface 60 61 62 ! Stand-alone routine which must be provided 63 interface 64 subroutine die(str) 65 character(len=*), intent(in), optional :: str 66 end subroutine die 67 end interface 68 69CONTAINS 70 71! -- Main structural features 72! 73 subroutine init_(this) 74 75 ! Initializes new storage 76 77 type (TYPE_NAME), intent(inout) :: this 78 79 integer :: error 80 81 ! First, remove the current reference 82 call delete(this) 83 84 ! Allocate fresh storage 85 allocate(this%data, stat=error) 86 if (error /= 0) then 87 call die("Error allocating data structure") 88 endif 89 90 ! Set the initial reference count 91 this%data%refCount = 1 92 93 end subroutine init_ 94 95 subroutine delete_(this) 96 97 ! Removes the current reference, possibly 98 ! deallocating storage 99 100 type (TYPE_NAME), intent(inout) :: this 101 102 integer :: error 103! logical, external :: print_debug_object_info 104 105 if (.not. initialized(this) ) return 106 107 this%data%refCount = this%data%refCount - 1 108 109 if (this%data%refCount == 0) then 110 111 ! Safe to delete the data now 112 ! Use the routine provided for this specific 113 ! type to clean up any internal structure 114 115 call delete_Data(this%data) 116 117! if (print_debug_object_info()) then 118! print *, "--> deallocated " // id(this) // " " // trim(this%data%name) 119! endif 120 121 ! Deallocate the currently referenced storage 122 123 deallocate(this%data, stat=error) 124 if (error /= 0) then 125 call die("Error in deallocation") 126 endif 127 endif 128 129 ! This is important to use the correct initialized functions 130 nullify(this%data) 131 132 end subroutine delete_ 133 134 135 subroutine assign_(this, other) 136 137 ! Make "this" reference the same data as "other". 138 ! No copying of data is involved, simply an increment of the 139 ! reference counter. 140 141 ! IMPORTANT NOTE: Assignment must take the form of a subroutine, and 142 ! not of a function, since the "inout" intent is essential. One has 143 ! to clean up "this" before making it point to the same place as 144 ! "other". In a function, the intrinsic "out" intent for "this" 145 ! will destroy any prior information. 146 147 type (TYPE_NAME), intent(inout) :: this 148 type (TYPE_NAME), intent(in) :: other 149 150 if (.not. initialized(other) ) then 151 call die("Assignment of non-initialized object in " // trim(mod_name)) 152 endif 153 154 ! Delete to remove the current reference of "this" 155 156 call delete(this) 157 158 ! Establish the new reference and increment the reference counter. 159 160 this%data => other%data 161 this%data%refcount = this%data%refcount+1 162 163 end subroutine assign_ 164 165 pure function initialized_(this) result(init) 166 type(TYPE_NAME), intent(in) :: this 167 logical :: init 168 ! If it is not associated, it can not contain any data 169 init = associated(this%data) 170 end function initialized_ 171 172 pure function same_(this1,this2) result(same) 173 type(TYPE_NAME), intent(in) :: this1, this2 174 logical :: same 175 ! If they are not both initialized they can not be the same 176 same = initialized(this1) .and. initialized(this2) 177 if ( .not. same ) return 178 same = associated(this1%data, target=this2%data) 179 end function same_ 180 181 function refcount_(this) result(count) 182 type(TYPE_NAME), intent(in) :: this 183 integer :: count 184 count = this%data%refCount 185 end function refcount_ 186 187 ! The remaining procedures are not essential 188 189 function id_(this) result(str) 190 type(TYPE_NAME), intent(in) :: this 191 character(len=36) :: str 192 str = this%data%id 193 end function id_ 194 195 function name_(this) result(str) 196 type(TYPE_NAME), intent(in) :: this 197 character(len=len_trim(this%data%name)) :: str 198 str = trim(this%data%name) 199 end function name_ 200 201 subroutine tag_new_object(this) 202 type(TYPE_NAME), intent(inout) :: this 203 204! logical, external :: print_debug_object_info 205! external :: get_uuid 206 207! call get_uuid(this%data%id) 208! if (print_debug_object_info()) then 209! print *, '--> allocated ' // trim(this%data%name) // " " // id(this) 210! endif 211 212 end subroutine tag_new_object 213 214!============================================================= 215