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
|
subroutine allops
c ======================================================================
c Calling function according to arguments type
c ======================================================================
c Copyright INRIA
include '../stack.h'
integer ogettype, vt,vt1,id(nsiz),r,op,extrac
logical compil,ptover
integer iadr,sadr
data extrac/3/
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
r=0
if(pt.gt.0) r=rstk(pt)
c
if (ddt .eq. 4) then
write(buf(1:12),'(3i4)') fin,pt,r
call basout(io,wte,' allops op:'//buf(1:4)//' pt:'//buf(5:8)//
& ' rstk(pt):'//buf(9:12))
endif
c
c compilation allops :<5 fin rhs lhs>
if ( compil(5,fin,rhs,lhs,0)) then
if (err.gt.0) return
fun=0
return
endif
c
01 ir=r/100
if(ir.eq.4) then
if (r.eq.401) then
call putid(syn(1),ids(1,pt))
pt=pt-1
elseif (r.eq.402) then
pt=pt-1
elseif (r.eq.403.or.r.eq.404) then
goto 50
endif
return
endif
if(err1.gt.0) return
02 vt=0
icall=0
if(fin.eq.2) then
c . insertions
nt=2
elseif(fin.eq.3) then
c . extraction
if(rhs.eq.1) then
c . a() -->a
goto 81
endif
nt=1
else
nt=rhs
endif
do 03 i=1,nt
vt1=abs(ogettype(top+1-i))
if(vt1.eq.129.and.fin.eq.extrac) vt1=2
if(vt1.gt.vt) vt=vt1
03 continue
c
goto (10,20,05,30,70,35,05,05,05,40,60,05,60,60,50,50,50) ,vt
c overloadable ops
op=fin
goto 90
05 call error(43)
return
10 call matops
goto 80
20 call polops
goto 80
30 call logic
goto 80
35 call lspops
goto 80
40 call strops
goto 80
50 call lstops
if(err.gt.0) return
if(icall.eq.4) goto 02
goto 81
60 call misops
goto 80
70 call spops
goto 80
c
80 if(err.gt.0) return
81 call iset(lhs,0,infstk(max(top-lhs+1,1)),1)
c
if(fun.ne.0) then
c . appel d'un matfn necessaire pour achever l'evaluation
if (ptover(1,psiz)) return
rstk(pt)=402
icall=9
c . *call* matfns
return
endif
c
if(fin.le.0) then
op=-fin
fin=-fin
goto 90
endif
if(rstk(pt).eq.406.or.rstk(pt).eq.405) then
c . list recursive extraction insertion
goto 50
endif
return
90 continue
c . operation macro programmee ?
call ref2val
call mname(op,id)
if(err.gt.0.or.err1.gt.0) return
if(fun.gt.0) then
if (ptover(1,psiz)) return
rstk(pt)=402
icall=9
c . *call* matfns
return
else
fin=lstk(fin)
if (ptover(1,psiz)) return
call putid(ids(1,pt),syn(1))
rstk(pt)=401
icall=5
c . *call* macro
return
endif
end
|
