bug 5588 fix
[scilab.git] / scilab / modules / data_structures / src / fortran / insertfield.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) ????-2008 - INRIA
3 c
4 c This file must be used under the terms of the CeCILL.
5 c This source file is licensed as described in the file COPYING, which
6 c you should have received as part of this distribution.  The terms
7 c are also available at
8 c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
9       subroutine insertfield(ilfrom,volfrom,iltos,ind,nind,lrn,lw,info)
10 c     insert a field (from) in a sublist "to"  of a list "tos"
11 c
12 c     ilfrom points on the first entry of the "from" data structure in
13 c     istk. data structure is contained in istk(ilfrom:ilfrom-1+2*volfrom)
14
15 c     ilto points on the first entry of the "to" data structure in istk
16 c     iltos points on the first entry of the "tos" data structure in istk
17 c     ind(1:nind) is the path of to in tos
18 c
19 c     is the position of the result,if info<>0
20 c     info
21 c        if 0 list has been updated "in place"
22 c        if 1 list needs to be stored
23       include 'stack.h'
24 c
25       integer volfrom,voltos,volto,dvol,ind(*)
26       integer typfrom,typto
27
28       integer subptr
29       external subptr
30
31       integer iadr,sadr
32 c
33       iadr(l)=l+l-1
34       sadr(l)=(l/2)+1
35 c
36       if(istk(ilfrom).lt.0) ilfrom=iadr(istk(ilfrom+1))
37       typfrom=istk(ilfrom)
38       lfromt=sadr(ilfrom)
39 c
40       if(istk(iltos).lt.0) iltos=iadr(istk(iltos+1))
41       mtos=istk(iltos+1)
42 c     voltos is the memory used to store all fields of tos
43       voltos=istk(iltos+2+mtos)-1
44 c     ltos points on the first entry of the "tos" fields in stk
45       ltos=sadr(iltos+mtos+3)
46 c
47 c     get pointer on the inner-most modified sublist
48       n=ind(nind)
49       il=iltos
50       if(istk(il).lt.0) il=iadr(istk(il+1))
51       mi=istk(il+1)
52       if(nind.gt.1) then
53          do 05 k1=1,nind-1
54             il=iadr(sadr(il+3+mi)+istk(il+1+ind(k1))-1)
55             if(istk(il).lt.0) il=iadr(istk(il+1))
56             mi=istk(il+1)
57  05      continue
58       endif
59 c
60       ilto=il
61       typto=istk(ilto)
62       mto=istk(ilto+1)
63 c     volto is the memory used to store all fields of to
64       volto=istk(ilto+2+mto)-1
65       lto=sadr(ilto+mto+3)
66 c
67
68       if(n.eq.0) then
69 c     .  add a new element "on the left"
70          if(typfrom.eq.0) then
71 c     .     null element : nothing added, "to" variable is returned as it
72             info=0
73             return
74          endif
75
76 c     .  get memory to install the resulting list (May be improved to avoid
77 c     .  copy when "to" list is at the top of the stack).
78          info=1
79          lrn=lw
80          iln=iadr(lrn)
81          lw1=sadr(iadr(lrn)+3+(mtos+1))+voltos+volfrom
82          err=lw1-lstk(bot)
83          if(err.gt.0) then
84             call error(17)
85             return
86          endif
87
88          if(iltos.ne.ilto) then
89 c     .     copy the beginning of "tos" up to the beginning of the modified sub-list.
90             ltod=sadr(iltos)
91             ltto=sadr(ilto)
92             call unsfdcopy(ltto-ltod,stk(ltod),1,stk(lrn),1)
93 c     .     lrn points to the beginning of the new entry
94             lrn=lrn+ltto-ltod
95          endif
96
97 c     .  create new sublist:
98 c     .  header
99          ilr=iadr(lrn)
100          istk(ilr)=typto
101          istk(ilr+1)=mto+1
102          istk(ilr+2)=1
103          istk(ilr+3)=1+volfrom
104          do 10 i=1,mto
105             istk(ilr+3+i)=istk(ilr+2+i)+istk(ilto+2+i)-istk(ilto+1+i)
106  10      continue
107 c     .  added field
108          lr=sadr(ilr+4+mto)
109          call unsfdcopy(volfrom,stk(lfromt),1,stk(lr),1)
110 c     .  copy old sublist fields
111          lr=lr+volfrom
112          call unsfdcopy(volto,stk(lto),1,stk(lr),1)
113          lr=lr+volto
114          dvol=(lr-lrn)-(lto+volto-sadr(ilto))
115
116 c     .  update new data structure pointers recursively
117          call updptr(iln,ind,nind-1,dvol)
118 c     .  copy the rest of data structure
119          if(nind.gt.1) then
120             ind(nind-1)=ind(nind-1)+1
121             ltto=sadr(subptr(iltos,ind,nind-1))
122             call unsfdcopy(ltos+voltos-ltto,stk(ltto),1,stk(lr),1)
123             lr=lr+ltos+voltos-ltto
124          endif
125 c     .  put the result in place
126          lrn=sadr(iln)
127 c         call unsfdcopy(lr-lrn,stk(lrn),1,stk(lstk(top)),1)
128 c         lstk(top+1)=lstk(top)+lr-lrn
129          info=1
130       elseif(n.gt.mto) then
131 c     .  add a new elements "on the right" of the sublist
132          if(typfrom.eq.0) then
133 c     .     from is a null element : nothing added
134             info=0
135             return
136          endif
137
138 c     .  get memory to install the resulting list (May be improved to avoid
139 c     .  copy when "to" list is at the top of the stack).
140          lrn=lw
141          iln=iadr(lrn)
142          lw1=sadr(iln+3+mtos+n-mto)+voltos+volfrom
143          info=1
144          err=lw1-lstk(bot)
145          if(err.gt.0) then
146             call error(17)
147             return
148          endif
149
150          if(ilto.ne.iltos) then
151 c     .     copy the beginning of "tos" up to the beginning of the modified sub-list.
152             ltod=sadr(iltos)
153             ltto=sadr(ilto)
154             err=lrn+ltto-ltod-lstk(bot)
155             if(err.gt.0) then
156                call error(17)
157                return
158             endif
159             call unsfdcopy(ltto-ltod,stk(ltod),1,stk(lrn),1)
160 c     .     lrn points to the beginning of the new entry
161             lrn=lrn+ltto-ltod
162          endif
163
164 c     .  copy the beginning of the sublist header
165          ilr=iadr(lrn)
166          lr=sadr(ilr+3+n)
167          err=lr+volto+volfrom-lstk(bot)
168          if(err.gt.0) then
169             call error(17)
170             return
171          endif
172          call icopy(mto+3,istk(ilto),1,istk(ilr),1)
173 c     .  update fields number
174          istk(ilr+1)=n
175 c     .  set pointers on added fields (some can be empty)
176          call iset(n-mto,istk(ilr+mto+2),istk(ilr+mto+3),1)
177          istk(ilr+n+2)=istk(ilr+n+1)+volfrom
178
179 c     .  copy old fields values
180          call unsfdcopy(volto,stk(lto),1,stk(lr),1)
181          lr=lr+volto
182 c     .  copy added field value
183          call unsfdcopy(volfrom,stk(lfromt),1,stk(lr),1)
184          lr=lr+volfrom
185 c
186          dvol=(lr-lrn)-(lto+volto-sadr(ilto))
187 c     .  update new data structure pointers recursively
188          call updptr(iln,ind,nind-1,dvol)
189 c     .  copy the rest of data structure
190 c???         ind(nind-1)=ind(nind-1)+n-mto
191          ind(nind-1)=ind(nind-1)+1
192          ltto=sadr(subptr(iltos,ind,nind-1))
193          if(ltos+voltos-ltto.gt.0) then
194             err=(lr+ltos+voltos-ltto)-lstk(bot)
195             if(err.gt.0) then
196                call error(17)
197                return
198             endif
199             call unsfdcopy(ltos+voltos-ltto,stk(ltto),1,stk(lr),1)
200             lr=lr+ltos+voltos-ltto
201          endif
202
203 c     .  store result  ????
204          lrn=sadr(iln)
205          return
206       else
207 c     .  replace or delete an intermediate field of the sublist
208          if(typfrom.ne.0) then
209 c     .     replace the specified field
210             if (istk(ilto+2+n)-istk(ilto+1+n).eq.volfrom) then
211 c     .        old and new fields have the same size,
212 c     .        field is  replaced in place
213                lr=lto+istk(ilto+1+n)-1
214                call unsfdcopy(volfrom,stk(lfromt),1,stk(lr),1)
215                info=0
216                return
217             else
218 c     .        get memory to install the resulting list
219 c     .        (May be improved to avoid copy when "to" list is at the
220 c     .        top of the stack).
221                iln=iadr(lw)
222                lrn=lw
223
224                info=1
225 c     .        dvol the size variation of modified sub-element (-old+new)
226                dvol=-(istk(ilto+2+n)-istk(ilto+1+n))+volfrom
227                lw1=sadr(iln+3+mtos)+voltos+dvol
228                err=lw1-lstk(bot)
229                if(err.gt.0) then
230                   call error(17)
231                   return
232                endif
233 c     .        lr,ilr points to the entry to be replaced
234                lr=lto+istk(ilto+1+n)-1
235                ilr=iadr(lr)
236 c     .        change list type if necessary (tlist and mlist are
237 c     .        changed to simple list)
238 c     .        copy the beginning of "to" up to field to be replaced
239                ltod=sadr(iltos)
240                call unsfdcopy(lr-ltod,stk(ltod),1,stk(lrn),1)
241                if(nind.eq.1.and.n.eq.1.and.typfrom.ne.10) istk(iln)=15
242
243 c     .        lrn points to the beginning of the new field
244                lrn=lrn+lr-ltod
245 c     .        set new value of the entry
246                call unsfdcopy(volfrom,stk(lfromt),1,stk(lrn),1)
247                lrn=lrn+volfrom
248 c     .        copy last field of "to"
249 c     .        iltol points to the end of "to" data structure
250                ltol=ltos+voltos
251                lto=lto+istk(ilto+2+n)-1
252                call unsfdcopy(ltol-lto,stk(lto),1,stk(lrn),1)
253                lrn=lrn+ltol-lto
254 c     .        update new data structure pointers recursively
255                call  updptr(iln,ind,nind,dvol)
256 c     .        store result
257                lrn=lw
258                return
259             endif
260          else
261 c     .     suppress the specified entry
262 c     .     get memory to install the resulting list
263 c     .     (May be improved to avoid copy when "to" list is at the
264 c     .     top of the stack).
265             lrn=lw
266             info=1
267             iln=iadr(lrn)
268             lw1=sadr(iln+3+mtos)+voltos-(istk(ilto+2+n)-istk(ilto+1+n))
269             err=lw1-lstk(bot)
270             if(err.gt.0) then
271                call error(17)
272                return
273             endif
274 c     .     if necessary,copy the "to" list data structure up to the
275 c     .     beginning of the modified sub-list
276             if(ilto.ne.iltos) then
277 c     .     copy the beginning of "to" up to  the modified sub-list
278                ltod=sadr(iltos)
279                ltto=sadr(ilto)
280                call unsfdcopy(ltto-ltod,stk(ltod),1,stk(lrn),1)
281 c     .        lrn points to the beginning of the new entry
282                lrn=lrn+ltto-ltod
283             endif
284 c     .     update sub_list
285 c     .     ---------------
286             il=iadr(lrn)
287             lfrom=lto-1+istk(ilto+2+n)
288 c     .     copy variable header and n-1 first pointers
289             call icopy(2+n,istk(ilto),1,istk(il),1)
290             if(n.eq.1) istk(il)=15
291 c     .     reduce list size
292             istk(il+1)=istk(il+1)-1
293 c     .     modify last pointers
294             do 20 i=n,mto
295                istk(il+i+2)=istk(il+i+1)+istk(ilto+i+3)-istk(ilto+i+2)
296  20         continue
297 c     .     copy first n-1 elements
298             l=sadr(il+2+mto)
299             call unsfdcopy(istk(il+n+1)-1,stk(lto),1,stk(l),1)
300             l=l+istk(il+n+1)-1
301 c     .     dvol the size variation of modified sub-element (-old+new)
302             dvol=(l-sadr(il))-(lfrom-sadr(ilto))
303 c     .     copy last elements
304             call unsfdcopy(istk(il+1+mto)-istk(il+1+n),stk(lfrom),1,
305      $           stk(l),1)
306             l=l+istk(il+1+mto)-istk(il+1+n)
307 c     .     update new data structure pointers recursively
308             call updptr(iln,ind,nind-1,dvol)
309 c     .     copy the rest of data structure
310             if(nind.gt.1) then
311                ind(nind-1)=ind(nind-1)+1
312                ltto=sadr(subptr(iltos,ind,nind-1))
313                call unsfdcopy(ltos+voltos-ltto,stk(ltto),1,stk(l),1)
314                l=l+ltos+voltos-ltto
315             endif
316 c     .     store result
317             lrn=sadr(iln)
318             info=1
319             return
320          endif
321       endif
322       return
323       end
324