home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd6.lzh / LIB / TILE / debugger.f83 < prev    next >
Text File  |  1989-12-21  |  5KB  |  144 lines
  1. \
  2. \  FORTH DEBUGGER DEFINITIONS
  3. \
  4. \  Copyright (c) 1989 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 29 November 1989
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, compiler, structures, blocks
  20. \
  21. \  Description:
  22. \       Basic debugging function built on a general advice function
  23. \       management. Allows black-box tracing, break points and
  24. \       colon definitions call profiling.
  25. \
  26. \  Copying:
  27. \       This program is free software; you can redistribute it and\or modify
  28. \       it under the terms of the GNU General Public License as published by
  29. \       the Free Software Foundation; either version 1, or (at your option)
  30. \       any later version.
  31. \
  32. \       This program is distributed in the hope that it will be useful,
  33. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  34. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35. \       GNU General Public License for more details.
  36. \
  37. \       You should have received a copy of the GNU General Public License
  38. \       along with this program; see the file COPYING.  If not, write to
  39. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  40.  
  41. .( Loading Debugger definitions...) cr
  42.  
  43. #include structures.f83
  44. #include forth.f83
  45. #include blocks.f83
  46.  
  47. vocabulary debugger
  48.  
  49. compiler blocks structures forth debugger definitions
  50.  
  51. struct.type ADVICE ( -- )
  52.   ptr  +block private                  ( Pointer to code definition)
  53.   ptr  +entry private                  ( Pointer to entry structure)
  54.   ptr  +advice private                 ( Pointer to advice function)
  55.   long +profile private                        ( Call counter for profiling)
  56. struct.end
  57.  
  58. : [advice] ( advice -- )
  59.   dup +advice @ execute ; private      ( Access and execute the advice)
  60.  
  61. : [colon] ( advice -- )
  62.   1 over +profile +!                   ( Increment profile counter)
  63.   +block @ call ; private              ( Call the code definition)
  64.  
  65. : [trace] ( advice -- )
  66.   ." --> " dup >r +entry @ .name .s cr ( Print function entry)
  67.   r@ [colon]                           ( Call the code definition)
  68.   ." <-- " r> +entry @ .name .s cr     ( Print function exit)
  69. ; private
  70.  
  71. : [break] ( advice -- )
  72.   >r                                   ( Save pointer to advice block)
  73.   begin
  74.     .s ."  Break at: "                 ( Print stack status and break)
  75.     r@ +entry @ .name cr               ( Print name of entry)
  76.     [compile] ascii                    ( Scan a command)
  77.     case
  78.       ascii a                          ( Abort command)
  79.         of abort endof
  80.       ascii c                          ( Call command)
  81.        of r> [colon] exit endof
  82.       ascii e                          ( Execute command)
  83.         of r@ [colon] endof
  84.       ascii p                          ( Profile command)
  85.         of r@ +profile @ . cr endof
  86.       ascii r                          ( Return command)
  87.        of r> drop exit endof
  88.       ." a(bort), c(ontinue), e(xecute), p(rofile) or r(eturn)" cr
  89.    endcase
  90.   again ; private
  91.  
  92. : tail-recurse ( -- )
  93.   compile (branch)                     ( Compile a branch to the beginning)
  94.   last >body +block @ <resolve         ( And resolve the address)
  95. ; compilation immediate
  96.  
  97. : ?advice ( entry -- flag)
  98.   +code @ ['] [advice] >body = ;       ( Check for advice handler)
  99.  
  100. : advice ( action -- )
  101.   ' dup ?advice not                    ( Access entry and check coding)
  102.   abort" advice: not an adviced definition" ( Abort if wrong code type)
  103.   >body                                        ( Access advice block)
  104.   0 over +profile !                    ( Initiate the profile counter)
  105.   +advice ! ;                          ( Define a new advice action)
  106.  
  107. : colon ( -- )
  108.   ['] [colon] advice ;                 ( Use colon as the advice action)
  109.  
  110. : trace ( -- )
  111.   ['] [trace] advice ;                 ( Use trace as the advice action)
  112.  
  113. : break ( -- )
  114.   ['] [break] advice ;                 ( Use break as the advice action)
  115.  
  116. : .r ( n w -- )
  117.   >r <# #s #> r> over - spaces type ;  ( Formated printing of numbers)
  118.  
  119. : .profile ( -- )
  120.   last                                 ( Print profile for all definitions)
  121.   5 spaces ." Calls"                   ( Print a profile header with calls and)
  122.   1 spaces ." Function" cr             ( last the name of the function)
  123.   begin
  124.     dup ?advice                                ( Check for adviced function)
  125.     if dup >body +profile @            ( Access profile information)
  126.       10 .r space                      ( Print in a nice format)
  127.       dup .name cr                     ( Print name)
  128.     then
  129.     +link @ ?dup nil =                 ( Print information about all functions)
  130.   until ;                              ( in the current search path)
  131.       
  132. : : ( -- )
  133.   :                                    ( Use the old colon definition)
  134.   new ADVICE                           ( Create an advice block)
  135.   dup last +parameter !                        ( Store the advice block into the last)
  136.   ['] [advice] >body last +code !      ( Make the last entry use the advice)
  137.   last over +entry !                   ( Save pointer to the entry)
  138.   ['] [colon] over +advice !           ( Colon is the initiate advice action)
  139.   0 over +profile !                    ( Initiate the profile counter)
  140.   here swap +block ! ;                 ( Setup pointer to block definition)
  141.  
  142. forth only
  143.  
  144.