[Win32forth-cvs] win32forth-stc/src CLASSDBG.F, NONE, 1.1 words.f, 1.5, 1.6

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

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv28495/win32forth-stc/src

Modified Files:
	words.f 
Added Files:
	CLASSDBG.F 
Log Message:
gah: on-allwords now working plus classdbg (with some utilities commented out) added

Index: words.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/words.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** words.f	22 May 2007 07:36:20 -0000	1.5
--- words.f	23 May 2007 08:12:58 -0000	1.6
***************
*** 195,199 ****
  : WORDS		( -<optional_name>- ) \ WORDS partial-string will focus the list
                  true to with-tabs? _words ;
! ((
  : on-allwords   { theCFA \ vocBuf -- }
                  512 cells LocalAlloc: vocBuf
--- 195,199 ----
  : WORDS		( -<optional_name>- ) \ WORDS partial-string will focus the list
                  true to with-tabs? _words ;
! 
  : on-allwords   { theCFA \ vocBuf -- }
                  512 cells LocalAlloc: vocBuf
***************
*** 201,207 ****
                  begin   dup vlink>voc
                          dup voc#threads >r
!                         dup voc>vxt@ @
!                         dup   doClass =         \ don't look through classes
!                         swap do|Class = or 0=   \ don't look through classes
                          if      vocBuf r@ cells move    \ copy vocabulary up
                                  begin   vocBuf r@ largest dup
--- 201,205 ----
                  begin   dup vlink>voc
                          dup voc#threads >r
!                         dup voc>vxt@  ?IsClass not      \ don't look through classes
                          if      vocBuf r@ cells move    \ copy vocabulary up
                                  begin   vocBuf r@ largest dup
***************
*** 212,216 ****
                          then    r>drop
                          @ dup 0=
!                 until   drop ;   ))
  
  in-application
--- 210,214 ----
                          then    r>drop
                          @ dup 0=
!                 until   drop ;
  
  in-application

--- NEW FILE: CLASSDBG.F ---
\ $Id: CLASSDBG.F,v 1.1 2007/05/23 08:12:58 georgeahubert Exp $

\ *D 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...)

internal

also classes

: .method       ( mlink -- mlink )
                dup cell+ @ unhash
                type 14 #tab space 14 ?cr ;

: _methods      ( class_body -- )
                MFA #mlists 0 do
                dup i cells+
                begin   @ ?dup
                while   .method
                repeat
                loop drop ;
((
: ?.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 ;
))
previous

external

also classes

\ *S Glossary

: cmethods      ( 'class' -- )          \ W32F      Class debug
\ *G Print out all the methods of a class.
                { \ superlist -- }
                cr ." New Methods :-" cr
                ' >body dup
                sfa @ swap
                #mlists 0 do 2dup
                mfa i cells+ swap mfa i cells+ @ to superlist
                begin   @ dup superlist <>
                while   .method
                repeat  drop
                loop    drop
                cr ." Inherited Methods :-" cr
                 _methods ;

: methods       ( object-address -- )    \ W32F      Class debug
\ *G Print out all the methods of an object.
                depth 0=
                if      ' execute
                then
                cr obj>class _methods ;

: ivars         ( object-address -- )    \ W32F      Class debug
\ *G Print out all the object IVARs of an object.
                depth 0=
                if      ' execute
                then
                cr obj>class IFA
                begin   @ ?dup
                while   dup cell+ @ unhash
                        type 10 #tab ."  (" dup 3 cells+ @ 1 .r ." )"
                        10 #tab space 20 ?cr
                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

INTERNAL

0 value theClass
also classes
: .obj          ( nfa -- )
                dup name>xt dup ?IsObj
                if      >body @ theClass =
                        if      nfa-count type cr
                        else    drop
                        then
                else    2drop
                then    ;
previous
EXTERNAL

also classes

: objects       ( 'class' -- )     \ W32F       Class debug
\ *G Display all of the instances of 'class'.
                ' >body to theClass
                ['] .obj on-allwords ;

previous

MODULE
\s
also classes also hidden also bug

\ 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
                base @ to debug-base
                GetMethod
                obj-save 0= abort" Must specify an Object, not a Class!"
                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 ! ;

previous previous previous

\ *Z