Return to debug.fs CVS log | Up to [gforth] / gforth |
Moved setjmp from engine to go_forth, because the socalled "globbered" variables where saved in memory (and this slows down everything). Added global up0 for security (up is globbered). Added restrict's functionalitz to cross.fs removed all occurency of cell+ name>, because the bug in name> is fixed. Added a dusty workaround at the end of prims2x.fs, because of strange exceptions.
\ DEBUG.FS Debugger 12jun93jaw decimal VARIABLE IP \ istruction pointer for debugger \ Formated debugger words 12jun93jaw false [IF] Color: Men# <A red >b yellow >f bold A> Men# CT! CREATE D-LineIP 80 cells allot CREATE D-XPos 300 chars allot align CREATE D-LineA 80 cells allot VARIABLE ^LineA VARIABLE D-Lines VARIABLE D-Line VARIABLE D-MaxLines 10 D-MaxLines ! VARIABLE D-Bugline : WatcherInit D-MaxLines @ 3 + YPos ! 0 D-Line ! ; : (lines) 1 cells ^LineA +! O-PNT@ ^LineA @ ! ; VARIABLE Body : ScanWord ( body -- ) dup body ! c-init ScanMode c-pass ! C-Formated on 0 Level ! C-ClearLine on Colors on 0 XPos ! 0 YPos ! O-INIT dup MakePass DisplayMode c-pass ! c-stop off D-LineIP 80 cells erase 0 D-Lines ! dup D-LineIP ! O-PNT@ D-LineA ! D-LineA ^LineA ! ['] (lines) IS nlcount XPos @ D-XPos c! BEGIN analyse D-Lines @ YPos @ <> IF YPos @ D-Lines ! dup YPos @ cells D-LineIP + ! THEN XPos @ over Body @ - 0 1 cells um/mod nip chars D-XPos + c! C-Stop @ UNTIL drop O-PNT@ YPos @ 1+ cells D-LineA + ! -1 YPos @ 1+ cells D-LineIP + ! O-DEINIT C-Formated off 0 D-Line ! ['] noop IS nlcount ; : SearchLine ( addr -- n ) D-LineIP D-Lines @ 0 ?DO dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN cell+ LOOP 2drop 0 ; : Display ( n -- ) dup cells D-LineA + @ O-Buffer + swap D-MaxLines @ + D-Lines @ min 1+ cells D-LineA + @ O-Buffer + over - type ; \ [IFDEF] Green Colors on [THEN] \ dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos ! \ D-LineIP + @ C-Stop off \ BEGIN \ [IFDEF] Green IP @ over = \ IF hig# C-Highlight ! ELSE C-Highlight off THEN \ [THEN] \ Analyse \ C-Stop @ YPos @ D-MaxLines @ u>= or \ UNTIL drop ; : TopLine 0 0 at-xy Men# CT@ attr! ." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr \ one step beyond 0 CT@ attr! ; : BottomLine 0 D-MaxLines @ 3 + at-xy Men# CT@ attr! ." U-nnest D-one N-est A-bort" cr 0 CT@ attr! ; VARIABLE LastIP : (supress) YPos @ D-MaxLines @ U>= IF c-output off THEN ; : DispIP ['] (supress) IS nlcount dup SearchLine D-Line @ - dup YPos ! 2 + over Body @ - 0 1 cells um/mod nip chars D-XPos + c@ swap AT-XY Analyse drop ['] noop IS nlcount c-output on ; : Watcher ( -- ) TopLine IP @ SearchLine dup D-Line @ dup D-MaxLines @ + within IF drop D-Line @ Display ELSE D-MaxLines @ 2/ - 0 max dup D-Line ! Display THEN C-Formated off Colors on \ LastIP @ ?DUP IF DispIP THEN Hig# C-Highlight ! IP @ DispIP IP @ LastIP ! C-Formated on C-Highlight off BottomLine ; ' noop ALIAS \w immediate \ end formated debugger words [ELSE] ' \ alias \w immediate : scanword ( body -- ) c-init C-Output off ScanMode c-pass ! dup MakePass 0 Level ! 0 XPos ! DisplayMode c-pass ! MakePass C-Output on ; [THEN] : .n 0 <# # # # # #S #> ctype bl cemit ; : d.s ." [ " depth . ." ] " depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; : NoFine XPos off YPos off NLFlag off Level off C-Formated off [IFDEF] Colors Colors off [THEN] ; : disp-step DisplayMode c-pass ! \ change to displaymode \ Branches Off \ don't display \ \ BEGIN and THEN cr \w YPos @ 1+ D-BugLine ! \w Watcher c-stop off \w 0 D-BugLine @ at-xy Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space Base ! NoFine 10 XPos ! \w D-Bugline @ YPos ! ip @ DisplayMode c-pass ! Analyse drop 25 XPos @ - 0 max spaces ." -> " ; : get-next ( -- n | n n ) DebugMode c-pass ! ip @ Analyse ; : jump ( addr -- ) r> drop \ discard last ip >r ; AVARIABLE DebugLoop : breaker r> 1 cells - IP ! DebugLoop @ jump ; CREATE BP 0 , 0 , CREATE DT 0 , 0 , : set-bp ( 0 n | 0 n n -- ) 0. BP 2! ?dup IF dup BP ! dup @ DT ! ['] Breaker swap ! ?dup IF dup BP cell+ ! dup @ DT cell+ ! ['] Breaker swap ! drop THEN THEN ; : restore-bp ( -- ) BP @ ?dup IF DT @ swap ! THEN BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; VARIABLE Body : NestXT ( xt -- true | body false ) DebugMode c-pass ! C-Output off xtc C-Output on c-pass @ DebugMode = dup IF ." Cannot debug" cr THEN ; VARIABLE Nesting : Leave-D [IFDEF] Colors Colors on [THEN] C-Formated on C-Output on ; VARIABLE Unnest : D-KEY ( -- flag ) BEGIN Unnest @ IF 0 ELSE key THEN CASE [char] n OF IP @ @ NestXT EXIT ENDOF [char] s OF Leave-D -128 THROW ENDOF [char] a OF Leave-D -128 THROW ENDOF [char] d OF Leave-D cr ." Done..." cr Nesting off r> drop IP @ >r EXIT ENDOF [char] ? OF cr ." Nest Stop Done Unnest" cr ENDOF [char] u OF Unnest on true EXIT ENDOF drop true EXIT ENDCASE AGAIN ; : (debug) ( body -- ) 0 Nesting ! BEGIN Unnest off cr ." Scanning code..." cr C-Formated on dup scanword IP ! cr ." Nesting debugger ready!" cr \w WatcherInit 0 CT@ attr! page BEGIN disp-step D-Key WHILE C-Stop @ 0= WHILE 0 get-next set-bp IP @ jump [ here DebugLoop ! ] restore-bp d.s REPEAT Nesting @ 0= ?EXIT -1 Nesting +! r> ELSE IP @ >r 1 Nesting +! THEN AGAIN ; : dbg ' NestXT ?EXIT (debug) ; \ : test 1 2 4 swap dup . ;