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
|
subroutine stackp(id,macmod)
c ======================================================================
c put variables into storage
c ======================================================================
c
c Copyright INRIA
INCLUDE '../stack.h'
integer iadr
common /mprot/ macprt
integer id(nsiz)
c
logical eqid,new,compil
integer macmod
integer v,vk,vt,vtk,pntr
c
iadr(l)=l+l-1
c
if (ddt .eq. 4) then
call cvname(id,buf,1)
call basout(io,wte,' stackp '//buf(1:nlgh))
endif
c
if(err1.gt.0) return
c compilation stackp: <1,nom(1:4)>
if (compil(1,id,0,0,0)) then
fin=0
return
endif
01 if (top .le. 0) then
call error(1)
return
endif
c
il=iadr(lstk(top))
vt=istk(il)
pntr=top
if(vt.lt.0) then
if(istk(il+1).lt.0) then
c cas des variables modifiees sur place (insertion)
pntr=istk(il+2)
top=top-1
fin=pntr
return
endif
endif
new=.true.
c
c does variable already exist
vtk=0
c
last=isiz
if(macr.eq.0.and.paus.eq.0) goto 04
k=lpt(1) - (13+nsiz)
last=lin(k+5)
04 continue
c
call putid(idstk(1,bot-1),id)
k = last
05 k = k-1
if (.not.eqid(idstk(1,k),id)) go to 05
if (k .eq. bot-1) go to 06
c
ilk=iadr(lstk(k))
vtk=istk(ilk)
vk=lstk(k+1)-lstk(k)
06 continue
c
c
v=lstk(pntr+1)-lstk(pntr)
if(vt.eq.0) v=0
c
if(vtk.eq.0) goto 30
c
c est-ce une variable predefinie
c
if(k.lt.bbot) goto 15
if(v.ne.vk) goto 12
if(k.le.isiz-4) goto 15
l1=lstk(pntr)-1
l2=lstk(k)-1
do 11 i=1,v
if(stk(l1+i).ne.stk(l2+i)) goto 12
11 continue
goto 15
12 call error(13)
return
c
15 continue
c
c preserve macros
if(vtk.eq.13.or.vtk.eq.11) then
if(vt.ne.0.and.macmod.eq.0) then
c fin=-3
c call funs(id)
c fun=0
c if(err.gt.0) return
c if(fin.gt.0) then
if(vt.ne.vtk) goto 19
c les macros sont elle identiques ?
if(istk(ilk).ne.istk(il)) goto 19
if(istk(ilk+1).ne.istk(il+1)) goto 19
mrhs=istk(ilk+1)
do 16 i=1,nsiz*mrhs
if(istk(ilk+1+i).ne.istk(il+1+i)) goto 19
16 continue
ln=2+nsiz*mrhs
if(istk(ilk+ln).ne.istk(il+ln)) goto 19
mlhs=istk(ilk+ln)
do 17 i=1,nsiz*mlhs
if(istk(ilk+ln+i).ne.istk(il+ln+i)) goto 19
17 continue
ln=ln+nsiz*mlhs+1
if(istk(ilk+ln).ne.istk(il+ln)) goto 19
long=istk(ilk+ln)
do 18 i=1,long
if(istk(ilk+ln+i).ne.istk(il+ln+i)) goto 19
18 continue
goto 20
c ce n'est pas la meme macro
19 call putid(ids(1,pt+1),id)
if(macprt.eq.2) then
call error(111)
if(err.gt.0) return
elseif(macprt.eq.1) then
call msgs(42,vt)
endif
20 continue
c endif
endif
endif
c
c does it fit
if (v.eq.vk) go to 35
c
c shift storage
if (k .eq. bot) go to 25
ls = lstk(bot)
ll = ls + vk
call dcopy(lstk(k)-lstk(bot),stk(ls),-1,stk(ll),-1)
km1 = k-1
do 21 ib = bot, km1
i = bot+km1-ib
call putid(idstk(1,i+1),idstk(1,i))
infstk(i+1)=infstk(i)
lstk(i+1) = lstk(i)+vk
21 continue
c
c destroy old variable
25 bot = bot+1
new=.false.
c
c create new variable
30 if (istk(il) .eq. 0) go to 41
if (bot-2 .lt. top) then
call error(18)
return
endif
if(macmod.eq.0.and.new) then
fin=-3
call funs(id)
fun=0
if(fin.gt.0) then
if(macprt.eq.2) then
call putid(ids(1,pt+1),id)
call error(111)
if(err.gt.0) return
elseif(macprt.eq.1) then
call putid(ids(1,pt+1),id)
call msgs(42,vt)
endif
endif
endif
k = bot-1
call putid(idstk(1,k), id)
infstk(k)=0
c
c store
35 lstk(k) = lstk(k+1) - v
lk = lstk(k)
call dcopy(v,stk(lstk(pntr)),-1,stk(lk),-1)
go to 40
c
c pop stack
40 if (k .eq. bot-1) bot = bot-1
41 top =top - 1
fin=0
if(istk(il).ne.0) fin=k
goto 99
c
c 92 call error(21)
c return
c 93 call error(44)
c return
99 continue
return
end
|
