bug 5588 fix
[scilab.git] / scilab / modules / data_structures / src / fortran / followpath.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 followpath(indtop,listtop,ilindi,voli,ilp,voll,ind,
10      $     count,info,lwork,job)
11 c =============================================================
12 c     given
13 c     - a path stored in a "linear" index list ind stored in the
14 c     variable number indtop
15 c     and
16 c     - a list L begining at position stored in the
17 c     variable number listtop
18
19 c     - a current pointer on index list entries count
20
21 c     returns:
22 c     - the pointer ilp on the deapest sublist of L on the path indtop
23 c       available just by following the list structure of L.
24 c       i.e. ilp is the pointer on the sublist of L pointed to by
25 c       the path indtop(1:count)
26 c     - the vector of numerical indexes corresponding to indtop(1:count)
27
28 c     - voll (in stk worlds) of the designed sublist,
29 c      and the size (in stk worlds) voli of the designed subindex
30 c
31 c     lw is a pointer on the beginning of the free area in stk
32 c     info
33 c         1 : unknown named field
34 c         2 : current index is a matrix index of an mlist
35 c         3 : current index is not a single number
36 c         4 : current index points to a leaf of the  L list
37 c         5 : end of index list reached
38 c         6 : current index is 0 or greater than current sublist # of
39 c             fields
40 c     job
41 c     if job is true and end of index list is reached, the last index is
42 c     a name and the parent of the deapest object is a tlist or an mlist
43 c     the procedure returns the pointer and path of the parent instead
44 c     of the object itself (null insertion).
45
46 c =============================================================
47 c
48       include 'stack.h'
49 c
50       logical job
51       integer indtop,listtop,ind(*)
52       integer typi,count,oldcount,voll,voli
53
54       integer strpos
55       external strpos
56       integer iadr,sadr
57 c
58       iadr(l)=l+l-1
59       sadr(l)=(l/2)+1
60 c
61       oldcount=count
62 c
63       ilind=iadr(lstk(indtop))
64       if(istk(ilind).lt.0) then
65          itop=istk(ilind+2)
66          voli=istk(ilind+3)
67          ilind=iadr(istk(ilind+1))
68       else
69          itop=indtop
70          voli=lstk(itop+1)-lstk(itop)
71       endif
72 c
73       illist=iadr(lstk(listtop))
74       if(istk(ilind).ne.15) then
75 c     .  special case if ind is not a list
76          nlist=1
77          count=1
78          ilindi=ilind
79          ilindir=ilindi
80          illistir=illist
81          if(istk(illist).lt.0) illist=iadr(istk(illist+1))
82          illisti=illist
83          goto 12
84
85       endif
86
87 c     nlist is the size of the path index list
88       nlist=istk(ilind+1)
89       ll=sadr(ilind+3+nlist)
90
91       illistir=illist
92       illisti=illistir
93       if(istk(illisti).lt.0)  illisti=iadr(istk(illisti+1))
94 c
95  10   continue
96 c     next index
97       count=count+1
98 c     move pointer to next entry in index list
99       ilindi=iadr(ll+istk(ilind+1+count)-1)
100       voli=istk(ilind+2+count)-istk(ilind+1+count)
101       ilindir=ilindi
102       if(istk(ilindi).lt.0) ilindi=iadr(istk(ilindi+1))
103 c     extract infos out of the current sublist
104  12   typi=istk(illisti)
105       mi=istk(illisti+1)
106       llisti=sadr(illisti+mi+3)
107       voll=istk(illisti+mi+2)-1+sadr(3+mi)
108 c     go ahead along the path
109
110       if(typi.eq.13.or.typi.eq.11) then
111 c     .  not an extraction but a function call
112          info=2
113          goto 50
114       endif
115
116 c
117       if(istk(ilindi).eq.10) then
118 c     .  current element index is a name
119          if (istk(ilindi+1)*istk(ilindi+2).ne.1) then
120             info=3
121             goto 50
122 c            call error(21)
123 c            return
124          endif
125          ilname=ilindi+6
126          nname=istk(ilindi+5)-istk(ilindi+4)
127 c     .  check if it is an explicit field name
128          if  (typi.ne.16.and.typi.ne.17) then
129 c     .     list with no explicit fields names
130             info=1
131             goto 50
132          else
133 c     .     first field may contain the fields names
134             ilfn=iadr(llisti)
135             nn=istk(ilfn+1)*istk(ilfn+2)
136             ilptr=ilfn+5
137             lfn=ilptr+nn
138 c     .     look for corresponding index if any
139             n=strpos(istk(ilptr),nn-1,istk(lfn),istk(ilname),nname)
140             if(n.le.0) then
141 c     .        no such name in the field names
142                info=1
143                goto 50
144             elseif(job.and.count.eq.nlist) then
145 c     .        null assignment into a named sublist of an tlist or mlist
146                info=1
147                goto 50
148             endif
149             n=n+1
150          endif
151       elseif(istk(ilindi).eq.15) then
152 c     .  current index is a multi dimensional matrix index
153          info=2
154          goto 50
155       else
156 c     .  current index is a standard index
157          if(typi.eq.17.or.(typi.ne.15.and.typi.ne.16)) then
158 c     .     matrix index
159 c     .     can be improved for some special mlist types for which
160 c     .     matrix entry addressing is predefined
161             info=2
162             goto 50
163          endif
164          lw=lwork
165          call indxg(ilindi,mi,ili,nl,mx,lw,10)
166          if(err.gt.0) return
167          if(nl.ne.1) then
168 c     .     index is a vector or []
169             info=3
170             goto 50
171          endif
172          n=istk(ili)
173          if(n.lt.0) then
174             call error(21)
175             return
176          endif
177       endif
178 c     n is the numerical index of the  sublist
179
180       if(n.eq.0.or.n.gt.mi) then
181          if (typi.eq.15.and.count.lt.nlist) then
182 c     .    current index is out of definable list indices and is not the
183 C     .    last of the index list
184             call error(21)
185             return
186          endif
187          ind(count)=n
188          info=6
189          goto 50
190       endif
191
192 c     move pointer to indexed sub-list of L
193       lti=sadr(illisti+3+mi)+istk(illisti+1+n)-1
194       voll=istk(illisti+2+n)-istk(illisti+n+1)
195       illisti=iadr(lti)
196       illistir=illisti
197 c      if(voll.eq.0) then
198 c     .  undefined field found
199 c         info=7
200 c         goto 50
201 c
202 c     endif
203       if(istk(illisti).lt.0) then
204          kk=istk(illisti+2)
205 c         voll=lstk(kk+1)-lstk(kk)
206          illisti=iadr(istk(illisti+1))
207       endif
208 c
209       ind(count)=n
210       if(count+1.gt.nlist) then
211 c     .   end of index list reached
212          info=5
213          goto 50
214       endif
215       if(istk(illisti).ge.15.and.istk(illisti).le.17) goto 10
216
217 c     a leaf of L has been found
218 c     move pointer to next entry in index list
219       count=count+1
220       ilindi=iadr(ll+istk(ilind+1+count)-1)
221       voli=istk(ilind+2+count)-istk(ilind+1+count)
222       ilindir=ilindi
223       if(istk(ilindi).lt.0) ilindi=iadr(istk(ilindi+1))
224       typi=istk(illisti)
225       info=4
226       goto 50
227
228
229  50   continue
230 c     end
231       ilp=illistir
232       ilindi=ilindir
233
234       return
235       end