blob: e54f729fe6f6abecfd51314d89cb6ea54e3131a7 (
plain)
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
|
\ *****************************************************************************
\ * Copyright (c) 2004, 2008 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ * IBM Corporation - initial implementation
\ ****************************************************************************/
\ Get the name of Forth command whose execution token is xt
: xt>name ( xt -- str len )
BEGIN
cell - dup c@ 0 2 within IF
dup 2+ swap 1+ c@ exit
THEN
AGAIN
;
cell -1 * CONSTANT -cell
: cell- ( n -- n-cell-size )
[ cell -1 * ] LITERAL +
;
\ Search for xt of given address
: find-xt-addr ( addr -- xt )
BEGIN
dup @ <colon> = IF
EXIT
THEN
cell-
AGAIN
;
: (.immediate) ( xt -- )
\ is it immediate?
xt>name drop 2 - c@ \ skip len and flags
immediate? IF
." IMMEDIATE"
THEN
;
: (.xt) ( xt -- )
xt>name type
;
\ Trace back on current return stack.
\ Start at 1, since 0 is return of trace-back itself
: trace-back ( )
1
BEGIN
cr dup dup . ." : " rpick dup . ." : "
['] tib here within IF
dup rpick find-xt-addr (.xt)
THEN
1+ dup rdepth 5 - >= IF cr drop EXIT THEN
AGAIN
;
VARIABLE see-my-type-column
: (see-my-type) ( indent limit xt str len -- indent limit xt )
dup see-my-type-column @ + dup 50 >= IF
-rot over " " comp 0= IF
\ blank causes overflow: just enforce new line with next call
2drop see-my-type-column !
ELSE
rot drop ( indent limit xt str len )
\ Need to copy string since we use (u.) again (kills internal buffer):
pocket swap 2dup >r >r ( indent limit xt str pk len R: len pk )
move r> r> ( indent limit xt pk len )
2 pick (u.) dup -rot
cr type ( indent limit xt pk len xt-len )
" :" type 1+ ( indent limit xt pk len prefix-len )
5 pick dup spaces + ( indent limit xt pk len prefix-len )
over + see-my-type-column ! ( indent limit xt pk len )
type
THEN ( indent limit xt )
ELSE
see-my-type-column ! type ( indent limit xt )
THEN
;
: (see-my-type-init) ( -- )
ffff see-my-type-column ! \ just enforce a new line
;
: (see-colon-body) ( indent limit xt -- indent limit xt )
(see-my-type-init) \ enforce new line
BEGIN ( indent limit xt )
cell+ 2dup <>
over @
dup <semicolon> <>
rot and ( indent limit xt @xt flag )
WHILE ( indent limit xt @xt )
xt>name (see-my-type) " " (see-my-type)
dup @ ( indent limit xt @xt)
CASE
<0branch> OF cell+ dup @
over + cell+ dup >r
(u.) (see-my-type) r> ( indent limit xt target)
2dup < IF
over 4 pick 3 + -rot recurse
nip nip nip cell- ( indent limit xt )
ELSE
drop ( indent limit xt )
THEN
(see-my-type-init) ENDOF \ enforce new line
<branch> OF cell+ dup @ over + cell+ (u.)
(see-my-type) " " (see-my-type) ENDOF
<do?do> OF cell+ dup @ (u.) (see-my-type)
" " (see-my-type) ENDOF
<lit> OF cell+ dup @ (u.) (see-my-type)
" " (see-my-type) ENDOF
<dotick> OF cell+ dup @ xt>name (see-my-type)
" " (see-my-type) ENDOF
<doloop> OF cell+ dup @ (u.) (see-my-type)
" " (see-my-type) ENDOF
<do+loop> OF cell+ dup @ (u.) (see-my-type)
" " (see-my-type) ENDOF
<doleave> OF cell+ dup @ over + cell+ (u.)
(see-my-type) " " (see-my-type) ENDOF
<do?leave> OF cell+ dup @ over + cell+ (u.)
(see-my-type) " " (see-my-type) ENDOF
<sliteral> OF cell+ " """ (see-my-type) dup count dup >r
(see-my-type) " """ (see-my-type)
" " (see-my-type)
r> -cell and + ENDOF
ENDCASE
REPEAT
drop
;
: (see-colon) ( xt -- )
(see-my-type-init)
1 swap 0 swap ( indent limit xt )
" : " (see-my-type) dup xt>name (see-my-type)
rot drop 4 -rot (see-colon-body) ( indent limit xt )
rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
3drop
;
\ Create words are a bit tricky. We find out where their code points.
\ If this code is part of SLOF, it is not a user generated CREATE.
: (see-create) ( xt -- )
dup cell+ @
CASE
<2constant> OF
dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT "
ENDOF
<instancevalue> OF
dup cell+ cell+ @ . ." INSTANCE VALUE "
ENDOF
<instancevariable> OF
." INSTANCE VARIABLE "
ENDOF
dup OF
." CREATE "
ENDOF
ENDCASE
(.xt)
;
\ Decompile Forth command whose execution token is xt
: (see) ( xt -- )
cr dup dup @
CASE
<variable> OF ." VARIABLE " (.xt) ENDOF
<value> OF dup execute . ." VALUE " (.xt) ENDOF
<constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
<defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF
<alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF
<buffer:> OF ." BUFFER: " (.xt) ENDOF
<create> OF (see-create) ENDOF
<colon> OF (see-colon) ENDOF
dup OF ." ??? PRIM " (.xt) ENDOF
ENDCASE
(.immediate) cr
;
\ Decompile Forth command old-name
: see ( "old-name<>" -- )
' (see)
;
\ Work in progress...
0 value forth-ip
true value trace>stepping?
true value trace>print?
true value trace>up?
0 value trace>depth
0 value trace>rdepth
0 value trace>recurse
: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
: trace-depth- ( -- ) trace>depth 1- to trace>depth ;
: stepping ( -- )
true to trace>stepping?
;
: tracing ( -- )
false to trace>stepping?
;
: trace-print-on ( -- )
true to trace>print?
;
: trace-print-off ( -- )
false to trace>print?
;
\ Add n to ip
: fip-add ( n -- )
forth-ip + to forth-ip
;
\ Save execution token address and content
0 value debug-last-xt
0 value debug-last-xt-content
: trace-print ( -- )
forth-ip cr u. ." : "
forth-ip @
dup ['] breakpoint = IF drop debug-last-xt-content THEN
xt>name type ." "
." ( " .s ." ) | "
;
: trace-interpret ( -- )
rdepth 1- to trace>rdepth
BEGIN
depth . [char] > dup emit emit space
source expect ( str len )
['] interpret catch print-status
AGAIN
;
\ Main trace routine, trace a colon definition
: trace-xt ( xt -- )
trace>recurse IF
r> drop \ Drop return of 'trace-xt call
cell+ \ Step over ":"
ELSE
debug-last-xt-content <colon> = IF
\ debug colon-definition
['] breakpoint @ debug-last-xt ! \ Re-arm break point
r> drop \ Drop return of 'trace-xt call
cell+ \ Step over ":"
ELSE
['] breakpoint debug-last-xt ! \ Re-arm break point
2r> 2drop
THEN
THEN
to forth-ip
true to trace>print?
BEGIN
trace>print? IF trace-print THEN
forth-ip ( ip )
trace>stepping? IF
BEGIN
key
CASE
[char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions
trace-depth+
1 to trace>recurse
dup >r @ recurse
THEN true ENDOF
[char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
[char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack
[char] c OF tracing true ENDOF
[char] t OF trace-back false ENDOF
[char] q OF drop cr quit ENDOF
20 OF true ENDOF
dup OF cr ." Press d: Down into current word" cr
." Press u: Up to caller" cr
." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr
." Press c: Switch to tracing" cr
." Press <space>: Execute current word" cr
." Press q: Abort execution, switch to interpreter" cr
false ENDOF
ENDCASE
UNTIL
THEN ( ip' )
dup to forth-ip @ ( xt )
dup ['] breakpoint = IF drop debug-last-xt-content THEN
dup ( xt xt )
CASE
<sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
<dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF
<lit> OF drop forth-ip cell+ @ cell fip-add ENDOF
<doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
<(doito)> OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
<0branch> OF drop IF
cell fip-add
ELSE
forth-ip cell+ @ cell+ fip-add THEN
ENDOF
<do?do> OF drop 2dup <> IF
swap >r >r cell fip-add
ELSE
forth-ip cell+ @ cell+ fip-add 2drop THEN
ENDOF
<branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF
<doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF
<do?leave> OF drop IF
r> r> 2drop forth-ip cell+ @ cell+ fip-add
ELSE
cell fip-add
THEN
ENDOF
<doloop> OF drop r> 1+ r> 2dup = IF
2drop cell fip-add
ELSE >r >r
forth-ip cell+ @ cell+ fip-add THEN
ENDOF
<do+loop> OF drop r> + r> 2dup >= IF
2drop cell fip-add
ELSE >r >r
forth-ip cell+ @ cell+ fip-add THEN
ENDOF
<semicolon> OF trace>depth 0> IF
trace-depth- 1 to trace>recurse
stepping drop r> recurse
ELSE
drop exit THEN
ENDOF
<exit> OF trace>depth 0> IF
trace-depth- stepping drop r> recurse
ELSE
drop exit THEN
ENDOF
dup OF execute ENDOF
ENDCASE
forth-ip cell+ to forth-ip
AGAIN
;
\ Resume execution from tracer
: resume ( -- )
trace>rdepth rdepth!
forth-ip cell - trace-xt
;
\ Turn debug off, by erasing breakpoint
: debug-off ( -- )
debug-last-xt IF
debug-last-xt-content debug-last-xt ! \ Restore overwritten token
0 to debug-last-xt
THEN
;
\ Entry point for debug
: (break-entry) ( -- )
debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt )
debug-last-xt-content swap ! \ Restore overwritten token
r> drop \ Don't return to bp, but to caller
debug-last-xt-content <colon> <> and IF \ Execute non colon definition
debug-last-xt cr u. ." : "
debug-last-xt xt>name type ." "
." ( " .s ." ) | "
key drop
debug-last-xt execute
ELSE
debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition
THEN
;
\ Put entry point bp defer
' (break-entry) to BP
\ Mark an address for debugging
: debug-address ( addr -- )
debug-off ( xt ) \ Remove active breakpoint
dup to debug-last-xt ( xt ) \ Save token for later debug
dup @ to debug-last-xt-content ( xt ) \ Save old value
['] breakpoint swap !
;
\ Mark the command indicated by xt for debugging
: (debug ( xt -- )
debug-off ( xt ) \ Remove active breakpoint
dup to debug-last-xt ( xt ) \ Save token for later debug
dup @ to debug-last-xt-content ( xt ) \ Save old value
['] breakpoint @ swap !
;
\ Mark the command indicated by xt for debugging
: debug ( "old-name<>" -- )
parse-word $find IF \ Get xt for old-name
(debug
ELSE
." undefined word " type cr
THEN
;
|
