mseek parameter offset passed as double for file size more than 2GB.
[scilab.git] / scilab / modules / core / src / fortran / getfun.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
10       subroutine getfun(lunit,nlines,caller)
11 c
12 c ======================================================================
13 c     get a user defined function
14 c ======================================================================
15 c
16       include 'stack.h'
17 c
18       character *(*) caller
19       integer lrecl,id(nsiz),retu(6),icount
20       integer slash,dot,blank,equal,lparen,rparen
21       integer comma,semi,less,great,left,right
22       integer name,cmt,eol
23       integer ssym,schar,slpt(6)
24       integer first,ierr
25       integer iadr,sadr
26       logical isinstring,incomment,isopened
27
28       external getfastcode
29       integer  getfastcode
30 c
31       data slash/48/,dot/51/,blank/40/,equal/50/,lparen/41/,rparen/42/
32       data comma/52/,semi/43/,less/59/,great/60/,left/54/,right/55/
33       data name/1/,cmt/2/,eol/99/,lrecl/4096/
34       data retu/27,14,29,30,27,23/
35
36 c     ennd/14,23,13/
37       iadr(l)=l+l-1
38       sadr(l)=(l/2)+1
39 c
40       lmax=iadr(lstk(bot)-1)
41       isopened=.false.
42 c
43       if(top-rhs+lhs+1.ge.bot) then
44          call error(18)
45          return
46       endif
47 c
48       job=0
49       call icopy(6,lpt,1,slpt,1)
50       ssym=sym
51       schar=char1
52       lpt(1)=lpt(6)+1
53       lpt(5)=lpt(3)
54 c
55       n=1
56       first=1
57       l = lpt(1)
58       if(lunit.eq.0) goto 30
59 c
60 c     get macro deff from file (getf)
61 c     ------------------------
62 c     acquisition d'une ligne du fichier
63       call getfiletype(lunit,ltype,info)
64       if(info.ne.0) goto 90
65       icount=0
66
67  11   buf=' '
68       if(ltype.eq.1) then
69          call basin(ierr,lunit,buf(1:lrecl),'*',0)
70          if(ierr.eq.1) goto 60
71          if(ierr.eq.2) goto 90
72          n=lnblnk(buf(1:lrecl))
73       else
74          call readnextline(lunit,buf,bsiz,n,nr,info)
75          if(info.eq.-1) goto 60
76          n=n-1
77          if (n.ge.1) n=lnblnk(buf(1:n))
78       endif
79
80       l0=l
81       nlines=nlines+1
82       incomment=.false.
83
84       if(n.le.0) then
85          if(first.eq.1) goto 11
86          goto 28
87       endif
88 c     strip blanks at the beginning of the line
89       m=0
90  16   m=m+1
91       if(buf(m:m).eq.' ') goto 16
92 c
93       if(buf(m:m+10).eq.'endfunction'.and.m+11.gt.n) then
94          if(first.eq.0) then
95             istk(l)=blank
96             istk(l+1)=eol
97             l=l+2
98             goto 61
99          endif
100       endif
101       if(buf(m:m+8).eq.'function ') then
102          if(first.eq.1) then
103             j=m+7
104             goto 25
105          else
106             if( ltype.eq.1) then
107                call myback(lunit)
108             else
109                call mseek(lunit,dble(-nr),'cur',ierr)
110             endif
111             nlines=max(0,nlines-1)
112             goto 61
113          endif
114       endif
115 c
116 c     boucle de conversion des caracteres de la ligne
117       j=m-1
118  17   j=j+1
119       if(j.gt.n) goto 27
120 c
121 *     modif Bruno : appel a getfastcode au lieu de la boucle
122       k = getfastcode(buf(j:j))
123       if (k .eq. eol) go to 11
124
125       if(buf(j+1:j+1).ne.buf(j:j)) goto 23
126       if(k.eq.slash) then
127          if(first.eq.1) then
128 c     .     // comments before declaration line
129             if(j.eq.1) goto 11
130             if(buf(1:j-1).eq.' ') goto 11
131 c     .     // comments at the end of declaration line
132             goto 26
133          else
134             if(.not.isinstring(istk(l0),l-l0+1)) incomment=.true.
135          endif
136       endif
137 c
138       if (k.eq.dot.and. .not.incomment) then
139 c     .. found, it is a continuation line only if next chars are dots or
140 c     comments mark (//)
141          jj=j+1
142  22      continue
143          if(jj.ge.n) then
144             icount=icount+1
145             goto 11
146          endif
147          jj=jj+1
148          if(buf(jj:jj).eq.buf(j:j))goto 22
149          if(buf(jj:jj).eq.' '.or.buf(jj:jj).eq.char(9)) goto 22
150          if(buf(jj:jj).eq.'/'.and.buf(jj+1:jj+1).eq.'/') then
151             icount=icount+1
152             goto 11
153          endif
154       endif
155
156  23   continue
157 c     it is not a continuation line
158       if(first.eq.1) goto 24
159       istk(l) = k
160 c
161       l = l + 1
162       if(l.gt.lmax) then
163          ierr=5
164          goto 90
165       endif
166       goto 17
167
168 c     first line
169  24   if(l.gt.lpt(1)) goto 26
170       if(buf(m:m+7).eq.'function') then
171          j=m+6
172       elseif(k.ne.slash .or. buf(m+1:m+1).ne.buf(m:m)) then
173          ierr=4
174          goto 90
175       else
176          goto 11
177       endif
178       j=j+1
179  25   lin(l)=blank
180       l=l+1
181       goto 17
182  26   lin(l)=k
183       l=l+1
184       if(l.gt.lsiz) then
185         ierr=3
186         goto 90
187       endif
188       goto 17
189 c
190 c     line conversion finished
191  27   if(first.eq.1) goto 40
192
193  28   l=l-1
194       if(istk(l).eq.blank) goto 28
195       l=l+1
196       if(l-1.le.l0) then
197          if (istk(l-1).ne.comma.and.
198      +        istk(l-1).ne.semi.and.
199      +        istk(l-1).ne.left) then
200             istk(l)=comma
201             l=l+1
202          endif
203       endif
204       do 29 i=0,icount
205 c     .  add as many end of lines to make line count taking continuation
206 C     .  lines into account
207          istk(l)=eol
208          istk(l+1)=blank
209          l=l+2
210  29   continue
211
212       l=l-1
213       icount=0
214 c
215       goto 11
216
217 c
218 c     get macro deff from stk
219 c     -----------------------
220  30   if(rhs.ne.2) then
221          call error(39)
222          return
223       endif
224 c
225       ilt=iadr(lstk(top))
226       if(istk(ilt).ne.10) then
227          err=2
228          call error(55)
229          return
230       endif
231 c
232       ild=iadr(lstk(top-1))
233       if(istk(ild).ne.10) then
234          err=1
235          call error(55)
236          return
237       endif
238       if(istk(ild+1)*istk(ild+2).ne.1) then
239          err=1
240          call error(89)
241          return
242       endif
243 c
244       il=ild+5
245       n=istk(il)-1
246       do 31 j=1,n
247          lin(l)=istk(il+j)
248          l=l+1
249  31   continue
250       goto 40
251 c
252  33   mn=istk(ilt+1)*istk(ilt+2)
253       ili=ilt+4+mn
254       ilt=ilt+4
255       if (caller.eq.'deff') then
256 c     . add a initial empty line for backward compatiblity
257          istk(l)=blank
258          istk(l+1)=eol
259          l=l+2
260       endif
261       do 35 i=1,mn
262          n=istk(ilt+i)-istk(ilt+i-1)
263          if(n.gt.0) then
264             do 34 j=1,n
265                istk(l)=istk(ili+j)
266                l=l+1
267  34         continue
268          else
269            istk(l)=blank
270            l=l+1
271          endif
272          istk(l)=eol
273          l=l+1
274          ili=ili+n
275  35   continue
276       if (caller.eq.'deff') then
277 c     . add a final empty line for backward compatiblity
278          istk(l)=blank
279          istk(l+1)=eol
280          l=l+2
281       endif
282
283       goto 61
284 c
285 c     analyse de la ligne de declaration
286  40   continue
287       if(ddt.ge.2) call basout(io,wte,buf(1:n))
288       if(l.eq.lpt(1)) then
289          ierr=6
290          goto 90
291       endif
292       lin(l) = eol
293       lpt(6) = l
294       lpt(4) = lpt(1)
295       lpt(3) = lpt(1)
296       lpt(2) = lpt(1)
297       lct(1) = 0
298 cMAJ
299       fin=0
300       call fortrangetch
301 c
302       if(top+2.ge.bot) then
303          call error(18)
304          return
305       endif
306       top=top+1
307       il=iadr(lstk(top))
308       istk(il)=11
309       l=il+2
310       isopened=.true.
311       if(l.gt.lmax) then
312          ierr=5
313          goto 90
314       endif
315 c
316       call getsym
317       mlhs=0
318       if(sym.eq.name) then
319 c     a=func(..) ou func(..)
320          if(char1.eq.equal) then
321 c     a=func(..)
322             mlhs=mlhs+1
323             l=l+nsiz
324             if(l.gt.lmax) then
325                ierr=5
326                goto 90
327             endif
328             call putid(istk(l-nsiz),syn(1))
329             call getsym
330             call getsym
331          endif
332       elseif(sym.eq.less.or.sym.eq.left) then
333 c     [..]=func()
334  41      call getsym
335          if(sym.ne.name) goto  42
336          mlhs=mlhs+1
337          l=l+nsiz
338          if(l.gt.lmax) then
339             ierr=5
340             goto 90
341          endif
342          call putid(istk(l-nsiz),syn(1))
343          call getsym
344          if(sym.eq.comma) goto  41
345  42      if(sym.ne.great.and.sym.ne.right) then
346             ierr=4
347             goto  90
348          endif
349 c
350          call getsym
351          if(sym.ne.equal) then
352             ierr=4
353             goto  90
354          endif
355          call getsym
356       else
357          ierr=4
358          goto 90
359       endif
360 c
361       if(sym.ne.name) then
362          ierr=4
363          goto  90
364       endif
365       istk(il+1)=mlhs
366       call putid(id,syn(1))
367 c
368       mrhs=0
369       il=l
370       l=l+1
371       if(l.gt.lmax) then
372          ierr=5
373          goto 90
374       endif
375       if(char1.eq.semi.or.char1.eq.comma) goto 46
376       call getsym
377       if(sym.eq.eol.or.sym.eq.cmt) goto 46
378       if(sym.ne.lparen) then
379          ierr=4
380          goto  90
381       endif
382  44   call getsym
383       if(sym.ne.name) goto  45
384       mrhs=mrhs+1
385       l=l+nsiz
386       if(l.gt.lmax) then
387          ierr=5
388          goto 90
389       endif
390       call putid(istk(l-nsiz),syn(1))
391       call getsym
392       if(sym.eq.comma) goto  44
393  45   if(sym.ne.rparen) then
394          ierr=4
395          goto  90
396       endif
397       call getsym
398       if(sym.ne.eol.and.sym.ne.semi.and.
399      $     sym.ne.comma.and.sym.ne.cmt) then
400          ierr=4
401          goto  90
402       endif
403  46   continue
404       istk(il)=mrhs
405 c
406       il=l
407       l=l+1
408
409       if(lunit.eq.0) goto 33
410 c     caller = 'getf' add an empty line for backward compatiblity
411       istk(l)=eol
412       istk(l+1)=blank
413       l=l+2
414
415       first=0
416       goto 11
417 c
418 c     fin
419  60   if(first.eq.1) then
420          job=-1
421          goto 62
422       else
423          job=1
424       endif
425  61   continue
426       if (.not.isopened) goto 93
427       call icopy(6,retu,1,istk(l),1)
428       l=l+6
429       istk(l)=eol
430       l=l+1
431       istk(l)=eol
432       l=l+1
433       istk(il)=l-(il+1)
434       lstk(top+1)=sadr(l)
435 c
436       lpt(1)=l1
437       call putid(idstk(1,top),id)
438 c
439  62   call icopy(6,slpt,1,lpt,1)
440       sym=ssym
441       char1=schar
442       fin=job
443       return
444
445 c
446  90   continue
447 c gestion des erreurs
448 c
449 c     on retablit les pointeurs de ligne pour le gestionnaire d'erreur
450       call icopy(6,slpt,1,lpt,1)
451       goto(91,92,93,94,95),ierr-1
452 c
453  91   continue
454 c     erreur de lecture
455       call error(49)
456       return
457  92   continue
458 c     buffer limit
459       call error(26)
460       return
461  93   continue
462 c     invalid syntax
463       err=nlines
464       call error(37)
465       return
466  94   err=lstk(bot)-sadr(l)
467       call error(17)
468       return
469  95   call error(28)
470       return
471 c
472
473       end
474