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