[Win32forth-cvs] win32forth/src CLASSDBG.F,1.6,1.7

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27674/win32forth/src

Modified Files:
	CLASSDBG.F 
Log Message:
gah: Added utility to check for matching hash values

Index: CLASSDBG.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/CLASSDBG.F,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** CLASSDBG.F	29 Aug 2005 15:56:27 -0000	1.6
--- CLASSDBG.F	9 Jan 2006 13:29:53 -0000	1.7
***************
*** 1,5 ****
  \ $Id$
  
! \ classdbg.f
  
  cr .( Loading Object Debugging...)
--- 1,7 ----
  \ $Id$
  
! \ *! doc\p-classdbg W32F classdbg
! \ *T Class Debugging Words
! \ *P Win32Forth contains some miscellaneous words to help with developing Classes and Objects.
  
  cr .( Loading Object Debugging...)
***************
*** 9,13 ****
  also classes
  
! : .method     ( mlink -- mlink )
                  dup cell+ @ unhash
                  type 14 #tab space 14 ?cr ;
--- 11,15 ----
  also classes
  
! : .method       ( mlink -- mlink )
                  dup cell+ @ unhash
                  type 14 #tab space 14 ?cr ;
***************
*** 19,25 ****
                  repeat  ;
  
  external
  
! : cmethods      ( 'class' -- )          \ methods of a class
                  { \ superlist -- }
                  cr ." New Methods :-" cr
--- 21,45 ----
                  repeat  ;
  
+ : ?.match       ( n lfa -- n )
+                 link> dup @ docon = if
+                   2dup execute = if
+                     >name id. 20 #tab space 20 ?cr else
+                     drop then else
+                   drop then ;
+ 
+ : #matches      ( n -- )
+                 cr hash-wid voc#threads 0 do
+                   ['] ?.match hash-wid i cells+ do-link loop
+                 drop ;
+ 
+ : "matches      ( addr len -- )
+                 2dup upper method-hash #matches ;
+ 
  external
  
! \ *S Glossary
! 
! : cmethods      ( 'class' -- )          \ W32F      Class debug
! \ *G Print out all the methods of a class.
                  { \ superlist -- }
                  cr ." New Methods :-" cr
***************
*** 33,37 ****
                   _methods ;
  
! : methods       ( object-address -- )
                  depth 0=
                  if      ' execute
--- 53,58 ----
                   _methods ;
  
! : methods       ( object-address -- )    \ W32F      Class debug
! \ *G Print out all the methods of an object.
                  depth 0=
                  if      ' execute
***************
*** 39,43 ****
                  cr obj>class _methods ;
  
! : ivars         ( object-address -- )
                  depth 0=
                  if      ' execute
--- 60,65 ----
                  cr obj>class _methods ;
  
! : ivars         ( object-address -- )    \ W32F      Class debug
! \ *G Print out all the object IVARs of an object.
                  depth 0=
                  if      ' execute
***************
*** 50,53 ****
--- 72,82 ----
                  repeat ;
  
+ 
+ : matches   ( -<name>- )                 \ W32F      Class debug
+ \ *G Print out all the method selectors and IVAR names that have the same hash value as
+ \ ** -<name>- will be assigned. If -<name>- is already in use as a selector or an IVAR name
+ \ ** then it will appear in the list.
+             bl word count "matches ;
+ 
  previous
  
***************
*** 69,73 ****
  also classes
  
! : objects       ( 'class' -- )  \ display direct object for 'class'
                  ' >body to theClass
                  ['] .obj on-allwords ;
--- 98,103 ----
  also classes
  
! : objects       ( 'class' -- )     \ W32F       Class debug
! \ *G Display all of the instances of 'class'.
                  ' >body to theClass
                  ['] .obj on-allwords ;
***************
*** 79,105 ****
  classes also hidden also bug also
  
! \ : GetMethod     { \ m0cfa -- -<method: object>- m0cfa }  \ return xt of method
! \                 @word _msgFind 1 <> abort" Undefined Method"
! \                 TRUE to get-reference?  \ tell do_message to return method
! \                 depth >r
! \                 execute to m0cfa        \ execute do_message
! \                 depth r> <
! \                 if      0               \ if it was a class, object is NULL
! \                 then    to obj-save m0cfa ;
! \ 
! \ : [GetMethod]   ( compiling:- -<method: object>- -- )
! \                 ( runtime:-  -- m0cfa )
! \                 state @ >r postpone [
! \                 GetMethod r> if ] then
! \                 Postpone Literal ; Immediate
  
! : msee          ( -<method object>- )         \ display code of method
                  GetMethod cr ." :M " dup .m0name 2 spaces
                  dup  2 cells+ @ if
!                 cell+ .locals                   \ display locals if present 
                  else 3 cells+ then              \ step to the PFA
                  .pfa ;                          \ decompile the definition
  
! : mdebug        ( -<method object>- )           \ set debugging of method
                  unbug
                  false to ?dbg-cont              \ turn off continuous step
--- 109,125 ----
  classes also hidden also bug also
  
! \ GetMethod and [GetMethod] have been moved to Class.f
  
! : msee          ( -<method object>- )       \ W32F      Class debug
! \ *G Display the source code of the method. Either a Class or Object can be supplied.
                  GetMethod cr ." :M " dup .m0name 2 spaces
                  dup  2 cells+ @ if
!                 cell+ .locals                   \ display locals if present
                  else 3 cells+ then              \ step to the PFA
                  .pfa ;                          \ decompile the definition
  
! : mdebug        ( -<method object>- )         \ W32F      Class debug
! \ *G Set debugging of the method. An Object must be supplied (Classes aren't allowed).
! \ ** NOTE the method will be debugged for all objects that respond to it.
                  unbug
                  false to ?dbg-cont              \ turn off continuous step
***************
*** 109,113 ****
                  3 cells+ tracing ;
  
! : mdbg          ( -<method object>- )    \ debug a method now
                  >in @ mdebug >in ! ;
!                 
--- 129,138 ----
                  3 cells+ tracing ;
  
! : mdbg          ( -<method object>- )         \ W32F       Class debug
! \ *G Set debugging of the method and then execute it.
! \ ** An Object must be supplied (Classes aren't allowed).
! \ ** NOTE the method will be debugged for all objects that respond to it.
                  >in @ mdebug >in ! ;
! 
! 
! \ *Z