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