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
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
|
subroutine run
c ========================================================================
C Execution of a compiled macro
c ========================================================================
c
c Copyright INRIA
include '../stack.h'
c
double precision x
integer op,equal,r,ix(2),m
equivalence (x,ix(1))
logical logops,ok,iflag,istrue,ptover,cremat,cresmat,
$ vcopyobj
integer p,lr,nlr,lcc,id(nsiz)
integer extrac,insert,semi
common /basbrk/ iflag
integer otimer,ntimer,stimer,ismenu,getendian
integer tref,t,fclock
integer iadr,sadr
external stimer,ismenu,getendian
save otimer
data extrac /3/,insert/2/,semi/43/
data otimer/0/
data equal/50/
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
tref = 0
itime = 10000
call xscion(inxsci)
if (ddt .eq. 4) then
write(buf(1:8),'(2i4)') pt,rstk(pt)
call basout(io,wte,' run pt:'//buf(1:4)//' rstk(pt):'
& //buf(5:8))
endif
c
l0=0
nc=0
c
if ( ptover(0,psiz-2)) return
c
r=rstk(pt)
ir=r/100
if(ir.ne.6) goto 01
goto(33,66,82,92,58,116),r-600
c
c debut d'une macro compilee
01 continue
tref=fclock()
toperr=top
k=lpt(1)-(13+nsiz)
lc=lin(k+7)
c
10 if(err.gt.0) return
if(iflag) then
iflag=.false.
goto 91
endif
if(err1.ne.0) then
c . errcatch in exec(function,'errrcatch')
if(rstk(pt-1).eq.909) return
endif
if(lc-l0.ne.nc) goto 11
r=rstk(pt)-610
goto(46,47,52,56,57,61),r
c
c nouvelle 'operation'
11 continue
op=istk(lc)
goto(20, 25, 40, 42, 30, 41, 45, 49, 49, 55,
& 15, 90, 95, 100,105,110,120,130,140,150,
& 160,170,180,190,200,210) ,op
c matfns
if(op.ge.100) goto 80
c return
if(op.eq.99) then
c le return s'est-il produit dans un for (si oui il faut depiler la variable
c de boucle
p=pt+1
12 p=p-1
if(rstk(p).eq.612) then
top=top-1
goto 12
else if(rstk(p).ne.501) then
goto 12
endif
13 fin = 2
goto 998
endif
c
if(op.eq.0) then
c nop
lc=lc+istk(lc+1)
goto 11
endif
15 continue
call error(60)
return
c
20 continue
call stackp(istk(lc+1),0)
c store info if printing is required see code 22
call putid(id,istk(lc+1))
kid=fin
lc=lc+1+nsiz
goto 10
c
25 fin=istk(lc+nsiz+1)
rhs=istk(lc+nsiz+2)
26 call stackg(istk(lc+1))
if(err.gt.0) then
lc=lc+nsiz+3
goto 10
endif
if(fin.ne.0) goto 28
call funs(istk(lc+1))
if(err.gt.0) return
if(fun.ne.-2) then
call putid(ids(1,pt+1),istk(lc+1))
if(fun.eq.0) then
call error(4)
else
c . referenced name was function at compile time it is now a
c . primitive. Modify the code for further use
c . change current opcode to nop
istk(lc)=0
istk(lc+1)=nsiz+3
lc=lc+nsiz+3
c . change the following to matfn
op=fun*100
istk(lc)=op
istk(lc+1)=istk(lc+2)-1
istk(lc+2)=istk(lc+3)
istk(lc+3)=fin
goto 80
c call error(110)
endif
lc=lc+nsiz+3
goto 10
endif
fin=istk(lc+nsiz+1)
goto 26
28 lc=lc+nsiz+3
if(fin.gt.0) goto 65
goto 10
c
c allops
30 fin=istk(lc+1)
rhs=istk(lc+2)
lhs=istk(lc+3)
lc=lc+4
if(fin.eq.extrac.or.fin.eq.insert) call adjustrhs
pt=pt+1
rstk(pt)=601
ids(1,pt)=tref
c following lines have been suppressed accordint to a modifiction in
c intl_i 22/08/00
c if(istk(lc).eq.1) then
c . if next op is stackp put name in ids for insertion
c call putid(ids(1,pt),istk(lc+1))
c endif
icall=4
pstk(pt)=lc
c *call* allops
return
33 continue
tref=ids(1,pt)
lc=pstk(pt)
pt=pt-1
goto 70
c
c string
40 n=istk(lc+1)
if(err1.le.0) then
top=top+1
if (cresmat("run",top,1,1,n)) then
call getsimat("run",top,top,mm1,nn1,1,1,lr,nlr)
call icopy(n,istk(lc+2),1,istk(lr),1)
endif
endif
lc=lc+n+2
goto 10
c
c num
41 if(err1.le.0) then
if(getendian().eq.1) then
ix(1)=istk(lc+1)
ix(2)=istk(lc+2)
else
ix(2)=istk(lc+1)
ix(1)=istk(lc+2)
endif
top=top+1
if (cremat("run",top,0,1,1,lr,lcc)) then
stk(lr)=x
endif
endif
lc=lc+3
goto 10
c
42 call defmat
lc=lc+1
goto 10
c
c for
45 nc=istk(lc+1)
lc=lc+2
l0=lc
if ( ptover(1,psiz)) then
lc=lc+nc
lc=lc+nsiz+istk(lc)
goto 10
endif
rstk(pt)=611
ids(1,pt)=l0
ids(2,pt)=nc
goto 10
c
46 nc=istk(lc)
l0=lc+1+nsiz
rstk(pt)=612
pstk(pt)=0
ids(1,pt)=l0
ids(2,pt)=lct(8)
ids(3,pt)=top
ids(4,pt)=toperr
toperr=top
47 lc=l0
if(top.ne.ids(3,pt)) then
call error(115)
return
endif
call nextj(istk(l0-nsiz),pstk(pt))
if(pstk(pt).ne.0) then
lct(8)=ids(2,pt)
if (inxsci.eq.1) then
ntimer=stimer()/itime
if (ntimer.ne.otimer) then
call sxevents()
otimer=ntimer
if (ismenu().eq.1) goto 115
endif
endif
goto 10
endif
c fin for
lc=lc+nc
toperr=ids(4,pt)
pt=pt-1
goto 70
c
c if - while (Anciennes versions maintenue pour compatibilite)
49 continue
li=lc
if(istk(li+1).lt.0) goto 55
if ( ptover(1,psiz)) then
lc=lc+1+istk(lc+2)+istk(lc+3)+istk(lc+4)
goto 10
endif
c evaluation de l'expression logique
nc=istk(li+2)
lc=li+5
pstk(pt)=lct(8)
51 kc=0
rstk(pt)=613
ids(1,pt)=li
l0=lc
ids(2,pt)=kc
ids(3,pt)=toperr
goto 10
c
52 if(kc.eq.0) then
lhs=0
toperr=top
if(istk(li+1).gt.0) then
c cet appel permet de garder la compatibilite avec les macro compilees
c precedemment a l'existence des booleens.
ok=logops(istk(li+1))
else
ok=istrue(1)
endif
if(ok) then
c evaluation des instructions du then
lct(8)=pstk(pt)
nc=istk(li+3)
kc=1
else
nc=istk(li+4)
lc=lc+istk(li+3)
kc=2
endif
l0=lc
ids(2,pt)=kc
goto 10
endif
c
if(kc.ne.2.and.istk(li).eq.9) goto 51
lct(8)=pstk(pt)
toperr=ids(3,pt)
lc=li+5+istk(li+2)
lc=lc+istk(li+3)+istk(li+4)
pt=pt-1
goto 70
c
c select - case ou nouveau "if elseif else end"
55 continue
if ( ptover(1,psiz)) then
lc=lc+abs(istk(lc+1))
goto 10
endif
pstk(pt)=lc
ids(3,pt)=toperr
c
if(istk(lc+1).gt.0) then
c premiere expression
nc=istk(lc+3)
rstk(pt)=614
lc=lc+4
l0=lc
ids(1,pt)=l0
ids(2,pt)=nc
goto 10
else
lc=lc+4
endif
c
c expri
56 continue
if(istk(pstk(pt)).eq.10) then
c recopie de la premiere expression
if (.not.vcopyobj("run",top,top+1)) return
top=top+1
endif
c
nc=istk(lc)
rstk(pt)=615
lc=lc+1
l0=lc
ids(1,pt)=l0
ids(2,pt)=nc
goto 10
c
c instructions i
57 continue
if(nc.eq.0) then
c si nc=0 l'instruction i correspond a l'isntruction associee au else
ok=.true.
if(istk(pstk(pt)).eq.10) top=top-1
goto 59
elseif(istk(pstk(pt)).ne.10) then
ok=istrue(1)
if(err.gt.0) return
goto 59
endif
pt=pt+1
fin=equal
rhs=2
lhs=1
rstk(pt)=605
icall=4
pstk(pt)=lc
ids(1,pt)=tref
c *call* allops(equal)
return
c
58 continue
lc=pstk(pt)
tref=ids(1,pt)
pt=pt-1
ok=istrue(1)
if(err.gt.0) return
59 nc=istk(lc)
toperr=top
if(ok) then
lc=lc+1
if(istk(pstk(pt)).eq.10) top=top-1
l0=lc
ids(1,pt)=l0
ids(2,pt)=nc
rstk(pt)=616
if (inxsci.eq.1) then
ntimer=stimer()/itime
if (ntimer.ne.otimer) then
call sxevents()
otimer=ntimer
if (ismenu().eq.1) goto 115
endif
endif
goto 10
else
if(istk(pstk(pt)).eq.9) goto 62
lc=lc+nc+1
goto 56
endif
c
61 continue
c fin if while select/case
l0=pstk(pt)
if(istk(pstk(pt)).eq.9) then
lc=l0+4
goto 56
endif
62 l0=pstk(pt)
lc=l0+abs(istk(l0+1))
toperr=ids(3,pt)
pt=pt-1
goto 70
c
c macro
65 rhs=max(istk(lc+2)-1,0)
call adjustrhs
lhs=istk(lc+3)
c
lc=lc+4
c
if ( ptover(1,psiz)) goto 10
rstk(pt)=602
pstk(pt)=lc
ids(1,pt)=wmac
ids(2,pt)=tref
icall=5
fun=0
c *call* macro
return
66 lc=pstk(pt)
wmac=ids(1,pt)
tref=ids(2,pt)
pt=pt-1
goto 70
c
70 continue
if (inxsci.eq.1) then
ntimer=stimer()/itime
if (ntimer.ne.otimer) then
call sxevents()
otimer=ntimer
if (ismenu().eq.1) goto 115
endif
endif
r=rstk(pt)-610
goto(74,71,72,73,73,73) ,r
goto 10
c retour d'une boucle interne ou d'une macro vers un for
71 j=pstk(pt)
l0=ids(1,pt)
nc=istk(l0-1-nsiz)
goto 10
c retour d'une boucle interne ou d'une macro vers un if/while
72 li=ids(1,pt)
kc=ids(2,pt)
nc=istk(li+2)
l0=li+5
if(kc.eq.0) goto 10
l0=l0+nc
nc=istk(li+3)
if(kc.eq.1) goto 10
l0=l0+nc
nc=istk(li+4)
goto 10
c retour d'une boucle interne vers une clause select
73 l0=ids(1,pt)
nc=ids(2,pt)
goto 10
c
74 l0=ids(1,pt)
nc=ids(2,pt)
goto 10
c
80 fun=op/100
rhs=istk(lc+1)
call adjustrhs
lhs=istk(lc+2)
fin=istk(lc+3)
lc=lc+4
c
81 pt=pt+1
rstk(pt)=603
pstk(pt)=lc
icall=9
ids(2,pt)=0
ids(3,pt)=tref
c *call* matfns
return
82 continue
lc=pstk(pt)
tref=ids(3,pt)
pt=pt-1
if(ids(2,pt+1).eq.0) goto 70
c fin resume
lhs=ids(2,pt+1)
goto 999
c
c pause
90 lc=lc+1
91 continue
if ( ptover(1,psiz)) goto 10
pstk(pt)=rio
rio=rte
fin=2
if(lct(4).le.-10) then
fin=-1
lct(4)=-lct(4)-11
endif
ids(1,pt)=lc
ids(2,pt)=top
ids(3,pt)=tref
rstk(pt)=604
icall=5
c *call* macro
return
92 lc=ids(1,pt)
top=ids(2,pt)
tref=ids(3,pt)
rio=pstk(pt)
pt=pt-1
goto 70
c
c break
95 continue
pt=pt+1
96 pt=pt-1
if(pt.eq.0) then
lc=lc+1
goto 10
endif
if(rstk(pt).eq.612) then
c break dans un for
l0=ids(1,pt)
lc=l0+istk(l0-1-nsiz)
pt=pt-1
top=top-1
goto 70
elseif(rstk(pt).eq.616.and.istk(pstk(pt)).eq.9) then
c break dans un while
l0=pstk(pt)
lc=l0+abs(istk(l0+1))
pt=pt-1
goto 70
else
goto 96
endif
c
c abort
100 continue
pt=pt+1
101 pt=pt-1
if(pt.eq.0) goto 102
if(int(rstk(pt)/100).eq.5) then
k = lpt(1) - (13+nsiz)
lpt(1) = lin(k+1)
lpt(2) = lin(k+2)
lpt(3) = lin(k+3)
lpt(4) = lin(k+4)
lct(4) = lin(k+6)
lpt(6) = k
if(rstk(pt).le.502) bot=lin(k+5)
endif
goto 101
102 continue
icall=10
top=0
comp(1)=0
if(niv.gt.1) err=9999999
return
c
105 continue
c eol
c la gestion de la recuperation des erreurs devrait plutot se trouver
c a la fin de l'instruction (mais il n'y a pas actuellement d'indicateur
c de fin d'instruction dans les macros
if(err1.ne.0) then
if(err2.eq.0) err2=err1
err1=0
imode=abs(errct/100000)
if(imode-8*int(imode/8).eq.2) iflag=.true.
endif
c gestion des points d'arrets dynamiques
if(wmac.ne.0) then
do 106 ibpt=lgptrs(wmac),lgptrs(wmac+1)-1
if(lct(8).eq.bptlg(ibpt)) then
call cvname(macnms(1,wmac),buf(1:nlgh),1)
write(buf(nlgh+2:nlgh+7),'(i5)') lct(8)
call msgs(32,0)
iflag=.true.
goto 107
endif
106 continue
endif
107 continue
c
if (mod(lct(4)/2,2).eq.1) then
call prompt(lct(4)/4)
endif
c
lct(8)=lct(8)+1
lc=lc+1
if (inxsci.eq.1) then
ntimer=stimer()/itime
if (ntimer.ne.otimer) then
call sxevents()
otimer=ntimer
if (ismenu().eq.1) goto 115
endif
endif
goto 10
c
c set line number. Au debut de chaque expression liee a un then et a
c la fin de chaque clause, le compilateur (compcl) inscrit
c la valeur de la ligne. ceci permet de mettre rapidement a jour le
c compteur de ligne sans avoir a analyser la suite des codes operatoires
110 continue
lct(8)=istk(lc+1)
lc=lc+2
goto 10
c
c gestion des evements asynchrones "interpretes"
c
115 continue
call getmen(buf,lb,nentry)
call bexec(buf(1:lb),lb,ierr)
if(ierr.ne.0) goto 10
pt=pt+1
ids(1,pt)=lc
ids(2,pt)=l0
ids(3,pt)=nc
ids(4,pt)=tref
rstk(pt)=606
icall=5
c *call* macro
return
116 lc=ids(1,pt)
l0=ids(2,pt)
nc=ids(3,pt)
tref=ids(4,pt)
top=top-1
pt=pt-1
r=rstk(pt)-610
goto(74,71,72,73,73,73) ,r
goto 10
c
c quit
c
120 continue
fun=99
return
c
c named variable
c
130 continue
infstk(top)=1
call putid(idstk(1,top),istk(lc+1))
lc=lc+1+nsiz
goto 10
c
c form recursive extraction list
c
140 continue
m=istk(lc+2)
if(rstk(pt).eq.617) then
c run time arg count (list extraction)
m=m+pstk(pt)
pstk(pt)=0
endif
call mkindx(istk(lc+1),m)
lc=lc+3
goto 10
c
c exit
c
150 continue
lc=lc+1
if (niv.gt.0) then
call sciquit
stop
endif
fun = 99
goto 10
c
c begrhs
c
160 continue
lc=lc+1
pt=pt+1
rstk(pt)=617
pstk(pt)=0
goto 10
c
c printmode
c
170 continue
c print stored variable
if(lct(4).ge.0.and.istk(lc+1).ne.semi.and.kid.ne.0) then
call print(id,kid,wte)
endif
lc=lc+2
goto 10
180 continue
c name2var
call name2var(istk(lc+1))
lc=lc+nsiz+1
goto 10
c
190 continue
c deffnull
lc=lc+1
top=top+1
call objvide(' ', top)
goto 10
c
200 continue
c profile
istk(lc+1)=istk(lc+1)+1
t=fclock()
istk(lc+2)=istk(lc+2)+t-tref
tref=t
lc=lc+3
goto 10
c
210 continue
c character string vector
if(err1.le.0) then
n=istk(lc+1)*istk(lc+2)
nc=istk(lc+4+n)-1
top=top+1
il=iadr(lstk(top))
err=sadr(il+5+n+nc)-lstk(bot)
if(err.gt.0) then
call error(17)
return
endif
call icopy(5+n+nc,istk(lc),1,istk(il),1)
istk(il)=10
lstk(top+1)=sadr(il+5+n+nc)
endif
lc=lc+5+n+nc
goto 10
c
998 continue
lhs=0
999 continue
if(rstk(pt).ne.501) then
pt=pt-1
goto 999
endif
fun=0
return
c
end
subroutine adjustrhs
include '../stack.h'
c adjust rhs
if(rstk(pt).eq.617) then
rhs=rhs+pstk(pt)
pt=pt-1
elseif(rstk(pt).eq.501) then
c retained for 2.4.1 compatiblity
rhs=rhs+ids(5,pt)
ids(5,pt)=0
endif
return
end
|
