[openfirmware] [commit] r2910 - forth/lib
repository service
svn at openfirmware.info
Wed Mar 21 23:15:39 CET 2012
Author: wmb
Date: Wed Mar 21 23:15:39 2012
New Revision: 2910
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2910
Log:
Debugger - factored (trace so it's not so crazy long, and cleaned up a few minor glitches.
Modified:
forth/lib/debug.fth
Modified: forth/lib/debug.fth
==============================================================================
--- forth/lib/debug.fth Wed Mar 21 23:14:01 2012 (r2909)
+++ forth/lib/debug.fth Wed Mar 21 23:15:39 2012 (r2910)
@@ -37,8 +37,7 @@
variable step? step? on
variable res
headers
-false value first-time?
-d# 10 circular-stack: locations
+false value redisplay?
: (debug) (s low-adr hi-adr -- )
unbug 1 cnt ! ip> ! <ip ! pnext
@@ -47,7 +46,7 @@
slow-next? on
then
step? on
- true is first-time?
+ true is redisplay?
;
headerless
: 'unnest (s pfa -- pfa' )
@@ -116,6 +115,7 @@
." $ Display top of stack as adr,len text string" cr
." \ Display Forth return stack as numbers (like the data stack)" cr
." Q Quit: abandon execution of the debugged word" cr
+ ." V Visual: toggle between 2-D and scrolling" cr
;
d# 24 constant cmd-column
: to-cmd-column ( -- ) cmd-column to-column ;
@@ -141,8 +141,6 @@
: save-result-loc ( -- ) #out @ to result-col #line @ to result-line ;
: to-result-loc ( -- ) result-col result-line at-xy ;
-0 value rp-mark
-
\ set-package is a hook for Open Firmware. When Open Firmware is loaded,
\ set-package should be set to a word that sets the active package to the
\ package corresponding to the current instance. set-package is called
@@ -165,72 +163,82 @@
variable hex-stack \ Show the data stack in hex?
: save# ( -- ) #-buf /#buf - #buf-save d# 72 move hld @ hld-save ! ;
: restore# ( -- ) #buf-save #-buf /#buf - d# 72 move hld-save @ hld ! ;
+0 value the-ip
+0 value the-rp
: (.rs ( -- )
show-rstack @ 0= if exit then
." return-stack: "
push-hex
- rp0 @ rp@ - /n /
- 6 do \ It appears that skipping the first 6 entries on the stack skips the debug goo on the rs
- rp@ i /n * + @ .
- loop
+ \ Skip the debugger's footprint on the return stack
+ rp0 @ the-rp 5 na+ ?do i @ . /n +loop
pop-base
;
-: (trace ( -- )
- first-time? if
+: setup-scrolling-display ( -- )
+ ??cr
+ the-ip <ip @ = if ." : " else ." Inside " then
+ <ip @ find-cfa .name
+;
+: setup-2d-display ( -- )
+ page
+ d# 78 rmargin !
+ .debug-short-help
+ ." Callers: " rp0 @ the-rp na1+ rslist kill-line cr
+ \ XXX the following is wrong when popping up
+ the-ip <ip @ = if
+ #line @ is stack-line \ So the initial stack is displayed in the right place
+ then
+ d# 40 rmargin !
+ the-ip debug-see
+ cr
+ \ When popping up from an interior word, display the initial stack on
+ \ the line where the cursor will be.
+ the-ip <ip @ <> if
+ the-ip ip>position if ( col row )
+ drop is stack-line ( )
+ then
+ then
+;
+: setup-debug-display ( -- )
+ redisplay? if
scrolling-debug? if
- ??cr
- ip@ <ip @ = if ." : " else ." Inside " then
- <ip @ find-cfa .name
+ setup-scrolling-display
else
- page
- d# 78 rmargin !
- ." Callers: " rp0 @ rp@ na1+ rslist kill-line cr
- \ XXX the following is wrong when popping up
- ip@ <ip @ = if
- #line @ is stack-line \ So the initial stack is displayed in the right place
- then
- d# 40 rmargin !
- ip@ debug-see
- cr
-\ ip@ <ip @ <> if
-\ ip@ ip>position if ( col row )
-\ swap
-\ is stack-line
-\ then
-\ #line @ is stack-line \ So the initial stack is displayed in the right place
- \ then
+ setup-2d-display
then
0 show-rstack !
- false is first-time?
- rp@ is rp-mark
+ false is redisplay?
then
-
- begin
- step? @ if to-debug-window then
+;
+: show-debug-stack ( -- )
+ scrolling-debug? if
save#
- scrolling-debug? if
- cmd-column 2+ to-column
+ cmd-column 2+ to-column
- hex-stack @ if push-hex then
- ." ( " .s \ Show data stack
- hex-stack @ if pop-base then
- show-rstack @ if (.rs then \ Show return stack
- ." )"
- restore#
-
- cr
- ['] noop is indent
- ip@ .token drop \ Show word name
- ['] (indent) is indent
- to-cmd-column
- else
- save-result-loc
- show-partial-stack
+ hex-stack @ if push-hex then
+ ." ( " .s \ Show data stack
+ hex-stack @ if pop-base then
+ show-rstack @ if (.rs then \ Show return stack
+ ." )"
+ restore#
+
+ cr
+ ['] noop is indent
+ the-ip .token drop \ Show word name
+ ['] (indent) is indent
+ to-cmd-column
+ else
+ save-result-loc
+ show-partial-stack
- ip@ ip-set-cursor
- #line @ to stack-line
- then
-
+ the-ip ip-set-cursor
+ #line @ to stack-line
+ then
+;
+: debug-interact ( -- )
+ save#
+ begin
+ step? @ if to-debug-window then
+ show-debug-stack
step? @ key? or if
step? on res off
key dup bl < if drop bl then
@@ -238,28 +246,35 @@
restore-window
scrolling-debug? if reset-page then
case
- ascii D of ip@ token@ executer ['] (debug try endof \ Down
- ascii U of rp@ ['] up1 try endof \ Up
- ascii C of step? @ 0= step? ! true endof \ Continue
- ascii F of
+ ascii D of the-ip token@ executer ['] (debug try endof \ Down
+ ascii U of the-rp ['] up1 try endof \ Up
+ ascii C of \ Continue
+ step? @ 0= step? !
+ step? @ 0= if true to scrolling-debug? true to redisplay? then
+ true
+ endof
+
+ ascii F of \ Forth
cr ." Type 'resume' to return to debugger" cr
set-package interact unset-package false
- endof \ Forth
- ascii G of debug-off cr exit endof \ Go
- ascii H of cr .debug-long-help false endof \ Help
- ascii R of cr rp0 @ rp@ na1+ (rstrace false endof \ RSTrace
- ascii S of cr <ip @ body> (see) false endof \ See
- ascii ? of cr .debug-short-help false endof \ Short Help
+ endof
+ ascii G of debug-off cr true endof \ Go
+ ascii H of cr .debug-long-help false endof \ Help
+ ascii R of cr rp0 @ the-rp na1+ (rstrace false endof \ RSTrace
+ ascii S of cr <ip @ body> (see) false endof \ See
+ ascii ? of cr .debug-short-help false endof \ Short Help
ascii $ of space 2dup type cr to-cmd-column false endof \ String
ascii Q of cr ." unbug" abort true endof \ Quit
- ascii ( of ip@ set-<ip false endof
- ascii < of ip@ ta1+ set-<ip 1 cnt ! false endof
- ascii ) of ip@ ip> ! 1 cnt ! false endof
- ascii * of ip@ find-cfa dup <ip ! 'unnest ip> ! false endof
- ascii \ of show-rstack @ 0= show-rstack ! false endof
- ascii X of hex-stack @ 0= hex-stack ! false endof
- ascii V of scrolling-debug? 0= to scrolling-debug?
- scrolling-debug? 0= if true to first-time? then false endof
+ ascii ( of the-ip set-<ip false endof
+ ascii < of the-ip ta1+ set-<ip 1 cnt ! false endof
+ ascii ) of the-ip ip> ! 1 cnt ! false endof
+ ascii * of the-ip find-cfa dup <ip ! 'unnest ip> ! false endof
+ ascii \ of show-rstack @ 0= show-rstack ! false endof \ toggle return stack display
+ ascii X of hex-stack @ 0= hex-stack ! false endof \ toggle heX stack display
+ ascii V of \ toggle Visual (2D) mode
+ scrolling-debug? 0= to scrolling-debug?
+ scrolling-debug? 0= if true to redisplay? then false
+ endof
( default ) true swap
endcase
else
@@ -267,11 +282,17 @@
then
until
restore#
- scrolling-debug? 0= if to-result-loc then
- ip@ token@ dup ['] unnest = swap ['] exit = or if
- cr true is first-time?
+;
+: (trace ( -- )
+ ip@ to the-ip
+ rp@ to the-rp
+ setup-debug-display
+ debug-interact
+\ scrolling-debug? 0= if to-result-loc then
+ the-ip token@ dup ['] unnest = swap ['] exit = or if
+ cr true is redisplay?
then
- pnext
+ slow-next? @ if pnext then
;
' (trace 'debug token!
More information about the openfirmware
mailing list