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
|
subroutine clause
c ======================================================================
c gestion des structures de controle
c ======================================================================
c Copyright INRIA
include '../stack.h'
integer while(nsiz),iff(nsiz),else(nsiz),ennd(nsiz)
integer do(nsiz),thenn(nsiz),cas(nsiz),sel(nsiz)
integer elsif(nsiz)
integer semi,equal,eol,blank,comma,name
integer r,r1
logical eqid,istrue,ok,first,eptover
parameter (nz1=nsiz-1,nz2=nsiz-2)
data semi/43/,equal/50/,eol/99/,blank/40/
data comma/52/,name/1/
data do/673716237,nz1*673720360/, else/236721422,nz1*673720360/
data ennd/671946510,nz1*673720360/
data iff/673713938,nz1*673720360/
data thenn/386797853,nz1*673720360/
data while/353505568,673720334,nz2*673720360/
data cas/236718604,nz1*673720360/
data sel/236260892,673717516,nz2*673720360/
data elsif/236721422,673713938,nz2*673720360/
c
r = -fin-10
fin = 0
r1=0
if(pt.gt.0) r1=rstk(pt)
c
if (ddt .eq. 4) then
write(buf(1:12),'(3i4)') pt,r1,r
call basout(io,wte,' clause pt:'//buf(1:4)//' rstk(pt):'//
& buf(5:8)//' -fin-10:'//buf(9:12))
endif
c
if(r.le.0.and.pt.le.0) then
call error(34)
return
endif
go to (02,30,30,55,30,55,55),r
c
01 r = rstk(pt)
ir=r/100
if(ir.ne.8) goto 99
goto(05,15,40,45,55,65,46),r-800
goto 99
c
c for
c
02 call getsym
if (sym .ne. name) then
call error(34)
return
endif
rstk(pt+1)=0
if ( eptover(2,psiz)) return
call putid(ids(1,pt),syn)
call getsym
if (sym .ne. equal) then
call error(34)
return
endif
call getsym
if(comp(1).ne.0) then
rstk(pt) = 800
call compcl
if(err.gt.0) return
endif
ids(4,pt-1) = toperr
rstk(pt) = 801
icall=1
c *call* expr
return
05 if(comp(1).ne.0) call compcl
if(err.gt.0) return
toperr=top
pstk(pt-1) = 0
ids(1,pt-1)=top
if (eqid(syn,do)) then
sym=comma
if(char1.eq.eol) call getsym
endif
if(sym.eq.comma.or.sym.eq.semi) then
sym = semi
pstk(pt) = lpt(4) - 1
elseif( sym.eq.eol) then
sym=semi
pstk(pt) = lpt(4)
else
call error(34)
return
endif
c on recherche le "end" pour s'assurer que toutes les lignes relatives
c sont chargee (pb des matrices sur plusieurs lignes)
call skpins(1)
if(err.gt.0) return
first=.true.
10 if(top.ne.ids(1,pt-1)) then
call error(115)
return
endif
call nextj(ids(1,pt),pstk(pt-1))
if(err.gt.0) return
if(pstk(pt-1).eq.0) goto 20
first=.false.
lpt(4) = pstk(pt)
char1 = blank
rstk(pt) = 802
icall=7
c *call* parse
return
15 if(comp(1).eq.0) goto 10
call compcl
if(err.gt.0) return
c
c fin for
20 continue
toperr = ids(4,pt-1)
pt = pt-2
icall=7
char1 = blank
return
c
c while if select/case or if/elseif
c
30 if ( eptover(1,psiz)) return
call putid(ids(1,pt),syn)
pstk(pt) = lpt(4)-1
if(eqid(while,ids(1,pt))) then
c on recherche le "end" pour s'assurer que toutes les lignes relatives
c sont chargee (pb des matrices sur plusieurs lignes)
call skpins(1)
if(err.gt.0) return
endif
35 lpt(4) = pstk(pt)
pstk(pt)=lpt(4)
char1 = blank
call getsym
rstk(pt)=803
if(comp(1).ne.0) call compcl
if(err.gt.0) return
goto 37
36 rstk(pt) = 803
call getsym
37 icall=1
c *call* expr
return
40 if (.not.eqid(ids(1,pt),sel)) goto 46
41 continue
if(sym.eq.comma.or.sym.eq.semi) then
call getsym
goto 41
elseif(sym.eq.eol) then
if(macr.gt.0.and.lin(lpt(4)+1).eq.eol) then
call error(47)
return
endif
if(comp(1).ne.0) call seteol()
c get the following line
if(lpt(4).eq.lpt(6)) then
call getlin(1)
else
lpt(4)=lpt(4)+1
char1=blank
endif
call getsym
goto 41
elseif(sym.eq.name.and.eqid(syn,cas)) then
rstk(pt)=807
if(comp(1).ne.0) then
call compcl
if(err.gt.0) return
endif
else
call error(35)
return
endif
42 if(comp(1).eq.0) then
c recopie de la premiere expression
l=lstk(top)
l1=lstk(top+1)
if(top+2.ge.bot) then
call error(18)
if(err.gt.0) return
endif
err=lstk(top+1)+l1-l-lstk(bot)
if(err.gt.0) then
call error(17)
if(err.gt.0) return
endif
call unsfdcopy(l1-l,stk(l),1,stk(l1),1)
top=top+1
lstk(top+1)=lstk(top)+l1-l
endif
43 call getsym
rstk(pt) = 804
icall=1
c *call* expr
return
45 continue
if(comp(2).ne.0) goto 46
rstk(pt)=807
fin = equal
rhs=2
icall=4
c *call* allops(==)
return
46 if (eqid(syn,do) .or. eqid(syn,thenn)
& .or.sym.eq.comma.or.sym.eq.semi.or.sym.eq.eol) then
sym = semi
else
call error(35)
return
endif
if(comp(1).ne.0) goto 48
c comparaison ...
ok=istrue(1)
if(err.gt.0) return
if(ok) then
goto 50
else
call skpins(0)
if(err.gt.0) return
if(eqid(syn,else)) goto 60
if(eqid(syn,elsif)) then
if(.not.eqid(iff,ids(1,pt))) then
call error(34)
return
endif
goto 36
endif
if(eqid(syn,cas)) then
if(.not.eqid(sel,ids(1,pt))) then
call error(34)
return
endif
goto 42
endif
if(eqid(syn,ennd)) goto 66
endif
48 rstk(pt)=804
call compcl
if(err.gt.0) return
c
c then
c --------
50 toperr=top
rstk(pt) = 805
icall=7
c *call* parse
return
55 if(comp(1).eq.0) then
if (eqid(ids(1,pt),while)) go to 35
if(.not.eqid(syn,ennd)) then
call skpins(1)
if(err.gt.0) return
endif
else
call compcl
if(err.gt.0) return
if(eqid(syn,else)) goto 60
if(eqid(syn,elsif)) goto 36
if(eqid(syn,cas)) goto 43
endif
goto 66
c
c else
c ---------
60 rstk(pt) = 806
icall=7
c *call parse*
return
65 if(comp(1).ne.0) then
call compcl
if(err.gt.0) return
endif
goto 66
c
c fin if ou while ou select
c------------------------------
66 if(eqid(ids(1,pt),sel).and.comp(1).eq.0) top=top-1
pt=pt-1
icall=7
return
c
99 call error(22)
if (err .gt. 0) return
return
end
|
