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