debugger.ans

   1 \\r
   2 \\r
   3 \\r
   4 \\r
   5 \ We CANNOT access code!\r
   6 \ We CANNOT change the compiler!\r
   7 \ We CANNOT do anything!\r
   8 \\r
   9 \ But we want a debugger!\r
  10 \ Ok, here it is....\r
  11 \\r
  12 \\r
  13 \ ********************************************************************\r
  14 \ *                                                                  *\r
  15 \ *                Debugger for ANSI Forth Programs                  *\r
  16 \ *                                                                  *\r
  17 \ *                                                                  *\r
  18 \ * Contributed to the community by                                  *\r
  19 \ *                                                                  *\r
  20 \ *                    Joerg Plewe, 1dec94                           *\r
  21 \ *                                                                  *\r
  22 \ * This code can be used and copied free of charge.                 *\r
  23 \ * All rights reserved.                                             *\r
  24 \ *                                                                  *\r
  25 \ * Comments, hints and bug reports are welcome. Please email to     *\r
  26 \ *                                                                  *\r
  27 \ *                     jps@Forth-eV.de                              *\r
  28 \ *                                                                  *\r
  29 \ *                                                                  *\r
  30 \ * testet with: F68KANS (>jan94), pfe0.9.7, thisForth               *\r
  31 \ *                                                                  *\r
  32 \ * Special thanks to Ulrich Hoffmann and Bernd Paysan               *\r
  33 \ *  for testing and commenting.                                     *\r
  34 \ *                                                                  *\r
  35 \ * V0.1: Added treatment of nesting levels                          *\r
  36 \ * V0.2: Decompiler feature                                         *\r
  37 \ * V0.3: worked in hints from the net                               *\r
  38 \ ********************************************************************\r
  39 \\r
  40 \\r
  41 \ The following code provides a simple debugging tool for ANSI Forth\r
  42 \ programs. It may be used to debug colon- and DOES>- and :NONAME-code\r
  43 \ on source level.\r
  44 \\r
  45 \ The debugger expects your system to be a well behaved Forth system.\r
  46 \ (Like my F68KANS :-)\r
  47 \ When you suspect that your problems arise from the compiler itself\r
  48 \ (do you use an optimizer?), please use another tool.\r
  49 \\r
  50 \\r
  51 \ Usage:\r
  52 \\r
  53 \ There are two pairs of words switching the debugger on and off.\r
  54 \\r
  55 \ +DEBUG, -DEBUG\r
  56 \ These two control a global switch, which has effects both a compile-\r
  57 \ and runtime. When used at compiletime, -DEBUG will completely switch\r
  58 \ of the debugger. So no debugging code is generated. This allows you\r
  59 \ to leave your code with all debugging statements in it and test it\r
  60 \ without debugger.\r
  61 \ At runtime, -DEBUG switches off the evaluation of debugging code.\r
  62 \ So your code will behave as normal, just a bit slower.\r
  63 \\r
  64 \ [DBG, DBG]\r
  65 \ You will have to use [DBG at compiletime in front of a ':' or a DOES>\r
  66 \ to tell the debugger to generate special debugging code. [DBG is\r
  67 \ valid until switched off with DBG]. DBG] may appear anywhere in the source!\r
  68 \ So it is possible to debug only the first part of a word and then to switch\r
  69 \ of the debugger causing 'original' code to be generated for the rest.\r
  70 \ It is not possible to generate normal code a the beginning of a definition\r
  71 \ and debugging code in the end!\r
  72 \\r
  73 \ E.g.\r
  74 \ : FOO CREATE [DBG  0 ,   DOES> @ ;   DBG]\r
  75 \\r
  76 \ will only debug the DOES>-part of the definition. The reason is that [DBG\r
  77 \ only switches the behaviour of ':' and DOES>.\r
  78 \\r
  79 \\r
  80 \ Think about the difference of +-DEBUG and [DBG]!\r
  81 \\r
  82 \\r
  83 \ There some additional words to control the debugger a runtime. These\r
  84 \ words have short names to be typepable at debugtime. But of course\r
  85 \ you may also compile them into your code. Thsi gives you the\r
  86 \ possibility to realize breakpoints etc.\r
  87 \\r
  88 \ [+I], [-I]\r
  89 \ Interactive. This switch controls wether you do singlestepping or a\r
  90 \ kind of code animation. When singlestepping, you can type any number\r
  91 \ of Forth statements between two steps. The next step is peformed when\r
  92 \ simply pressing <return>.\r
  93 \\r
  94 \ [+V], [-V]\r
  95 \ Verbose. [+V] adds a stack dump to the output on each step.\r
  96 \\r
  97 \ [+S], [-S]\r
  98 \ Silent. [+S] switches off all outputs and the program begins to run.\r
  99 \ Pressing a key switches it back to interactive mode.\r
 100 \\r
 101 \ [>L] ( n -- )\r
 102 \ Goto Level of nesting. This option recieves a parameter (don't forget).\r
 103 \ It lets the debugger run in '[+S] [-I] [-V]'-mode until the given\r
 104 \ level of nesting is reached the next time. Then the previous state of\r
 105 \ the debugger is restored.\r
 106 \ Note that the given level may be lower, higher or equal to the current level.\r
 107 \ You can overwrite the settings invoked be [>L] with further debugger\r
 108 \ commands.\r
 109 \ Suppose you are on level 1, than\r
 110 \    1 [>L] [-S]\r
 111 \ will give you an animation of your code until the next word on nestinglevel 1\r
 112 \ is reached.\r
 113 \\r
 114 \ [Y]\r
 115 \ Step over. This command will avoid nesting to deeper levels. It is\r
 116 \ equivalent to a [>L] with the current level. So the example above can\r
 117 \ be written as:\r
 118 \    [Y] [-S]\r
 119 \\r
 120 \\r
 121 \ [DEF]\r
 122 \ Default: [+I] [-V] [-S], no nestlevel targeting\r
 123 \\r
 124 \\r
 125 \ The debugger also supports a decompiler feature for words compiled with the\r
 126 \ debugger on. The decompiler is envoked by\r
 127 \\r
 128 \ DSEE <name>\r
 129 \\r
 130 \ and decompiles the whole word at once. For this decompiler works completely\r
 131 \ different from these you maybe know, it has e.g. the possibility to\r
 132 \ decompile even things which were in you source with the compiler off.\r
 133 \ This means, sequences like '... [ 1 2 3 + + ] LITERAL ...' will\r
 134 \ reappear while decompiling.\r
 135 \\r
 136 \\r
 137 \ 0!DBG\r
 138 \\r
 139 \ This is the debugger's reset. It sets back e.g. the level of nesting.\r
 140 \ You should use this at the beginning of a file you compile, e.g.\r
 141 \      0!DBG\r
 142 \ in the first line.\r
 143 \\r
 144 \\r
 145 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 146 \ WORKS WITH\r
 147 \\r
 148 \   F68KANS (>jan94)    portable 68k nativecode Forth by me\r
 149 \   pfe0.9.7            by Dirk Zoller\r
 150 \   thisForth           by Wil Baden\r
 151 \\r
 152 \ Reported to work with:\r
 153 \\r
 154 \   gforth              by Bernd Paysan (paysan@informatik.tu-muenchen.de)\r
 155 \   iForth              by Marcel Hendrix (mhx@bbs.forth-ev.de)\r
 156 \\r
 157 \\r
 158 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 159 \ ENVIRONMENTAL DEPENDENCIES\r
 160 \\r
 161 \ When the decompiler option is used:\r
 162 \   The Control Stack (CS) has to be the data stack.\r
 163 \\r
 164 \\r
 165 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 166 \ RESTRICTIONS:\r
 167 \\r
 168 \ The generation of debugging code can only be invoked with the words\r
 169 \ ':', DOES> and :NONAME (or words which use them, after the debugger\r
 170 \ has been compiled).\r
 171 \\r
 172 \ The debugger is steered by some string literals: debugging is switched\r
 173 \ off when the debugger's outer interpreter finds the words DBG] or ';'.\r
 174 \ The words a compiled as string literals into the debugger, so no\r
 175 \ definitions including them will be able to do theire job!\r
 176 \ Further, the words ';' and '[' have a special meaning for the\r
 177 \ debugger (they both switch off the Forth compiler).\r
 178 \\r
 179 \ In the current state, the debugger cannot handle floating point\r
 180 \ literals. This will be removed in one of the next releases.\r
 181 \\r
 182 \\r
 183 \\r
 184 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 185 \ HOW IT WORKS\r
 186 \\r
 187 \ A standard system does not let you examine the code. You do not know\r
 188 \ anything about it's location in memory or it's structure. You do not\r
 189 \ know wether it is direct or inderect threaded or native code.\r
 190 \ But most debuggers exactly do that: they examine the code, and sometimes\r
 191 \ even modify it at runtime (e.g. to set breakpoints in native code systems).\r
 192 \ They need detailed knowledge about the code and the CPU it runs on.\r
 193 \ In most cases, additional knowledge about the structure of the\r
 194 \ dictionary is needed, too.\r
 195 \\r
 196 \ For all that cannot be done with an ANSI Forth system, this debugger\r
 197 \ tries a completely different way.\r
 198 \ From the things said above, it is clear that once the code is\r
 199 \ generated, there is no possibility for debugging any more. So an ANSI\r
 200 \ debugger has to generate a special debugging code. In order to do that,\r
 201 \ it must define a new compiler, because an ANSI system does not\r
 202 \ let you manipulate the outer interpreter.\r
 203 \ My debugger uses an own outer interpreter which generates, let's say,\r
 204 \ 'self debugging code'.\r
 205 \ (Thanks to the standard comittee for providing REFILL)\r
 206 \\r
 207 \ The next serious problem is how to access the source? There are\r
 208 \ different input sources like TIB, files, blocks or strings. Perhaps for\r
 209 \ blocks it would be possible to compile the blocknumber into the code.\r
 210 \ Then the right block could be accessed at runtime.\r
 211 \ Files would be more complicated, because they are represented by a\r
 212 \ single number, which may be OS dependent. Reaccessing a file from\r
 213 \ this number later means to implement a completely new\r
 214 \ file word set. I did not want to do that!\r
 215 \ With source from TIB or a string, the source retrieval will be\r
 216 \ impossible at all.\r
 217 \ So the only way to solve the problem is to compile the source together\r
 218 \ with the generated code!\r
 219 \ (Thanks to the standard comittee for providing SLITERAL)\r
 220 \\r
 221 \ The following code is generated (in general) for a Forth word <word>:\r
 222 \\r
 223 \       [ S" <word>" ] SLITERAL dodebug nodecomp @ IF <word> THEN\r
 224 \\r
 225 \ (So make sure that you have enough space in your code area!)\r
 226 \\r
 227 \\r
 228 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 229 \  REMARKS\r
 230 \\r
 231 \ V0.2 initially did not work with Wil Baden's thisForth.\r
 232 \ The reason seemed to be\r
 233 \ that VALUES cannot be POSTPONEd in thisForth. So I turned the VALUE\r
 234 \ 'decompile' into the VARIABLE 'nodecomp'.\r
 235 \ thisForth had (has?) some problems with it's REFILL. Wil Baden send\r
 236 \ me a valid definition:\r
 237 \\r
 238 \  : REFILL ( -- flag ) next-char eof <> ;\r
 239 \\r
 240 \ Don't wonder about what you see when debugging thisForth programs!\r
 241 \ The debugger also sees thisForth's macro expansions!!\r
 242 \\r
 243 \r
 244 \r
 245 \ CR .(  ANSI Forth debugger V0.3     by Joerg Plewe, 1dec94 ) CR\r
 246 \r
 247 MARKER *debugger*\r
 248 \r
 249 \\r
 250 \ customization\r
 251 \\r
 252  \ Compile the decompiler feature?\r
 253  \ This will introduce an environmental dependency!\r
 254 \ TRUE CONSTANT withDSEE\r
 255 \r
 256 \ Try to find out wether the control stack is the data stack.\r
 257 \ In this case, the system fullfills the environmental dependency\r
 258 MARKER *check_for_controlstack*\r
 259 FALSE VARIABLE CSisDS  CSisDS !\r
 260 VARIABLE saveDEPTH\r
 261 \r
 262 : checker\r
 263   [ DEPTH saveDEPTH ! ]\r
 264   IF             \ IF should change the controlstack\r
 265   [ DEPTH saveDEPTH @ > CSisDS ! ]   \ datastack changed?\r
 266   THEN ;\r
 267 \r
 268 CSisDS @ *check_for_controlstack*  CONSTANT withDSEE\r
 269 \r
 270 \r
 271 \r
 272 \r
 273 : is_defined ( <name> -- flag )\r
 274   BL WORD FIND NIP ;\r
 275 \r
 276 \ prelude\r
 277 \ is_defined ON  is_defined OFF  AND  0=\r
 278 \ [IF]\r
 279 : ON  ( addr -- )   TRUE SWAP ! ;\r
 280 : OFF ( addr -- )  FALSE SWAP ! ;\r
 281 \ [THEN]\r
 282 \r
 283 \r
 284 \r
 285 \r
 286 \\r
 287 \ switching debugger globally\r
 288 \\r
 289 VARIABLE use_debugger       use_debugger ON\r
 290    \ use the debugger at all?\r
 291 VARIABLE nodecomp           nodecomp ON\r
 292    \ controls decompiling vs. debugging at runtime\r
 293 VARIABLE creating_dbgcode   creating_dbgcode OFF   \ internal switch\r
 294 VARIABLE nestlevel          0 nestlevel !          \ level of nesting\r
 295 \r
 296 \r
 297 \r
 298 : +DEBUG ( -- )\r
 299   use_debugger ON ;\r
 300 \r
 301 : -DEBUG ( -- )\r
 302   use_debugger OFF ;\r
 303 \r
 304 \r
 305 \r
 306 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 307 \\r
 308 \ executing watches\r
 309 \\r
 310 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 311 \r
 312 10 CONSTANT #watches\r
 313 CREATE watchlist #watches CELLS ALLOT\r
 314 \r
 315 : slot ( n -- addr )\r
 316         CELLS watchlist + ;\r
 317 \r
 318 : watch_execute ( xt -- flag )\r
 319         DEPTH >R  EXECUTE  DEPTH R> -           \ may ONLY return a flag!\r
 320         ABORT" A watch is not legal: not returning ONLY a flag!"\r
 321         ;\r
 322 \r
 323 \r
 324 : do_watch ( n -- flag )\r
 325         DUP 0 #watches WITHIN\r
 326         IF\r
 327                 slot @ DUP                      \ if slot @ gives 0, this is\r
 328                                                         \ uses as a FALSE\r
 329                 IF  watch_execute  THEN\r
 330         ELSE DROP FALSE THEN ;\r
 331 \r
 332 : do_watches ( -- flag )\r
 333         FALSE\r
 334         #watches 0 DO  I do_watch 0= 0= OR  LOOP ;\r
 335 \r
 336 \r
 337 : find_free_slot ( -- n | -1 )\r
 338         #watches 0\r
 339         DO\r
 340                 I slot @ 0=\r
 341                 IF  I UNLOOP EXIT  THEN\r
 342         LOOP\r
 343         -1 ;\r
 344 \r
 345 : 0!WATCHES ( -- )\r
 346         watchlist #watches CELLS ERASE ;\r
 347 \r
 348 0!WATCHES\r
 349 \r
 350 \r
 351 : :WATCH ( -- xt ) ( C: -- colon-sys )\r
 352         use_debugger @ -DEBUG           \ no debugging of the watches\r
 353         :NONAME ;\r
 354 \r
 355 : ;WATCH ( xt -- ) ( C: colon-sys -- )\r
 356         POSTPONE ;\r
 357         SWAP use_debugger !\r
 358         find_free_slot DUP 0< 0=\r
 359         IF\r
 360                 DUP >R slot !\r
 361                 R> ." ( Slot #" . ." filled with watch.) "\r
 362         ELSE\r
 363                 2DROP TRUE ABORT" Cannot add more watches!"\r
 364         THEN ;\r
 365 IMMEDIATE\r
 366 \r
 367 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 368 \\r
 369 \ we need some routines for service\r
 370 \\r
 371 \r
 372 \\r
 373 \ is a string a number?\r
 374 \\r
 375 : ?negate ( n sign -- n' )     0< IF NEGATE THEN ;\r
 376 : ?dnegate ( d sign -- d' )    0< IF DNEGATE THEN ;\r
 377 \r
 378 : number? ( addr c -- FALSE | u 1 | ud -1 )\r
 379    \ Tries to find out, wether the given string can be interpreted\r
 380    \ as a numeric literal.\r
 381    \ Returns a flag and the converted number, if possible.\r
 382         0 >R                                            \ push default sign\r
 383         OVER C@ [CHAR] - = IF R> DROP -1 >R  THEN       \ - sign?\r
 384         OVER C@ [CHAR] + = IF R> DROP  1 >R  THEN       \ + sign?\r
 385         R@ ABS /STRING\r
 386         0. 2SWAP >NUMBER  ( ud2 c-addr2 u2 )\r
 387         ?DUP 0= IF  DROP D>S R> ?negate  1 EXIT  THEN   ( exit: single )\r
 388         1 = SWAP C@ [CHAR] . = AND                      \ with a '.', it is double\r
 389         IF  R> ?dnegate  -1 EXIT  THEN                  ( exit: double )\r
 390         R> DROP 2DROP FALSE\r
 391         ;\r
 392 \r
 393 \r
 394 \r
 395 \\r
 396 \ things to be done while debugging\r
 397 \\r
 398 \r
 399 CREATE debugTIB 80 CHARS ALLOT\r
 400 : eval_debug_statements ( -- )\r
 401   \ A simple outer interpreter for interactive input at\r
 402   \ debugtime.\r
 403         BEGIN\r
 404           CR ." > " debugTIB DUP 80 ACCEPT SPACE DUP\r
 405         WHILE\r
 406           ['] EVALUATE  CATCH IF ." Oops!?" CR THEN\r
 407         REPEAT\r
 408         2DROP ;\r
 409 \r
 410 \r
 411 : .next_statement ( addr len -- )\r
 412   \ addr len shows the name of the following statement in the\r
 413   \ source code. .next_statement formats and prints it.\r
 414         nestlevel @ 2* SPACES\r
 415         nodecomp @ IF\r
 416           ." Nxt["   nestlevel @ S>D <# #S #> TYPE  ." ]: "\r
 417         THEN\r
 418         TYPE\r
 419         ;\r
 420 \r
 421 \r
 422 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 423 \\r
 424 \ steering the debugger\r
 425 \\r
 426 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 427 VARIABLE debugstate     0 debugstate !\r
 428                           \ Bit 0 = Interactive\r
 429                           \ Bit 1 = Silent\r
 430                           \ Bit 2 = Verbose\r
 431 \r
 432 : +debugstate: ( state <name> -- )\r
 433     CREATE ,\r
 434     DOES> @ debugstate @ OR debugstate ! ;\r
 435 \r
 436 : -debugstate: ( state <name> -- )\r
 437     CREATE INVERT ,\r
 438     DOES> @ debugstate @ AND debugstate ! ;\r
 439 \r
 440 : ?debugstate: ( state <name> -- )\r
 441     CREATE ,\r
 442     DOES> @ debugstate @ AND 0<> ;\r
 443 \r
 444 1  DUP +debugstate: (+I)  DUP -debugstate: [-I]  ?debugstate: [?I]\r
 445 2  DUP +debugstate: [+S]  DUP -debugstate: [-S]  ?debugstate: [?S]\r
 446 4  DUP +debugstate: [+V]  DUP -debugstate: [-V]  ?debugstate: [?V]\r
 447 \r
 448 \\r
 449 \ define some additional rules\r
 450 \\r
 451 : [+I] ( -- )          \ interactive can never be silent\r
 452         [-S] (+I) ;\r
 453 \r
 454 VARIABLE target_nestlevel      -1 target_nestlevel !\r
 455 VARIABLE savedebugstate       debugstate @ savedebugstate !\r
 456 \r
 457 \r
 458 : check_nesting ( -- )\r
 459   \ Checks wether the execution has reached a defined level\r
 460   \ of nexting (target_nestlevel). In this case, it switches off\r
 461   \ targetting (-1!) and restore the previously saved state\r
 462   \ of the debugger.\r
 463         target_nestlevel @ nestlevel @ =\r
 464         IF\r
 465           -1 target_nestlevel !           \ switch targeting off\r
 466           savedebugstate @ debugstate !\r
 467         THEN ;\r
 468 \r
 469 \r
 470 : [>L] ( n -- )                      \ goto level\r
 471         target_nestlevel !\r
 472         debugstate @ savedebugstate !\r
 473         [+S] [-I] [-V]\r
 474         ;\r
 475 \r
 476 \r
 477 : [Y] ( -- )                      \ step over\r
 478         nestlevel @ [>L]\r
 479         ;\r
 480 \r
 481 \r
 482 \r
 483 : [DEF] ( -- )      \ the default behaviour\r
 484         -1 target_nestlevel !\r
 485         [+I] [-V] [-S] ;\r
 486 \r
 487 [DEF]\r
 488 \r
 489 \r
 490 \\r
 491 \\r
 492 \ check: what has to be displayed?\r
 493 \\r
 494 \\r
 495 : ?.next_statement ( addr len -- )\r
 496   \ When the debugger is not running silent, the following\r
 497   \ has to be displayed. When not beeing interactive, a CR\r
 498   \ has to be added.\r
 499         [?S] 0=\r
 500         IF\r
 501           .next_statement\r
 502           [?I] 0= IF CR THEN\r
 503         ELSE  2DROP  THEN\r
 504         ;\r
 505 \r
 506 \r
 507 : ?eval_debug_statements ( -- )\r
 508   \ When the debugger is interactive but not silent, we want\r
 509   \ to evaluate statements.\r
 510     [?I] [?S] 0= AND\r
 511     IF  eval_debug_statements  THEN ;\r
 512 \r
 513 : ?.s ( -- )\r
 514   \ Perhaps, a stackdump is needed. This is indicated by the\r
 515   \ verbose mode.\r
 516     [?V] [?S] 0= AND\r
 517     IF  .S  CR THEN ;\r
 518 \r
 519 : ?>[+I] ( -- )\r
 520   \ Oh oh. Return to interactive mode when a key is pressed\r
 521   \ or a watch is activated.\r
 522         nodecomp @\r
 523         IF\r
 524         EKEY? IF  KEY DROP  [+I]  THEN\r
 525                 do_watches IF  [+I]  THEN\r
 526         THEN ;\r
 527 \r
 528 \r
 529 : dodebug ( addr len -- )\r
 530   \ This word is executed between two statements in the source.\r
 531   \ Note I had to do some stack juggling for the stack has to\r
 532   \ be 'original' when showing the stackdump!\r
 533         use_debugger @ IF                 \ wonna debug anyway?\r
 534           check_nesting\r
 535           ?>[+I]\r
 536           >R >R ?.s R> R>       ( >R's for addr len )\r
 537           ?.next_statement\r
 538           ?eval_debug_statements\r
 539         ELSE  2DROP  THEN\r
 540         ;\r
 541 \r
 542 \r
 543 \r
 544 \r
 545 \r
 546 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 547 \\r
 548 \ this section is to create debugging code\r
 549 \\r
 550 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
 551 \r
 552 \r
 553 \\r
 554 \ THIS word is the main point:\r
 555 \ It compiles code suitable for debugging.\r
 556 \ Or better: it compiles self-debugging code\r
 557 \\r
 558 : .source, ( c-addr -- )\r
 559     STATE @ DUP >R 0= IF ] THEN     \ switch compiler on for SLITERAL\r
 560     COUNT\r
 561     POSTPONE SLITERAL ( POSTPONE) ALIGN\r
 562     POSTPONE dodebug\r
 563     R> 0= IF POSTPONE [ THEN        \ switch compiler off when it was off\r
 564     ;\r
 565 \r
 566 CREATE wordbuf 64 CHARS ALLOT\r
 567 \r
 568 : >wordbuf ( c-addr -- )\r
 569   DUP C@ CHAR+ wordbuf SWAP CHARS MOVE ;\r
 570 \r
 571 \r
 572 : C$= ( c-addr addr u -- flag )\r
 573      ROT COUNT COMPARE 0= ;\r
 574 \r
 575 : $;=    ( c-addr -- flag )   S" ;"     C$= ;\r
 576 : $DBG]= ( c-addr -- flag )   S" DBG]"  C$= ;\r
 577 : $[=    ( c-addr -- flag )   S" ["     C$= ;\r
 578 \r
 579 \r
 580 : apply_semantic ( xt +-1 -- ? )\r
 581         0< STATE @  AND\r
 582         IF  COMPILE,  ELSE  EXECUTE THEN ;\r
 583 \r
 584 \r
 585 : compile_number ( u 1 | ud -1 -- )\r
 586   STATE @ 0<>\r
 587   IF\r
 588      0< IF  POSTPONE 2LITERAL  ELSE  POSTPONE LITERAL  THEN\r
 589   ELSE DROP THEN ;\r
 590 \r
 591 \r
 592 : compiler_error ( c-addr -- )\r
 593   ." Not found in dictionary: " wordbuf COUNT TYPE\r
 594   -13 THROW ;\r
 595 \r
 596 \r
 597 \\r
 598 \ handling the nesting level\r
 599 \\r
 600 : +nest ( -- )\r
 601    1 nestlevel +! ;\r
 602 : -nest ( -- )\r
 603    -1 nestlevel +! ;\r
 604 \r
 605 \r
 606 \r
 607 : endof_dbgd_def? ( -- flag )     \ end of debugged definition?\r
 608         wordbuf $;=\r
 609         wordbuf $DBG]= OR\r
 610         ;\r
 611 \r
 612 : compiler_off? ( -- flag )     \ a word, which switches the compiler off?\r
 613         wordbuf $;=\r
 614         wordbuf $[= OR\r
 615         ;\r
 616 \r
 617 \r
 618 \r
 619 \\r
 620 \ compile conditinal branches to skip 'real' code for decompiling\r
 621 \\r
 622 withDSEE [IF]\r
 623 \r
 624 CREATE CSbuffer 20 CELLS ALLOT\r
 625 VARIABLE decompilerIF     decompilerIF OFF\r
 626 VARIABLE saveDEPTH        0 saveDEPTH !\r
 627 VARIABLE CSsaved          0 CSsaved !\r
 628 \r
 629 : saveCS ( ? -- )\r
 630   \ Save control structure information from the data stack\r
 631   \ to a special buffer.\r
 632   \ The variable saveDEPTH has to be set!!\r
 633         0 CSsaved !\r
 634         BEGIN\r
 635           DEPTH saveDEPTH @ <>\r
 636         WHILE\r
 637           CSbuffer CSsaved @ CELLS + !\r
 638           1 CSsaved +!\r
 639         REPEAT ;\r
 640 \r
 641 : restoreCS ( -- ? )\r
 642   \ restore control structure information from the buffer to stack\r
 643         BEGIN\r
 644           CSsaved @\r
 645         WHILE\r
 646           -1 CSsaved +!\r
 647           CSbuffer CSsaved @ CELLS + @\r
 648         REPEAT ;\r
 649 \r
 650 \r
 651 : decompiler_jump ( -- )\r
 652   \ Under right conditions, compile a 'nodecomp @ IF'\r
 653   \ The possible change on data stack (IF) is cleared, so that\r
 654   \ words like LITERAL do not come into trouble.\r
 655   \ The Control Stack CS defined in the ANSI document may consist\r
 656   \ of some entries on the common data stack (which, indeed, is implemented\r
 657   \ in most Forth systems). But the data stack has to be unchanged by the\r
 658   \ debugger when compiling a word: ' ... [ 1 2 3 + + ] LITERAL ...'\r
 659   \ In this example, 'LITERAL' wants to compile the number 6, and not some\r
 660   \ token left on the stack by the decompiler's IF. For it is unknown,\r
 661   \ what IF will place in an arbitary Forth system, this complicated\r
 662   \ construction has to be made.\r
 663         STATE @  compiler_off? 0= AND\r
 664         IF\r
 665           DEPTH saveDEPTH !             \ DEPTH of stack 'before'\r
 666           POSTPONE nodecomp  POSTPONE @\r
 667           POSTPONE IF                   \ now compile IF. It may change stack!\r
 668           saveCS                        \ stackeffect of IF removed\r
 669           decompilerIF ON               \ ok, there is an IF\r
 670         THEN\r
 671         ;\r
 672 \r
 673 : decompiler_target ( -- )\r
 674   \ Resolve the decompiler IF compiled\r
 675         decompilerIF @\r
 676         IF\r
 677           restoreCS                     \ prepare stack with IF-values\r
 678           POSTPONE THEN                 \ and resolve the jump.\r
 679           decompilerIF OFF              \ done!\r
 680         THEN\r
 681         ;\r
 682 \r
 683 [ELSE]  ( withDSEE )\r
 684 : decompiler_jump ;   IMMEDIATE\r
 685 : decompiler_target ; IMMEDIATE\r
 686 [THEN]  ( withDSEE )\r
 687 \r
 688 \r
 689 \r
 690 \\r
 691 \ now construct a complete outer interpreter\r
 692 \\r
 693 \r
 694 \ a special hack to allow F68KANS to handle files with tabs etc.\r
 695 is_defined F68kAns\r
 696   [IF] blankbits  [ELSE]  BL  [THEN]\r
 697   CONSTANT whitespace\r
 698 \r
 699 \r
 700 : create_debugging_code ( -- )\r
 701   POSTPONE +nest\r
 702   creating_dbgcode @ >R creating_dbgcode ON\r
 703   BEGIN                                           \ loop to EOF\r
 704     BEGIN                                         \ loop to EOL\r
 705       whitespace WORD DUP C@\r
 706     WHILE\r
 707       >wordbuf\r
 708       wordbuf .source,\r
 709       endof_dbgd_def? IF  POSTPONE -nest THEN\r
 710       decompiler_jump\r
 711       wordbuf FIND ( c-addr 0 | xt +1 | xt -1 )  ?DUP\r
 712       IF   apply_semantic\r
 713       ELSE                                     ( caddr )\r
 714          COUNT number? ?DUP\r
 715          IF  compile_number  ELSE  compiler_error  THEN\r
 716       THEN\r
 717       decompiler_target\r
 718       endof_dbgd_def? IF  R> creating_dbgcode !  EXIT ( **) THEN\r
 719     REPEAT  DROP\r
 720   REFILL 0= UNTIL\r
 721   R> creating_dbgcode !\r
 722 ;\r
 723 \r
 724 \r
 725 \r
 726 \r
 727 \r
 728 \r
 729 \\r
 730 \ Define the decompiler\r
 731 \\r
 732 withDSEE [IF]\r
 733 : DSEE ( <name> -- )\r
 734   \ Show a decompiler listing of a word compiled with the debugger.\r
 735   \ A non-debugger word will be executed instead.\r
 736         CR\r
 737         nodecomp @  >R     FALSE nodecomp !\r
 738         debugstate @ >R    [-I] [-V] [-S]\r
 739         ' EXECUTE\r
 740         R> debugstate !\r
 741         R> nodecomp !\r
 742         ;\r
 743 [ELSE]\r
 744 : DSEE ( <name> -- )\r
 745         CR BL WORD DROP\r
 746         ." Debugger compiled without decompiler option! "\r
 747         ;\r
 748 [THEN]\r
 749 \r
 750 \r
 751 \\r
 752 \ Now the replacements for the code-beginning words.\r
 753 \\r
 754 \r
 755 : debug: ( <name> -- )\r
 756   :   create_debugging_code ;\r
 757 \r
 758 : debug:NONAME ( --  xt )\r
 759   :NONAME   create_debugging_code ;\r
 760 \r
 761 \r
 762 : debugDOES>\r
 763   creating_dbgcode @ IF POSTPONE -nest THEN\r
 764       \ when the decompiler is invoked between ':' and 'DOES>',\r
 765       \ there has to be a '-nest' compiled before 'DOES>'.\r
 766   POSTPONE DOES>  create_debugging_code ;\r
 767 \r
 768 \r
 769 \\r
 770 \ switching the debugger on and off\r
 771 \\r
 772 VARIABLE debugging     debugging OFF\r
 773 \r
 774 : [DBG\r
 775   debugging ON ;  IMMEDIATE\r
 776 \r
 777 : DBG]\r
 778   debugging OFF ;  IMMEDIATE\r
 779 \r
 780 \r
 781 : 0!DBG ( -- )\r
 782   \ reset the debugger\r
 783         0 nestlevel !\r
 784         POSTPONE [DBG\r
 785         +DEBUG\r
 786         [DEF]\r
 787         creating_dbgcode OFF\r
 788         ;\r
 789 \r
 790 \r
 791 \r
 792 \\r
 793 \ redefinition of the code generating defining words\r
 794 \\r
 795 : : ( <name> -- )\r
 796   use_debugger @ debugging @ AND\r
 797   IF  debug:  ELSE  :  THEN ;\r
 798 \r
 799 : DOES> ( <name> -- )\r
 800   use_debugger @ debugging @ AND\r
 801   IF  debugDOES>  ELSE  POSTPONE DOES>  THEN ; IMMEDIATE\r
 802 \r
 803 : :NONAME ( <name> -- )\r
 804   use_debugger @ debugging @ AND\r
 805   IF  debug:NONAME  ELSE  :NONAME  THEN ;\r
 806 \r
 807 \r
 808 \\r
 809 \ OK\r
 810 \\r
 811 CR\r
 812 .( The words for you are: ) CR\r
 813 .(   +DEBUG -DEBUG     to switch debugging on/off globally ) CR\r
 814 .(   [DBG   DBG]       to envoke and terminate generation ) CR\r
 815 .(                     of debugging code at compiletime ) CR\r
 816 .(   :WATCH ;WATCH     Define a watch function returning a flag ) CR\r
 817 .(   0!WATCHES         to remove all watch functions ) CR\r
 818 .(   [+I]   [-I]       Interactive mode on/off ) CR\r
 819 .(   [+S]   [-S]       Silent mode on/off ) CR\r
 820 .(   [+V]   [-V]       Verbose mode on/off ) CR\r
 821 .(   [>L]   [Y]        level targeting control ) CR\r
 822 .(   [DEF]             DEFault settings ) CR\r
 823 withDSEE [IF]\r
 824 .(   DSEE              Decompile words compiled with debugger ) CR\r
 825 [THEN]\r
 826 .(   0!DBG             Reset the debugger when something goes wrong ) CR\r
 827 \r
 828 \r
 829 \1a