1
\ *****************************************************************************
2
\ * Copyright (c) 2004, 2008 IBM Corporation
3
\ * All rights reserved.
4
\ * This program and the accompanying materials
5
\ * are made available under the terms of the BSD License
6
\ * which accompanies this distribution, and is available at
7
\ * http://www.opensource.org/licenses/bsd-license.php
10
\ * IBM Corporation - initial implementation
11
\ ****************************************************************************/
14
\ Get the name of Forth command whose execution token is xt
16
: xt>name ( xt -- str len )
18
cell - dup c@ 0 2 within IF
19
dup 2+ swap 1+ c@ exit
24
cell -1 * CONSTANT -cell
25
: cell- ( n -- n-cell-size )
26
[ cell -1 * ] LITERAL +
29
\ Search for xt of given address
30
: find-xt-addr ( addr -- xt )
39
: (.immediate) ( xt -- )
41
xt>name drop 2 - c@ \ skip len and flags
51
\ Trace back on current return stack.
52
\ Start at 1, since 0 is return of trace-back itself
57
cr dup dup . ." : " rpick dup . ." : "
58
['] tib here within IF
59
dup rpick find-xt-addr (.xt)
61
1+ dup rdepth 5 - >= IF cr drop EXIT THEN
65
VARIABLE see-my-type-column
67
: (see-my-type) ( indent limit xt str len -- indent limit xt )
68
dup see-my-type-column @ + dup 50 >= IF
69
-rot over " " comp 0= IF
70
\ blank causes overflow: just enforce new line with next call
71
2drop see-my-type-column !
73
rot drop ( indent limit xt str len )
74
\ Need to copy string since we use (u.) again (kills internal buffer):
75
pocket swap 2dup >r >r ( indent limit xt str pk len R: len pk )
76
move r> r> ( indent limit xt pk len )
78
cr type ( indent limit xt pk len xt-len )
79
" :" type 1+ ( indent limit xt pk len prefix-len )
80
5 pick dup spaces + ( indent limit xt pk len prefix-len )
81
over + see-my-type-column ! ( indent limit xt pk len )
83
THEN ( indent limit xt )
85
see-my-type-column ! type ( indent limit xt )
89
: (see-my-type-init) ( -- )
90
ffff see-my-type-column ! \ just enforce a new line
93
: (see-colon-body) ( indent limit xt -- indent limit xt )
94
(see-my-type-init) \ enforce new line
95
BEGIN ( indent limit xt )
99
rot and ( indent limit xt @xt flag )
100
WHILE ( indent limit xt @xt )
101
xt>name (see-my-type) " " (see-my-type)
102
dup @ ( indent limit xt @xt)
104
<0branch> OF cell+ dup @
106
(u.) (see-my-type) r> ( indent limit xt target)
108
over 4 pick 3 + -rot recurse
109
nip nip nip cell- ( indent limit xt )
111
drop ( indent limit xt )
113
(see-my-type-init) ENDOF \ enforce new line
114
<branch> OF cell+ dup @ over + cell+ (u.)
115
(see-my-type) " " (see-my-type) ENDOF
116
<do?do> OF cell+ dup @ (u.) (see-my-type)
117
" " (see-my-type) ENDOF
118
<lit> OF cell+ dup @ (u.) (see-my-type)
119
" " (see-my-type) ENDOF
120
<dotick> OF cell+ dup @ xt>name (see-my-type)
121
" " (see-my-type) ENDOF
122
<doloop> OF cell+ dup @ (u.) (see-my-type)
123
" " (see-my-type) ENDOF
124
<do+loop> OF cell+ dup @ (u.) (see-my-type)
125
" " (see-my-type) ENDOF
126
<doleave> OF cell+ dup @ over + cell+ (u.)
127
(see-my-type) " " (see-my-type) ENDOF
128
<do?leave> OF cell+ dup @ over + cell+ (u.)
129
(see-my-type) " " (see-my-type) ENDOF
130
<sliteral> OF cell+ " """ (see-my-type) dup count dup >r
131
(see-my-type) " """ (see-my-type)
139
: (see-colon) ( xt -- )
141
1 swap 0 swap ( indent limit xt )
142
" : " (see-my-type) dup xt>name (see-my-type)
143
rot drop 4 -rot (see-colon-body) ( indent limit xt )
144
rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
148
\ Create words are a bit tricky. We find out where their code points.
149
\ If this code is part of SLOF, it is not a user generated CREATE.
151
: (see-create) ( xt -- )
155
dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT "
159
dup cell+ cell+ @ . ." INSTANCE VALUE "
162
<instancevariable> OF
163
." INSTANCE VARIABLE "
173
\ Decompile Forth command whose execution token is xt
178
<variable> OF ." VARIABLE " (.xt) ENDOF
179
<value> OF dup execute . ." VALUE " (.xt) ENDOF
180
<constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
181
<defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF
182
<alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF
183
<buffer:> OF ." BUFFER: " (.xt) ENDOF
184
<create> OF (see-create) ENDOF
185
<colon> OF (see-colon) ENDOF
186
dup OF ." ??? PRIM " (.xt) ENDOF
191
\ Decompile Forth command old-name
193
: see ( "old-name<>" -- )
197
\ Work in progress...
200
true value trace>stepping?
201
true value trace>print?
205
0 value trace>recurse
206
: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
207
: trace-depth- ( -- ) trace>depth 1- to trace>depth ;
210
true to trace>stepping?
214
false to trace>stepping?
217
: trace-print-on ( -- )
221
: trace-print-off ( -- )
222
false to trace>print?
229
forth-ip + to forth-ip
232
\ Save execution token address and content
234
0 value debug-last-xt
235
0 value debug-last-xt-content
238
forth-ip cr u. ." : "
240
dup ['] breakpoint = IF drop debug-last-xt-content THEN
245
: trace-interpret ( -- )
246
rdepth 1- to trace>rdepth
248
depth . [char] > dup emit emit space
249
source expect ( str len )
250
['] interpret catch print-status
254
\ Main trace routine, trace a colon definition
258
r> drop \ Drop return of 'trace-xt call
259
cell+ \ Step over ":"
261
debug-last-xt-content <colon> = IF
262
\ debug colon-definition
263
['] breakpoint @ debug-last-xt ! \ Re-arm break point
264
r> drop \ Drop return of 'trace-xt call
265
cell+ \ Step over ":"
267
['] breakpoint debug-last-xt ! \ Re-arm break point
275
trace>print? IF trace-print THEN
282
[char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions
287
[char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
288
[char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack
289
[char] c OF tracing true ENDOF
290
[char] t OF trace-back false ENDOF
291
[char] q OF drop cr quit ENDOF
293
dup OF cr ." Press d: Down into current word" cr
294
." Press u: Up to caller" cr
295
." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr
296
." Press c: Switch to tracing" cr
297
." Press <space>: Execute current word" cr
298
." Press q: Abort execution, switch to interpreter" cr
303
dup to forth-ip @ ( xt )
304
dup ['] breakpoint = IF drop debug-last-xt-content THEN
308
<sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
309
<dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF
310
<lit> OF drop forth-ip cell+ @ cell fip-add ENDOF
311
<doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
312
<(doito)> OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
316
forth-ip cell+ @ cell+ fip-add THEN
318
<do?do> OF drop 2dup <> IF
319
swap >r >r cell fip-add
321
forth-ip cell+ @ cell+ fip-add 2drop THEN
323
<branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF
324
<doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF
325
<do?leave> OF drop IF
326
r> r> 2drop forth-ip cell+ @ cell+ fip-add
331
<doloop> OF drop r> 1+ r> 2dup = IF
334
forth-ip cell+ @ cell+ fip-add THEN
336
<do+loop> OF drop r> + r> 2dup >= IF
339
forth-ip cell+ @ cell+ fip-add THEN
342
<semicolon> OF trace>depth 0> IF
343
trace-depth- 1 to trace>recurse
344
stepping drop r> recurse
348
<exit> OF trace>depth 0> IF
349
trace-depth- stepping drop r> recurse
355
forth-ip cell+ to forth-ip
359
\ Resume execution from tracer
362
forth-ip cell - trace-xt
365
\ Turn debug off, by erasing breakpoint
369
debug-last-xt-content debug-last-xt ! \ Restore overwriten token
376
\ Entry point for debug
378
: (break-entry) ( -- )
379
debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt )
380
debug-last-xt-content swap ! \ Restore overwriten token
381
r> drop \ Don't return to bp, but to caller
382
debug-last-xt-content <colon> <> and IF \ Execute non colon definition
383
debug-last-xt cr u. ." : "
384
debug-last-xt xt>name type ." "
387
debug-last-xt execute
389
debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition
393
\ Put entry point bp defer
394
' (break-entry) to BP
396
\ Mark an address for debugging
398
: debug-address ( addr -- )
399
debug-off ( xt ) \ Remove active breakpoint
400
dup to debug-last-xt ( xt ) \ Save token for later debug
401
dup @ to debug-last-xt-content ( xt ) \ Save old value
402
['] breakpoint swap !
405
\ Mark the command indicated by xt for debugging
408
debug-off ( xt ) \ Remove active breakpoint
409
dup to debug-last-xt ( xt ) \ Save token for later debug
410
dup @ to debug-last-xt-content ( xt ) \ Save old value
411
['] breakpoint @ swap !
414
\ Mark the command indicated by xt for debugging
416
: debug ( "old-name<>" -- )
417
parse-word $find IF \ Get xt for old-name
420
." undefined word " type cr
added
removed
slof/fs/debug.fs
