2005-07-06 01:28:45 -04:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: inspector
|
|
|
|
USING: generic hashtables io kernel kernel-internals lists math
|
2005-07-24 23:09:43 -04:00
|
|
|
memory namespaces prettyprint sequences strings styles test
|
|
|
|
unparser vectors words ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
|
|
|
SYMBOL: inspecting
|
|
|
|
|
|
|
|
GENERIC: sheet ( obj -- sheet )
|
|
|
|
|
2005-07-25 17:13:35 -04:00
|
|
|
M: object sheet ( obj -- sheet )
|
2005-07-06 01:28:45 -04:00
|
|
|
dup class "slots" word-prop
|
|
|
|
[ second ] map
|
2005-07-25 17:13:35 -04:00
|
|
|
tuck [ execute ] map-with
|
|
|
|
2list ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
2005-08-21 14:40:12 -04:00
|
|
|
M: list sheet unit ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
2005-07-24 23:09:43 -04:00
|
|
|
M: vector sheet unit ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
2005-07-24 23:09:43 -04:00
|
|
|
M: array sheet unit ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
M: hashtable sheet dup hash-keys swap hash-values 2list ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
2005-07-30 22:14:34 -04:00
|
|
|
: format-column ( list -- list )
|
2005-08-21 14:40:12 -04:00
|
|
|
[ pprint>short-string ] map
|
2005-07-26 16:39:14 -04:00
|
|
|
[ max-length ] keep
|
2005-07-06 01:28:45 -04:00
|
|
|
[ swap CHAR: \s pad-right ] map-with ;
|
|
|
|
|
2005-07-24 23:09:43 -04:00
|
|
|
: format-sheet ( sheet -- list )
|
2005-07-25 17:13:35 -04:00
|
|
|
dup first length >vector swons
|
2005-07-24 22:59:23 -04:00
|
|
|
dup peek over first [ set ] 2each
|
2005-07-30 22:14:34 -04:00
|
|
|
[ format-column ] map
|
2005-07-30 02:08:59 -04:00
|
|
|
flip
|
2005-07-06 03:29:42 -04:00
|
|
|
[ " | " join ] map ;
|
|
|
|
|
2005-07-06 01:56:01 -04:00
|
|
|
: vocab-banner ( word -- )
|
|
|
|
dup word-vocabulary [
|
|
|
|
dup interned? [
|
|
|
|
"This word is located in the " write
|
|
|
|
] [
|
|
|
|
"This is an orphan not part of the dictionary." print
|
|
|
|
"It claims to belong to the " write
|
|
|
|
] ifte
|
2005-08-21 14:40:12 -04:00
|
|
|
word-vocabulary pprint " vocabulary." print
|
2005-07-06 01:56:01 -04:00
|
|
|
] [
|
|
|
|
drop
|
|
|
|
"The word is a uniquely generated symbol." print
|
|
|
|
] ifte ;
|
|
|
|
|
2005-07-06 03:29:42 -04:00
|
|
|
GENERIC: extra-banner ( obj -- )
|
|
|
|
|
2005-07-06 01:56:01 -04:00
|
|
|
M: word extra-banner ( obj -- )
|
2005-07-24 22:44:33 -04:00
|
|
|
dup vocab-banner
|
|
|
|
metaclass [
|
|
|
|
"This is a class whose behavior is specifed by the " write
|
2005-08-21 01:17:37 -04:00
|
|
|
pprint " metaclass." print
|
2005-07-24 22:44:33 -04:00
|
|
|
] when* ;
|
2005-07-06 01:56:01 -04:00
|
|
|
|
|
|
|
M: object extra-banner ( obj -- ) drop ;
|
|
|
|
|
2005-07-06 01:28:45 -04:00
|
|
|
: inspect-banner ( obj -- )
|
2005-08-21 01:17:37 -04:00
|
|
|
"You are looking at an instance of the " write dup class pprint
|
2005-07-13 22:51:43 -04:00
|
|
|
" class:" print
|
2005-08-21 14:40:12 -04:00
|
|
|
" " write dup pprint-short terpri
|
2005-08-21 01:17:37 -04:00
|
|
|
"It takes up " write dup size pprint " bytes of memory." print
|
2005-07-24 22:44:33 -04:00
|
|
|
extra-banner ;
|
2005-07-06 01:28:45 -04:00
|
|
|
|
2005-07-24 23:09:43 -04:00
|
|
|
: describe ( obj -- )
|
|
|
|
sheet dup format-sheet
|
|
|
|
swap peek [ presented swons unit ] map
|
|
|
|
[ format terpri ] 2each ;
|
|
|
|
|
2005-07-06 01:28:45 -04:00
|
|
|
: inspect ( obj -- )
|
2005-07-24 23:09:43 -04:00
|
|
|
dup inspecting set dup inspect-banner describe ;
|
2005-08-11 19:08:22 -04:00
|
|
|
|
|
|
|
: go ( n -- ) get inspect ;
|