Reorganization
[scilab.git] / scilab / modules / io / sci_gateway / fortran / intfile.f
1       subroutine intfile
2 c     interface for builtin file
3 c     Copyright INRIA
4       INCLUDE 'stack.h'
5 c     
6       integer status,access,form,recl,old,new,scratc,unknow
7       integer sequen,direct,forma1,unform
8       integer clo,rew,bak,ope,mode(2)
9       integer top0,tops
10       logical getscalar
11
12       integer iadr,sadr
13 c     
14       data old/857368/,new/2100759/,scratc/1707037/,unknow/1316638/
15       data sequen/1707548/,direct/1774093/,forma1/1775631/
16       data unform/988958/
17       data clo/12/,ope/24/,rew/27/,bak/11/,last/21/,nclas/29/
18 c     
19       iadr(l)=l+l-1
20       sadr(l)=(l/2)+1
21 c     
22
23       tops=top
24       top0=top-rhs+1
25 c
26       lw=lstk(top+1)
27       if(rhs.le.1) then
28 c     .  enquire
29 c
30          if(lhs.gt.5) then
31             call error(41)
32             return
33          endif
34
35 c     .  count opened files
36          n=0
37          nb=0
38          if(rhs.eq.1) then
39             if(.not.getscalar('file', top, top, lr))return
40             iu=stk(lr)
41             top=top-1
42             call getfileinfo(iu,ifa,iswap,ltype,mode,buf,lb,info)
43             if(info.ne.1.and.info.ne.2) n=1
44             nb=lb
45          else
46             i=-1
47  01         i=i+1
48             call getfileinfo(i,ifa,iswap,ltype,mode,buf,lb,info)
49             if(info.eq.1) goto 02
50             if(info.eq.2) goto 01
51             n=n+1
52             nb=nb+lb
53             goto 01
54          endif
55  02      continue
56
57          if(n.eq.0) then
58             err=lstk(top+1)+2*rhs-lstk(bot)
59             if(err.gt.0) then
60                call error(17)
61                return
62             endif
63             do 05 i=1,lhs
64                top=top+1
65                il=iadr(lstk(top))
66                istk(il)=1
67                istk(il+1)=0
68                istk(il+2)=0
69                istk(il+3)=0
70                lstk(top+1)=sadr(il+4)
71  05         continue
72             return
73          endif
74          
75 c     .  allocate lhs variables
76 c
77 c     .  vector of units
78          top=top+1
79          ilu=iadr(lstk(top))
80          lu=sadr(ilu+4)
81          lstk(top+1)=lu+n
82          if(lhs.eq.1) goto 06
83 c     .  vector of types
84          top=top+1
85          ilt=iadr(lstk(top))
86          lt=ilt+5+n
87          lstk(top+1)=sadr(lt+n)
88          if(lhs.eq.2) goto 06
89 c     .  vector of file names
90          top=top+1
91          iln=iadr(lstk(top))
92          ln=iln+5+n
93          lstk(top+1)=sadr(ln+nb)
94          if(lhs.eq.3) goto 06
95 c     .  vector of modes
96          top=top+1
97          ilm=iadr(lstk(top))
98          lm=sadr(ilm+4)
99          lstk(top+1)=lm+n
100          if(lhs.eq.4) goto 06
101 c     .  vector of swap
102          top=top+1
103          ils=iadr(lstk(top))
104          ls=sadr(ils+4)
105          lstk(top+1)=ls+n
106 c
107  06      err=lstk(top+1)-lstk(bot)
108          if(err.gt.0) then
109             call error(17)
110             return
111          endif
112 c     .  create lhs variable headers
113
114 c     .  vector of units
115          istk(ilu)=1
116          istk(ilu+1)=1
117          istk(ilu+2)=n
118          istk(ilu+3)=0
119          if(lhs.eq.1) goto 12
120 c     .  vector of types
121          istk(ilt)=10
122          istk(ilt+1)=1
123          istk(ilt+2)=n
124          istk(ilt+3)=0
125          istk(ilt+4)=1
126          do 10 i=1,n
127             istk(ilt+4+i)=i+1
128  10      continue
129          if(lhs.eq.2) goto 12
130 c     .  vector of names
131          istk(iln)=10
132          istk(iln+1)=1
133          istk(iln+2)=n
134          istk(iln+3)=0
135          istk(iln+4)=1
136          iln=iln+4
137 c
138          if(lhs.eq.3) goto 12
139 c     .  vector of modes
140          istk(ilm)=1
141          istk(ilm+1)=1
142          istk(ilm+2)=n
143          istk(ilm+3)=0
144 c
145          if(lhs.eq.4) goto 12
146 c     .  vector of swap
147          istk(ils)=1
148          istk(ils+1)=1
149          istk(ils+2)=n
150          istk(ils+3)=0
151  12      continue
152
153 c     .  get file infos
154          if(rhs.eq.1) then
155 c     .     unit
156             stk(lu)=iu
157             if(lhs.eq.1) goto 17
158 c     .     type
159             if(ltype.eq.2) then
160                istk(lt)=-12
161             else
162                istk(lt)=-15
163             endif
164             if(lhs.eq.2) goto 17
165 c     .     name
166             call cvstr(lb,istk(ln),buf,0)
167             istk(iln+1)=istk(iln)+lb
168             if(lhs.eq.3) goto 17
169 c     .     mode
170             stk(lm)=mode(1)
171             if(lhs.eq.4) goto 17
172 c     .     swap
173             stk(ls)=iswap
174          else
175             i=-1
176  15         i=i+1
177             call getfileinfo(i,ifa,iswap,ltype,mode,buf,lb,info)
178             if(info.eq.1) goto 17
179             if(info.eq.2) goto 15
180 c     .     unit
181             stk(lu)=i
182             lu=lu+1
183             if(lhs.eq.1) goto 15
184 c     .     type
185             if(ltype.eq.2) then
186                istk(lt)=-12
187             else
188                istk(lt)=-15
189             endif
190             lt=lt+1
191             if(lhs.eq.2) goto 15
192 c     .     name
193             call cvstr(lb,istk(ln),buf,0)
194             ln=ln+lb
195             istk(iln+1)=istk(iln)+lb
196             iln=iln+1
197             if(lhs.eq.3) goto 15
198 c     .     mode
199             stk(lm)=mode(1)
200             lm=lm+1
201             if(lhs.eq.4) goto 15
202 c     .     swap
203             stk(ls)=iswap
204             ls=ls+1
205
206             goto 15
207          endif
208  17      continue
209          return
210       endif
211
212       il=iadr(lstk(top))
213       if(lhs.gt.2) then
214          call error(41)
215          return
216       endif
217
218 c     action
219       il=iadr(lstk(top+1-rhs))
220       if(istk(il).ne.10) then
221          err=1
222          call error(55)
223          return
224       endif      
225       if(istk(il+1)*istk(il+2).ne.1) then
226          err=1
227          call error(36)
228          return
229       endif
230       l=il+5+istk(il+1)*istk(il+2)
231       itype=abs(istk(l))
232 c
233
234       if(itype.eq.ope) then
235 c     
236 c     open
237          if(rhs.gt.6) then
238             call error(39)
239             return
240          endif
241 c     path
242          il=iadr(lstk(top+2-rhs))
243          if(istk(il).ne.10) then
244             err=2
245             call error(55)
246             return
247          endif
248          if(istk(il+1)*istk(il+2).ne.1) then
249             err=2
250             call error(36)
251             return
252          endif
253          l=il+5+istk(il+1)*istk(il+2)
254          mn=istk(il+5)-1
255          buf=' '
256          call cvstr(mn,istk(l),buf,1)
257          rhs=rhs-2
258          status=0
259          access=0
260          form=0
261          recl=0
262          if(rhs.eq.0) goto 145
263          do 143 i=1,rhs
264             il=iadr(lstk(top))
265             if(istk(il).eq.10) then
266                l=il+5+istk(il+1)*istk(il+2)
267                if(istk(il+5)-1.lt.3) then
268                   call error(36)
269                   return
270                endif
271                itype=abs(istk(l))+256*(abs(istk(l+1))+256*abs(istk(l+2))
272      $              )
273                if(itype.eq.new) then
274                   status=0
275                elseif(itype.eq.old) then
276                   status=1
277                elseif(itype.eq.scratc) then
278                   status=2
279                elseif(itype.eq.unknow) then
280                   status=3
281                elseif(itype.eq.sequen) then
282                   access=0
283                elseif(itype.eq.direct) then
284                   access=1
285                elseif(itype.eq.forma1) then
286                   form=0
287                elseif(itype.eq.unform) then
288                   form=1
289                endif
290             elseif(istk(il).eq.1) then
291                recl=int(stk(sadr(il+4)))
292                mode(2)=recl
293             else
294                err=i
295                call error(53)
296                return
297             endif
298             top=top-1
299  143     continue
300  145     mode(1)=status+10*(access+10*(form))
301          lunit=0
302          call clunit(lunit,buf(1:mn),mode)
303          if(err.gt.0) then
304             if(lhs.eq.1) then
305                buf(mn+1:)=' '
306                call error(err)
307                return
308             else
309                top=top-1
310                il=iadr(lstk(top))
311                istk(il)=1
312                istk(il+1)=0
313                istk(il+2)=0
314                istk(il+3)=0
315                l=sadr(il+4)
316                lstk(top+1)=l+1 
317
318                top=top+1
319                il=iadr(lstk(top))
320                istk(il)=1
321                istk(il+1)=1
322                istk(il+2)=1
323                istk(il+3)=0
324                l=sadr(il+4)
325                stk(l)=err
326                lstk(top+1)=l+1
327                err=0
328                return
329             endif
330          endif
331          top=top-1
332          il=iadr(lstk(top))
333          istk(il)=1
334          istk(il+1)=1
335          istk(il+2)=1
336          istk(il+3)=0
337          l=sadr(il+4)
338          stk(l)=dble(lunit)
339          lstk(top+1)=l+1
340          if(lhs.eq.2) then
341             top=top+1
342             il=iadr(lstk(top))
343             istk(il)=1
344             istk(il+1)=1
345             istk(il+2)=1
346             istk(il+3)=0
347             l=sadr(il+4)
348             stk(l)=0.0d0
349             lstk(top+1)=l+1
350          endif
351       elseif(itype.eq.clo) then
352 c     close
353          if(lhs.ne.1) then
354             call error(41)
355             return
356          endif
357          if(rhs.ne.2) then
358             call error(36)
359             return
360          endif
361          il1=iadr(lstk(top))
362          if(istk(il1).ne.1) then
363             err=rhs
364             call error(53)
365             return
366          endif
367          n=istk(il1+1)*istk(il1+2)
368          l=sadr(il1+4)
369
370          top=top-1
371          if(n.gt.0) then
372             mode(1)=0
373             do 151 i=1,n
374                lunit=int(stk(l-1+i))
375                if(lunit.ge.0) then
376                   call clunit(-lunit,buf,mode)
377                endif
378  151        continue
379          endif
380          istk(il)=0
381       elseif(itype.eq.rew) then
382 c     rewind
383          if(lhs.ne.1) then
384             call error(41)
385             return
386          endif
387          if(rhs.ne.2) then
388             call error(36)
389             return
390          endif
391          il1=iadr(lstk(top))
392          if(istk(il1).ne.1) then
393             err=rhs
394             call error(53)
395             return
396          endif
397          lunit=int(stk(sadr(il1+4)))
398          top=top-1
399
400          if(lunit.ge.0) then
401             call getfiletype(lunit,ltype,info)
402             if(info.eq.0) then
403                if(ltype.eq.2) then
404                   call mseek(lunit,0,'set'//char(0),err)
405                else
406                   rewind(lunit)
407                endif
408             endif
409          endif
410          istk(il)=0
411          goto 999
412
413       elseif(itype.eq.bak) then
414 c     backspace
415          if(lhs.ne.1) then
416             call error(41)
417             return
418          endif
419          if(rhs.ne.2) then
420             call error(36)
421             return
422          endif
423          il1=iadr(lstk(top))
424          if(istk(il1).ne.1) then
425             err=rhs
426             call error(53)
427             return
428          endif
429          lunit=int(stk(sadr(il1+4)))
430          top=top-1
431          if(lunit.ge.0) then
432             call getfiletype(lunit,ltype,info)
433             if(info.eq.0) then
434                if(ltype.eq.2) then
435                   err=1
436                   call error(36)
437                   return
438                else
439                   backspace(lunit)
440                endif
441             endif
442          endif
443 c     
444          istk(il)=0
445       elseif(itype.eq.last) then
446 c     last
447          if(lhs.ne.1) then
448             call error(41)
449             return
450          endif
451          if(rhs.ne.2) then
452             call error(36)
453             return
454          endif
455          il1=iadr(lstk(top))
456          if(istk(il1).ne.1) then
457             err=rhs
458             call error(53)
459             return
460          endif
461          lunit=int(stk(sadr(il1+4)))
462          top=top-1
463          if(lunit.ge.0) then
464             call getfiletype(lunit,ltype,info)
465             if(info.eq.0) then
466                if(ltype.eq.2) then
467                   call mseek(lunit,0,'end'//char(0),err)
468                else
469  154              read(lunit,'(a)',err=156,end=155)
470                   go to 154
471  155              backspace(lunit)
472                endif
473             endif
474          endif
475          istk(il)=0
476          return
477  156     call error(49)
478          return
479       else
480 c     incorrect action name
481          err=1
482          call error(36)
483          return
484       endif
485  999  return
486       end
487