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
|
subroutine showstack()
c -------------------------
c this routines handle display of calling tree
c!
c Copyright INRIA
c Revised and corrected by Francois VOGEL, July 2004 (bug 908)
include '../stack.h'
c
integer sadr
c
character mg*9
integer lunit,lpt1(6),top1,rios
integer l1,ilk,m,lk,km,k,ll,r,p
logical first
data mg /' ! '/
c
sadr(l)=(l/2)+1
c
ll=lct(5)
first=.true.
lunit=wte
top1=top
call icopy(6,lpt,1,lpt1,1)
lct4=lct(4)
rios=rio
c
m1=lpt(2)-lpt(1)
if(m1.lt.1) m1=1
c
if(macr.eq.0.and.rio.eq.rte) goto 1000
call whatln(lpt(1),lpt(2),lpt(6),nlc,l1,ifin)
m=ifin-l1+1
if(m.gt.ll) then
l1=max(l1,lpt(2)-ll/2)
m=min(ifin-l1,ll)
endif
m1=lpt(2)-l1
if(m.gt.0) then
call cvstr(m,lin(l1),buf,1)
call basout(io,lunit,buf(1:max(m,1)))
endif
1000 buf=' '
buf(m1+1:m1+9)=mg
call basout(io,lunit,buf(1:m1+9))
c depilement de l'environnement
lct(4)=2
p=pt+1
1501 p=p-1
if(p.eq.0) goto 1510
r=rstk(p)
goto(1502,1502,1504) r-500
goto 1501
c
c on depile une function
1502 k=lpt1(1)-(13+nsiz)
lpt1(1)=lin(k+1)
lpt1(2)=lin(k+2)
lpt1(6)=k
c
c recherche du nom de la function correspondant a ce niveau
lk=sadr(lin(k+6))
if(lk.le.lstk(top1+1)) then
km=0
else
km=lin(k+5)-1
endif
1503 km=km+1
if(km.gt.isiz)goto 1513
if(lstk(km).ne.lk) goto 1503
c
1513 continue
ilk=lin(k+6)
if(istk(ilk).ne.10) then
if(first) then
buf='at line '
m=11
first=.false.
nlc=0
else
buf='line '
m=6
call whatln(lpt1(1),lpt1(2),lpt1(6),nlc,l1,ifin)
endif
write(buf(m+1:m+5),'(i4)') lct(8)-nlc
m=m+4
buf(m+1:m+18)=' of function '
m=m+13
if (km.le.isiz) call cvname(idstk(1,km),buf(m+1:m+nlgh),1)
m=m+nlgh
else
buf='in execstr instruction'
m=26
endif
buf(m+1:m+14)=' called by :'
m=m+14
call basout(io,lunit,buf(1:m))
lct(8)=lin(k+12+nsiz)
c
call whatln(lpt1(1),lpt1(2),lpt1(6),nlc,l1,ifin)
m=ifin-l1+1
if(m.gt.ll) then
l1=max(l1,lpt1(2)-ll/2)
m=min(ifin-l1,ll)
endif
if(l1.gt.0.and.m.gt.0.and.m+l1-1.le.lsiz) then
call cvstr(m,lin(l1),buf(1:m),1)
call basout(io,lunit,buf(1:m))
endif
c
goto 1501
c
c on depile un exec ou une pause
1504 if(rio.ne.rte) then
c exec
k=lpt1(1)-(13+nsiz)
lpt1(1)=lin(k+1)
lpt1(2)=lin(k+4)
lpt1(6)=k
c
if(first) then
buf='at line '
m=11
first=.false.
nlc=0
else
buf='line '
m=6
endif
write(buf(m+1:m+5),'(i4)') lct(8)-nlc
m=m+4
buf(m+1:m+29)=' of exec file called by :'
m=m+29
call basout(io,lunit,buf(1:m))
lct(8)=lin(k+12+nsiz)
c
call whatln(lpt1(1),lpt1(2),lpt1(6),nlc,l1,ifin)
m=ifin-l1+1
if(m.gt.ll) then
l1=max(l1,lpt1(2)-ll/2)
m=min(ifin-l1,ll)
endif
call cvstr(m,lin(l1),buf,1)
call basout(io,lunit,buf(1:m))
1505 p=p-1
if(rstk(p).ne.902) goto 1505
rio=pstk(p)
goto 1501
else
c pause
top1=ids(2,p-1)
goto 1510
endif
c
1510 continue
call basout(io,lunit,' ')
lct(4)=lct4
rio=rios
c
return
end
|
