← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to routines/system2/tradsl.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/system2/tradsl.f
 
1
      subroutine tradsl(ilfun,funnam,illist,nlist)
 
2
c     
 
3
c!but 
 
4
c     convert compiled macros to lst structure
 
5
c!calling sequence
 
6
c     subroutine tradsl(ilfun,id,illist,nlist)
 
7
c     kmac  : variable number of the compiled macro in the scilab stack
 
8
c!    
 
9
c
 
10
c
 
11
c     Copyright INRIA
 
12
      include '../stack.h'
 
13
c     
 
14
      integer nops,funnam(nsiz)
 
15
      parameter (nops=32)
 
16
      character*40 strg
 
17
      character*40 form
 
18
      double precision x,xx
 
19
      integer op,ix(2),fptr
 
20
      equivalence (x,ix(1))
 
21
      logical iflag
 
22
      common /basbrk/ iflag
 
23
c
 
24
 
 
25
      integer id(nsiz),iadr,sadr,cmplxt,pt0
 
26
c
 
27
      integer for(3),while(5),iff(2),sel(6)
 
28
      integer ops(nops)
 
29
      external getendian
 
30
      integer getendian
 
31
 
 
32
      data for/15,24,27/
 
33
      data iff/18,15/
 
34
      data while/32,17,18,21,14/
 
35
      data sel/28,14,21,14,12,29/
 
36
c                            +  -  * .*  *. .*.  / ./  /. ./.  
 
37
      data (ops(i),i=1,10) /45,46,47,98,200,149,48,99,201,150/
 
38
c                            \ .\   \. .\. ** =  <  >  <=  >=  <>
 
39
      data (ops(i),i=11,21)/49,100,202,151,62,50,59,60,109,110,119/
 
40
c                             : [,] ins ext '  [;]  | &   ~  .^  .'
 
41
      data (ops(i),i=22,nops)/44,01, 02 ,03,53,04, 57,58, 61,113,104/
 
42
c
 
43
      iadr(l)=l+l-1
 
44
      sadr(l)=(l/2)+1
 
45
c
 
46
c     mode debug
 
47
 
 
48
      if (ddt .eq. 4) then
 
49
         write(buf(1:8),'(2i4)') pt,rstk(pt)
 
