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
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
|
subroutine insertfield(ilfrom,volfrom,iltos,ind,nind,lrn,lw,info)
c insert a field (from) in a sublist "to" of a list "tos"
c
c ilfrom points on the first entry of the "from" data structure in
c istk. data structure is contained in istk(ilfrom:ilfrom-1+2*volfrom)
c ilto points on the first entry of the "to" data structure in istk
c iltos points on the first entry of the "tos" data structure in istk
c ind(1:nind) is the path of to in tos
c
c is the position of the result,if info<>0
c info
c if 0 list has been updated "in place"
c if 1 list needs to be stored
include '../stack.h'
c
integer volfrom,voltos,volto,dvol,ind(*)
integer typfrom,typto
Integer subptr
external subptr
integer iadr,sadr
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
if(istk(ilfrom).lt.0) ilfrom=iadr(istk(ilfrom+1))
typfrom=istk(ilfrom)
lfromt=sadr(ilfrom)
c
if(istk(iltos).lt.0) iltos=iadr(istk(iltos+1))
mtos=istk(iltos+1)
c voltos is the memory used to store all fields of tos
voltos=istk(iltos+2+mtos)-1
c ltos points on the first entry of the "tos" fields in stk
ltos=sadr(iltos+mtos+3)
c
c get pointer on the inner-most modified sublist
n=ind(nind)
il=iltos
if(istk(il).lt.0) il=iadr(istk(il+1))
mi=istk(il+1)
if(nind.gt.1) then
do 05 k1=1,nind-1
il=iadr(sadr(il+3+mi)+istk(il+1+ind(k1))-1)
if(istk(il).lt.0) il=iadr(istk(il+1))
mi=istk(il+1)
05 continue
endif
c
ilto=il
typto=istk(ilto)
mto=istk(ilto+1)
c volto is the memory used to store all fields of to
volto=istk(ilto+2+mto)-1
lto=sadr(ilto+mto+3)
c
if(n.eq.0) then
c . add a new element "on the left"
if(typfrom.eq.0) then
c . null element : nothing added, "to" variable is returned as it
info=0
return
endif
c . get memory to install the resulting list (May be improved to avoid
c . copy when "to" list is at the top of the stack).
info=1
lrn=lw
iln=iadr(lrn)
lw1=sadr(iadr(lrn)+3+(mtos+1))+voltos+volfrom
err=lw1-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
if(iltos.ne.ilto) then
c . copy the beginning of "tos" up to the beginning of the modified sub-list.
ltod=sadr(iltos)
ltto=sadr(ilto)
call unsfdcopy(ltto-ltod,stk(ltod),1,stk(lrn),1)
c . lrn points to the beginning of the new entry
lrn=lrn+ltto-ltod
endif
c . create new sublist:
c . header
ilr=iadr(lrn)
istk(ilr)=typto
istk(ilr+1)=mto+1
istk(ilr+2)=1
istk(ilr+3)=1+volfrom
do 10 i=1,mto
istk(ilr+3+i)=istk(ilr+2+i)+istk(ilto+2+i)-istk(ilto+1+i)
10 continue
c . added field
lr=sadr(ilr+4+mto)
call unsfdcopy(volfrom,stk(lfromt),1,stk(lr),1)
c . copy old sublist fields
lr=lr+volfrom
call unsfdcopy(volto,stk(lto),1,stk(lr),1)
lr=lr+volto
dvol=(lr-lrn)-(lto+volto-sadr(ilto))
c . update new data structure pointers recursively
call updptr(iln,ind,nind-1,dvol)
c . copy the rest of data structure
if(nind.gt.1) then
ind(nind-1)=ind(nind-1)+1
ltto=sadr(subptr(iltos,ind,nind-1))
call unsfdcopy(ltos+voltos-ltto,stk(ltto),1,stk(lr),1)
lr=lr+ltos+voltos-ltto
endif
c . put the result in place
lrn=sadr(iln)
c call unsfdcopy(lr-lrn,stk(lrn),1,stk(lstk(top)),1)
c lstk(top+1)=lstk(top)+lr-lrn
info=1
elseif(n.gt.mto) then
c . add a new elements "on the right" of the sublist
if(typfrom.eq.0) then
c . from is a null element : nothing added
info=0
return
endif
c . get memory to install the resulting list (May be improved to avoid
c . copy when "to" list is at the top of the stack).
lrn=lw
iln=iadr(lrn)
lw1=sadr(iln+3+mtos+n-mto)+voltos+volfrom
info=1
err=lw1-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
if(ilto.ne.iltos) then
c . copy the beginning of "tos" up to the beginning of the modified sub-list.
ltod=sadr(iltos)
ltto=sadr(ilto)
err=lrn+ltto-ltod-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
call unsfdcopy(ltto-ltod,stk(ltod),1,stk(lrn),1)
c . lrn points to the beginning of the new entry
lrn=lrn+ltto-ltod
endif
c . copy the beginning of the sublist header
ilr=iadr(lrn)
lr=sadr(ilr+3+n)
err=lr+volto+volfrom-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
call icopy(mto+3,istk(ilto),1,istk(ilr),1)
c . update fields number
istk(ilr+1)=n
c . set pointers on added fields (some can be empty)
call iset(n-mto,istk(ilr+mto+2),istk(ilr+mto+3),1)
istk(ilr+n+2)=istk(ilr+n+1)+volfrom
c . copy old fields values
call unsfdcopy(volto,stk(lto),1,stk(lr),1)
lr=lr+volto
c . copy added field value
call unsfdcopy(volfrom,stk(lfromt),1,stk(lr),1)
lr=lr+volfrom
c
dvol=(lr-lrn)-(lto+volto-sadr(ilto))
c . update new data structure pointers recursively
call updptr(iln,ind,nind-1,dvol)
c . copy the rest of data structure
c??? ind(nind-1)=ind(nind-1)+n-mto
ind(nind-1)=ind(nind-1)+1
ltto=sadr(subptr(iltos,ind,nind-1))
if(ltos+voltos-ltto.gt.0) then
err=(lr+ltos+voltos-ltto)-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
call unsfdcopy(ltos+voltos-ltto,stk(ltto),1,stk(lr),1)
lr=lr+ltos+voltos-ltto
endif
c . store result ????
lrn=sadr(iln)
return
else
c . replace or delete an intermediate field of the sublist
if(typfrom.ne.0) then
c . replace the specified field
if (istk(ilto+2+n)-istk(ilto+1+n).eq.volfrom) then
c . old and new fields have the same size,
c . field is replaced in place
lr=lto+istk(ilto+1+n)-1
call unsfdcopy(volfrom,stk(lfromt),1,stk(lr),1)
info=0
return
else
c . get memory to install the resulting list
c . (May be improved to avoid copy when "to" list is at the
c . top of the stack).
iln=iadr(lw)
lrn=lw
info=1
c . dvol the size variation of modified sub-element (-old+new)
dvol=-(istk(ilto+2+n)-istk(ilto+1+n))+volfrom
lw1=sadr(iln+3+mtos)+voltos+dvol
err=lw1-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
c . lr,ilr points to the entry to be replaced
lr=lto+istk(ilto+1+n)-1
ilr=iadr(lr)
c . change list type if necessary (tlist and mlist are
c . changed to simple list)
c . copy the beginning of "to" up to field to be replaced
ltod=sadr(iltos)
call unsfdcopy(lr-ltod,stk(ltod),1,stk(lrn),1)
if(nind.eq.1.and.n.eq.1.and.typfrom.ne.10) istk(iln)=15
c . lrn points to the beginning of the new field
lrn=lrn+lr-ltod
c . set new value of the entry
call unsfdcopy(volfrom,stk(lfromt),1,stk(lrn),1)
lrn=lrn+volfrom
c . copy last field of "to"
c . iltol points to the end of "to" data structure
ltol=ltos+voltos
lto=lto+istk(ilto+2+n)-1
call unsfdcopy(ltol-lto,stk(lto),1,stk(lrn),1)
lrn=lrn+ltol-lto
c . update new data structure pointers recursively
call updptr(iln,ind,nind,dvol)
c . store result
lrn=lw
return
endif
else
c . suppress the specified entry
c . get memory to install the resulting list
c . (May be improved to avoid copy when "to" list is at the
c . top of the stack).
lrn=lw
info=1
iln=iadr(lrn)
lw1=sadr(iln+3+mtos)+voltos-(istk(ilto+2+n)-istk(ilto+1+n))
err=lw1-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
c . if necessary,copy the "to" list data structure up to the
c . beginning of the modified sub-list
if(ilto.ne.iltos) then
c . copy the beginning of "to" up to the modified sub-list
ltod=sadr(iltos)
ltto=sadr(ilto)
call unsfdcopy(ltto-ltod,stk(ltod),1,stk(lrn),1)
c . lrn points to the beginning of the new entry
lrn=lrn+ltto-ltod
endif
c . update sub_list
c . ---------------
il=iadr(lrn)
lfrom=lto-1+istk(ilto+2+n)
c . copy variable header and n-1 first pointers
call icopy(2+n,istk(ilto),1,istk(il),1)
if(n.eq.1) istk(il)=15
c . reduce list size
istk(il+1)=istk(il+1)-1
c . modify last pointers
do 20 i=n,mto
istk(il+i+2)=istk(il+i+1)+istk(ilto+i+3)-istk(ilto+i+2)
20 continue
c . copy first n-1 elements
l=sadr(il+2+mto)
call unsfdcopy(istk(il+n+1)-1,stk(lto),1,stk(l),1)
l=l+istk(il+n+1)-1
c . dvol the size variation of modified sub-element (-old+new)
dvol=(l-sadr(il))-(lfrom-sadr(ilto))
c . copy last elements
call unsfdcopy(istk(il+1+mto)-istk(il+1+n),stk(lfrom),1,
$ stk(l),1)
l=l+istk(il+1+mto)-istk(il+1+n)
c . update new data structure pointers recursively
call updptr(iln,ind,nind-1,dvol)
c . copy the rest of data structure
if(nind.gt.1) then
ind(nind-1)=ind(nind-1)+1
ltto=sadr(subptr(iltos,ind,nind-1))
call unsfdcopy(ltos+voltos-ltto,stk(ltto),1,stk(l),1)
l=l+ltos+voltos-ltto
endif
c . store result
lrn=sadr(iln)
info=1
return
endif
endif
return
end
subroutine updptr(ilt,ind,nind,dvol)
c!purpose
c update new data structure pointers recursively for nested lists
c!parameters
c ilt : pointer to the beginning of the list
c ind : vector of indexes giving modified entry path.
c nind: size of the path
c dvol: difference of the old and new sizes of the modified entry
c!
integer ind(*),dvol
integer iadr,sadr
include '../stack.h'
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
il=ilt
if(nind.le.0) return
c
do 20 k=1,nind
c . m : sub-list size
m=istk(il+1)
mi=ind(k)
c . update pointers to entries following the mi sub list entry
do 10 i=mi,m
istk(il+i+2)=istk(il+i+2)+dvol
10 continue
c . il pointer to ind(k) sub-list entry
il=iadr(sadr(il+3+m)+istk(il+1+mi)-1)
20 continue
end
integer function subptr(ilt,ind,nind)
c !purpose
c get pointer to an entry of a nested list
c !parameters
c ilt : pointer to the beginning of the list
c ind : vector of indexes giving modified entry path.
c nind: size of the path
c !
integer ind(nind)
integer iadr,sadr
include '../stack.h'
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
il=ilt
if(nind.le.0) goto 30
c
do 20 k=1,nind
c . m : sub-list size
m=istk(il+1)
c . il pointer to ind(k) sub-list entry
il=iadr(sadr(il+3+m)+istk(il+1+ind(k))-1)
20 continue
30 subptr=il
end
|
