improved inspector with slot links

cvs
Slava Pestov 2005-07-25 03:09:43 +00:00
parent b0ecd948ce
commit a7e713764f
2 changed files with 15 additions and 11 deletions

View File

@ -2,8 +2,8 @@
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: inspector IN: inspector
USING: generic hashtables io kernel kernel-internals lists math USING: generic hashtables io kernel kernel-internals lists math
memory namespaces prettyprint sequences strings test unparser memory namespaces prettyprint sequences strings styles test
vectors words ; unparser vectors words ;
SYMBOL: inspecting SYMBOL: inspecting
@ -16,11 +16,11 @@ M: object sheet ( obj -- sheet )
PREDICATE: list nonvoid cons? ; PREDICATE: list nonvoid cons? ;
M: nonvoid sheet >list unit ; M: nonvoid sheet unit ;
M: vector sheet >list unit ; M: vector sheet unit ;
M: array sheet >list unit ; M: array sheet unit ;
M: hashtable sheet hash>alist unzip 2list ; M: hashtable sheet hash>alist unzip 2list ;
@ -29,8 +29,8 @@ M: hashtable sheet hash>alist unzip 2list ;
[ [ length ] map 0 [ max ] reduce ] keep [ [ length ] map 0 [ max ] reduce ] keep
[ swap CHAR: \s pad-right ] map-with ; [ swap CHAR: \s pad-right ] map-with ;
: describe ( obj -- list ) : format-sheet ( sheet -- list )
sheet dup first length count swons dup first length count swons
dup peek over first [ set ] 2each dup peek over first [ set ] 2each
[ column ] map [ column ] map
seq-transpose seq-transpose
@ -68,6 +68,10 @@ M: object extra-banner ( obj -- ) drop ;
"It takes up " write dup size unparse write " bytes of memory." print "It takes up " write dup size unparse write " bytes of memory." print
extra-banner ; extra-banner ;
: describe ( obj -- )
sheet dup format-sheet
swap peek [ presented swons unit ] map
[ format terpri ] 2each ;
: inspect ( obj -- ) : inspect ( obj -- )
dup inspecting set dup inspecting set dup inspect-banner describe ;
dup inspect-banner describe [ print ] each ;

View File

@ -22,8 +22,8 @@ TUPLE: pack align fill vector ;
: pref-dims ( gadget -- list ) : pref-dims ( gadget -- list )
gadget-children [ pref-dim ] map ; gadget-children [ pref-dim ] map ;
: orient ( gadget list1 list2 -- list ) : orient ( gadget seq1 seq2 -- seq )
zip >r pack-vector r> [ uncons rot set-axis ] map-with ; >r >r pack-vector r> r> [ pick set-axis ] 2map nip ;
: packed-dim-2 ( gadget sizes -- list ) : packed-dim-2 ( gadget sizes -- list )
[ [