![]() ![]() | ![]() |
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.
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 . ;