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