cec2d16f5bcde1691a93c6672a0662a81b85793c
[scilab.git] / scilab / modules / data_structures / src / fortran / intl_i.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_i
10 c =============================================================
11 c     list insertions arg3(arg1)=arg2
12 c =============================================================
13 c
14 c     Copyright INRIA
15       include 'stack.h'
16 c
17       integer vol1,vol2,vol3,volv
18       integer top3,top2,top1
19
20       logical ptover
21       integer iadr,sadr
22 c
23       iadr(l)=l+l-1
24       sadr(l)=(l/2)+1
25 c
26       if (ddt .eq. 4) then
27          write(buf(1:8),'(2i4)') pt,rstk(pt)
28          call basout(io,wte,' intl_i   pt:'//buf(1:4)//' rstk(pt):'
29      &        //buf(5:8))
30       endif
31 c
32  01   icall=0
33 c     handle recursion
34       if(rstk(pt).eq.406.or.rstk(pt).eq.407) then
35          if(err1.ne.0) then
36             pt=pt-1
37             return
38          endif
39          ilrec=pstk(pt)
40          il1i=istk(ilrec+1)
41          ilind=istk(ilrec+2)
42          icount=istk(ilrec+3)
43          top1=istk(ilrec+4)
44          il3i=istk(ilrec+5)
45          vol3=istk(ilrec+6)
46          goto(35,45,65,55,81,84) istk(ilrec)
47       endif
48       fun=0
49  05   lw=lstk(top+1)
50 c
51       if(rhs.ge.4) then
52 c     .  l(i,j,..)
53          fin=-fin
54          return
55       endif
56       ltop=lstk(top+1)
57
58
59
60 c     get arg3
61       top3=top
62       il3=iadr(lstk(top))
63       if(abs(istk(il3)).lt.14.or.abs(istk(il3)).gt.17) then
64 c     .  arg3 is not a list
65          fin=-fin
66          return
67       endif
68 c
69 c     get arg2
70       top=top-1
71       top2=top
72       il2=iadr(lstk(top))
73       il2r=il2
74       if(istk(il2).lt.0) then
75          vol2=istk(il2+3)
76          il2=iadr(istk(il2+1))
77       else
78          vol2=lstk(top+1)-lstk(top)
79       endif
80 c
81 c     get arg1
82       top=top-1
83       top1=top
84       il1=iadr(lstk(top))
85       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
86       m1=istk(il1+1)
87
88       ilind=iadr(lw)
89 c
90 c     get room for index list
91       if(istk(il1).ne.15) then
92          lw=lw+1
93       else
94          lw=sadr(ilind+m1)
95       endif
96 c     protect index list
97       lstk(top3+1)=lw
98
99 c     go ahead along the path
100       icount=0
101       call followpath(top1,top3,il1ir,vol1,il3ir,vol3,
102      $     istk(ilind),icount,info,lw)
103       if(err.gt.0) return
104       il1i=il1ir
105       if(istk(il1i).lt.0) il1i=iadr(istk(il1i+1))
106       il3i=il3ir
107       if(istk(il3i).lt.0) il3i=iadr(istk(il3i+1))
108
109 c     get room for recursion data
110       ilrec=iadr(lw)
111       lw=sadr(ilrec+7)
112 c     protect recursion data
113       lstk(top3+1)=lw
114
115       istk(ilrec+1)=il1i
116       istk(ilrec+2)=ilind
117       istk(ilrec+3)=icount
118       istk(ilrec+4)=top1
119       istk(ilrec+5)=il3i
120       istk(ilrec+6)=vol3
121
122       if(info.eq.5.or.info.eq.6) then
123 c     .  end of arg1 list reached
124 c     .  replace designed sublist of arg3 by arg2
125          call insertfield(il2,vol2,il3,istk(ilind),icount,lrn,lw,info)
126          if(err.gt.0) return
127          goto 90
128       elseif(info.eq.3) then
129 c     .  current list index is not a single index (multiple insertion)
130          call error(43)
131          return
132       elseif(info.eq.2.or.info.eq.4) then
133 c     .  syntax is arg3(...)(i,j,..)(...)=arg2
134 c     .  matrix index (i,..) syntax
135          if(istk(il3i).eq.17.or.istk(il3i).eq.16) then
136             if(icount.eq.1.and.abs(m1).eq.1) then
137 c     .     syntax is arg3('xxx')=arg2 or  arg3(i)=arg2
138                fin=-2
139                top=top3
140                rhs=3
141                lstk(top+1)=ltop
142                return
143             else
144                goto 40
145             endif
146          elseif(istk(il3i).eq.9) then
147 c     .     handle case
148             goto 80
149          else
150             goto 30
151          endif
152       elseif(info.eq.1) then
153 c     .  current index is a name which is not an explicit field name
154          top=top3
155          rhs=3
156          if(icount.eq.1.and.m1.eq.1) then
157 c         if(icount.eq.1) then
158 c     .     syntax is arg3('xxx')=arg2
159             fin=-2
160             lstk(top+1)=ltop
161             return
162          else
163 c     .     syntax is arg3(...)('xxx')(...)=arg1
164 c     .     set the index
165 c            call copyvar(il1ir,vol1)
166 c            if(err.gt.0) return
167             goto 40
168          endif
169       endif
170
171  30   continue
172 c     last index points on a matrix, use standard matrix insertion
173 c     to finish
174       top=top3
175       if (istk(il1i).eq.15) then
176 c     .  more than one index
177 c     .  transform index list(i,j,...) in the list in sequence of
178 c     .  variables at the top of the stack
179          call lst2vars(il1i,m1i)
180          if(err.gt.0) return
181          rhs=2+m1i
182       else
183 c     .  a matrix single index
184          if(m1.gt.icount) then
185 c     .     arg3(...)(i,j,..)(...)=arg2 :too many indices in index list
186             call error(21)
187             return
188          endif
189 c     .  arg3(...)(i,j,..)=arg2: a matrix single  index
190 c     .  copy it at the top of the stack (may be possible to put a pointer)
191          call copyvar(il1ir,vol1)
192          if(err.gt.0) return
193          rhs=3
194       endif
195
196 c     create a pointer on arg2
197       call createref(il2,top2,vol2)
198       if(err.gt.0) return
199
200 c     create a pointer on the designed matrix (part of arg3)
201       if(vol3.gt.0) then
202          call createref(il3i,0,vol3)
203          if(err.gt.0) return
204       else
205 c     .  the list entry is undefined
206          call defmat
207          if(err.gt.0) return
208       endif
209 c     call allops for  standard insertion
210       fin=2
211       if (ptover(1,psiz)) return
212
213       icall=4
214       istk(ilrec)=1
215
216       pstk(pt)=ilrec
217       rstk(pt)=406
218 c     *call* allops
219       return
220  35   continue
221       ilv=iadr(lstk(top))
222       if(istk(ilv).lt.0.or.istk(il3i).eq.9)  then
223 c     .  matrix or handle has been modified in place, nothing more to be done
224          top=top-3
225          pt=pt-1
226          info=0
227          goto 90
228       else
229 c     .  insert the matrix in main list
230          volv=lstk(top+1)-lstk(top)
231          lw=lstk(top+1)
232          il3=iadr(lstk(top1+2))
233          call insertfield(ilv,volv,il3,istk(ilind),icount-1,lrn,lw,info)
234          if(err.gt.0) return
235          pt=pt-1
236          top=top-3
237          goto 90
238       endif
239
240
241  40   continue
242 c     mlist or tlist coded matrix insertion or other method
243 c     if k+1<n then
244 c     A3(i1)..(ik)(ik+1)(ik+2)..(in)=A2 is decomposed as follow
245 c     .  Temp1=A3(i1)..(ik)
246 c     .  Temp2=Temp1(ik+1)
247 c     .  Temp2(ik+2)..(in)=A2
248 c     .  Temp1(ik+1)=Temp2
249 c     .  A3(i1)..(ik)=Temp1
250 c     else
251 c     A3(i1)..(ik)(ik+1)=A2 is decomposed as follow
252 c     .  Temp1=A3(i1)..(ik)
253 c     .  Temp1(ik+1)=A2
254 c     .  A3(i1)..(ik)=Temp1
255
256 c     top of stack contains [A1, A2, A3]
257       k=icount-1
258       top=top3
259 c     put ik+1 in the stack for further use
260       if (istk(il1i).ne.15) then
261          ill=iadr(sadr(il1+3+m1)+istk(il1+1+(k+1))-1)
262          call copyvar(ill,istk(il1+2+(k+1))-istk(il1+1+(k+1)))
263          if(err.gt.0) return
264          rhs=3
265       else
266 c     .  more than one index
267 c     .  transform index list(i,j,...) in the list in sequence of
268 c     .  variables at the top of the stack
269          call lst2vars(il1i,m1i)
270          if(err.gt.0) return
271          rhs=2+m1i
272       endif
273
274       if(k+1.lt.m1) then
275 c     put (ik+2)..(in) in the stack for further use
276          ll=sadr(il1+3+m1)+istk(il1+1+(k+2))-1
277          volv=istk(il1+2+m1)-istk(il1+3+k)
278          if(k+2.eq.m1) then
279 c     il suffirait de mettre un ptr ici
280             call copyvar(iadr(ll),volv)
281             if(err.gt.0) return
282          else
283             top=top+1
284             ilv=iadr(lstk(top))
285             istk(ilv)=15
286             istk(ilv+1)=m1-(k+1)
287             istk(ilv+2)=1
288             ilv=ilv+2
289             do 42 i=1,m1-(k+1)
290                ilv=ilv+1
291                istk(ilv)=istk(ilv-1)+istk(il1+3+k+i)-istk(il1+2+k+i)
292  42         continue
293             call unsfdcopy(volv,stk(ll),1,stk(sadr(ilv+1)),1)
294             lstk(top+1)=sadr(ilv+1)+volv
295          endif
296       endif
297
298 c     put a pointer to A2 in the stack for further use
299       call createref(il2,top2,vol2)
300       if(err.gt.0) return
301
302       if(k+1.eq.m1) goto 56
303
304 c     Temp2=Temp1(ik+1) extraction:
305 c     - form index ik+1
306       if (istk(il1i).ne.15) then
307          ill=iadr(sadr(il1+3+m1)+istk(il1+1+(k+1))-1)
308          call copyvar(ill,istk(il1+2+(k+1))-istk(il1+1+(k+1)))
309          if(err.gt.0) return
310          rhs=2
311       else
312 c     .  more than one index
313 c     .  transform index list(i,j,...) in the list in sequence of
314 c     .  variables at the top of the stack
315          call lst2vars(il1i,m1i)
316          if(err.gt.0) return
317          rhs=1+m1i
318       endif
319 c     - form the sublist Temp1=A3(i1)..(ik)
320       call copyvar(il3i,vol3)
321       if(err.gt.0) return
322 c     top of stack contains [A1, A2, A3,ik+1, (ik+2)..(in),&a2,ik+1,Temp1]
323 c     - save context for recursion
324       if (ptover(1,psiz)) return
325       pstk(pt)=ilrec
326       istk(ilrec)=2
327       fun=0
328       fin=-5
329       rstk(pt)=406
330 c     *call* allops
331       return
332
333  45   continue
334 c     - top variable  contains Temp2
335
336 c     - restore context
337       lw=lstk(top+1)
338       ltop=lw
339
340       k=icount-1
341       il1=iadr(lstk(top1))
342       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
343       m1=istk(il1+1)
344 c
345 c     re-enter intl_i to realize Temp2(ik+2)..(in)=A2 insertion
346 c     top of stack contains : [A1, A2, A3,ik+1,(ik+2)..(in), &A2, Temp2]
347 c
348 c      pt=pt-1
349 c      if (ptover(1,psiz)) return
350 c     save context for recursion
351       istk(ilrec)=4
352       rstk(pt)=407
353       rhs=3
354       fin=2
355       if (istk(iadr(lstk(top))).eq.1) then
356 c     .  insertion in an empty matrix
357 c     .  get the type of the inserted variable
358          ityp=abs(istk(iadr(lstk(top-1))))
359          if(ityp.ne.15.and.ityp.ne.16.and.ityp.ne.17) then
360 c     .     not a list, *call* allops
361             icall=4
362             return
363          endif
364       endif
365 c     *call* intl_i
366       goto 05
367  55   continue
368 c     top variable  contains new Temp2 value
369       pt=pt-1
370 c     put Temp1=A3(i1)..(ik)  at the top of the stack
371  56   call copyvar(il3i,vol3)
372       if(err.gt.0) return
373 c     top of stack contains : [A1, A2, A3, ik+1,Temp2,Temp1]
374
375 c     return to parser for Temp1(ik+1)=Temp2 insertion
376
377       if (ptover(1,psiz)) return
378 c     save context for recursion
379       pstk(pt)=ilrec
380       istk(ilrec)=3
381       rhs=3
382       if (istk(il1i).eq.15) rhs=2+istk(il1i+1)
383 c     *call* intl_i
384       fun=0
385       fin=-2
386       rstk(pt)=406
387 c     *call* macro or matfns
388       return
389
390  65   continue
391 c     top of stack contains : [A1, A2, A3, Temp1]
392 c     restore context
393       pt=pt-1
394       lw=lstk(top+1)
395       k=icount-1
396       if(k.eq.0) then
397 c     .  temp1 contains the result
398          lrn=lstk(top)
399          top=top-3
400          info=1
401          goto 90
402       endif
403
404 c
405 c     realize insertion A3(i1)..(ik)=Temp1
406       ilv=iadr(lstk(top))
407       volv=lstk(top+1)-lstk(top)
408       il3=iadr(lstk(top1+2))
409       call insertfield(ilv,volv,il3,istk(ilind),icount-1,lrn,lw,info)
410       if(err.gt.0) return
411       top=top-3
412       goto 90
413
414  80   continue
415 c     special case for property assignation of a handle field of a list
416 c     handle case ...h.property...=arg2
417 c     or ...h(i,j).property...=arg2
418 c     change the property value of the entity pointed to by
419 c     handle and does not change the list
420 c
421       top=top3
422 c     case ...h(i,j).property...=arg2 or ...h(i).property...=arg2
423 c     first extract the handle or  sub handle
424
425       if (istk(il1i).eq.10) then
426 c     .  handle case ...h.property...=arg2
427          icount=icount-1
428          call createref(il3i,0,vol3)
429          goto 82
430       elseif (istk(il1i).eq.15) then
431 c     .  sub handle case ...h(i,j).property...=arg2
432          call lst2vars(il1i,m1i)
433          if(err.gt.0) return
434          rhs=1+m1i
435       else
436 c     .  sub handle case ...h(i).property...=arg2
437          call copyvar(il1ir,vol1)
438          rhs=2
439       endif
440 c     create a pointer on the matrix of handle
441       call createref(il3i,0,vol3)
442       fin=3
443 c     back to allops for h(i) or h(i,j)  extraction
444       if (ptover(1,psiz)) return
445       icall=4
446       pstk(pt)=ilrec
447       istk(ilrec)=5
448       rstk(pt)=406
449 c     *call* allops
450       return
451 c
452  81   continue
453
454       icall=0
455       if(err1.ne.0) then
456          pt=pt-1
457          return
458       endif
459       il1=iadr(lstk(top1))
460       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
461       m1=istk(il1+1)
462       top2=top1+1
463       top3=top2+1
464       pt=pt-1
465
466  82   continue
467 c     change handle property
468 c     build new index list using the remaining entries of the
469 c     original index list
470       ll=sadr(il1+3+m1)
471
472       do i=1,m1-icount
473          ilindi=iadr(ll+istk(il1+1+icount+i)-1)
474          volv=istk(il1+2+icount+i)-istk(il1+1+icount+i)
475          call copyvar(ilindi,volv)
476       enddo
477
478       if (m1-icount.gt.1) call mklist(m1-icount)
479       rhs=3
480       call createref1(top2)
481
482       call createref1(top3+1)
483       fun=0
484       fin=-2
485       if (ptover(1,psiz)) return
486       istk(ilrec)=6
487       pstk(pt)=ilrec
488       rstk(pt)=406
489 c     *call* allops
490       return
491
492  84   continue
493       pt=pt-1
494       top3=top1+2
495 c     notify that result has already been stored
496       k1=istk(iadr(lstk(top3))+2)
497       top=top3-3
498       call setref(k1)
499       fin=2
500       return
501
502  90   continue
503
504       if(info.eq.0) then
505 c     .  insertion has been done in place,
506          top3=top1+2
507          if(rstk(pt).eq.407) then
508             il3=iadr(lstk(top3))
509             top=top-1
510             call copyvar(il3,lstk(top3+1)-lstk(top3))
511             if(err.gt.0) return
512             goto 01
513          else
514 c     .  notify that result has already been stored
515             k1=istk(iadr(lstk(top3))+2)
516             top=top-1
517             call setref(k1)
518             fin=2
519             return
520          endif
521       elseif(info.eq.1) then
522 c     .  insertfield has created the result at adress lrn. stored it
523          if(rstk(pt).eq.407) then
524             il1=iadr(lrn)
525             m=istk(il1+1)
526             top=top-1
527             call copyvar(il1,sadr(4+m)+(istk(il1+2+m)-1))
528             if(err.gt.0) return
529             goto 01
530          else
531 c     .  set lstk pointers to the newly created variable
532
533             lt=lstk(top)
534             lstk(top)=lrn
535             il1=iadr(lrn)
536             m=istk(il1+1)
537             lstk(top+1)=sadr(il1+3+m)+(istk(il1+2+m)-1)
538 c     .  store it
539             lhs=1
540 c     .     modification according to those in run.f 22/08/00
541             if(rstk(pt).eq.607) then
542 c     .        called by run
543                call stackp(istk(pstk(pt)),0)
544             elseif(rstk(pt).eq.601) then
545 c     .        called by run version 2.7 and earlier
546                call stackp(istk(pstk(pt)+1),0)
547             else
548 c     .        called by parse
549                call stackp(ids(1,pt),0)
550             endif
551             if(err.gt.0) return
552             lstk(top+1)=lt
553 c     .  notify that result has already been stored
554             call setref(fin)
555             return
556          endif
557
558       endif
559 c
560       return
561
562       end
563
564