50
         call basout(io,wte,' tradsl pt:'//buf(1:4)//' rstk(pt):'
 
51
     &        //buf(5:8))
 
52
      endif
 
53
c
 
54
c
 
55
      pt0=pt
 
56
      pt=pt+1
 
57
      if(pt.gt.psiz) then
 
58
         call error(26)
 
59
         return
 
60
      endif
 
61
      rstk(pt)=0
 
62
c
 
63
 
 
64
      lc=ilfun
 
65
      ilk=lc
 
66
 
 
67
c
 
68
c     on scrute une premiere fois l'ensemble de la macro pour determiner
 
69
c     sa complexite
 
70
c
 
71
      lc = lc +1
 
72
      lc = lc + nsiz*istk(lc) + 1
 
73
      lc = lc + nsiz*istk(lc) + 1
 
74
      long = istk(lc)
 
75
      lc = lc+1
 
76
      icount=cmplxt(istk(lc),long) 
 
77
      if(icount.lt.0) then
 
78
         pt=pt0
 
79
         call error(37)
 
80
         return
 
81
      endif
 
82
 
 
83
c
 
84
c     premiers elements de la liste resultat
 
85
c
 
86
      ilr=illist
 
87
      istk(ilr)=15
 
88
      istk(ilr+1)=icount+3
 
89
      istk(ilr+2)=1
 
90
      lr=sadr(ilr+3+icount+3)
 
91
      ilr=ilr+3
 
92
c
 
93
c     nom de la macro
 
94
      il=iadr(lr)
 
95
      call basnms(funnam,1,istk(il),ni)
 
96
      l=sadr(il+ni)
 
97
      istk(ilr)=istk(ilr-1)+l-lr
 
98
      lr=l
 
99
      ilr=ilr+1
 
100
 
 
101
c     nom des parametres de sortie
 
102
      lc=ilk+1
 
103
      nc=istk(lc)
 
104
      il=iadr(lr)
 
105
      call basnms(istk(lc+1),nc,istk(il),ni)
 
106
      l=sadr(il+ni)
 
107
      istk(ilr)=istk(ilr-1)+l-lr
 
108
      lr=l
 
109
      ilr=ilr+1
 
110
 
 
111
c     nom des parametres d'entree
 
112
      lc=lc+nsiz*nc+1
 
113
      nc=istk(lc)
 
114
      il=iadr(lr)
 
115
      call basnms(istk(lc+1),nc,istk(il),ni)
 
116
      l=sadr(il+ni)
 
117
      istk(ilr)=istk(ilr-1)+l-lr
 
118
      lr=l
 
119
      ilr=ilr+1
 
120
c
 
121
      lc=lc+nsiz*nc+1
 
122
c
 
123
c
 
124
      l0=0
 
125
      nc=0
 
126
C     pointeur sur le tableau de travail : pointe sur la premiere adresse libre
 
127
c     
 
128
c     debut du texte proprement dit de la macro
 
129
c
 
130
C     lc : pointeur sur l'instruction de la macro en cours de traduction
 
131
c     lr : pointeur dans stk sur l'element courant de la liste courante
 
132
c     ilr: pointeur dans istk sur la position de  l'element courant dans
 
133
c          la liste courante
 
134
C     
 
135
      Lc = lc+1
 
136
      lcf=lc+long-1
 
137
c     
 
138
c     nouvelle 'operation'
 
139
 10   continue
 
140
      if(lc.gt.lcf) then
 
141
         goto(11,11,11,46,47,11,51,54,55,11,61,63,64,65),rstk(pt)
 
142
 11      nlist=iadr(lr)-illist
 
143
         pt=pt0
 
144
         return
 
145
      endif
 
146
      op=istk(lc)
 
147
c     
 
148
      if(ddt.lt.-1) write(6,'(i7)') op
 
149
      goto(20,25,40,42,30,41,45,50,50,60,15,90,90,90,90,100,
 
150
     &     12,101,102,90,103,104,105,106,107,108) ,op
 
151
c     
 
152
c     
 
153
c     matfns
 
154
      if(op.ge.100)   goto 80
 
155
      if(op.eq.0) then
 
156
c     "deleted op"
 
157
         lc=lc+istk(lc+1)
 
158
         goto 10
 
159
      endif
 
160
c     
 
161
 12   if(op.ne.99) then
 
162
         call error(44)
 
163
         return
 
164
      endif
 
165
c
 
166
c     return
 
167
      il=iadr(lr)
 
168
      istk(il)=10
 
169
      istk(il+1)=1
 
170
      istk(il+2)=1
 
171
      istk(il+3)=0
 
172
      istk(il+4)=1
 
173
      l=il+6
 
174
c     type 99
 
175
      istk(l)=9
 
176
      istk(l+1)=9
 
177
      istk(il+5)=3
 
178
      l=l+2
 
179
c
 
180
      l=sadr(l)
 
181
      istk(ilr)=istk(ilr-1)+l-lr
 
182
      lr=l
 
183
      ilr=ilr+1
 
184
c
 
185
      lc=lc+1
 
186
      goto 10
 
187
c     
 
188
c     
 
189
 15   continue
 
190
      call error(60)
 
191
      return
 
192
c 
 
193
c     stackp
 
194
c     
 
195
c     affectation d'une valeur a une variable
 
196
c     de par le fonctionnement de la pile , la valeur a affecter est 
 
197
c     en premiere  position
 
198
c
 
199
 20   continue
 
200
      il=iadr(lr)
 
201
      istk(il)=10
 
202
      istk(il+1)=1
 
203
      istk(il+2)=2
 
204
      istk(il+3)=0
 
205
      istk(il+4)=1
 
206
      l=il+7
 
207
c     type 1
 
208
      istk(l)=1
 
209
      istk(il+5)=2
 
210
      l=l+1
 
211
c     nom de la variable
 
212
      call namstr(istk(lc+1),istk(l),ni,1)
 
213
      istk(il+6)=istk(il+5)+ni
 
214
      l=l+ni
 
215
c
 
216
      l=sadr(l)
 
217
      istk(ilr)=istk(ilr-1)+l-lr
 
218
      lr=l
 
219
      ilr=ilr+1
 
220
c
 
221
      lc=lc+1+nsiz
 
222
      goto 10
 
223
c     
 
224
c     stackg
 
225
c
 
226
 25   continue
 
227
      il=iadr(lr)
 
228
      istk(il)=10
 
229
      istk(il+1)=1
 
230
      istk(il+2)=4
 
231
      istk(il+3)=0
 
232
      istk(il+4)=1
 
233
      l=il+9
 
234
c     type 2
 
235
      istk(l)=2
 
236
      istk(il+5)=2
 
237
      l=l+1
 
238
c     nom de la variable
 
239
      call namstr(istk(lc+1),istk(l),ni,1)
 
240
      istk(il+6)=istk(il+5)+ni
 
241
      l=l+ni
 
242
c     rhs
 
243
      call intstr(istk(lc+nsiz+1),istk(l),ni,1)
 
244
      istk(il+7)=istk(il+6)+ni
 
245
      l=l+ni
 
246
c     fin
 
247
      call intstr(istk(lc+nsiz+2),istk(l),ni,1)
 
248
      istk(il+8)=istk(il+7)+ni
 
249
      l=l+ni
 
250
c
 
251
      l=sadr(l)
 
252
      istk(ilr)=istk(ilr-1)+l-lr
 
253
      lr=l
 
254
      ilr=ilr+1
 
255
c
 
256
      lc=lc+nsiz+3
 
257
      goto 10
 
258
c     
 
259
c     allops => operation sur les operandes de la pile
 
260
c     
 
261
 30   continue
 
262
      il=iadr(lr)
 
263
      istk(il)=10
 
264
      istk(il+1)=1
 
265
      istk(il+2)=4
 
266
      istk(il+3)=0
 
267
      istk(il+4)=1
 
268
      l=il+9
 
269
c     type 5
 
270
      istk(l)=5
 
271
      istk(il+5)=2
 
272
      l=l+1
 
273
c     op
 
274
      iop=istk(lc+1)
 
275
      ii=0
 
276
 31   ii=ii+1
 
277
      if(ii.gt.nops) then
 
278
         buf='Unmanaged operation'
 
279
         call error(999)
 
280
         return
 
281
      endif
 
282
      if(ops(ii).ne.iop) goto 31
 
283
      call intstr(ii,istk(l),ni,1)
 
284
c      call intstr(istk(lc+1),istk(l),ni,1)
 
285
      istk(il+6)=istk(il+5)+ni
 
286
      l=l+ni
 
287
c     rhs
 
288
      call intstr(istk(lc+2),istk(l),ni,1)
 
289
      istk(il+7)=istk(il+6)+ni
 
290
      l=l+ni
 
291
c     lhs
 
292
      call intstr(istk(lc+3),istk(l),ni,1)
 
293
      istk(il+8)=istk(il+7)+ni
 
294
      l=l+ni
 
295
c
 
296
      l=sadr(l)
 
297
      istk(ilr)=istk(ilr-1)+l-lr
 
298
      lr=l
 
299
      ilr=ilr+1
 
300
c
 
301
      lc=lc+4
 
302
      goto 10
 
303
c     
 
304
c     string
 
305
c     
 
306
 40   continue
 
307
      il=iadr(lr)
 
308
      istk(il)=10
 
309
      istk(il+1)=1
 
310
      istk(il+2)=2
 
311
      istk(il+3)=0
 
312
      istk(il+4)=1
 
313
      l=il+7
 
314
c     type 3
 
315
      istk(l)=3
 
316
      istk(il+5)=2
 
317
      l=l+1
 
318
c     str
 
319
      ni=istk(lc+1)
 
320
      call icopy(ni,istk(lc+2),1,istk(l),1)
 
321
      istk(il+6)=istk(il+5)+ni
 
322
      l=l+ni
 
323
c
 
324
      l=sadr(l)
 
325
      istk(ilr)=istk(ilr-1)+l-lr
 
326
      lr=l
 
327
      ilr=ilr+1
 
328
c      
 
329
      lc=lc+2+ni
 
330
      goto 10
 
331
c     
 
332
c     num
 
333
c     
 
334
 41   continue
 
335
      il=iadr(lr)
 
336
      if(getendian().eq.1) then
 
337
         ix(1)=istk(lc+1)
 
338
         ix(2)=istk(lc+2)
 
339
      else
 
340
         ix(2)=istk(lc+1)
 
341
         ix(1)=istk(lc+2)
 
342
      endif
 
343
 
 
344
 
 
345
      maxc=17
 
346
      isign=1
 
347
      if(x.lt.0)  isign=-1
 
348
      call fmt(abs(x),maxc,ifmt,n1,n2)
 
349
      if(ifmt.eq.-1) then
 
350
c     Inf
 
351
         ifl=3
 
352
         strg='Inf'
 
353
      elseif(ifmt.eq.-2) then
 
354
c     Nan
 
355
         ifl=3
 
356
         strg='Nan'
 
357
      elseif(ifmt.eq.1) then
 
358
         nf=1
 
359
         ifl=maxc
 
360
         n2=1
 
361
         if(abs(x).ge.1.d100.or.abs(x).lt.1.d-99) then
 
362
            ie=int(log10(abs(x)))
 
363
            if(ie.lt.0) ie=ie-1
 
364
            xx=x/(10.0d0**ie)
 
365
            nf=2
 
366
            write(form,120) maxc,0
 
367
            write(strg,form) xx
 
368
            ls=lnblnk(strg)
 
369
            write(strg(ls+1:),'(''D'',i4)') ie
 
370
         else
 
371
            write(form,130) maxc,maxc-7
 
372
            write(strg,form) x
 
373
         endif
 
374
      elseif(ifmt.ge.0) then
 
375
         nf=2
 
376
         write(form,120) n1,n2
 
377
         write(strg,form) x
 
378
      endif
 
379
      i1=0
 
380
 410  i1=i1+1
 
381
      if(strg(i1:i1).eq.' ') goto 410
 
382
 
 
383
      i2=lnblnk(strg)+1
 
384
      if(ifmt.ge.0.and.ifmt.ne.1) then
 
385
 420     i2=i2-1
 
386
         if(i2.gt.2) then
 
387
            if(strg(i2:i2).eq.'0') goto 420
 
388
         endif
 
389
         if(strg(i2:i2).eq.'.') i2=i2-1
 
390
      else
 
391
         i2=i2-1
 
392
      endif
 
393
 
 
394
      istk(il)=10
 
395
      istk(il+1)=1
 
396
      istk(il+2)=2
 
397
      istk(il+3)=0
 
398
      istk(il+4)=1
 
399
      l=il+7
 
400
c     type 6
 
401
      istk(l)=6
 
402
      istk(il+5)=2
 
403
      l=l+1
 
404
c     nom de la variable
 
405
      ni=i2-i1+1
 
406
      call cvstr(ni,istk(l),strg(i1:i2),0)
 
407
      istk(il+6)=istk(il+5)+ni
 
408
      l=l+ni
 
409
c
 
410
      l=sadr(l)
 
411
      istk(ilr)=istk(ilr-1)+l-lr
 
412
      lr=l
 
413
      ilr=ilr+1
 
414
c
 
415
      lc=lc+3
 
416
      goto 10
 
417
c     
 
418
c matrice vide
 
419
c
 
420
 42   continue
 
421
      il=iadr(lr)
 
422
      istk(il)=10
 
423
      istk(il+1)=1
 
424
      istk(il+2)=1
 
425
      istk(il+3)=0
 
426
      istk(il+4)=1
 
427
      l=il+6
 
428
c     type 4
 
429
      istk(l)=4
 
430
      istk(il+5)=2
 
431
      l=l+1
 
432
c
 
433
      l=sadr(l)
 
434
      istk(ilr)=istk(ilr-1)+l-lr
 
435
      lr=l
 
436
      ilr=ilr+1
 
437
c
 
438
      lc=lc+1
 
439
      goto 10
 
440
 
 
441
c     
 
442
c     for
 
443
c     
 
444
 45   continue
 
445
      if(ddt.le.-1) write(6,'(a10,5i5)') 'for',pt,lcf,ilr,lr,l-lr
 
446
      il=iadr(lr)
 
447
c     on preserve les pointeurs de la liste courante
 
448
      pt=pt+1
 
449
      rstk(pt)=3
 
450
      ids(1,pt)=ilr
 
451
      ids(2,pt)=lr
 
452
      istk(ilr)=lcf
 
453
c
 
454
c     on cree les premiers elements de la liste "for"
 
455
      istk(il)=15
 
456
      istk(il+1)=3
 
457
      istk(il+2)=1
 
458
      lr=sadr(il+6)
 
459
      ilr=il+3
 
460
c
 
461
      il=iadr(lr)
 
462
      istk(il)=10
 
463
      istk(il+1)=1
 
464
      istk(il+2)=2
 
465
      istk(il+3)=0
 
466
      istk(il+4)=1
 
467
      l=il+7
 
468
c     type for
 
469
      call icopy(3,for,1,istk(l),1)
 
470
      istk(il+5)=istk(il+4)+3
 
471
      l=l+3
 
472
c     variable de boucle
 
473
      ni=istk(lc+1)
 
474
      li=lc+2+ni
 
475
      call namstr(istk(li+1),istk(l),ni,1)
 
476
      istk(il+6)=istk(il+5)+ni
 
477
      l=l+ni
 
478
c
 
479
      l=sadr(l)
 
480
      istk(ilr)=istk(ilr-1)+l-lr
 
481
      ilr=ilr+1
 
482
      lr=l
 
483
      lc=lc+1
 
484
c
 
485
c     expression de boucle
 
486
c
 
487
      il=iadr(lr)
 
488
 
 
489
c     ---- on preserve les pointeurs  de la liste "for" 
 
490
      pt=pt+1
 
491
      if(pt.gt.psiz) then
 
492
         call error(26)
 
493
         return
 
494
      endif
 
495
      rstk(pt)=4
 
496
      ids(1,pt)=ilr
 
497
      ids(2,pt)=lr
 
498
      long=istk(lc)
 
499
      lcf=lc+long
 
500
      lc=lc+1
 
501
c     ----   ----   ----   ----   ----  --
 
502
c     on cree la liste "code boucle"
 
503
      ni=cmplxt(istk(lc),long)
 
504
      istk(il)=15
 
505
      istk(il+1)=ni
 
506
      istk(il+2)=1
 
507
      lr=sadr(il+3+ni)
 
508
      l=lr
 
509
      ilr=il+3
 
510
c
 
511
      goto 10
 
512
 46   continue
 
513
c     fin code boucle
 
514
c     on rappelle les pointeurs de la liste "for"
 
515
      ilr=ids(1,pt)
 
516
      lr=ids(2,pt)
 
517
c     on complete la liste for
 
518
      istk(ilr)=istk(ilr-1)+l-lr
 
519
      ilr=ilr+1
 
520
      lr=l
 
521
c     code du for
 
522
c     ---- on preserve les pointeurs  de la liste "for" 
 
523
      rstk(pt)=5
 
524
      ids(1,pt)=ilr
 
525
      ids(2,pt)=lr
 
526
      long=istk(lc)
 
527
      lc=lc+1+nsiz
 
528
c     on cree la liste "for code "
 
529
      ni=cmplxt(istk(lc),long)
 
530
      lcf=lc+long-1
 
531
      il=iadr(lr)
 
532
      istk(il)=15
 
533
      istk(il+1)=ni
 
534
      istk(il+2)=1
 
535
      lr=sadr(il+3+ni)
 
536
      ilr=il+3
 
537
c     on preserve les pointeurs de la liste "for code"
 
538
      goto 10
 
539
 47   continue
 
540
c     fin du code du for
 
541
c     fin du for
 
542
c     on recharge les pointeurs de la liste "for"
 
543
      ilr=ids(1,pt)
 
544
      lr=ids(2,pt)
 
545
      pt=pt-1
 
546
      lcf=istk(ilr)
 
547
c     on complete la liste "for"
 
548
      istk(ilr)=istk(ilr-1)+l-lr
 
549
      lr=l
 
550
      ilr=ilr+1
 
551
c     on recharge les pointeurs de la liste courante
 
552
      ilr=ids(1,pt)
 
553
      lr=ids(2,pt)
 
554
      lcf=istk(ilr)
 
555
c     on complete la liste "courante"
 
556
      istk(ilr)=istk(ilr-1)+l-lr
 
557
      lr=l
 
558
      ilr=ilr+1
 
559
      pt=pt-1
 
560
      if(ddt.le.-1) write(6,'(a10,5i5)') 'fin for',pt,lcf,ilr,lr,l-lr
 
561
      goto 10
 
562
c
 
563
c     if - while
 
564
 50   continue
 
565
      if(istk(lc+1).lt.0) goto 60
 
566
c     ce qui suit (jusqu'a l'etiquette 60 correspond a la traduction 
 
567
c     des if/while de  la version 3 et assure la compatibilite
 
568
      if(ddt.le.-1) write(6,'(a10,5i5)') 'if',pt,lcf,ilr,lr,l-lr
 
569
      il=iadr(lr)
 
570
c     on preserve les pointeurs de la liste courante
 
571
      pt=pt+1
 
572
      rstk(pt)=6
 
573
      ids(1,pt)=ilr
 
574
      ids(2,pt)=lr
 
575
      istk(ilr)=lcf
 
576
      lc0=lc
 
577
c
 
578
c     on cree les premiers elements de la liste "if" ou "while"
 
579
      istk(il)=15
 
580
      istk(il+1)=4
 
581
      istk(il+2)=1
 
582
      lr=sadr(il+7)
 
583
      ilr=il+3
 
584
      istk(ilr+3)=lc0
 
585
c
 
586
      il=iadr(lr)
 
587
      istk(il)=10
 
588
      istk(il+1)=1
 
589
      istk(il+2)=1
 
590
      istk(il+3)=0
 
591
      istk(il+4)=1
 
592
      l=il+6
 
593
c     type if ou while
 
594
      if(op.eq.8) then
 
595
         call icopy(2,iff,1,istk(l),1)
 
596
         istk(il+5)=istk(il+4)+2
 
597
         l=l+2
 
598
      else
 
599
         call icopy(5,while,1,istk(l),1)
 
600
         istk(il+5)=istk(il+4)+5
 
601
         l=l+5
 
602
      endif
 
603
c
 
604
      l=sadr(l)
 
605
      istk(ilr)=istk(ilr-1)+l-lr
 
606
      ilr=ilr+1
 
607
      lr=l
 
608
      lc=lc+5
 
609
c
 
610
c     expression logique
 
611
c
 
612
      il=iadr(lr)
 
613
 
 
614
c     ---- on preserve les pointeurs  de la liste "if" ou "while"
 
615
      pt=pt+1
 
616
      if(pt.gt.psiz) then
 
617
         call error(26)
 
618
         return
 
619
      endif
 
620
      rstk(pt)=7
 
621
      ids(1,pt)=ilr
 
622
      ids(2,pt)=lr
 
623
      istk(ilr)=lc
 
624
      long=istk(lc0+2)
 
625
      lcf=lc+long-1
 
626
 
 
627
c     ----   ----   ----   ----   ----  --
 
628
c     on cree la liste "code expression logique"
 
629
      ni=cmplxt(istk(lc),long)+1
 
630
      istk(il)=15
 
631
      istk(il+1)=ni
 
632
      istk(il+2)=1
 
633
      lr=sadr(il+3+ni)
 
634
      ilr=il+3
 
635
c
 
636
      goto 10
 
637
 51   continue
 
638
c     fin "code expression logique"
 
639
c     on ajoute le code de l'op de comparaison
 
640
      il=iadr(lr)
 
641
      istk(il)=10
 
642
      istk(il+1)=1
 
643
      istk(il+2)=4
 
644
      istk(il+3)=0
 
645
      istk(il+4)=1
 
646
      l=il+9
 
647
c     type 5
 
648
      istk(l)=5
 
649
      istk(il+5)=2
 
650
      l=l+1
 
651
c     op
 
652
      ii=0
 
653
 52   ii=ii+1
 
654
      if(ii.gt.nops) then
 
655
         buf='Unmanaged operation'
 
656
         call error(999)
 
657
         return
 
658
      endif
 
659
      if(ops(ii).ne.istk(lc0+1)) goto 52
 
660
      call intstr(ii,istk(l),ni,1)
 
661
      istk(il+6)=istk(il+5)+ni
 
662
      l=l+ni
 
663
c     rhs
 
664
      istk(l)=2
 
665
      istk(il+7)=istk(il+6)+1
 
666
      l=l+1
 
667
c     lhs
 
668
      istk(l)=1
 
669
      istk(il+8)=istk(il+7)+1
 
670
      l=l+1
 
671
c
 
672
      l=sadr(l)
 
673
      istk(ilr)=istk(ilr-1)+l-lr
 
674
      lr=l
 
675
      ilr=ilr+1
 
676
c
 
677
c     on rappelle les pointeurs de la liste "if" ou "while"
 
678
      ilr=ids(1,pt)
 
679
      lr=ids(2,pt)
 
680
c     on complete la liste "if" ou "while"
 
681
      istk(ilr)=istk(ilr-1)+l-lr
 
682
      ilr=ilr+1
 
683
      lr=l
 
684
c     code du then
 
685
c     ---- on preserve les pointeurs  de la liste "if" ou "while"
 
686
      rstk(pt)=8
 
687
      ids(1,pt)=ilr
 
688
      ids(2,pt)=lr
 
689
c     on cree la liste "then"
 
690
      long=istk(lc0+3)
 
691
      ni=cmplxt(istk(lc),long)
 
692
      lcf=lc+long-1
 
693
      il=iadr(lr)
 
694
      istk(il)=15
 
695
      istk(il+1)=ni
 
696
      istk(il+2)=1
 
697
      lr=sadr(il+3+ni)
 
698
      l=lr
 
699
      ilr=il+3
 
700
      goto 10
 
701
 54   continue
 
702
c     fin du code du then
 
703
c     on rappele les pointeur de la liste "if" ou "while"
 
704
      ilr=ids(1,pt)
 
705
      lr=ids(2,pt)
 
706
c     on complete la liste  "if" ou "while"
 
707
      istk(ilr)=istk(ilr-1)+l-lr
 
708
      ilr=ilr+1
 
709
      lr=l
 
710
c     code du else
 
711
c     ---- on preserve les pointeurs  de la liste "if" ou "while"
 
712
      if(ddt.le.-1) write(6,'(a10,5i5)') 'else',pt,lcf,ilr,lr,l-lr
 
713
      rstk(pt)=9
 
714
      ids(1,pt)=ilr
 
715
      ids(2,pt)=lr
 
716
      lc0=istk(ilr)
 
717
      long=istk(lc0+4)
 
718
c     on cree la liste "else"
 
719
      ni=cmplxt(istk(lc),long)
 
720
      lcf=lc+long-1
 
721
      il=iadr(lr)
 
722
      istk(il)=15
 
723
      istk(il+1)=ni
 
724
      istk(il+2)=1
 
725
      lr=sadr(il+3+ni)
 
726
      l=lr
 
727
      ilr=il+3
 
728
      goto 10
 
729
 55   continue
 
730
c     fin du else
 
731
c     on recharge les pointeurs de la liste "if" ou "while"
 
732
      ilr=ids(1,pt)
 
733
      lr=ids(2,pt)
 
734
      pt=pt-1
 
735
c     on complete la liste "if" ou "while"
 
736
      istk(ilr)=istk(ilr-1)+l-lr
 
737
      lr=l
 
738
      ilr=ilr+1
 
739
      if(ddt.le.-1) write(6,'(a10,5i5)') 'fin else',pt,lcf,ilr,lr,l-lr
 
740
c     on recharge les pointeurs de la liste courante
 
741
      ilr=ids(1,pt)
 
742
      lr=ids(2,pt)
 
743
      lcf=istk(ilr)
 
744
c     on complete la liste "courante"
 
745
      istk(ilr)=istk(ilr-1)+l-lr
 
746
      lr=l
 
747
      ilr=ilr+1
 
748
      pt=pt-1
 
749
      if(ddt.le.-1) write(6,'(a10,5i5)') 'fin if',pt,lcf,ilr,lr,l-lr
 
750
      goto 10
 
751
c
 
752
c     select - case
 
753
 60   continue
 
754
      if(ddt.le.-1) write(6,'(a10,5i5)') 'sel',pt,lcf,ilr,lr,l-lr
 
755
      il=iadr(lr)
 
756
c     on preserve les pointeurs de la liste courante
 
757
      pt=pt+1
 
758
      rstk(pt)=10
 
759
      ids(1,pt)=ilr
 
760
      ids(2,pt)=lr
 
761
      istk(ilr)=lcf
 
762
      lc0=lc
 
763
c
 
764
c     on cree les premiers elements de la liste  "select case"
 
765
      ncase=istk(lc0+2)
 
766
      istk(il)=15
 
767
      if(istk(lc).eq.10) then
 
768
         istk(il+1)=2*ncase+3
 
769
      else
 
770
         istk(il+1)=2*ncase+2
 
771
      endif
 
772
      istk(il+2)=1
 
773
      ilr=il+3
 
774
      lr=sadr(ilr+istk(il+1))
 
775
c
 
776
      il=iadr(lr)
 
777
      istk(il)=10
 
778
      istk(il+1)=1
 
779
      istk(il+2)=1
 
780
      istk(il+3)=0
 
781
      istk(il+4)=1
 
782
      l=il+6
 
783
      if(istk(lc).eq.8) then
 
784
c     type if
 
785
         call icopy(2,iff,1,istk(l),1)
 
786
         istk(il+5)=istk(il+4)+2
 
787
         l=l+2
 
788
      elseif(istk(lc).eq.9) then
 
789
c     type while
 
790
         call icopy(5,while,1,istk(l),1)
 
791
         istk(il+5)=istk(il+4)+5
 
792
         l=l+5
 
793
      elseif(istk(lc).eq.10) then
 
794
c     type select
 
795
         call icopy(6,sel,1,istk(l),1)
 
796
         istk(il+5)=istk(il+4)+6
 
797
         l=l+6
 
798
      endif
 
799
c
 
800
      l=sadr(l)
 
801
      istk(ilr)=istk(ilr-1)+l-lr
 
802
      ilr=ilr+1
 
803
      lr=l
 
804
      lc=lc+4
 
805
c
 
806
c     premiere expression 
 
807
c
 
808
      il=iadr(lr)
 
809
 
 
810
c     ---- on preserve les pointeurs  de la liste  "select case"
 
811
      pt=pt+1
 
812
      if(pt.gt.psiz) then
 
813
         call error(26)
 
814
         return
 
815
      endif
 
816
      rstk(pt)=11
 
817
      ids(1,pt)=ilr
 
818
      ids(2,pt)=lr
 
819
      istk(ilr)=lc
 
820
      long=istk(lc0+3)
 
821
      lcf=lc+long-1
 
822
 
 
823
c     ----   ----   ----   ----   ----  --
 
824
      icase=ncase+1
 
825
      if(istk(lc0).ne.10) goto 62
 
826
c
 
827
c     on cree la liste "code premiere expression"
 
828
      ni=cmplxt(istk(lc),long)
 
829
      istk(il)=15
 
830
      istk(il+1)=ni
 
831
      istk(il+2)=1
 
832
      lr=sadr(il+3+ni)
 
833
      ilr=il+3
 
834
c
 
835
      goto 10
 
836
 61   continue
 
837
c     fin "code premiere expression"
 
838
c     on rappelle les pointeurs de la liste  "select case"
 
839
      ilr=ids(1,pt)
 
840
      lr=ids(2,pt)
 
841
c     on complete la liste  "select case"
 
842
      istk(ilr)=istk(ilr-1)+l-lr
 
843
      ilr=ilr+1
 
844
      lr=l
 
845
c
 
846
c
 
847
 62   continue
 
848
c
 
849
      if(ddt.le.-1) write(6,'(a10,5i5)') 'case',pt,lcf,ilr,lr,l-lr
 
850
      icase=icase-1
 
851
      istk(ilr+1)=icase
 
852
c
 
853
c     code de l'expression du case
 
854
c     ---- on preserve les pointeurs  de la liste  "select case"
 
855
      rstk(pt)=12
 
856
      ids(1,pt)=ilr
 
857
      ids(2,pt)=lr
 
858
c     on cree la liste "case"
 
859
      long=istk(lc)
 
860
      lc=lc+1
 
861
      ni=cmplxt(istk(lc),long)
 
862
      lcf=lc+long-1
 
863
      il=iadr(lr)
 
864
      istk(il)=15
 
865
      istk(il+1)=ni
 
866
      istk(il+2)=1
 
867
      lr=sadr(il+3+ni)
 
868
      l=lr
 
869
      ilr=il+3
 
870
      goto 10
 
871
 63   continue
 
872
c     fin du code de l'expression du case
 
873
c     on rappele les pointeur de la liste  "select case"
 
874
      ilr=ids(1,pt)
 
875
      lr=ids(2,pt)
 
876
c     on complete la liste "select case"
 
877
      istk(ilr)=istk(ilr-1)+l-lr
 
878
      ilr=ilr+1
 
879
      lr=l
 
880
 
 
881
 
 
882
c     code du then 
 
883
c     ---- on preserve les pointeurs  de la liste  "select case"
 
884
      rstk(pt)=13
 
885
      ids(1,pt)=ilr
 
886
      ids(2,pt)=lr
 
887
      long=istk(lc)
 
888
      lc=lc+1
 
889
c     on cree la liste "then"
 
890
      ni=cmplxt(istk(lc),long)
 
891
      lcf=lc+long-1
 
892
      il=iadr(lr)
 
893
      istk(il)=15
 
894
      istk(il+1)=ni
 
895
      istk(il+2)=1
 
896
      lr=sadr(il+3+ni)
 
897
      l=lr
 
898
      ilr=il+3
 
899
      goto 10
 
900
 64   continue
 
901
c     fin du then
 
902
c     on recharge les pointeurs de la liste  "select case"
 
903
      ilr=ids(1,pt)
 
904
      lr=ids(2,pt)
 
905
      icase=istk(ilr)
 
906
c     on complete la liste  "select case"
 
907
      istk(ilr)=istk(ilr-1)+l-lr
 
908
      lr=l
 
909
      ilr=ilr+1
 
910
      if(ddt.le.-1) write(6,'(a10,5i5)') 'fin case',pt,lcf,ilr,lr,l-lr
 
911
c
 
912
      if(icase.gt.1) goto 62
 
913
      lc=lc+1
 
914
c     code du else
 
915
      if(ddt.le.-1) write(6,'(a10,5i5)') 'else',pt,lcf,ilr,lr,l-lr
 
916
c     ---- on preserve les pointeurs  de la liste  "select case"
 
917
      rstk(pt)=14
 
918
      ids(1,pt)=ilr
 
919
      ids(2,pt)=lr
 
920
      long=istk(lc)
 
921
      lc=lc+1
 
922
c     on cree la liste "else"
 
923
      ni=cmplxt(istk(lc),long)
 
924
      if(long.eq.0) lc=lc+1
 
925
      lcf=lc+long-1
 
926
      il=iadr(lr)
 
927
      istk(il)=15
 
928
      istk(il+1)=ni
 
929
      istk(il+2)=1
 
930
      lr=sadr(il+3+ni)
 
931
      l=lr
 
932
      ilr=il+3
 
933
      goto 10
 
934
 65   continue
 
935
c     fin du else
 
936
c     on recharge les pointeurs de la liste  "select case"
 
937
      ilr=ids(1,pt)
 
938
      lr=ids(2,pt)
 
939
      pt=pt-1
 
940
c     on complete la liste  "select case"
 
941
      istk(ilr)=istk(ilr-1)+l-lr
 
942
      lr=l
 
943
      ilr=ilr+1
 
944
      if(ddt.le.-1) write(6,'(a10,5i5)') 'fin else',pt,lcf,ilr,lr,l-lr
 
945
c     on recharge les pointeurs de la liste courante
 
946
      ilr=ids(1,pt)
 
947
      lr=ids(2,pt)
 
948
      lcf=istk(ilr)
 
949
c     on complete la liste "courante"
 
950
      istk(ilr)=istk(ilr-1)+l-lr
 
951
      lr=l
 
952
      ilr=ilr+1
 
953
      pt=pt-1
 
954
      if(ddt.le.-1) write(6,'(a10,5i5)') 'fin sel',pt,lcf,ilr,lr,l-lr
 
955
      goto 10
 
956
c   
 
957
 80   continue
 
958
      fptr=op+istk(lc+3)
 
959
      call funtab(id,fptr,2)
 
960
 
 
961
      il=iadr(lr)
 
962
      istk(il)=10
 
963
      istk(il+1)=1
 
964
      istk(il+2)=4
 
965
      istk(il+3)=0
 
966
      istk(il+4)=1
 
967
      l=il+9
 
968
c     type 20
 
969
      istk(l)=2
 
970
      istk(l+1)=0
 
971
      istk(il+5)=3
 
972
      l=l+2
 
973
c     nom de la variable
 
974
      call namstr(id,istk(l),ni,1)
 
975
      istk(il+6)=istk(il+5)+ni
 
976
      l=l+ni
 
977
c     rhs
 
978
      call intstr(istk(lc+1),istk(l),ni,1)
 
979
      istk(il+7)=istk(il+6)+ni
 
980
      l=l+ni
 
981
c     lhs
 
982
      call intstr(istk(lc+2),istk(l),ni,1)
 
983
      istk(il+8)=istk(il+7)+ni
 
984
      l=l+ni
 
985
c
 
986
      l=sadr(l)
 
987
      istk(ilr)=istk(ilr-1)+l-lr
 
988
      lr=l
 
989
      ilr=ilr+1
 
990
c
 
991
      lc=lc+4
 
992
      goto 10
 
993
c     
 
994
c     pause,break,abort,eol
 
995
 90   continue
 
996
      il=iadr(lr)
 
997
      istk(il)=10
 
998
      istk(il+1)=1
 
999
      istk(il+2)=1
 
1000
      istk(il+3)=0
 
1001
      istk(il+4)=1
 
1002
      l=il+6
 
1003
c     type >=12
 
1004
      call intstr(op,istk(l),nw,0)
 
1005
      istk(il+5)=3
 
1006
      l=l+2
 
1007
c
 
1008
      l=sadr(l)
 
1009
      istk(ilr)=istk(ilr-1)+l-lr
 
1010
      lr=l
 
1011
      ilr=ilr+1
 
1012
c
 
1013
      lc=lc+1
 
1014
      goto 10
 
1015
c
 
1016
 100  continue
 
1017
c     info sur numero de lignes
 
1018
      lc=lc+2
 
1019
      goto 10
 
1020
c
 
1021
 101  continue
 
1022
c     mark named variable
 
1023
      il=iadr(lr)
 
1024
      istk(il)=10
 
1025
      istk(il+1)=1
 
1026
      istk(il+2)=2
 
1027
      istk(il+3)=0
 
1028
      istk(il+4)=1
 
1029
      l=il+7
 
1030
c     type 18
 
1031
      istk(l)=1
 
1032
      istk(l+1)=8
 
1033
      istk(il+5)=3
 
1034
      l=l+2
 
1035
c     nom de la variable
 
1036
      call namstr(istk(lc+1),istk(l),ni,1)
 
1037
      istk(il+6)=istk(il+5)+ni
 
1038
      l=l+ni
 
1039
c     
 
1040
      l=sadr(l)
 
1041
      istk(ilr)=istk(ilr-1)+l-lr
 
1042
      lr=l
 
1043
      ilr=ilr+1
 
1044
c     
 
1045
      lc=lc+1+nsiz
 
1046
      goto 10
 
1047
 
 
1048
 102  continue
 
1049
c     mkindx
 
1050
      il=iadr(lr)
 
1051
      istk(il)=10
 
1052
      istk(il+1)=1
 
1053
      istk(il+2)=3
 
1054
      istk(il+3)=0
 
1055
      istk(il+4)=1
 
1056
      l=il+8
 
1057
c     type 19
 
1058
      istk(l)=1
 
1059
      istk(l+1)=9
 
1060
      istk(il+5)=3
 
1061
      l=l+2
 
1062
 
 
1063
c     n
 
1064
      call intstr(istk(lc+1),istk(l),ni,1)
 
1065
      istk(il+6)=istk(il+5)+ni
 
1066
      l=l+ni
 
1067
c     m
 
1068
      call intstr(istk(lc+2),istk(l),ni,1)
 
1069
      istk(il+7)=istk(il+6)+ni
 
1070
      l=l+ni
 
1071
c
 
1072
      l=sadr(l)
 
1073
      istk(ilr)=istk(ilr-1)+l-lr
 
1074
      lr=l
 
1075
      ilr=ilr+1
 
1076
c
 
1077
      lc=lc+3
 
1078
      goto 10
 
1079
 
 
1080
 103  continue
 
1081
c     begrhs
 
1082
      lc=lc+1
 
1083
      goto 10
 
1084
 
 
1085
 104  continue
 
1086
c     printmode (ignored)
 
1087
      lc=lc+2
 
1088
      goto 10
 
1089
c
 
1090
 105  continue
 
1091
c     name2var
 
1092
      il=iadr(lr)
 
1093
      istk(il)=10
 
1094
      istk(il+1)=1
 
1095
      istk(il+2)=2
 
1096
      istk(il+3)=0
 
1097
      istk(il+4)=1
 
1098
      l=il+7
 
1099
c     type 23
 
1100
      istk(l)=2
 
1101
      istk(l+1)=3
 
1102
      istk(il+5)=3
 
1103
      l=l+2
 
1104
c     nom de la variable
 
1105
      call namstr(istk(lc+1),istk(l),ni,1)
 
1106
      istk(il+6)=istk(il+5)+ni
 
1107
      l=l+ni
 
1108
c     
 
1109
      l=sadr(l)
 
1110
      istk(ilr)=istk(ilr-1)+l-lr
 
1111
      lr=l
 
1112
      ilr=ilr+1
 
1113
c     
 
1114
      lc=lc+1+nsiz
 
1115
      goto 10
 
1116
c
 
1117
106   continue
 
1118
      il=iadr(lr)
 
1119
      istk(il)=10
 
1120
      istk(il+1)=1
 
1121
      istk(il+2)=1
 
1122
      istk(il+3)=0
 
1123
      istk(il+4)=1
 
1124
      l=il+6
 
1125
c     type 24
 
1126
      istk(l)=2
 
1127
      istk(l+1)=4
 
1128
      istk(il+5)=3
 
1129
      l=l+2
 
1130
c
 
1131
      l=sadr(l)
 
1132
      istk(ilr)=istk(ilr-1)+l-lr
 
1133
      lr=l
 
1134
      ilr=ilr+1
 
1135
c
 
1136
      lc=lc+1
 
1137
      goto 10
 
1138
c
 
1139
107   continue
 
1140
c     profile
 
1141
      il=iadr(lr)
 
1142
      istk(il)=10
 
1143
      istk(il+1)=1
 
1144
      istk(il+2)=3
 
1145
      istk(il+3)=0
 
1146
      istk(il+4)=1
 
1147
      l=il+8
 
1148
c     type 25
 
1149
      istk(l)=2
 
1150
      istk(l+1)=5
 
1151
      istk(il+5)=3
 
1152
      l=l+2
 
1153
c
 
1154
c     n
 
1155
      call intstr(istk(lc+1),istk(l),ni,1)
 
1156
      istk(il+6)=istk(il+5)+ni
 
1157
      l=l+ni
 
1158
c     m
 
1159
      call intstr(istk(lc+2),istk(l),ni,1)
 
1160
      istk(il+7)=istk(il+6)+ni
 
1161
      l=l+ni
 
1162
 
 
1163
      l=sadr(l)
 
1164
      istk(ilr)=istk(ilr-1)+l-lr
 
1165
      lr=l
 
1166
      ilr=ilr+1
 
1167
c
 
1168
      lc=lc+3
 
1169
      goto 10
 
1170
c
 
1171
 108  continue
 
1172
c     vector of string
 
1173
      n=istk(lc+1)*istk(lc+2)
 
1174
      il=iadr(lr)
 
1175
      istk(il)=10
 
1176
      istk(il+1)=1
 
1177
      istk(il+2)=3+n
 
1178
      istk(il+3)=0
 
1179
      istk(il+4)=1
 
1180
      l=il+5+(3+n)
 
1181
c     type 26
 
1182
      istk(l)=2
 
1183
      istk(l+1)=6
 
1184
      istk(il+5)=3
 
1185
      l=l+2
 
1186
c
 
1187
c     n
 
1188
      call intstr(istk(lc+1),istk(l),ni,1)
 
1189
      istk(il+6)=istk(il+5)+ni
 
1190
      l=l+ni
 
1191
c     m
 
1192
      call intstr(istk(lc+2),istk(l),ni,1)
 
1193
      istk(il+7)=istk(il+6)+ni
 
1194
      l=l+ni
 
1195
 
 
1196
      nc=istk(lc+4+n)-1
 
1197
      do 109 ii=1,n
 
1198
         istk(il+7+ii)=istk(il+6+ii)+istk(lc+4+ii)-istk(lc+3+ii)
 
1199
 109  continue
 
1200
      call icopy(nc,istk(lc+5+n),1,istk(l),1)
 
1201
      l=l+nc
 
1202
 
 
1203
      l=sadr(l)
 
1204
      istk(ilr)=istk(ilr-1)+l-lr
 
1205
      lr=l
 
1206
      ilr=ilr+1
 
1207
c
 
1208
      lc=lc+5+n+nc
 
1209
      goto 10
 
1210
 
 
1211
 
 
1212
  120 format('(f',i2,'.',i2,')')
 
1213
  130 format('(1pd',i2,'.',i2,')')
 
1214
 
 
1215
c     
 
1216
      end
 
1217