Annotation of gforth/debug.fs, revision 1.1
1.1 ! anton 1: \ DEBUG.FS Debugger 12jun93jaw
! 2:
! 3: decimal
! 4:
! 5: VARIABLE IP \ istruction pointer for debugger
! 6:
! 7: \ Formated debugger words 12jun93jaw
! 8:
! 9: false [IF]
! 10:
! 11: Color: Men#
! 12: <A red >b yellow >f bold A> Men# CT!
! 13:
! 14: CREATE D-LineIP 80 cells allot
! 15: CREATE D-XPos 300 chars allot align
! 16: CREATE D-LineA 80 cells allot
! 17: VARIABLE ^LineA
! 18:
! 19: VARIABLE D-Lines
! 20: VARIABLE D-Line
! 21: VARIABLE D-MaxLines 10 D-MaxLines !
! 22: VARIABLE D-Bugline
! 23:
! 24: : WatcherInit
! 25: D-MaxLines @ 3 + YPos ! 0 D-Line ! ;
! 26:
! 27: : (lines)
! 28: 1 cells ^LineA +!
! 29: O-PNT@ ^LineA @ ! ;
! 30:
! 31: VARIABLE Body
! 32:
! 33: : ScanWord ( body -- )
! 34: dup body !
! 35: c-init
! 36: ScanMode c-pass !
! 37: C-Formated on 0 Level !
! 38: C-ClearLine on
! 39: Colors on
! 40: 0 XPos ! 0 YPos !
! 41: O-INIT
! 42: dup MakePass
! 43: DisplayMode c-pass !
! 44: c-stop off
! 45: D-LineIP 80 cells erase
! 46: 0 D-Lines ! dup D-LineIP !
! 47: O-PNT@ D-LineA ! D-LineA ^LineA !
! 48: ['] (lines) IS nlcount
! 49: XPos @ D-XPos c!
! 50: BEGIN analyse
! 51: D-Lines @ YPos @ <>
! 52: IF YPos @ D-Lines !
! 53: dup YPos @ cells D-LineIP + !
! 54: THEN
! 55: XPos @ over Body @ - 0 1 cells um/mod nip chars
! 56: D-XPos + c!
! 57: C-Stop @
! 58: UNTIL drop
! 59: O-PNT@ YPos @ 1+ cells D-LineA + !
! 60: -1 YPos @ 1+ cells D-LineIP + !
! 61: O-DEINIT
! 62: C-Formated off
! 63: 0 D-Line !
! 64: ['] noop IS nlcount ;
! 65:
! 66: : SearchLine ( addr -- n )
! 67: D-LineIP D-Lines @ 0
! 68: ?DO dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN
! 69: cell+
! 70: LOOP 2drop 0 ;
! 71:
! 72: : Display ( n -- )
! 73: dup cells D-LineA + @ O-Buffer +
! 74: swap D-MaxLines @ + D-Lines @ min 1+
! 75: cells D-LineA + @ O-Buffer +
! 76: over - type ;
! 77:
! 78: \ [IFDEF] Green Colors on [THEN]
! 79: \ dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos !
! 80: \ D-LineIP + @ C-Stop off
! 81: \ BEGIN
! 82: \ [IFDEF] Green IP @ over =
! 83: \ IF hig# C-Highlight ! ELSE C-Highlight off THEN
! 84: \ [THEN]
! 85: \ Analyse
! 86: \ C-Stop @ YPos @ D-MaxLines @ u>= or
! 87: \ UNTIL drop ;
! 88:
! 89: : TopLine
! 90: 0 0 at-xy
! 91: Men# CT@ attr!
! 92: ." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr
! 93: \ one step beyond
! 94: 0 CT@ attr! ;
! 95:
! 96: : BottomLine
! 97: 0 D-MaxLines @ 3 + at-xy
! 98: Men# CT@ attr!
! 99: ." U-nnest D-one N-est A-bort" cr
! 100: 0 CT@ attr! ;
! 101:
! 102: VARIABLE LastIP
! 103:
! 104: : (supress)
! 105: YPos @ D-MaxLines @ U>=
! 106: IF c-output off THEN ;
! 107:
! 108: : DispIP
! 109: ['] (supress) IS nlcount
! 110: dup SearchLine D-Line @ - dup YPos ! 2 +
! 111: over Body @ - 0 1 cells um/mod nip chars D-XPos + c@
! 112: swap AT-XY
! 113: Analyse drop
! 114: ['] noop IS nlcount
! 115: c-output on ;
! 116:
! 117: : Watcher ( -- )
! 118: TopLine
! 119: IP @ SearchLine dup D-Line @ dup D-MaxLines @ +
! 120: within
! 121: IF drop D-Line @ Display
! 122: ELSE D-MaxLines @ 2/ - 0 max dup D-Line !
! 123: Display
! 124: THEN
! 125: C-Formated off Colors on
! 126: \ LastIP @ ?DUP IF DispIP THEN
! 127: Hig# C-Highlight !
! 128: IP @ DispIP IP @ LastIP !
! 129: C-Formated on C-Highlight off
! 130: BottomLine ;
! 131:
! 132:
! 133: ' noop ALIAS \w immediate
! 134:
! 135: \ end formated debugger words
! 136:
! 137: [ELSE]
! 138: ' \ alias \w immediate
! 139:
! 140: : scanword ( body -- )
! 141: c-init C-Output off
! 142: ScanMode c-pass !
! 143: dup MakePass
! 144: 0 Level !
! 145: 0 XPos !
! 146: DisplayMode c-pass !
! 147: MakePass
! 148: C-Output on ;
! 149: [THEN]
! 150:
! 151: : .n 0 <# # # # # #S #> ctype bl cemit ;
! 152:
! 153: : d.s ." [ " depth . ." ] "
! 154: depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
! 155:
! 156: : NoFine XPos off YPos off
! 157: NLFlag off Level off
! 158: C-Formated off
! 159: [IFDEF] Colors Colors off [THEN]
! 160: ;
! 161:
! 162: : disp-step
! 163: DisplayMode c-pass ! \ change to displaymode
! 164: \ Branches Off \ don't display
! 165: \ \ BEGIN and THEN
! 166: cr
! 167: \w YPos @ 1+ D-BugLine !
! 168: \w Watcher
! 169: c-stop off
! 170: \w 0 D-BugLine @ at-xy
! 171: Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space
! 172: Base !
! 173: NoFine 10 XPos !
! 174: \w D-Bugline @ YPos !
! 175: ip @ DisplayMode c-pass ! Analyse drop
! 176: 25 XPos @ - 0 max spaces ." -> " ;
! 177:
! 178: : get-next ( -- n | n n )
! 179: DebugMode c-pass !
! 180: ip @ Analyse ;
! 181:
! 182: : jump ( addr -- )
! 183: r> drop \ discard last ip
! 184: >r ;
! 185:
! 186: AVARIABLE DebugLoop
! 187:
! 188: : breaker r> 1 cells - IP ! DebugLoop @ jump ;
! 189:
! 190: CREATE BP 0 , 0 ,
! 191: CREATE DT 0 , 0 ,
! 192:
! 193: : set-bp ( 0 n | 0 n n -- )
! 194: 0. BP 2!
! 195: ?dup IF dup BP ! dup @ DT !
! 196: ['] Breaker swap !
! 197: ?dup IF dup BP cell+ ! dup @ DT cell+ !
! 198: ['] Breaker swap ! drop THEN
! 199: THEN ;
! 200:
! 201: : restore-bp ( -- )
! 202: BP @ ?dup IF DT @ swap ! THEN
! 203: BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
! 204:
! 205: VARIABLE Body
! 206:
! 207: : NestXT ( xt -- true | body false )
! 208: DebugMode c-pass ! C-Output off
! 209: xtc C-Output on
! 210: c-pass @ DebugMode = dup
! 211: IF ." Cannot debug" cr
! 212: THEN ;
! 213:
! 214: VARIABLE Nesting
! 215:
! 216: : Leave-D
! 217: [IFDEF] Colors Colors on [THEN]
! 218: C-Formated on
! 219: C-Output on ;
! 220:
! 221: VARIABLE Unnest
! 222:
! 223: : D-KEY ( -- flag )
! 224: BEGIN
! 225: Unnest @ IF 0 ELSE key THEN
! 226: CASE [char] n OF IP @ @ NestXT EXIT ENDOF
! 227: [char] s OF Leave-D
! 228: -128 THROW ENDOF
! 229: [char] a OF Leave-D
! 230: -128 THROW ENDOF
! 231: [char] d OF Leave-D
! 232: cr ." Done..." cr
! 233: Nesting off
! 234: r> drop IP @ >r
! 235: EXIT ENDOF
! 236: [char] ? OF cr ." Nest Stop Done Unnest" cr
! 237: ENDOF
! 238: [char] u OF Unnest on true EXIT ENDOF
! 239: drop true EXIT
! 240: ENDCASE
! 241: AGAIN ;
! 242:
! 243: : (debug) ( body -- )
! 244: 0 Nesting !
! 245: BEGIN Unnest off
! 246: cr ." Scanning code..." cr C-Formated on
! 247: dup scanword IP !
! 248: cr ." Nesting debugger ready!" cr
! 249: \w WatcherInit 0 CT@ attr! page
! 250: BEGIN disp-step D-Key
! 251: WHILE C-Stop @ 0=
! 252: WHILE 0 get-next set-bp
! 253: IP @ jump
! 254: [ here DebugLoop ! ]
! 255: restore-bp
! 256: d.s
! 257: REPEAT
! 258: Nesting @ 0= ?EXIT
! 259: -1 Nesting +! r>
! 260: ELSE
! 261: IP @ >r 1 Nesting +!
! 262: THEN
! 263: AGAIN ;
! 264:
! 265: : dbg ' NestXT ?EXIT (debug) ;
! 266:
! 267: : test 1 2 4 swap dup . ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to debug.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth