Menu
▾
▴
win32forth-cvs
|
From: Jos v.d.V. <jo...@us...> - 2007-05-19 10:12:32
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv6104 Modified Files: extend.f Added Files: dthread.f words.f Log Message: Jos: Enabled the display of words and threads. --- NEW FILE: dthread.f --- \ $Id: dthread.f,v 1.1 2007/05/19 10:12:28 jos_ven Exp $ \ DTHREAD.F Display the Threads by Tom Zimmer cr .( Loading Hash Thread Display...) synonym voc>vcfa voc>vxt@ synonym l>name link>name ' count alias nfa-count : link> ( link -- cfa ) link>name name>xt ; 0 value words-cnt 0 value app-cnt \ count of application dictionary words 0 value header-cnt : count-voc ( voc -- ) dup voc#threads >r dup voc>vcfa ?isclass not \ don't look through classes if r@ 0 do dup i cells + begin @ ?dup while 1 +to words-cnt dup link> here u< if 1 +to app-cnt then dup l>name c@ 1+ 2 cells+ +to header-cnt repeat start/stop loop then drop r>drop ; : count-words ( -- n1 ) 0 to words-cnt 0 to app-cnt 0 to header-cnt voc-link begin @ ?dup while dup vlink>voc count-voc repeat words-cnt ; : .1thread { voc-thread \ thread-depth -- } 0 to thread-depth voc-thread begin ?dup while dup l>name dup nfa-count nip 5 + ?cr .id @ 1 +to thread-depth start/stop repeat cr ." Thread depth: " thread-depth . cr ; : 1tcount { voc-thread \ thread-depth -- n1 } \ get thread depth of voc thread 0 to thread-depth voc-thread begin @ ?dup while 1 +to thread-depth start/stop repeat thread-depth ; : .thread ( n1 -- ) \ display a thread of context vocabulary >r context @ dup voc>vcfa >name cr ." Vocabulary: " .id cr ." Thread " r@ . dup voc#threads ." of " dup . ." threads" cr r> min 0max cells+ @ .1thread ; : .threads ( -- ) context @ dup voc>vcfa >name cr ." Vocabulary: " .id dup voc#threads 0 do cr ." Thread: " i . cr dup i cells + @ .1thread start/stop loop drop ; : .counts { \ #thread-over -- } 0 to words-cnt 0 to app-cnt 0 to #thread-over context @ count-voc context @ dup voc>vcfa >name cr ." Vocabulary: " .id cr dup voc#threads 0 do ." Thread:Depth " 13 ?line getxy drop 12 < over voc#threads I 1+ = over 0= and if cr then getcolrow drop 12 < or ?leave loop dup voc#threads 0 do 13 ?line ." " i 3 .r ." :" dup i cells + 1tcount dup words-cnt context @ voc#threads / > if 1 +to #thread-over then 3 .r 3 spaces start/stop loop drop cr ." Vocabulary words: " words-cnt . ." Words over average: " #thread-over 100 * context @ voc#threads / 1 .r ." %" cr ." Total system words: " count-words . ; Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.20 retrieving revision 1.21 diff -C2 -d -r1.20 -r1.21 *** extend.f 13 May 2007 21:39:26 -0000 1.20 --- extend.f 19 May 2007 10:12:28 -0000 1.21 *************** *** 39,42 **** --- 39,44 ---- FLOAD src\console\forthdlg.f fload src\xfiledlg.f \ xcall replacements for open dialogs + sys-FLOAD src\words.f + FLOAD src\console\ConsoleMenu.f --- NEW FILE: words.f --- \ $Id: words.f,v 1.1 2007/05/19 10:12:28 jos_ven Exp $ cr .( Loading WORDS...) only forth also definitions in-system Require Dthread.f \ display words from one or two patterns : horizontal-line ( -- ) getcolrow drop getxy drop - 8 - 0max 8 /mod 0 ?do ." --------" loop s" --------" drop swap type cr ; INTERNAL \ internal definitions start here variable vocsave create words-pocket MAXSTRING allot : .voc-once ( -- ) vocsave @ ?dup if cr ." ----------- " .NAME horizontal-line vocsave off then ; : match? ( addr len -- f ) 2dup >r >r words-pocket count search nip nip pocket c@ if r> r> pocket count search nip nip and else r> r> 2drop then words-pocket c@ 0= or ; 0 value with-address? true value with-tabs? : (words) { voc \ words-pad$ w#threads -- } MAXSTRING LocalAlloc: words-pad$ voc dup voc#threads to w#threads dup voc>vcfa ?isclass not \ don't look through classes if dup here 500 + w#threads cells move \ copy vocabulary up voc>vcfa vocsave ! begin here 500 + w#threads largest dup while dup l>name nfa-count 2dup "CLIP" words-pad$ place words-pad$ ?uppercase count match? if .voc-once with-address? if 2 pick link> dup here u> if ." +" else space then ." 0x" h.8 ." " 30 else 20 then -rot type with-tabs? if dup #tab space ?cr else drop cr then 1 +to words-cnt start/stop screendelay ms \ slow down screen output else 2drop then @ swap ! repeat 2drop else drop then vocsave off ; \ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ \ ++++++++++++ display windows constants containing adr,len ++++++++++++++ \ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ \ enum constants \ int wcEnumWin32Constants(char* addr, int len, CALLBACKPROC* proc) \ int callback(char* addr, int len, int value) 0 value constant-cnt 0 value constant-tot 3 CALLBACK: .WinConstantCount ( abs_adr len value -- f ) 3drop 1 +to constant-tot 1 ; 3 CALLBACK: .WinConstant ( abs_adr len value -- f ) drop \ discard the constant's value 2dup match? if type 20 #tab space 20 ?cr 1 +to constant-cnt else 2drop then nuf? 0= ; (( : count-constants ( -- n1 ) \ count the constants available to system constant-tot 0= \ only count if not counted... if WinConPtr proc>cfa @ dodefer = \ Leave if 'wcFindWin32Constant' if 0 EXIT then \ hasn't already been resolved &.WinConstantCount 0 here CALL wcEnumWin32Constants DROP then constant-tot ; )) EXTERNAL : VOCS ( -- ) \ display vocabularies cr ." Vocabularies #Threads #Words #Average" cr VOC-LINK @ BEGIN DUP VLINK>VOC dup voc>vcfa ?isclass not \ don't look through classes IF dup voc>vcfa .NAME 18 #tab dup voc#threads dup>r 4 .r 0 to words-cnt 0 to header-cnt count-voc words-cnt dup 9 .r 10 * r> / 10 .r.1 cr ELSE DROP THEN @ DUP 0= UNTIL DROP ." -----------------------------------------" cr ." Total System Words: " count-words 11 .r cr ; : .words ( -- ) count-words dup cr app-cnt dup 6 u,.r - ." Words in Application dictionary" cr 6 u,.r ." Words in System dictionary" cr 6 u,.r ." Words total in dictionaries" ( cr count-constants 6 u,.r ." Windows Constants available") ; (( : CONSTANTS ( -<optional_name>- ) cr 0 to constant-cnt WinConPtr proc>cfa @ dodefer = \ Leave if 'wcFindWin32Constant' if ." WINCON.DLL missing" EXIT then \ hasn't already been resolved cr ." ----------- Windows Constants " horizontal-line bl word ?uppercase count words-pocket place bl word ?uppercase drop &.WinConstant 0 here CALL wcEnumWin32Constants DROP cr horizontal-line cr ." Displayed " constant-cnt . ." of the " count-constants . ." Windows Constants in the system." ; )) : with-address ( -- ) true to with-address? ; INTERNAL : _WORDS ( -<optional_name>- ) \ WORDS partial-string will focus the list 0 to words-cnt words-pocket off bl word ?uppercase c@ if pocket count words-pocket place bl word ?uppercase drop voc-link @ begin dup vlink>voc ( #threads cells - ) ['] (words) catch if cr ." Interrupted!" drop TRUE \ stop now else @ dup 0= then until drop else context @ ['] (words) catch if drop cr ." Interrupted!" then then 0 to with-address? base @ >r decimal cr horizontal-line ." Displayed " words-cnt . ." of the " count-words . ." words in the system." cr ." ** Use: WORDS <substring> to limit the list **" cr ." ** Use: CONSTANTS <substring> to display Windows Constants **" cr ." See also .loaded .deferred .file .fonts .free and more" r> base ! ; EXTERNAL : WORDS ( -<optional_name>- ) \ WORDS partial-string will focus the list true to with-tabs? _words ; (( : on-allwords { theCFA \ vocBuf -- } 512 cells LocalAlloc: vocBuf voc-link @ begin dup vlink>voc dup voc#threads >r dup voc>vcfa @ 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 while dup l>name theCFA execute @ swap ! repeat 2drop else drop then r>drop @ dup 0= until drop ; )) in-application MODULE \ end of the module |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X