1\ DEBUG.FS     Debugger                                12jun93jaw
2
3\ Copyright (C) 1995,1996,1997,2000,2003,2004,2007 Free Software Foundation, Inc.
4
5\ This file is part of Gforth.
6
7\ Gforth is free software; you can redistribute it and/or
8\ modify it under the terms of the GNU General Public License
9\ as published by the Free Software Foundation, either version 3
10\ of the License, or (at your option) any later version.
11
12\ This program is distributed in the hope that it will be useful,
13\ but WITHOUT ANY WARRANTY; without even the implied warranty of
14\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15\ GNU General Public License for more details.
16
17\ You should have received a copy of the GNU General Public License
18\ along with this program. If not, see http://www.gnu.org/licenses/.
19
20require see.fs
21
22decimal
23
24VARIABLE dbg-ip     \ instruction pointer for debugger
25
26\ !! move to see?
27
28: save-see-flags ( -- n* cnt )
29  C-Output @
30  C-Formated @ 1 ;
31
32: restore-see-flags ( n* cnt -- )
33  drop C-Formated !
34  C-Output ! ;
35
36: scanword ( body -- )
37        >r save-see-flags r>
38        c-init C-Output off
39        ScanMode c-pass !
40        dup MakePass
41        0 Level !
42        0 XPos !
43        DisplayMode c-pass !
44        MakePass
45        restore-see-flags ;
46
47: .n ( n -- )    0 <# # # # # #S #> ctype bl cemit ;
48
49: d.s   ( .. -- .. )  ." [ " depth . ." ] "
50    depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
51
52: NoFine ( -- )
53    XPos off YPos off
54    NLFlag off Level off
55    C-Formated off ;
56
57: Leave-D ( -- ) ;
58
59: disp-step ( -- )
60\ display step at current dbg-ip
61        DisplayMode c-pass !            \ change to displaymode
62        cr
63        c-stop off
64        Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
65        Base !
66        save-see-flags
67        NoFine 10 XPos !
68        dbg-ip @ DisplayMode c-pass ! Analyse drop
69        25 XPos @ - 0 max spaces ." -> "
70        restore-see-flags ;
71
72: get-next ( -- n | n n )
73        DebugMode c-pass !
74        dbg-ip @ Analyse ;
75
76: jump          ( addr -- )
77    r> drop \ discard last ip
78    >r ;
79
80AVARIABLE DebugLoop
81
821 cells Constant breaker-size \ !!! dependency: ITC
83
84: breaker ( R:body -- )
85    r> breaker-size - dbg-ip ! DebugLoop @ jump ;
86
87CREATE BP 0 , 0 ,
88CREATE DT 0 , 0 ,
89
90: set-bp        ( 0 n | 0 n n -- ) \ !!! dependency: ITC
91                0. BP 2!
92                ?dup IF dup BP ! dup @ DT !
93                        ['] Breaker swap !
94                        ?dup IF dup BP cell+ ! dup @ DT cell+ !
95                                ['] Breaker swap ! drop THEN
96                     THEN ;
97
98: restore-bp    ( -- ) \ !!! dependency: ITC
99    BP @ ?dup IF DT @ swap ! THEN
100    BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
101
102VARIABLE Body
103
104: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 )
105    dup ['] call = IF
106	drop dbg-ip @ cell+ @ body>  EXIT
107    THEN
108    dup >does-code IF
109	\ if nest into a does> we must leave
110	\ the body address on stack as does> does...
111	dup >body swap EXIT
112    THEN
113    dup ['] EXECUTE = IF
114	\ xt to EXECUTE is next stack item...
115	drop EXIT
116    THEN
117    dup ['] PERFORM = IF
118	\ xt to EXECUTE is addressed by next stack item
119	drop @ EXIT
120    THEN
121    BEGIN
122	dup >code-address dodefer: =
123    WHILE
124	    \ load xt of DEFERed word
125	    cr ." nesting defered..."
126	    >body @
127    REPEAT ;
128
129: nestXT ( xt -- true | body false )
130\G return true if we are not able to debug this,
131\G body and false otherwise
132  nestXT-checkSpecial
133  \ scan code with xt-see
134  DebugMode c-pass ! C-Output off
135  xt-see C-Output on
136  c-pass @ DebugMode = dup
137  IF      cr ." Cannot debug!!"
138  THEN ;
139
140VARIABLE Nesting
141
142VARIABLE Unnest
143
144: D-KEY         ( -- flag )
145        BEGIN
146                Unnest @ IF 0 ELSE key THEN
147                CASE    [char] n OF     dbg-ip @ @ nestXT EXIT ENDOF
148                        [char] s OF     Leave-D
149                                        -128 THROW ENDOF
150                        [char] a OF     Leave-D
151                                        -128 THROW ENDOF
152                        [char] d OF     Leave-D
153                                        cr ." Done..." cr
154                                        Nesting off
155                                        r> drop dbg-ip @ >r
156                                        EXIT ENDOF
157                        [char] ? OF     cr ." Nest Stop Done Unnest" cr
158                                        ENDOF
159                        [char] u OF     Unnest on true EXIT ENDOF
160                        drop true EXIT
161                ENDCASE
162        AGAIN ;
163
164: (_debug) ( body ip -- )
165        0 Nesting !
166        BEGIN   Unnest off
167                cr ." Scanning code..." cr C-Formated on
168                swap scanword dbg-ip !
169                cr ." Nesting debugger ready!" cr
170                BEGIN   d.s disp-step D-Key
171                WHILE   C-Stop @ 0=
172                WHILE   0 get-next set-bp
173                        dbg-ip @ jump
174                        [ here DebugLoop ! ]
175                        restore-bp
176                REPEAT
177                Nesting @ 0= IF EXIT THEN
178                -1 Nesting +! r>
179                ELSE
180                get-next >r 1 Nesting +!
181                THEN
182                dup
183        AGAIN ;
184
185: (debug) dup (_debug) ;
186
187: dbg ( "name" -- ) \ gforth
188    ' NestXT IF EXIT THEN (debug) Leave-D ;
189
190: break:, ( -- )
191  latestxt postpone literal ;
192
193: (break:)
194    r> ['] (_debug) >body >r ;
195
196: break: ( -- ) \ gforth
197    break:, postpone (break:) ; immediate
198
199: (break")
200    cr
201    ." BREAK AT: " type cr
202    r> ['] (_debug) >body >r ;
203
204: break" ( 'ccc"' -- ) \ gforth
205    break:,
206    postpone s"
207    postpone (break") ; immediate
208