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