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
|
subroutine lstops
c ==================================
c elementary operations on lists
c ==================================
c
c Copyright INRIA
include '../stack.h'
c
c
logical ishm
integer insert,extrac, toto, gettype
data insert/2/,extrac/3/
c handle recursion
if(rstk(pt).ge.403.and.rstk(pt).le.405) goto 10
if(rstk(pt).eq.406.or.rstk(pt).eq.407) goto 50
c
if (ddt .eq. 4) then
write(buf(1:4),'(i4)') fin
call basout(io,wte,' lstops '//buf(1:4))
endif
c
if(fin.eq.extrac) goto 10
if(fin.eq.insert) goto 50
c
c undefined operations (look for function-defined operation)
icall = 0
fun = 0
fin = -fin
return
c
c extraction
10 continue
toto = gettype(top-1)
c$$$ print *, ' type de top =', gettype(top), ' type de top-1 =', toto
if ( ishm() .and. toto.ne.10 .and. toto.ne.15) then
call intehm()
else
call intl_e()
endif
return
c
c insertion
50 continue
toto = gettype(top-2) ! a priori
c$$$ print *, ' type de top =', gettype(top),
c$$$ $ ' type de top-1 =', gettype(top-1),
c$$$ $ ' type de top-2 =', toto
if ( ishm() .and. toto.ne.10 .and. toto.ne.15) then
call intihm()
else
call intl_i()
endif
if(err.gt.0) return
c if(rstk(pt).eq.407) goto 50
return
c
end
integer function strpos(ptr,ns,chars,str,n)
integer ptr(ns+1),ns,chars(*),str(n),n
do 10 i=1,ns
i1=ptr(i)
i2=ptr(i+1)
if(i2-i1.eq.n) then
do 05 j=1,n
if(str(j).ne.chars(i1-1+j)) goto 10
05 continue
strpos=i
return
endif
10 continue
strpos=0
return
end
|
