bug 5588 fix
[scilab.git] / scilab / modules / data_structures / src / fortran / intl_e.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 intl_e()
10 c =============================================================
11 c     extraction pour les list tlist, mlist
12 c =============================================================
13 c
14 c     Copyright INRIA
15       include 'stack.h'
16 c
17 c
18       integer rhs1,vol1,vol2,vol
19       integer top1,top2
20
21       integer strpos
22       external strpos
23       logical ptover
24       integer iadr,sadr
25 c
26 c
27       iadr(l)=l+l-1
28       sadr(l)=(l/2)+1
29 c
30       icall=0
31 c
32       if(rstk(pt).eq.403) goto 45
33       if(rstk(pt).eq.405) goto 35
34       if(rstk(pt).eq.404) goto 36
35
36
37       rhs1=rhs
38       top0=top
39       fun=0
40       if(rhs.gt.2) then
41          fin=-fin
42          return
43       endif
44
45       if(rhs.le.0) then
46          call error(39)
47          return
48       endif
49       icount=0
50 c     arg2(arg1)
51 c     ==========
52
53 c     get arg2
54  10   continue
55       lw=lstk(top+1)
56 c
57       top2=top
58 c     get arg1
59       top=top-1
60       top1=top
61       il1=iadr(lstk(top))
62       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
63
64       if(istk(il1).eq.15.and.istk(il1+1).eq.0) then
65 c     .  arg2(list())  -->arg2
66          il2=iadr(lstk(top2))
67          if(istk(il2).lt.0) top2=istk(il2+2)
68          call unsfdcopy(lstk(top2+1)-lstk(top2),stk(lstk(top2)),1,
69      &        stk(lstk(top)),1)
70          lstk(top+1)=lstk(top)+lstk(top2+1)-lstk(top2)
71          return
72       endif
73
74 c
75       ilind=iadr(lw)
76
77       if(istk(il1).ne.15) then
78          lw=lw+1
79          m1=1
80       else
81          m1=istk(il1+1)
82          lw=sadr(ilind+m1)
83       endif
84 c     go ahead along the path
85       call followpath(top1,top2,il1ir,vol1,il2ir,vol2,istk(ilind),
86      $     icount,info,lw,.false.)
87       if(err.gt.0) return
88       if(vol2.eq.0) then
89 c     empty field found
90          err=istk(ilind-1+icount)
91          call error(117)
92          return
93       endif
94       il1i=il1ir
95       if(istk(il1i).lt.0) il1i=iadr(istk(il1i+1))
96       il2i=il2ir
97       if(istk(il2i).lt.0) il2i=iadr(istk(il2i+1))
98       if(info.eq.2.or.info.eq.4) then
99 c     .  syntax is arg2(...)(i,j,..)(...)
100 c     .  matrix index (i,..) syntax
101          lstk(top+2)=lw
102          if (istk(il1i).eq.15) then
103 c     .     more than one index
104 c     .     transform index list(i,j,...) in the list in sequence of variables
105 c     .     at the top of the stack
106             m1i=istk(il1i+1)
107             ll1=sadr(il1i+m1i+3)
108             top=top2+1
109             call unsfdcopy(istk(il1i+m1i+2)-1,stk(ll1),1,
110      $           stk(lstk(top)),1)
111             do 16 k1=1,m1i
112                lstk(top+1)=lstk(top)+istk(il1i+2+k1)-istk(il1i+1+k1)
113                top=top+1
114  16         continue
115             top=top-1
116             rhs=1+m1i
117             m2i=istk(il2i+1)
118          else
119 c     .     a matrix  index
120             if(m1.gt.icount.and.info.eq.4) then
121 c     .        arg2(...)(i,j,..)(...)
122                if(istk(il2i).ne.9) then
123 c     .            too many indices in index list
124                    call error(21)
125                    return
126                 endif
127             endif
128 c     .     arg2(...)(i,j,..) a matrix single index,
129 c     .     use standard extraction to finish the job
130
131 c     .     copy index at the top of the stack
132             top=top2
133             call copyvar(il1ir,vol1)
134             rhs=2
135          endif
136          goto 30
137       elseif(info.eq.3) then
138 c     .  current list index is not a single index (multiple extraction)
139          if(icount.ne.m1) then
140 c     .     only final index handled
141             call error(43)
142             return
143          endif
144          if(istk(il1i).eq.10) then
145             if(istk(il2i).ne.16.and.istk(il2i).ne.17) then
146                call error(21)
147                return
148             endif
149 c     .  named indexes
150             ilfn=iadr(sadr(il2i+istk(il2i+1)+3))
151             nn=istk(ilfn+1)*istk(ilfn+2)
152             ilptr=ilfn+5
153             lfn=ilfn+5+nn
154             ili=iadr(lw)
155             lw=sadr(ili+nn)
156             nind=istk(il1i+1)*istk(il1i+2)
157             do 20 k=1,nind
158                nname=istk(il1i+4+k)-istk(il1i+3+k)
159                ilname=il1i+4+nind+istk(il1i+3+k)
160 c     .        look for corresponding index if any
161                ipos=strpos(istk(ilptr),nn-1,istk(lfn),istk(ilname),
162      $              nname)
163                if(ipos.le.0) then
164 c     .           no such name in the field names
165                   if(icount.eq.1.and.m1.eq.1) then
166 c     .              syntax is arg2('xxx')
167                      fin=-fin
168                      top=top2
169                      rhs1=rhs
170                      return
171                   else
172 c     .              syntax is arg2(...)('xxx')(...)
173 c     .              set the index
174                      top=top2
175                      call copyvar(il1ir,vol1)
176                      rhs=2
177                      goto 30
178                   endif
179                else
180                   istk(ili+k-1)=ipos+1
181                endif
182  20         continue
183             call extractfields(il2i,istk(ili),nind,lw)
184          else
185             m2i=istk(il2i+1)
186             call indxg(il1i,m2i,ili,n,mx,lw,10)
187             call extractfields(il2i,istk(ili),n,lw)
188          endif
189          return
190       elseif(info.eq.5) then
191 c     .  end of arg1 list (index list) reached
192 c     .  copy the designed sublist at the top of the stack
193          top=top-1
194          if (rstk(pt-1).eq.314.and.
195      $        (istk(il2ir).eq.11.or.istk(il2ir).eq.13)) then
196             call createref(il2ir,0,vol2)
197          else
198             call copyvar(il2ir,vol2)
199          endif
200          return
201       elseif(info.eq.6) then
202 c     .  index is out of bounds
203          call error(21)
204          return
205       elseif(info.eq.1) then
206 c     .  current index is a name which is not an explicit field name
207
208          if(icount.eq.1.and.m1.eq.1) then
209 c     .     syntax is arg2.xxx
210             fin=-fin
211             top=top2
212             rhs1=rhs
213             return
214          else
215 c     .     syntax is arg2(...).xxx(...)
216 c     .     set the index
217             top=top2
218             call copyvar(il1ir,vol1)
219             rhs=2
220             goto 30
221          endif
222       endif
223
224
225  30   continue
226 c     escape from standard list algorithm to handle  special cases:
227 c     (matrix/vector extraction, method..)
228
229       if(istk(il2i).ge.15.and.istk(il2i).le.17) goto 40
230 c
231 c     standard matrix extraction
232       call createref(il2i,0,vol2)
233 c
234       fin=3
235 c     back to allops for  standard extraction
236       if (ptover(1,psiz)) return
237       icall=4
238       ids(1,pt)=icount
239       ids(2,pt)=m1
240       ids(4,pt)=lhs
241
242       rstk(pt)=405
243 c     *call* allops
244       return
245  35   continue
246       icall=0
247
248       if(err1.ne.0) then
249          pt=pt-1
250          return
251       endif
252       icount=ids(1,pt)
253       m1=ids(2,pt)
254       lhs=ids(4,pt)
255       pt=pt-1
256       if (m1.le.icount) then
257 c     .  nothing more to do here but to move results at its correct location
258          top=top-2-lhs
259          do ii=1,lhs
260             top=top+1
261             vol=lstk(top+3)-lstk(top+2)
262             call unsfdcopy(vol,stk(lstk(top+2)),1,stk(lstk(top)),1)
263             lstk(top+1)=lstk(top)+vol
264          enddo
265          fin=0
266          return
267       endif
268
269 c     m1 > icount handle, ... case
270 c     finish extraction using overloading
271
272 c     build new index list using the remaining entries of the
273 c     original index list
274       ilind=iadr(lstk(top-2))
275       if(istk(ilind).lt.0) ilind=iadr(istk(ilind+1))
276       nlist=istk(ilind+1)
277       ll=sadr(ilind+3+nlist)
278       if(m1-icount.eq.1) then
279          il1i=iadr(ll+istk(ilind+1+icount+1)-1)
280          if (istk(il1i).ne.15) then
281             vol=istk(ilind+2+icount+1)-istk(ilind+1+icount+1)
282             call copyvar(il1i,vol)
283             rhs=2
284          else
285 c     .     transform index list(i,j,...) in the list in sequence of variables
286 c     .     at the top of the stack
287             m1i=istk(il1i+1)
288             ll1=sadr(il1i+m1i+3)
289             call unsfdcopy(istk(il1i+m1i+2)-1,stk(ll1),1,
290      $           stk(lstk(top+1)),1)
291             do  k1=1,m1i
292                top=top+1
293                lstk(top+1)=lstk(top)+istk(il1i+2+k1)-istk(il1i+1+k1)
294             enddo
295             rhs=1+m1i
296             m2i=istk(il2i+1)
297          endif
298       else
299          do i=1,m1-icount
300             ilindi=iadr(ll+istk(ilind+1+icount+i)-1)
301             vol=istk(ilind+2+icount+i)-istk(ilind+1+icount+i)
302             call copyvar(ilindi,vol)
303          enddo
304          if(m1-icount.gt.1) call mklist(m1-icount)
305          rhs=2
306       endif
307 c     create a reference on the handle
308       call createref1(top-rhs+1)
309       if (ptover(1,psiz)) return
310       fun=0
311       fin=3
312       icall=4
313       rstk(pt)=404
314 c     *call* allops
315       return
316
317  36   continue
318       pt=pt-1
319 c     move results at its correct location
320       vol=lstk(top+1)-lstk(top)
321       call unsfdcopy(vol,stk(lstk(top)),1,stk(lstk(top-3)),1)
322       top=top-3
323       lstk(top+1)=lstk(top)+vol
324       fin=0
325       return
326
327
328  40   continue
329 c     list mlist or tlist coded matrix extraction or other method
330 c     .  form the sublist
331       call copyvar(il2i,vol2)
332       if (ptover(1,psiz)) return
333       ids(1,pt)=icount
334       ids(2,pt)=m1
335       ids(4,pt)=lhs
336 c     only last index may select many lhs elements
337       if (icount.ne.m1) lhs=1
338       fun=0
339       fin=-fin
340       rstk(pt)=403
341 c     *call* macro or matfns
342       return
343
344  45   continue
345 c     restore context
346       if(err1.ne.0) then
347          pt=pt-1
348          return
349       endif
350       icount=ids(1,pt)
351       m1=ids(2,pt)
352       lhs=ids(4,pt)
353       fin=3
354       pt=pt-1
355       if(icount.eq.m1) then
356 c     .  put the result at the top of the stack and return
357          vol=lstk(top+1)-lstk(top-lhs+1)
358          im=lstk(top-lhs+1)-lstk(top-lhs-1)
359         call unsfdcopy(vol,stk(lstk(top-lhs+1)),1,
360      $        stk(lstk(top-lhs-1)),1)
361          top=top-2
362          do 46 k=1,lhs
363             lstk(top-lhs+k+1)=lstk(top-lhs+k+3)-im
364  46      continue
365          return
366       else
367 c     .  move result ajust after the index
368          ll2=lstk(top+1)-lstk(top)
369          call unsfdcopy(ll2,stk(lstk(top)),1,stk(lstk(top-1)),1)
370          lstk(top)=lstk(top-1)+ll2
371          top=top-1
372 c     .  goto back to the standard list algorithm
373          goto 10
374       endif
375 c
376       end
377