/
m_common_elstack.F90
236 lines (181 loc) · 5.96 KB
/
m_common_elstack.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
module m_common_elstack
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str
use m_common_error, only: FoX_fatal
use m_common_content_model, only: content_particle_t, checkCP, &
elementContentCP, emptyContentCP, checkCPToEnd
implicit none
private
! Element stack during parsing. Keeps track of element names
! and optionally tracks validity of content model
! Initial stack size:
integer, parameter :: STACK_SIZE_INIT = 10
! Multiplier when stack is exceeded:
real, parameter :: STACK_SIZE_MULT = 1.5
type :: elstack_item
character, dimension(:), pointer :: name => null()
type(content_particle_t), pointer :: cp => null()
end type elstack_item
type :: elstack_t
private
integer :: n_items
type(elstack_item), pointer, dimension(:) :: stack => null()
end type elstack_t
public :: elstack_t
public :: push_elstack, pop_elstack, init_elstack, destroy_elstack, reset_elstack, print_elstack
public :: get_top_elstack, is_empty
public :: checkContentModel
public :: checkContentModelToEnd
public :: elementContent
public :: emptyContent
public :: len
interface len
module procedure number_of_items
end interface
interface is_empty
module procedure is_empty_elstack
end interface
contains
subroutine init_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
! We go from 0 (and initialize the 0th string to "")
! in order that we can safely check the top of an
! empty stack
allocate(elstack%stack(0:STACK_SIZE_INIT))
elstack%n_items = 0
allocate(elstack%stack(0)%name(0))
end subroutine init_elstack
subroutine destroy_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
integer :: i
do i = 0, elstack % n_items
deallocate(elstack%stack(i)%name)
enddo
deallocate(elstack%stack)
end subroutine destroy_elstack
subroutine reset_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
call destroy_elstack(elstack)
call init_elstack(elstack)
end subroutine reset_elstack
subroutine resize_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
type(elstack_item), dimension(0:ubound(elstack%stack,1)) :: temp
integer :: i, s
s = ubound(elstack%stack, 1)
do i = 0, s
temp(i)%name => elstack%stack(i)%name
temp(i)%cp => elstack%stack(i)%cp
enddo
deallocate(elstack%stack)
allocate(elstack%stack(0:nint(s*STACK_SIZE_MULT)))
do i = 0, s
elstack%stack(i)%name => temp(i)%name
elstack%stack(i)%cp => temp(i)%cp
enddo
end subroutine resize_elstack
pure function is_empty_elstack(elstack) result(answer)
type(elstack_t), intent(in) :: elstack
logical :: answer
answer = (elstack%n_items == 0)
end function is_empty_elstack
function number_of_items(elstack) result(n)
type(elstack_t), intent(in) :: elstack
integer :: n
n = elstack%n_items
end function number_of_items
subroutine push_elstack(elstack, name, cp)
type(elstack_t), intent(inout) :: elstack
character(len=*), intent(in) :: name
type(content_particle_t), pointer, optional :: cp
integer :: n
n = elstack%n_items
n = n + 1
if (n == size(elstack%stack)) then
call resize_elstack(elstack)
endif
allocate(elstack%stack(n)%name(len(name)))
elstack%stack(n)%name = vs_str(name)
if (present(cp)) elstack%stack(n)%cp => cp
elstack%n_items = n
end subroutine push_elstack
function pop_elstack(elstack) result(item)
type(elstack_t), intent(inout) :: elstack
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
integer :: n
n = elstack%n_items
if (n == 0) then
call FoX_fatal("Element stack empty")
endif
item = str_vs(elstack%stack(n)%name)
deallocate(elstack%stack(n)%name)
elstack%n_items = n - 1
end function pop_elstack
pure function get_top_elstack(elstack) result(item)
! Get the top element of the stack, *without popping it*.
type(elstack_t), intent(in) :: elstack
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
integer :: n
n = elstack%n_items
if (n==0) then
item = ""
else
item = str_vs(elstack%stack(n)%name)
endif
end function get_top_elstack
function checkContentModel(elstack, name) result(p)
type(elstack_t), intent(inout) :: elstack
character(len=*), intent(in) :: name
logical :: p
type(content_particle_t), pointer :: cp
integer :: n
n = elstack%n_items
if (n==0) then
p = .true.
else
cp => elstack%stack(n)%cp
p = checkCP(cp, name)
elstack%stack(n)%cp => cp
endif
end function checkContentModel
function checkContentModelToEnd(elstack) result(p)
type(elstack_t), intent(inout) :: elstack
logical :: p
type(content_particle_t), pointer :: cp
integer :: n
n = elstack%n_items
cp => elstack%stack(n)%cp
p = checkCPToEnd(cp)
end function checkContentModelToEnd
function elementContent(elstack) result(p)
type(elstack_t), intent(in) :: elstack
logical :: p
integer :: n
n = elstack%n_items
if (n==0) then
p = .false.
else
p = elementContentCP(elstack%stack(n)%cp)
endif
end function elementContent
function emptyContent(elstack) result(p)
type(elstack_t), intent(in) :: elstack
logical :: p
integer :: n
n = elstack%n_items
if (n==0) then
p = .false.
else
p = emptyContentCP(elstack%stack(n)%cp)
endif
end function emptyContent
subroutine print_elstack(elstack,unit)
type(elstack_t), intent(in) :: elstack
integer, intent(in) :: unit
integer :: i
do i = elstack%n_items, 1, -1
write(unit=unit,fmt=*) elstack%stack(i)%name
enddo
end subroutine print_elstack
#endif
end module m_common_elstack