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