version 1.23, 2003/03/22 10:04:06
|
version 1.27, 2007/12/31 19:02:24
|
Line 1
|
Line 1
|
\ DEBUG.FS Debugger 12jun93jaw |
\ DEBUG.FS Debugger 12jun93jaw |
|
|
\ Copyright (C) 1995,1996,1997,2000,2003 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,2000,2003,2004,2007 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
require see.fs |
require see.fs |
|
|
Line 45 VARIABLE dbg-ip \ instruction pointe
|
Line 44 VARIABLE dbg-ip \ instruction pointe
|
MakePass |
MakePass |
restore-see-flags ; |
restore-see-flags ; |
|
|
: .n 0 <# # # # # #S #> ctype bl cemit ; |
: .n ( n -- ) 0 <# # # # # #S #> ctype bl cemit ; |
|
|
: d.s ." [ " depth . ." ] " |
: d.s ( .. -- .. ) ." [ " depth . ." ] " |
depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; |
depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; |
|
|
: NoFine XPos off YPos off |
: NoFine ( -- ) |
NLFlag off Level off |
XPos off YPos off |
C-Formated off |
NLFlag off Level off |
; |
C-Formated off ; |
|
|
: Leave-D ; |
: Leave-D ( -- ) ; |
|
|
: disp-step ( -- ) |
: disp-step ( -- ) |
\ display step at current dbg-ip |
\ display step at current dbg-ip |
Line 75 VARIABLE dbg-ip \ instruction pointe
|
Line 74 VARIABLE dbg-ip \ instruction pointe
|
dbg-ip @ Analyse ; |
dbg-ip @ Analyse ; |
|
|
: jump ( addr -- ) |
: jump ( addr -- ) |
r> drop \ discard last ip |
r> drop \ discard last ip |
>r ; |
>r ; |
|
|
AVARIABLE DebugLoop |
AVARIABLE DebugLoop |
|
|
: breaker r> 1 cells - dbg-ip ! DebugLoop @ jump ; |
1 cells Constant breaker-size \ !!! dependency: ITC |
|
|
|
: breaker ( R:body -- ) |
|
r> breaker-size - dbg-ip ! DebugLoop @ jump ; |
|
|
CREATE BP 0 , 0 , |
CREATE BP 0 , 0 , |
CREATE DT 0 , 0 , |
CREATE DT 0 , 0 , |
|
|
: set-bp ( 0 n | 0 n n -- ) |
: set-bp ( 0 n | 0 n n -- ) \ !!! dependency: ITC |
0. BP 2! |
0. BP 2! |
?dup IF dup BP ! dup @ DT ! |
?dup IF dup BP ! dup @ DT ! |
['] Breaker swap ! |
['] Breaker swap ! |
Line 93 CREATE DT 0 , 0 ,
|
Line 95 CREATE DT 0 , 0 ,
|
['] Breaker swap ! drop THEN |
['] Breaker swap ! drop THEN |
THEN ; |
THEN ; |
|
|
: restore-bp ( -- ) |
: restore-bp ( -- ) \ !!! dependency: ITC |
BP @ ?dup IF DT @ swap ! THEN |
BP @ ?dup IF DT @ swap ! THEN |
BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; |
BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; |
|
|
VARIABLE Body |
VARIABLE Body |
|
|
: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) |
: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) |
dup >does-code IF |
dup ['] call = IF |
\ if nest into a does> we must leave |
drop dbg-ip @ cell+ @ body> EXIT |
\ the body address on stack as does> does... |
THEN |
dup >body swap EXIT |
dup >does-code IF |
THEN |
\ if nest into a does> we must leave |
dup ['] EXECUTE = IF |
\ the body address on stack as does> does... |
\ xt to EXECUTE is next stack item... |
dup >body swap EXIT |
drop EXIT |
THEN |
THEN |
dup ['] EXECUTE = IF |
dup ['] PERFORM = IF |
\ xt to EXECUTE is next stack item... |
\ xt to EXECUTE is addressed by next stack item |
drop EXIT |
drop @ EXIT |
THEN |
THEN |
dup ['] PERFORM = IF |
BEGIN |
\ xt to EXECUTE is addressed by next stack item |
dup >code-address dodefer: = |
drop @ EXIT |
|
THEN |
|
BEGIN |
|
dup >code-address dodefer: = |
WHILE |
WHILE |
\ load xt of DEFERed word |
\ load xt of DEFERed word |
cr ." nesting defered..." |
cr ." nesting defered..." |
>body @ |
>body @ |
REPEAT ; |
REPEAT ; |
|
|
: nestXT ( xt -- true | body false ) |
: nestXT ( xt -- true | body false ) |
\G return true if we are not able to debug this, |
\G return true if we are not able to debug this, |
Line 172 VARIABLE Unnest
|
Line 177 VARIABLE Unnest
|
Nesting @ 0= IF EXIT THEN |
Nesting @ 0= IF EXIT THEN |
-1 Nesting +! r> |
-1 Nesting +! r> |
ELSE |
ELSE |
dbg-ip @ 1 cells + >r 1 Nesting +! |
get-next >r 1 Nesting +! |
THEN |
THEN |
dup |
dup |
AGAIN ; |
AGAIN ; |